summaryrefslogtreecommitdiff
path: root/compiler/pdecvar.pas
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/pdecvar.pas')
-rw-r--r--compiler/pdecvar.pas1318
1 files changed, 1318 insertions, 0 deletions
diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas
new file mode 100644
index 0000000000..0540bdf91b
--- /dev/null
+++ b/compiler/pdecvar.pas
@@ -0,0 +1,1318 @@
+{
+ Copyright (c) 1998-2002 by Florian Klaempfl
+
+ Parses variable declarations. Used for var statement and record
+ definitions
+
+ 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 pdecvar;
+
+{$i fpcdefs.inc}
+
+interface
+
+ uses
+ symsym,symdef;
+
+ type Tvar_dec_option=(vd_record,vd_object,vd_threadvar);
+ Tvar_dec_options=set of Tvar_dec_option;
+
+ function read_property_dec(aclass:tobjectdef):tpropertysym;
+
+ procedure read_var_decs(options:Tvar_dec_options);
+
+
+implementation
+
+ uses
+ { common }
+ cutils,cclasses,
+ { global }
+ globtype,globals,tokens,verbose,
+ systems,
+ { symtable }
+ symconst,symbase,symtype,symtable,defutil,defcmp,
+ fmodule,
+ { pass 1 }
+ node,pass_1,
+ nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nmem,
+ { codegen }
+ ncgutil,
+ { parser }
+ scanner,
+ pbase,pexpr,ptype,ptconst,pdecsub,
+ { link }
+ import
+ ;
+
+
+ function read_property_dec(aclass:tobjectdef):tpropertysym;
+
+ { convert a node tree to symlist and return the last
+ symbol }
+ function parse_symlist(pl:tsymlist;var def:tdef):boolean;
+ var
+ idx : longint;
+ sym : tsym;
+ srsymtable : tsymtable;
+ st : tsymtable;
+ p : tnode;
+ begin
+ result:=true;
+ def:=nil;
+ if token=_ID then
+ begin
+ if assigned(aclass) then
+ sym:=search_class_member(aclass,pattern)
+ else
+ searchsym(pattern,sym,srsymtable);
+ if assigned(sym) then
+ begin
+ case sym.typ of
+ fieldvarsym :
+ begin
+ pl.addsym(sl_load,sym);
+ def:=tfieldvarsym(sym).vartype.def;
+ end;
+ procsym :
+ begin
+ pl.addsym(sl_call,sym);
+ end;
+ else
+ begin
+ Message1(parser_e_illegal_field_or_method,orgpattern);
+ result:=false;
+ end;
+ end;
+ end
+ else
+ begin
+ Message1(parser_e_illegal_field_or_method,orgpattern);
+ result:=false;
+ end;
+ consume(_ID);
+ repeat
+ case token of
+ _ID,
+ _SEMICOLON :
+ begin
+ break;
+ end;
+ _POINT :
+ begin
+ consume(_POINT);
+ if assigned(def) then
+ begin
+ st:=def.getsymtable(gs_record);
+ if assigned(st) then
+ begin
+ sym:=searchsymonlyin(st,pattern);
+ if assigned(sym) then
+ begin
+ pl.addsym(sl_subscript,sym);
+ case sym.typ of
+ fieldvarsym :
+ def:=tfieldvarsym(sym).vartype.def;
+ else
+ begin
+ Message1(sym_e_illegal_field,orgpattern);
+ result:=false;
+ end;
+ end;
+ end
+ else
+ begin
+ Message1(sym_e_illegal_field,orgpattern);
+ result:=false;
+ end;
+ end
+ else
+ begin
+ Message(parser_e_invalid_qualifier);
+ result:=false;
+ end;
+ end
+ else
+ begin
+ Message(parser_e_invalid_qualifier);
+ result:=false;
+ end;
+ consume(_ID);
+ end;
+ _LECKKLAMMER :
+ begin
+ consume(_LECKKLAMMER);
+ repeat
+ if def.deftype=arraydef then
+ begin
+ idx:=0;
+ p:=comp_expr(true);
+ if (not codegenerror) then
+ begin
+ if (p.nodetype=ordconstn) then
+ begin
+ if compare_defs(p.resulttype.def,tarraydef(def).rangetype.def,nothingn)>=te_equal then
+ idx:=tordconstnode(p).value
+ else
+ IncompatibleTypes(p.resulttype.def,tarraydef(def).rangetype.def);
+ end
+ else
+ Message(type_e_ordinal_expr_expected)
+ end;
+ p.free;
+ pl.addconst(sl_vec,idx);
+ def:=tarraydef(def).elementtype.def;
+ end
+ else
+ begin
+ Message(parser_e_invalid_qualifier);
+ result:=false;
+ end;
+ until not try_to_consume(_COMMA);
+ consume(_RECKKLAMMER);
+ end;
+ else
+ begin
+ Message(parser_e_ill_property_access_sym);
+ result:=false;
+ break;
+ end;
+ end;
+ until false;
+ end
+ else
+ begin
+ Message(parser_e_ill_property_access_sym);
+ result:=false;
+ end;
+ end;
+
+ var
+ sym : tsym;
+ p : tpropertysym;
+ overriden : tsym;
+ varspez : tvarspez;
+ tt : ttype;
+ arraytype : ttype;
+ def : tdef;
+ pt : tnode;
+ propname : stringid;
+ sc : tsinglelist;
+ paranr : word;
+ oldregisterdef : boolean;
+ hreadparavs,
+ hparavs : tparavarsym;
+ readprocdef,
+ writeprocdef : tprocvardef;
+ oldsymtablestack : tsymtable;
+ begin
+ { Generate temp procvardefs to search for matching read/write
+ procedures. the readprocdef will store all definitions }
+ oldregisterdef:=registerdef;
+ registerdef:=false;
+ paranr:=0;
+ readprocdef:=tprocvardef.create(normal_function_level);
+ writeprocdef:=tprocvardef.create(normal_function_level);
+ registerdef:=oldregisterdef;
+
+ { make it method pointers }
+ if assigned(aclass) then
+ begin
+ include(readprocdef.procoptions,po_methodpointer);
+ include(writeprocdef.procoptions,po_methodpointer);
+ end;
+
+ if token<>_ID then
+ begin
+ consume(_ID);
+ consume(_SEMICOLON);
+ exit;
+ end;
+ { Generate propertysym and insert in symtablestack }
+ p:=tpropertysym.create(orgpattern);
+ symtablestack.insert(p);
+ propname:=pattern;
+ consume(_ID);
+ { Set the symtablestack to the parast of readprop so
+ temp defs will be destroyed after declaration }
+ readprocdef.parast.next:=symtablestack;
+ symtablestack:=readprocdef.parast;
+ { property parameters ? }
+ if token=_LECKKLAMMER then
+ begin
+ if (sp_published in current_object_option) then
+ Message(parser_e_cant_publish_that_property);
+
+ { create a list of the parameters }
+ sc:=tsinglelist.create;
+ 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 if (idtoken=_OUT) and (m_out in aktmodeswitches) then
+ begin
+ consume(_OUT);
+ varspez:=vs_out;
+ end
+ else
+ varspez:=vs_value;
+ sc.reset;
+ repeat
+ inc(paranr);
+ hreadparavs:=tparavarsym.create(orgpattern,10*paranr,varspez,generrortype,[]);
+ readprocdef.parast.insert(hreadparavs);
+ sc.insert(hreadparavs);
+ consume(_ID);
+ until not try_to_consume(_COMMA);
+ if try_to_consume(_COLON) then
+ begin
+ { for records, don't search the recordsymtable for
+ the symbols of the types }
+ oldsymtablestack:=symtablestack;
+ symtablestack:=symtablestack.next;
+ if try_to_consume(_ARRAY) then
+ begin
+ consume(_OF);
+ { define range and type of range }
+ tt.setdef(tarraydef.create(0,-1,s32inttype));
+ { define field type }
+ single_type(arraytype,false);
+ tarraydef(tt.def).setelementtype(arraytype);
+ end
+ else
+ single_type(tt,false);
+ symtablestack:=oldsymtablestack;
+ end
+ else
+ tt:=cformaltype;
+ hreadparavs:=tparavarsym(sc.first);
+ while assigned(hreadparavs) do
+ begin
+ hreadparavs.vartype:=tt;
+ { also update the writeprocdef }
+ hparavs:=tparavarsym.create(hreadparavs.realname,hreadparavs.paranr,vs_value,tt,[]);
+ writeprocdef.parast.insert(hparavs);
+ hreadparavs:=tparavarsym(hreadparavs.listnext);
+ end;
+ until not try_to_consume(_SEMICOLON);
+ sc.free;
+ dec(testcurobject);
+ consume(_RECKKLAMMER);
+
+ { the parser need to know if a property has parameters, the
+ index parameter doesn't count (PFV) }
+ if paranr>0 then
+ include(p.propoptions,ppo_hasparameters);
+ end;
+ { overriden property ? }
+ { force property interface
+ there is a property parameter
+ a global property }
+ if (token=_COLON) or (paranr>0) or (aclass=nil) then
+ begin
+ consume(_COLON);
+ { insert types in global symtable }
+ oldsymtablestack:=symtablestack;
+ while not(symtablestack.symtabletype in [globalsymtable,staticsymtable]) do
+ symtablestack:=symtablestack.next;
+ single_type(p.proptype,false);
+ symtablestack:=oldsymtablestack;
+ if (idtoken=_INDEX) then
+ begin
+ consume(_INDEX);
+ pt:=comp_expr(true);
+ if is_constnode(pt) and
+ is_ordinal(pt.resulttype.def)
+{$ifndef cpu64bit}
+ and (not is_64bitint(pt.resulttype.def))
+{$endif}
+ then
+ p.index:=tordconstnode(pt).value
+ else
+ begin
+ Message(parser_e_invalid_property_index_value);
+ p.index:=0;
+ end;
+ p.indextype.setdef(pt.resulttype.def);
+ include(p.propoptions,ppo_indexed);
+ { concat a longint to the para templates }
+ inc(paranr);
+ hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indextype,[]);
+ readprocdef.parast.insert(hparavs);
+ hparavs:=tparavarsym.create('$index',10*paranr,vs_value,p.indextype,[]);
+ writeprocdef.parast.insert(hparavs);
+ pt.free;
+ end;
+ end
+ else
+ begin
+ { do an property override }
+ overriden:=search_class_member(aclass.childof,propname);
+ if assigned(overriden) and (overriden.typ=propertysym) then
+ begin
+ p.dooverride(tpropertysym(overriden));
+ end
+ else
+ begin
+ p.proptype:=generrortype;
+ message(parser_e_no_property_found_to_override);
+ end;
+ end;
+ if (sp_published in current_object_option) and
+ not(p.proptype.def.is_publishable) then
+ Message(parser_e_cant_publish_that_property);
+
+ if try_to_consume(_READ) then
+ begin
+ p.readaccess.clear;
+ if parse_symlist(p.readaccess,def) then
+ begin
+ sym:=p.readaccess.firstsym^.sym;
+ case sym.typ of
+ procsym :
+ begin
+ { read is function returning the type of the property }
+ readprocdef.rettype:=p.proptype;
+ { Insert hidden parameters }
+ handle_calling_convention(readprocdef);
+ { search procdefs matching readprocdef }
+ { we ignore hidden stuff here because the property access symbol might have
+ non default calling conventions which might change the hidden stuff;
+ see tw3216.pp (FK) }
+ p.readaccess.procdef:=Tprocsym(sym).search_procdef_bypara(readprocdef.paras,p.proptype.def,[cpo_allowdefaults,cpo_ignorehidden,cpo_allowconvert]);
+ if not assigned(p.readaccess.procdef) then
+ Message(parser_e_ill_property_access_sym);
+ end;
+ fieldvarsym :
+ begin
+ if not assigned(def) then
+ internalerror(200310071);
+ if compare_defs(def,p.proptype.def,nothingn)>=te_equal then
+ begin
+ { property parameters are allowed if this is
+ an indexed property, because the index is then
+ the parameter.
+ Note: In the help of Kylix it is written
+ that it isn't allowed, but the compiler accepts it (PFV) }
+ if (ppo_hasparameters in p.propoptions) then
+ Message(parser_e_ill_property_access_sym);
+ end
+ else
+ IncompatibleTypes(def,p.proptype.def);
+ end;
+ else
+ Message(parser_e_ill_property_access_sym);
+ end;
+ end;
+ end;
+ if try_to_consume(_WRITE) then
+ begin
+ p.writeaccess.clear;
+ if parse_symlist(p.writeaccess,def) then
+ begin
+ sym:=p.writeaccess.firstsym^.sym;
+ case sym.typ of
+ procsym :
+ begin
+ { write is a procedure with an extra value parameter
+ of the of the property }
+ writeprocdef.rettype:=voidtype;
+ inc(paranr);
+ hparavs:=tparavarsym.create('$value',10*paranr,vs_value,p.proptype,[]);
+ writeprocdef.parast.insert(hparavs);
+ { Insert hidden parameters }
+ handle_calling_convention(writeprocdef);
+ { search procdefs matching writeprocdef }
+ p.writeaccess.procdef:=Tprocsym(sym).search_procdef_bypara(writeprocdef.paras,writeprocdef.rettype.def,[cpo_allowdefaults,cpo_allowconvert]);
+ if not assigned(p.writeaccess.procdef) then
+ Message(parser_e_ill_property_access_sym);
+ end;
+ fieldvarsym :
+ begin
+ if not assigned(def) then
+ internalerror(200310072);
+ if compare_defs(def,p.proptype.def,nothingn)>=te_equal then
+ begin
+ { property parameters are allowed if this is
+ an indexed property, because the index is then
+ the parameter.
+ Note: In the help of Kylix it is written
+ that it isn't allowed, but the compiler accepts it (PFV) }
+ if (ppo_hasparameters in p.propoptions) then
+ Message(parser_e_ill_property_access_sym);
+ end
+ else
+ IncompatibleTypes(def,p.proptype.def);
+ end;
+ else
+ Message(parser_e_ill_property_access_sym);
+ end;
+ end;
+ end;
+ if assigned(aclass) then
+ begin
+ include(p.propoptions,ppo_stored);
+ if try_to_consume(_STORED) then
+ begin
+ p.storedaccess.clear;
+ case token of
+ _ID:
+ begin
+ { in the case that idtoken=_DEFAULT }
+ { we have to do nothing except }
+ { setting ppo_stored, it's the same }
+ { as stored true }
+ if idtoken<>_DEFAULT then
+ begin
+ if parse_symlist(p.storedaccess,def) then
+ begin
+ sym:=p.storedaccess.firstsym^.sym;
+ case sym.typ of
+ procsym :
+ begin
+ p.storedaccess.procdef:=Tprocsym(sym).search_procdef_nopara_boolret;
+ if not assigned(p.storedaccess.procdef) then
+ message(parser_e_ill_property_storage_sym);
+ end;
+ fieldvarsym :
+ begin
+ if not assigned(def) then
+ internalerror(200310073);
+ if (ppo_hasparameters in p.propoptions) or
+ not(is_boolean(def)) then
+ Message(parser_e_stored_property_must_be_boolean);
+ end;
+ else
+ Message(parser_e_ill_property_access_sym);
+ end;
+ end;
+ end;
+ end;
+ _FALSE:
+ begin
+ consume(_FALSE);
+ exclude(p.propoptions,ppo_stored);
+ end;
+ _TRUE:
+ consume(_TRUE);
+ end;
+ end;
+ end;
+ if try_to_consume(_DEFAULT) then
+ begin
+ if not(is_ordinal(p.proptype.def) or
+{$ifndef cpu64bit}
+ is_64bitint(p.proptype.def) or
+{$endif cpu64bit}
+ is_class(p.proptype.def) or
+ is_single(p.proptype.def) or
+ (p.proptype.def.deftype in [classrefdef,pointerdef]) or
+ ((p.proptype.def.deftype=setdef) and
+ (tsetdef(p.proptype.def).settype=smallset))) or
+ ((p.proptype.def.deftype=arraydef) and
+ (ppo_indexed in p.propoptions)) or
+ (ppo_hasparameters in p.propoptions) then
+ begin
+ Message(parser_e_property_cant_have_a_default_value);
+ { Error recovery }
+ pt:=comp_expr(true);
+ pt.free;
+ end
+ else
+ begin
+ { Get the result of the default, the firstpass is
+ needed to support values like -1 }
+ pt:=comp_expr(true);
+ if (p.proptype.def.deftype=setdef) and
+ (pt.nodetype=arrayconstructorn) then
+ begin
+ arrayconstructor_to_set(pt);
+ do_resulttypepass(pt);
+ end;
+ inserttypeconv(pt,p.proptype);
+ if not(is_constnode(pt)) then
+ Message(parser_e_property_default_value_must_const);
+ { Set default value }
+ case pt.nodetype of
+ setconstn :
+ p.default:=plongint(tsetconstnode(pt).value_set)^;
+ ordconstn :
+ p.default:=longint(tordconstnode(pt).value);
+ niln :
+ p.default:=0;
+ realconstn:
+ p.default:=longint(single(trealconstnode(pt).value_real));
+ end;
+ pt.free;
+ end;
+ end
+ else if try_to_consume(_NODEFAULT) then
+ begin
+ p.default:=0;
+ end;
+ { remove temporary procvardefs }
+ symtablestack:=symtablestack.next;
+ readprocdef.free;
+ writeprocdef.free;
+ result:=p;
+ end;
+
+
+ const
+ variantrecordlevel : longint = 0;
+
+ procedure read_var_decs(options:Tvar_dec_options);
+ { 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 }
+
+ procedure insert_syms(sc : tsinglelist;tt : ttype;is_threadvar : boolean; addsymopts : tsymoptions);
+ { inserts the symbols of sc in st with def as definition or sym as ttypesym, sc is disposed }
+ var
+ vs : tabstractvarsym;
+ hstaticvs : tglobalvarsym;
+ begin
+ vs:=tabstractvarsym(sc.first);
+ while assigned(vs) do
+ begin
+ vs.vartype:=tt;
+ { insert any additional hint directives }
+ vs.symoptions := vs.symoptions + addsymopts;
+ if (sp_static in current_object_option) then
+ include(vs.symoptions,sp_static);
+ if is_threadvar then
+ include(vs.varoptions,vo_is_thread_var);
+ { static data fields are inserted in the globalsymtable }
+ if (symtablestack.symtabletype=objectsymtable) and
+ (sp_static in current_object_option) then
+ begin
+ hstaticvs:=tglobalvarsym.create('$'+lower(symtablestack.name^)+'_'+vs.name,vs_value,tt,[]);
+ symtablestack.defowner.owner.insert(hstaticvs);
+ insertbssdata(hstaticvs);
+ end
+ else
+ begin
+ { external data is not possible here }
+ case symtablestack.symtabletype of
+ globalsymtable,
+ staticsymtable :
+ insertbssdata(tglobalvarsym(vs));
+ recordsymtable,
+ objectsymtable :
+ tabstractrecordsymtable(symtablestack).insertfield(tfieldvarsym(vs),false);
+ end;
+ end;
+ vs:=tabstractvarsym(vs.listnext);
+ end;
+ end;
+
+
+ procedure read_default_value(sc : tsinglelist;tt : ttype;is_threadvar : boolean);
+ var
+ vs : tabstractnormalvarsym;
+ tcsym : ttypedconstsym;
+ begin
+ vs:=tabstractnormalvarsym(sc.first);
+ if assigned(vs.listnext) then
+ Message(parser_e_initialized_only_one_var);
+ if is_threadvar then
+ Message(parser_e_initialized_not_for_threadvar);
+ if symtablestack.symtabletype=localsymtable then
+ begin
+ consume(_EQUAL);
+ tcsym:=ttypedconstsym.createtype('default'+vs.realname,tt,false);
+ vs.defaultconstsym:=tcsym;
+ symtablestack.insert(tcsym);
+ readtypedconst(tt,tcsym,false);
+ { The variable has a value assigned }
+ vs.varstate:=vs_assigned;
+ end
+ else
+ begin
+ tcsym:=ttypedconstsym.createtype(vs.realname,tt,true);
+ tcsym.fileinfo:=vs.fileinfo;
+ symtablestack.replace(vs,tcsym);
+ vs.free;
+ consume(_EQUAL);
+ readtypedconst(tt,tcsym,true);
+ end;
+ end;
+
+ var
+ sc : tsinglelist;
+ old_block_type : tblock_type;
+ symdone : boolean;
+ { to handle absolute }
+ abssym : tabsolutevarsym;
+ { c var }
+ newtype : ttypesym;
+ is_dll,
+ hasdefaultvalue,
+ is_gpc_name,is_cdecl,
+ extern_var,export_var : boolean;
+ old_current_object_option : tsymoptions;
+ hs,sorg,C_name,dll_name : string;
+ tt,casetype : ttype;
+ { maxsize contains the max. size of a variant }
+ { startvarrec contains the start of the variant part of a record }
+ maxsize, startvarrecsize : longint;
+ usedalign,
+ maxalignment,startvarrecalign,
+ maxpadalign, startpadalign: shortint;
+ hp,pt : tnode;
+ fieldvs : tfieldvarsym;
+ vs,vs2 : tabstractvarsym;
+ srsym : tsym;
+ oldsymtablestack,
+ srsymtable : tsymtable;
+ unionsymtable : trecordsymtable;
+ offset : longint;
+ uniondef : trecorddef;
+ unionsym : tfieldvarsym;
+ uniontype : ttype;
+ dummysymoptions : tsymoptions;
+ semicolonatend,semicoloneaten: boolean;
+{$ifdef powerpc}
+ tempdef: tdef;
+ is_first_field: boolean;
+{$endif powerpc}
+ begin
+{$ifdef powerpc}
+ is_first_field := true;
+{$endif powerpc}
+ old_current_object_option:=current_object_option;
+ { all variables are public if not in a object declaration }
+ if not(vd_object in options) then
+ current_object_option:=[sp_public];
+ 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 }
+ sc:=tsinglelist.create;
+ while (token=_ID) and
+ not((vd_object in options) and
+ (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED,_STRICT])) do
+ begin
+ sorg:=orgpattern;
+ semicoloneaten:=false;
+ hasdefaultvalue:=false;
+ symdone:=false;
+ sc.reset;
+ repeat
+ case symtablestack.symtabletype of
+ localsymtable :
+ vs:=tlocalvarsym.create(orgpattern,vs_value,generrortype,[]);
+ staticsymtable,
+ globalsymtable :
+ vs:=tglobalvarsym.create(orgpattern,vs_value,generrortype,[]);
+ recordsymtable,
+ objectsymtable :
+ vs:=tfieldvarsym.create(orgpattern,vs_value,generrortype,[]);
+ else
+ internalerror(200411064);
+ end;
+ symtablestack.insert(vs);
+ if assigned(vs.owner) then
+ sc.insert(vs)
+ else
+ vs.free;
+ consume(_ID);
+ until not try_to_consume(_COMMA);
+ consume(_COLON);
+ if (m_gpc in aktmodeswitches) and (options=[]) and
+ (token=_ID) and (orgpattern='__asmname__') then
+ begin
+ consume(_ID);
+ C_name:=get_stringconst;
+ Is_gpc_name:=true;
+ end;
+ { this is needed for Delphi mode at least
+ but should be OK for all modes !! (PM) }
+ ignore_equal:=true;
+ if options*[vd_record,vd_object]<>[] then
+ begin
+ { for records, don't search the recordsymtable for
+ the symbols of the types }
+ oldsymtablestack:=symtablestack;
+ symtablestack:=symtablestack.next;
+ read_type(tt,'',false);
+ symtablestack:=oldsymtablestack;
+ end
+ else
+ read_type(tt,'',false);
+ ignore_equal:=false;
+ { Process procvar directives }
+ if (tt.def.deftype=procvardef) and
+ (tt.def.typesym=nil) and
+ check_proc_directive(true) then
+ begin
+ newtype:=ttypesym.create('unnamed',tt);
+ parse_var_proc_directives(tsym(newtype));
+ semicoloneaten:=true;
+ newtype.restype.def:=nil;
+ tt.def.typesym:=nil;
+ newtype.free;
+ end;
+
+{$ifdef powerpc}
+ { from gcc/gcc/config/rs6000/rs6000.h:
+ /* APPLE LOCAL begin Macintosh alignment 2002-1-22 ff */
+ /* Return the alignment of a struct based on the Macintosh PowerPC
+ alignment rules. In general the alignment of a struct is
+ determined by the greatest alignment of its elements. However, the
+ PowerPC rules cause the alignment of a struct to peg at word
+ alignment except when the first field has greater than word
+ (32-bit) alignment, in which case the alignment is determined by
+ the alignment of the first field. */
+ }
+ if (target_info.system in [system_powerpc_darwin, system_powerpc_macos]) and
+ (vd_record in options) and
+ is_first_field and
+ (trecordsymtable(symtablestack).usefieldalignment = -1) then
+ begin
+ tempdef := tt.def;
+ while tempdef.deftype = arraydef do
+ tempdef := tarraydef(tempdef).elementtype.def;
+ if tempdef.deftype <> recorddef then
+ maxpadalign := tempdef.alignment
+ else
+ maxpadalign := trecorddef(tempdef).padalignment;
+
+ if (maxpadalign > 4) and
+ (maxpadalign > trecordsymtable(symtablestack).padalignment) then
+ trecordsymtable(symtablestack).padalignment := maxpadalign;
+ is_first_field := false;
+ end;
+{$endif powerpc}
+
+ { types that use init/final are not allowed in variant parts, but
+ classes are allowed }
+ if (variantrecordlevel>0) and
+ (tt.def.needs_inittable and not is_class(tt.def)) then
+ Message(parser_e_cant_use_inittable_here);
+
+ if is_gpc_name then
+ begin
+ vs:=tabstractvarsym(sc.first);
+ if assigned(vs.listnext) then
+ Message(parser_e_absolute_only_one_var);
+ vs.vartype:=tt;
+ if vs.typ=globalvarsym then
+ begin
+ tglobalvarsym(vs).set_mangledname(target_info.Cprefix+sorg);
+ include(vs.varoptions,vo_is_C_var);
+ include(vs.varoptions,vo_is_external);
+ end
+ else
+ Message(parser_e_no_local_var_external);
+ symdone:=true;
+ end;
+
+ { check for absolute }
+ if not symdone and (idtoken=_ABSOLUTE) and (options=[]) then
+ begin
+ consume(_ABSOLUTE);
+ abssym:=nil;
+ { only allowed for one var }
+ vs:=tabstractvarsym(sc.first);
+ if assigned(vs.listnext) then
+ Message(parser_e_absolute_only_one_var);
+ { parse the rest }
+ pt:=expr;
+ { check allowed absolute types }
+ if (pt.nodetype=stringconstn) or
+ (is_constcharnode(pt)) then
+ begin
+ abssym:=tabsolutevarsym.create(vs.realname,tt);
+ abssym.fileinfo:=vs.fileinfo;
+ if pt.nodetype=stringconstn then
+ hs:=strpas(tstringconstnode(pt).value_str)
+ else
+ hs:=chr(tordconstnode(pt).value);
+ consume(token);
+ abssym.abstyp:=toasm;
+ abssym.asmname:=stringdup(hs);
+ { replace the varsym }
+ symtablestack.replace(vs,abssym);
+ vs.free;
+ end
+ { address }
+ else if is_constintnode(pt) and
+ ((target_info.system in [system_i386_go32v2,system_i386_watcom,
+ system_i386_wdosx,system_i386_win32,system_arm_wince,system_i386_wince]) or
+ (m_objfpc in aktmodeswitches) or
+ (m_delphi in aktmodeswitches)) then
+ begin
+ abssym:=tabsolutevarsym.create(vs.realname,tt);
+ abssym.fileinfo:=vs.fileinfo;
+ abssym.abstyp:=toaddr;
+ abssym.addroffset:=tordconstnode(pt).value;
+{$ifdef i386}
+ abssym.absseg:=false;
+ if (target_info.system in [system_i386_go32v2,system_i386_watcom]) and
+ try_to_consume(_COLON) then
+ begin
+ pt.free;
+ pt:=expr;
+ if is_constintnode(pt) then
+ begin
+ abssym.addroffset:=abssym.addroffset shl 4+tordconstnode(pt).value;
+ abssym.absseg:=true;
+ end
+ else
+ Message(type_e_ordinal_expr_expected);
+ end;
+{$endif i386}
+ symtablestack.replace(vs,abssym);
+ vs.free;
+ end
+ { variable }
+ else
+ begin
+ { remove subscriptn before checking for loadn }
+ hp:=pt;
+ while (hp.nodetype in [subscriptn,typeconvn,vecn]) do
+ hp:=tunarynode(hp).left;
+ if (hp.nodetype=loadn) then
+ begin
+ { we should check the result type of loadn }
+ if not (tloadnode(hp).symtableentry.typ in [fieldvarsym,globalvarsym,localvarsym,
+ paravarsym,typedconstsym]) then
+ Message(parser_e_absolute_only_to_var_or_const);
+ abssym:=tabsolutevarsym.create(vs.realname,tt);
+ abssym.fileinfo:=vs.fileinfo;
+ abssym.abstyp:=tovar;
+ abssym.ref:=node_to_symlist(pt);
+ symtablestack.replace(vs,abssym);
+ vs.free;
+ end
+ else
+ Message(parser_e_absolute_only_to_var_or_const);
+ end;
+ if assigned(abssym) then
+ begin
+ { try to consume the hint directives with absolute symbols }
+ dummysymoptions:=[];
+ try_consume_hintdirective(dummysymoptions);
+ abssym.symoptions := abssym.symoptions + dummysymoptions;
+ end;
+ pt.free;
+ symdone:=true;
+ end;
+
+ { Process procvar directives before = and ; }
+ if (tt.def.deftype=procvardef) and
+ (tt.def.typesym=nil) and
+ check_proc_directive(true) then
+ begin
+ newtype:=ttypesym.create('unnamed',tt);
+ parse_var_proc_directives(tsym(newtype));
+ newtype.restype.def:=nil;
+ tt.def.typesym:=nil;
+ newtype.free;
+ end;
+
+ { try to parse the hint directives }
+ dummysymoptions:=[];
+ try_consume_hintdirective(dummysymoptions);
+
+ { Records and objects can't have default values }
+ if options*[vd_record,vd_object]<>[] then
+ begin
+ { for a record there doesn't need to be a ; before the END or ) }
+ if not(token in [_END,_RKLAMMER]) and
+ not(semicoloneaten) then
+ consume(_SEMICOLON);
+ end
+ else
+ { Handling of Delphi typed const = initialized vars }
+ if (token=_EQUAL) and
+ not(m_tp7 in aktmodeswitches) and
+ (symtablestack.symtabletype<>parasymtable) then
+ begin
+ { Add calling convention for procvar }
+ if (tt.def.deftype=procvardef) and
+ (tt.def.typesym=nil) then
+ handle_calling_convention(tprocvardef(tt.def));
+ read_default_value(sc,tt,vd_threadvar in options);
+ consume(_SEMICOLON);
+ { for locals we've created typedconstsym with a different name }
+ if symtablestack.symtabletype<>localsymtable then
+ symdone:=true;
+ hasdefaultvalue:=true;
+ end
+ else
+ begin
+ if not(semicoloneaten) then
+ consume(_SEMICOLON);
+ end;
+
+ { Support calling convention for procvars after semicolon }
+ if not(hasdefaultvalue) and
+ (tt.def.deftype=procvardef) and
+ (tt.def.typesym=nil) then
+ begin
+ { Parse procvar directives after ; }
+ if check_proc_directive(true) then
+ begin
+ newtype:=ttypesym.create('unnamed',tt);
+ parse_var_proc_directives(tsym(newtype));
+ newtype.restype.def:=nil;
+ tt.def.typesym:=nil;
+ newtype.free;
+ end;
+ { Add calling convention for procvar }
+ handle_calling_convention(tprocvardef(tt.def));
+ { Handling of Delphi typed const = initialized vars }
+ if (token=_EQUAL) and (options*[vd_record,vd_object]=[]) and
+ not(m_tp7 in aktmodeswitches) and
+ (symtablestack.symtabletype<>parasymtable) then
+ begin
+ read_default_value(sc,tt,vd_threadvar in options);
+ consume(_SEMICOLON);
+ symdone:=true;
+ hasdefaultvalue:=true;
+ end;
+ end;
+
+ { Check for EXTERNAL etc directives or, in macpas, if cs_external_var is set}
+ if not symdone and (options=[]) then
+ begin
+ if (
+ (token=_ID) and
+ (m_cvar_support in aktmodeswitches) and
+ (idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR])
+ ) or
+ (
+ (m_mac in aktmodeswitches) and
+ ((cs_external_var in aktlocalswitches) or (cs_externally_visible in aktlocalswitches))
+ ) then
+ begin
+ { only allowed for one var }
+ vs:=tabstractvarsym(sc.first);
+ if assigned(vs.listnext) then
+ Message(parser_e_absolute_only_one_var);
+ { set type of the var }
+ vs.vartype:=tt;
+ vs.symoptions := vs.symoptions + dummysymoptions;
+ { defaults }
+ is_dll:=false;
+ is_cdecl:=false;
+ extern_var:=false;
+ export_var:=false;
+ C_name:=sorg;
+ semicolonatend:= false;
+ { cdecl }
+ if idtoken=_CVAR then
+ begin
+ consume(_CVAR);
+ consume(_SEMICOLON);
+ is_cdecl:=true;
+ C_name:=target_info.Cprefix+sorg;
+ end;
+ { external }
+ if idtoken=_EXTERNAL then
+ begin
+ consume(_EXTERNAL);
+ extern_var:=true;
+ semicolonatend:= true;
+ end;
+ { macpas specific handling due to some switches}
+ if (m_mac in aktmodeswitches) then
+ begin
+ if (cs_external_var in aktlocalswitches) then
+ begin {The effect of this is the same as if cvar; external; has been given as directives.}
+ is_cdecl:=true;
+ C_name:=target_info.Cprefix+sorg;
+ extern_var:=true;
+ end
+ else if (cs_externally_visible in aktlocalswitches) then
+ begin {The effect of this is the same as if cvar has been given as directives.}
+ is_cdecl:=true;
+ C_name:=target_info.Cprefix+sorg;
+ end;
+ vs.varregable := vr_none;
+ end;
+ { export }
+ if idtoken in [_EXPORT,_PUBLIC] then
+ begin
+ consume(_ID);
+ if extern_var then
+ Message(parser_e_not_external_and_export)
+ else
+ begin
+ export_var:=true;
+ semicolonatend:= true;
+ end;
+ end;
+ { external and export need a name after when no cdecl is used }
+ if not is_cdecl then
+ begin
+ { dll name ? }
+ if (extern_var) and (idtoken<>_NAME) then
+ begin
+ is_dll:=true;
+ dll_name:=get_stringconst;
+ end;
+ if try_to_consume(_NAME) then
+ C_name:=get_stringconst
+ else
+ C_name:=sorg;
+ end;
+ { consume the ; when export or external is used }
+ if semicolonatend then
+ consume(_SEMICOLON);
+
+ { set some vars options }
+ if is_dll then
+ include(vs.varoptions,vo_is_dll_var)
+ else
+ include(vs.varoptions,vo_is_C_var);
+
+ if (is_dll) and
+ (target_info.system = system_powerpc_darwin) then
+ C_Name := target_info.Cprefix+C_Name;
+
+ if export_var then
+ begin
+ inc(vs.refs);
+ include(vs.varoptions,vo_is_exported);
+ end;
+
+ if extern_var then
+ include(vs.varoptions,vo_is_external);
+
+ if vs.typ=globalvarsym then
+ begin
+ tglobalvarsym(vs).set_mangledname(C_Name);
+ { insert in the al_globals when it is not external }
+ if (not extern_var) then
+ insertbssdata(tglobalvarsym(vs));
+ { now we can insert it in the import lib if its a dll, or
+ add it to the externals }
+ if extern_var then
+ begin
+ vs.varregable := vr_none;
+ if is_dll then
+ begin
+ if not(current_module.uses_imports) then
+ begin
+ current_module.uses_imports:=true;
+ importlib.preparelib(current_module.realmodulename^);
+ end;
+ importlib.importvariable(tglobalvarsym(vs),C_name,dll_name);
+ end
+ else
+ if target_info.DllScanSupported then
+ current_module.Externals.insert(tExternalsItem.create(vs.mangledname));
+ end;
+ end
+ else
+ Message(parser_e_no_local_var_external);
+ symdone:=true;
+ end;
+ end;
+
+ { Check for STATIC directive }
+ if not symdone and (vd_object in options) and
+ (cs_static_keyword in aktmoduleswitches) and (idtoken=_STATIC) then
+ begin
+ include(current_object_option,sp_static);
+ insert_syms(sc,tt,false,dummysymoptions);
+ exclude(current_object_option,sp_static);
+ consume(_STATIC);
+ consume(_SEMICOLON);
+ symdone:=true;
+ end;
+
+ { insert it in the symtable, if not done yet }
+ if not symdone then
+ begin
+ { save object option, because we can turn of the sp_published }
+ if (sp_published in current_object_option) and
+ not(is_class(tt.def)) then
+ begin
+ Message(parser_e_cant_publish_that);
+ exclude(current_object_option,sp_published);
+ { recover by changing access type to public }
+ vs2:=tabstractvarsym(sc.first);
+ while assigned (vs2) do
+ begin
+ exclude(vs2.symoptions,sp_published);
+ include(vs2.symoptions,sp_public);
+ vs2:=tabstractvarsym(vs2.listnext);
+ end;
+ end
+ else
+ if (sp_published in current_object_option) and
+ not(oo_can_have_published in tobjectdef(tt.def).objectoptions) then
+ begin
+ Message(parser_e_only_publishable_classes_can__be_published);
+ exclude(current_object_option,sp_published);
+ end;
+ insert_syms(sc,tt,vd_threadvar in options,dummysymoptions);
+ current_object_option:=old_current_object_option;
+ end;
+
+ end;
+
+ { Check for Case }
+ if (vd_record in options) and (token=_CASE) then
+ begin
+ maxsize:=0;
+ maxalignment:=0;
+ maxpadalign:=0;
+ consume(_CASE);
+ sorg:=orgpattern;
+ hs:=pattern;
+ searchsym(hs,srsym,srsymtable);
+ { may be only a type: }
+ if assigned(srsym) and (srsym.typ in [typesym,unitsym]) then
+ begin
+ { for records, don't search the recordsymtable for
+ the symbols of the types }
+ oldsymtablestack:=symtablestack;
+ symtablestack:=symtablestack.next;
+ read_type(casetype,'',true);
+ symtablestack:=oldsymtablestack;
+ end
+ else
+ begin
+ consume(_ID);
+ consume(_COLON);
+ { for records, don't search the recordsymtable for
+ the symbols of the types }
+ oldsymtablestack:=symtablestack;
+ symtablestack:=symtablestack.next;
+ read_type(casetype,'',true);
+ symtablestack:=oldsymtablestack;
+ fieldvs:=tfieldvarsym.create(sorg,vs_value,casetype,[]);
+ tabstractrecordsymtable(symtablestack).insertfield(fieldvs,true);
+ end;
+ if not(is_ordinal(casetype.def))
+{$ifndef cpu64bit}
+ or is_64bitint(casetype.def)
+{$endif cpu64bit}
+ then
+ Message(type_e_ordinal_expr_expected);
+ consume(_OF);
+ UnionSymtable:=trecordsymtable.create(aktpackrecords);
+ Unionsymtable.next:=symtablestack;
+ registerdef:=false;
+ UnionDef:=trecorddef.create(unionsymtable);
+ uniondef.isunion:=true;
+ if assigned(symtablestack.defowner) then
+ Uniondef.owner:=symtablestack.defowner.owner;
+ registerdef:=true;
+ startvarrecsize:=UnionSymtable.datasize;
+ startvarrecalign:=UnionSymtable.fieldalignment;
+ startpadalign:=Unionsymtable.padalignment;
+ symtablestack:=UnionSymtable;
+ repeat
+ repeat
+ pt:=comp_expr(true);
+ if not(pt.nodetype=ordconstn) then
+ Message(parser_e_illegal_expression);
+ pt.free;
+ if token=_COMMA then
+ consume(_COMMA)
+ else
+ break;
+ until false;
+ consume(_COLON);
+ { read the vars }
+ consume(_LKLAMMER);
+ inc(variantrecordlevel);
+ if token<>_RKLAMMER then
+ read_var_decs([vd_record]);
+ dec(variantrecordlevel);
+ consume(_RKLAMMER);
+ { calculates maximal variant size }
+ maxsize:=max(maxsize,unionsymtable.datasize);
+ maxalignment:=max(maxalignment,unionsymtable.fieldalignment);
+ maxpadalign:=max(maxpadalign,unionsymtable.padalignment);
+ { the items of the next variant are overlayed }
+ unionsymtable.datasize:=startvarrecsize;
+ unionsymtable.fieldalignment:=startvarrecalign;
+ unionsymtable.padalignment:=startpadalign;
+ 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 }
+ unionsymtable.datasize:=maxsize;
+ unionsymtable.fieldalignment:=maxalignment;
+ uniontype.def:=uniondef;
+ uniontype.sym:=nil;
+ UnionSym:=tfieldvarsym.create('$case',vs_value,uniontype,[]);
+ symtablestack:=symtablestack.next;
+ unionsymtable.addalignmentpadding;
+{$ifdef powerpc}
+ { parent inherits the alignment padding if the variant is the first "field" of the parent record/variant }
+ if (target_info.system in [system_powerpc_darwin, system_powerpc_macos]) and
+ is_first_field and
+ (trecordsymtable(symtablestack).usefieldalignment = -1) and
+ (maxpadalign > trecordsymtable(symtablestack).padalignment) then
+ trecordsymtable(symtablestack).padalignment:=maxpadalign;
+{$endif powerpc}
+ { Align the offset where the union symtable is added }
+ if (trecordsymtable(symtablestack).usefieldalignment=-1) then
+ usedalign:=used_align(unionsymtable.recordalignment,aktalignment.recordalignmin,aktalignment.maxCrecordalign)
+ else
+ usedalign:=used_align(unionsymtable.recordalignment,aktalignment.recordalignmin,aktalignment.recordalignmax);
+
+ offset:=align(trecordsymtable(symtablestack).datasize,usedalign);
+ trecordsymtable(symtablestack).datasize:=offset+unionsymtable.datasize;
+
+ if unionsymtable.recordalignment>trecordsymtable(symtablestack).fieldalignment then
+ trecordsymtable(symtablestack).fieldalignment:=unionsymtable.recordalignment;
+
+ trecordsymtable(symtablestack).insertunionst(Unionsymtable,offset);
+ Unionsym.owner:=nil;
+ unionsym.free;
+ uniondef.owner:=nil;
+ uniondef.free;
+ end;
+ block_type:=old_block_type;
+ current_object_option:=old_current_object_option;
+ { free the list }
+ sc.free;
+{$ifdef powerpc}
+ is_first_field := false;
+{$endif powerpc}
+ end;
+
+end.
View Lorry Controller Status