paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-09 14:46:11 +02:00
Code Issues Packages Projects Releases Wiki Activity

merge r13488 from cpstrnew branch by florian except ncgcon.pas which has a difficult merge conflict (code moved to another unit which is not at the branch during the revision):

Browse Source 
* first batch of patches to make tcpstr1.pp work

git-svn-id: trunk@19085 -
This commit is contained in:
paul 2011-09-17 11:16:45 +00:00
parent 06af8f3e44
commit 8cc22972a0
8 changed files with 65 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/ncginl.pas
View File

@ -363,7 +363,7 @@ implementation
hregister:=cg.makeregsize(current_asmdata.CurrAsmList,left.location.register,OS_INT); hregister:=cg.makeregsize(current_asmdata.CurrAsmList,left.location.register,OS_INT);
cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,href,hregister); cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,href,hregister);
end; end;
if is_widestring(left.resultdef) or is_unicodestring(left.resultdef) then if is_widestring(left.resultdef) then
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,OS_INT,1,hregister); cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,OS_INT,1,hregister);
cg.a_label(current_asmdata.CurrAsmList,lengthlab); cg.a_label(current_asmdata.CurrAsmList,lengthlab);
location_reset(location,LOC_REGISTER,def_cgsize(resultdef)); location_reset(location,LOC_REGISTER,def_cgsize(resultdef));

47
rtl/inc/astrings.inc
View File

@ -73,7 +73,7 @@ begin
PAnsiRec(P)^.CodePage:=DefaultSystemCodePage; PAnsiRec(P)^.CodePage:=DefaultSystemCodePage;
PAnsiRec(P)^.ElementSize:=SizeOf(AnsiChar); PAnsiRec(P)^.ElementSize:=SizeOf(AnsiChar);
PAnsiRec(P)^.First:=#0; { Terminating #0 } PAnsiRec(P)^.First:=#0; { Terminating #0 }
inc(p,AnsiFirstOff); { Points to string now } inc(p,AnsiFirstOff); { Points to string now }
end; end;
NewAnsiString:=P; NewAnsiString:=P;
end; end;
@ -103,10 +103,12 @@ Var
l : pSizeInt; l : pSizeInt;
Begin Begin
{ Zero string } { Zero string }
If S=Nil then exit; If S=Nil then
exit;
{ check for constant strings ...} { check for constant strings ...}
l:=@PAnsiRec(S-AnsiFirstOff)^.Ref; l:=@PAnsiRec(S-AnsiFirstOff)^.Ref;
If l^<0 then exit; If l^<0 then
exit;
{ declocked does a MT safe dec and returns true, if the counter is 0 } { declocked does a MT safe dec and returns true, if the counter is 0 }
If declocked(l^) then If declocked(l^) then
{ Ref count dropped to zero } { Ref count dropped to zero }
@ -308,12 +310,9 @@ begin
end; end;
fpc_AnsiStr_Decr_Ref(destcopy); fpc_AnsiStr_Decr_Ref(destcopy);
end; end;
{$endif STR_CONCAT_PROCS} {$endif STR_CONCAT_PROCS}
{$ifdef EXTRAANSISHORT} {$ifdef EXTRAANSISHORT}
Procedure AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString); Procedure AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString);
{ {
@ -335,8 +334,7 @@ begin
end; end;
{$endif EXTRAANSISHORT} {$endif EXTRAANSISHORT}
Function fpc_AnsiStr_To_AnsiStr (const S : RawByteString;cp : TSystemCodePage): RawByteString; [Public, alias: 'FPC_ANSISTR_TO_ANSISTR']; compilerproc;
Function fpc_AnsiStr_To_AnsiStr (const S : AnsiString;cp : TSystemCodePage): AnsiString; compilerproc;
{ {
Converts an AnsiString to an AnsiString taking code pages into care Converts an AnsiString to an AnsiString taking code pages into care
} }
@ -351,6 +349,7 @@ begin
widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(temp)),result,cp,Size); widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(temp)),result,cp,Size);
end; end;
Function fpc_AnsiStr_To_AnsiStr (const S : RawByteString;cp : TSystemCodePage): RawByteString; [external name 'FPC_ANSISTR_TO_ANSISTR'];
{$ifndef FPC_STRTOSHORTSTRINGPROC} {$ifndef FPC_STRTOSHORTSTRINGPROC}
@ -358,7 +357,7 @@ end;
{ procedure fpc_AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer); } { procedure fpc_AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer); }
{ which is what the old helper was, so we don't need an extra implementation } { which is what the old helper was, so we don't need an extra implementation }
{ of the old helper (JM) } { of the old helper (JM) }
function fpc_AnsiStr_To_ShortStr (high_of_res: SizeInt;const S2 : Ansistring): shortstring;[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR']; compilerproc; function fpc_AnsiStr_To_ShortStr (high_of_res: SizeInt;const S2 : Ansistring): shortstring; [Public, alias: 'FPC_ANSISTR_TO_SHORTSTR']; compilerproc;
{ {
Converts a AnsiString to a ShortString; Converts a AnsiString to a ShortString;
} }
@ -440,7 +439,6 @@ begin
end; end;
Function fpc_CharArray_To_AnsiStr(const arr: array of char; zerobased: boolean = true): ansistring; compilerproc; Function fpc_CharArray_To_AnsiStr(const arr: array of char; zerobased: boolean = true): ansistring; compilerproc;
var var
i : SizeInt; i : SizeInt;
@ -598,6 +596,8 @@ begin
begin begin
GetMem(Pointer(S),AnsiRecLen+L); GetMem(Pointer(S),AnsiRecLen+L);
PAnsiRec(S)^.Ref:=1; PAnsiRec(S)^.Ref:=1;
PAnsiRec(S)^.CodePage:=DefaultSystemCodePage;
PAnsiRec(S)^.ElementSize:=1;
inc(Pointer(S),AnsiFirstOff); inc(Pointer(S),AnsiFirstOff);
end end
else if PAnsiRec(Pointer(S)-AnsiFirstOff)^.Ref=1 then else if PAnsiRec(Pointer(S)-AnsiFirstOff)^.Ref=1 then
@ -617,14 +617,14 @@ begin
{ also move terminating null } { also move terminating null }
lens:=succ(length(s)); lens:=succ(length(s));
if l < lens then if l<lens then
movelen := l movelen:=l
else else
movelen := lens; movelen:=lens;
Move(Pointer(S)^,Temp^,movelen); Move(Pointer(S)^,Temp^,movelen);
{ ref count dropped to zero in the mean time? } { ref count dropped to zero in the mean time? }
If (PAnsiRec(Pointer(S)-AnsiFirstOff)^.Ref > 0) and If (PAnsiRec(Pointer(S)-AnsiFirstOff)^.Ref>0) and
declocked(PAnsiRec(Pointer(S)-AnsiFirstOff)^.Ref) then declocked(PAnsiRec(Pointer(S)-AnsiFirstOff)^.Ref) then
freemem(PAnsiRec(Pointer(s)-AnsiFirstOff)); freemem(PAnsiRec(Pointer(s)-AnsiFirstOff));
Pointer(S):=Temp; Pointer(S):=Temp;
end; end;
@ -636,7 +636,7 @@ begin
begin begin
{ Length=0 } { Length=0 }
if Pointer(S)<>nil then if Pointer(S)<>nil then
fpc_ansistr_decr_ref (Pointer(S)); fpc_ansistr_decr_ref (Pointer(S));
Pointer(S):=Nil; Pointer(S):=Nil;
end; end;
end; end;
@ -1144,3 +1144,18 @@ function StringRefCount(const S: RawByteString): SizeInt; overload;
Result:=SizeOf(AnsiChar); Result:=SizeOf(AnsiChar);
end; end;
procedure SetCodePage(var s : RawByteString; CodePage : TSystemCodePage; Convert : Boolean = True);
begin
if (S='') or (StringCodePage(S)=CodePage) then
exit
else if Convert then
begin
s:=fpc_AnsiStr_To_AnsiStr(s,CodePage);
end
else
begin
UniqueString(s);
PAnsiRec(pointer(s)-AnsiFirstOff)^.CodePage:=CodePage;
end;
end;

2
rtl/inc/compproc.inc
View File

@ -266,7 +266,7 @@ function fpc_AnsiStr_To_ShortStr (high_of_res: SizeInt;const S2 : Ansistring): s
{$else FPC_STRTOSHORTSTRINGPROC} {$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_AnsiStr_To_ShortStr (out res : shortstring;const S2 : Ansistring); compilerproc; procedure fpc_AnsiStr_To_ShortStr (out res : shortstring;const S2 : Ansistring); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC} {$endif FPC_STRTOSHORTSTRINGPROC}
Function fpc_AnsiStr_To_AnsiStr (const S : AnsiString;cp : TSystemCodePage): AnsiString; compilerproc; Function fpc_AnsiStr_To_AnsiStr (const S : RawByteString;cp : TSystemCodePage): RawByteString; compilerproc;
Function fpc_ShortStr_To_AnsiStr (Const S2 : ShortString): ansistring; compilerproc; Function fpc_ShortStr_To_AnsiStr (Const S2 : ShortString): ansistring; compilerproc;
Function fpc_Char_To_AnsiStr(const c : Char): AnsiString; compilerproc; Function fpc_Char_To_AnsiStr(const c : Char): AnsiString; compilerproc;

2
rtl/inc/systemh.inc
View File

@ -345,7 +345,7 @@ Type
{$ifndef FPUNONE} {$ifndef FPUNONE}
PDate = ^TDateTime; PDate = ^TDateTime;
PDateTime = ^TDateTime; PDateTime = ^TDateTime;
{$endif} {$endif}
PError = ^TError; PError = ^TError;
PVariant = ^Variant; PVariant = ^Variant;

10
rtl/inc/ustrings.inc
View File

@ -185,7 +185,7 @@ begin
GetMem(P,Len*sizeof(UnicodeChar)+UnicodeRecLen); GetMem(P,Len*sizeof(UnicodeChar)+UnicodeRecLen);
If P<>Nil then If P<>Nil then
begin begin
PUnicodeRec(P)^.Len:=Len*2; { Initial length } PUnicodeRec(P)^.Len:=Len; { Initial length }
PUnicodeRec(P)^.Ref:=1; { Initial Refcount } PUnicodeRec(P)^.Ref:=1; { Initial Refcount }
PUnicodeRec(P)^.CodePage:=DefaultUnicodeCodePage; PUnicodeRec(P)^.CodePage:=DefaultUnicodeCodePage;
PUnicodeRec(P)^.ElementSize:=SizeOf(UnicodeChar); PUnicodeRec(P)^.ElementSize:=SizeOf(UnicodeChar);
@ -231,9 +231,8 @@ Begin
{ declocked does a MT safe dec and returns true, if the counter is 0 } { declocked does a MT safe dec and returns true, if the counter is 0 }
if declocked(l^) then if declocked(l^) then
{ Ref count dropped to zero ... { Ref count dropped to zero remove }
... remove } DisposeUnicodeString(S);
DisposeUnicodeString(S);
end; end;
{ alias for internal use } { alias for internal use }
@ -676,7 +675,6 @@ begin
end; end;
Function fpc_Char_To_UnicodeStr(const c : Char): UnicodeString; compilerproc; Function fpc_Char_To_UnicodeStr(const c : Char): UnicodeString; compilerproc;
{ {
Converts a Char to a UnicodeString; Converts a Char to a UnicodeString;
@ -1377,7 +1375,7 @@ begin
end; end;
{ Force nil termination in case it gets shorter } { Force nil termination in case it gets shorter }
PWord(Pointer(S)+l*sizeof(UnicodeChar))^:=0; PWord(Pointer(S)+l*sizeof(UnicodeChar))^:=0;
PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.Len:=l*sizeof(UnicodeChar); PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.Len:=l;
end end
else else
begin begin

1
rtl/inc/wstrings.inc
View File

@ -1359,7 +1359,6 @@ function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: SizeInt): SizeI
end; end;
function UTF8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt; function UTF8ToUnicode(Dest: PWideChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
const const
UNICODE_INVALID=63; UNICODE_INVALID=63;

36
rtl/win/syswin.inc
View File

@ -289,9 +289,10 @@ function GetProcessID: SizeUInt;
******************************************************************************} ******************************************************************************}
const const
{ MultiByteToWideChar } { MultiByteToWideChar }
MB_PRECOMPOSED = 1; MB_PRECOMPOSED = 1;
CP_ACP = 0; CP_ACP = 0;
WC_NO_BEST_FIT_CHARS = $400; CP_UTF16 = 1200;
WC_NO_BEST_FIT_CHARS = $400;
function MultiByteToWideChar(CodePage:UINT; dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint; function MultiByteToWideChar(CodePage:UINT; dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint;
stdcall; external 'kernel32' name 'MultiByteToWideChar'; stdcall; external 'kernel32' name 'MultiByteToWideChar';
@ -308,10 +309,14 @@ procedure Win32Unicode2AnsiMove(source:punicodechar;var dest:ansistring;cp : TSy
begin begin
// retrieve length including trailing #0 // retrieve length including trailing #0
// not anymore, because this must also be usable for single characters // not anymore, because this must also be usable for single characters
destlen:=WideCharToMultiByte(cp, WC_NO_BEST_FIT_CHARS, source, len, nil, 0, nil, nil); destlen:=WideCharToMultiByte(cp, 0, source, len, nil, 0, nil, nil);
// this will null-terminate // this will null-terminate
setlength(dest, destlen); setlength(dest, destlen);
WideCharToMultiByte(cp, WC_NO_BEST_FIT_CHARS, source, len, @dest[1], destlen, nil, nil); if destlen>0 then
begin
WideCharToMultiByte(cp, 0, source, len, @dest[1], destlen, nil, nil);
PAnsiRec(pointer(dest)-AnsiFirstOff)^.CodePage:=cp;
end;
end; end;
procedure Win32Ansi2UnicodeMove(source:pchar;cp : TSystemCodePage;var dest:UnicodeString;len:SizeInt); procedure Win32Ansi2UnicodeMove(source:pchar;cp : TSystemCodePage;var dest:UnicodeString;len:SizeInt);
@ -323,7 +328,11 @@ procedure Win32Ansi2UnicodeMove(source:pchar;cp : TSystemCodePage;var dest:Unico
destlen:=MultiByteToWideChar(cp, MB_PRECOMPOSED, source, len, nil, 0); destlen:=MultiByteToWideChar(cp, MB_PRECOMPOSED, source, len, nil, 0);
// this will null-terminate // this will null-terminate
setlength(dest, destlen); setlength(dest, destlen);
MultiByteToWideChar(cp, MB_PRECOMPOSED, source, len, @dest[1], destlen); if destlen>0 then
begin
MultiByteToWideChar(cp, MB_PRECOMPOSED, source, len, @dest[1], destlen);
PUnicodeRec(pointer(dest)-UnicodeFirstOff)^.CodePage:=CP_UTF16;
end;
end; end;
@ -354,10 +363,14 @@ procedure Win32Wide2AnsiMove(source:pwidechar;var dest:ansistring;cp : TSystemCo
begin begin
// retrieve length including trailing #0 // retrieve length including trailing #0
// not anymore, because this must also be usable for single characters // not anymore, because this must also be usable for single characters
destlen:=WideCharToMultiByte(cp, WC_NO_BEST_FIT_CHARS, source, len, nil, 0, nil, nil); destlen:=WideCharToMultiByte(cp, 0, source, len, nil, 0, nil, nil);
// this will null-terminate // this will null-terminate
setlength(dest, destlen); setlength(dest, destlen);
WideCharToMultiByte(cp, WC_NO_BEST_FIT_CHARS, source, len, @dest[1], destlen, nil, nil); if destlen>0 then
begin
WideCharToMultiByte(cp, 0, source, len, @dest[1], destlen, nil, nil);
PAnsiRec(pointer(dest)-AnsiFirstOff)^.CodePage:=cp;
end;
end; end;
@ -370,7 +383,8 @@ procedure Win32Ansi2WideMove(source:pchar;cp : TSystemCodePage;var dest:widestri
destlen:=MultiByteToWideChar(cp, MB_PRECOMPOSED, source, len, nil, 0); destlen:=MultiByteToWideChar(cp, MB_PRECOMPOSED, source, len, nil, 0);
// this will null-terminate // this will null-terminate
setlength(dest, destlen); setlength(dest, destlen);
MultiByteToWideChar(cp, MB_PRECOMPOSED, source, len, @dest[1], destlen); if destlen>0 then
MultiByteToWideChar(cp, MB_PRECOMPOSED, source, len, @dest[1], destlen);
end; end;
@ -407,6 +421,8 @@ var
WStrInitTablesTable: TWStrInitTablesTable; external name 'FPC_WIDEINITTABLES'; WStrInitTablesTable: TWStrInitTablesTable; external name 'FPC_WIDEINITTABLES';
{$endif} {$endif}
function GetACP:UINT; external 'kernel32' name 'GetACP';
{ there is a similiar procedure in sysutils which inits the fields which { there is a similiar procedure in sysutils which inits the fields which
are only relevant for the sysutils units } are only relevant for the sysutils units }
procedure InitWin32Widestrings; procedure InitWin32Widestrings;
@ -442,5 +458,7 @@ procedure InitWin32Widestrings;
widestringmanager.UpperUnicodeStringProc:=@Win32UnicodeUpper; widestringmanager.UpperUnicodeStringProc:=@Win32UnicodeUpper;
widestringmanager.LowerUnicodeStringProc:=@Win32UnicodeLower; widestringmanager.LowerUnicodeStringProc:=@Win32UnicodeLower;
{$endif VER2_2} {$endif VER2_2}
DefaultSystemCodePage:=GetACP;
DefaultUnicodeCodePage:=CP_UTF16;
end; end;

1
rtl/win32/system.pp
View File

@ -948,4 +948,3 @@ begin
InitWin32Widestrings; InitWin32Widestrings;
DispCallByIDProc:=@DoDispCallByIDError; DispCallByIDProc:=@DoDispCallByIDError;
end. end.