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

* update smartlinking, uses getdatalabel

Browse Source 
* renamed ptree.value vars to value_str,value_real,value_set
This commit is contained in:
peter 1998-09-07 18:45:52 +00:00
parent 295d53cb69
commit 12a80cf3dc
17 changed files with 343 additions and 410 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
compiler/cg386add.pas
View File

@ -230,8 +230,8 @@ implementation
cmpop:=true;
{ generate better code for s='' and s<>'' }
if (p^.treetype in [equaln,unequaln]) and
(((p^.left^.treetype=stringconstn) and (p^.left^.values^='')) or
((p^.right^.treetype=stringconstn) and (p^.right^.values^=''))) then
(((p^.left^.treetype=stringconstn) and (p^.left^.value_str^='')) or
((p^.right^.treetype=stringconstn) and (p^.right^.value_str^=''))) then
begin
secondpass(p^.left);
{ are too few registers free? }
@ -1277,7 +1277,11 @@ implementation
end.
{
$Log$
Revision 1.10 1998-09-04 10:05:04 florian
Revision 1.11 1998-09-07 18:45:52 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.10 1998/09/04 10:05:04 florian
* ugly fix for STRCAT, nevertheless it needs more fixing !!!!!!!
we need an new version of STRCAT which takes a length parameter

152
compiler/cg386con.pas
View File

@ -33,7 +33,7 @@ interface
procedure secondfixconst(var p : ptree);
procedure secondordconst(var p : ptree);
procedure secondstringconst(var p : ptree);
procedure secondsetcons(var p : ptree);
procedure secondsetconst(var p : ptree);
procedure secondniln(var p : ptree);
@ -52,13 +52,10 @@ implementation
var
hp1 : pai;
lastlabel : plabel;
found : boolean;
begin
clear_reference(p^.location.reference);
lastlabel:=nil;
found:=false;
{ const already used ? }
if p^.labnumber=-1 then
if not assigned(p^.lab_real) then
begin
{ tries to found an old entry }
hp1:=pai(consts^.first);
@ -70,12 +67,12 @@ implementation
begin
if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then
begin
if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then
if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.value_real)) or
((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.value_real)) or
((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.value_real)) then
begin
{ found! }
p^.labnumber:=lastlabel^.nb;
p^.lab_real:=lastlabel;
break;
end;
end;
@ -84,25 +81,25 @@ implementation
hp1:=pai(hp1^.next);
end;
{ :-(, we must generate a new entry }
if p^.labnumber=-1 then
if not assigned(p^.lab_real) then
begin
getlabel(lastlabel);
p^.labnumber:=lastlabel^.nb;
concat_constlabel(lastlabel,constreal);
getdatalabel(lastlabel);
p^.lab_real:=lastlabel;
if (cs_smartlink in aktmoduleswitches) then
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_label,init(lastlabel)));
case p^.realtyp of
ait_real_64bit : consts^.concat(new(pai_double,init(p^.valued)));
ait_real_32bit : consts^.concat(new(pai_single,init(p^.valued)));
ait_real_extended : consts^.concat(new(pai_extended,init(p^.valued)));
ait_real_64bit : consts^.concat(new(pai_double,init(p^.value_real)));
ait_real_32bit : consts^.concat(new(pai_single,init(p^.value_real)));
ait_real_extended : consts^.concat(new(pai_extended,init(p^.value_real)));
else
internalerror(10120);
end;
end;
end;
stringdispose(p^.location.reference.symbol);
if assigned(lastlabel) then
p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,constreal))
else
p^.location.reference.symbol:=stringdup(constlabelnb2str(p^.labnumber,constreal));
clear_reference(p^.location.reference);
p^.location.reference.symbol:=stringdup(lab2str(p^.lab_real));
p^.location.loc:=LOC_MEM;
end;
@ -115,7 +112,7 @@ implementation
{ an fix comma const. behaves as a memory reference }
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=p^.valuef;
p^.location.reference.offset:=p^.value_fix;
end;
@ -141,18 +138,15 @@ implementation
hp1 : pai;
{$ifdef UseAnsiString}
l1,
{$endif}
lastlabel : plabel;
pc : pchar;
{$endif}
lastlabel : plabel;
pc : pchar;
same_string : boolean;
i : word;
i : longint;
begin
clear_reference(p^.location.reference);
lastlabel:=nil;
{ const already used ? }
if p^.labstrnumber=-1 then
if not assigned(p^.lab_str) then
begin
{ tries to found an old entry }
hp1:=pai(consts^.first);
@ -173,20 +167,16 @@ implementation
(pai_string(hp1)^.len=p^.length+2) then
{$else UseAnsiString}
if (hp1^.typ=ait_string) and (lastlabel<>nil) and
(pai_string(hp1)^.len=length(p^.values^)+2) then
(pai_string(hp1)^.len=length(p^.value_str^)+2) then
{$endif UseAnsiString}
begin
same_string:=true;
{$ifndef UseAnsiString}
{ weird error here !!! }
{ pchar ' ' was found equal to string '' !!!! }
{ gave strange output in exceptions !! PM }
for i:=0 to length(p^.values^) do
if pai_string(hp1)^.str[i]<>p^.values^[i] then
for i:=0 to length(p^.value_str^) do
if pai_string(hp1)^.str[i]<>p^.value_str^[i] then
{$else}
for i:=0 to p^.length do
if pai_string(hp1)^.str[i]<>p^.values[i] then
if pai_string(hp1)^.str[i]<>p^.value_str[i] then
{$endif}
begin
same_string:=false;
@ -195,7 +185,7 @@ implementation
if same_string then
begin
{ found! }
p^.labstrnumber:=lastlabel^.nb;
p^.lab_str:=lastlabel;
break;
end;
end;
@ -204,38 +194,37 @@ implementation
hp1:=pai(hp1^.next);
end;
{ :-(, we must generate a new entry }
if p^.labstrnumber=-1 then
if not assigned(p^.lab_str) then
begin
getlabel(lastlabel);
p^.labstrnumber:=lastlabel^.nb;
getdatalabel(lastlabel);
p^.lab_str:=lastlabel;
if (cs_smartlink in aktmoduleswitches) then
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_label,init(lastlabel)));
{$ifndef UseAnsiString}
getmem(pc,length(p^.values^)+3);
move(p^.values^,pc^,length(p^.values^)+1);
pc[length(p^.values^)+1]:=#0;
concat_constlabel(lastlabel,conststring);
getmem(pc,length(p^.value_str^)+3);
move(p^.value_str^,pc^,length(p^.value_str^)+1);
pc[length(p^.value_str^)+1]:=#0;
{ we still will have a problem if there is a #0 inside the pchar }
consts^.concat(new(pai_string,init_length_pchar(pc,length(p^.values^)+2)));
consts^.concat(new(pai_string,init_length_pchar(pc,length(p^.value_str^)+2)));
{$else UseAnsiString}
{ generate an ansi string ? }
case p^.stringtype of
st_ansistring:
begin
{ an empty ansi string is nil! }
concat_constlabel(lastlabel,conststring);
if p^.length=0 then
consts^.concat(new(pai_const,init_32bit(0)))
else
begin
getlabel(l1);
consts^.concat(new(pai_const,init_symbol(strpnew(lab2str(l1)))));
consts^.concat(new(pai_const,init_32bit(p^.length)));
consts^.concat(new(pai_const,init_32bit(p^.length)));
consts^.concat(new(pai_const,init_32bit(-1)));
consts^.concat(new(pai_label,init(l1)));
getmem(pc,p^.length+1);
move(p^.values^,pc^,p^.length+1);
move(p^.value_str^,pc^,p^.length+1);
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+1)));
@ -244,9 +233,8 @@ implementation
st_shortstring:
begin
getmem(pc,p^.length+3);
move(p^.values^,pc[1],p^.length+1);
move(p^.value_str^,pc[1],p^.length+1);
pc[0]:=chr(p^.length);
concat_constlabel(lastlabel,conststring);
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+2)));
@ -255,12 +243,9 @@ implementation
{$endif UseAnsiString}
end;
end;
stringdispose(p^.location.reference.symbol);
if assigned(lastlabel) then
p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,conststring))
else
p^.location.reference.symbol:=stringdup(constlabelnb2str(p^.labstrnumber,conststring));
p^.location.loc := LOC_MEM;
clear_reference(p^.location.reference);
p^.location.reference.symbol:=stringdup(lab2str(p^.lab_str));
p^.location.loc:=LOC_MEM;
end;
@ -268,47 +253,50 @@ implementation
SecondSetCons
*****************************************************************************}
procedure secondsetcons(var p : ptree);
procedure secondsetconst(var p : ptree);
var
l : plabel;
i : longint;
href : treference;
lastlabel : plabel;
i : longint;
begin
{$ifdef SMALLSETORD}
if psetdef(p^.resulttype)^.settype=smallset then
begin
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=p^.constset^[0];
p^.location.reference.offset:=p^.value_set^[0];
end
else
begin
reset_reference(href);
getlabel(l);
stringdispose(p^.location.reference.symbol);
href.symbol:=stringdup(constlabel2str(l,constseta));
concat_constlabel(l,constseta);
getdatalabel(lastlabel);
p^.lab_set:=lastlabel;
if (cs_smartlink in aktmoduleswitches) then
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_label,init(duplabel(lastlabel))));
for i:=0 to 31 do
consts^.concat(new(pai_const,init_8bit(p^.constset^[i])));
p^.location.reference:=href;
consts^.concat(new(pai_const,init_8bit(p^.value_set^[i])));
clear_reference(p^.location.reference);
p^.location.reference.symbol:=stringdup(lab2str(p^.lab_set));
p^.location.loc:=LOC_MEM;
end;
{$else}
reset_reference(href);
getlabel(l);
stringdispose(p^.location.reference.symbol);
href.symbol:=stringdup(constlabel2str(l,constseta));
concat_constlabel(l,constseta);
getdatalabel(lastlabel);
p^.lab_set:=lastlabel;
if (cs_smartlink in aktmoduleswitches) then
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_label,init(lastlabel)));
if psetdef(p^.resulttype)^.settype=smallset then
begin
move(p^.constset^,i,sizeof(longint));
move(p^.value_set^,i,sizeof(longint));
consts^.concat(new(pai_const,init_32bit(i)));
end
else
begin
for i:=0 to 31 do
consts^.concat(new(pai_const,init_8bit(p^.constset^[i])));
consts^.concat(new(pai_const,init_8bit(p^.value_set^[i])));
end;
p^.location.reference:=href;
clear_reference(p^.location.reference);
p^.location.reference.symbol:=stringdup(lab2str(p^.lab_set));
p^.location.loc:=LOC_MEM;
{$endif SMALLSETORD}
end;
@ -328,7 +316,11 @@ implementation
end.
{
$Log$
Revision 1.12 1998-08-28 10:56:57 peter
Revision 1.13 1998-09-07 18:45:53 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.12 1998/08/28 10:56:57 peter
* removed warnings
Revision 1.11 1998/08/14 18:18:39 peter

10
compiler/cg386set.pas
View File

@ -87,7 +87,7 @@ implementation
href,href2 : Treference;
l,l2 : plabel;
function analizeset(Aset:Pconstset;is_small:boolean):boolean;
function analizeset(Aset:pconstset;is_small:boolean):boolean;
type
byteset=set of byte;
var
@ -173,7 +173,7 @@ implementation
{ Can we generate jumps? Possible for all types of sets }
if (p^.right^.treetype=setconstn) and
analizeset(p^.right^.constset,use_small) then
analizeset(p^.right^.value_set,use_small) then
begin
{ It gives us advantage to check for the set elements
separately instead of using the SET_IN_BYTE procedure.
@ -775,7 +775,11 @@ implementation
end.
{
$Log$
Revision 1.12 1998-09-05 23:51:05 florian
Revision 1.13 1998-09-07 18:45:54 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.12 1998/09/05 23:51:05 florian
* possible bug with too few registers in first/secondin fixed
Revision 1.11 1998/09/04 08:41:41 peter

10
compiler/cg68kadd.pas
View File

@ -300,9 +300,9 @@ implementation
if (p^.treetype in [equaln,unequaln]) and
(
((p^.left^.treetype=stringconstn) and
(p^.left^.values^='')) or
(p^.left^.value_str^='')) or
((p^.right^.treetype=stringconstn) and
(p^.right^.values^=''))
(p^.right^.value_str^=''))
) then
begin
{ only one node can be stringconstn }
@ -1263,7 +1263,11 @@ implementation
end.
{
$Log$
Revision 1.2 1998-09-04 08:41:42 peter
Revision 1.3 1998-09-07 18:45:55 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.2 1998/09/04 08:41:42 peter
* updated some error messages
Revision 1.1 1998/09/01 09:07:09 peter

150
compiler/cg68kcon.pas
View File

@ -33,7 +33,7 @@ interface
procedure secondfixconst(var p : ptree);
procedure secondordconst(var p : ptree);
procedure secondstringconst(var p : ptree);
procedure secondsetcons(var p : ptree);
procedure secondsetconst(var p : ptree);
procedure secondniln(var p : ptree);
@ -53,13 +53,10 @@ implementation
var
hp1 : pai;
lastlabel : plabel;
found : boolean;
begin
clear_reference(p^.location.reference);
lastlabel:=nil;
found:=false;
{ const already used ? }
if p^.labnumber=-1 then
if not assigned(p^.lab_real) then
begin
{ tries to found an old entry }
hp1:=pai(consts^.first);
@ -71,12 +68,12 @@ implementation
begin
if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then
begin
if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) or
((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then
if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.value_real)) or
((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.value_real)) or
((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.value_real)) then
begin
{ found! }
p^.labnumber:=lastlabel^.nb;
p^.lab_real:=lastlabel;
break;
end;
end;
@ -85,25 +82,25 @@ implementation
hp1:=pai(hp1^.next);
end;
{ :-(, we must generate a new entry }
if p^.labnumber=-1 then
if not assigned(p^.lab_real) then
begin
getlabel(lastlabel);
p^.labnumber:=lastlabel^.nb;
concat_constlabel(lastlabel,constreal);
getdatalabel(lastlabel);
p^.lab_real:=lastlabel;
if (cs_smartlink in aktmoduleswitches) then
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_label,init(lastlabel)));
case p^.realtyp of
ait_real_64bit : consts^.concat(new(pai_double,init(p^.valued)));
ait_real_32bit : consts^.concat(new(pai_single,init(p^.valued)));
ait_real_extended : consts^.concat(new(pai_extended,init(p^.valued)));
ait_real_64bit : consts^.concat(new(pai_double,init(p^.value_real)));
ait_real_32bit : consts^.concat(new(pai_single,init(p^.value_real)));
ait_real_extended : consts^.concat(new(pai_extended,init(p^.value_real)));
else
internalerror(10120);
end;
end;
end;
stringdispose(p^.location.reference.symbol);
if assigned(lastlabel) then
p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,constreal))
else
p^.location.reference.symbol:=stringdup(constlabelnb2str(p^.labnumber,constreal));
clear_reference(p^.location.reference);
p^.location.reference.symbol:=stringdup(lab2str(p^.lab_real));
p^.location.loc:=LOC_MEM;
end;
@ -116,7 +113,7 @@ implementation
{ an fix comma const. behaves as a memory reference }
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=p^.valuef;
p^.location.reference.offset:=p^.value_fix;
end;
@ -143,18 +140,14 @@ implementation
{$ifdef UseAnsiString}
l1,
{$endif}
lastlabel : plabel;
pc : pchar;
lastlabel : plabel;
pc : pchar;
same_string : boolean;
i : word;
i : longint;
begin
clear_reference(p^.location.reference);
lastlabel:=nil;
{ const already used ? }
if p^.labstrnumber=-1 then
if not assigned(p^.lab_str) then
begin
{ tries to found an old entry }
hp1:=pai(consts^.first);
@ -175,20 +168,16 @@ implementation
(pai_string(hp1)^.len=p^.length+2) then
{$else UseAnsiString}
if (hp1^.typ=ait_string) and (lastlabel<>nil) and
(pai_string(hp1)^.len=length(p^.values^)+2) then
(pai_string(hp1)^.len=length(p^.value_str^)+2) then
{$endif UseAnsiString}
begin
same_string:=true;
{$ifndef UseAnsiString}
{ weird error here !!! }
{ pchar ' ' was found equal to string '' !!!! }
{ gave strange output in exceptions !! PM }
for i:=0 to length(p^.values^) do
if pai_string(hp1)^.str[i]<>p^.values^[i] then
for i:=0 to length(p^.value_str^) do
if pai_string(hp1)^.str[i]<>p^.value_str^[i] then
{$else}
for i:=0 to p^.length do
if pai_string(hp1)^.str[i]<>p^.values[i] then
if pai_string(hp1)^.str[i]<>p^.value_str[i] then
{$endif}
begin
same_string:=false;
@ -197,7 +186,7 @@ implementation
if same_string then
begin
{ found! }
p^.labstrnumber:=lastlabel^.nb;
p^.lab_str:=lastlabel;
break;
end;
end;
@ -206,38 +195,37 @@ implementation
hp1:=pai(hp1^.next);
end;
{ :-(, we must generate a new entry }
if p^.labstrnumber=-1 then
if not assigned(p^.lab_str) then
begin
getlabel(lastlabel);
p^.labstrnumber:=lastlabel^.nb;
getdatalabel(lastlabel);
p^.lab_str:=lastlabel;
if (cs_smartlink in aktmoduleswitches) then
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_label,init(lastlabel)));
{$ifndef UseAnsiString}
getmem(pc,length(p^.values^)+3);
move(p^.values^,pc^,length(p^.values^)+1);
pc[length(p^.values^)+1]:=#0;
concat_constlabel(lastlabel,conststring);
getmem(pc,length(p^.value_str^)+3);
move(p^.value_str^,pc^,length(p^.value_str^)+1);
pc[length(p^.value_str^)+1]:=#0;
{ we still will have a problem if there is a #0 inside the pchar }
consts^.concat(new(pai_string,init_length_pchar(pc,length(p^.values^)+2)));
consts^.concat(new(pai_string,init_length_pchar(pc,length(p^.value_str^)+2)));
{$else UseAnsiString}
{ generate an ansi string ? }
case p^.stringtype of
st_ansistring:
begin
{ an empty ansi string is nil! }
concat_constlabel(lastlabel,conststring);
if p^.length=0 then
consts^.concat(new(pai_const,init_32bit(0)))
else
begin
getlabel(l1);
consts^.concat(new(pai_const,init_symbol(strpnew(lab2str(l1)))));
consts^.concat(new(pai_const,init_32bit(p^.length)));
consts^.concat(new(pai_const,init_32bit(p^.length)));
consts^.concat(new(pai_const,init_32bit(-1)));
consts^.concat(new(pai_label,init(l1)));
getmem(pc,p^.length+1);
move(p^.values^,pc^,p^.length+1);
move(p^.value_str^,pc^,p^.length+1);
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+1)));
@ -246,9 +234,8 @@ implementation
st_shortstring:
begin
getmem(pc,p^.length+3);
move(p^.values^,pc[1],p^.length+1);
move(p^.value_str^,pc[1],p^.length+1);
pc[0]:=chr(p^.length);
concat_constlabel(lastlabel,conststring);
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
consts^.concat(new(pai_string,init_length_pchar(pc,p^.length+2)));
@ -257,12 +244,9 @@ implementation
{$endif UseAnsiString}
end;
end;
stringdispose(p^.location.reference.symbol);
if assigned(lastlabel) then
p^.location.reference.symbol:=stringdup(constlabel2str(lastlabel,conststring))
else
p^.location.reference.symbol:=stringdup(constlabelnb2str(p^.labstrnumber,conststring));
p^.location.loc := LOC_MEM;
clear_reference(p^.location.reference);
p^.location.reference.symbol:=stringdup(lab2str(p^.lab_str));
p^.location.loc:=LOC_MEM;
end;
@ -270,47 +254,50 @@ implementation
SecondSetCons
*****************************************************************************}
procedure secondsetcons(var p : ptree);
procedure secondsetconst(var p : ptree);
var
l : plabel;
i : longint;
href : treference;
lastlabel : plabel;
i : longint;
begin
{$ifdef SMALLSETORD}
if psetdef(p^.resulttype)^.settype=smallset then
begin
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=p^.constset^[0];
p^.location.reference.offset:=p^.value_set^[0];
end
else
begin
reset_reference(href);
getlabel(l);
stringdispose(p^.location.reference.symbol);
href.symbol:=stringdup(constlabel2str(l,constseta));
concat_constlabel(l,constseta);
getdatalabel(lastlabel);
p^.lab_set:=lastlabel;
if (cs_smartlink in aktmoduleswitches) then
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_label,init(duplabel(lastlabel))));
for i:=0 to 31 do
consts^.concat(new(pai_const,init_8bit(p^.constset^[i])));
p^.location.reference:=href;
consts^.concat(new(pai_const,init_8bit(p^.value_set^[i])));
clear_reference(p^.location.reference);
p^.location.reference.symbol:=stringdup(lab2str(p^.lab_set));
p^.location.loc:=LOC_MEM;
end;
{$else}
reset_reference(href);
getlabel(l);
stringdispose(p^.location.reference.symbol);
href.symbol:=stringdup(constlabel2str(l,constseta));
concat_constlabel(l,constseta);
getdatalabel(lastlabel);
p^.lab_set:=lastlabel;
if (cs_smartlink in aktmoduleswitches) then
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_label,init(lastlabel)));
if psetdef(p^.resulttype)^.settype=smallset then
begin
move(p^.constset^,i,sizeof(longint));
move(p^.value_set^,i,sizeof(longint));
consts^.concat(new(pai_const,init_32bit(i)));
end
else
begin
for i:=0 to 31 do
consts^.concat(new(pai_const,init_8bit(p^.constset^[i])));
consts^.concat(new(pai_const,init_8bit(p^.value_set^[i])));
end;
p^.location.reference:=href;
clear_reference(p^.location.reference);
p^.location.reference.symbol:=stringdup(lab2str(p^.lab_set));
p^.location.loc:=LOC_MEM;
{$endif SMALLSETORD}
end;
@ -330,7 +317,8 @@ implementation
end.
{
$Log$
Revision 1.1 1998-09-01 09:07:09 peter
* m68k fixes, splitted cg68k like cgi386
Revision 1.2 1998-09-07 18:45:56 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
}

10
compiler/cg68kmem.pas
View File

@ -146,7 +146,7 @@ implementation
case p^.treetype of
simpledisposen:
begin
if ppointerdef(p^.left^.resulttype)^.definition^.needs_rtti then
if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then
begin
{!!!!!!!}
@ -168,7 +168,7 @@ implementation
simplenewn:
begin
emitcall('GETMEM',true);
if ppointerdef(p^.left^.resulttype)^.definition^.needs_rtti then
if ppointerdef(p^.left^.resulttype)^.definition^.needs_inittable then
begin
{!!!!!!!}
@ -691,7 +691,11 @@ implementation
end.
{
$Log$
Revision 1.1 1998-09-01 09:07:09 peter
Revision 1.2 1998-09-07 18:45:57 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.1 1998/09/01 09:07:09 peter
* m68k fixes, splitted cg68k like cgi386
}

8
compiler/cg68kset.pas
View File

@ -281,7 +281,7 @@ implementation
else
begin
if (p^.right^.treetype=setconstn) and
analizeset(p^.right^.constset) then
analizeset(p^.right^.value_set) then
begin
{It gives us advantage to check for the set elements
separately instead of using the SET_IN_BYTE procedure.
@ -812,7 +812,11 @@ implementation
end.
{
$Log$
Revision 1.2 1998-09-04 08:41:49 peter
Revision 1.3 1998-09-07 18:45:59 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.2 1998/09/04 08:41:49 peter
* updated some error messages
Revision 1.1 1998/09/01 09:07:09 peter

12
compiler/cga68k.pas
View File

@ -138,7 +138,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{ if it is a char, then simply }
{ load 0 length string }
if (p^.right^.treetype=stringconstn) and
(p^.right^.values^='') then
(p^.right^.value_str^='') then
exprasmlist^.concat(new(pai68k,op_const_ref(
A_MOVE,S_B,0,newreference(p^.left^.location.reference))))
else
@ -458,7 +458,7 @@ procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
{ This routine needs to be further checked to see if it works correctly }
{ because contrary to the intel version, all large set elements are read }
{ as 32-bit values, and then decomposed to find the correct byte. }
{ as 32-bit value_str, and then decomposed to find the correct byte. }
{ CHECKED : Depending on the result size, if reference, a load may be }
{ required on word, long or byte. }
@ -1264,7 +1264,7 @@ end;
if not ((cs_fp_emulation) in aktmoduleswitches) then
begin
{ This permits the mixing of emulation and non-emulation routines }
{ only possible for REAL = SINGLE values }
{ only possible for REAL = SINGLE value_str }
if not (location.fpureg in [R_FP0..R_FP7]) then
Begin
if s = S_FS then
@ -1345,7 +1345,11 @@ end;
end.
{
$Log$
Revision 1.14 1998-09-04 08:41:50 peter
Revision 1.15 1998-09-07 18:46:00 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.14 1998/09/04 08:41:50 peter
* updated some error messages
Revision 1.13 1998/09/01 12:48:02 peter

8
compiler/cgi386.pas
View File

@ -219,7 +219,7 @@ implementation
secondstringconst,secondfuncret,secondselfn,
secondnot,secondinline,secondniln,seconderror,
secondnothing,secondhnewn,secondhdisposen,secondnewn,
secondsimplenewdispose,secondsetelement,secondsetcons,secondblockn,
secondsimplenewdispose,secondsetelement,secondsetconst,secondblockn,
secondstatement,secondnothing,secondifn,secondbreakn,
secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
secondexitn,secondwith,secondcase,secondlabel,
@ -516,7 +516,11 @@ implementation
end.
{
$Log$
Revision 1.52 1998-09-05 23:03:58 florian
Revision 1.53 1998-09-07 18:46:03 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.52 1998/09/05 23:03:58 florian
* some fixes to get -Or work:
- inc/dec didn't take care of CREGISTER
- register calculcation of inc/dec was wrong

100
compiler/hcodegen.pas
View File

@ -143,18 +143,16 @@ unit hcodegen;
function case_get_min(root : pcaserecord) : longint;
{ concates/inserts the ASCII string to the data segment }
procedure generate_ascii(const hs : string);
procedure generate_ascii_insert(const hs : string);
procedure generate_ascii(a : paasmoutput;const hs : string);
{ concates/inserts the ASCII string from pchar to the data segment }
{ WARNING : if hs has no #0 and strlen(hs)=length }
{ the terminal zero is not written }
procedure generate_pascii(a : paasmoutput;hs : pchar;length : longint);
procedure generate_pascii_insert(hs : pchar;length : longint);
{ convert/concats a label for constants in the consts section }
function constlabel2str(l : plabel;ctype:tconsttype):string;
{ function constlabel2str(l : plabel;ctype:tconsttype):string;
function constlabelnb2str(pnb : longint;ctype:tconsttype):string;
procedure concat_constlabel(p:plabel;ctype:tconsttype);
procedure concat_constlabel(p:plabel;ctype:tconsttype); }
{ to be able to force to have a global label for const }
const
@ -336,15 +334,9 @@ implementation
String Helpers
*****************************************************************************}
procedure generate_ascii(const hs : string);
procedure generate_ascii(a : paasmoutput;const hs : string);
begin
datasegment^.concat(new(pai_string,init(hs)))
end;
procedure generate_ascii_insert(const hs : string);
begin
datasegment^.insert(new(pai_string,init(hs)));
a^.concat(new(pai_string,init(hs)))
end;
@ -387,87 +379,15 @@ implementation
end;
{ inserts the ASCII string from pchar to the const segment }
procedure generate_pascii_insert(hs : pchar;length : longint);
var
real_end,current_begin,current_end : pchar;
c :char;
begin
if assigned(hs) then
begin
current_begin:=hs;
real_end:=strend(hs);
c:=hs[0];
length:=longint(real_end)-longint(hs);
while length>32 do
begin
{ restore the char displaced }
current_begin[0]:=c;
current_end:=current_begin+32;
{ store the char for next loop }
c:=current_end[0];
current_end[0]:=#0;
datasegment^.insert(new(pai_string,init_length_pchar(strnew(current_begin,32),32)));
length:=length-32;
end;
datasegment^.insert(new(pai_string,init_length_pchar(strnew(current_begin,length),length)));
end;
end;
{*****************************************************************************
Const Helpers
*****************************************************************************}
const
consttypestr : array[tconsttype] of string[6]=
('ord','string','real','bool','int','char','set');
{ Peter this gives problems for my inlines !! }
{ we must use the number directly !!! (PM) }
function constlabel2str(l : plabel;ctype:tconsttype):string;
begin
if (cs_smartlink in aktmoduleswitches) or
make_const_global {or (aktoutputformat in [as_tasm])} then
constlabel2str:='_$'+current_module^.modulename^+'$'+consttypestr[ctype]+'_const_'+tostr(l^.nb)
else
constlabel2str:=lab2str(l);
end;
function constlabelnb2str(pnb : longint;ctype:tconsttype):string;
begin
if (cs_smartlink in aktmoduleswitches) or
make_const_global {or (aktoutputformat in [as_tasm])} then
constlabelnb2str:='_$'+current_module^.modulename^+'$'+consttypestr[ctype]+'_const_'+tostr(pnb)
else
constlabelnb2str:=target_asm.labelprefix+tostr(pnb);
end;
procedure concat_constlabel(p:plabel;ctype:tconsttype);
var
s : string;
begin
if (cs_smartlink in aktmoduleswitches) or
make_const_global {or (aktoutputformat in [as_tasm])} then
begin
s:='_$'+current_module^.modulename^+'$'+consttypestr[ctype]+'_const_'+tostr(p^.nb);
if (cs_smartlink in aktmoduleswitches) then
begin
consts^.concat(new(pai_cut,init));
consts^.concat(new(pai_symbol,init_global(s)))
end
else
consts^.concat(new(pai_symbol,init_global(s)));
end
else
consts^.concat(new(pai_label,init(p)));
end;
end.
{
$Log$
Revision 1.15 1998-09-01 09:02:51 peter
Revision 1.16 1998-09-07 18:46:04 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.15 1998/09/01 09:02:51 peter
* moved message() to hcodegen, so pass_2 also uses them
Revision 1.14 1998/08/21 14:08:43 pierre

50
compiler/pass_1.pas
View File

@ -840,8 +840,8 @@ unit pass_1;
{ both real constants ? }
if (lt=realconstn) and (rt=realconstn) then
begin
lvd:=p^.left^.valued;
rvd:=p^.right^.valued;
lvd:=p^.left^.value_real;
rvd:=p^.right^.value_real;
case p^.treetype of
addn : t:=genrealconstnode(lvd+rvd);
subn : t:=genrealconstnode(lvd-rvd);
@ -897,7 +897,7 @@ unit pass_1;
s2:=strpnew(char(byte(p^.right^.value)));
l2:=1;
{$else UseAnsiString}
s1^:=p^.left^.values^;
s1^:=p^.left^.value_str^;
s2^:=char(byte(p^.right^.value));
{$endif UseAnsiString}
concatstrings:=true;
@ -914,7 +914,7 @@ unit pass_1;
l2:=p^.right^.length;
{$else UseAnsiString}
s1^:=char(byte(p^.left^.value));
s2^:=p^.right^.values^;
s2^:=p^.right^.value_str^;
{$endif UseAnsiString}
concatstrings:=true;
end
@ -926,8 +926,8 @@ unit pass_1;
s2:=getpcharcopy(p^.right);
l2:=p^.right^.length;
{$else UseAnsiString}
s1^:=p^.left^.values^;
s2^:=p^.right^.values^;
s1^:=p^.left^.value_str^;
s2^:=p^.right^.value_str^;
{$endif UseAnsiString}
concatstrings:=true;
end;
@ -1114,31 +1114,31 @@ unit pass_1;
addn : begin
for i:=0 to 31 do
resultset^[i]:=
p^.right^.constset^[i] or p^.left^.constset^[i];
p^.right^.value_set^[i] or p^.left^.value_set^[i];
t:=gensetconstnode(resultset,psetdef(ld));
end;
muln : begin
for i:=0 to 31 do
resultset^[i]:=
p^.right^.constset^[i] and p^.left^.constset^[i];
p^.right^.value_set^[i] and p^.left^.value_set^[i];
t:=gensetconstnode(resultset,psetdef(ld));
end;
subn : begin
for i:=0 to 31 do
resultset^[i]:=
p^.left^.constset^[i] and not(p^.right^.constset^[i]);
p^.left^.value_set^[i] and not(p^.right^.value_set^[i]);
t:=gensetconstnode(resultset,psetdef(ld));
end;
symdifn : begin
for i:=0 to 31 do
resultset^[i]:=
p^.left^.constset^[i] xor p^.right^.constset^[i];
p^.left^.value_set^[i] xor p^.right^.value_set^[i];
t:=gensetconstnode(resultset,psetdef(ld));
end;
unequaln : begin
b:=true;
for i:=0 to 31 do
if p^.right^.constset^[i]=p^.left^.constset^[i] then
if p^.right^.value_set^[i]=p^.left^.value_set^[i] then
begin
b:=false;
break;
@ -1148,7 +1148,7 @@ unit pass_1;
equaln : begin
b:=true;
for i:=0 to 31 do
if p^.right^.constset^[i]<>p^.left^.constset^[i] then
if p^.right^.value_set^[i]<>p^.left^.value_set^[i] then
begin
b:=false;
break;
@ -1607,7 +1607,7 @@ unit pass_1;
begin
{why this !!! lost of dummy type definitions
one per const string !!!
p^.resulttype:=new(pstringdef,init(length(p^.values^)));}
p^.resulttype:=new(pstringdef,init(length(p^.value_str^)));}
if cs_ansistrings in aktlocalswitches then
p^.resulttype:=cansistringdef
else
@ -1646,7 +1646,7 @@ unit pass_1;
{$endif}
then
begin
t:=genrealconstnode(-p^.left^.valued);
t:=genrealconstnode(-p^.left^.value_real);
disposetree(p);
firstpass(t);
p:=t;
@ -2303,7 +2303,7 @@ unit pass_1;
begin
{ convert constants direct }
p^.treetype:=fixconstn;
p^.valuef:=p^.left^.value shl 16;
p^.value_fix:=p^.left^.value shl 16;
p^.disposetyp:=dt_nothing;
disposetree(p^.left);
p^.location.loc:=LOC_MEM;
@ -2323,7 +2323,7 @@ unit pass_1;
begin
{ convert constants direct }
p^.treetype:=fixconstn;
p^.valuef:=round(p^.left^.valued*65536);
p^.value_fix:=round(p^.left^.value_real*65536);
p^.disposetyp:=dt_nothing;
disposetree(p^.left);
p^.location.loc:=LOC_MEM;
@ -2346,7 +2346,7 @@ unit pass_1;
begin
{ convert constants direct }
p^.treetype:=realconstn;
p^.valued:=round(p^.left^.valuef/65536.0);
p^.value_real:=round(p^.left^.value_fix/65536.0);
p^.disposetyp:=dt_nothing;
disposetree(p^.left);
p^.location.loc:=LOC_MEM;
@ -2567,7 +2567,7 @@ unit pass_1;
exit;
end;
{ load the values from the left part }
{ load the value_str from the left part }
p^.registers32:=p^.left^.registers32;
p^.registersfpu:=p^.left^.registersfpu;
{$ifdef SUPPORT_MMX}
@ -3688,7 +3688,7 @@ unit pass_1;
if ret_in_param(p^.retdef) or
(@procinfo<>pprocinfo(p^.funcretprocinfo)) then
p^.registers32:=1;
{ no claim if setting higher return values }
{ no claim if setting higher return value_str }
if must_be_valid and
(@procinfo=pprocinfo(p^.funcretprocinfo)) and
not procinfo.funcret_is_valid then
@ -3768,7 +3768,7 @@ unit pass_1;
begin
isreal:=(p^.left^.treetype=realconstn);
vl:=p^.left^.value;
vr:=p^.left^.valued;
vr:=p^.left^.value_real;
case p^.inlinenumber of
in_const_trunc : begin
if isreal then
@ -3970,7 +3970,7 @@ unit pass_1;
{$ifdef UseAnsiString}
hp:=genordinalconstnode(p^.left^.length,s32bitdef);
{$else UseAnsiString}
hp:=genordinalconstnode(length(p^.left^.values^),s32bitdef);
hp:=genordinalconstnode(length(p^.left^.value_str^),s32bitdef);
{$endif UseAnsiString}
disposetree(p);
firstpass(hp);
@ -4950,7 +4950,7 @@ unit pass_1;
begin
{ it's a f... to determine the used registers }
{ should be done by getnode
I think also, that all values should be set to their maximum (FK)
I think also, that all value_str should be set to their maximum (FK)
p^.registers32:=0;
p^.registersfpu:=0;
p^.registersmmx:=0;
@ -5456,7 +5456,11 @@ unit pass_1;
end.
{
$Log$
Revision 1.75 1998-09-05 23:51:06 florian
Revision 1.76 1998-09-07 18:46:05 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.75 1998/09/05 23:51:06 florian
* possible bug with too few registers in first/secondin fixed
Revision 1.74 1998/09/05 23:04:00 florian

18
compiler/pass_2.pas
View File

@ -72,7 +72,6 @@ implementation
procedure seconderror(var p : ptree);
begin
p^.error:=true;
codegenerror:=true;
@ -110,15 +109,12 @@ implementation
if not p^.object_preserved then
begin
{$ifdef i386}
maybe_loadesi;
{$endif}
{$ifdef m68k}
maybe_loada5;
{$endif}
end;
end;
@ -173,7 +169,7 @@ implementation
secondnewn, {newn}
secondsimplenewdispose, {simpledisposen}
secondsetelement, {setelementn}
secondsetcons, {setconstn}
secondsetconst, {setconstn}
secondblockn, {blockn}
secondstatement, {statementn}
secondnothing, {loopn}
@ -213,7 +209,6 @@ implementation
oldcodegenerror:=codegenerror;
oldlocalswitches:=aktlocalswitches;
oldpos:=aktfilepos;
aktfilepos:=p^.fileinfo;
aktlocalswitches:=p^.localswitches;
@ -221,7 +216,6 @@ implementation
procedures[p^.treetype](p);
p^.error:=codegenerror;
codegenerror:=codegenerror or oldcodegenerror;
aktlocalswitches:=oldlocalswitches;
aktfilepos:=oldpos;
@ -248,10 +242,8 @@ implementation
parasym : boolean;
procedure searchregvars(p : psym);
var
i,j,k : longint;
begin
if (p^.typ=varsym) and ((pvarsym(p)^.var_options and vo_regable)<>0) then
begin
@ -403,7 +395,6 @@ implementation
regvars[i]^.reg:=reg32toreg8(varregs[i]);
{$endif}
regsize:=S_B;
end
else if (regvars[i]^.definition^.deftype=orddef) and
@ -413,7 +404,6 @@ implementation
regvars[i]^.reg:=reg32toreg16(varregs[i]);
{$endif}
regsize:=S_W;
end
else
@ -485,7 +475,11 @@ implementation
end.
{
$Log$
Revision 1.1 1998-09-01 09:07:12 peter
Revision 1.2 1998-09-07 18:46:07 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.1 1998/09/01 09:07:12 peter
* m68k fixes, splitted cg68k like cgi386
}

21
compiler/pdecl.pas
View File

@ -114,26 +114,25 @@ unit pdecl;
else internalerror(111);
end;
stringconstn:
{values is disposed with p so I need a copy !}
{value_str is disposed with p so I need a copy !}
{$ifdef USEANSISTRING} begin
getmem(sp,p^.length+1);
move(p^.values^,sp^[1],p^.length);
move(p^.value_str^,sp^[1],p^.length);
sp^[0]:=chr(p^.length);
symtablestack^.insert(new(pconstsym,init(name,conststring,longint(sp),nil)));
end;
{$else USEANSISTRING}
symtablestack^.insert(new(pconstsym,init(name,conststring,longint(stringdup(p^.values^)),nil)));
symtablestack^.insert(new(pconstsym,init(name,conststring,longint(stringdup(p^.value_str^)),nil)));
{$endif USEANSISTRING}
realconstn : begin
new(pd);
pd^:=p^.valued;
pd^:=p^.value_real;
symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd),nil)));
end;
setconstn : begin
new(ps);
ps^:=p^.constset^;
symtablestack^.insert(new(pconstsym,init(name,
constseta,longint(ps),p^.resulttype)));
ps^:=p^.value_set^;
symtablestack^.insert(new(pconstsym,init(name,constset,longint(ps),p^.resulttype)));
end;
else Message(cg_e_illegal_expression);
end;
@ -1670,7 +1669,7 @@ unit pdecl;
LKLAMMER:
begin
consume(LKLAMMER);
{ allow negativ values }
{ allow negativ value_str }
l:=-1;
aufsym := Nil;
aufdef:=new(penumdef,init);
@ -1970,7 +1969,11 @@ unit pdecl;
end.
{
$Log$
Revision 1.49 1998-09-07 17:37:00 florian
Revision 1.50 1998-09-07 18:46:08 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.49 1998/09/07 17:37:00 florian
* first fixes for published properties
Revision 1.48 1998/09/04 08:42:02 peter

18
compiler/pexpr.pas
View File

@ -911,7 +911,7 @@ unit pexpr;
constchar : p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
constreal : p1:=genrealconstnode(pbestreal(pconstsym(srsym)^.value)^);
constbool : p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
constseta : p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
constset : p1:=gensetconstnode(pconstset(pconstsym(srsym)^.value),
psetdef(pconstsym(srsym)^.definition));
constord : p1:=genordinalconstnode(pconstsym(srsym)^.value,
pconstsym(srsym)^.definition);
@ -1018,7 +1018,7 @@ unit pexpr;
constsetlo:=0;
constsethi:=0;
constp:=gensinglenode(setconstn,nil);
constp^.constset:=constset;
constp^.value_set:=constset;
buildp:=constp;
pd:=nil;
if token<>RECKKLAMMER then
@ -1102,8 +1102,8 @@ unit pexpr;
if not(is_equal(pd,cchardef)) then
Message(type_e_typeconflict_in_set)
else
for l:=1 to length(pstring(p2^.values)^) do
do_set(ord(pstring(p2^.values)^[l]));
for l:=1 to length(pstring(p2^.value_str)^) do
do_set(ord(pstring(p2^.value_str)^[l]));
disposetree(p2);
end;
else
@ -1147,7 +1147,7 @@ unit pexpr;
---------------------------------------------}
procedure postfixoperators;
{ p1 and p2 must contain valid values }
{ p1 and p2 must contain valid value_str }
begin
check_tokenpos;
while again do
@ -1850,14 +1850,18 @@ unit pexpr;
Message(cg_e_illegal_expression);
end
else
get_stringconst:=p^.values^;
get_stringconst:=p^.value_str^;
disposetree(p);
end;
end.
{
$Log$
Revision 1.46 1998-09-04 08:42:03 peter
Revision 1.47 1998-09-07 18:46:10 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.46 1998/09/04 08:42:03 peter
* updated some error messages
Revision 1.45 1998/09/01 17:39:49 peter

41
compiler/ptconst.pas
View File

@ -131,7 +131,7 @@ unit ptconst;
p:=comp_expr(true);
do_firstpass(p);
if is_constrealnode(p) then
value:=p^.valued
value:=p^.value_real
else if is_constintnode(p) then
value:=p^.value
else
@ -159,11 +159,11 @@ unit ptconst;
if (ppointerdef(def)^.definition^.deftype=orddef) and
(porddef(ppointerdef(def)^.definition)^.typ=uchar) then
begin
getlabel(ll);
getdatalabel(ll);
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
consts^.concat(new(pai_label,init(ll)));
if p^.treetype=stringconstn then
consts^.concat(new(pai_string,init(p^.values^+#0)))
consts^.concat(new(pai_string,init(p^.value_str^+#0)))
else
if is_constcharnode(p) then
consts^.concat(new(pai_string,init(char(byte(p^.value))+#0)))
@ -219,7 +219,7 @@ unit ptconst;
begin
{$ifdef i386}
for l:=0 to def^.savesize-1 do
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[l])));
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[l])));
{$endif}
{$ifdef m68k}
j:=0;
@ -227,10 +227,10 @@ unit ptconst;
{ HORRIBLE HACK because of endian }
{ now use intel endian for constant sets }
begin
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+3])));
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+2])));
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+1])));
datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j])));
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+3])));
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+2])));
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[j+1])));
datasegment^.concat(new(pai_const,init_8bit(p^.value_set^[j])));
Inc(j,4);
end;
{$endif}
@ -272,19 +272,18 @@ unit ptconst;
strlength:=p^.length;
datasegment^.concat(new(pai_const,init_8bit(strlength)));
{ this can also handle longer strings }
generate_pascii(datasegment,p^.values,strlength);
generate_pascii(datasegment,p^.value_str,strlength);
{$else UseAnsiString}
if length(p^.values^)>=def^.size then
if length(p^.value_str^)>=def^.size then
begin
strlength:=def^.size-1;
generate_ascii(char(strlength)+copy(p^.values^,1,strlength));
generate_ascii(datasegment,char(strlength)+copy(p^.value_str^,1,strlength));
end
else
begin
strlength:=length(p^.values^);
generate_ascii(char(strlength)+p^.values^);
strlength:=length(p^.value_str^);
generate_ascii(datasegment,char(strlength)+p^.value_str^);
end;
{$endif UseAnsiString}
end
else if is_constcharnode(p) then
@ -319,7 +318,7 @@ unit ptconst;
if p^.treetype=stringconstn then
begin
{ this can also handle longer strings }
generate_pascii(consts,p^.values,p^.length);
generate_pascii(consts,p^.value_str,p^.length);
end
else if is_constcharnode(p) then
begin
@ -338,7 +337,7 @@ unit ptconst;
datasegment^.concat(new(pai_const,init_32bit(0)))
else
begin
getlabel(ll);
getdatalabel(ll);
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
{ first write the maximum size }
consts^.concat(new(pai_const,init_32bit(p^.length)));
@ -355,7 +354,7 @@ unit ptconst;
if p^.treetype=stringconstn then
begin
{ this can also handle longer strings }
generate_pascii(consts,p^.values,p^.length);
generate_pascii(consts,p^.value_str,p^.length);
end
else if is_constcharnode(p) then
begin
@ -388,7 +387,7 @@ unit ptconst;
p:=comp_expr(true);
do_firstpass(p);
if p^.treetype=stringconstn then
s:=p^.values^
s:=p^.value_str^
else if is_constcharnode(p) then
s:=char(byte(p^.value))
else Message(cg_e_illegal_expression);
@ -512,7 +511,11 @@ unit ptconst;
end.
{
$Log$
Revision 1.14 1998-09-04 08:42:07 peter
Revision 1.15 1998-09-07 18:46:11 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.14 1998/09/04 08:42:07 peter
* updated some error messages
Revision 1.13 1998/09/01 09:05:36 peter

14
compiler/symsym.inc
View File

@ -1277,7 +1277,7 @@
pd^:=readreal;
value:=longint(pd);
end;
constseta : begin
constset : begin
definition:=readdefref;
new(ps);
readnormalset(ps^);
@ -1294,7 +1294,7 @@
case consttype of
conststring : stringdispose(pstring(value));
constreal : dispose(pbestreal(value));
constseta : dispose(pnormalset(value));
constset : dispose(pnormalset(value));
end;
inherited done;
end;
@ -1308,7 +1308,7 @@
procedure tconstsym.deref;
begin
if consttype in [constord,constseta] then
if consttype in [constord,constset] then
resolvedef(pdef(definition));
end;
@ -1327,7 +1327,7 @@
end;
conststring : writestring(pstring(value)^);
constreal : writereal(pbestreal(value)^);
constseta : begin
constset : begin
writedefref(definition);
writenormalset(pointer(value)^);
end;
@ -1624,7 +1624,11 @@
{
$Log$
Revision 1.40 1998-09-07 17:37:04 florian
Revision 1.41 1998-09-07 18:46:12 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.40 1998/09/07 17:37:04 florian
* first fixes for published properties
Revision 1.39 1998/09/05 22:11:02 florian

121
compiler/tree.pas
View File

@ -151,9 +151,8 @@ unit tree;
{ allows to determine which elementes are to be replaced }
tdisposetyp = (dt_nothing,dt_leftright,dt_left,
dt_mbleft,dt_string,dt_typeconv,dt_inlinen,
dt_mbleft_and_method,dt_constset,dt_loop,dt_case,
dt_with,dt_onn);
dt_mbleft,dt_typeconv,dt_inlinen,
dt_mbleft_and_method,dt_loop,dt_case,dt_with,dt_onn);
{ different assignment types }
@ -210,23 +209,21 @@ unit tree;
methodpointer : ptree;
no_check,unit_specific,return_value_used : boolean);
ordconstn : (value : longint);
realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
fixconstn : (valuef: longint);
realconstn : (value_real : bestreal;lab_real : plabel;realtyp : tait);
fixconstn : (value_fix: longint);
funcretn : (funcretprocinfo : pointer;retdef : pdef);
subscriptn : (vs : pvarsym);
vecn : (memindex,memseg:boolean);
{ stringconstn : (length : longint; values : pstring;labstrnumber : longint); }
{ string const can be longer then 255 with ansistring !! }
{$ifdef UseAnsiString}
stringconstn : (values : pchar;length : longint; labstrnumber : longint;stringtype : tstringtype);
stringconstn : (value_str : pchar;length : longint; lab_str : plabel;stringtype : tstringtype);
{$else UseAnsiString}
stringconstn : (values : pstring; labstrnumber : longint;stringtype : tstringtype);
stringconstn : (value_str : pstring; lab_str:plabel;stringtype : tstringtype);
{$endif UseAnsiString}
typeconvn : (convtyp : tconverttype;explizit : boolean);
inlinen : (inlinenumber : longint;inlineconst:boolean);
procinlinen : (inlineprocdef : pprocdef;
retoffset,para_offset,para_size : longint);
setconstn : (constset : pconstset);
setconstn : (value_set : pconstset;lab_set:plabel);
loopn : (t1,t2 : ptree;backward : boolean);
asmn : (p_asm : paasmoutput;object_preserved : boolean);
casen : (nodes : pcaserecord;elseblock : ptree);
@ -333,21 +330,22 @@ unit tree;
case p^.treetype of
asmn : if assigned(p^.p_asm) then
dispose(p^.p_asm,done);
setconstn : if assigned(p^.constset) then
dispose(p^.constset);
stringconstn : begin
{$ifndef UseAnsiString}
stringdispose(p^.value_str);
{$else UseAnsiString}
ansistringdispose(p^.value_str,p^.length);
{$endif UseAnsiString}
end;
setconstn : begin
if assigned(p^.value_set) then
dispose(p^.value_set);
end;
end;
{ reference info }
if (p^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
assigned(p^.location.reference.symbol) then
stringdispose(p^.location.reference.symbol);
{$ifndef UseAnsiString}
if p^.disposetyp=dt_string then
stringdispose(p^.values);
{$else UseAnsiString}
if p^.disposetyp=dt_string then
ansistringdispose(p^.values,p^.length);
{$endif UseAnsiString}
{$ifdef extdebug}
if p^.firstpasscount>maxfirstpasscount then
maxfirstpasscount:=p^.firstpasscount;
@ -397,20 +395,27 @@ unit tree;
if assigned(p^.t2) then
hp^.t2:=getcopy(p^.t2);
end;
{$ifdef UseAnsiString}
dt_string : begin
hp^.values:=getpcharcopy(p);
hp^.length:=p^.length;
end;
{$else UseAnsiString}
dt_string : hp^.values:=stringdup(p^.values^);
{$endif UseAnsiString}
dt_typeconv : hp^.left:=getcopy(p^.left);
dt_inlinen :
if assigned(p^.left) then
hp^.left:=getcopy(p^.left);
else internalerror(11);
end;
{ now check treetype }
case p^.treetype of
stringconstn : begin
{$ifdef UseAnsiString}
hp^.value_str:=getpcharcopy(p);
hp^.length:=p^.length;
{$else UseAnsiString}
hp^.value_str:=stringdup(p^.value_str^);
{$endif UseAnsiString}
end;
setconstn : begin
new(hp^.value_set);
hp^.value_set:=p^.value_set;
end;
end;
getcopy:=hp;
end;
@ -436,7 +441,6 @@ unit tree;
end;
procedure disposetree(p : ptree);
begin
@ -473,21 +477,6 @@ unit tree;
if assigned(p^.left) then disposetree(p^.left);
disposetree(p^.methodpointer);
end;
{$ifdef UseAnsiString}
dt_string : ansistringdispose(p^.values,p^.length);
{$else UseAnsiString}
dt_string : stringdispose(p^.values);
{$endif UseAnsiString}
dt_constset :
begin
if assigned(p^.constset) then
begin
dispose(p^.constset);
p^.constset:=nil;
end;
if assigned(p^.left) then
disposetree(p^.left);
end;
dt_typeconv : disposetree(p^.left);
dt_inlinen :
if assigned(p^.left) then
@ -740,17 +729,17 @@ unit tree;
{$endif SUPPORT_MMX}
{$ifdef i386}
p^.resulttype:=c64floatdef;
p^.valued:=v;
p^.value_real:=v;
{ default value is double }
p^.realtyp:=ait_real_64bit;
{$endif}
{$ifdef m68k}
p^.resulttype:=new(pfloatdef,init(s32real));
p^.valued:=v;
p^.value_real:=v;
{ default value is double }
p^.realtyp:=ait_real_32bit;
{$endif}
p^.labnumber:=-1;
p^.lab_real:=nil;
genrealconstnode:=p;
end;
@ -763,7 +752,7 @@ unit tree;
{$endif UseAnsiString}
begin
p:=getnode;
p^.disposetyp:=dt_string;
p^.disposetyp:=dt_nothing;
p^.treetype:=stringconstn;
p^.registers32:=0;
{ p^.registers16:=0;
@ -777,13 +766,13 @@ unit tree;
l:=length(s);
p^.length:=l;
{ stringdup write even past a #0 }
getmem(p^.values,l+1);
move(s[1],p^.values^,l);
p^.values[l]:=#0;
getmem(p^.value_str,l+1);
move(s[1],p^.value_str^,l);
p^.value_str[l]:=#0;
{$else UseAnsiString}
p^.values:=stringdup(s);
p^.value_str:=stringdup(s);
{$endif UseAnsiString}
p^.labstrnumber:=-1;
p^.lab_str:=nil;
p^.stringtype:=st_shortstring;
genstringconstnode:=p;
end;
@ -800,7 +789,7 @@ unit tree;
{ Peter can you change that ? }
if pc=nil then
Message(general_f_no_memory_left);
move(p^.values^,pc^,p^.length+1);
move(p^.value_str^,pc^,p^.length+1);
getpcharcopy:=pc;
end;
@ -811,7 +800,7 @@ unit tree;
begin
p:=getnode;
p^.disposetyp:=dt_string;
p^.disposetyp:=dt_nothing;
p^.treetype:=stringconstn;
p^.registers32:=0;
{ p^.registers16:=0;
@ -822,8 +811,8 @@ unit tree;
{$endif SUPPORT_MMX}
p^.resulttype:=cstringdef;
p^.length:=length;
p^.values:=s;
p^.labstrnumber:=-1;
p^.value_str:=s;
p^.lab_str:=nil;
genpcharconstnode:=p;
end;
{$endif UseAnsiString}
@ -1137,7 +1126,7 @@ unit tree;
begin
p:=getnode;
p^.disposetyp:=dt_constset;
p^.disposetyp:=dt_nothing;
p^.treetype:=setconstn;
p^.registers32:=0;
p^.registersfpu:=0;
@ -1146,8 +1135,8 @@ unit tree;
{$endif SUPPORT_MMX}
p^.resulttype:=settype;
p^.left:=nil;
new(p^.constset);
p^.constset^:=s^;
new(p^.value_set);
p^.value_set^:=s^;
gensetconstnode:=p;
end;
@ -1389,12 +1378,12 @@ unit tree;
funcretn : (funcretprocinfo : pointer;retdef : pdef);
subscriptn : (vs : pvarsym);
vecn : (memindex,memseg:boolean);
{ stringconstn : (length : longint; values : pstring;labstrnumber : longint); }
{ stringconstn : (length : longint; value_str : pstring;labstrnumber : longint); }
{ string const can be longer then 255 with ansistring !! }
{$ifdef UseAnsiString}
stringconstn : (values : pchar;length : longint; labstrnumber : longint);
stringconstn : (value_str : pchar;length : longint; labstrnumber : longint);
{$else UseAnsiString}
stringconstn : (values : pstring; labstrnumber : longint);
stringconstn : (value_str : pstring; labstrnumber : longint);
{$endif UseAnsiString}
typeconvn : (convtyp : tconverttype;explizit : boolean);
inlinen : (inlinenumber : longint);
@ -1556,7 +1545,11 @@ unit tree;
end.
{
$Log$
Revision 1.35 1998-09-04 08:42:11 peter
Revision 1.36 1998-09-07 18:46:17 peter
* update smartlinking, uses getdatalabel
* renamed ptree.value vars to value_str,value_real,value_set
Revision 1.35 1998/09/04 08:42:11 peter
* updated some error messages
Revision 1.34 1998/09/01 17:39:54 peter