paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-24 05:39:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

merge r17552 from cpstrnew branch by inoussa:

Browse Source 
*In normal procedure "var" and "out" RawByteString parameters does not accept other string types. Procedures with
"compilerproc" directive or the newly added "rtlproc" directive accept that. Please note that it is up to the
procedure coder to ensure the correctness of the code page in that case. The new directive is needed to handle 
the RTL procedures/functions that are not marked as "compilerproc" such as "UniqueString", "Insert" and "Delete".

*Correct "fpc_ansistr_concat" to handle code page correctly.

*Default "ansitring" type is now created with code page set to "0" instead of "65535". Before that change it was 
impossible to distinguish a "RawByteString" with the default "ansistring". At runtime "ansistring" variable'code
page is set to DefaultSystemCodePage

*UniqueString flavor of "SetLength" has been updated to release memory when shrinked to at least 50%, like ansitring
does.

git-svn-id: trunk@19118 -
This commit is contained in:
paul 2011-09-17 13:52:09 +00:00
parent 0c3ccadf07
commit 005795495d
12 changed files with 142 additions and 49 deletions

22
compiler/defcmp.pas
View File

@ -43,7 +43,9 @@ interface
cpo_ignoreuniv,
cpo_warn_incompatible_univ,
cpo_ignorevarspez, // ignore parameter access type
cpo_ignoreframepointer // ignore frame pointer parameter (for assignment-compatibility of global procedures to nested procvars)
cpo_ignoreframepointer, // ignore frame pointer parameter (for assignment-compatibility of global procedures to nested procvars)
cpo_compilerproc,
cpo_rtlproc
);
tcompare_paras_options = set of tcompare_paras_option;
@ -355,8 +357,11 @@ implementation
if (tstringdef(def_from).encoding=tstringdef(def_to).encoding) or
(tstringdef(def_from).encoding=globals.CP_NONE) or
(tstringdef(def_to).encoding=globals.CP_NONE) then
eq:=te_equal
else
begin
//doconv := tc_string_2_string;
eq:=te_equal;
end
else
begin
doconv := tc_string_2_string;
if (tstringdef(def_to).encoding=globals.CP_UTF8) then
@ -1804,6 +1809,17 @@ implementation
if not equal_constsym(tconstsym(currpara1.defaultconstsym),tconstsym(currpara2.defaultconstsym)) then
exit;
end;
if not(cpo_compilerproc in cpoptions) and
not(cpo_rtlproc in cpoptions) and
is_ansistring(currpara1.vardef) and
is_ansistring(currpara2.vardef) and
(tstringdef(currpara1.vardef).encoding<>tstringdef(currpara2.vardef).encoding) and
((tstringdef(currpara1.vardef).encoding=globals.CP_NONE) or
(tstringdef(currpara2.vardef).encoding=globals.CP_NONE)
) then
eq:=te_convert_l1;
if eq<lowesteq then
lowesteq:=eq;
inc(i1);
inc(i2);
if cpo_ignorehidden in cpoptions then

20
compiler/htypechk.pas
View File

@ -1997,6 +1997,7 @@ implementation
st : TSymtable;
contextstructdef : tabstractrecorddef;
ProcdefOverloadList : TFPObjectList;
cpoptions : tcompare_paras_options;
begin
FCandidateProcs:=nil;
@ -2086,11 +2087,16 @@ implementation
) then
begin
{ don't add duplicates, only compare visible parameters for the user }
cpoptions:=[cpo_ignorehidden];
if (po_compilerproc in pd.procoptions) then
cpoptions:=cpoptions+[cpo_compilerproc];
if (po_rtlproc in pd.procoptions) then
cpoptions:=cpoptions+[cpo_rtlproc];
found:=false;
hp:=FCandidateProcs;
while assigned(hp) do
begin
if (compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,[cpo_ignorehidden])>=te_equal) and
if (compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,cpoptions)>=te_equal) and
(not(po_objc in pd.procoptions) or
(pd.messageinf.str^=hp^.data.messageinf.str^)) then
begin
@ -2412,7 +2418,17 @@ implementation
else
{ generic type comparision }
begin
eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,cdoptions);
if not(po_compilerproc in hp^.data.procoptions) and
not(po_rtlproc in hp^.data.procoptions) and
is_ansistring(currpara.vardef) and
is_ansistring(currpt.left.resultdef) and
(tstringdef(currpara.vardef).encoding<>tstringdef(currpt.left.resultdef).encoding) and
((tstringdef(currpara.vardef).encoding=globals.CP_NONE) or
(tstringdef(currpt.left.resultdef).encoding=globals.CP_NONE)
) then
eq:=te_convert_l1
else
eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,cdoptions);
{ when the types are not equal we need to check
some special case for parameter passing }

54
compiler/nadd.pas
View File

@ -1983,6 +1983,7 @@ implementation
newstatement : tstatementnode;
tempnode (*,tempnode2*) : ttempcreatenode;
cmpfuncname: string;
para: tcallparanode;
begin
{ when we get here, we are sure that both the left and the right }
{ node are both strings of the same stringtype (JM) }
@ -2011,11 +2012,26 @@ implementation
(aktassignmentnode.left.resultdef=resultdef) and
valid_for_var(aktassignmentnode.left,false) then
begin
result:=ccallnode.createintern('fpc_'+
tstringdef(resultdef).stringtypname+'_concat',
ccallparanode.create(right,
ccallparanode.create(left,
ccallparanode.create(aktassignmentnode.left.getcopy,nil))));
para:=ccallparanode.create(
right,
ccallparanode.create(
left,
ccallparanode.create(aktassignmentnode.left.getcopy,nil)
)
);
if is_ansistring(resultdef) then
para:=ccallparanode.create(
cordconstnode.create(
tstringdef(resultdef).encoding,
u16inttype,
true
),
para
);
result:=ccallnode.createintern(
'fpc_'+tstringdef(resultdef).stringtypname+'_concat',
para
);
include(aktassignmentnode.flags,nf_assign_done_in_right);
firstpass(result);
end
@ -2024,11 +2040,29 @@ implementation
result:=internalstatements(newstatement);
tempnode:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
addstatement(newstatement,tempnode);
addstatement(newstatement,ccallnode.createintern('fpc_'+
tstringdef(resultdef).stringtypname+'_concat',
ccallparanode.create(right,
ccallparanode.create(left,
ccallparanode.create(ctemprefnode.create(tempnode),nil)))));
para:=ccallparanode.create(
right,
ccallparanode.create(
left,
ccallparanode.create(ctemprefnode.create(tempnode),nil)
)
);
if is_ansistring(resultdef) then
para:=ccallparanode.create(
cordconstnode.create(
tstringdef(resultdef).encoding,
u16inttype,
true
),
para
);
addstatement(
newstatement,
ccallnode.createintern(
'fpc_'+tstringdef(resultdef).stringtypname+'_concat',
para
)
);
addstatement(newstatement,ctempdeletenode.create_normal_temp(tempnode));
addstatement(newstatement,ctemprefnode.create(tempnode));
end;

11
compiler/pdecsub.pas
View File

@ -2140,7 +2140,7 @@ type
end;
const
{Should contain the number of procedure directives we support.}
num_proc_directives=42;
num_proc_directives=43;
proc_direcdata:array[1..num_proc_directives] of proc_dir_rec=
(
(
@ -2533,6 +2533,15 @@ const
mutexclpocall : [pocall_internproc];
mutexclpotype : [];
mutexclpo : [po_exports,po_interrupt,po_external,po_inline]
),(
idtok:_RTLPROC;
pd_flags : [pd_interface,pd_implemen,pd_body,pd_notobjintf];
handler : nil;
pocall : pocall_none;
pooption : [po_rtlproc];
mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_interrupt]
)
);

3
compiler/symconst.pas
View File

@ -314,7 +314,8 @@ type
(when calling a regular procedure using the above convention, it will
simply not see the frame pointer parameter, and since the caller cleans
up the stack will also remain balanced) }
po_delphi_nested_cc
po_delphi_nested_cc,
po_rtlproc
);
tprocoptions=set of tprocoption;

2
compiler/symdef.pas
View File

@ -1447,7 +1447,7 @@ implementation
begin
inherited create(stringdef);
stringtype:=st_ansistring;
encoding:=65535;
encoding:=0;
len:=-1;
savesize:=sizeof(pint);
end;

2
compiler/tokens.pas
View File

@ -204,6 +204,7 @@ type
_PRIVATE,
_PROGRAM,
_R12BASE,
_RTLPROC,
_SECTION,
_STDCALL,
_SYSCALL,
@ -500,6 +501,7 @@ const
(str:'PRIVATE' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'PROGRAM' ;special:false;keyword:m_all;op:NOTOKEN),
(str:'R12BASE' ;special:false;keyword:m_none;op:NOTOKEN), { Syscall variation on MorphOS }
(str:'RTLPROC' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'SECTION' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'STDCALL' ;special:false;keyword:m_none;op:NOTOKEN),
(str:'SYSCALL' ;special:false;keyword:m_none;op:NOTOKEN),

38
rtl/inc/astrings.inc
View File

@ -207,7 +207,7 @@ end;
{$else STR_CONCAT_PROCS}
procedure fpc_AnsiStr_Concat (var DestS:RawByteString;const S1,S2 : RawByteString); compilerproc;
procedure fpc_AnsiStr_Concat (var DestS:RawByteString;const S1,S2 : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
Var
Size,Location : SizeInt;
same : boolean;
@ -216,13 +216,20 @@ Var
begin
{ if codepages are differ then concat using unicodestring }
S1CP:=StringCodePage(S1);
if S1CP=$ffff then
if (S1CP=$ffff) or (S1CP=0) then
S1CP:=DefaultSystemCodePage;
S2CP:=StringCodePage(S2);
if S2CP=$ffff then
if (S2CP=$ffff) or (S2CP=0) then
S2CP:=DefaultSystemCodePage;
{$ifdef FPC_HAS_CPSTRING}
if (Pointer(DestS)=nil) then
DestCP:=cp
else
DestCP:=StringCodePage(DestS);
{$else FPC_HAS_CPSTRING}
DestCP:=StringCodePage(DestS);
if DestCP=$ffff then
{$endif FPC_HAS_CPSTRING}
if (DestCP=$ffff) or (DestCP=0) then
DestCP:=DefaultSystemCodePage;
if (S1CP<>DestCP) or (S2CP<>DestCP) then
begin
@ -264,6 +271,7 @@ begin
begin
DestS:='';
SetLength(DestS,Size+Location);
SetCodePage(DestS,DestCP,false);
Move(Pointer(S1)^,Pointer(DestS)^,Location);
Move(Pointer(S2)^,(Pointer(DestS)+Location)^,Size+1);
end;
@ -281,6 +289,7 @@ Var
U : UnicodeString;
sameCP : Boolean;
tmpStr : RawByteString;
tmpCP : TSystemCodePage;
begin
if high(sarr)=0 then
begin
@ -295,7 +304,7 @@ begin
{$else FPC_HAS_CPSTRING}
DestCP:=StringCodePage(DestS);
{$endif FPC_HAS_CPSTRING}
if (DestCP=$ffff) then
if (DestCP=$ffff) or (DestCP=0) then
DestCP:=DefaultSystemCodePage;
sameCP:=true;
lowstart:=low(sarr);
@ -311,7 +320,8 @@ begin
begin
U:='';
for i:=lowstart to high(sarr) do begin
if (StringCodePage(sarr[i]) = $ffff) then
tmpCP:=StringCodePage(sarr[i]);
if (tmpCP=$ffff) or (tmpCP=0) then
begin
tmpStr:=sarr[i];
SetCodePage(tmpStr,DefaultSystemCodePage,False);
@ -619,10 +629,10 @@ begin
else
begin
r1:=S1;
if (cp1=$ffff) then
if (cp1=$ffff) or (cp1=0) then
SetCodePage(r1,DefaultSystemCodePage,false);
r2:=S2;
if (cp2=$ffff) then
if (cp2=$ffff) or (cp2=0) then
SetCodePage(r2,DefaultSystemCodePage,false);
//convert them to utf8 then compare
SetCodePage(r1,65001);
@ -662,10 +672,10 @@ begin
else
begin
r1:=S1;
if (cp1=$ffff) then
if (cp1=$ffff) or (cp1=0) then
SetCodePage(r1,DefaultSystemCodePage,false);
r2:=S2;
if (cp2=$ffff) then
if (cp2=$ffff) or (cp2=0) then
SetCodePage(r2,DefaultSystemCodePage,false);
Result:=widestringmanager.CompareTextUnicodeStringProc(UnicodeString(r1),UnicodeString(r2));
end;
@ -710,6 +720,8 @@ begin
GetMem(Pointer(S),AnsiRecLen+L);
PAnsiRec(S)^.Ref:=1;
{$ifdef FPC_HAS_CPSTRING}
if (cp=0) then
cp:=DefaultSystemCodePage;
PAnsiRec(S)^.CodePage:=cp;
{$else}
PAnsiRec(S)^.CodePage:=DefaultSystemCodePage;
@ -1156,7 +1168,7 @@ end;
{$endif CPU64}
Procedure Delete (Var S : AnsiString; Index,Size: SizeInt);
Procedure Delete (Var S : RawByteString; Index,Size: SizeInt);
Var
LS : SizeInt;
begin
@ -1175,9 +1187,9 @@ begin
end;
Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : SizeInt);
Procedure Insert (Const Source : RawByteString; Var S : RawByteString; Index : SizeInt);
var
Temp : AnsiString;
Temp : RawByteString;
LS : SizeInt;
begin
If Length(Source)=0 then

2
rtl/inc/compproc.inc
View File

@ -249,7 +249,7 @@ Procedure fpc_ansistr_decr_ref (Var S : Pointer); compilerproc;
Procedure fpc_ansistr_incr_ref (S : Pointer); compilerproc;
Procedure fpc_AnsiStr_Assign (Var DestS : Pointer;S2 : Pointer); compilerproc;
{$ifdef STR_CONCAT_PROCS}
Procedure fpc_AnsiStr_Concat (Var DestS : RawByteString;const S1,S2 : RawByteString); compilerproc;
Procedure fpc_AnsiStr_Concat (Var DestS : RawByteString;const S1,S2 : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
Procedure fpc_AnsiStr_Concat_multi (Var DestS : RawByteString;const sarr:array of RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
{$else STR_CONCAT_PROCS}
function fpc_AnsiStr_Concat (const S1,S2 : AnsiString): AnsiString; compilerproc;

6
rtl/inc/systemh.inc
View File

@ -880,11 +880,11 @@ function pos(const substr : shortstring;c:char): SizeInt;
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure UniqueString(var S : AnsiString);external name 'FPC_ANSISTR_UNIQUE';
Procedure UniqueString(var S : RawByteString);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}external name 'FPC_ANSISTR_UNIQUE';
Function Pos (const Substr : RawByteString; const Source : RawByteString) : SizeInt;
Function Pos (c : Char; const s : RawByteString) : SizeInt;
Procedure Insert (const Source : AnsiString; var S : AnsiString; Index : SizeInt);
Procedure Delete (var S : AnsiString; Index,Size: SizeInt);
Procedure Insert (const Source : RawByteString; var S : RawByteString; Index : SizeInt);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}
Procedure Delete (var S : RawByteString; Index,Size: SizeInt);{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}
Function StringOfChar(c : char;l : SizeInt) : AnsiString;
function upcase(const s : ansistring) : ansistring;
function lowercase(const s : ansistring) : ansistring;

25
rtl/inc/ustrings.inc
View File

@ -320,13 +320,13 @@ Var
{$endif FPC_HAS_CPSTRING}
begin
{$ifndef FPC_HAS_CPSTRING}
cp:=$ffff;
cp:=DefaultSystemCodePage;
{$endif FPC_HAS_CPSTRING}
result:='';
Size:=Length(S2);
if Size>0 then
begin
if cp=$ffff then
if (cp=$ffff) or (cp=0) then
cp:=DefaultSystemCodePage;
widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(S2)),result,cp,Size);
end;
@ -346,7 +346,7 @@ begin
if Size>0 then
begin
cp:=StringCodePage(S2);
if cp=$ffff then
if (cp=$ffff) or (cp=0) then
cp:=DefaultSystemCodePage;
widestringmanager.Ansi2UnicodeMoveProc(PChar(S2),cp,result,Size);
end;
@ -375,7 +375,7 @@ var
{$endif FPC_HAS_CPSTRING}
begin
{$ifndef FPC_HAS_CPSTRING}
cp:=$ffff;
cp:=DefaultSystemCodePage;
{$endif FPC_HAS_CPSTRING}
result:='';
if p=nil then
@ -465,7 +465,7 @@ var
{$endif FPC_HAS_CPSTRING}
begin
{$ifndef FPC_HAS_CPSTRING}
cp:=$ffff;
cp:=DefaultSystemCodePage;
{$endif FPC_HAS_CPSTRING}
result:='';
if p=nil then
@ -808,9 +808,9 @@ var
{$endif FPC_HAS_CPSTRING}
begin
{$ifndef FPC_HAS_CPSTRING}
cp:=$ffff;
cp:=DefaultSystemCodePage;
{$endif FPC_HAS_CPSTRING}
if cp=$ffff then
if (cp=$ffff) or (cp=0) then
cp:=DefaultSystemCodePage;
widestringmanager.Unicode2AnsiMoveProc(@c, fpc_UChar_To_AnsiStr, cp, 1);
end;
@ -939,7 +939,7 @@ var
{$endif FPC_HAS_CPSTRING}
begin
{$ifndef FPC_HAS_CPSTRING}
cp:=$ffff;
cp:=DefaultSystemCodePage;
{$endif FPC_HAS_CPSTRING}
if (zerobased) then
begin
@ -1052,7 +1052,7 @@ var
{$endif FPC_HAS_CPSTRING}
begin
{$ifndef FPC_HAS_CPSTRING}
cp:=$ffff;
cp:=DefaultSystemCodePage;
{$endif FPC_HAS_CPSTRING}
if (zerobased) then
begin
@ -1389,6 +1389,7 @@ Procedure fpc_UnicodeStr_SetLength(Var S : UnicodeString; l : SizeInt);[Public,A
Var
Temp : Pointer;
movelen: SizeInt;
lens, lena : SizeUInt;
begin
if (l>0) then
begin
@ -1401,8 +1402,10 @@ begin
if (PUnicodeRec(Pointer(S)-UnicodeFirstOff)^.Ref = 1) then
begin
Dec(Pointer(S),UnicodeFirstOff);
if SizeUInt(L*sizeof(UnicodeChar)+UnicodeRecLen)>MemSize(Pointer(S)) then
reallocmem(pointer(S), L*sizeof(UnicodeChar)+UnicodeRecLen);
lens:=MemSize(Pointer(s));
lena:=SizeUInt(L*sizeof(UnicodeChar)+UnicodeRecLen);
if (lena>lens) or ((lens>32) and (lena<=(lens div 2))) then
reallocmem(pointer(S), lena);
Inc(Pointer(S), UnicodeFirstOff);
end
else

6
rtl/inc/wstrings.inc
View File

@ -272,13 +272,13 @@ Var
{$endif FPC_HAS_CPSTRING}
begin
{$ifndef FPC_HAS_CPSTRING}
cp:=$ffff;
cp:=DefaultSystemCodePage;
{$endif FPC_HAS_CPSTRING}
result:='';
Size:=Length(S2);
if Size>0 then
begin
if cp=$ffff then
if (cp=$ffff) or (cp=0) then
cp:=DefaultSystemCodePage;
widestringmanager.Wide2AnsiMoveProc(PWideChar(Pointer(S2)),result,cp,Size);
end;
@ -298,7 +298,7 @@ begin
if Size>0 then
begin
cp:=StringCodePage(S2);
if cp=$ffff then
if (cp=$ffff) or (cp=0) then
cp:=DefaultSystemCodePage;
widestringmanager.Ansi2WideMoveProc(PChar(S2),cp,result,Size);
end;