{ $Id$ Copyright (c) 1993-98 by Florian Klaempfl Does declaration parsing for Free Pascal This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } unit pdecl; interface uses globtype,tokens,globals,symtable; var { pointer to the last read type symbol, (for "forward" } { types) } lasttypesym : ptypesym; { hack, which allows to use the current parsed } { object type as function argument type } testcurobject : byte; curobjectname : stringid; { reads a string type with optional length } { and returns a pointer to the string } { definition } function stringtype : pdef; { reads a string, file type or a type id and returns a name and } { pdef } function single_type(var s : string) : pdef; { reads the declaration blocks } procedure read_declarations(islibrary : boolean); { reads declarations in the interface part of a unit } procedure read_interface_declarations; implementation uses cobjects,scanner,aasm,tree,pass_1,strings, files,types,verbose,systems,import {$ifdef GDB} ,gdb {$endif GDB} { parser specific stuff } ,pbase,ptconst,pexpr,psub,pexports { processor specific stuff } {$ifdef i386} {$ifdef Ag386Bin} ,i386base {$else} ,i386 {$endif} {$endif} {$ifdef m68k} ,m68k {$endif} { codegen } ,hcodegen,hcgdata ; function read_type(const name : stringid) : pdef;forward; { search in symtablestack used, but not defined type } procedure testforward_type(p : psym);{$ifndef FPC}far;{$endif} var reaktvarsymtable : psymtable; oldaktfilepos : tfileposinfo; begin if not(p^.typ=typesym) then exit; if ((p^.properties and sp_forwarddef)<>0) then begin oldaktfilepos:=aktfilepos; aktfilepos:=p^.fileinfo; Message1(sym_e_forward_type_not_resolved,p^.name); aktfilepos:=oldaktfilepos; { try to recover } ptypesym(p)^.definition:=generrordef; p^.properties:=p^.properties and (not sp_forwarddef); end else if (ptypesym(p)^.definition^.deftype in [recorddef,objectdef]) then begin if (ptypesym(p)^.definition^.deftype=recorddef) then reaktvarsymtable:=precdef(ptypesym(p)^.definition)^.symtable else reaktvarsymtable:=pobjectdef(ptypesym(p)^.definition)^.publicsyms; {$ifdef tp} reaktvarsymtable^.foreach(testforward_type); {$else} reaktvarsymtable^.foreach(@testforward_type); {$endif} end; end; procedure const_dec; var name : stringid; p : ptree; def : pdef; sym : psym; storetokenpos,filepos : tfileposinfo; old_block_type : tblock_type; ps : pconstset; pd : pbestreal; sp : pchar; begin consume(_CONST); old_block_type:=block_type; block_type:=bt_const; repeat name:=pattern; filepos:=tokenpos; consume(ID); case token of EQUAL: begin consume(EQUAL); p:=comp_expr(true); do_firstpass(p); storetokenpos:=tokenpos; tokenpos:=filepos; case p^.treetype of ordconstn: begin if is_constintnode(p) then symtablestack^.insert(new(pconstsym,init_def(name,constint,p^.value,nil))) else if is_constcharnode(p) then symtablestack^.insert(new(pconstsym,init_def(name,constchar,p^.value,nil))) else if is_constboolnode(p) then symtablestack^.insert(new(pconstsym,init_def(name,constbool,p^.value,nil))) else if p^.resulttype^.deftype=enumdef then symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype))) else if p^.resulttype^.deftype=pointerdef then symtablestack^.insert(new(pconstsym,init_def(name,constord,p^.value,p^.resulttype))) else internalerror(111); end; stringconstn: begin getmem(sp,p^.length+1); move(p^.value_str^,sp^,p^.length+1); symtablestack^.insert(new(pconstsym,init_string(name,conststring,sp,p^.length))); end; realconstn : begin new(pd); pd^:=p^.value_real; symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd)))); end; setconstn : begin new(ps); ps^:=p^.value_set^; symtablestack^.insert(new(pconstsym,init_def(name,constset,longint(ps),p^.resulttype))); end; niln : begin symtablestack^.insert(new(pconstsym,init_def(name,constnil,0,p^.resulttype))); end; else Message(cg_e_illegal_expression); end; tokenpos:=storetokenpos; consume(SEMICOLON); disposetree(p); end; COLON: begin { set the blocktype first so a consume also supports a caret, to support const s : ^string = nil } block_type:=bt_type; consume(COLON); ignore_equal:=true; def:=read_type(''); ignore_equal:=false; block_type:=bt_const; storetokenpos:=tokenpos; tokenpos:=filepos; sym:=new(ptypedconstsym,init(name,def)); tokenpos:=storetokenpos; symtablestack^.insert(sym); consume(EQUAL); readtypedconst(def,ptypedconstsym(sym)); consume(SEMICOLON); end; else consume(EQUAL); end; until token<>ID; block_type:=old_block_type; end; procedure label_dec; var hl : plabel; begin consume(_LABEL); if not(cs_support_goto in aktmoduleswitches) then Message(sym_e_goto_and_label_not_supported); repeat if not(token in [ID,INTCONST]) then consume(ID) else begin getlabel(hl); symtablestack^.insert(new(plabelsym,init(pattern,hl))); consume(token); end; if token<>SEMICOLON then consume(COMMA); until not(token in [ID,INTCONST]); consume(SEMICOLON); end; procedure read_var_decs(is_record,is_object:boolean); { reads the filed of a record into a } { symtablestack, if record=false } { variants are forbidden, so this procedure } { can be used to read object fields } { if absolute is true, ABSOLUTE and file } { types are allowed } { => the procedure is also used to read } { a sequence of variable declaration } var sc : pstringcontainer; s : stringid; old_block_type : tblock_type; declarepos,storetokenpos : tfileposinfo; symdone : boolean; { to handle absolute } abssym : pabsolutesym; l : longint; code : word; { c var } newtype : ptypesym; is_dll, is_gpc_name,is_cdecl,extern_aktvarsym,export_aktvarsym : boolean; dll_name, C_name : string; { case } p,casedef : pdef; { maxsize contains the max. size of a variant } { startvarrec contains the start of the variant part of a record } maxsize,startvarrec : longint; pt : ptree; begin old_block_type:=block_type; block_type:=bt_type; is_gpc_name:=false; { Force an expected ID error message } if not (token in [ID,_CASE,_END]) then consume(ID); { read vars } while (token=ID) and not(is_object and (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED])) do begin C_name:=orgpattern; sc:=idlist; consume(COLON); if (m_gpc in aktmodeswitches) and not(is_record or is_object) and (token=ID) and (orgpattern='__asmname__') then begin consume(ID); C_name:=pattern; if token=CCHAR then consume(CCHAR) else consume(CSTRING); Is_gpc_name:=true; end; p:=read_type(''); symdone:=false; if is_gpc_name then begin storetokenpos:=tokenpos; s:=sc^.get_with_tokeninfo(tokenpos); if not sc^.empty then Message(parser_e_absolute_only_one_var); dispose(sc,done); aktvarsym:=new(pvarsym,init_C(s,target_os.Cprefix+C_name,p)); tokenpos:=storetokenpos; aktvarsym^.var_options:=aktvarsym^.var_options or vo_is_external; concat_external(aktvarsym^.mangledname,EXT_NEAR); symtablestack^.insert(aktvarsym); symdone:=true; end; { check for absolute } if not symdone and (idtoken=_ABSOLUTE) and not(is_record or is_object) then begin consume(_ABSOLUTE); { only allowed for one var } s:=sc^.get_with_tokeninfo(declarepos); if not sc^.empty then Message(parser_e_absolute_only_one_var); dispose(sc,done); { parse the rest } if token=ID then begin getsym(pattern,true); consume(ID); { we should check the result type of srsym } if not (srsym^.typ in [varsym,typedconstsym]) then Message(parser_e_absolute_only_to_var_or_const); storetokenpos:=tokenpos; tokenpos:=declarepos; abssym:=new(pabsolutesym,init(s,p)); abssym^.abstyp:=tovar; abssym^.ref:=srsym; tokenpos:=storetokenpos; symtablestack^.insert(abssym); end else if (token=CSTRING) or (token=CCHAR) then begin storetokenpos:=tokenpos; tokenpos:=declarepos; abssym:=new(pabsolutesym,init(s,p)); s:=pattern; consume(token); abssym^.abstyp:=toasm; abssym^.asmname:=stringdup(s); tokenpos:=storetokenpos; symtablestack^.insert(abssym); end else { absolute address ?!? } if token=INTCONST then begin if (target_info.target=target_i386_go32v2) then begin storetokenpos:=tokenpos; tokenpos:=declarepos; abssym:=new(pabsolutesym,init(s,p)); abssym^.abstyp:=toaddr; abssym^.absseg:=false; tokenpos:=storetokenpos; s:=pattern; consume(INTCONST); val(s,abssym^.address,code); if token=COLON then begin consume(token); s:=pattern; consume(INTCONST); val(s,l,code); abssym^.address:=abssym^.address shl 4+l; abssym^.absseg:=true; end; symtablestack^.insert(abssym); end else Message(parser_e_absolute_only_to_var_or_const); end else Message(parser_e_absolute_only_to_var_or_const); symdone:=true; end; { for a record there doesn't need to be a ; before the END or ) } if not((is_record or is_object) and (token in [_END,RKLAMMER])) then consume(SEMICOLON); { procvar handling } if (p^.deftype=procvardef) and (p^.sym=nil) then begin newtype:=new(ptypesym,init('unnamed',p)); parse_var_proc_directives(newtype); newtype^.definition:=nil; p^.sym:=nil; dispose(newtype,done); end; { Check for variable directives } if not symdone and (token=ID) then begin { Check for C Variable declarations } if (m_cvar_support in aktmodeswitches) and not(is_record or is_object) and (idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR]) then begin { only allowed for one var } s:=sc^.get_with_tokeninfo(declarepos); if not sc^.empty then Message(parser_e_absolute_only_one_var); dispose(sc,done); { defaults } is_dll:=false; is_cdecl:=false; extern_aktvarsym:=false; export_aktvarsym:=false; { cdecl } if idtoken=_CVAR then begin consume(_CVAR); consume(SEMICOLON); is_cdecl:=true; C_name:=target_os.Cprefix+C_name; end; { external } if idtoken=_EXTERNAL then begin consume(_EXTERNAL); extern_aktvarsym:=true; end; { export } if idtoken in [_EXPORT,_PUBLIC] then begin consume(ID); if extern_aktvarsym then Message(parser_e_not_external_and_export) else export_aktvarsym:=true; end; { external and export need a name after when no cdecl is used } if not is_cdecl then begin { dll name ? } if (extern_aktvarsym) and (token=CSTRING) then begin is_dll:=true; dll_name:=pattern; consume(CSTRING); end; consume(_NAME); C_name:=pattern; { allow also char } if token=CCHAR then consume(CCHAR) else consume(CSTRING); end; { consume the ; when export or external is used } if extern_aktvarsym or export_aktvarsym then consume(SEMICOLON); { insert in the symtable } storetokenpos:=tokenpos; tokenpos:=declarepos; if is_dll then aktvarsym:=new(pvarsym,init_dll(s,p)) else aktvarsym:=new(pvarsym,init_C(s,C_name,p)); tokenpos:=storetokenpos; { 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; { insert in the stack/datasegment } symtablestack^.insert(aktvarsym); { now we can insert it in the import lib if its a dll, or add it to the externals } if extern_aktvarsym then begin if is_dll then begin if not(current_module^.uses_imports) then begin current_module^.uses_imports:=true; importlib^.preparelib(current_module^.modulename^); end; importlib^.importvariable(aktvarsym^.mangledname,dll_name,C_name) end else concat_external(aktvarsym^.mangledname,EXT_NEAR); end; symdone:=true; end else 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); current_object_option:=current_object_option - sp_static; consume(_STATIC); consume(SEMICOLON); symdone:=true; end; end; { insert it in the symtable, if not done yet } if not symdone then begin 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); end; end; { Check for Case } if is_record and (token=_CASE) then begin maxsize:=0; consume(_CASE); s:=pattern; getsym(s,false); { may be only a type: } if assigned(srsym) and (srsym^.typ in [typesym,unitsym]) then casedef:=read_type('') else begin consume(ID); consume(COLON); casedef:=read_type(''); symtablestack^.insert(new(pvarsym,init(s,casedef))); end; if not is_ordinal(casedef) then Message(type_e_ordinal_expr_expected); consume(_OF); startvarrec:=symtablestack^.datasize; repeat repeat pt:=comp_expr(true); do_firstpass(pt); if not(pt^.treetype=ordconstn) then Message(cg_e_illegal_expression); disposetree(pt); if token=COMMA then consume(COMMA) else break; until false; consume(COLON); { read the vars } consume(LKLAMMER); if token<>RKLAMMER then read_var_decs(true,false); consume(RKLAMMER); { calculates maximal variant size } maxsize:=max(maxsize,symtablestack^.datasize); { the items of the next variant are overlayed } symtablestack^.datasize:=startvarrec; if (token<>_END) and (token<>RKLAMMER) then consume(SEMICOLON) else break; until (token=_END) or (token=RKLAMMER); { at last set the record size to that of the biggest variant } symtablestack^.datasize:=maxsize; end; block_type:=old_block_type; end; function stringtype : pdef; { reads a string type with optional length } { and returns a pointer to the string } { definition } var p : ptree; d : pdef; begin consume(_STRING); if token=LECKKLAMMER then begin consume(LECKKLAMMER); p:=comp_expr(true); do_firstpass(p); if not is_constintnode(p) then Message(cg_e_illegal_expression); if (p^.value<=0) then begin Message(parser_e_invalid_string_size); p^.value:=255; end; consume(RECKKLAMMER); if p^.value>255 then d:=new(pstringdef,longinit(p^.value)) else if p^.value<>255 then d:=new(pstringdef,shortinit(p^.value)) else d:=cshortstringdef; disposetree(p); end else begin if cs_ansistrings in aktlocalswitches then d:=cansistringdef else d:=cshortstringdef; end; stringtype:=d; end; function id_type(var s : string) : pdef; { reads a type definition and returns a pointer } { to a appropriating pdef, s gets the name of } { the type to allow name mangling } begin s:=pattern; consume(ID); { classes can be used also in classes } if (curobjectname=pattern) and aktobjectdef^.isclass then begin id_type:=aktobjectdef; exit; end; { objects can be parameters } if (testcurobject=2) and (curobjectname=pattern) then begin id_type:=aktobjectdef; exit; end; getsym(s,true); if assigned(srsym) then begin if srsym^.typ=unitsym then begin consume(POINT); getsymonlyin(punitsym(srsym)^.unitsymtable,pattern); s:=pattern; consume(ID); end; if not assigned(srsym) or (srsym^.typ<>typesym) then begin Message(type_e_type_id_expected); lasttypesym:=ptypesym(srsym); id_type:=generrordef; exit; end; if not forwardsallowed then testforward_type(srsym); end; lasttypesym:=ptypesym(srsym); id_type:=ptypesym(srsym)^.definition; end; function single_type(var s : string) : pdef; { reads a string, file type or a type id and returns a name and } { pdef } var hs : string; begin case token of _STRING: begin single_type:=stringtype; s:='STRING'; lasttypesym:=nil; end; _FILE: begin consume(_FILE); if token=_OF then begin consume(_OF); single_type:=new(pfiledef,init(ft_typed,single_type(hs))); s:='FILE$OF$'+hs; end else begin { single_type:=new(pfiledef,init(ft_untyped,nil));} single_type:=cfiledef; s:='FILE'; end; lasttypesym:=nil; end; else single_type:=id_type(s); end; end; function object_dec(const n : stringid;fd : pobjectdef) : pdef; { this function parses an object or class declaration } var actmembertype : symprop; there_is_a_destructor : boolean; is_a_class : boolean; childof : pobjectdef; aktclass : pobjectdef; procedure constructor_head; begin consume(_CONSTRUCTOR); { must be at same level as in implementation } inc(lexlevel); parse_proc_head(poconstructor); dec(lexlevel); if (cs_constructor_name in aktglobalswitches) and (aktprocsym^.name<>'INIT') then Message(parser_e_constructorname_must_be_init); aktclass^.options:=aktclass^.options or oo_hasconstructor; consume(SEMICOLON); begin if (aktclass^.options and oo_is_class)<>0 then begin { CLASS constructors return the created instance } aktprocsym^.definition^.retdef:=aktclass; end else begin { OBJECT constructors return a boolean } {$IfDef GDB} {GDB doesn't like unnamed types !} aktprocsym^.definition^.retdef:= globaldef('boolean'); {$Else GDB} aktprocsym^.definition^.retdef:= new(porddef,init(bool8bit,0,1)); {$Endif GDB} end; end; end; procedure property_dec; var sym : psym; propertyparas : pdefcoll; { returns the matching procedure to access a property } function get_procdef : pprocdef; var p : pprocdef; begin p:=pprocsym(sym)^.definition; get_procdef:=nil; while assigned(p) do begin if equal_paras(p^.para1,propertyparas,true) then break; p:=p^.nextoverloaded; end; get_procdef:=p; end; var hp2,datacoll : pdefcoll; p,p2 : ppropertysym; overriden : psym; hs : string; code : word; varspez : tvarspez; sc : pstringcontainer; hp : pdef; s : string; declarepos : tfileposinfo; pp : pprocdef; pt : ptree; propname : stringid; begin { check for a class } if (aktclass^.options and oo_is_class=0) then Message(parser_e_syntax_error); consume(_PROPERTY); propertyparas:=nil; datacoll:=nil; if token=ID then begin p:=new(ppropertysym,init(pattern)); propname:=pattern; consume(ID); { property parameters ? } if token=LECKKLAMMER then begin if current_object_option=sp_published then Message(parser_e_cant_publish_that_property); { create a list of the parameters in propertyparas } consume(LECKKLAMMER); inc(testcurobject); repeat if token=_VAR then begin consume(_VAR); varspez:=vs_var; end else if token=_CONST then begin consume(_CONST); varspez:=vs_const; end else varspez:=vs_value; sc:=idlist; if token=COLON then begin consume(COLON); if token=_ARRAY then begin { if (varspez<>vs_const) and (varspez<>vs_var) then begin varspez:=vs_const; Message(parser_e_illegal_open_parameter); end; } consume(_ARRAY); consume(_OF); { define range and type of range } hp:=new(parraydef,init(0,-1,s32bitdef)); { define field type } parraydef(hp)^.definition:=single_type(s); end else hp:=single_type(s); end else hp:=cformaldef; s:=sc^.get_with_tokeninfo(declarepos); while s<>'' do begin new(hp2); hp2^.paratyp:=varspez; hp2^.data:=hp; hp2^.next:=propertyparas; propertyparas:=hp2; s:=sc^.get_with_tokeninfo(declarepos); end; dispose(sc,done); if token=SEMICOLON then consume(SEMICOLON) else break; until false; dec(testcurobject); consume(RECKKLAMMER); end; { overriden property ? } { force property interface, if there is a property parameter } if (token=COLON) or assigned(propertyparas) then begin consume(COLON); p^.proptype:=single_type(hs); if (idtoken=_INDEX) then begin consume(_INDEX); p^.options:=p^.options or ppo_indexed; if token=INTCONST then val(pattern,p^.index,code); consume(INTCONST); { concat a longint to the para template } new(hp2); hp2^.paratyp:=vs_value; hp2^.data:=s32bitdef; hp2^.next:=propertyparas; propertyparas:=hp2; end; end else begin { do an property override } overriden:=search_class_member(aktclass,propname); if assigned(overriden) and (overriden^.typ=propertysym) then begin { take the whole info: } p^.options:=ppropertysym(overriden)^.options; p^.index:=ppropertysym(overriden)^.index; p^.proptype:=ppropertysym(overriden)^.proptype; p^.writeaccesssym:=ppropertysym(overriden)^.writeaccesssym; p^.readaccesssym:=ppropertysym(overriden)^.readaccesssym; p^.writeaccessdef:=ppropertysym(overriden)^.writeaccessdef; p^.readaccessdef:=ppropertysym(overriden)^.readaccessdef; p^.storedsym:=ppropertysym(overriden)^.storedsym; p^.storeddef:=ppropertysym(overriden)^.storeddef; p^.default:=ppropertysym(overriden)^.default; end else begin p^.proptype:=generrordef; message(parser_e_no_property_found_to_override); end; end; if (current_object_option=sp_published) and not(p^.proptype^.is_publishable) then Message(parser_e_cant_publish_that_property); { create data defcoll to allow correct parameter checks } new(datacoll); datacoll^.paratyp:=vs_value; datacoll^.data:=p^.proptype; datacoll^.next:=nil; if (idtoken=_READ) then begin consume(_READ); sym:=search_class_member(aktclass,pattern); if not(assigned(sym)) then begin Message1(sym_e_unknown_id,pattern); consume(ID); end else begin consume(ID); if (token=POINT) and ((sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)) then begin consume(POINT); getsymonlyin(precdef(pvarsym(sym)^.definition)^.symtable,pattern); if not assigned(srsym) then Message1(sym_e_illegal_field,pattern); sym:=srsym; consume(ID); end; end; if assigned(sym) then begin { varsym aren't allowed for an indexed property or an property with parameters } if ((sym^.typ=varsym) and { not necessary, an index forces propertyparas to be assigned } { (((p^.options and ppo_indexed)<>0) or } assigned(propertyparas)) or not(sym^.typ in [varsym,procsym]) then Message(parser_e_ill_property_access_sym); { search the matching definition } if sym^.typ=procsym then begin pp:=get_procdef; if not(assigned(pp)) or not(is_equal(pp^.retdef,p^.proptype)) then Message(parser_e_ill_property_access_sym); p^.readaccessdef:=pp; end else if sym^.typ=varsym then begin if not(is_equal(pvarsym(sym)^.definition, p^.proptype)) then Message(parser_e_ill_property_access_sym); end; p^.readaccesssym:=sym; end; end; if (idtoken=_WRITE) then begin consume(_WRITE); sym:=search_class_member(aktclass,pattern); if not(assigned(sym)) then begin Message1(sym_e_unknown_id,pattern); consume(ID); end else begin consume(ID); if (token=POINT) and ((sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)) then begin consume(POINT); getsymonlyin(precdef(pvarsym(sym)^.definition)^.symtable,pattern); if not assigned(srsym) then Message1(sym_e_illegal_field,pattern); sym:=srsym; consume(ID); end; end; if assigned(sym) then begin if ((sym^.typ=varsym) and assigned(propertyparas)) or not(sym^.typ in [varsym,procsym]) then Message(parser_e_ill_property_access_sym); { search the matching definition } if sym^.typ=procsym then begin { insert data entry to check access method } datacoll^.next:=propertyparas; propertyparas:=datacoll; pp:=get_procdef; { ... and remove it } propertyparas:=propertyparas^.next; datacoll^.next:=nil; if not(assigned(pp)) then Message(parser_e_ill_property_access_sym); p^.writeaccessdef:=pp; end else if sym^.typ=varsym then begin if not(is_equal(pvarsym(sym)^.definition, p^.proptype)) then Message(parser_e_ill_property_access_sym); end; p^.writeaccesssym:=sym; end; end; if (idtoken=_STORED) then begin consume(_STORED); Message(parser_w_stored_not_implemented); { !!!!!!!! } end; if (idtoken=_DEFAULT) then begin consume(_DEFAULT); if not(is_ordinal(p^.proptype) or ((p^.proptype^.deftype=setdef) and (psetdef(p^.proptype)^.settype=smallset) ) or assigned(propertyparas) ) then Message(parser_e_property_cant_have_a_default_value); pt:=comp_expr(true); pt:=gentypeconvnode(pt,p^.proptype); do_firstpass(pt); if not(is_constnode(pt)) then Message(parser_e_property_default_value_must_const); if pt^.treetype=setconstn then p^.default:=plongint(pt^.value_set)^ else p^.default:=pt^.value; disposetree(pt); end else if (idtoken=_NODEFAULT) then begin consume(_NODEFAULT); p^.default:=0; end; symtablestack^.insert(p); { default property ? } consume(SEMICOLON); if (idtoken=_DEFAULT) then begin consume(_DEFAULT); p2:=search_default_property(aktclass); if assigned(p2) then message1(parser_e_only_one_default_property, pobjectdef(p2^.owner^.defowner)^.name^) else begin p^.options:=p^.options or ppo_defaultproperty; if not(assigned(propertyparas)) then message(parser_e_property_need_paras); end; consume(SEMICOLON); end; { clean up } if assigned(datacoll) then disposepdefcoll(datacoll); end else begin consume(ID); consume(SEMICOLON); end; if assigned(propertyparas) then disposepdefcoll(propertyparas); end; procedure destructor_head; begin consume(_DESTRUCTOR); inc(lexlevel); parse_proc_head(podestructor); dec(lexlevel); if (cs_constructor_name in aktglobalswitches) and (aktprocsym^.name<>'DONE') then Message(parser_e_destructorname_must_be_done); aktclass^.options:=aktclass^.options or oo_hasdestructor; consume(SEMICOLON); if assigned(aktprocsym^.definition^.para1) then Message(parser_e_no_paras_for_destructor); { no return value } aktprocsym^.definition^.retdef:=voiddef; end; var hs : string; pcrd : pclassrefdef; hp1 : pdef; oldprocsym : pprocsym; oldparse_only : boolean; intmessagetable,strmessagetable,classnamelabel : plabel; storetypeforwardsallowed : boolean; pt : ptree; begin {Nowadays aktprocsym may already have a value, so we need to save it.} oldprocsym:=aktprocsym; { forward is resolved } if assigned(fd) then fd^.options:=fd^.options and not(oo_isforward); there_is_a_destructor:=false; actmembertype:=sp_public; { objects and class types can't be declared local } if (symtablestack^.symtabletype<>globalsymtable) and (symtablestack^.symtabletype<>staticsymtable) then Message(parser_e_no_local_objects); storetypeforwardsallowed:=typecanbeforward; if m_tp in aktmodeswitches then typecanbeforward:=false; { distinguish classes and objects } if token=_OBJECT then begin is_a_class:=false; consume(_OBJECT) end else begin is_a_class:=true; consume(_CLASS); if not(assigned(fd)) and (token=_OF) then begin { a hack, but it's easy to handle } { class reference type } consume(_OF); if typecanbeforward then forwardsallowed:=true; hp1:=single_type(hs); { accept hp1, if is a forward def ...} if ((lasttypesym<>nil) and ((lasttypesym^.properties and sp_forwarddef)<>0)) or { or a class (if the foward defined type is a class is checked, when the forward is resolved) } ((hp1^.deftype=objectdef) and ( (pobjectdef(hp1)^.options and oo_is_class)<>0)) then begin pcrd:=new(pclassrefdef,init(hp1)); object_dec:=pcrd; if assigned(lasttypesym) and ((lasttypesym^.properties and sp_forwarddef)<>0) then lasttypesym^.addforwardpointer(ppointerdef(pcrd)); forwardsallowed:=false; end else begin Message(type_e_class_type_expected); object_dec:=new(perrordef,init); end; typecanbeforward:=storetypeforwardsallowed; exit; end { forward class } else if not(assigned(fd)) and (token=SEMICOLON) then begin { also anonym objects aren't allow (o : object a : longint; end;) } if n='' then begin Message(parser_f_no_anonym_objects) end; if n='TOBJECT' then begin aktclass:=new(pobjectdef,init(n,nil)); class_tobject:=aktclass; end else aktclass:=new(pobjectdef,init(n,nil)); aktclass^.options:=aktclass^.options or oo_is_class or oo_isforward; { all classes must have a vmt !! at offset zero } if (aktclass^.options and oo_hasvmt)=0 then aktclass^.insertvmt; object_dec:=aktclass; typecanbeforward:=storetypeforwardsallowed; exit; end; end; { also anonym objects aren't allow (o : object a : longint; end;) } if n='' then Message(parser_f_no_anonym_objects); { read the parent class } if token=LKLAMMER then begin consume(LKLAMMER); { does not allow objects.tobject !! } {if token<>ID then consume(ID); getsym(pattern,true);} childof:=pobjectdef(id_type(pattern)); if (childof^.deftype<>objectdef) then begin Message(type_e_class_type_expected); childof:=nil; end else begin { a mix of class and object isn't allowed } if (((childof^.options and oo_is_class)<>0) and not is_a_class) or (((childof^.options and oo_is_class)=0) and is_a_class) then Message(parser_e_mix_of_classes_and_objects); end; if assigned(fd) then begin { the forward of the child must be resolved to get correct field addresses } if (childof^.options and oo_isforward)<>0 then Message1(parser_e_forward_declaration_must_be_resolved,childof^.name^); aktclass:=fd; { we must inherit several options !! this was missing !! all is now done in set_parent including symtable datasize setting PM } fd^.set_parent(childof); end else aktclass:=new(pobjectdef,init(n,childof)); consume(RKLAMMER); end { if no parent class, then a class get tobject as parent } else if is_a_class then begin { is the current class tobject? } { so you could define your own tobject } if n='TOBJECT' then begin if assigned(fd) then aktclass:=fd else aktclass:=new(pobjectdef,init(n,nil)); class_tobject:=aktclass; end else begin childof:=class_tobject; if assigned(fd) then begin { the forward of the child must be resolved to get correct field addresses } if (childof^.options and oo_isforward)<>0 then Message1(parser_e_forward_declaration_must_be_resolved,childof^.name^); aktclass:=fd; aktclass^.set_parent(childof); end else begin aktclass:=new(pobjectdef,init(n,childof)); aktclass^.set_parent(childof); end; end; end else aktclass:=new(pobjectdef,init(n,nil)); { set the class attribute } if is_a_class then begin aktclass^.options:=aktclass^.options or oo_is_class; if (cs_generate_rtti in aktlocalswitches) or (assigned(aktclass^.childof) and ((aktclass^.childof^.options and oo_can_have_published)<>0) ) then aktclass^.options:=aktclass^.options or oo_can_have_published; end; aktobjectdef:=aktclass; { default access is public } actmembertype:=sp_public; aktclass^.publicsyms^.next:=symtablestack; symtablestack:=aktclass^.publicsyms; procinfo._class:=aktclass; testcurobject:=1; curobjectname:=n; { short class declaration ? } if (not is_a_class) or (token<>SEMICOLON) then begin { Parse componenten } repeat if actmembertype=sp_private then aktclass^.options:=aktclass^.options or oo_hasprivate; if actmembertype=sp_protected then aktclass^.options:=aktclass^.options or oo_hasprotected; case token of ID : begin case idtoken of _PRIVATE : begin consume(_PRIVATE); actmembertype:=sp_private; current_object_option:=sp_private; end; _PROTECTED : begin consume(_PROTECTED); current_object_option:=sp_protected; actmembertype:=sp_protected; end; _PUBLIC : begin consume(_PUBLIC); current_object_option:=sp_public; actmembertype:=sp_public; end; _PUBLISHED : begin if (aktclass^.options and oo_can_have_published)=0 then Message(parser_e_cant_have_published); consume(_PUBLISHED); current_object_option:=sp_published; actmembertype:=sp_published; end; else read_var_decs(false,true); end; end; _PROPERTY : property_dec; _PROCEDURE, _FUNCTION, _CLASS : begin oldparse_only:=parse_only; parse_only:=true; parse_proc_dec; if idtoken=_MESSAGE then begin { check parameter type } if assigned(aktprocsym^.definition^.para1^.next) or (aktprocsym^.definition^.para1^.paratyp<>vs_var) then Message(parser_e_ill_msg_param); consume(idtoken); pt:=comp_expr(true); do_firstpass(pt); if pt^.treetype=stringconstn then begin aktclass^.options:=aktclass^.options or oo_hasmsgstr; aktprocsym^.definition^.options:= aktprocsym^.definition^.options or pomsgstr; aktprocsym^.definition^.messageinf.str:=strnew(pt^.value_str); end else if is_constintnode(pt) then begin aktclass^.options:=aktclass^.options or oo_hasmsgint; aktprocsym^.definition^.options:= aktprocsym^.definition^.options or pomsgint; aktprocsym^.definition^.messageinf.i:=pt^.value; end else Message(parser_e_ill_msg_expr); disposetree(pt); consume(SEMICOLON); end else begin {$ifdef OLDOBJECTOPTIONS} case idtoken of _DYNAMIC, _VIRTUAL : begin if actmembertype=sp_private then Message(parser_w_priv_meth_not_virtual); consume(idtoken); consume(SEMICOLON); aktprocsym^.definition^.options:=aktprocsym^.definition^.options or povirtualmethod; aktclass^.options:=aktclass^.options or oo_hasvirtual; end; _OVERRIDE : begin consume(_OVERRIDE); consume(SEMICOLON); aktprocsym^.definition^.options:=aktprocsym^.definition^.options or pooverridingmethod or povirtualmethod; end; end; if idtoken=_ABSTRACT then begin if (aktprocsym^.definition^.options and povirtualmethod)<>0 then aktprocsym^.definition^.options:=aktprocsym^.definition^.options or poabstractmethod else Message(parser_e_only_virtual_methods_abstract); consume(_ABSTRACT); consume(SEMICOLON); { the method is defined } aktprocsym^.definition^.forwarddef:=false; end; if (cs_static_keyword in aktglobalswitches) and (idtoken=_STATIC) then begin consume(_STATIC); consume(SEMICOLON); aktprocsym^.properties:=aktprocsym^.properties or sp_static; aktprocsym^.definition^.options:=aktprocsym^.definition^.options or postaticmethod; end; {$else OLDOBJECTOPTIONS} parse_object_proc_directives(aktprocsym); {$endif def OLDOBJECTOPTIONS} end; parse_only:=oldparse_only; end; _CONSTRUCTOR : begin if actmembertype<>sp_public then Message(parser_w_constructor_should_be_public); oldparse_only:=parse_only; parse_only:=true; constructor_head; {$ifdef OLDOBJECTOPTIONS} case idtoken of _DYNAMIC, _VIRTUAL : begin if not(aktclass^.isclass) then Message(parser_e_constructor_cannot_be_not_virtual) else begin aktprocsym^.definition^.options:=aktprocsym^.definition^.options or povirtualmethod; aktclass^.options:=aktclass^.options or oo_hasvirtual; end; consume(idtoken); consume(SEMICOLON); end; _OVERRIDE : begin if (aktclass^.options and oo_is_class=0) then Message(parser_e_constructor_cannot_be_not_virtual) else aktprocsym^.definition^.options:=aktprocsym^.definition^.options or pooverridingmethod or povirtualmethod; consume(_OVERRIDE); consume(SEMICOLON); end; end; {$else OLDOBJECTOPTIONS} parse_object_proc_directives(aktprocsym); {$endif def OLDOBJECTOPTIONS} parse_only:=oldparse_only; end; _DESTRUCTOR : begin if there_is_a_destructor then Message(parser_n_only_one_destructor); there_is_a_destructor:=true; if actmembertype<>sp_public then Message(parser_w_destructor_should_be_public); oldparse_only:=parse_only; parse_only:=true; destructor_head; {$ifdef OLDOBJECTOPTIONS} case idtoken of _DYNAMIC, _VIRTUAL : begin consume(idtoken); consume(SEMICOLON); aktprocsym^.definition^.options:=aktprocsym^.definition^.options or povirtualmethod; aktclass^.options:=aktclass^.options or oo_hasvirtual; end; _OVERRIDE : begin consume(_OVERRIDE); consume(SEMICOLON); aktprocsym^.definition^.options:=aktprocsym^.definition^.options or pooverridingmethod or povirtualmethod; end; end; {$else OLDOBJECTOPTIONS} parse_object_proc_directives(aktprocsym); {$endif def OLDOBJECTOPTIONS} parse_only:=oldparse_only; end; _END : begin consume(_END); break; end; else consume(ID); { Give a ident expected message, like tp7 } end; until false; current_object_option:=sp_public; end; testcurobject:=0; curobjectname:=''; typecanbeforward:=storetypeforwardsallowed; { generate vmt space if needed } if ((aktclass^.options and (oo_hasvirtual or oo_hasconstructor or oo_hasdestructor or oo_is_class))<>0) and ((aktclass^.options and oo_hasvmt)=0) then aktclass^.insertvmt; if (cs_smartlink in aktmoduleswitches) then datasegment^.concat(new(pai_cut,init)); { write extended info for classes } if is_a_class then begin if (aktclass^.options and oo_can_have_published)<>0 then aktclass^.generate_rtti; { write class name } getlabel(classnamelabel); datasegment^.concat(new(pai_label,init(classnamelabel))); datasegment^.concat(new(pai_const,init_8bit(length(aktclass^.name^)))); datasegment^.concat(new(pai_string,init(aktclass^.name^))); { generate message and dynamic tables } { why generate those if empty ??? } if (aktclass^.options and oo_hasmsgstr)<>0 then strmessagetable:=genstrmsgtab(aktclass); if (aktclass^.options and oo_hasmsgint)<>0 then intmessagetable:=genintmsgtab(aktclass); { table for string messages } if (aktclass^.options and oo_hasmsgstr)<>0 then datasegment^.concat(new(pai_const_symbol,init(lab2str(strmessagetable)))) else datasegment^.concat(new(pai_const,init_32bit(0))); { interface table } datasegment^.concat(new(pai_const,init_32bit(0))); { auto table } datasegment^.concat(new(pai_const,init_32bit(0))); { inittable for con-/destruction } if aktclass^.needs_inittable then datasegment^.concat(new(pai_const_symbol,init(lab2str(aktclass^.get_inittable_label)))) else datasegment^.concat(new(pai_const,init_32bit(0))); { pointer to type info of published section } if (aktclass^.options and oo_can_have_published)<>0 then datasegment^.concat(new(pai_const_symbol,init(aktclass^.rtti_name))) else datasegment^.concat(new(pai_const,init_32bit(0))); { pointer to field table } datasegment^.concat(new(pai_const,init_32bit(0))); { pointer to method table } datasegment^.concat(new(pai_const,init_32bit(0))); { pointer to dynamic table } if (aktclass^.options and oo_hasmsgint)<>0 then datasegment^.concat(new(pai_const_symbol,init(lab2str(intmessagetable)))) else datasegment^.concat(new(pai_const,init_32bit(0))); { pointer to class name string } datasegment^.concat(new(pai_const_symbol,init(lab2str(classnamelabel)))); end; {$ifdef GDB} { generate the VMT } if (cs_debuginfo in aktmoduleswitches) and ((aktclass^.options and oo_hasvmt)<>0) then begin do_count_dbx:=true; if assigned(aktclass^.owner) and assigned(aktclass^.owner^.name) then datasegment^.concat(new(pai_stabs,init(strpnew('"vmt_'+aktclass^.owner^.name^+n+':S'+ typeglobalnumber('__vtbl_ptr_type')+'",'+tostr(N_STSYM)+',0,0,'+aktclass^.vmt_mangledname)))); end; {$endif GDB} if ((aktclass^.options and oo_hasvmt)<>0) then begin datasegment^.concat(new(pai_symbol,init_global(aktclass^.vmt_mangledname))); { determine the size with publicsyms^.datasize, because } { size gives back 4 for classes } datasegment^.concat(new(pai_const,init_32bit(aktclass^.publicsyms^.datasize))); datasegment^.concat(new(pai_const,init_32bit(-aktclass^.publicsyms^.datasize))); { write pointer to parent VMT, this isn't implemented in TP } { but this is not used in FPC ? (PM) } { it's not used yet, but the delphi-operators as and is need it (FK) } { it is not written for parents that don't have any vmt !! } if assigned(aktclass^.childof) and ((aktclass^.childof^.options and oo_hasvmt)<>0) then begin datasegment^.concat(new(pai_const_symbol,init(aktclass^.childof^.vmt_mangledname))); if aktclass^.childof^.owner^.symtabletype=unitsymtable then concat_external(aktclass^.childof^.vmt_mangledname,EXT_NEAR); end else datasegment^.concat(new(pai_const,init_32bit(0))); { this generates the entries } genvmt(aktclass); end; {$ifndef STORENUMBER} { number symbols and defs } symtablestack^.number_defs; symtablestack^.number_symbols; {$endif} { restore old state } symtablestack:=symtablestack^.next; procinfo._class:=nil; aktobjectdef:=nil; {Restore the aktprocsym.} aktprocsym:=oldprocsym; object_dec:=aktclass; end; { reads a record declaration } function record_dec : pdef; var symtable : psymtable; storetypeforwardsallowed : boolean; begin symtable:=new(psymtable,init(recordsymtable)); symtable^.next:=symtablestack; symtablestack:=symtable; consume(_RECORD); storetypeforwardsallowed:=typecanbeforward; if m_tp in aktmodeswitches then typecanbeforward:=false; read_var_decs(true,false); { may be scale record size to a size of n*4 ? } if ((symtablestack^.datasize mod aktpackrecords)<>0) then inc(symtablestack^.datasize,aktpackrecords-(symtablestack^.datasize mod aktpackrecords)); consume(_END); typecanbeforward:=storetypeforwardsallowed; {$ifndef STORENUMBER} { number symbols and defs } symtablestack^.number_defs; symtablestack^.number_symbols; {$endif} symtablestack:=symtable^.next; record_dec:=new(precdef,init(symtable)); end; { reads a type definition and returns a pointer to it } function read_type(const name : stringid) : pdef; function handle_procvar:Pprocvardef; var sc : pstringcontainer; s : string; p : pdef; varspez : tvarspez; procvardef : pprocvardef; begin procvardef:=new(pprocvardef,init); if token=LKLAMMER then begin consume(LKLAMMER); inc(testcurobject); repeat case token of _VAR : begin consume(_VAR); varspez:=vs_var; end; _CONST : begin consume(_CONST); varspez:=vs_const; end; else varspez:=vs_value; end; 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); if token=SEMICOLON then consume(SEMICOLON) else break; until false; dec(testcurobject); consume(RKLAMMER); end; handle_procvar:=procvardef; end; var hp1,p : pdef; aufdef : penumdef; aufsym : penumsym; ap : parraydef; s : stringid; l,v,oldaktpackrecords : longint; 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 begin consume(ID); p:=aktobjectdef; exit; end; { we can't accept a equal in type } pt1:=comp_expr(not(ignore_equal)); do_firstpass(pt1); if (token=POINTPOINT) then begin consume(POINTPOINT); { get high value of range } pt2:=comp_expr(not(ignore_equal)); do_firstpass(pt2); { both must be evaluated to constants now } if (pt1^.treetype<>ordconstn) or (pt2^.treetype<>ordconstn) then Message(sym_e_error_in_type_def) else begin { check types } if not is_equal(pt1^.resulttype,pt2^.resulttype) then Message(type_e_mismatch) else begin { Check bounds } if pt2^.value=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,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; 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; end; _RECORD: p:=record_dec; _PACKED: begin consume(_PACKED); if token=_ARRAY then array_dec else begin oldaktpackrecords:=aktpackrecords; aktpackrecords:=1; if token in [_CLASS,_OBJECT] then p:=object_dec(name,nil) else p:=record_dec; aktpackrecords:=oldaktpackrecords; end; end; _CLASS, _OBJECT: p:=object_dec(name,nil); _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; 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; end; else expr_type; end; if p=nil then p:=generrordef; read_type:=p; end; { reads a type declaration to the symbol table } procedure type_dec; var typename : stringid; newtype : ptypesym; sym : psym; begin block_type:=bt_type; consume(_TYPE); typecanbeforward:=true; repeat typename:=pattern; consume(ID); consume(EQUAL); { here you loose the strictness of pascal for which a redefinition like childtype = parenttype; child2type = parenttype; does not make the two child types equal !! here all vars from childtype and child2type get the definition of parenttype !! } {$ifdef testequaltype} if (token = ID) or (token=_FILE) or (token=_STRING) then begin olddef := single_type(s); { make a clone of olddef } { is that ok ??? } getmem(newdef,SizeOf(olddef)); move(olddef^,newdef^,SizeOf(olddef)); newtype:=new(ptypesym,init(typename,newdef)); symtablestack^.insert(newtype); end else {$endif testequaltype} begin getsym(typename,false); sym:=srsym; newtype:=nil; {$ifdef STORENUMBER} { found a symbol with this name? } if assigned(sym) then begin if (sym^.typ=typesym) then begin if (token=_CLASS) and (assigned(ptypesym(sym)^.definition)) and (ptypesym(sym)^.definition^.deftype=objectdef) and ((pobjectdef(ptypesym(sym)^.definition)^.options and oo_isforward)<>0) and ((pobjectdef(ptypesym(sym)^.definition)^.options and oo_is_class)<>0) then begin { we can ignore the result } { the definition is modified } object_dec(typename,pobjectdef(ptypesym(sym)^.definition)); newtype:=ptypesym(sym); end else if sym^.properties=sp_forwarddef then begin ptypesym(sym)^.updateforwarddef(read_type(typename)); newtype:=ptypesym(sym); end; end; end; { no old type reused ? Then insert this new type } if not assigned(newtype) then begin newtype:=new(ptypesym,init(typename,read_type(typename))); newtype:=ptypesym(symtablestack^.insert(newtype)); end; {$else} { check if it is the definition of a forward defined class } if assigned(srsym) and (token=_CLASS) and (srsym^.typ=typesym) and (assigned(ptypesym(srsym)^.definition)) and (ptypesym(srsym)^.definition^.deftype=objectdef) and ((pobjectdef(ptypesym(srsym)^.definition)^.options and oo_isforward)<>0) and ((pobjectdef(ptypesym(srsym)^.definition)^.options and oo_is_class)<>0) then begin { we can ignore the result } { the definition is modified } object_dec(typename,pobjectdef(ptypesym(srsym)^.definition)); newtype:=ptypesym(srsym); end else begin newtype:=new(ptypesym,init(typename,read_type(typename))); { load newtype with the new pointer to the inserted type because it can be an already defined forwarded type !! } newtype:=ptypesym(symtablestack^.insert(newtype)); end; {$endif} end; consume(SEMICOLON); if assigned(newtype^.definition) and (newtype^.definition^.deftype=procvardef) then parse_var_proc_directives(newtype); until token<>ID; typecanbeforward:=false; {$ifdef tp} symtablestack^.foreach(testforward_type); {$else} symtablestack^.foreach(@testforward_type); {$endif} resolve_forwards; block_type:=bt_general; end; procedure var_dec; { parses varaible declarations and inserts them in } { the top symbol table of symtablestack } begin consume(_VAR); read_var_decs(false,false); end; procedure Not_supported_for_inline(t : ttoken); begin if assigned(aktprocsym) and ((aktprocsym^.definition^.options and poinline)<>0) then Begin Message1(parser_w_not_supported_for_inline,tokenstring(t)); Message(parser_w_inlining_disabled); aktprocsym^.definition^.options:= aktprocsym^.definition^.options and not poinline; End; end; procedure read_declarations(islibrary : boolean); begin repeat case token of _LABEL: begin Not_supported_for_inline(token); label_dec; end; _CONST: begin Not_supported_for_inline(token); const_dec; end; _TYPE: begin Not_supported_for_inline(token); type_dec; end; _VAR: var_dec; _CONSTRUCTOR,_DESTRUCTOR, _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS: begin Not_supported_for_inline(token); read_proc; end; _EXPORTS: begin Not_supported_for_inline(token); { here we should be at lexlevel 1, no ? PM } if (lexlevel<>main_program_level) or (not islibrary and not DLLsource) then begin Message(parser_e_syntax_error); consume_all_until(SEMICOLON); end else if islibrary then read_exports; end else break; end; until false; end; procedure read_interface_declarations; begin {Since the body is now parsed at lexlevel 1, and the declarations must be parsed at the same lexlevel we increase the lexlevel.} inc(lexlevel); repeat case token of _CONST : const_dec; _TYPE : type_dec; _VAR : var_dec; _FUNCTION, _PROCEDURE, _OPERATOR : read_proc; else break; end; until false; dec(lexlevel); end; end. { $Log$ Revision 1.108 1999-04-17 13:16:19 peter * fixes for storenumber Revision 1.107 1999/04/14 09:14:50 peter * first things to store the symbol/def number in the ppu Revision 1.106 1999/04/07 15:31:15 pierre * all formaldefs are now a sinlge definition cformaldef (this was necessary for double_checksum) + small part of double_checksum code Revision 1.105 1999/03/26 00:05:34 peter * released valintern + deffile is now removed when compiling is finished * ^( compiles now correct + static directive * shrd fixed Revision 1.104 1999/03/24 23:17:13 peter * fixed bugs 212,222,225,227,229,231,233 Revision 1.103 1999/03/22 22:10:25 florian * typecanbeforward wasn't always restored in object_dec which sometimes caused strange effects Revision 1.102 1999/03/05 01:14:26 pierre * bug0198 : call conventions for methods not yet implemented is the control of same calling convention for virtual and child's virtual * msgstr and msgint only created if message was found who implemented this by the way ? it leaks lots of plabels !!!! (check with heaptrc !) Revision 1.101 1999/02/25 21:02:41 peter * ag386bin updates + coff writer Revision 1.100 1999/02/24 00:59:14 peter * small updates for ag386bin Revision 1.99 1999/02/22 23:33:29 florian + message directive for integers added Revision 1.98 1999/02/22 20:13:36 florian + first implementation of message keyword Revision 1.97 1999/02/22 02:44:10 peter * ag386bin doesn't use i386.pas anymore Revision 1.96 1999/02/17 14:20:40 pierre * Reference specific bug in recompiling unit solved Revision 1.95 1999/01/25 20:13:48 peter * fixed crash with forward declared class of ... Revision 1.94 1999/01/19 12:17:00 peter * fixed constant strings > 255 chars Revision 1.93 1999/01/15 13:08:23 peter * error if upper255 added * small problem with TP fixed Revision 1.74 1998/10/20 13:09:13 peter * fixed object(unknown) crash Revision 1.73 1998/10/19 08:54:56 pierre * wrong stabs info corrected once again !! + variable vmt offset with vmt field only if required implemented now !!! Revision 1.72 1998/10/16 13:12:51 pierre * added vmt_offsets in destructors code also !!! * vmt_offset code for m68k Revision 1.71 1998/10/15 15:13:25 pierre + added oo_hasconstructor and oo_hasdestructor for objects options Revision 1.70 1998/10/13 13:10:22 peter * new style for m68k/i386 infos and enums Revision 1.69 1998/10/09 12:07:49 pierre * typo error for propertyparas dispose corrected Revision 1.68 1998/10/09 11:47:54 pierre * still more memory leaks fixes !! Revision 1.67 1998/10/08 13:48:46 peter * fixed memory leaks for do nothing source * fixed unit interdependency Revision 1.66 1998/10/06 20:43:31 peter * fixed set of bugs. like set of false..true set of #1..#255 and set of #1..true which was allowed Revision 1.65 1998/10/05 22:43:35 peter * commited the wrong file :( Revision 1.64 1998/10/05 21:33:24 peter * fixed 161,165,166,167,168 Revision 1.63 1998/10/05 13:57:13 peter * crash preventions Revision 1.62 1998/10/02 17:06:02 peter * better error message for unresolved forward types Revision 1.61 1998/10/02 09:23:24 peter * fixed error msg with type l= * block_type bt_const is now set in read_const_dec Revision 1.60 1998/09/30 07:40:33 florian * better error recovering Revision 1.59 1998/09/26 17:45:33 peter + idtoken and only one token table Revision 1.58 1998/09/25 00:04:01 florian * problems when calling class methods fixed Revision 1.57 1998/09/24 23:49:09 peter + aktmodeswitches Revision 1.56 1998/09/23 15:39:09 pierre * browser bugfixes was adding a reference when looking for the symbol if -bSYM_NAME was used Revision 1.55 1998/09/21 13:24:44 daniel * Memory leak fixed. Revision 1.54 1998/09/17 13:41:16 pierre sizeof(TPOINT) problem Revision 1.53.2.1 1998/09/17 13:12:09 pierre * virtual destructor did not set oo_hasvirtual (detected with the sizeof(TPoint) problem * genloadcallnode was missing Revision 1.53 1998/09/09 11:50:52 pierre * forward def are not put in record or objects + added check for forwards also in record and objects * dummy parasymtable for unit initialization removed from symtable stack Revision 1.52 1998/09/07 23:10:22 florian * a lot of stuff fixed regarding rtti and publishing of properties, basics should now work Revision 1.51 1998/09/07 19:33:22 florian + some stuff for property rtti added: - NameIndex of the TPropInfo record is now written correctly - the DEFAULT/NODEFAULT keyword is supported now - the default value and the storedsym/def are now written to the PPU fiel 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 * updated some error messages Revision 1.47 1998/09/03 16:03:18 florian + rtti generation * init table generation changed Revision 1.46 1998/09/01 17:39:48 peter + internal constant functions Revision 1.45 1998/08/31 12:20:28 peter * fixed array_dec when unknown type was used Revision 1.44 1998/08/28 10:57:01 peter * removed warnings Revision 1.43 1998/08/25 13:09:25 pierre * corrected mangling sheme : cvar add Cprefix to the mixed case name whereas export or public use direct name Revision 1.42 1998/08/25 12:42:41 pierre * CDECL changed to CVAR for variables specifications are read in structures also + started adding GPC compatibility mode ( option -Sp) * names changed to lowercase Revision 1.41 1998/08/23 21:04:36 florian + rtti generation for classes added + new/dispose do now also a call to INITIALIZE/FINALIZE, if necessaray Revision 1.40 1998/08/21 15:48:58 pierre * more cdecl chagnes - better line info - changes the definition options of a procvar if it is a unnamed type Revision 1.39 1998/08/19 00:42:40 peter + subrange types for enums + checking for bounds type with ranges Revision 1.38 1998/08/12 19:20:39 peter + public is the same as export for c_vars * a exported/public c_var incs now the refcount Revision 1.37 1998/08/11 15:31:38 peter * write extended to ppu file * new version 0.99.7 Revision 1.36 1998/08/10 14:50:09 peter + localswitches, moduleswitches, globalswitches splitting Revision 1.35 1998/07/26 21:59:00 florian + better support for switch $H + index access to ansi strings added + assigment of data (records/arrays) containing ansi strings Revision 1.34 1998/07/20 22:17:15 florian * hex constants in numeric char (#$54#$43 ...) are now allowed * there was a bug in record_var_dec which prevents the used of nested variant records (for example drivers.tevent of tv) Revision 1.33 1998/07/18 17:11:11 florian + ansi string constants fixed + switch $H partial implemented Revision 1.32 1998/07/14 21:46:50 peter * updated messages file Revision 1.31 1998/07/14 14:46:53 peter * released NEWINPUT Revision 1.30 1998/07/10 00:00:00 peter * fixed ttypesym bug finally * fileinfo in the symtable and better using for unused vars Revision 1.29 1998/06/25 14:04:21 peter + internal inc/dec Revision 1.28 1998/06/24 12:26:45 peter * stricter var parsing like tp7 and some optimizes with directive parsing Revision 1.27 1998/06/12 16:15:34 pierre * external name 'C_var'; export name 'intern_C_var'; cdecl; cdecl;external; are now supported only with -Sv switch Revision 1.25 1998/06/09 16:01:45 pierre + added procedure directive parsing for procvars (accepted are popstack cdecl and pascal) + added C vars with the following syntax var C calias 'true_c_name';(can be followed by external) reason is that you must add the Cprefix which is target dependent Revision 1.24 1998/06/05 14:37:32 pierre * fixes for inline for operators * inline procedure more correctly restricted Revision 1.23 1998/06/04 23:51:50 peter * m68k compiles + .def file creation moved to gendef.pas so it could also be used for win32 Revision 1.22 1998/06/03 22:48:59 peter + wordbool,longbool * rename bis,von -> high,low * moved some systemunit loading/creating to psystem.pas Revision 1.21 1998/06/03 22:14:19 florian * problem with sizes of classes fixed (if the anchestor was declared forward, the compiler doesn't update the child classes size) Revision 1.20 1998/05/28 14:35:54 peter * nicer error message when no id is used after var Revision 1.19 1998/05/23 01:21:19 peter + aktasmmode, aktoptprocessor, aktoutputformat + smartlink per module $SMARTLINK-/+ (like MMX) and moved to aktswitches + $LIBNAME to set the library name where the unit will be put in * splitted cgi386 a bit (codeseg to large for bp7) * nasm, tasm works again. nasm moved to ag386nsm.pas Revision 1.18 1998/05/20 09:42:35 pierre + UseTokenInfo now default * unit in interface uses and implementation uses gives error now * only one error for unknown symbol (uses lastsymknown boolean) the problem came from the label code ! + first inlined procedures and function work (warning there might be allowed cases were the result is still wrong !!) * UseBrower updated gives a global list of all position of all used symbols with switch -gb Revision 1.17 1998/05/11 13:07:55 peter + $ifdef NEWPPU for the new ppuformat + $define GDB not longer required * removed all warnings and stripped some log comments * no findfirst/findnext anymore to remove smartlink *.o files Revision 1.16 1998/05/05 12:05:42 florian * problems with properties fixed * crash fixed: i:=l when i and l are undefined, was a problem with implementation of private/protected Revision 1.15 1998/05/01 09:01:23 florian + correct semantics of private and protected * small fix in variable scope: a id can be used in a parameter list of a method, even it is used in an anchestor class as field id Revision 1.14 1998/05/01 07:43:56 florian + basics for rtti implemented + switch $m (generate rtti for published sections) Revision 1.13 1998/04/30 15:59:41 pierre * GDB works again better : correct type info in one pass + UseTokenInfo for better source position * fixed one remaining bug in scanner for line counts * several little fixes Revision 1.12 1998/04/29 10:33:57 pierre + added some code for ansistring (not complete nor working yet) * corrected operator overloading * corrected nasm output + started inline procedures + added starstarn : use ** for exponentiation (^ gave problems) + started UseTokenInfo cond to get accurate positions Revision 1.11 1998/04/28 11:45:52 florian * make it compilable with TP + small COM problems solved to compile classes.pp Revision 1.10 1998/04/27 23:10:28 peter + new scanner * $makelib -> if smartlink * small filename fixes pmodule.setfilename * moved import from files.pas -> import.pas Revision 1.9 1998/04/10 21:36:56 florian + some stuff to support method pointers (procedure of object) added (declaration, parameter handling) Revision 1.8 1998/04/10 15:39:48 florian * more fixes to get classes.pas compiled Revision 1.7 1998/04/09 23:02:15 florian * small problems solved to get remake3 work Revision 1.6 1998/04/09 22:16:35 florian * problem with previous REGALLOC solved * improved property support Revision 1.5 1998/04/08 14:59:20 florian * problem with new expr_type solved Revision 1.4 1998/04/08 10:26:09 florian * correct error handling of virtual constructors * problem with new type declaration handling fixed Revision 1.3 1998/04/07 22:45:05 florian * bug0092, bug0115 and bug0121 fixed + packed object/class/array Revision 1.2 1998/04/05 13:58:35 peter * fixed the -Ss bug + warning for Virtual constructors * helppages updated with -TGO32V1 }