diff --git a/compiler/m68k/cpubase.pas b/compiler/m68k/cpubase.pas index 4f40c6b987..021e7d32fd 100644 --- a/compiler/m68k/cpubase.pas +++ b/compiler/m68k/cpubase.pas @@ -153,7 +153,7 @@ unit cpubase; { registers which may be destroyed by calls } VOLATILE_INTREGISTERS = [RS_D0,RS_D1]; - VOLATILE_FPUREGISTERS = []; + VOLATILE_FPUREGISTERS = [RS_FP0,RS_FP1]; VOLATILE_ADDRESSREGISTERS = [RS_A0,RS_A1]; type @@ -311,6 +311,7 @@ unit cpubase; } saved_standard_registers : array[0..5] of tsuperregister = (RS_D2,RS_D3,RS_D4,RS_D5,RS_D6,RS_D7); saved_address_registers : array[0..4] of tsuperregister = (RS_A2,RS_A3,RS_A4,RS_A5,RS_A6); + saved_fpu_registers : array[0..5] of tsuperregister = (RS_FP2,RS_FP3,RS_FP4,RS_FP5,RS_FP6,RS_FP7); { this is only for the generic code which is not used for this architecture } saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID); @@ -471,7 +472,9 @@ implementation R_INTREGISTER : result:=OS_32; R_FPUREGISTER : - result:=OS_F64; + { 68881 & compatibles -> 80 bit } + { CF FPU -> 64 bit, but that's unsupported for now } + result:=OS_F80; else internalerror(200303181); end; diff --git a/packages/ami-extra/src/cliputils.pas b/packages/ami-extra/src/cliputils.pas index 25b171aa60..d779843257 100644 --- a/packages/ami-extra/src/cliputils.pas +++ b/packages/ami-extra/src/cliputils.pas @@ -121,7 +121,7 @@ begin end; begin -{$IF DEFINED(MORPHOS) OR DEFINED(AMIGA)} +{$IF DEFINED(MORPHOS)} InitIFFParseLibrary; {$ENDIF} end. diff --git a/rtl/os2/doscall2.pas b/rtl/os2/doscall2.pas index a07544c486..feb0be6220 100644 --- a/rtl/os2/doscall2.pas +++ b/rtl/os2/doscall2.pas @@ -2181,6 +2181,17 @@ DosAcquireSpinLock = DOSCALLS.450 - might be simulated using semaphores on no DosReleaseSpinLock = DOSCALLS.451 - might be simulated using semaphores on non-SMP DosFreeSpinLock = DOSCALLS.452 - might be simulated using semaphores on non-SMP +type + TSpinLock = cardinal; + HSpinLock = TSpinLock; + PSpinLock = ^TSpinLock; + PHSpinLock = PSpinLock; + +function DosCreateSpinLock (var SpinLock: TSpinLock): cardinal; cdecl; +procedure DosAcquireSpinLock (SpinLock: TSpinLock); cdecl; +procedure DosReleaseSpinLock (SpinLock: TSpinLock); cdecl; +function DosFreeSpinLock (SpinLock: TSpinLock): cardinal; cdecl; + DosQueryModFromEIP - may be simulated by returning empty value if not available or possibly by using data returned by DosQuerySysState (if they are equal across different OS/2 versions?) ___ function Dos16QueryModFromCS (...): ... diff --git a/rtl/os2/doscalls.pas b/rtl/os2/doscalls.pas index 7bc9d91cd5..e5bb10cc01 100644 --- a/rtl/os2/doscalls.pas +++ b/rtl/os2/doscalls.pas @@ -5706,7 +5706,20 @@ external 'DOSCALLS' index 358; functionDosGetProcessorStatus (...): cardinal; cdecl; external 'DOSCALLS' index 447; + DosSetProcessorStatus = DOSCALLS.448 + +type + TSpinLock = cardinal; + HSpinLock = TSpinLock; + PSpinLock = ^TSpinLock; + PHSpinLock = PSpinLock; + +function DosCreateSpinLock (var SpinLock: TSpinLock): cardinal; cdecl; +procedure DosAcquireSpinLock (SpinLock: TSpinLock); cdecl; +procedure DosReleaseSpinLock (SpinLock: TSpinLock); cdecl; +function DosFreeSpinLock (SpinLock: TSpinLock): cardinal; cdecl; + DosCreateSpinLock = DOSCALLS.449 DosAcquireSpinLock = DOSCALLS.450 DosReleaseSpinLock = DOSCALLS.451 diff --git a/rtl/os2/sysos.inc b/rtl/os2/sysos.inc index 6f448610c4..29fc811164 100644 --- a/rtl/os2/sysos.inc +++ b/rtl/os2/sysos.inc @@ -431,3 +431,23 @@ external 'DOSCALLS' index 291; function DosSetProcessCP (CP: cardinal): cardinal; cdecl; external 'DOSCALLS' index 289; + +type + TCountryCode = record + Country, {Country to query info about (0=current).} + CodePage: cardinal; {Code page to query info about (0=current).} + end; + +function DosMapCase (Size: cardinal; var Country: TCountryCode; + AString: PChar): cardinal; cdecl; +external 'NLS' index 7; + +function DosQueryDBCSEnv (Size: cardinal; var Country: TCountryCode; + Buf: PChar): cardinal; cdecl; +external 'NLS' index 6; + +{ +function DosQueryCollate (Size: cardinal; var Country: TCountryCode; + Buf: PByteArray; var TableLen: cardinal): cardinal; cdecl; +external 'NLS' index 8; +} diff --git a/rtl/os2/system.pas b/rtl/os2/system.pas index d771d6eb8f..9557b374d1 100644 --- a/rtl/os2/system.pas +++ b/rtl/os2/system.pas @@ -55,6 +55,7 @@ const type TOS = (osDOS, osOS2, osDPMI); (* For compatibility with target EMX *) TUConvObject = pointer; + TLocaleObject = pointer; const OS_Mode: TOS = osOS2; (* For compatibility with target EMX *) @@ -185,6 +186,19 @@ type var InBytesLeft: longint; var UcsBuf: PWideChar; var UniCharsLeft: longint; var NonIdentical: longint): longint; cdecl; + TUniToLower = function (UniCharIn: WideChar): WideChar; cdecl; + + TUniToUpper = function (UniCharIn: WideChar): WideChar; cdecl; + + TUniStrColl = function (Locale_Object: TLocaleObject; + const UCS1, UCS2: PWideChar): longint; cdecl; + + TUniCreateLocaleObject = function (LocaleSpecType: longint; + const LocaleSpec: pointer; + var Locale_Object: TLocaleObject): longint; cdecl; + + TUniFreeLocaleObject = function (Locale_Object: TLocaleObject): longint; + cdecl; const @@ -205,6 +219,12 @@ var Sys_UniMapCpToUcsCp: TUniMapCpToUcsCp; Sys_UniUConvFromUcs: TUniUConvFromUcs; Sys_UniUConvToUcs: TUniUConvToUcs; + Sys_UniToLower: TUniToLower; + Sys_UniToUpper: TUniToUpper; + Sys_UniStrColl: TUniStrColl; + Sys_UniCreateLocaleObject: TUniCreateLocaleObject; + Sys_UniFreeLocaleObject: TUniFreeLocaleObject; + {$ENDIF OS2UNICODE} diff --git a/rtl/os2/sysucode.inc b/rtl/os2/sysucode.inc index cfd6739fc1..cf6e7a0a22 100644 --- a/rtl/os2/sysucode.inc +++ b/rtl/os2/sysucode.inc @@ -1,7 +1,7 @@ { This file is part of the Free Pascal run time library. - Copyright (c) 2014 by Tomas Hajny, - member of the Free Pascal development team. + Copyright (c) 2014-2015 by Tomas Hajny and other members + of the Free Pascal development team. OS/2 UnicodeStrings support @@ -29,6 +29,7 @@ const CpxSpecial = 1; CpxMappingOnly = 2; Uls_Success = 0; + Uls_API_Error_Base = $20400; Uls_Other = $20401; Uls_IllegalSequence = $20402; Uls_MaxFilesPerProc = $20403; @@ -65,6 +66,89 @@ const Ord_UniMalloc = 13; Ord_UniFree = 14; LibUniName: array [0..6] of char = 'LIBUNI'#0; + OrdUniQueryXdigit = 1; + OrdUniQuerySpace = 2; + OrdUniQueryPrint = 3; + OrdUniQueryGraph = 4; + OrdUniQueryCntrl = 5; + OrdUniQueryAlpha = 6; + OrdUniFreeAttrObject = 7; + OrdUniQueryCharAttr = 8; + OrdUniQueryUpper = 9; + OrdUniQueryPunct = 10; + OrdUniQueryLower = 11; + OrdUniQueryDigit = 12; + OrdUniQueryBlank = 13; + OrdUniQueryAlnum = 14; + OrdUniScanForAttr = 15; + OrdUniCreateAttrObject = 16; + OrdUniCreateTransformObject = 17; + OrdUniFreeTransformObject = 18; + OrdUniQueryLocaleObject = 19; + OrdUniCreateLocaleObject = 20; + OrdUniFreeLocaleObject = 21; + OrdUniFreeMem = 22; + OrdUniFreeLocaleInfo = 28; + OrdUniQueryLocaleInfo = 29; + OrdUniQueryLocaleItem = 30; + OrdUniStrcat = 31; + OrdUniStrchr = 32; + OrdUniStrcmp = 33; + OrdUniStrcmpi = 34; + OrdUniStrColl = 35; + OrdUniStrcpy = 36; + OrdUniStrcspn = 37; + OrdUniStrfmon = 38; + OrdUniStrftime = 39; + OrdUniStrlen = 40; + OrdUniStrncat = 41; + OrdUniStrncmp = 42; + OrdUniStrncmpi = 43; + OrdUniStrncpy = 44; + OrdUniStrpbrk = 45; + OrdUniStrptime = 46; + OrdUniStrrchr = 47; + OrdUniStrspn = 48; + OrdUniStrstr = 49; + OrdUniStrtod = 50; + OrdUniStrtol = 51; + OrdUniStrtoul = 52; + OrdUniStrxfrm = 53; + OrdUniLocaleStrToToken = 54; + OrdUniLocaleTokenToStr = 55; + OrdUniTransformStr = 56; + OrdUniTransLower = 57; + OrdUniTransUpper = 58; + OrdUniTolower = 59; + OrdUniToupper = 60; + OrdUniStrupr = 61; + OrdUniStrlwr = 62; + OrdUniStrtok = 63; + OrdUniMapCtryToLocale = 67; + OrdUniMakeKey = 70; + OrdUniQueryChar = 71; + OrdUniGetOverride = 72; + OrdUniGetColval = 73; + OrdUniQueryAttr = 74; + OrdUniQueryStringType = 75; + OrdUniQueryCharType = 76; + OrdUniQueryNumericValue = 77; + OrdUniQueryCharTypeTable = 78; + OrdUniProcessUconv = 80; + OrdLocale = 151; + OrdUniMakeUserLocale = 152; + OrdUniSetUserLocaleItem = 153; + OrdUniDeleteUserLocale = 154; + OrdUniCompleteUserLocale = 155; + OrdUniQueryLocaleValue = 156; + OrdUniQueryLocaleList = 157; + OrdUniQueryLanguageName = 158; + OrdUniQueryCountryName = 159; + Uni_Token_Pointer = 1; + Uni_MBS_String_Pointer = 2; + Uni_UCS_String_Pointer = 3; + Uni_System_Locales = 1; + Uni_User_Locales = 2; WNull: WideChar = #0; @@ -80,7 +164,6 @@ type UConvObj: TUConvObject; end; TCpXList = array [1..MaxCPMapping] of TCpRec; - TLocaleObject = pointer; TDummyUConvObject = record CP: cardinal; CPNameLen: byte; @@ -88,11 +171,68 @@ type end; PDummyUConvObject = ^TDummyUConvObject; + +var + DBCSLeadRanges: array [0..11] of char; + + const DefCpRec: TCpRec = (WinCP: 0; OS2CP: 0; UConvObj: nil); + InInitDefaultCP: int64 = -1; (* Range is bigger than TThreadID to avoid conflict *) + DefLocObj: TLocaleObject = nil; IBMPrefix: packed array [1..4] of WideChar = 'IBM-'; CachedDefFSCodepage: TSystemCodepage = 0; - + EmptyCC: TCountryCode = (Country: 0; Codepage: 0); (* Empty = current *) + (* 819 = IBM codepage number for ISO 8859-1 used in FPC default *) + (* dummy translation between UnicodeString and AnsiString. *) + IsoCC: TCountryCode = (Country: 1; Codepage: 819); (* Empty = current *) + (* The following two arrays are initialized on startup in case that *) + (* Dummy* routines must be used. First for current codepage... *) + DBCSLeadRangesEnd: byte = 0; + LowerChars: array [char] of char = + (#0, #1, #2, #3, #4, #5, #6, #7, #8, #9, #10, #11, #12, #13, #14, #15, #16, + #17, #18, #19, #20, #21, #22, #23, #24, #25, #26, #27, #28, #29, #30, #31, + #32, #33, #34, #35, #36, #37, #38, #39, #40, #41, #42, #43, #44, #45, #46, + #47, #48, #49, #50, #51, #52, #53, #54, #55, #56, #57, #58, #59, #60, #61, + #62, #63, #64, #65, #66, #67, #68, #69, #70, #71, #72, #73, #74, #75, #76, + #77, #78, #79, #80, #81, #82, #83, #84, #85, #86, #87, #88, #89, #90, #91, + #92, #93, #94, #95, #96, #97, #98, #99, #100, #101, #102, #103, #104, #105, + #106, #107, #108, #109, #110, #111, #112, #113, #114, #115, #116, #117, + #118, #119, #120, #121, #122, #123, #124, #125, #126, #127, #128, #129, + #130, #131, #132, #133, #134, #135, #136, #137, #138, #139, #140, #141, + #142, #143, #144, #145, #146, #147, #148, #149, #150, #151, #152, #153, + #154, #155, #156, #157, #158, #159, #160, #161, #162, #163, #164, #165, + #166, #167, #168, #169, #170, #171, #172, #173, #174, #175, #176, #177, + #178, #179, #180, #181, #182, #183, #184, #185, #186, #187, #188, #189, + #190, #191, #192, #193, #194, #195, #196, #197, #198, #199, #200, #201, + #202, #203, #204, #205, #206, #207, #208, #209, #210, #211, #212, #213, + #214, #215, #216, #217, #218, #219, #220, #221, #222, #223, #224, #225, + #226, #227, #228, #229, #230, #231, #232, #233, #234, #235, #236, #237, + #238, #239, #240, #241, #242, #243, #244, #245, #246, #247, #248, #249, + #250, #251, #252, #253, #254, #255); + (* ...and now for ISO 8859-1 aka IBM codepage 819 *) + LowerCharsISO88591: array [char] of char = + (#0, #1, #2, #3, #4, #5, #6, #7, #8, #9, #10, #11, #12, #13, #14, #15, #16, + #17, #18, #19, #20, #21, #22, #23, #24, #25, #26, #27, #28, #29, #30, #31, + #32, #33, #34, #35, #36, #37, #38, #39, #40, #41, #42, #43, #44, #45, #46, + #47, #48, #49, #50, #51, #52, #53, #54, #55, #56, #57, #58, #59, #60, #61, + #62, #63, #64, #65, #66, #67, #68, #69, #70, #71, #72, #73, #74, #75, #76, + #77, #78, #79, #80, #81, #82, #83, #84, #85, #86, #87, #88, #89, #90, #91, + #92, #93, #94, #95, #96, #97, #98, #99, #100, #101, #102, #103, #104, #105, + #106, #107, #108, #109, #110, #111, #112, #113, #114, #115, #116, #117, + #118, #119, #120, #121, #122, #123, #124, #125, #126, #127, #128, #129, + #130, #131, #132, #133, #134, #135, #136, #137, #138, #139, #140, #141, + #142, #143, #144, #145, #146, #147, #148, #149, #150, #151, #152, #153, + #154, #155, #156, #157, #158, #159, #160, #161, #162, #163, #164, #165, + #166, #167, #168, #169, #170, #171, #172, #173, #174, #175, #176, #177, + #178, #179, #180, #181, #182, #183, #184, #185, #186, #187, #188, #189, + #190, #191, #192, #193, #194, #195, #196, #197, #198, #199, #200, #201, + #202, #203, #204, #205, #206, #207, #208, #209, #210, #211, #212, #213, + #214, #215, #216, #217, #218, #219, #220, #221, #222, #223, #224, #225, + #226, #227, #228, #229, #230, #231, #232, #233, #234, #235, #236, #237, + #238, #239, #240, #241, #242, #243, #244, #245, #246, #247, #248, #249, + #250, #251, #252, #253, #254, #255); + NoIso88591Support: boolean = false; threadvar (* Temporary allocations may be performed in parallel in different threads *) @@ -319,6 +459,121 @@ begin end; +procedure InitDBCSLeadRanges; +var + RC: cardinal; +begin + RC := DosQueryDBCSEnv (SizeOf (DBCSLeadRanges), EmptyCC, + @DBCSLeadRanges [0]); + DBCSLeadRangesEnd := 0; + if RC <> 0 then + while (DBCSLeadRangesEnd < SizeOf (DBCSLeadRanges)) and + ((DBCSLeadRanges [DBCSLeadRangesEnd] <> #0) or + (DBCSLeadRanges [Succ (DBCSLeadRangesEnd)] <> #0)) do + Inc (DBCSLeadRangesEnd, 2); +end; + +procedure InitDummyLowercase; +var + C: char; + AllChars: array [char] of char; +begin + Move (LowerChars, AllChars, SizeOf (AllChars)); + if DosMapCase (SizeOf (AllChars), IsoCC, @AllChars [#0]) <> 0 then +(* Codepage 819 may not be supported in all old OS/2 versions. *) + begin + Move (LowerCharsIso88591, AllChars, SizeOf (AllChars)); + DosMapCase (SizeOf (AllChars), EmptyCC, @AllChars [#0]); + NoIso88591Support := true; + end; + for C := Low (char) to High (char) do + if AllChars [C] <> C then + LowerCharsIso88591 [AllChars [C]] := C; + if NoIso88591Support then + Move (LowerCharsIso88591, LowerChars, SizeOf (LowerChars)) + else + begin + Move (LowerChars, AllChars, SizeOf (AllChars)); + DosMapCase (SizeOf (AllChars), EmptyCC, @AllChars [#0]); + for C := Low (char) to High (char) do + if AllChars [C] <> C then + LowerChars [AllChars [C]] := C; + end; + InitDBCSLeadRanges; +end; + + +procedure ReInitDummyLowercase; +var + C: char; + AllChars: array [char] of char; +begin + for C := Low (char) to High (char) do + AllChars [C] := C; + DosMapCase (SizeOf (AllChars), EmptyCC, @AllChars [#0]); + for C := Low (char) to High (char) do + if AllChars [C] <> C then + LowerChars [AllChars [C]] := C; + InitDBCSLeadRanges; +end; + + +function DummyUniToLower (UniCharIn: WideChar): WideChar; cdecl; +var + C: char; +begin + C := UniCharIn; + DummyUniToLower := LowerCharsIso88591 [C]; +end; + + +function DummyUniToUpper (UniCharIn: WideChar): WideChar; cdecl; +var + C: char; +begin + DummyUniToUpper := UniCharIn; + C := UniCharIn; + if NoIso88591Support then + begin + if DosMapCase (1, EmptyCC, @C) = 0 then + DummyUniToUpper := C; + end + else + if DosMapCase (1, IsoCC, @C) = 0 then + DummyUniToUpper := C +end; + + +function DummyUniStrColl (Locale_Object: TLocaleObject; + const UCS1, UCS2: PWideChar): longint; cdecl; +var + S1, S2: ansistring; +begin + S1 := UCS1; + S2 := UCS2; + if S1 = S2 then + DummyUniStrColl := 0 + else if S1 < S2 then + DummyUniStrColl := -1 + else + DummyUniStrColl := 1; +end; + + +function DummyUniCreateLocaleObject (LocaleSpecType: longint; + const LocaleSpec: pointer; var Locale_Object: TLocaleObject): longint; cdecl; +begin + DummyUniCreateLocaleObject := ULS_Unsupported; +end; + + +function DummyUniFreeLocaleObject (Locale_Object: TLocaleObject): longint; + cdecl; +begin + DummyUniFreeLocaleObject := ULS_BadObject; +end; + + const CpXList: TCpXList = ( @@ -437,11 +692,23 @@ var CPArr: TCPArray; ReturnedSize: cardinal; begin + if InInitDefaultCP <> -1 then + begin + repeat + DosSleep (5); + until InInitDefaultCP <> -1; + Exit; + end; + InInitDefaultCP := ThreadID; if DefCpRec.UConvObj <> nil then begin +(* Do not free the UConv object from DefCpRec, because it is also stored in + the respective CPXList record! *) +{ RCI := Sys_UniFreeUConvObject (DefCpRec.UConvObj); if RCI <> 0 then OSErrorWatch (cardinal (RCI)); +} DefCpRec.UConvObj := nil; end; RC := DosQueryCP (SizeOf (CPArr), @CPArr, ReturnedSize); @@ -452,7 +719,7 @@ begin end else if (ReturnedSize < 4) then CPArr [0] := 850; - DefaultFileSystemCodePage := OS2CPtoRtlCP (CPArr [0], cpxMappingOnly, + DefaultFileSystemCodePage := OS2CPtoRtlCP (CPArr [0], cpxAll, DefCpRec.UConvObj); CachedDefFSCodepage := DefaultFileSystemCodePage; DefCpRec.OS2CP := CPArr [0]; @@ -464,6 +731,19 @@ begin DefCpRec.WinCP := CpXList [I].WinCP else DefCpRec.WinCP := CPArr [0]; + + if DefLocObj <> nil then + begin + RCI := Sys_UniFreeLocaleObject (DefLocObj); + if RCI <> 0 then + OSErrorWatch (cardinal (RCI)); + end; + RCI := Sys_UniCreateLocaleObject (Uni_UCS_String_Pointer, @WNull, DefLocObj); + if RCI <> 0 then + OSErrorWatch (cardinal (RCI)); + if not (UniAPI) then + ReInitDummyLowercase; + InInitDefaultCP := -1; end; @@ -494,9 +774,16 @@ begin ReqFlags := ReqFlags or CpxMappingOnly; if CheckDefaultOS2CP then Exit; - if CachedDefFSCodepage <> DefaultFileSystemCodePage then + if (CachedDefFSCodepage <> DefaultFileSystemCodePage) and + (InInitDefaultCP <> ThreadID) then +(* InInitDefaultCP = ThreadID -> this thread is already re-initializing the cached information *) begin - InitDefaultCP; + if InInitDefaultCP <> -1 then + repeat + DosSleep (5) (* Let's wait until the other thread finishes re-initialization of the cache *) + until InInitDefaultCP = -1 + else + InitDefaultCP; if CheckDefaultOS2CP then Exit; end; @@ -518,8 +805,7 @@ begin begin if CpXList [I].UConvObj = nil then begin - if UConvObjectForCP (CpXList [I].OS2CP, UConvObj) = Uls_Success - then + if UConvObjectForCP (CpXList [I].OS2CP, UConvObj) = Uls_Success then CpXList [I].UConvObj := UConvObj else UConvObj := nil; @@ -589,9 +875,17 @@ begin Exit else begin - if CachedDefFSCodepage <> DefaultFileSystemCodePage then + if (CachedDefFSCodepage <> DefaultFileSystemCodePage) and + (InInitDefaultCP <> ThreadID) then +(* InInitDefaultCP = ThreadID -> this thread is already re-initializing the cached information *) begin - InitDefaultCP; + if InInitDefaultCP <> -1 then + repeat +(* Let's wait until the other thread finishes re-initialization of the cache *) + DosSleep (5) + until InInitDefaultCP = -1 + else + InitDefaultCP; if CheckDefaultWinCP then Exit; end; @@ -739,6 +1033,7 @@ begin until false; end; + procedure OS2Ansi2UnicodeMove (Source: PChar; CP: TSystemCodePage; var Dest: UnicodeString; Len: SizeInt); var @@ -804,10 +1099,6 @@ begin RCI := Sys_UniUConvToUcs (UConvObj, Src2, Len2, Dest2, LenOut, NonIdentical); until false; - -{??? - PUnicodeRec(pointer(dest)-UnicodeFirstOff)^.CodePage:=CP_UTF16; -} end; @@ -831,9 +1122,13 @@ begin begin if DefCpRec.UConvObj <> nil then begin +(* Do not free the UConv object from DefCpRec, because it is also stored in + the respective CpXList record! *) +{ RCI := Sys_UniFreeUConvObject (DefCpRec.UConvObj); if RCI <> 0 then OSErrorWatch (cardinal (RCI)); +} DefCpRec.UConvObj := nil; end; DefCPRec.OS2CP := OS2CP; @@ -852,49 +1147,152 @@ begin end; end; + +function OS2UpperUnicodeString (const S: UnicodeString): UnicodeString; +var + I: cardinal; +begin + SetLength (Result, Length (S)); + for I := 0 to Pred (Length (S)) do + PWideChar (Result) [I] := Sys_UniToUpper (S [Succ (I)]); +end; + + +function OS2LowerUnicodeString (const S: UnicodeString): UnicodeString; +var + I: cardinal; +begin + SetLength (Result, Length (S)); + for I := 0 to Pred (Length (S)) do + PWideChar (Result) [I] := Sys_UniToLower (S [Succ (I)]); +end; + + +function NoNullsUnicodeString (const S: UnicodeString): UnicodeString; +var + I: cardinal; +begin + Result := S; + UniqueString (Result); + for I := 1 to Length (S) do + if Result [I] = WNull then + Result [I] := ' '; +end; + + +function OS2CompareUnicodeString (const S1, S2: UnicodeString): PtrInt; +var + HS1, HS2: UnicodeString; +begin + { UniStrColl interprets null chars as end-of-string -> filter out } + HS1 := NoNullsUnicodeString (S1); + HS2 := NoNullsUnicodeString (S2); + Result := Sys_UniStrColl (DefLocObj, PWideChar (HS1), PWideChar (HS2)); + if Result < -1 then + Result := -1 + else if Result > 1 then + Result := 1; +end; + + +function OS2CompareTextUnicodeString (const S1, S2: UnicodeString): PtrInt; +begin + Result := OS2CompareUnicodeString (OS2UpperUnicodeString (S1), + OS2UpperUnicodeString (S2)); +{$WARNING Language independent uppercase routine may not be appropriate for language dependent case insensitive comparison!} +end; + + +function OS2UpperAnsiString (const S: AnsiString): AnsiString; +var + RC: cardinal; +begin + Result := S; + UniqueString (Result); + FillChar (EmptyCC, SizeOf (EmptyCC), 0); + RC := DosMapCase (Length (Result), EmptyCC, PChar (Result)); +{ What to do in case of a failure??? } + if RC <> 0 then + Result := UpCase (S); { Use a fallback? } +end; + + +function OS2LowerAnsiString (const S: AnsiString): AnsiString; +var + I: PtrUInt; + + function IsDBCSLeadChar (C: char): boolean; + var + D: byte; + begin + IsDBCSLeadChar := false; + D := 0; + while D < DBCSLeadRangesEnd do + begin + if (C >= DBCSLeadRanges [D]) and (C <= DBCSLeadRanges [Succ (D)]) then + begin + IsDBCSLeadChar := true; + Exit; + end; + Inc (D, 2); + end; + end; + +begin +(* + OS/2 provides no direct solution for lowercase conversion of MBCS strings. + If Unicode support is available, using Unicode routines is the best solution. + If not, we use a translation table built at startup by translating the full + character set to uppercase and using that for creation of a lookup table + (as already done in sysutils). However, we need to check for DBCS (MBCS) + codepages and avoid translating the DBCS lead bytes and the following + character. +*) + if UniAPI then + Result := OS2LowerUnicodeString (S) +{ Two implicit conversions... ;-) } + else + begin + Result := S; + if Length (Result) > 0 then + begin + UniqueString (Result); + if DBCSLeadRangesEnd > 0 then + begin + I := 1; + while I <= Length (Result) do + begin + if IsDBCSLeadChar (Result [I]) then + Inc (I, 2) + else + begin + Result [I] := LowerChars [Result [I]]; + Inc (I); + end; + end; + end + else + for I := 1 to Length (Result) do + Result [I] := LowerChars [Result [I]]; + end; + end; +end; + + { -function Win32UnicodeUpper(const s : UnicodeString) : UnicodeString; - begin - result:=s; - UniqueString(result); - if length(result)>0 then - CharUpperBuff(LPWSTR(result),length(result)); - end; - - -function Win32UnicodeLower(const s : UnicodeString) : UnicodeString; - begin - result:=s; - UniqueString(result); - if length(result)>0 then - CharLowerBuff(LPWSTR(result),length(result)); - end; + CompareStrAnsiStringProc:=@CompareStrAnsiString; + CompareTextAnsiStringProc:=@AnsiCompareText; + StrCompAnsiStringProc:=@StrCompAnsi; + StrICompAnsiStringProc:=@AnsiStrIComp; + StrLCompAnsiStringProc:=@AnsiStrLComp; + StrLICompAnsiStringProc:=@AnsiStrLIComp; + StrLowerAnsiStringProc:=@AnsiStrLower; + StrUpperAnsiStringProc:=@AnsiStrUpper; } - (* CWSTRING: -function LowerWideString(const s : WideString) : WideString; - var - i : SizeInt; - begin - SetLength(result,length(s)); - for i:=0 to length(s)-1 do - pwidechar(result)[i]:=WideChar(towlower(wint_t(s[i+1]))); - end; - - -function UpperWideString(const s : WideString) : WideString; - var - i : SizeInt; - begin - SetLength(result,length(s)); - for i:=0 to length(s)-1 do - pwidechar(result)[i]:=WideChar(towupper(wint_t(s[i+1]))); - end; - - procedure EnsureAnsiLen(var S: AnsiString; const len: SizeInt); inline; begin if (len>length(s)) then @@ -947,185 +1345,14 @@ begin end; -function LowerAnsiString(const s : AnsiString) : AnsiString; - var - i, slen, - resindex : SizeInt; - mblen : size_t; -{$ifndef beos} - ombstate, - nmbstate : mbstate_t; -{$endif beos} - wc : wchar_t; - begin -{$ifndef beos} - fillchar(ombstate,sizeof(ombstate),0); - fillchar(nmbstate,sizeof(nmbstate),0); -{$endif beos} - slen:=length(s); - SetLength(result,slen+10); - i:=1; - resindex:=1; - while (i<=slen) do - begin - if (s[i]<=#127) then - begin - wc:=wchar_t(s[i]); - mblen:= 1; - end - else -{$ifndef beos} - mblen:=mbrtowc(@wc, pchar(@s[i]), slen-i+1, @ombstate); -{$else not beos} - mblen:=mbtowc(@wc, pchar(@s[i]), slen-i+1); -{$endif not beos} - case mblen of - size_t(-2): - begin - { partial invalid character, copy literally } - while (i<=slen) do - begin - ConcatCharToAnsiStr(s[i],result,resindex); - inc(i); - end; - end; - size_t(-1), 0: - begin - { invalid or null character } - ConcatCharToAnsiStr(s[i],result,resindex); - inc(i); - end; - else - begin - { a valid sequence } - { even if mblen = 1, the lowercase version may have a } - { different length } - { We can't do anything special if wchar_t is 16 bit... } -{$ifndef beos} - ConcatUTF32ToAnsiStr(towlower(wint_t(wc)),result,resindex,nmbstate); -{$else not beos} - ConcatUTF32ToAnsiStr(towlower(wint_t(wc)),result,resindex); -{$endif not beos} - inc(i,mblen); - end; - end; - end; - SetLength(result,resindex-1); - end; - - -function UpperAnsiString(const s : AnsiString) : AnsiString; - var - i, slen, - resindex : SizeInt; - mblen : size_t; -{$ifndef beos} - ombstate, - nmbstate : mbstate_t; -{$endif beos} - wc : wchar_t; - begin -{$ifndef beos} - fillchar(ombstate,sizeof(ombstate),0); - fillchar(nmbstate,sizeof(nmbstate),0); -{$endif beos} - slen:=length(s); - SetLength(result,slen+10); - i:=1; - resindex:=1; - while (i<=slen) do - begin - if (s[i]<=#127) then - begin - wc:=wchar_t(s[i]); - mblen:= 1; - end - else -{$ifndef beos} - mblen:=mbrtowc(@wc, pchar(@s[i]), slen-i+1, @ombstate); -{$else not beos} - mblen:=mbtowc(@wc, pchar(@s[i]), slen-i+1); -{$endif beos} - case mblen of - size_t(-2): - begin - { partial invalid character, copy literally } - while (i<=slen) do - begin - ConcatCharToAnsiStr(s[i],result,resindex); - inc(i); - end; - end; - size_t(-1), 0: - begin - { invalid or null character } - ConcatCharToAnsiStr(s[i],result,resindex); - inc(i); - end; - else - begin - { a valid sequence } - { even if mblen = 1, the uppercase version may have a } - { different length } - { We can't do anything special if wchar_t is 16 bit... } -{$ifndef beos} - ConcatUTF32ToAnsiStr(towupper(wint_t(wc)),result,resindex,nmbstate); -{$else not beos} - ConcatUTF32ToAnsiStr(towupper(wint_t(wc)),result,resindex); -{$endif not beos} - inc(i,mblen); - end; - end; - end; - SetLength(result,resindex-1); - end; function utf16toutf32(const S: WideString; const index: SizeInt; out len: longint): UCS4Char; external name 'FPC_UTF16TOUTF32'; -function WideStringToUCS4StringNoNulls(const s : WideString) : UCS4String; - var - i, slen, - destindex : SizeInt; - len : longint; - uch : UCS4Char; - begin - slen:=length(s); - setlength(result,slen+1); - i:=1; - destindex:=0; - while (i<=slen) do - begin - uch:=utf16toutf32(s,i,len); - if (uch=UCS4Char(0)) then - uch:=UCS4Char(32); - result[destindex]:=uch; - inc(destindex); - inc(i,len); - end; - result[destindex]:=UCS4Char(0); - { destindex <= slen } - setlength(result,destindex+1); - end; - - -function CompareWideString(const s1, s2 : WideString) : PtrInt; - var - hs1,hs2 : UCS4String; - begin - { wcscoll interprets null chars as end-of-string -> filter out } - hs1:=WideStringToUCS4StringNoNulls(s1); - hs2:=WideStringToUCS4StringNoNulls(s2); - result:=wcscoll(pwchar_t(hs1),pwchar_t(hs2)); - end; - - -function CompareTextWideString(const s1, s2 : WideString): PtrInt; - begin - result:=CompareWideString(UpperWideString(s1),UpperWideString(s2)); - end; - - +{ return value: number of code points in the string. Whenever an invalid + code point is encountered, all characters part of this invalid code point + are considered to form one "character" and the next character is + considered to be the start of a new (possibly also invalid) code point } function CharLengthPChar(const Str: PChar): PtrInt; var nextlen: ptrint; @@ -1141,14 +1368,14 @@ function CharLengthPChar(const Str: PChar): PtrInt; {$endif not beos} repeat {$ifdef beos} - nextlen:=ptrint(mblen(str,MB_CUR_MAX)); + nextlen:=ptrint(mblen(s,MB_CUR_MAX)); {$else beos} - nextlen:=ptrint(mbrlen(str,MB_CUR_MAX,@mbstate)); + nextlen:=ptrint(mbrlen(s,MB_CUR_MAX,@mbstate)); {$endif beos} { skip invalid/incomplete sequences } if (nextlen<0) then nextlen:=1; - inc(result,nextlen); + inc(result,1); inc(s,nextlen); until (nextlen=0); end; @@ -1363,7 +1590,42 @@ begin begin Sys_UniUConvToUcs := TUniUConvToUcs (P); - UniAPI := true; + RC := DosLoadModule (@ErrName [0], SizeOf (ErrName), + @LibUniName [0], LibUniHandle); + if RC = 0 then + begin + RC := DosQueryProcAddr (LibUniHandle, OrdUniToLower, nil, P); + if RC = 0 then + begin + Sys_UniToLower := TUniToLower (P); + RC := DosQueryProcAddr (LibUniHandle, OrdUniToUpper, nil, P); + if RC = 0 then + begin + Sys_UniToUpper := TUniToUpper (P); + RC := DosQueryProcAddr (LibUniHandle, OrdUniStrColl, nil, + P); + if RC = 0 then + begin + Sys_UniStrColl := TUniStrColl (P); + RC := DosQueryProcAddr (LibUniHandle, + OrdUniCreateLocaleObject, nil, P); + if RC = 0 then + begin + Sys_UniCreateLocaleObject := TUniCreateLocaleObject + (P); + RC := DosQueryProcAddr (LibUniHandle, + OrdUniFreeLocaleObject, nil, P); + if RC = 0 then + begin + Sys_UniFreeLocaleObject := TUniFreeLocaleObject (P); + + UniAPI := true; + end; + end; + end; + end; + end; + end; end; end; end; @@ -1379,52 +1641,46 @@ begin Sys_UniFreeUConvObject := @DummyUniFreeUConvObject; Sys_UniUConvFromUcs := @DummyUniUConvFromUcs; Sys_UniUConvToUcs := @DummyUniUConvToUcs; - + Sys_UniToLower := @DummyUniToLower; + Sys_UniToUpper := @DummyUniToUpper; + Sys_UniStrColl := @DummyUniStrColl; + Sys_UniCreateLocaleObject := @DummyUniCreateLocaleObject; + Sys_UniFreeLocaleObject := @DummyUniFreeLocaleObject; + InitDummyLowercase; end; { Widestring } WideStringManager.Wide2AnsiMoveProc := @OS2Unicode2AnsiMove; WideStringManager.Ansi2WideMoveProc := @OS2Ansi2UnicodeMove; -{ WideStringManager.UpperWideStringProc := @OS2UnicodeUpper; - WideStringManager.LowerWideStringProc := @OS2UnicodeLower;} + WideStringManager.UpperWideStringProc := @OS2UpperUnicodeString; + WideStringManager.LowerWideStringProc := @OS2LowerUnicodeString; + WideStringManager.CompareWideStringProc := @OS2CompareUnicodeString; + WideStringManager.CompareTextWideStringProc := @OS2CompareTextUnicodeString; { Unicode } WideStringManager.Unicode2AnsiMoveProc := @OS2Unicode2AnsiMove; WideStringManager.Ansi2UnicodeMoveProc := @OS2Ansi2UnicodeMove; -{ WideStringManager.UpperUnicodeStringProc := @OS2UnicodeUpper; - WideStringManager.LowerUnicodeStringProc := @OS2UnicodeLower;} + WideStringManager.UpperUnicodeStringProc := @OS2UpperUnicodeString; + WideStringManager.LowerUnicodeStringProc := @OS2LowerUnicodeString; + WideStringManager.CompareUnicodeStringProc := @OS2CompareUnicodeString; + WideStringManager.CompareTextUnicodeStringProc := + @OS2CompareTextUnicodeString; { Codepage } WideStringManager.GetStandardCodePageProc := @OS2GetStandardCodePage; (* - Wide2AnsiMoveProc:=@Wide2AnsiMove; - Ansi2WideMoveProc:=@Ansi2WideMove; - - UpperWideStringProc:=@UpperWideString; - LowerWideStringProc:=@LowerWideString; - - CompareWideStringProc:=@CompareWideString; - CompareTextWideStringProc:=@CompareTextWideString; - CharLengthPCharProc:=@CharLengthPChar; CodePointLengthProc:=@CodePointLength; +*) + WideStringManager.UpperAnsiStringProc := @OS2UpperAnsiString; + WideStringManager.LowerAnsiStringProc := @OS2LowerAnsiString; +(* + WideStringManager.CompareStrAnsiStringProc := @OS2CompareStrAnsiString; + WideStringManager.CompareTextAnsiStringProc := @OS2AnsiCompareTextAnsiString; - UpperAnsiStringProc:=@UpperAnsiString; - LowerAnsiStringProc:=@LowerAnsiString; - CompareStrAnsiStringProc:=@CompareStrAnsiString; - CompareTextAnsiStringProc:=@AnsiCompareText; StrCompAnsiStringProc:=@StrCompAnsi; StrICompAnsiStringProc:=@AnsiStrIComp; StrLCompAnsiStringProc:=@AnsiStrLComp; StrLICompAnsiStringProc:=@AnsiStrLIComp; StrLowerAnsiStringProc:=@AnsiStrLower; StrUpperAnsiStringProc:=@AnsiStrUpper; - ThreadInitProc:=@InitThread; - ThreadFiniProc:=@FiniThread; - { Unicode } - Unicode2AnsiMoveProc:=@Wide2AnsiMove; - Ansi2UnicodeMoveProc:=@Ansi2WideMove; - UpperUnicodeStringProc:=@UpperWideString; - LowerUnicodeStringProc:=@LowerWideString; - CompareUnicodeStringProc:=@CompareWideString; - CompareTextUnicodeStringProc:=@CompareTextWideString; *) end;