--- Merging r29407 into '.':

U    compiler/m68k/cpubase.pas
--- Merging r29428 into '.':
U    packages/ami-extra/src/cliputils.pas
--- Merging r29432 into '.':
U    rtl/os2/system.pas
U    rtl/os2/sysos.inc
U    rtl/os2/sysucode.inc
--- Merging r29433 into '.':
U    rtl/os2/doscall2.pas
U    rtl/os2/doscalls.pas
--- Merging r29441 into '.':
G    rtl/os2/sysucode.inc
--- Merging r29457 into '.':
G    rtl/os2/sysucode.inc
G    rtl/os2/sysos.inc

# revisions: 29407,29428,29432,29433,29441,29457

git-svn-id: branches/fixes_3_0@29461 -

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;

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.

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 (...): ...

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

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;
+}

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}
 
 

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,48 +1147,151 @@ begin
    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 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 Win32UnicodeLower(const s : UnicodeString) : UnicodeString;
-  begin
-    result:=s;
-    UniqueString(result);
-    if length(result)>0 then
-      CharLowerBuff(LPWSTR(result),length(result));
-  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;
 
-(*
-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 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 UpperWideString(const s : WideString) : WideString;
+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
-    i : SizeInt;
+    D: byte;
   begin
-    SetLength(result,length(s));
-    for i:=0 to length(s)-1 do
-      pwidechar(result)[i]:=WideChar(towupper(wint_t(s[i+1])));
+    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;
+
+      
+{
+      CompareStrAnsiStringProc:=@CompareStrAnsiString;
+      CompareTextAnsiStringProc:=@AnsiCompareText;
+      StrCompAnsiStringProc:=@StrCompAnsi;
+      StrICompAnsiStringProc:=@AnsiStrIComp;
+      StrLCompAnsiStringProc:=@AnsiStrLComp;
+      StrLICompAnsiStringProc:=@AnsiStrLIComp;
+      StrLowerAnsiStringProc:=@AnsiStrLower;
+      StrUpperAnsiStringProc:=@AnsiStrUpper;
+}
+
+(*
+CWSTRING:
 
 procedure EnsureAnsiLen(var S: AnsiString; const len: SizeInt); inline;
 begin
@@ -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;