From 30be2bf0632a8a4f55f4c250c157a2e48aa1b560 Mon Sep 17 00:00:00 2001 From: peter Date: Tue, 27 Jul 1999 23:42:10 +0000 Subject: [PATCH] * indirect type referencing is now allowed --- compiler/pbase.pas | 39 +--- compiler/pdecl.pas | 443 ++++++++++++++++++++++++++----------------- compiler/pexpr.pas | 27 ++- compiler/psub.pas | 34 +++- compiler/symdef.inc | 42 +++- compiler/symdefh.inc | 7 +- compiler/symsym.inc | 236 ++++++++++++++--------- compiler/symsymh.inc | 12 +- compiler/tree.pas | 14 +- 9 files changed, 521 insertions(+), 333 deletions(-) diff --git a/compiler/pbase.pas b/compiler/pbase.pas index 647446a6f0..ace22e906a 100644 --- a/compiler/pbase.pas +++ b/compiler/pbase.pas @@ -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 diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index 9c8e9c3169..343e37811c 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -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 diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 1930de5598..748e2de2d7 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -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 diff --git a/compiler/psub.pas b/compiler/psub.pas index ea83636a96..af4c015b24 100644 --- a/compiler/psub.pas +++ b/compiler/psub.pas @@ -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 diff --git a/compiler/symdef.inc b/compiler/symdef.inc index b1b4fa6c02..8f58814eec 100644 --- a/compiler/symdef.inc +++ b/compiler/symdef.inc @@ -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 diff --git a/compiler/symdefh.inc b/compiler/symdefh.inc index 935dd58f88..30e42ca5c4 100644 --- a/compiler/symdefh.inc +++ b/compiler/symdefh.inc @@ -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 diff --git a/compiler/symsym.inc b/compiler/symsym.inc index a2c98d178c..03018650ef 100644 --- a/compiler/symsym.inc +++ b/compiler/symsym.inc @@ -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 diff --git a/compiler/symsymh.inc b/compiler/symsymh.inc index 6c1503b417..700884466c 100644 --- a/compiler/symsymh.inc +++ b/compiler/symsymh.inc @@ -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 diff --git a/compiler/tree.pas b/compiler/tree.pas index 1efaa7d359..0292fdce00 100644 --- a/compiler/tree.pas +++ b/compiler/tree.pas @@ -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