mirror of
				https://gitlab.com/freepascal.org/fpc/source.git
				synced 2025-10-31 10:11:27 +01:00 
			
		
		
		
	
		
			
				
	
	
		
			794 lines
		
	
	
		
			32 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
			
		
		
	
	
			794 lines
		
	
	
		
			32 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
| {
 | |
|     $Id$
 | |
|     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
 | |
| 
 | |
|     procedure read_var_decs(is_record,is_object,is_threadvar:boolean);
 | |
| 
 | |
| 
 | |
| implementation
 | |
| 
 | |
|     uses
 | |
|        { common }
 | |
|        cutils,cclasses,
 | |
|        { global }
 | |
|        globtype,globals,tokens,verbose,
 | |
|        systems,
 | |
|        { symtable }
 | |
|        symconst,symbase,symtype,symdef,symsym,symtable,defutil,
 | |
|        fmodule,
 | |
|        { pass 1 }
 | |
|        node,
 | |
|        nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
 | |
|        { codegen }
 | |
|        ncgutil,
 | |
|        { parser }
 | |
|        scanner,
 | |
|        pbase,pexpr,ptype,ptconst,pdecsub,
 | |
|        { link }
 | |
|        import
 | |
| {$ifdef Delphi}
 | |
|        ,dmisc
 | |
|        ,sysutils
 | |
| {$endif}
 | |
|        ;
 | |
| 
 | |
|     const
 | |
|        variantrecordlevel : longint = 0;
 | |
| 
 | |
|     procedure read_var_decs(is_record,is_object,is_threadvar: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        }
 | |
| 
 | |
|       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,vs2 : tvarsym;
 | |
|         begin
 | |
|            vs:=tvarsym(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
 | |
|                      vs2:=tvarsym.create('$'+lower(symtablestack.name^)+'_'+vs.name,vs_value,tt);
 | |
|                      symtablestack.defowner.owner.insert(vs2);
 | |
|                      insertbssdata(vs2);
 | |
|                   end
 | |
|                 else
 | |
|                   begin
 | |
|                     { external data is not possible here }
 | |
|                     case symtablestack.symtabletype of
 | |
|                       globalsymtable,
 | |
|                       staticsymtable :
 | |
|                         insertbssdata(vs);
 | |
|                       recordsymtable,
 | |
|                       objectsymtable :
 | |
|                         tabstractrecordsymtable(symtablestack).insertfield(vs,false);
 | |
|                     end;
 | |
|                   end;
 | |
|                 vs:=tvarsym(vs.listnext);
 | |
|              end;
 | |
|         end;
 | |
| 
 | |
|       var
 | |
|          sc : tsinglelist;
 | |
|          old_block_type : tblock_type;
 | |
|          symdone : boolean;
 | |
|          { to handle absolute }
 | |
|          abssym : tabsolutesym;
 | |
|          { c var }
 | |
|          newtype : ttypesym;
 | |
|          is_dll,
 | |
|          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;
 | |
|          { Delphi initialized vars }
 | |
|          tconstsym : ttypedconstsym;
 | |
|          { maxsize contains the max. size of a variant }
 | |
|          { startvarrec contains the start of the variant part of a record }
 | |
|          maxsize, startvarrecsize : longint;
 | |
|          usedalign,
 | |
|          minalignment,maxalignment,startvarrecalign : byte;
 | |
|          pt : tnode;
 | |
|          vs,vs2    : tvarsym;
 | |
|          srsym : tsym;
 | |
|          oldsymtablestack,
 | |
|          srsymtable : tsymtable;
 | |
|          unionsymtable : trecordsymtable;
 | |
|          offset : longint;
 | |
|          uniondef : trecorddef;
 | |
|          unionsym : tvarsym;
 | |
|          uniontype : ttype;
 | |
|          dummysymoptions : tsymoptions;
 | |
|       begin
 | |
|          old_current_object_option:=current_object_option;
 | |
|          { all variables are public if not in a object declaration }
 | |
|          if not is_object 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(is_object and (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED])) do
 | |
|            begin
 | |
|              sorg:=orgpattern;
 | |
|              sc.reset;
 | |
|              repeat
 | |
|                vs:=tvarsym.create(orgpattern,vs_value,generrortype);
 | |
|                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
 | |
|                 not(is_record or is_object or is_threadvar) 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 is_record or is_object then
 | |
|               begin
 | |
|                 { for records, don't search the recordsymtable for
 | |
|                   the symbols of the types }
 | |
|                 oldsymtablestack:=symtablestack;
 | |
|                 symtablestack:=symtablestack.next;
 | |
|                 read_type(tt,'',true);
 | |
|                 symtablestack:=oldsymtablestack;
 | |
|               end
 | |
|              else
 | |
|               read_type(tt,'',true);
 | |
|              { 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);
 | |
|              ignore_equal:=false;
 | |
|              symdone:=false;
 | |
|              if is_gpc_name then
 | |
|                begin
 | |
|                   vs:=tvarsym(sc.first);
 | |
|                   if assigned(vs.listnext) then
 | |
|                     Message(parser_e_absolute_only_one_var);
 | |
|                   vs.vartype:=tt;
 | |
|                   include(vs.varoptions,vo_is_C_var);
 | |
|                   vs.set_mangledname(target_info.Cprefix+sorg);
 | |
|                   include(vs.varoptions,vo_is_external);
 | |
|                   symdone:=true;
 | |
|                end;
 | |
|              { check for absolute }
 | |
|              if not symdone and
 | |
|                 (idtoken=_ABSOLUTE) and not(is_record or is_object or is_threadvar) then
 | |
|               begin
 | |
|                 consume(_ABSOLUTE);
 | |
|                 abssym:=nil;
 | |
|                 { only allowed for one var }
 | |
|                 vs:=tvarsym(sc.first);
 | |
|                 if assigned(vs.listnext) then
 | |
|                   Message(parser_e_absolute_only_one_var);
 | |
|                 { parse the rest }
 | |
|                 pt:=expr;
 | |
|                 { transform a procvar calln to loadn }
 | |
|                 if pt.nodetype=calln then
 | |
|                   load_procvar_from_calln(pt);
 | |
|                 { check allowed absolute types }
 | |
|                 if (pt.nodetype=stringconstn) or
 | |
|                    (is_constcharnode(pt)) then
 | |
|                  begin
 | |
|                    abssym:=tabsolutesym.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
 | |
|                 { variable }
 | |
|                 else if (pt.nodetype=loadn) then
 | |
|                  begin
 | |
|                    { we should check the result type of srsym }
 | |
|                    if not (tloadnode(pt).symtableentry.typ in [varsym,typedconstsym]) then
 | |
|                      Message(parser_e_absolute_only_to_var_or_const);
 | |
|                    abssym:=tabsolutesym.create(vs.realname,tt);
 | |
|                    abssym.fileinfo:=vs.fileinfo;
 | |
|                    abssym.abstyp:=tovar;
 | |
|                    abssym.ref:=tstoredsym(tloadnode(pt).symtableentry);
 | |
|                    symtablestack.replace(vs,abssym);
 | |
|                    vs.free;
 | |
|                    { the variable cannot be put into a register
 | |
|                      if the size definition is not the same.
 | |
|                    }
 | |
|                    if tloadnode(pt).symtableentry.typ = varsym then
 | |
|                      begin
 | |
|                        if abssym.vartype.def <>
 | |
|                           tvarsym(tloadnode(pt).symtableentry).vartype.def then
 | |
|                           tvarsym(tloadnode(pt).symtableentry).varoptions:=
 | |
|                           tvarsym(tloadnode(pt).symtableentry).varoptions-[vo_regable,vo_fpuregable]
 | |
|                      end;
 | |
|                  end
 | |
|                 { address }
 | |
|                 else if is_constintnode(pt) and
 | |
|                         ((target_info.system in [system_i386_go32v2,system_i386_watcom,
 | |
|                                                  system_i386_wdosx,system_i386_win32]) or
 | |
|                          (m_objfpc in aktmodeswitches) or
 | |
|                          (m_delphi in aktmodeswitches)) then
 | |
|                  begin
 | |
|                    abssym:=tabsolutesym.create(vs.realname,tt);
 | |
|                    abssym.fileinfo:=vs.fileinfo;
 | |
|                    abssym.abstyp:=toaddr;
 | |
|                    abssym.absseg:=false;
 | |
|                    abssym.fieldoffset:=tordconstnode(pt).value;
 | |
|                    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.fieldoffset:=abssym.fieldoffset shl 4+tordconstnode(pt).value;
 | |
|                           abssym.absseg:=true;
 | |
|                         end
 | |
|                       else
 | |
|                          Message(type_e_ordinal_expr_expected);
 | |
|                     end;
 | |
|                    symtablestack.replace(vs,abssym);
 | |
|                    vs.free;
 | |
|                  end
 | |
|                 else
 | |
|                  Message(parser_e_absolute_only_to_var_or_const);
 | |
|                 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;
 | |
|              { Records and objects can't have default values }
 | |
|              if is_record or is_object then
 | |
|                begin
 | |
|                  { try to parse the hint directives }
 | |
|                  dummysymoptions:=[];
 | |
|                  try_consume_hintdirective(dummysymoptions);
 | |
| 
 | |
|                  { for a record there doesn't need to be a ; before the END or ) }
 | |
|                  if not(token in [_END,_RKLAMMER]) then
 | |
|                    consume(_SEMICOLON);
 | |
|                end
 | |
|              else
 | |
|                begin
 | |
|                  { Process procvar directives before = and ; }
 | |
|                  if (tt.def.deftype=procvardef) and
 | |
|                     (tt.def.typesym=nil) and
 | |
|                     is_proc_directive(token,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);
 | |
| 
 | |
|                  { Handling of Delphi typed const = initialized vars ! }
 | |
|                  { When should this be rejected ?
 | |
|                    - in parasymtable
 | |
|                    - in record or object
 | |
|                    - ... (PM) }
 | |
|                  if (token=_EQUAL) and
 | |
|                     not(m_tp7 in aktmodeswitches) and
 | |
|                     not(symtablestack.symtabletype in [parasymtable]) and
 | |
|                     not is_record and
 | |
|                     not is_object then
 | |
|                    begin
 | |
|                      vs:=tvarsym(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);
 | |
|                          tconstsym:=ttypedconstsym.createtype('default'+vs.realname,tt,false);
 | |
|                          vs.defaultconstsym:=tconstsym;
 | |
|                          symtablestack.insert(tconstsym);
 | |
|                          insertconstdata(tconstsym);
 | |
|                          readtypedconst(tt,tconstsym,false);
 | |
|                        end
 | |
|                      else
 | |
|                        begin
 | |
|                          tconstsym:=ttypedconstsym.createtype(vs.realname,tt,true);
 | |
|                          tconstsym.fileinfo:=vs.fileinfo;
 | |
|                          symtablestack.replace(vs,tconstsym);
 | |
|                          vs.free;
 | |
|                          insertconstdata(tconstsym);
 | |
|                          consume(_EQUAL);
 | |
|                          readtypedconst(tt,tconstsym,true);
 | |
|                          symdone:=true;
 | |
|                        end;
 | |
|                      consume(_SEMICOLON);
 | |
|                    end
 | |
|                  else
 | |
|                    begin
 | |
|                      consume(_SEMICOLON);
 | |
|                    end;
 | |
|                end;
 | |
|              { Parse procvar directives after ; }
 | |
|              if (tt.def.deftype=procvardef) and
 | |
|                 (tt.def.typesym=nil) then
 | |
|                begin
 | |
|                  if is_proc_directive(token,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));
 | |
|               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 or is_threadvar) and
 | |
|                    (idtoken in [_EXPORT,_EXTERNAL,_PUBLIC,_CVAR]) then
 | |
|                  begin
 | |
|                    { only allowed for one var }
 | |
|                    vs:=tvarsym(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;
 | |
|                    { 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;
 | |
|                     end;
 | |
|                    { export }
 | |
|                    if idtoken in [_EXPORT,_PUBLIC] then
 | |
|                     begin
 | |
|                       consume(_ID);
 | |
|                       if extern_var or
 | |
|                          (symtablestack.symtabletype in [parasymtable,localsymtable]) then
 | |
|                        Message(parser_e_not_external_and_export)
 | |
|                       else
 | |
|                        export_var:=true;
 | |
|                     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;
 | |
|                       consume(_NAME);
 | |
|                       C_name:=get_stringconst;
 | |
|                     end;
 | |
|                    { consume the ; when export or external is used }
 | |
|                    if extern_var or export_var 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);
 | |
|                    vs.set_mangledname(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);
 | |
|                    { insert in the datasegment when it is not external }
 | |
|                    if (not extern_var) then
 | |
|                      insertbssdata(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
 | |
|                       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(vs,C_name,dll_name);
 | |
|                        end
 | |
|                       else
 | |
|                        if target_info.DllScanSupported then
 | |
|                         current_module.Externals.insert(tExternalsItem.create(vs.mangledname));
 | |
|                     end;
 | |
|                    symdone:=true;
 | |
|                  end
 | |
|                 else
 | |
|                  if (is_object) 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;
 | |
|               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:=tvarsym(sc.first);
 | |
|                      while assigned (vs2) do
 | |
|                        begin
 | |
|                          exclude(vs2.symoptions,sp_published);
 | |
|                          include(vs2.symoptions,sp_public);
 | |
|                          vs2:=tvarsym(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,is_threadvar,dummysymoptions);
 | |
|                   current_object_option:=old_current_object_option;
 | |
|                end;
 | |
|            end;
 | |
|          { Check for Case }
 | |
|          if is_record and (token=_CASE) then
 | |
|            begin
 | |
|               maxsize:=0;
 | |
|               maxalignment:=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;
 | |
|                   vs:=tvarsym.create(sorg,vs_value,casetype);
 | |
|                   tabstractrecordsymtable(symtablestack).insertfield(vs,true);
 | |
|                 end;
 | |
|               if not(is_ordinal(casetype.def)) or is_64bitint(casetype.def)  then
 | |
|                Message(type_e_ordinal_expr_expected);
 | |
|               consume(_OF);
 | |
|               UnionSymtable:=trecordsymtable.create;
 | |
|               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.dataalignment;
 | |
|               symtablestack:=UnionSymtable;
 | |
|               repeat
 | |
|                 repeat
 | |
|                   pt:=comp_expr(true);
 | |
|                   if not(pt.nodetype=ordconstn) then
 | |
|                     Message(cg_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(true,false,false);
 | |
|                 dec(variantrecordlevel);
 | |
|                 consume(_RKLAMMER);
 | |
|                 { calculates maximal variant size }
 | |
|                 maxsize:=max(maxsize,unionsymtable.datasize);
 | |
|                 maxalignment:=max(maxalignment,unionsymtable.dataalignment);
 | |
|                 { the items of the next variant are overlayed }
 | |
|                 unionsymtable.datasize:=startvarrecsize;
 | |
|                 unionsymtable.dataalignment:=startvarrecalign;
 | |
|                 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.dataalignment:=maxalignment;
 | |
|               uniontype.def:=uniondef;
 | |
|               uniontype.sym:=nil;
 | |
|               UnionSym:=tvarsym.create('$case',vs_value,uniontype);
 | |
|               symtablestack:=symtablestack.next;
 | |
|               { we do NOT call symtablestack.insert
 | |
|                on purpose PM }
 | |
|               if aktalignment.recordalignmax=-1 then
 | |
|                begin
 | |
| {$ifdef i386}
 | |
|                  if maxalignment>2 then
 | |
|                   minalignment:=4
 | |
|                  else if maxalignment>1 then
 | |
|                   minalignment:=2
 | |
|                  else
 | |
|                   minalignment:=1;
 | |
| {$else}
 | |
| {$ifdef m68k}
 | |
|                  minalignment:=2;
 | |
| {$endif}
 | |
|                  minalignment:=1;
 | |
| {$endif}
 | |
|                end
 | |
|               else
 | |
|                minalignment:=maxalignment;
 | |
|               usedalign:=used_align(maxalignment,minalignment,maxalignment);
 | |
|               offset:=align(trecordsymtable(symtablestack).datasize,usedalign);
 | |
|               trecordsymtable(symtablestack).datasize:=offset+unionsymtable.datasize;
 | |
|               if maxalignment>trecordsymtable(symtablestack).dataalignment then
 | |
|                 trecordsymtable(symtablestack).dataalignment:=maxalignment;
 | |
|               Unionsymtable.Insert_in(trecordsymtable(symtablestack),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;
 | |
|       end;
 | |
| 
 | |
| end.
 | |
| {
 | |
|   $Log$
 | |
|   Revision 1.56  2003-10-05 12:55:37  peter
 | |
|     * allow absolute with value for win32,wdos
 | |
| 
 | |
|   Revision 1.55  2003/10/03 14:45:09  peter
 | |
|     * more proc directive for procvar fixes
 | |
| 
 | |
|   Revision 1.54  2003/10/02 21:13:09  peter
 | |
|     * procvar directive parsing fixes
 | |
| 
 | |
|   Revision 1.53  2003/10/02 15:12:07  peter
 | |
|     * fix type parsing in records
 | |
| 
 | |
|   Revision 1.52  2003/10/01 19:05:33  peter
 | |
|     * searchsym_type to search for type definitions. It ignores
 | |
|       records,objects and parameters
 | |
| 
 | |
|   Revision 1.51  2003/09/23 17:56:05  peter
 | |
|     * locals and paras are allocated in the code generation
 | |
|     * tvarsym.localloc contains the location of para/local when
 | |
|       generating code for the current procedure
 | |
| 
 | |
|   Revision 1.50  2003/09/07 14:14:51  florian
 | |
|     * proper error recovering from invalid published fields
 | |
| 
 | |
|   Revision 1.49  2003/09/05 17:41:12  florian
 | |
|     * merged Wiktor's Watcom patches in 1.1
 | |
| 
 | |
|   Revision 1.48  2003/07/02 22:18:04  peter
 | |
|     * paraloc splitted in callerparaloc,calleeparaloc
 | |
|     * sparc calling convention updates
 | |
| 
 | |
|   Revision 1.47  2003/05/09 17:47:03  peter
 | |
|     * self moved to hidden parameter
 | |
|     * removed hdisposen,hnewn,selfn
 | |
| 
 | |
|   Revision 1.46  2003/04/25 20:59:33  peter
 | |
|     * removed funcretn,funcretsym, function result is now in varsym
 | |
|       and aliases for result and function name are added using absolutesym
 | |
|     * vs_hidden parameter for funcret passed in parameter
 | |
|     * vs_hidden fixes
 | |
|     * writenode changed to printnode and released from extdebug
 | |
|     * -vp option added to generate a tree.log with the nodetree
 | |
|     * nicer printnode for statements, callnode
 | |
| 
 | |
|   Revision 1.45  2003/03/17 18:56:02  peter
 | |
|     * fix crash with duplicate id
 | |
| 
 | |
|   Revision 1.44  2003/01/02 11:14:02  michael
 | |
|   + Patch from peter to support initial values for local variables
 | |
| 
 | |
|   Revision 1.43  2002/12/27 15:22:20  peter
 | |
|     * don't allow initialized threadvars
 | |
| 
 | |
|   Revision 1.42  2002/12/07 14:04:59  carl
 | |
|    * convert some vars from longint -> byte
 | |
| 
 | |
|   Revision 1.41  2002/11/29 22:31:19  carl
 | |
|     + unimplemented hint directive added
 | |
|     * hint directive parsing implemented
 | |
|     * warning on these directives
 | |
| 
 | |
|   Revision 1.40  2002/11/25 17:43:21  peter
 | |
|     * splitted defbase in defutil,symutil,defcmp
 | |
|     * merged isconvertable and is_equal into compare_defs(_ext)
 | |
|     * made operator search faster by walking the list only once
 | |
| 
 | |
|   Revision 1.39  2002/11/15 16:29:31  peter
 | |
|     * made tasmsymbol.refs private (merged)
 | |
| 
 | |
|   Revision 1.38  2002/11/15 01:58:53  peter
 | |
|     * merged changes from 1.0.7 up to 04-11
 | |
|       - -V option for generating bug report tracing
 | |
|       - more tracing for option parsing
 | |
|       - errors for cdecl and high()
 | |
|       - win32 import stabs
 | |
|       - win32 records<=8 are returned in eax:edx (turned off by default)
 | |
|       - heaptrc update
 | |
|       - more info for temp management in .s file with EXTDEBUG
 | |
| 
 | |
|   Revision 1.37  2002/10/05 15:18:43  carl
 | |
|     * fix heap leaks
 | |
| 
 | |
|   Revision 1.36  2002/10/05 12:43:26  carl
 | |
|     * fixes for Delphi 6 compilation
 | |
|      (warning : Some features do not work under Delphi)
 | |
| 
 | |
|   Revision 1.35  2002/10/04 20:53:05  carl
 | |
|     * bugfix of crash
 | |
| 
 | |
|   Revision 1.34  2002/10/03 21:22:01  carl
 | |
|     * don't make the vars regable if they are absolute and their definitions
 | |
|       are not the same.
 | |
| 
 | |
|   Revision 1.33  2002/09/16 18:08:45  peter
 | |
|     * fix setting of sp_static
 | |
| 
 | |
|   Revision 1.32  2002/09/09 17:34:15  peter
 | |
|     * tdicationary.replace added to replace and item in a dictionary. This
 | |
|       is only allowed for the same name
 | |
|     * varsyms are inserted in symtable before the types are parsed. This
 | |
|       fixes the long standing "var longint : longint" bug
 | |
|     - consume_idlist and idstringlist removed. The loops are inserted
 | |
|       at the callers place and uses the symtable for duplicate id checking
 | |
| 
 | |
|   Revision 1.31  2002/08/25 19:25:20  peter
 | |
|     * sym.insert_in_data removed
 | |
|     * symtable.insertvardata/insertconstdata added
 | |
|     * removed insert_in_data call from symtable.insert, it needs to be
 | |
|       called separatly. This allows to deref the address calculation
 | |
|     * procedures now calculate the parast addresses after the procedure
 | |
|       directives are parsed. This fixes the cdecl parast problem
 | |
|     * push_addr_param has an extra argument that specifies if cdecl is used
 | |
|       or not
 | |
| 
 | |
|   Revision 1.30  2002/07/29 21:23:44  florian
 | |
|     * more fixes for the ppc
 | |
|     + wrappers for the tcnvnode.first_* stuff introduced
 | |
| 
 | |
|   Revision 1.29  2002/07/26 21:15:40  florian
 | |
|     * rewrote the system handling
 | |
| 
 | |
|   Revision 1.28  2002/07/20 11:57:55  florian
 | |
|     * types.pas renamed to defbase.pas because D6 contains a types
 | |
|       unit so this would conflicts if D6 programms are compiled
 | |
|     + Willamette/SSE2 instructions to assembler added
 | |
| 
 | |
|   Revision 1.27  2002/06/10 13:41:26  jonas
 | |
|     * fixed bug 1985
 | |
| 
 | |
|   Revision 1.26  2002/05/18 13:34:12  peter
 | |
|     * readded missing revisions
 | |
| 
 | |
|   Revision 1.25  2002/05/16 19:46:43  carl
 | |
|   + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
 | |
|   + try to fix temp allocation (still in ifdef)
 | |
|   + generic constructor calls
 | |
|   + start of tassembler / tmodulebase class cleanup
 | |
| 
 | |
|   Revision 1.23  2002/04/21 18:57:24  peter
 | |
|     * fixed memleaks when file can't be opened
 | |
| 
 | |
| }
 | 
