paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-02 19:22:05 +01:00
Code Issues Packages Projects Releases Wiki Activity

* indirect type referencing is now allowed

Browse Source
This commit is contained in:
peter 1999-07-27 23:42:10 +00:00
parent bdd61f119c
commit 30be2bf063
9 changed files with 521 additions and 333 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
compiler/pbase.pas
View File

@ -78,10 +78,6 @@ unit pbase;
{ reads a list of identifiers into a string container }
function idlist : pstringcontainer;
{ inserts the symbols of sc in st with def as definition }
{ sc is disposed }
procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef;is_threadvar : boolean);
{ just for an accurate position of the end of a procedure (PM) }
var
last_endtoken_filepos: tfileposinfo;
@ -165,41 +161,14 @@ unit pbase;
idlist:=sc;
end;
{ inserts the symbols of sc in st with def as definition }
{ sc is disposed }
procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef;is_threadvar : boolean);
var
s : string;
filepos : tfileposinfo;
ss : pvarsym;
begin
filepos:=tokenpos;
while not sc^.empty do
begin
s:=sc^.get_with_tokeninfo(tokenpos);
ss:=new(pvarsym,init(s,def));
if is_threadvar then
ss^.var_options:=ss^.var_options or vo_is_thread_var;
st^.insert(ss);
{ static data fields are inserted in the globalsymtable }
if (st^.symtabletype=objectsymtable) and
((current_object_option and sp_static)<>0) then
begin
s:=lower(st^.name^)+'_'+s;
st^.defowner^.owner^.insert(new(pvarsym,init(s,def)));
end;
end;
dispose(sc,done);
tokenpos:=filepos;
end;
end.
{
$Log$
Revision 1.22 1999-07-26 09:42:10 florian
Revision 1.23 1999-07-27 23:42:10 peter
* indirect type referencing is now allowed
Revision 1.22 1999/07/26 09:42:10 florian
* bugs 494-496 fixed
Revision 1.21 1999/04/28 06:02:05 florian

443
compiler/pdecl.pas
View File

@ -31,6 +31,7 @@ unit pdecl;
{ pointer to the last read type symbol, (for "forward" }
{ types) }
lasttypesym : ptypesym;
readtypesym : ptypesym; { ttypesym read by read_type }
{ hack, which allows to use the current parsed }
{ object type as function argument type }
@ -190,10 +191,20 @@ unit pdecl;
tokenpos:=filepos;
{$ifdef DELPHI_CONST_IN_RODATA}
if m_delphi in aktmodeswitches then
sym:=new(ptypedconstsym,init(name,def,true))
begin
if assigned(readtypesym) then
sym:=new(ptypedconstsym,initsym(name,readtypesym,true))
else
sym:=new(ptypedconstsym,init(name,def,true))
end
else
{$endif DELPHI_CONST_IN_RODATA}
sym:=new(ptypedconstsym,init(name,def,false));
begin
if assigned(readtypesym) then
sym:=new(ptypedconstsym,initsym(name,readtypesym,false))
else
sym:=new(ptypedconstsym,init(name,def,false))
end;
tokenpos:=storetokenpos;
symtablestack^.insert(sym);
consume(EQUAL);
@ -247,6 +258,40 @@ unit pdecl;
{ types are allowed }
{ => the procedure is also used to read }
{ a sequence of variable declaration }
procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef;sym:ptypesym;is_threadvar : boolean);
{ inserts the symbols of sc in st with def as definition or sym as ptypesym, sc is disposed }
var
s : string;
filepos : tfileposinfo;
ss : pvarsym;
begin
{ can't have a definition and ttypesym }
if assigned(def) and assigned(sym) then
internalerror(5438257);
filepos:=tokenpos;
while not sc^.empty do
begin
s:=sc^.get_with_tokeninfo(tokenpos);
if assigned(sym) then
ss:=new(pvarsym,initsym(s,sym))
else
ss:=new(pvarsym,init(s,def));
if is_threadvar then
ss^.var_options:=ss^.var_options or vo_is_thread_var;
st^.insert(ss);
{ static data fields are inserted in the globalsymtable }
if (st^.symtabletype=objectsymtable) and
((current_object_option and sp_static)<>0) then
begin
s:=lower(st^.name^)+'_'+s;
st^.defowner^.owner^.insert(new(pvarsym,init(s,def)));
end;
end;
dispose(sc,done);
tokenpos:=filepos;
end;
var
sc : pstringcontainer;
s : stringid;
@ -403,7 +448,10 @@ unit pdecl;
s:=sc^.get_with_tokeninfo(tokenpos);
if not sc^.empty then
Message(parser_e_initialized_only_one_var);
pconstsym:=new(ptypedconstsym,init(s,p,false));
if assigned(readtypesym) then
pconstsym:=new(ptypedconstsym,initsym(s,readtypesym,false))
else
pconstsym:=new(ptypedconstsym,init(s,p,false));
symtablestack^.insert(pconstsym);
tokenpos:=storetokenpos;
consume(EQUAL);
@ -482,14 +530,24 @@ unit pdecl;
storetokenpos:=tokenpos;
tokenpos:=declarepos;
if is_dll then
aktvarsym:=new(pvarsym,init_dll(s,p))
begin
if assigned(readtypesym) then
aktvarsym:=new(pvarsym,initsym_dll(s,readtypesym))
else
aktvarsym:=new(pvarsym,init_dll(s,p))
end
else
aktvarsym:=new(pvarsym,init_C(s,C_name,p));
begin
if assigned(readtypesym) then
aktvarsym:=new(pvarsym,initsym_C(s,C_name,readtypesym))
else
aktvarsym:=new(pvarsym,init_C(s,C_name,p));
end;
{ set some vars options }
if export_aktvarsym then
inc(aktvarsym^.refs);
if extern_aktvarsym then
aktvarsym^.var_options:=aktvarsym^.var_options or vo_is_external;
aktvarsym^.var_options:=aktvarsym^.var_options or vo_is_external;
{ insert in the stack/datasegment }
symtablestack^.insert(aktvarsym);
tokenpos:=storetokenpos;
@ -513,7 +571,10 @@ unit pdecl;
if (is_object) and (cs_static_keyword in aktmoduleswitches) and (idtoken=_STATIC) then
begin
current_object_option:=current_object_option or sp_static;
insert_syms(symtablestack,sc,p,false);
if assigned(readtypesym) then
insert_syms(symtablestack,sc,nil,readtypesym,false)
else
insert_syms(symtablestack,sc,p,nil,false);
current_object_option:=current_object_option - sp_static;
consume(_STATIC);
consume(SEMICOLON);
@ -526,7 +587,10 @@ unit pdecl;
if (current_object_option=sp_published) and
(not((p^.deftype=objectdef) and (pobjectdef(p)^.isclass))) then
Message(parser_e_cant_publish_that);
insert_syms(symtablestack,sc,p,is_threadvar);
if assigned(readtypesym) then
insert_syms(symtablestack,sc,nil,readtypesym,is_threadvar)
else
insert_syms(symtablestack,sc,p,nil,is_threadvar);
end;
end;
{ Check for Case }
@ -669,6 +733,11 @@ unit pdecl;
testforward_type(srsym);
end;
lasttypesym:=ptypesym(srsym);
if (ptypesym(srsym)^.owner^.unitid=0) or
(ptypesym(srsym)^.owner^.unitid=1) then
readtypesym:=nil
else
readtypesym:=ptypesym(srsym);
id_type:=ptypesym(srsym)^.definition;
end;
@ -679,12 +748,14 @@ unit pdecl;
var
hs : string;
begin
readtypesym:=nil;
case token of
_STRING:
begin
single_type:=stringtype;
s:='STRING';
lasttypesym:=nil;
readtypesym:=nil;
end;
_FILE:
begin
@ -702,8 +773,12 @@ unit pdecl;
s:='FILE';
end;
lasttypesym:=nil;
readtypesym:=nil;
end;
else single_type:=id_type(s);
else
begin
single_type:=id_type(s);
end;
end;
end;
@ -1557,102 +1632,99 @@ unit pdecl;
{ reads a type definition and returns a pointer to it }
function read_type(const name : stringid) : pdef;
function handle_procvar:Pprocvardef;
var
sc : pstringcontainer;
hs1,s : string;
p : pdef;
varspez : tvarspez;
procvardef : pprocvardef;
begin
procvardef:=new(pprocvardef,init);
if token=LKLAMMER then
begin
consume(LKLAMMER);
inc(testcurobject);
repeat
if try_to_consume(_VAR) then
varspez:=vs_var
else
if try_to_consume(_CONST) then
varspez:=vs_const
else
varspez:=vs_value;
{ self method ? }
if idtoken=_SELF then
begin
procvardef^.options:=procvardef^.options or pocontainsself;
consume(idtoken);
consume(COLON);
p:=single_type(hs1);
procvardef^.concatdef(p,vs_value);
end
else
begin
sc:=idlist;
if (token=COLON) or (varspez=vs_value) then
function handle_procvar:Pprocvardef;
var
sc : pstringcontainer;
hs1,s : string;
p : pdef;
varspez : tvarspez;
procvardef : pprocvardef;
begin
procvardef:=new(pprocvardef,init);
if token=LKLAMMER then
begin
consume(LKLAMMER);
inc(testcurobject);
repeat
if try_to_consume(_VAR) then
varspez:=vs_var
else
if try_to_consume(_CONST) then
varspez:=vs_const
else
varspez:=vs_value;
{ self method ? }
if idtoken=_SELF then
begin
consume(COLON);
if token=_ARRAY then
begin
consume(_ARRAY);
consume(_OF);
{ define range and type of range }
p:=new(Parraydef,init(0,-1,s32bitdef));
{ array of const ? }
if (token=_CONST) and (m_objpas in aktmodeswitches) then
begin
consume(_CONST);
srsym:=nil;
if assigned(objpasunit) then
getsymonlyin(objpasunit,'TVARREC');
if not assigned(srsym) then
InternalError(1234124);
Parraydef(p)^.definition:=ptypesym(srsym)^.definition;
Parraydef(p)^.IsArrayOfConst:=true;
end
else
begin
{ define field type }
Parraydef(p)^.definition:=single_type(s);
end;
end
else
p:=single_type(s);
procvardef^.options:=procvardef^.options or pocontainsself;
consume(idtoken);
consume(COLON);
p:=single_type(hs1);
procvardef^.concatdef(p,vs_value);
end
else
p:=cformaldef;
while not sc^.empty do
else
begin
s:=sc^.get;
procvardef^.concatdef(p,varspez);
sc:=idlist;
if (token=COLON) or (varspez=vs_value) then
begin
consume(COLON);
if token=_ARRAY then
begin
consume(_ARRAY);
consume(_OF);
{ define range and type of range }
p:=new(Parraydef,init(0,-1,s32bitdef));
{ array of const ? }
if (token=_CONST) and (m_objpas in aktmodeswitches) then
begin
consume(_CONST);
srsym:=nil;
if assigned(objpasunit) then
getsymonlyin(objpasunit,'TVARREC');
if not assigned(srsym) then
InternalError(1234124);
Parraydef(p)^.definition:=ptypesym(srsym)^.definition;
Parraydef(p)^.IsArrayOfConst:=true;
end
else
begin
{ define field type }
Parraydef(p)^.definition:=single_type(s);
end;
end
else
p:=single_type(s);
end
else
p:=cformaldef;
while not sc^.empty do
begin
s:=sc^.get;
procvardef^.concatdef(p,varspez);
end;
dispose(sc,done);
end;
dispose(sc,done);
end;
until not try_to_consume(SEMICOLON);
dec(testcurobject);
consume(RKLAMMER);
end;
handle_procvar:=procvardef;
end;
until not try_to_consume(SEMICOLON);
dec(testcurobject);
consume(RKLAMMER);
end;
handle_procvar:=procvardef;
end;
var
hp1,p : pdef;
aufdef : penumdef;
aufsym : penumsym;
ap : parraydef;
s : stringid;
l,v : longint;
oldaktpackrecords : tpackrecords;
hs : string;
procedure expr_type;
pt : ptree;
hp1,p : pdef;
aufdef : penumdef;
aufsym : penumsym;
ap : parraydef;
s : stringid;
l,v : longint;
oldaktpackrecords : tpackrecords;
hs : string;
procedure expr_type;
var
pt1,pt2 : ptree;
begin
{ use of current parsed object ? }
if (token=ID) and (testcurobject=2) and (curobjectname=pattern) then
@ -1705,17 +1777,17 @@ unit pdecl;
begin
{ a simple type renaming }
if (pt1^.treetype=typen) then
p:=pt1^.resulttype
begin
p:=pt1^.resulttype;
readtypesym:=pt1^.typenodesym;
end
else
Message(sym_e_error_in_type_def);
end;
disposetree(pt1);
end;
var
pt : ptree;
procedure array_dec;
procedure array_dec;
var
lowval,
highval : longint;
@ -1801,10 +1873,14 @@ unit pdecl;
end;
begin
readtypesym:=nil;
p:=nil;
case token of
_STRING,_FILE:
p:=single_type(hs);
begin
p:=single_type(hs);
readtypesym:=nil;
end;
LKLAMMER:
begin
consume(LKLAMMER);
@ -1839,96 +1915,118 @@ unit pdecl;
min and max are now set in tenumsym.init PM }
p:=aufdef;
consume(RKLAMMER);
readtypesym:=nil;
end;
_ARRAY:
array_dec;
begin
array_dec;
readtypesym:=nil;
end;
_SET:
begin
consume(_SET);
consume(_OF);
hp1:=read_type('');
if assigned(hp1) then
begin
case hp1^.deftype of
consume(_SET);
consume(_OF);
hp1:=read_type('');
if assigned(hp1) then
begin
case hp1^.deftype of
{ don't forget that min can be negativ PM }
enumdef : if penumdef(hp1)^.min>=0 then
p:=new(psetdef,init(hp1,penumdef(hp1)^.max))
enumdef :
if penumdef(hp1)^.min>=0 then
p:=new(psetdef,init(hp1,penumdef(hp1)^.max))
else
Message(sym_e_ill_type_decl_set);
orddef :
begin
case porddef(hp1)^.typ of
uchar :
p:=new(psetdef,init(hp1,255));
u8bit,u16bit,u32bit,
s8bit,s16bit,s32bit :
begin
if (porddef(hp1)^.low>=0) then
p:=new(psetdef,init(hp1,porddef(hp1)^.high))
else
Message(sym_e_ill_type_decl_set);
orddef : begin
case porddef(hp1)^.typ of
uchar : p:=new(psetdef,init(hp1,255));
u8bit,s8bit,u16bit,s16bit,s32bit :
begin
if (porddef(hp1)^.low>=0) then
p:=new(psetdef,init(hp1,porddef(hp1)^.high))
else Message(sym_e_ill_type_decl_set);
end;
else Message(sym_e_ill_type_decl_set);
end;
end;
else Message(sym_e_ill_type_decl_set);
end;
end
else
p:=generrordef;
end;
else
Message(sym_e_ill_type_decl_set);
end;
end;
else
Message(sym_e_ill_type_decl_set);
end;
end
else
p:=generrordef;
readtypesym:=nil;
end;
CARET:
begin
consume(CARET);
{ forwards allowed only inside TYPE statements }
if typecanbeforward then
forwardsallowed:=true;
hp1:=single_type(hs);
p:=new(ppointerdef,init(hp1));
if (lasttypesym<>nil) and ((lasttypesym^.properties and sp_forwarddef)<>0) then
lasttypesym^.addforwardpointer(ppointerdef(p));
forwardsallowed:=false;
consume(CARET);
{ forwards allowed only inside TYPE statements }
if typecanbeforward then
forwardsallowed:=true;
hp1:=single_type(hs);
p:=new(ppointerdef,init(hp1));
if (lasttypesym<>nil) and ((lasttypesym^.properties and sp_forwarddef)<>0) then
lasttypesym^.addforwardpointer(ppointerdef(p));
forwardsallowed:=false;
readtypesym:=nil;
end;
_RECORD:
p:=record_dec;
begin
p:=record_dec;
readtypesym:=nil;
end;
_PACKED:
begin
consume(_PACKED);
if token=_ARRAY then
array_dec
else
begin
oldaktpackrecords:=aktpackrecords;
aktpackrecords:=packrecord_1;
if token in [_CLASS,_OBJECT] then
p:=object_dec(name,nil)
else
p:=record_dec;
aktpackrecords:=oldaktpackrecords;
end;
consume(_PACKED);
if token=_ARRAY then
array_dec
else
begin
oldaktpackrecords:=aktpackrecords;
aktpackrecords:=packrecord_1;
if token in [_CLASS,_OBJECT] then
p:=object_dec(name,nil)
else
p:=record_dec;
aktpackrecords:=oldaktpackrecords;
end;
readtypesym:=nil;
end;
_CLASS,
_OBJECT:
p:=object_dec(name,nil);
begin
p:=object_dec(name,nil);
readtypesym:=nil;
end;
_PROCEDURE:
begin
consume(_PROCEDURE);
p:=handle_procvar;
if token=_OF then
begin
consume(_OF);
consume(_OBJECT);
pprocvardef(p)^.options:=pprocvardef(p)^.options or pomethodpointer;
end;
consume(_PROCEDURE);
p:=handle_procvar;
if token=_OF then
begin
consume(_OF);
consume(_OBJECT);
pprocvardef(p)^.options:=pprocvardef(p)^.options or pomethodpointer;
end;
readtypesym:=nil;
end;
_FUNCTION:
begin
consume(_FUNCTION);
p:=handle_procvar;
consume(COLON);
pprocvardef(p)^.retdef:=single_type(hs);
if token=_OF then
begin
consume(_OF);
consume(_OBJECT);
pprocvardef(p)^.options:=pprocvardef(p)^.options or pomethodpointer;
end;
consume(_FUNCTION);
p:=handle_procvar;
consume(COLON);
pprocvardef(p)^.retdef:=single_type(hs);
if token=_OF then
begin
consume(_OF);
consume(_OBJECT);
pprocvardef(p)^.options:=pprocvardef(p)^.options or pomethodpointer;
end;
readtypesym:=nil;
end;
else
expr_type;
@ -2188,7 +2286,10 @@ unit pdecl;
end.
{
$Log$
Revision 1.135 1999-07-23 16:05:23 peter
Revision 1.136 1999-07-27 23:42:11 peter
* indirect type referencing is now allowed
Revision 1.135 1999/07/23 16:05:23 peter
* alignment is now saved in the symtable
* C alignment added for records
* PPU version increased to solve .12 <-> .13 probs

27
compiler/pexpr.pas
View File

@ -978,15 +978,19 @@ unit pexpr;
end
else
begin
{ illegal reference ? }
if pd^.owner^.unitid=-1 then
Comment(V_Error,'illegal type reference, unit '+pd^.owner^.name^+' is not in uses');
{ if we read a type declaration }
{ we have to return the type and }
{ nothing else }
if block_type=bt_type then
begin
p1:=gentypenode(pd);
{ we don't need sym reference when it's in the
current unit or system unit, because those
units are always loaded (PFV) }
if (pd^.owner^.unitid=0) or
(pd^.owner^.unitid=1) then
p1:=gentypenode(pd,nil)
else
p1:=gentypenode(pd,ptypesym(srsym));
{ here we can also set resulttype !! }
p1^.resulttype:=pd;
pd:=voiddef;
@ -1011,7 +1015,7 @@ unit pexpr;
begin
if procinfo._class^.isrelated(pobjectdef(pd)) then
begin
p1:=gentypenode(pd);
p1:=gentypenode(pd,ptypesym(srsym));
p1^.resulttype:=pd;
srsymtable:=pobjectdef(pd)^.publicsyms;
sym:=pvarsym(srsymtable^.search(pattern));
@ -1061,7 +1065,7 @@ unit pexpr;
if (pd^.deftype=objectdef)
and pobjectdef(pd)^.isclass then
begin
p1:=gentypenode(pd);
p1:=gentypenode(pd,nil);
p1^.resulttype:=pd;
pd:=new(pclassrefdef,init(pd));
p1:=gensinglenode(loadvmtn,p1);
@ -1073,7 +1077,7 @@ unit pexpr;
{ (for typeof etc) }
if allow_type then
begin
p1:=gentypenode(pd);
p1:=gentypenode(pd,nil);
{ here we must use typenodetype explicitly !! PM
p1^.resulttype:=pd; }
pd:=voiddef;
@ -1723,7 +1727,7 @@ unit pexpr;
postfixoperators;
end
else
p1:=gentypenode(pd);
p1:=gentypenode(pd,nil);
end;
_FILE : begin
pd:=cfiledef;
@ -1741,7 +1745,7 @@ unit pexpr;
postfixoperators;
end
else
p1:=gentypenode(pd);
p1:=gentypenode(pd,nil);
end;
CSTRING : begin
p1:=genstringconstnode(pattern);
@ -2056,7 +2060,10 @@ unit pexpr;
end.
{
$Log$
Revision 1.124 1999-07-23 21:31:42 peter
Revision 1.125 1999-07-27 23:42:14 peter
* indirect type referencing is now allowed
Revision 1.124 1999/07/23 21:31:42 peter
* fixed crash with resourcestring
Revision 1.123 1999/07/23 11:37:46 peter

34
compiler/psub.pas
View File

@ -105,6 +105,7 @@ begin
else
varspez:=vs_value;
inserthigh:=false;
readtypesym:=nil;
if idtoken=_SELF then
begin
{ we parse the defintion in the class definition }
@ -125,7 +126,10 @@ begin
consume(idtoken);
consume(COLON);
p:=single_type(hs1);
aktprocsym^.definition^.concatdef(p,vs_value);
if assigned(readtypesym) then
aktprocsym^.definition^.concattypesym(readtypesym,vs_value)
else
aktprocsym^.definition^.concatdef(p,vs_value);
CheckTypes(p,procinfo._class);
end
else
@ -135,7 +139,6 @@ begin
begin
{ read identifiers }
sc:=idlist;
{ read type declaration, force reading for value and const paras }
if (token=COLON) or (varspez=vs_value) then
begin
@ -165,6 +168,8 @@ begin
{ define field type }
Parraydef(p)^.definition:=single_type(hs1);
hs1:='array_of_'+hs1;
{ we don't need the typesym anymore }
readtypesym:=nil;
end;
inserthigh:=true;
end
@ -201,14 +206,22 @@ begin
storetokenpos:=tokenpos;
while not sc^.empty do
begin
s:=sc^.get_with_tokeninfo(tokenpos);
aktprocsym^.definition^.concatdef(p,varspez);
{$ifndef UseNiceNames}
{$ifndef UseNiceNames}
hs2:=hs2+'$'+hs1;
{$else UseNiceNames}
{$else UseNiceNames}
hs2:=hs2+tostr(length(hs1))+hs1;
{$endif UseNiceNames}
vs:=new(Pvarsym,init(s,p));
{$endif UseNiceNames}
s:=sc^.get_with_tokeninfo(tokenpos);
if assigned(readtypesym) then
begin
aktprocsym^.definition^.concattypesym(readtypesym,varspez);
vs:=new(Pvarsym,initsym(s,readtypesym))
end
else
begin
aktprocsym^.definition^.concatdef(p,varspez);
vs:=new(Pvarsym,init(s,p));
end;
vs^.varspez:=varspez;
{ we have to add this to avoid var param to be in registers !!!}
if (varspez in [vs_var,vs_const]) and push_addr_param(p) then
@ -1841,7 +1854,10 @@ end.
{
$Log$
Revision 1.5 1999-07-26 09:42:15 florian
Revision 1.6 1999-07-27 23:42:16 peter
* indirect type referencing is now allowed
Revision 1.5 1999/07/26 09:42:15 florian
* bugs 494-496 fixed
Revision 1.4 1999/07/11 20:10:24 peter

42
compiler/symdef.inc
View File

@ -2108,7 +2108,6 @@
***************************************************************************}
constructor tabstractprocdef.init;
begin
inherited init;
para1:=nil;
@ -2119,7 +2118,6 @@
end;
procedure disposepdefcoll(var para1 : pdefcoll);
var
hp : pdefcoll;
@ -2146,12 +2144,26 @@
begin
new(hp);
hp^.paratyp:=vsp;
hp^.datasym:=nil;
hp^.data:=p;
hp^.next:=para1;
hp^.register:=R_NO;
para1:=hp;
end;
procedure tabstractprocdef.concattypesym(p : ptypesym;vsp : tvarspez);
var
hp : pdefcoll;
begin
new(hp);
hp^.paratyp:=vsp;
hp^.datasym:=p;
hp^.data:=p^.definition;
hp^.next:=para1;
hp^.register:=R_NO;
para1:=hp;
end;
{ all functions returning in FPU are
assume to use 2 FPU registers
until the function implementation
@ -2162,6 +2174,7 @@
fpu_used:=2;
end;
procedure tabstractprocdef.deref;
var
hp : pdefcoll;
@ -2171,7 +2184,13 @@
hp:=para1;
while assigned(hp) do
begin
resolvedef(hp^.data);
if assigned(hp^.datasym) then
begin
resolvesym(psym(hp^.datasym));
hp^.data:=hp^.datasym^.definition;
end
else
resolvedef(hp^.data);
hp:=hp^.next;
end;
end;
@ -2196,6 +2215,7 @@
{ hp^.register:=tregister(readbyte); }
hp^.register:=R_NO;
hp^.data:=readdefref;
hp^.datasym:=ptypesym(readsymref);
hp^.next:=nil;
if para1=nil then
para1:=hp
@ -2252,7 +2272,16 @@
begin
writebyte(byte(hp^.paratyp));
{ writebyte(byte(hp^.register)); }
writedefref(hp^.data);
if assigned(hp^.datasym) then
begin
writedefref(nil);
writesymref(psym(hp^.datasym));
end
else
begin
writedefref(hp^.data);
writesymref(nil);
end;
hp:=hp^.next;
end;
end;
@ -3493,7 +3522,10 @@ Const local_symtable_index : longint = $8001;
{
$Log$
Revision 1.134 1999-07-23 23:07:03 peter
Revision 1.135 1999-07-27 23:42:18 peter
* indirect type referencing is now allowed
Revision 1.134 1999/07/23 23:07:03 peter
* fixed stabs for record which still used savesize
Revision 1.133 1999/07/23 16:05:28 peter

7
compiler/symdefh.inc
View File

@ -102,6 +102,7 @@
pdefcoll = ^tdefcoll;
tdefcoll = record
data : pdef;
datasym : ptypesym;
next : pdefcoll;
paratyp : tvarspez;
argconvtyp : targconvtyp;
@ -351,6 +352,7 @@
constructor load;
destructor done;virtual;
procedure concatdef(p : pdef;vsp : tvarspez);
procedure concattypesym(p : ptypesym;vsp : tvarspez);
procedure deref;virtual;
function para_size : longint;
function demangled_paras : string;
@ -525,7 +527,10 @@
{
$Log$
Revision 1.34 1999-07-23 16:05:30 peter
Revision 1.35 1999-07-27 23:42:20 peter
* indirect type referencing is now allowed
Revision 1.34 1999/07/23 16:05:30 peter
* alignment is now saved in the symtable
* C alignment added for records
* PPU version increased to solve .12 <-> .13 probs

236
compiler/symsym.inc
View File

@ -773,11 +773,22 @@
procedure tabsolutesym.write;
begin
{ Note: This needs to write everything of tvarsym.write }
tsym.write;
writebyte(byte(varspez));
if read_member then
writelong(address);
writedefref(definition);
{ write only definition or definitionsym }
if assigned(definitionsym) then
begin
writedefref(nil);
writesymref(definitionsym);
end
else
begin
writedefref(definition);
writesymref(nil);
end;
writebyte(var_options and (not vo_regable));
writebyte(byte(abstyp));
case abstyp of
@ -797,7 +808,7 @@
procedure tabsolutesym.deref;
begin
resolvedef(definition);
tvarsym.deref;
if (abstyp=tovar) and (asmname<>nil) then
begin
{ search previous loaded symtables }
@ -849,6 +860,7 @@
tsym.init(n);
typ:=varsym;
definition:=p;
definitionsym:=nil;
_mangledname:=nil;
varspez:=vs_value;
address:=0;
@ -899,6 +911,27 @@
end;
constructor tvarsym.initsym(const n : string;p : ptypesym);
begin
tvarsym.init(n,p^.definition);
definitionsym:=p;
end;
constructor tvarsym.initsym_dll(const n : string;p : ptypesym);
begin
tvarsym.init_dll(n,p^.definition);
definitionsym:=p;
end;
constructor tvarsym.initsym_C(const n,mangled : string;p : ptypesym);
begin
tvarsym.init_C(n,mangled,p^.definition);
definitionsym:=p;
end;
constructor tvarsym.load;
begin
tsym.load;
@ -915,15 +948,29 @@
islocalcopy:=false;
localvarsym:=nil;
definition:=readdefref;
definitionsym:=ptypesym(readsymref);
var_options:=readbyte;
if (var_options and vo_is_C_var)<>0 then
setmangledname(readstring);
end;
destructor tvarsym.done;
begin
strdispose(_mangledname);
inherited done;
end;
procedure tvarsym.deref;
begin
resolvedef(definition);
if assigned(definitionsym) then
begin
resolvesym(psym(definitionsym));
definition:=definitionsym^.definition;
end
else
resolvedef(definition);
end;
@ -933,7 +980,17 @@
writebyte(byte(varspez));
if read_member then
writelong(address);
writedefref(definition);
{ write only definition or definitionsym }
if assigned(definitionsym) then
begin
writedefref(nil);
writesymref(definitionsym);
end
else
begin
writedefref(definition);
writesymref(nil);
end;
{ symbols which are load are never candidates for a register,
turn off the regable }
writebyte(var_options and (not vo_regable));
@ -993,16 +1050,6 @@
vs_value,
vs_const :
begin
(*case definition^.deftype of
arraydef,
setdef,
stringdef,
recorddef,
objectdef :
getpushsize:=target_os.size_of_pointer;
else
getpushsize:=definition^.size;
this is obsolete use push_param instead (PM) *)
if push_addr_param(definition) then
getpushsize:=target_os.size_of_pointer
else
@ -1026,7 +1073,8 @@
else *)
if length>2 then
data_align:=4
else if length>1 then
else
if length>1 then
data_align:=2
else
data_align:=1;
@ -1127,9 +1175,6 @@
ali:=data_align(l);
if ali>1 then
begin
(* this is done
either by the assembler or in ag386bin
bsssegment^.concat(new(pai_align,init(ali))); *)
modulo:=owner^.datasize mod ali;
if modulo>0 then
inc(owner^.datasize,ali-modulo);
@ -1234,9 +1279,9 @@
{$ifdef GDB}
function tvarsym.stabstring : pchar;
var
st : char;
begin
var
st : char;
begin
if (owner^.symtabletype = objectsymtable) and
((properties and sp_static)<>0) then
begin
@ -1330,44 +1375,41 @@
end;
{$endif GDB}
destructor tvarsym.done;
begin
strdispose(_mangledname);
inherited done;
end;
{****************************************************************************
TTYPEDCONSTSYM
*****************************************************************************}
constructor ttypedconstsym.init(const n : string;p : pdef;really_const : boolean);
begin
tsym.init(n);
typ:=typedconstsym;
definition:=p;
definitionsym:=nil;
is_really_const:=really_const;
prefix:=stringdup(procprefix);
end;
constructor ttypedconstsym.load;
constructor ttypedconstsym.initsym(const n : string;p : ptypesym;really_const : boolean);
begin
ttypedconstsym.init(n,p^.definition,really_const);
definitionsym:=p;
end;
constructor ttypedconstsym.load;
begin
tsym.load;
typ:=typedconstsym;
definition:=readdefref;
{$ifdef DELPHI_CONST_IN_RODATA}
is_really_const:=boolean(readbyte);
{$else DELPHI_CONST_IN_RODATA}
is_really_const:=false;
{$endif DELPHI_CONST_IN_RODATA}
definitionsym:=ptypesym(readsymref);
prefix:=stringdup(readstring);
is_really_const:=boolean(readbyte);
end;
destructor ttypedconstsym.done;
destructor ttypedconstsym.done;
begin
stringdispose(prefix);
tsym.done;
@ -1390,77 +1432,80 @@
procedure ttypedconstsym.deref;
begin
resolvedef(definition);
if assigned(definitionsym) then
begin
resolvesym(psym(definitionsym));
definition:=definitionsym^.definition;
end
else
resolvedef(definition);
end;
procedure ttypedconstsym.write;
procedure ttypedconstsym.write;
begin
tsym.write;
writedefref(definition);
{ write only definition or definitionsym }
if assigned(definitionsym) then
begin
writedefref(nil);
writesymref(definitionsym);
end
else
begin
writedefref(definition);
writesymref(nil);
end;
writestring(prefix^);
{$ifdef DELPHI_CONST_IN_RODATA}
writebyte(byte(is_really_const));
{$endif DELPHI_CONST_IN_RODATA}
current_ppu^.writeentry(ibtypedconstsym);
end;
{ for most symbol types ther is nothing to do at all }
procedure ttypedconstsym.insert_in_data;
begin
{ here there is a problem for ansistrings !! }
{ we must write the label only after the 12 header bytes (PM)
if not is_ansistring(definition) then
}
{ solved, the ansis string is moved to consts (FK) }
really_insert_in_data;
end;
procedure ttypedconstsym.really_insert_in_data;
var curconstsegment : paasmoutput;
l,ali,modulo : longint;
storefilepos : tfileposinfo;
begin
storefilepos:=aktfilepos;
aktfilepos:=tokenpos;
if is_really_const then
curconstsegment:=consts
else
curconstsegment:=datasegment;
if (cs_smartlink in aktmoduleswitches) then
curconstsegment^.concat(new(pai_cut,init));
l:=getsize;
ali:=data_align(l);
if ali>1 then
begin
curconstsegment^.concat(new(pai_align,init(ali)));
modulo:=owner^.datasize mod ali;
if modulo>0 then
inc(owner^.datasize,ali-modulo);
end;
{ Why was there no owner size update here ??? }
inc(owner^.datasize,l);
procedure ttypedconstsym.insert_in_data;
var
curconstsegment : paasmoutput;
l,ali,modulo : longint;
storefilepos : tfileposinfo;
begin
storefilepos:=aktfilepos;
aktfilepos:=tokenpos;
if is_really_const then
curconstsegment:=consts
else
curconstsegment:=datasegment;
if (cs_smartlink in aktmoduleswitches) then
curconstsegment^.concat(new(pai_cut,init));
l:=getsize;
ali:=data_align(l);
if ali>1 then
begin
curconstsegment^.concat(new(pai_align,init(ali)));
modulo:=owner^.datasize mod ali;
if modulo>0 then
inc(owner^.datasize,ali-modulo);
end;
{ Why was there no owner size update here ??? }
inc(owner^.datasize,l);
{$ifdef GDB}
if cs_debuginfo in aktmoduleswitches then
concatstabto(curconstsegment);
if cs_debuginfo in aktmoduleswitches then
concatstabto(curconstsegment);
{$endif GDB}
if owner^.symtabletype=globalsymtable then
begin
curconstsegment^.concat(new(pai_symbol,initname_global(mangledname)));
end
else
if owner^.symtabletype<>unitsymtable then
begin
if (cs_smartlink in aktmoduleswitches) then
curconstsegment^.concat(new(pai_symbol,initname_global(mangledname)))
else
curconstsegment^.concat(new(pai_symbol,initname(mangledname)));
end;
aktfilepos:=storefilepos;
end;
if owner^.symtabletype=globalsymtable then
begin
curconstsegment^.concat(new(pai_symbol,initname_global(mangledname)));
end
else
if owner^.symtabletype<>unitsymtable then
begin
if (cs_smartlink in aktmoduleswitches) then
curconstsegment^.concat(new(pai_symbol,initname_global(mangledname)))
else
curconstsegment^.concat(new(pai_symbol,initname(mangledname)));
end;
aktfilepos:=storefilepos;
end;
{$ifdef GDB}
function ttypedconstsym.stabstring : pchar;
@ -2011,7 +2056,10 @@
{
$Log$
Revision 1.103 1999-07-24 15:12:59 michael
Revision 1.104 1999-07-27 23:42:21 peter
* indirect type referencing is now allowed
Revision 1.103 1999/07/24 15:12:59 michael
changes for resourcestrings
Revision 1.102 1999/07/24 13:36:23 michael

12
compiler/symsymh.inc
View File

@ -173,6 +173,7 @@
localvarsym : pvarsym;
islocalcopy : boolean;
definition : pdef;
definitionsym : ptypesym;
refs : longint;
var_options : byte;
_mangledname : pchar;
@ -182,6 +183,9 @@
constructor init(const n : string;p : pdef);
constructor init_dll(const n : string;p : pdef);
constructor init_C(const n,mangled : string;p : pdef);
constructor initsym(const n : string;p : ptypesym);
constructor initsym_dll(const n : string;p : ptypesym);
constructor initsym_C(const n,mangled : string;p : ptypesym);
constructor load;
destructor done;virtual;
procedure write;virtual;
@ -260,8 +264,10 @@
ttypedconstsym = object(tsym)
prefix : pstring;
definition : pdef;
definitionsym : ptypesym;
is_really_const : boolean;
constructor init(const n : string;p : pdef;really_const : boolean);
constructor initsym(const n : string;p : ptypesym;really_const : boolean);
constructor load;
destructor done;virtual;
function mangledname : string;virtual;
@ -269,7 +275,6 @@
procedure deref;virtual;
function getsize:longint;
procedure insert_in_data;virtual;
procedure really_insert_in_data;
{$ifdef GDB}
function stabstring : pchar;virtual;
{$endif GDB}
@ -333,7 +338,10 @@
{
$Log$
Revision 1.28 1999-07-24 15:13:01 michael
Revision 1.29 1999-07-27 23:42:23 peter
* indirect type referencing is now allowed
Revision 1.28 1999/07/24 15:13:01 michael
changes for resourcestrings
Revision 1.27 1999/07/22 09:37:57 florian

14
compiler/tree.pas
View File

@ -230,7 +230,7 @@ unit tree;
vecn : (memindex,memseg:boolean;callunique : boolean);
stringconstn : (value_str : pchar;length : longint; lab_str : pasmlabel;stringtype : tstringtype);
typeconvn : (convtyp : tconverttype;explizit : boolean);
typen : (typenodetype : pdef);
typen : (typenodetype : pdef;typenodesym:ptypesym);
inlinen : (inlinenumber : byte;inlineconst:boolean);
procinlinen : (inlinetree:ptree;inlineprocsym:pprocsym;retoffset,para_offset,para_size : longint);
setconstn : (value_set : pconstset;lab_set:pasmlabel);
@ -253,7 +253,7 @@ unit tree;
function genordinalconstnode(v : longint;def : pdef) : ptree;
function genfixconstnode(v : longint;def : pdef) : ptree;
function gentypeconvnode(node : ptree;t : pdef) : ptree;
function gentypenode(t : pdef) : ptree;
function gentypenode(t : pdef;sym:ptypesym) : ptree;
function gencallparanode(expr,next : ptree) : ptree;
function genrealconstnode(v : bestreal;def : pdef) : ptree;
function gencallnode(v : pprocsym;st : psymtable) : ptree;
@ -1036,11 +1036,9 @@ unit tree;
gentypeconvnode:=p;
end;
function gentypenode(t : pdef) : ptree;
function gentypenode(t : pdef;sym:ptypesym) : ptree;
var
p : ptree;
begin
p:=getnode;
p^.disposetyp:=dt_nothing;
@ -1054,6 +1052,7 @@ unit tree;
{$endif SUPPORT_MMX}
p^.resulttype:=generrordef;
p^.typenodetype:=t;
p^.typenodesym:=sym;
gentypenode:=p;
end;
@ -1731,7 +1730,10 @@ unit tree;
end.
{
$Log$
Revision 1.83 1999-05-27 19:45:29 peter
Revision 1.84 1999-07-27 23:42:24 peter
* indirect type referencing is now allowed
Revision 1.83 1999/05/27 19:45:29 peter
* removed oldasm
* plabel -> pasmlabel
* -a switches to source writing automaticly