paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-08 22:47:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r29407 into '.':

Browse Source 
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 -
This commit is contained in:
marco 2015-01-13 12:00:00 +00:00
parent 54a3e7c4a1
commit 12aee0aaf5
7 changed files with 584 additions and 261 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/m68k/cpubase.pas
View File

@ -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;

2
packages/ami-extra/src/cliputils.pas
View File

@ -121,7 +121,7 @@ begin
end;
begin
{$IF DEFINED(MORPHOS) OR DEFINED(AMIGA)}
{$IF DEFINED(MORPHOS)}
InitIFFParseLibrary;
{$ENDIF}
end.

11
rtl/os2/doscall2.pas
View File

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

13
rtl/os2/doscalls.pas
View File

@ -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

20
rtl/os2/sysos.inc
View File

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

20
rtl/os2/system.pas
View File

@ -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}

772
rtl/os2/sysucode.inc
View File

@ -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;