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

* type casts pchar<->ansistring fixed

Browse Source 
* ansistring[..] calls does now an unique call
This commit is contained in:
florian 1998-09-27 10:16:22 +00:00
parent d4ac5e456b
commit 9083713fe4
6 changed files with 142 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
compiler/cg386cnv.pas
View File

@ -637,7 +637,7 @@ implementation
begin begin
stringdispose(p^.location.reference.symbol); stringdispose(p^.location.reference.symbol);
gettempofsizereference(256,p^.location.reference); gettempofsizereference(256,p^.location.reference);
{ call loadstring with correct left and right } { call loadstring with correct left and right }
p^.right:=p^.left; p^.right:=p^.left;
p^.left:=p; p^.left:=p;
loadstring(p); loadstring(p);
@ -1084,27 +1084,51 @@ implementation
pushed : tpushed; pushed : tpushed;
begin begin
case pstringdef(p^.resulttype)^.string_typ of case pstringdef(p^.resulttype)^.string_typ of
st_shortstring : begin st_shortstring:
pushusedregisters(pushed,$ff); begin
stringdispose(p^.location.reference.symbol); pushusedregisters(pushed,$ff);
gettempofsizereference(p^.resulttype^.size,p^.location.reference); stringdispose(p^.location.reference.symbol);
case p^.left^.location.loc of gettempofsizereference(p^.resulttype^.size,p^.location.reference);
LOC_REGISTER,LOC_CREGISTER: case p^.left^.location.loc of
begin LOC_REGISTER,LOC_CREGISTER:
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); begin
ungetregister32(p^.left^.location.register); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register)));
end; ungetregister32(p^.left^.location.register);
LOC_REFERENCE,LOC_MEM: end;
begin LOC_REFERENCE,LOC_MEM:
emit_push_mem(p^.left^.location.reference); begin
del_reference(p^.left^.location.reference); emit_push_mem(p^.left^.location.reference);
end; del_reference(p^.left^.location.reference);
end; end;
emitpushreferenceaddr(exprasmlist,p^.location.reference); end;
emitcall('FPC_PCHAR_TO_STR',true); emitpushreferenceaddr(exprasmlist,p^.location.reference);
maybe_loadesi; emitcall('FPC_PCHAR_TO_STR',true);
popusedregisters(pushed); maybe_loadesi;
end; popusedregisters(pushed);
end;
st_ansistring:
begin
stringdispose(p^.location.reference.symbol);
gettempofsizereference(p^.resulttype^.size,p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
ungetregister32(p^.left^.location.register);
pushusedregisters(pushed,$ff);
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register)));
end;
LOC_REFERENCE,LOC_MEM:
begin
del_reference(p^.left^.location.reference);
pushusedregisters(pushed,$ff);
emit_push_mem(p^.left^.location.reference);
end;
end;
emitpushreferenceaddr(exprasmlist,p^.location.reference);
emitcall('FPC_PCHAR_TO_ANSISTRING',true);
maybe_loadesi;
popusedregisters(pushed);
end;
else else
begin begin
p^.location.loc:=LOC_REGISTER; p^.location.loc:=LOC_REGISTER;
@ -1282,7 +1306,11 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.23 1998-09-23 12:03:51 peter Revision 1.24 1998-09-27 10:16:22 florian
* type casts pchar<->ansistring fixed
* ansistring[..] calls does now an unique call
Revision 1.23 1998/09/23 12:03:51 peter
* overloading fix for array of const * overloading fix for array of const
Revision 1.22 1998/09/22 15:34:09 peter Revision 1.22 1998/09/22 15:34:09 peter

36
compiler/cg386mem.pas
View File

@ -324,7 +324,7 @@ implementation
procedure secondvecn(var p : ptree); procedure secondvecn(var p : ptree);
var var
pushed : boolean; is_pushed : boolean;
ind,hr : tregister; ind,hr : tregister;
_p : ptree; _p : ptree;
@ -358,6 +358,7 @@ implementation
t : ptree; t : ptree;
hp : preference; hp : preference;
tai : Pai386; tai : Pai386;
pushed : tpushed;
begin begin
secondpass(p^.left); secondpass(p^.left);
@ -370,11 +371,34 @@ implementation
begin begin
reset_reference(p^.location.reference); reset_reference(p^.location.reference);
p^.location.loc:=LOC_REFERENCE; p^.location.loc:=LOC_REFERENCE;
if is_ansistring(p^.left^.resulttype) then
begin
if p^.callunique then
begin
pushusedregisters(pushed,$ff);
emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
emitcall('FPC_UNIQUE_ANSISTRING',true);
maybe_loadesi;
popusedregisters(pushed);
end;
end
else
begin
if p^.callunique then
begin
pushusedregisters(pushed,$ff);
emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
emitcall('FPC_UNIQUE_WIDESTRING',true);
maybe_loadesi;
popusedregisters(pushed);
end;
end;
del_reference(p^.left^.location.reference); del_reference(p^.left^.location.reference);
p^.location.reference.base:=getregister32; p^.location.reference.base:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference), newreference(p^.left^.location.reference),
p^.location.reference.base))); p^.location.reference.base)));
if is_ansistring(p^.left^.resulttype) then if is_ansistring(p^.left^.resulttype) then
begin begin
{ in ansistrings S[1] is pchar(S)[0] !! } { in ansistrings S[1] is pchar(S)[0] !! }
@ -480,9 +504,9 @@ implementation
if (p^.location.loc<>LOC_REFERENCE) and if (p^.location.loc<>LOC_REFERENCE) and
(p^.location.loc<>LOC_MEM) then (p^.location.loc<>LOC_MEM) then
CGMessage(cg_e_illegal_expression); CGMessage(cg_e_illegal_expression);
pushed:=maybe_push(p^.right^.registers32,p); is_pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right); secondpass(p^.right);
if pushed then restore(p); if is_pushed then restore(p);
case p^.right^.location.loc of case p^.right^.location.loc of
LOC_REGISTER: LOC_REGISTER:
begin begin
@ -649,7 +673,11 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.12 1998-09-23 15:46:36 florian Revision 1.13 1998-09-27 10:16:23 florian
* type casts pchar<->ansistring fixed
* ansistring[..] calls does now an unique call
Revision 1.12 1998/09/23 15:46:36 florian
* problem with with and classes fixed * problem with with and classes fixed
Revision 1.11 1998/09/17 09:42:18 peter Revision 1.11 1998/09/17 09:42:18 peter

11
compiler/tccal.pas
View File

@ -182,7 +182,10 @@ implementation
{ is this usefull here ? } { is this usefull here ? }
{ this was missing in formal parameter list } { this was missing in formal parameter list }
if defcoll^.paratyp=vs_var then if defcoll^.paratyp=vs_var then
make_not_regable(p^.left); begin
set_unique(p^.left);
make_not_regable(p^.left);
end;
p^.resulttype:=defcoll^.data; p^.resulttype:=defcoll^.data;
end; end;
@ -907,7 +910,11 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.3 1998-09-24 14:27:40 peter Revision 1.4 1998-09-27 10:16:24 florian
* type casts pchar<->ansistring fixed
* ansistring[..] calls does now an unique call
Revision 1.3 1998/09/24 14:27:40 peter
* some better support for openarray * some better support for openarray
Revision 1.2 1998/09/24 09:02:16 peter Revision 1.2 1998/09/24 09:02:16 peter

27
compiler/tccnv.pas
View File

@ -279,6 +279,7 @@ implementation
if p^.left^.treetype=ordconstn then if p^.left^.treetype=ordconstn then
begin begin
hp:=genstringconstnode(chr(p^.left^.value)); hp:=genstringconstnode(chr(p^.left^.value));
hp^.stringtype:=pstringdef(p^.resulttype)^.string_typ;
firstpass(hp); firstpass(hp);
disposetree(p); disposetree(p);
p:=hp; p:=hp;
@ -488,14 +489,11 @@ implementation
end; end;
procedure first_pchar_to_ansistring(var p : ptree); procedure first_pchar_to_string(var p : ptree);
begin begin
p^.location.loc:=LOC_REGISTER; p^.location.loc:=LOC_MEM;
if p^.registers32<1 then
p^.registers32:=1;
end; end;
procedure first_ansistring_to_pchar(var p : ptree); procedure first_ansistring_to_pchar(var p : ptree);
begin begin
p^.location.loc:=LOC_REGISTER; p^.location.loc:=LOC_REGISTER;
@ -550,12 +548,12 @@ implementation
first_cchar_charpointer, first_cchar_charpointer,
first_load_smallset, first_load_smallset,
first_ansistring_to_pchar, first_ansistring_to_pchar,
first_pchar_to_ansistring, first_pchar_to_string,
first_arrayconstructor_to_set); first_arrayconstructor_to_set);
begin begin
aprocdef:=nil; aprocdef:=nil;
{ if explicite type conversation, then run firstpass } { if explicite type cast, then run firstpass }
if p^.explizit then if p^.explizit then
firstpass(p^.left); firstpass(p^.left);
@ -720,6 +718,13 @@ implementation
firstconvert[p^.convtyp](p); firstconvert[p^.convtyp](p);
exit; exit;
end; end;
if is_pchar(p^.resulttype) and
is_ansistring(p^.left^.resulttype) then
begin
p^.convtyp:=tc_ansistring_2_pchar;
firstconvert[p^.convtyp](p);
exit;
end;
{ normal tc_equal-Konvertierung durchf<68>hren } { normal tc_equal-Konvertierung durchf<68>hren }
p^.convtyp:=tc_equal; p^.convtyp:=tc_equal;
{ wenn Aufz„hltyp nach Ordinal konvertiert werden soll } { wenn Aufz„hltyp nach Ordinal konvertiert werden soll }
@ -738,7 +743,7 @@ implementation
else else
begin begin
if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp, if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp,
ordconstn { nur Dummy},false ) then ordconstn { only Dummy},false ) then
CGMessage(cg_e_illegal_type_conversion); CGMessage(cg_e_illegal_type_conversion);
end; end;
@ -898,7 +903,11 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.2 1998-09-24 23:49:22 peter Revision 1.3 1998-09-27 10:16:26 florian
* type casts pchar<->ansistring fixed
* ansistring[..] calls does now an unique call
Revision 1.2 1998/09/24 23:49:22 peter
+ aktmodeswitches + aktmodeswitches
Revision 1.1 1998/09/23 20:42:24 peter Revision 1.1 1998/09/23 20:42:24 peter

9
compiler/tcld.pas
View File

@ -174,6 +174,9 @@ implementation
store_valid:=must_be_valid; store_valid:=must_be_valid;
must_be_valid:=false; must_be_valid:=false;
{ must be made unique }
set_unique(p^.left);
firstpass(p^.left); firstpass(p^.left);
if codegenerror then if codegenerror then
exit; exit;
@ -396,7 +399,11 @@ implementation
end. end.
{ {
$Log$ $Log$
Revision 1.2 1998-09-24 15:13:48 peter Revision 1.3 1998-09-27 10:16:27 florian
* type casts pchar<->ansistring fixed
* ansistring[..] calls does now an unique call
Revision 1.2 1998/09/24 15:13:48 peter
* fixed type node which was always set to void :( * fixed type node which was always set to void :(
Revision 1.1 1998/09/23 20:42:24 peter Revision 1.1 1998/09/23 20:42:24 peter

26
compiler/tree.pas
View File

@ -214,7 +214,7 @@ unit tree;
fixconstn : (value_fix: longint); fixconstn : (value_fix: longint);
funcretn : (funcretprocinfo : pointer;retdef : pdef); funcretn : (funcretprocinfo : pointer;retdef : pdef);
subscriptn : (vs : pvarsym); subscriptn : (vs : pvarsym);
vecn : (memindex,memseg:boolean); vecn : (memindex,memseg:boolean;callunique : boolean);
{$ifdef UseAnsiString} {$ifdef UseAnsiString}
stringconstn : (value_str : pchar;length : longint; lab_str : plabel;stringtype : tstringtype); stringconstn : (value_str : pchar;length : longint; lab_str : plabel;stringtype : tstringtype);
{$else UseAnsiString} {$else UseAnsiString}
@ -286,6 +286,10 @@ unit tree;
maxfirstpasscount : longint = 0; maxfirstpasscount : longint = 0;
{$endif extdebug} {$endif extdebug}
{ sets the callunique flag, if the node is a vecn, }
{ takes care of type casts etc. }
procedure set_unique(p : ptree);
{ gibt den ordinalen Werten der Node zurueck oder falls sie } { gibt den ordinalen Werten der Node zurueck oder falls sie }
{ keinen ordinalen Wert hat, wird ein Fehler erzeugt } { keinen ordinalen Wert hat, wird ein Fehler erzeugt }
function get_ordinal_value(p : ptree) : longint; function get_ordinal_value(p : ptree) : longint;
@ -1493,6 +1497,20 @@ unit tree;
equal_trees:=false; equal_trees:=false;
end; end;
procedure set_unique(p : ptree);
begin
if assigned(p) then
begin
case p^.treetype of
vecn:
p^.callunique:=true;
typeconvn:
set_unique(p^.left);
end;
end;
end;
{This is needed if you want to be able to delete the string with the nodes !!} {This is needed if you want to be able to delete the string with the nodes !!}
procedure set_location(var destloc,sourceloc : tlocation); procedure set_location(var destloc,sourceloc : tlocation);
@ -1570,7 +1588,11 @@ unit tree;
end. end.
{ {
$Log$ $Log$
Revision 1.42 1998-09-23 12:03:59 peter Revision 1.43 1998-09-27 10:16:28 florian
* type casts pchar<->ansistring fixed
* ansistring[..] calls does now an unique call
Revision 1.42 1998/09/23 12:03:59 peter
* overloading fix for array of const * overloading fix for array of const
Revision 1.41 1998/09/23 09:58:55 peter Revision 1.41 1998/09/23 09:58:55 peter