mirror of
				https://gitlab.com/freepascal.org/fpc/source.git
				synced 2025-10-31 21:09:38 +01:00 
			
		
		
		
	
		
			
				
	
	
		
			2263 lines
		
	
	
		
			66 KiB
		
	
	
	
		
			PHP
		
	
	
	
	
	
			
		
		
	
	
			2263 lines
		
	
	
		
			66 KiB
		
	
	
	
		
			PHP
		
	
	
	
	
	
| {
 | |
|     $Id$
 | |
|     Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
 | |
| 
 | |
|     Implementation for the symbols types of the symtable
 | |
| 
 | |
|     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.
 | |
|  ****************************************************************************
 | |
| }
 | |
| 
 | |
| {****************************************************************************
 | |
|                           TSYM (base for all symtypes)
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tsym.init(const n : string);
 | |
|       begin
 | |
|          if n[1]='$' then
 | |
|           inherited initname(copy(n,2,255))
 | |
|          else
 | |
|           inherited initname(upper(n));
 | |
|          _realname:=stringdup(n);
 | |
|          typ:=abstractsym;
 | |
|          symoptions:=current_object_option;
 | |
| {$ifdef GDB}
 | |
|          isstabwritten := false;
 | |
| {$endif GDB}
 | |
|          fileinfo:=tokenpos;
 | |
|          defref:=nil;
 | |
|          refs:=0;
 | |
|          lastwritten:=nil;
 | |
|          refcount:=0;
 | |
|          if (cs_browser in aktmoduleswitches) and make_ref then
 | |
|           begin
 | |
|             defref:=new(pref,init(defref,@tokenpos));
 | |
|             inc(refcount);
 | |
|           end;
 | |
|          lastref:=defref;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tsym.load;
 | |
|       begin
 | |
|          inherited init;
 | |
|          indexnr:=readword;
 | |
|          _realname:=stringdup(readstring);
 | |
|          if _realname^[1]='$' then
 | |
|           setname(copy(_realname^,2,255))
 | |
|          else
 | |
|           setname(upper(_realname^));
 | |
|          typ:=abstractsym;
 | |
|          readsmallset(symoptions,sizeof(symoptions));
 | |
|          readposinfo(fileinfo);
 | |
|          lastref:=nil;
 | |
|          defref:=nil;
 | |
|          refs:=0;
 | |
|          lastwritten:=nil;
 | |
|          refcount:=0;
 | |
| {$ifdef GDB}
 | |
|          isstabwritten := false;
 | |
| {$endif GDB}
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tsym.load_references;
 | |
|       var
 | |
|         pos : tfileposinfo;
 | |
|         move_last : boolean;
 | |
|       begin
 | |
|         move_last:=lastwritten=lastref;
 | |
|         while (not current_ppu^.endofentry) do
 | |
|          begin
 | |
|            readposinfo(pos);
 | |
|            inc(refcount);
 | |
|            lastref:=new(pref,init(lastref,@pos));
 | |
|            lastref^.is_written:=true;
 | |
|            if refcount=1 then
 | |
|             defref:=lastref;
 | |
|          end;
 | |
|         if move_last then
 | |
|           lastwritten:=lastref;
 | |
|       end;
 | |
| 
 | |
|     { big problem here :
 | |
|       wrong refs were written because of
 | |
|       interface parsing of other units PM
 | |
|       moduleindex must be checked !! }
 | |
| 
 | |
|     function tsym.write_references : boolean;
 | |
|       var
 | |
|         ref   : pref;
 | |
|         symref_written,move_last : boolean;
 | |
|       begin
 | |
|         write_references:=false;
 | |
|         if lastwritten=lastref then
 | |
|           exit;
 | |
|       { should we update lastref }
 | |
|         move_last:=true;
 | |
|         symref_written:=false;
 | |
|       { write symbol refs }
 | |
|         if assigned(lastwritten) then
 | |
|           ref:=lastwritten
 | |
|         else
 | |
|           ref:=defref;
 | |
|         while assigned(ref) do
 | |
|          begin
 | |
|            if ref^.moduleindex=current_module^.unit_index then
 | |
|              begin
 | |
|               { write address to this symbol }
 | |
|                 if not symref_written then
 | |
|                   begin
 | |
|                      writesymref(@self);
 | |
|                      symref_written:=true;
 | |
|                   end;
 | |
|                 writeposinfo(ref^.posinfo);
 | |
|                 ref^.is_written:=true;
 | |
|                 if move_last then
 | |
|                   lastwritten:=ref;
 | |
|              end
 | |
|            else if not ref^.is_written then
 | |
|              move_last:=false
 | |
|            else if move_last then
 | |
|              lastwritten:=ref;
 | |
|            ref:=ref^.nextref;
 | |
|          end;
 | |
|         if symref_written then
 | |
|           current_ppu^.writeentry(ibsymref);
 | |
|         write_references:=symref_written;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {$ifdef BrowserLog}
 | |
|     procedure tsym.add_to_browserlog;
 | |
|       begin
 | |
|         if assigned(defref) then
 | |
|          begin
 | |
|            browserlog.AddLog('***'+name+'***');
 | |
|            browserlog.AddLogRefs(defref);
 | |
|          end;
 | |
|       end;
 | |
| {$endif BrowserLog}
 | |
| 
 | |
| 
 | |
|     destructor tsym.done;
 | |
|       begin
 | |
|         if assigned(defref) then
 | |
|          begin
 | |
|            defref^.freechain;
 | |
|            dispose(defref,done);
 | |
|          end;
 | |
|         stringdispose(_realname);
 | |
|         inherited done;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tsym.write;
 | |
|       begin
 | |
|          writeword(indexnr);
 | |
|          writestring(_realname^);
 | |
|          writesmallset(symoptions,sizeof(symoptions));
 | |
|          writeposinfo(fileinfo);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tsym.prederef;
 | |
|       begin
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tsym.deref;
 | |
|       begin
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tsym.realname : string;
 | |
|       begin
 | |
|         if assigned(_realname) then
 | |
|          realname:=_realname^
 | |
|         else
 | |
|          realname:=name;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tsym.mangledname : string;
 | |
|       begin
 | |
|          mangledname:=name;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     { for most symbol types there is nothing to do at all }
 | |
|     procedure tsym.insert_in_data;
 | |
|       begin
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     function tsym.stabstring : pchar;
 | |
| 
 | |
|       begin
 | |
|          stabstring:=strpnew('"'+name+'",'+tostr(N_LSYM)+',0,'+
 | |
|            tostr(fileinfo.line)+',0');
 | |
|       end;
 | |
| 
 | |
|     procedure tsym.concatstabto(asmlist : paasmoutput);
 | |
| 
 | |
|     var stab_str : pchar;
 | |
|       begin
 | |
|          if not isstabwritten then
 | |
|            begin
 | |
|               stab_str := stabstring;
 | |
|               { count_dbx(stab_str); moved to GDB.PAS }
 | |
|               asmlist^.concat(new(pai_stabs,init(stab_str)));
 | |
|               isstabwritten:=true;
 | |
|           end;
 | |
|     end;
 | |
| {$endif GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                  TLABELSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tlabelsym.init(const n : string; l : pasmlabel);
 | |
| 
 | |
|       begin
 | |
|          inherited init(n);
 | |
|          typ:=labelsym;
 | |
|          lab:=l;
 | |
|          used:=false;
 | |
|          defined:=false;
 | |
|          code:=nil;
 | |
|       end;
 | |
| 
 | |
|     constructor tlabelsym.load;
 | |
| 
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=labelsym;
 | |
|          { this is all dummy
 | |
|            it is only used for local browsing }
 | |
|          lab:=nil;
 | |
|          code:=nil;
 | |
|          used:=false;
 | |
|          defined:=true;
 | |
|       end;
 | |
| 
 | |
|     destructor tlabelsym.done;
 | |
| 
 | |
|       begin
 | |
|          inherited done;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tlabelsym.mangledname : string;
 | |
|       begin
 | |
|          mangledname:=lab^.name;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tlabelsym.write;
 | |
|       begin
 | |
|          if owner^.symtabletype in [unitsymtable,globalsymtable] then
 | |
|            Message(sym_e_ill_label_decl)
 | |
|          else
 | |
|            begin
 | |
|               tsym.write;
 | |
|               current_ppu^.writeentry(iblabelsym);
 | |
|            end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TUNITSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tunitsym.init(const n : string;ref : punitsymtable);
 | |
|       var
 | |
|         old_make_ref : boolean;
 | |
|       begin
 | |
|          old_make_ref:=make_ref;
 | |
|          make_ref:=false;
 | |
|          inherited init(n);
 | |
|          make_ref:=old_make_ref;
 | |
|          typ:=unitsym;
 | |
|          unitsymtable:=ref;
 | |
|          prevsym:=ref^.unitsym;
 | |
|          ref^.unitsym:=@self;
 | |
|          refs:=0;
 | |
|       end;
 | |
| 
 | |
|     constructor tunitsym.load;
 | |
| 
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=unitsym;
 | |
|          unitsymtable:=punitsymtable(current_module^.globalsymtable);
 | |
|          prevsym:=nil;
 | |
|       end;
 | |
| 
 | |
|     { we need to remove it from the prevsym chain ! }
 | |
| 
 | |
|     procedure tunitsym.restoreunitsym;
 | |
|       var pus,ppus : punitsym;
 | |
|       begin
 | |
|          if assigned(unitsymtable) then
 | |
|            begin
 | |
|              ppus:=nil;
 | |
|              pus:=unitsymtable^.unitsym;
 | |
|              if pus=@self then
 | |
|                unitsymtable^.unitsym:=prevsym
 | |
|              else while assigned(pus) do
 | |
|                begin
 | |
|                   if pus=@self then
 | |
|                     begin
 | |
|                        ppus^.prevsym:=prevsym;
 | |
|                        break;
 | |
|                     end
 | |
|                   else
 | |
|                     begin
 | |
|                        ppus:=pus;
 | |
|                        pus:=ppus^.prevsym;
 | |
|                     end;
 | |
|                end;
 | |
|            end;
 | |
|          prevsym:=nil;
 | |
|       end;
 | |
| 
 | |
|     destructor tunitsym.done;
 | |
|       begin
 | |
|          restoreunitsym;
 | |
|          inherited done;
 | |
|       end;
 | |
| 
 | |
|     procedure tunitsym.write;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          current_ppu^.writeentry(ibunitsym);
 | |
|       end;
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     procedure tunitsym.concatstabto(asmlist : paasmoutput);
 | |
|       begin
 | |
|       {Nothing to write to stabs !}
 | |
|       end;
 | |
| {$endif GDB}
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TPROCSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tprocsym.init(const n : string);
 | |
| 
 | |
|       begin
 | |
|          tsym.init(n);
 | |
|          typ:=procsym;
 | |
|          definition:=nil;
 | |
|          owner:=nil;
 | |
|          is_global := false;
 | |
|       end;
 | |
| 
 | |
|     constructor tprocsym.load;
 | |
| 
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=procsym;
 | |
|          definition:=pprocdef(readdefref);
 | |
|          is_global := false;
 | |
|       end;
 | |
| 
 | |
|     destructor tprocsym.done;
 | |
| 
 | |
|       begin
 | |
|          { don't check if errors !! }
 | |
|          if Errorcount=0 then
 | |
|            check_forward;
 | |
|          tsym.done;
 | |
|       end;
 | |
| 
 | |
|     function tprocsym.mangledname : string;
 | |
| 
 | |
|       begin
 | |
|          mangledname:=definition^.mangledname;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tprocsym.declarationstr(p : pprocdef):string;
 | |
|       begin
 | |
|         declarationstr:=realname+p^.demangled_paras;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tprocsym.write_parameter_lists(skipdef:pprocdef);
 | |
|       var
 | |
|          p : pprocdef;
 | |
|       begin
 | |
|          p:=definition;
 | |
|          while assigned(p) do
 | |
|            begin
 | |
|               if p<>skipdef then
 | |
|                 MessagePos1(p^.fileinfo,sym_b_param_list,name+p^.demangled_paras);
 | |
|               p:=p^.nextoverloaded;
 | |
|            end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tprocsym.check_forward;
 | |
|       var
 | |
|          pd : pprocdef;
 | |
|       begin
 | |
|          pd:=definition;
 | |
|          while assigned(pd) do
 | |
|            begin
 | |
|               if pd^.forwarddef then
 | |
|                 begin
 | |
|                    if assigned(pd^._class) then
 | |
|                      MessagePos1(fileinfo,sym_e_forward_not_resolved,pd^._class^.objname^+'.'+declarationstr(pd))
 | |
|                    else
 | |
|                      MessagePos1(fileinfo,sym_e_forward_not_resolved,declarationstr(pd));
 | |
|                    { Turn futher error messages off }
 | |
|                    pd^.forwarddef:=false;
 | |
|                 end;
 | |
|               pd:=pd^.nextoverloaded;
 | |
|               { do not check defs of operators in other units }
 | |
|               if assigned(pd) and (pd^.procsym<>@self) then
 | |
|                 pd:=nil;
 | |
|            end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tprocsym.deref;
 | |
| {$ifdef DONOTCHAINOPERATORS}
 | |
|       var
 | |
|         t    : ttoken;
 | |
|         last,pd : pprocdef;
 | |
| {$endif DONOTCHAINOPERATORS}
 | |
|       begin
 | |
|          resolvedef(pdef(definition));
 | |
| {$ifdef DONOTCHAINOPERATORS}
 | |
|          if (definition^.proctypeoption=potype_operator) then
 | |
|            begin
 | |
|               last:=definition;
 | |
|               while assigned(last^.nextoverloaded) do
 | |
|                 last:=last^.nextoverloaded;
 | |
|               for t:=first_overloaded to last_overloaded do
 | |
|               if (name=overloaded_names[t]) then
 | |
|                 begin
 | |
|                    if assigned(overloaded_operators[t]) then
 | |
|                      begin
 | |
|                        pd:=overloaded_operators[t]^.definition;
 | |
|                        { test if not already in list, bug report by KC Wong PM }
 | |
|                        while assigned(pd) do
 | |
|                          if pd=last then
 | |
|                            break
 | |
|                          else
 | |
|                            pd:=pd^.nextoverloaded;
 | |
|                        if pd=last then
 | |
|                          break;
 | |
|                        last^.nextoverloaded:=overloaded_operators[t]^.definition;
 | |
|                      end;
 | |
|                    overloaded_operators[t]:=@self;
 | |
|                    break;
 | |
|                 end;
 | |
|            end;
 | |
| {$endif DONOTCHAINOPERATORS}
 | |
|       end;
 | |
| 
 | |
|     procedure tprocsym.order_overloaded;
 | |
|       var firstdef,currdef,lastdef,nextopdef : pprocdef;
 | |
|       begin
 | |
|          if not assigned(definition) then
 | |
|            exit;
 | |
|          firstdef:=definition;
 | |
|          currdef:=definition;
 | |
|          while assigned(currdef) and (currdef^.owner=firstdef^.owner) do
 | |
|            begin
 | |
|              currdef^.count:=false;
 | |
|              currdef:=currdef^.nextoverloaded;
 | |
|            end;
 | |
|          nextopdef:=currdef;
 | |
|          definition:=definition^.nextoverloaded;
 | |
|          firstdef^.nextoverloaded:=nil;
 | |
|          while (definition<>nextopdef) do
 | |
|            begin
 | |
|              currdef:=firstdef;
 | |
|              lastdef:=definition;
 | |
|              definition:=definition^.nextoverloaded;
 | |
|              if lastdef^.mangledname<firstdef^.mangledname then
 | |
|                begin
 | |
|                  lastdef^.nextoverloaded:=firstdef;
 | |
|                  firstdef:=lastdef;
 | |
|                end
 | |
|              else
 | |
|                begin
 | |
|                  while assigned(currdef^.nextoverloaded) and
 | |
|                     (lastdef^.mangledname>currdef^.nextoverloaded^.mangledname) do
 | |
|                    currdef:=currdef^.nextoverloaded;
 | |
|                  lastdef^.nextoverloaded:=currdef^.nextoverloaded;
 | |
|                  currdef^.nextoverloaded:=lastdef;
 | |
|                end;
 | |
|            end;
 | |
|          definition:=firstdef;
 | |
|          currdef:=definition;
 | |
|          while assigned(currdef) do
 | |
|            begin
 | |
|              currdef^.count:=true;
 | |
|              lastdef:=currdef;
 | |
|              currdef:=currdef^.nextoverloaded;
 | |
|            end;
 | |
|          lastdef^.nextoverloaded:=nextopdef;
 | |
|       end;
 | |
| 
 | |
|     procedure tprocsym.write;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          writedefref(pdef(definition));
 | |
|          current_ppu^.writeentry(ibprocsym);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tprocsym.load_references;
 | |
|       (*var
 | |
|         prdef,prdef2 : pprocdef;
 | |
|         b : byte; *)
 | |
|       begin
 | |
|          inherited load_references;
 | |
|          (*prdef:=definition;
 | |
|            done in tsymtable.load_browser (PM)
 | |
|          { take care about operators !!  }
 | |
|          if (current_module^.flags and uf_has_browser) <>0 then
 | |
|            while assigned(prdef) and (prdef^.owner=definition^.owner) do
 | |
|              begin
 | |
|                 b:=current_ppu^.readentry;
 | |
|                 if b<>ibdefref then
 | |
|                   Message(unit_f_ppu_read_error);
 | |
|                 prdef2:=pprocdef(readdefref);
 | |
|                 resolvedef(prdef2);
 | |
|                 if prdef<>prdef2 then
 | |
|                   Message(unit_f_ppu_read_error);
 | |
|                 prdef^.load_references;
 | |
|                 prdef:=prdef^.nextoverloaded;
 | |
|              end; *)
 | |
|       end;
 | |
| 
 | |
|     function tprocsym.write_references : boolean;
 | |
|       var
 | |
|         prdef : pprocdef;
 | |
|       begin
 | |
|          write_references:=false;
 | |
|          if not inherited write_references then
 | |
|            exit;
 | |
|          write_references:=true;
 | |
|          prdef:=definition;
 | |
|          while assigned(prdef) and (prdef^.owner=definition^.owner) do
 | |
|           begin
 | |
|             prdef^.write_references;
 | |
|             prdef:=prdef^.nextoverloaded;
 | |
|           end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {$ifdef BrowserLog}
 | |
|     procedure tprocsym.add_to_browserlog;
 | |
|       var
 | |
|         prdef : pprocdef;
 | |
|       begin
 | |
|          inherited add_to_browserlog;
 | |
|          prdef:=definition;
 | |
|          while assigned(prdef) do
 | |
|            begin
 | |
|               pprocdef(prdef)^.add_to_browserlog;
 | |
|               prdef:=pprocdef(prdef)^.nextoverloaded;
 | |
|            end;
 | |
|       end;
 | |
| {$endif BrowserLog}
 | |
| 
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     function tprocsym.stabstring : pchar;
 | |
|      Var RetType : Char;
 | |
|          Obj,Info : String;
 | |
|          stabsstr : string;
 | |
|          p : pchar;
 | |
|     begin
 | |
|       obj := name;
 | |
|       info := '';
 | |
|       if is_global then
 | |
|        RetType := 'F'
 | |
|       else
 | |
|        RetType := 'f';
 | |
|      if assigned(owner) then
 | |
|       begin
 | |
|         if (owner^.symtabletype = objectsymtable) then
 | |
|          obj := upper(owner^.name^)+'__'+name;
 | |
|         { this code was correct only as long as the local symboltable
 | |
|           of the parent had the same name as the function
 | |
|           but this is no true anymore !! PM
 | |
|         if (owner^.symtabletype=localsymtable) and assigned(owner^.name) then
 | |
|          info := ','+name+','+owner^.name^;  }
 | |
|         if (owner^.symtabletype=localsymtable) and assigned(owner^.defowner) and
 | |
|            assigned(pprocdef(owner^.defowner)^.procsym) then
 | |
|           info := ','+name+','+pprocdef(owner^.defowner)^.procsym^.name;
 | |
|       end;
 | |
|      stabsstr:=definition^.mangledname;
 | |
|      getmem(p,length(stabsstr)+255);
 | |
|      strpcopy(p,'"'+obj+':'+RetType
 | |
|            +definition^.rettype.def^.numberstring+info+'",'+tostr(n_function)
 | |
|            +',0,'+
 | |
|            tostr(aktfilepos.line)
 | |
|            +',');
 | |
|      strpcopy(strend(p),stabsstr);
 | |
|      stabstring:=strnew(p);
 | |
|      freemem(p,length(stabsstr)+255);
 | |
|     end;
 | |
| 
 | |
|     procedure tprocsym.concatstabto(asmlist : paasmoutput);
 | |
|     begin
 | |
|       if (pocall_internproc in definition^.proccalloptions) then exit;
 | |
|       if not isstabwritten then
 | |
|         asmlist^.concat(new(pai_stabs,init(stabstring)));
 | |
|       isstabwritten := true;
 | |
|       if assigned(definition^.parast) then
 | |
|         definition^.parast^.concatstabto(asmlist);
 | |
|       { local type defs and vars should not be written
 | |
|         inside the main proc stab }
 | |
|       if assigned(definition^.localst) and
 | |
|          (lexlevel>main_program_level) then
 | |
|         definition^.localst^.concatstabto(asmlist);
 | |
|       definition^.is_def_stab_written := written;
 | |
|     end;
 | |
| {$endif GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TERRORSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor terrorsym.init;
 | |
|       begin
 | |
|         inherited init('');
 | |
|         typ:=errorsym;
 | |
|       end;
 | |
| 
 | |
| {****************************************************************************
 | |
|                                 TPROPERTYSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tpropertysym.init(const n : string);
 | |
|       begin
 | |
|          inherited init(n);
 | |
|          typ:=propertysym;
 | |
|          propoptions:=[];
 | |
|          index:=0;
 | |
|          default:=0;
 | |
|          proptype.reset;
 | |
|          indextype.reset;
 | |
|          new(readaccess,init);
 | |
|          new(writeaccess,init);
 | |
|          new(storedaccess,init);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tpropertysym.load;
 | |
|       begin
 | |
|          inherited load;
 | |
|          typ:=propertysym;
 | |
|          readsmallset(propoptions,sizeof(propoptions));
 | |
|          if (ppo_is_override in propoptions) then
 | |
|           begin
 | |
|             propoverriden:=ppropertysym(readsymref);
 | |
|             { we need to have these objects initialized }
 | |
|             new(readaccess,init);
 | |
|             new(writeaccess,init);
 | |
|             new(storedaccess,init);
 | |
|           end
 | |
|          else
 | |
|           begin
 | |
|             proptype.load;
 | |
|             index:=readlong;
 | |
|             default:=readlong;
 | |
|             indextype.load;
 | |
|             new(readaccess,load);
 | |
|             new(writeaccess,load);
 | |
|             new(storedaccess,load);
 | |
|           end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     destructor tpropertysym.done;
 | |
|       begin
 | |
|          dispose(readaccess,done);
 | |
|          dispose(writeaccess,done);
 | |
|          dispose(storedaccess,done);
 | |
|          inherited done;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tpropertysym.deref;
 | |
|       begin
 | |
|         if (ppo_is_override in propoptions) then
 | |
|          begin
 | |
|            resolvesym(psym(propoverriden));
 | |
|            dooverride(propoverriden);
 | |
|          end
 | |
|         else
 | |
|          begin
 | |
|            proptype.resolve;
 | |
|            indextype.resolve;
 | |
|            readaccess^.resolve;
 | |
|            writeaccess^.resolve;
 | |
|            storedaccess^.resolve;
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tpropertysym.getsize : longint;
 | |
|       begin
 | |
|          getsize:=0;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tpropertysym.write;
 | |
|       begin
 | |
|         tsym.write;
 | |
|         writesmallset(propoptions,sizeof(propoptions));
 | |
|         if (ppo_is_override in propoptions) then
 | |
|          writesymref(propoverriden)
 | |
|         else
 | |
|          begin
 | |
|            proptype.write;
 | |
|            writelong(index);
 | |
|            writelong(default);
 | |
|            indextype.write;
 | |
|            readaccess^.write;
 | |
|            writeaccess^.write;
 | |
|            storedaccess^.write;
 | |
|          end;
 | |
|         current_ppu^.writeentry(ibpropertysym);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tpropertysym.dooverride(overriden:ppropertysym);
 | |
|       begin
 | |
|         propoverriden:=overriden;
 | |
|         proptype:=overriden^.proptype;
 | |
|         propoptions:=overriden^.propoptions+[ppo_is_override];
 | |
|         index:=overriden^.index;
 | |
|         default:=overriden^.default;
 | |
|         indextype:=overriden^.indextype;
 | |
|         readaccess^.clear;
 | |
|         readaccess:=overriden^.readaccess^.getcopy;
 | |
|         writeaccess^.clear;
 | |
|         writeaccess:=overriden^.writeaccess^.getcopy;
 | |
|         storedaccess^.clear;
 | |
|         storedaccess:=overriden^.storedaccess^.getcopy;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     function tpropertysym.stabstring : pchar;
 | |
|       begin
 | |
|          { !!!! don't know how to handle }
 | |
|          stabstring:=strpnew('');
 | |
|       end;
 | |
| 
 | |
|     procedure tpropertysym.concatstabto(asmlist : paasmoutput);
 | |
|       begin
 | |
|          { !!!! don't know how to handle }
 | |
|       end;
 | |
| {$endif GDB}
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TFUNCRETSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo});
 | |
| 
 | |
|       begin
 | |
|          tsym.init(n);
 | |
|          typ:=funcretsym;
 | |
|          funcretprocinfo:=approcinfo;
 | |
|          rettype:=pprocinfo(approcinfo)^.returntype;
 | |
|          { address valid for ret in param only }
 | |
|          { otherwise set by insert             }
 | |
|          address:=pprocinfo(approcinfo)^.return_offset;
 | |
|       end;
 | |
| 
 | |
|     constructor tfuncretsym.load;
 | |
|       begin
 | |
|          tsym.load;
 | |
|          rettype.load;
 | |
|          address:=readlong;
 | |
|          funcretprocinfo:=nil;
 | |
|          typ:=funcretsym;
 | |
|       end;
 | |
| 
 | |
|     destructor tfuncretsym.done;
 | |
|       begin
 | |
|         inherited done;
 | |
|       end;
 | |
| 
 | |
|     procedure tfuncretsym.write;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          rettype.write;
 | |
|          writelong(address);
 | |
|          current_ppu^.writeentry(ibfuncretsym);
 | |
|       end;
 | |
| 
 | |
|     procedure tfuncretsym.deref;
 | |
|       begin
 | |
|          rettype.resolve;
 | |
|       end;
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     procedure tfuncretsym.concatstabto(asmlist : paasmoutput);
 | |
|       begin
 | |
|         { Nothing to do here, it is done in genexitcode  }
 | |
|       end;
 | |
| {$endif GDB}
 | |
| 
 | |
|     procedure tfuncretsym.insert_in_data;
 | |
|       var
 | |
|         l : longint;
 | |
|       begin
 | |
|         { if retoffset is already set then reuse it, this is needed
 | |
|           when inserting the result variable }
 | |
|         if procinfo^.return_offset<>0 then
 | |
|          address:=procinfo^.return_offset
 | |
|         else
 | |
|          begin
 | |
|            { allocate space in local if ret in acc or in fpu }
 | |
|            if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then
 | |
|             begin
 | |
|               l:=rettype.def^.size;
 | |
|               inc(owner^.datasize,l);
 | |
| {$ifdef m68k}
 | |
|               { word alignment required for motorola }
 | |
|               if (l=1) then
 | |
|                inc(owner^.datasize,1)
 | |
|               else
 | |
| {$endif}
 | |
|               if (l>=4) and ((owner^.datasize and 3)<>0) then
 | |
|                 inc(owner^.datasize,4-(owner^.datasize and 3))
 | |
|               else if (l>=2) and ((owner^.datasize and 1)<>0) then
 | |
|                 inc(owner^.datasize,2-(owner^.datasize and 1));
 | |
|               address:=owner^.datasize;
 | |
|               procinfo^.return_offset:=-owner^.datasize;
 | |
|             end;
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TABSOLUTESYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tabsolutesym.init(const n : string;const tt : ttype);
 | |
|       begin
 | |
|         inherited init(n,tt);
 | |
|         typ:=absolutesym;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tabsolutesym.initdef(const n : string;p : pdef);
 | |
|       var
 | |
|         t : ttype;
 | |
|       begin
 | |
|         t.setdef(p);
 | |
|         tabsolutesym.init(n,t);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tabsolutesym.load;
 | |
|       begin
 | |
|          tvarsym.load;
 | |
|          typ:=absolutesym;
 | |
|          ref:=nil;
 | |
|          address:=0;
 | |
|          asmname:=nil;
 | |
|          abstyp:=absolutetyp(readbyte);
 | |
|          absseg:=false;
 | |
|          case abstyp of
 | |
|            tovar :
 | |
|              begin
 | |
|                asmname:=stringdup(readstring);
 | |
|                ref:=srsym;
 | |
|              end;
 | |
|            toasm :
 | |
|              asmname:=stringdup(readstring);
 | |
|            toaddr :
 | |
|              begin
 | |
|                address:=readlong;
 | |
|                absseg:=boolean(readbyte);
 | |
|              end;
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tabsolutesym.write;
 | |
|       var
 | |
|         hvo : tvaroptions;
 | |
|       begin
 | |
|          { Note: This needs to write everything of tvarsym.write }
 | |
|          tsym.write;
 | |
|          writebyte(byte(varspez));
 | |
|          if read_member then
 | |
|            writelong(address);
 | |
|          { write only definition or definitionsym }
 | |
|          vartype.write;
 | |
|          hvo:=varoptions-[vo_regable];
 | |
|          writesmallset(hvo,sizeof(hvo));
 | |
|          writebyte(byte(abstyp));
 | |
|          case abstyp of
 | |
|            tovar :
 | |
|              writestring(ref^.name);
 | |
|            toasm :
 | |
|              writestring(asmname^);
 | |
|            toaddr :
 | |
|              begin
 | |
|                writelong(address);
 | |
|                writebyte(byte(absseg));
 | |
|              end;
 | |
|          end;
 | |
|         current_ppu^.writeentry(ibabsolutesym);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tabsolutesym.deref;
 | |
|       begin
 | |
|          tvarsym.deref;
 | |
|          if (abstyp=tovar) and (asmname<>nil) then
 | |
|            begin
 | |
|               { search previous loaded symtables }
 | |
|               getsym(asmname^,false);
 | |
|               if not(assigned(srsym)) then
 | |
|                 getsymonlyin(owner,asmname^);
 | |
|               if not(assigned(srsym)) then
 | |
|                 srsym:=generrorsym;
 | |
|               ref:=srsym;
 | |
|               stringdispose(asmname);
 | |
|            end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tabsolutesym.mangledname : string;
 | |
|       begin
 | |
|          case abstyp of
 | |
|            tovar :
 | |
|              mangledname:=ref^.mangledname;
 | |
|            toasm :
 | |
|              mangledname:=asmname^;
 | |
|            toaddr :
 | |
|              mangledname:='$'+tostr(address);
 | |
|          else
 | |
|            internalerror(10002);
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tabsolutesym.insert_in_data;
 | |
|       begin
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     procedure tabsolutesym.concatstabto(asmlist : paasmoutput);
 | |
|       begin
 | |
|       { I don't know how to handle this !! }
 | |
|       end;
 | |
| {$endif GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TVARSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tvarsym.init(const n : string;const tt : ttype);
 | |
|       begin
 | |
|          tsym.init(n);
 | |
|          typ:=varsym;
 | |
|          vartype:=tt;
 | |
|          _mangledname:=nil;
 | |
|          varspez:=vs_value;
 | |
|          address:=0;
 | |
|          localvarsym:=nil;
 | |
|          refs:=0;
 | |
|          varstate:=vs_used;
 | |
|          varoptions:=[];
 | |
|          { can we load the value into a register ? }
 | |
|          if tt.def^.is_intregable then
 | |
|            include(varoptions,vo_regable)
 | |
|          else
 | |
|            exclude(varoptions,vo_regable);
 | |
| 
 | |
|          if tt.def^.is_fpuregable then
 | |
|            include(varoptions,vo_fpuregable)
 | |
|          else
 | |
|            exclude(varoptions,vo_fpuregable);
 | |
|          reg:=R_NO;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tvarsym.init_dll(const n : string;const tt : ttype);
 | |
|       begin
 | |
|          tvarsym.init(n,tt);
 | |
|          include(varoptions,vo_is_dll_var);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tvarsym.init_C(const n,mangled : string;const tt : ttype);
 | |
|       begin
 | |
|          tvarsym.init(n,tt);
 | |
|          include(varoptions,vo_is_C_var);
 | |
|          setmangledname(mangled);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tvarsym.initdef(const n : string;p : pdef);
 | |
|       var
 | |
|         t : ttype;
 | |
|       begin
 | |
|         t.setdef(p);
 | |
|         tvarsym.init(n,t);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tvarsym.load;
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=varsym;
 | |
|          _mangledname:=nil;
 | |
|          reg:=R_NO;
 | |
|          refs := 0;
 | |
|          varstate:=vs_used;
 | |
|          varspez:=tvarspez(readbyte);
 | |
|          if read_member then
 | |
|            address:=readlong
 | |
|          else
 | |
|            address:=0;
 | |
|          localvarsym:=nil;
 | |
|          vartype.load;
 | |
|          readsmallset(varoptions,sizeof(varoptions));
 | |
|          if (vo_is_C_var in varoptions) then
 | |
|            setmangledname(readstring);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     destructor tvarsym.done;
 | |
|       begin
 | |
|          strdispose(_mangledname);
 | |
|          inherited done;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tvarsym.deref;
 | |
|       begin
 | |
|         vartype.resolve;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tvarsym.write;
 | |
|       var
 | |
|         hvo : tvaroptions;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          writebyte(byte(varspez));
 | |
|          if read_member then
 | |
|           writelong(address);
 | |
|          vartype.write;
 | |
|          { symbols which are load are never candidates for a register,
 | |
|            turn off the regable }
 | |
|          hvo:=varoptions-[vo_regable];
 | |
|          writesmallset(hvo,sizeof(hvo));
 | |
|          if (vo_is_C_var in varoptions) then
 | |
|            writestring(mangledname);
 | |
|          current_ppu^.writeentry(ibvarsym);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tvarsym.setmangledname(const s : string);
 | |
|       begin
 | |
|         _mangledname:=strpnew(s);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tvarsym.mangledname : string;
 | |
|       var
 | |
|         prefix : string;
 | |
|       begin
 | |
|          if assigned(_mangledname) then
 | |
|            begin
 | |
|               mangledname:=strpas(_mangledname);
 | |
|               exit;
 | |
|            end;
 | |
|          case owner^.symtabletype of
 | |
|            staticsymtable :
 | |
|              if (cs_create_smart in aktmoduleswitches) then
 | |
|                prefix:='_'+owner^.name^+'$$$_'
 | |
|              else
 | |
|                prefix:='_';
 | |
|            unitsymtable,
 | |
|            globalsymtable :
 | |
|              prefix:=
 | |
|               'U_'+owner^.name^+'_';
 | |
|            else
 | |
|              Message(sym_e_invalid_call_tvarsymmangledname);
 | |
|          end;
 | |
|          mangledname:=prefix+name;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tvarsym.getsize : longint;
 | |
|       begin
 | |
|         if assigned(vartype.def) then
 | |
|           getsize:=vartype.def^.size
 | |
|         else
 | |
|           getsize:=0;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tvarsym.getvaluesize : longint;
 | |
|       begin
 | |
|         if assigned(vartype.def) and
 | |
|            (varspez=vs_value) and
 | |
|            ((vartype.def^.deftype<>arraydef) or
 | |
|             (Parraydef(vartype.def)^.highrange>=Parraydef(vartype.def)^.lowrange)) then
 | |
|           getvaluesize:=vartype.def^.size
 | |
|         else
 | |
|           getvaluesize:=0;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tvarsym.getpushsize : longint;
 | |
|       begin
 | |
|          if assigned(vartype.def) then
 | |
|            begin
 | |
|               case varspez of
 | |
|                 vs_out,
 | |
|                 vs_var :
 | |
|                   getpushsize:=target_os.size_of_pointer;
 | |
|                 vs_value,
 | |
|                 vs_const :
 | |
|                   begin
 | |
|                       if push_addr_param(vartype.def) then
 | |
|                         getpushsize:=target_os.size_of_pointer
 | |
|                       else
 | |
|                         getpushsize:=vartype.def^.size;
 | |
|                   end;
 | |
|               end;
 | |
|            end
 | |
|          else
 | |
|            getpushsize:=0;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function  data_align(length : longint) : longint;
 | |
|       begin
 | |
|          (* this is useless under go32v2 at least
 | |
|          because the section are only align to dword
 | |
|          if length>8 then
 | |
|            data_align:=16
 | |
|          else if length>4 then
 | |
|            data_align:=8
 | |
|          else *)
 | |
|          if length>2 then
 | |
|            data_align:=4
 | |
|          else
 | |
|           if length>1 then
 | |
|            data_align:=2
 | |
|          else
 | |
|            data_align:=1;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tvarsym.insert_in_data;
 | |
|       var
 | |
|          varalign,
 | |
|          l,ali,modulo : longint;
 | |
|          storefilepos : tfileposinfo;
 | |
|       begin
 | |
|         if (vo_is_external in varoptions) then
 | |
|           exit;
 | |
|         { handle static variables of objects especially }
 | |
|         if read_member and (owner^.symtabletype=objectsymtable) and
 | |
|            (sp_static in symoptions) then
 | |
|          begin
 | |
|             { the data filed is generated in parser.pas
 | |
|               with a tobject_FIELDNAME variable }
 | |
|             { this symbol can't be loaded to a register }
 | |
|             exclude(varoptions,vo_regable);
 | |
|             exclude(varoptions,vo_fpuregable);
 | |
|          end
 | |
|         else
 | |
|          if not(read_member) then
 | |
|           begin
 | |
|              { made problems with parameters etc. ! (FK) }
 | |
|              {  check for instance of an abstract object or class }
 | |
|              {
 | |
|              if (pvarsym(sym)^.definition^.deftype=objectdef) and
 | |
|                (oo_is_abstract in pobjectdef(pvarsym(sym)^.definition)^.options) then
 | |
|                Message(sym_e_no_instance_of_abstract_object);
 | |
|              }
 | |
|              storefilepos:=aktfilepos;
 | |
|              aktfilepos:=tokenpos;
 | |
|              if (vo_is_thread_var in varoptions) then
 | |
|                l:=4
 | |
|              else
 | |
|                l:=getvaluesize;
 | |
|              case owner^.symtabletype of
 | |
|                stt_exceptsymtable:
 | |
|                  { can contain only one symbol, address calculated later }
 | |
|                  ;
 | |
|                localsymtable :
 | |
|                  begin
 | |
|                    varstate:=vs_declared;
 | |
|                    modulo:=owner^.datasize and 3;
 | |
| {$ifdef m68k}
 | |
|                  { word alignment required for motorola }
 | |
|                    if (l=1) then
 | |
|                     l:=2
 | |
|                    else
 | |
| {$endif}
 | |
| {
 | |
|                    if (cs_optimize in aktglobalswitches) and
 | |
|                       (aktoptprocessor in [classp5,classp6]) and
 | |
|                       (l>=8) and ((owner^.datasize and 7)<>0) then
 | |
|                      inc(owner^.datasize,8-(owner^.datasize and 7))
 | |
|                    else
 | |
| }
 | |
|                      begin
 | |
|                         if (l>=4) and (modulo<>0) then
 | |
|                           inc(l,4-modulo)
 | |
|                         else
 | |
|                           if (l>=2) and ((modulo and 1)<>0) then
 | |
|                             inc(l,2-(modulo and 1));
 | |
|                      end;
 | |
|                    inc(owner^.datasize,l);
 | |
|                    address:=owner^.datasize;
 | |
|                  end;
 | |
|                staticsymtable :
 | |
|                  begin
 | |
|                    { enable unitialized warning for local symbols }
 | |
|                    varstate:=vs_declared;
 | |
|                    if (cs_create_smart in aktmoduleswitches) then
 | |
|                      bsssegment^.concat(new(pai_cut,init));
 | |
|                    ali:=data_align(l);
 | |
|                    if ali>1 then
 | |
|                      begin
 | |
|                         modulo:=owner^.datasize mod ali;
 | |
|                         if modulo>0 then
 | |
|                           inc(owner^.datasize,ali-modulo);
 | |
|                      end;
 | |
| {$ifdef GDB}
 | |
|                    if cs_debuginfo in aktmoduleswitches then
 | |
|                       concatstabto(bsssegment);
 | |
| {$endif GDB}
 | |
| 
 | |
|                    if (cs_create_smart in aktmoduleswitches) or
 | |
|                       DLLSource or
 | |
|                       (vo_is_exported in varoptions) or
 | |
|                       (vo_is_C_var in varoptions) then
 | |
|                      bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)))
 | |
|                    else
 | |
|                      bsssegment^.concat(new(pai_datablock,init(mangledname,l)));
 | |
|                    { increase datasize }
 | |
|                    inc(owner^.datasize,l);
 | |
|                    { this symbol can't be loaded to a register }
 | |
|                    exclude(varoptions,vo_regable);
 | |
|                    exclude(varoptions,vo_fpuregable);
 | |
|                  end;
 | |
|                globalsymtable :
 | |
|                  begin
 | |
|                    if (cs_create_smart in aktmoduleswitches) then
 | |
|                      bsssegment^.concat(new(pai_cut,init));
 | |
|                    ali:=data_align(l);
 | |
|                    if ali>1 then
 | |
|                      begin
 | |
|                         modulo:=owner^.datasize mod ali;
 | |
|                         if modulo>0 then
 | |
|                           inc(owner^.datasize,ali-modulo);
 | |
|                      end;
 | |
| {$ifdef GDB}
 | |
|                    if cs_debuginfo in aktmoduleswitches then
 | |
|                      concatstabto(bsssegment);
 | |
| {$endif GDB}
 | |
|                    bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)));
 | |
|                    inc(owner^.datasize,l);
 | |
|                    { this symbol can't be loaded to a register }
 | |
|                    exclude(varoptions,vo_regable);
 | |
|                    exclude(varoptions,vo_fpuregable);
 | |
|                  end;
 | |
|                recordsymtable,
 | |
|                objectsymtable :
 | |
|                  begin
 | |
|                  { this symbol can't be loaded to a register }
 | |
|                    exclude(varoptions,vo_regable);
 | |
|                    exclude(varoptions,vo_fpuregable);
 | |
|                  { get the alignment size }
 | |
|                    if (aktpackrecords=packrecord_C) then
 | |
|                     begin
 | |
|                       varalign:=vartype.def^.alignment;
 | |
|                       if (varalign>4) and ((varalign mod 4)<>0) and
 | |
|                         (vartype.def^.deftype=arraydef) then
 | |
|                         begin
 | |
|                           Message1(sym_w_wrong_C_pack,vartype.def^.typename);
 | |
|                         end;
 | |
|                       if varalign=0 then
 | |
|                         varalign:=l;
 | |
|                       if (owner^.dataalignment<target_os.maxCrecordalignment) then
 | |
|                        begin
 | |
|                          if (varalign>16) and (owner^.dataalignment<32) then
 | |
|                           owner^.dataalignment:=32
 | |
|                          else if (varalign>12) and (owner^.dataalignment<16) then
 | |
|                           owner^.dataalignment:=16
 | |
|                          { 12 is needed for long double }
 | |
|                          else if (varalign>8) and (owner^.dataalignment<12) then
 | |
|                           owner^.dataalignment:=12
 | |
|                          else if (varalign>4) and (owner^.dataalignment<8) then
 | |
|                           owner^.dataalignment:=8
 | |
|                          else if (varalign>2) and (owner^.dataalignment<4) then
 | |
|                           owner^.dataalignment:=4
 | |
|                          else if (varalign>1) and (owner^.dataalignment<2) then
 | |
|                           owner^.dataalignment:=2;
 | |
|                        end;
 | |
|                       if owner^.dataalignment>target_os.maxCrecordalignment then
 | |
|                         owner^.dataalignment:=target_os.maxCrecordalignment;
 | |
|                     end
 | |
|                    else
 | |
|                     varalign:=vartype.def^.alignment;
 | |
|                    if varalign=0 then
 | |
|                      varalign:=l;
 | |
|                  { align record and object fields }
 | |
|                    if (varalign=1) or (owner^.dataalignment=1) then
 | |
|                     begin
 | |
|                       address:=owner^.datasize;
 | |
|                       inc(owner^.datasize,l)
 | |
|                     end
 | |
|                    else if (varalign=2) or (owner^.dataalignment=2) then
 | |
|                      begin
 | |
|                        owner^.datasize:=(owner^.datasize+1) and (not 1);
 | |
|                        address:=owner^.datasize;
 | |
|                        inc(owner^.datasize,l)
 | |
|                      end
 | |
|                    else if (varalign<=4) or (owner^.dataalignment=4) then
 | |
|                      begin
 | |
|                        owner^.datasize:=(owner^.datasize+3) and (not 3);
 | |
|                        address:=owner^.datasize;
 | |
|                        inc(owner^.datasize,l);
 | |
|                      end
 | |
|                    else if (varalign<=8) or (owner^.dataalignment=8) then
 | |
|                      begin
 | |
|                        owner^.datasize:=(owner^.datasize+7) and (not 7);
 | |
|                        address:=owner^.datasize;
 | |
|                        inc(owner^.datasize,l);
 | |
|                      end
 | |
|                          { 12 is needed for C long double support }
 | |
|                    else if (varalign<=12) and (owner^.dataalignment=12) then
 | |
|                      begin
 | |
|                        owner^.datasize:=((owner^.datasize+11) div 12) * 12;
 | |
|                        address:=owner^.datasize;
 | |
|                        inc(owner^.datasize,l);
 | |
|                      end
 | |
|                    else if (varalign<=16) or (owner^.dataalignment=16) then
 | |
|                      begin
 | |
|                        owner^.datasize:=(owner^.datasize+15) and (not 15);
 | |
|                        address:=owner^.datasize;
 | |
|                        inc(owner^.datasize,l);
 | |
|                      end
 | |
|                    else if (varalign<=32) or (owner^.dataalignment=32) then
 | |
|                      begin
 | |
|                        owner^.datasize:=(owner^.datasize+31) and (not 31);
 | |
|                        address:=owner^.datasize;
 | |
|                        inc(owner^.datasize,l);
 | |
|                      end
 | |
|                     else
 | |
|                      internalerror(1000022);
 | |
|                  end;
 | |
|                parasymtable :
 | |
|                  begin
 | |
|                    { here we need the size of a push instead of the
 | |
|                      size of the data }
 | |
|                    l:=getpushsize;
 | |
|                    varstate:=vs_assigned;
 | |
|                    address:=owner^.datasize;
 | |
|                    owner^.datasize:=align(owner^.datasize+l,target_os.stackalignment);
 | |
|                  end
 | |
|                else
 | |
|                  begin
 | |
|                      modulo:=owner^.datasize and 3;
 | |
|                      if (l>=4) and (modulo<>0) then
 | |
|                        inc(owner^.datasize,4-modulo)
 | |
|                      else
 | |
|                        if (l>=2) and ((modulo and 1)<>0) then
 | |
|                          inc(owner^.datasize);
 | |
|                    address:=owner^.datasize;
 | |
|                    inc(owner^.datasize,l);
 | |
|                  end;
 | |
|                end;
 | |
|              aktfilepos:=storefilepos;
 | |
|         end;
 | |
|       end;
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     function tvarsym.stabstring : pchar;
 | |
|      var
 | |
|        st : string;
 | |
|      begin
 | |
|        st:=vartype.def^.numberstring;
 | |
|        if (owner^.symtabletype = objectsymtable) and
 | |
|           (sp_static in symoptions) then
 | |
|          begin
 | |
|             if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st;
 | |
| {$ifndef Delphi}
 | |
|             stabstring := strpnew('"'+owner^.name^+'__'+name+':'+st+
 | |
|                      '",'+
 | |
|                      tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
 | |
| {$endif}
 | |
|          end
 | |
|        else if (owner^.symtabletype = globalsymtable) or
 | |
|           (owner^.symtabletype = unitsymtable) then
 | |
|          begin
 | |
|             { Here we used S instead of
 | |
|               because with G GDB doesn't look at the address field
 | |
|               but searches the same name or with a leading underscore
 | |
|               but these names don't exist in pascal !}
 | |
|             if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st;
 | |
|             stabstring := strpnew('"'+name+':'+st+'",'+
 | |
|                      tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
 | |
|          end
 | |
|        else if owner^.symtabletype = staticsymtable then
 | |
|          begin
 | |
|             stabstring := strpnew('"'+name+':S'+st+'",'+
 | |
|                   tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
 | |
|          end
 | |
|        else if (owner^.symtabletype in [parasymtable,inlineparasymtable]) then
 | |
|          begin
 | |
|             case varspez of
 | |
|                vs_out,
 | |
|                vs_var   : st := 'v'+st;
 | |
|                vs_value,
 | |
|                vs_const : if push_addr_param(vartype.def) then
 | |
|                             st := 'v'+st { should be 'i' but 'i' doesn't work }
 | |
|                           else
 | |
|                             st := 'p'+st;
 | |
|               end;
 | |
|             stabstring := strpnew('"'+name+':'+st+'",'+
 | |
|                   tostr(N_PSYM)+',0,'+tostr(fileinfo.line)+','+
 | |
|                   tostr(address+owner^.address_fixup));
 | |
|                   {offset to ebp => will not work if the framepointer is esp
 | |
|                   so some optimizing will make things harder to debug }
 | |
|          end
 | |
|        else if (owner^.symtabletype in [localsymtable,inlinelocalsymtable]) then
 | |
|    {$ifdef i386}
 | |
|          if reg<>R_NO then
 | |
|            begin
 | |
|               { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
 | |
|               { this is the register order for GDB}
 | |
|               stabstring:=strpnew('"'+name+':r'+st+'",'+
 | |
|                         tostr(N_RSYM)+',0,'+
 | |
|                         tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
 | |
|            end
 | |
|          else
 | |
|    {$endif i386}
 | |
|            { I don't know if this will work (PM) }
 | |
|            if (vo_is_C_var in varoptions) then
 | |
|             stabstring := strpnew('"'+name+':S'+st+'",'+
 | |
|                   tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname)
 | |
|            else
 | |
|            stabstring := strpnew('"'+name+':'+st+'",'+
 | |
|                   tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',-'+tostr(address-owner^.address_fixup))
 | |
|        else
 | |
|          stabstring := inherited stabstring;
 | |
|   end;
 | |
| 
 | |
|     procedure tvarsym.concatstabto(asmlist : paasmoutput);
 | |
| {$ifdef i386}
 | |
|       var stab_str : pchar;
 | |
| {$endif i386}
 | |
|       begin
 | |
|          inherited concatstabto(asmlist);
 | |
| {$ifdef i386}
 | |
|       if (owner^.symtabletype=parasymtable) and
 | |
|          (reg<>R_NO) then
 | |
|            begin
 | |
|            { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
 | |
|            { this is the register order for GDB}
 | |
|               stab_str:=strpnew('"'+name+':r'
 | |
|                      +vartype.def^.numberstring+'",'+
 | |
|                      tostr(N_RSYM)+',0,'+
 | |
|                      tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
 | |
|               asmlist^.concat(new(pai_stabs,init(stab_str)));
 | |
|            end;
 | |
| {$endif i386}
 | |
|       end;
 | |
| {$endif GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                              TTYPEDCONSTSYM
 | |
| *****************************************************************************}
 | |
| 
 | |
|     constructor ttypedconstsym.init(const n : string;p : pdef;really_const : boolean);
 | |
|       begin
 | |
|          tsym.init(n);
 | |
|          typ:=typedconstsym;
 | |
|          typedconsttype.setdef(p);
 | |
|          is_really_const:=really_const;
 | |
|          prefix:=stringdup(procprefix);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor ttypedconstsym.inittype(const n : string;const tt : ttype;really_const : boolean);
 | |
|       begin
 | |
|          ttypedconstsym.init(n,nil,really_const);
 | |
|          typedconsttype:=tt;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor ttypedconstsym.load;
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=typedconstsym;
 | |
|          typedconsttype.load;
 | |
|          prefix:=stringdup(readstring);
 | |
|          is_really_const:=boolean(readbyte);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     destructor ttypedconstsym.done;
 | |
|       begin
 | |
|          stringdispose(prefix);
 | |
|          tsym.done;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function ttypedconstsym.mangledname : string;
 | |
|       begin
 | |
|          mangledname:='TC_'+prefix^+'_'+name;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function ttypedconstsym.getsize : longint;
 | |
|       begin
 | |
|         if assigned(typedconsttype.def) then
 | |
|          getsize:=typedconsttype.def^.size
 | |
|         else
 | |
|          getsize:=0;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure ttypedconstsym.deref;
 | |
|       begin
 | |
|         typedconsttype.resolve;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure ttypedconstsym.write;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          typedconsttype.write;
 | |
|          writestring(prefix^);
 | |
|          writebyte(byte(is_really_const));
 | |
|          current_ppu^.writeentry(ibtypedconstsym);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure ttypedconstsym.insert_in_data;
 | |
|       var
 | |
|         curconstsegment : paasmoutput;
 | |
|         l,ali,modulo : longint;
 | |
|         storefilepos : tfileposinfo;
 | |
|       begin
 | |
|         storefilepos:=aktfilepos;
 | |
|         aktfilepos:=tokenpos;
 | |
|         if is_really_const then
 | |
|           curconstsegment:=consts
 | |
|         else
 | |
|           curconstsegment:=datasegment;
 | |
|         if (cs_create_smart in aktmoduleswitches) then
 | |
|           curconstsegment^.concat(new(pai_cut,init));
 | |
|         l:=getsize;
 | |
|         ali:=data_align(l);
 | |
|         if ali>1 then
 | |
|           begin
 | |
|              curconstsegment^.concat(new(pai_align,init(ali)));
 | |
|              modulo:=owner^.datasize mod ali;
 | |
|              if modulo>0 then
 | |
|                inc(owner^.datasize,ali-modulo);
 | |
|           end;
 | |
|         {  Why was there no owner size update here ??? }
 | |
|         inc(owner^.datasize,l);
 | |
| {$ifdef GDB}
 | |
|               if cs_debuginfo in aktmoduleswitches then
 | |
|                 concatstabto(curconstsegment);
 | |
| {$endif GDB}
 | |
|         if owner^.symtabletype=globalsymtable then
 | |
|           begin
 | |
|              curconstsegment^.concat(new(pai_symbol,initdataname_global(mangledname,getsize)));
 | |
|           end
 | |
|         else
 | |
|           if owner^.symtabletype<>unitsymtable then
 | |
|             begin
 | |
|               if (cs_create_smart in aktmoduleswitches) or
 | |
|                  DLLSource then
 | |
|                 curconstsegment^.concat(new(pai_symbol,initdataname_global(mangledname,getsize)))
 | |
|               else
 | |
|                 curconstsegment^.concat(new(pai_symbol,initdataname(mangledname,getsize)));
 | |
|             end;
 | |
|         aktfilepos:=storefilepos;
 | |
|       end;
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     function ttypedconstsym.stabstring : pchar;
 | |
|     var
 | |
|       st : char;
 | |
|     begin
 | |
|     if (cs_gdb_gsym in aktglobalswitches) and (owner^.symtabletype in [unitsymtable,globalsymtable]) then
 | |
|       st := 'G'
 | |
|     else
 | |
|       st := 'S';
 | |
|     stabstring := strpnew('"'+name+':'+st+
 | |
|             typedconsttype.def^.numberstring+'",'+tostr(n_STSYM)+',0,'+
 | |
|             tostr(fileinfo.line)+','+mangledname);
 | |
|     end;
 | |
| {$endif GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TCONSTSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tconstsym.init(const n : string;t : tconsttyp;v : TConstExprInt);
 | |
|       begin
 | |
|          inherited init(n);
 | |
|          typ:=constsym;
 | |
|          consttyp:=t;
 | |
|          value:=v;
 | |
|          ResStrIndex:=0;
 | |
|          consttype.reset;
 | |
|          len:=0;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tconstsym.init_def(const n : string;t : tconsttyp;v : TConstExprInt;def : pdef);
 | |
|       begin
 | |
|          inherited init(n);
 | |
|          typ:=constsym;
 | |
|          consttyp:=t;
 | |
|          value:=v;
 | |
|          consttype.setdef(def);
 | |
|          len:=0;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tconstsym.init_string(const n : string;t : tconsttyp;str:pchar;l:longint);
 | |
|       begin
 | |
|          inherited init(n);
 | |
|          typ:=constsym;
 | |
|          consttyp:=t;
 | |
|          value:=longint(str);
 | |
|          consttype.reset;
 | |
|          len:=l;
 | |
|          if t=constresourcestring then
 | |
|            ResStrIndex:=ResourceStrings^.Register(name,
 | |
|              pchar(tpointerord(value)),len);
 | |
|       end;
 | |
| 
 | |
|     constructor tconstsym.load;
 | |
|       var
 | |
|          pd : pbestreal;
 | |
|          ps : pnormalset;
 | |
|          pc : pchar;
 | |
|          l1,l2 : longint;
 | |
| 
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=constsym;
 | |
|          consttype.reset;
 | |
|          consttyp:=tconsttyp(readbyte);
 | |
|          case consttyp of
 | |
|            constint:
 | |
|              if sizeof(tconstexprint)=8 then
 | |
|                begin
 | |
|                   l1:=readlong;
 | |
|                   l2:=readlong;
 | |
| {$ifopt R+}
 | |
|   {$define Range_check_on}
 | |
| {$endif opt R+}
 | |
| {$R- needed here }
 | |
|                   value:=qword(l1)+(int64(l2) shl 32);
 | |
| {$ifdef Range_check_on}
 | |
|   {$R+}
 | |
|   {$undef Range_check_on}
 | |
| {$endif Range_check_on}
 | |
|                end
 | |
|              else
 | |
|                value:=readlong;
 | |
|            constbool,
 | |
|            constchar :
 | |
|              value:=readlong;
 | |
|            constpointer,
 | |
|            constord :
 | |
|              begin
 | |
|                consttype.load;
 | |
|                if sizeof(TConstExprInt)=8 then
 | |
|                  begin
 | |
|                     l1:=readlong;
 | |
|                     l2:=readlong;
 | |
| {$ifopt R+}
 | |
|   {$define Range_check_on}
 | |
| {$endif opt R+}
 | |
| {$R- needed here }
 | |
|                     value:=qword(l1)+(int64(l2) shl 32);
 | |
| {$ifdef Range_check_on}
 | |
|   {$R+}
 | |
|   {$undef Range_check_on}
 | |
| {$endif Range_check_on}
 | |
|                  end
 | |
|                else
 | |
|                  value:=readlong;
 | |
|              end;
 | |
|            conststring,constresourcestring :
 | |
|              begin
 | |
|                len:=readlong;
 | |
|                getmem(pc,len+1);
 | |
|                current_ppu^.getdata(pc^,len);
 | |
|                if consttyp=constresourcestring then
 | |
|                  ResStrIndex:=readlong;
 | |
|                value:=tpointerord(pc);
 | |
|              end;
 | |
|            constreal :
 | |
|              begin
 | |
|                new(pd);
 | |
|                pd^:=readreal;
 | |
|                value:=tpointerord(pd);
 | |
|              end;
 | |
|            constset :
 | |
|              begin
 | |
|                consttype.load;
 | |
|                new(ps);
 | |
|                readnormalset(ps^);
 | |
|                value:=tpointerord(ps);
 | |
|              end;
 | |
|            constnil : ;
 | |
|            else
 | |
|              Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp)));
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     destructor tconstsym.done;
 | |
|       begin
 | |
|         case consttyp of
 | |
|           conststring,constresourcestring :
 | |
|             freemem(pchar(tpointerord(value)),len+1);
 | |
|           constreal :
 | |
|             dispose(pbestreal(tpointerord(value)));
 | |
|           constset :
 | |
|             dispose(pnormalset(tpointerord(value)));
 | |
|         end;
 | |
|         inherited done;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tconstsym.mangledname : string;
 | |
|       begin
 | |
|          mangledname:=name;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tconstsym.deref;
 | |
|       begin
 | |
|         if consttyp in [constord,constpointer,constset] then
 | |
|          consttype.resolve;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tconstsym.write;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          writebyte(byte(consttyp));
 | |
|          case consttyp of
 | |
|            constnil : ;
 | |
|            constint:
 | |
|              if sizeof(TConstExprInt)=8 then
 | |
|                begin
 | |
|                   writelong(lo(value));
 | |
|                   writelong(hi(value));
 | |
|                end
 | |
|              else
 | |
|                writelong(value);
 | |
| 
 | |
|            constbool,
 | |
|            constchar :
 | |
|              writelong(value);
 | |
|            constpointer,
 | |
|            constord :
 | |
|              begin
 | |
|                consttype.write;
 | |
|                if sizeof(TConstExprInt)=8 then
 | |
|                  begin
 | |
|                     writelong(lo(value));
 | |
|                     writelong(hi(value));
 | |
|                  end
 | |
|                else
 | |
|                  writelong(value);
 | |
|              end;
 | |
|            conststring,constresourcestring :
 | |
|              begin
 | |
|                writelong(len);
 | |
|                current_ppu^.putdata(pchar(TPointerOrd(value))^,len);
 | |
|                if consttyp=constresourcestring then
 | |
|                  writelong(ResStrIndex);
 | |
|              end;
 | |
|            constreal :
 | |
|              writereal(pbestreal(TPointerOrd(value))^);
 | |
|            constset :
 | |
|              begin
 | |
|                consttype.write;
 | |
|                writenormalset(pointer(TPointerOrd(value))^);
 | |
|              end;
 | |
|          else
 | |
|            internalerror(13);
 | |
|          end;
 | |
|         current_ppu^.writeentry(ibconstsym);
 | |
|       end;
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     function tconstsym.stabstring : pchar;
 | |
|     var st : string;
 | |
|     begin
 | |
|          {even GDB v4.16 only now 'i' 'r' and 'e' !!!}
 | |
|          case consttyp of
 | |
|             conststring : begin
 | |
|                           { I had to remove ibm2ascii !! }
 | |
|                           st := pstring(TPointerOrd(value))^;
 | |
|                           {st := ibm2ascii(pstring(value)^);}
 | |
|                           st := 's'''+st+'''';
 | |
|                           end;
 | |
|             constbool,
 | |
|             constint,
 | |
|             constpointer,
 | |
|             constord,
 | |
|             constchar : st := 'i'+tostr(value);
 | |
|             constreal : begin
 | |
|                         system.str(pbestreal(TPointerOrd(value))^,st);
 | |
|                         st := 'r'+st;
 | |
|                         end;
 | |
|          { if we don't know just put zero !! }
 | |
|          else st:='i0';
 | |
|             {***SETCONST}
 | |
|             {constset:;}    {*** I don't know what to do with a set.}
 | |
|          { sets are not recognized by GDB}
 | |
|             {***}
 | |
|         end;
 | |
|     stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+
 | |
|                     tostr(fileinfo.line)+',0');
 | |
|     end;
 | |
| 
 | |
|     procedure tconstsym.concatstabto(asmlist : paasmoutput);
 | |
|       begin
 | |
|         if consttyp <> conststring then
 | |
|           inherited concatstabto(asmlist);
 | |
|       end;
 | |
| {$endif GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TENUMSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tenumsym.init(const n : string;def : penumdef;v : longint);
 | |
|       begin
 | |
|          tsym.init(n);
 | |
|          typ:=enumsym;
 | |
|          definition:=def;
 | |
|          value:=v;
 | |
|          if def^.min>v then
 | |
|            def^.setmin(v);
 | |
|          if def^.max<v then
 | |
|            def^.setmax(v);
 | |
|          order;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tenumsym.load;
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=enumsym;
 | |
|          definition:=penumdef(readdefref);
 | |
|          value:=readlong;
 | |
|          nextenum := Nil;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tenumsym.deref;
 | |
|       begin
 | |
|          resolvedef(pdef(definition));
 | |
|          order;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|    procedure tenumsym.order;
 | |
|       var
 | |
|          sym : penumsym;
 | |
|       begin
 | |
|          sym := definition^.firstenum;
 | |
|          if sym = nil then
 | |
|           begin
 | |
|             definition^.firstenum := @self;
 | |
|             nextenum := nil;
 | |
|             exit;
 | |
|           end;
 | |
|          { reorder the symbols in increasing value }
 | |
|          if value < sym^.value then
 | |
|           begin
 | |
|             nextenum := sym;
 | |
|             definition^.firstenum := @self;
 | |
|           end
 | |
|          else
 | |
|           begin
 | |
|             while (sym^.value <= value) and assigned(sym^.nextenum) do
 | |
|              sym := sym^.nextenum;
 | |
|             nextenum := sym^.nextenum;
 | |
|             sym^.nextenum := @self;
 | |
|           end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tenumsym.write;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          writedefref(definition);
 | |
|          writelong(value);
 | |
|          current_ppu^.writeentry(ibenumsym);
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     procedure tenumsym.concatstabto(asmlist : paasmoutput);
 | |
|     begin
 | |
|     {enum elements have no stab !}
 | |
|     end;
 | |
| {$EndIf GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TTYPESYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor ttypesym.init(const n : string;const tt : ttype);
 | |
| 
 | |
|       begin
 | |
|          tsym.init(n);
 | |
|          typ:=typesym;
 | |
|          restype:=tt;
 | |
| {$ifdef GDB}
 | |
|          isusedinstab := false;
 | |
| {$endif GDB}
 | |
| {$ifdef SYNONYM}
 | |
|          if assigned(restype.def) then
 | |
|           begin
 | |
|              if not(assigned(restype.def^.typesym)) then
 | |
|                begin
 | |
|                   restype.def^.typesym:=@self;
 | |
|                   synonym:=nil;
 | |
|                   include(symoptions,sp_primary_typesym);
 | |
|                end
 | |
|              else
 | |
|                begin
 | |
|                   synonym:=restype.def^.typesym^.synonym;
 | |
|                   restype.def^.typesym^.synonym:=@self;
 | |
|                end;
 | |
|           end;
 | |
| {$else}
 | |
|         { register the typesym for the definition }
 | |
|         if assigned(restype.def) and
 | |
|            not(assigned(restype.def^.typesym)) then
 | |
|          restype.def^.typesym:=@self;
 | |
| {$endif}
 | |
|       end;
 | |
| 
 | |
|     constructor ttypesym.initdef(const n : string;d : pdef);
 | |
|       var
 | |
|         t : ttype;
 | |
|       begin
 | |
|         t.setdef(d);
 | |
|         ttypesym.init(n,t);
 | |
|       end;
 | |
| 
 | |
|     constructor ttypesym.load;
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=typesym;
 | |
| {$ifdef SYNONYM}
 | |
|          synonym:=nil;
 | |
| {$endif}
 | |
| {$ifdef GDB}
 | |
|          isusedinstab := false;
 | |
| {$endif GDB}
 | |
|          restype.load;
 | |
|       end;
 | |
| 
 | |
| {$ifdef SYNONYM}
 | |
|     destructor ttypesym.done;
 | |
|       var
 | |
|         prevsym : ptypesym;
 | |
|       begin
 | |
|          if assigned(restype.def) then
 | |
|            begin
 | |
|               prevsym:=restype.def^.typesym;
 | |
|               if prevsym=@self then
 | |
|                 restype.def^.typesym:=synonym;
 | |
|               while assigned(prevsym) do
 | |
|                 begin
 | |
|                    if (prevsym^.synonym=@self) then
 | |
|                      begin
 | |
|                         prevsym^.synonym:=synonym;
 | |
|                         break;
 | |
|                      end;
 | |
|                    prevsym:=prevsym^.synonym;
 | |
|                 end;
 | |
|            end;
 | |
|          synonym:=nil;
 | |
|          inherited done;
 | |
|       end;
 | |
| {$endif}
 | |
| 
 | |
| 
 | |
|     procedure ttypesym.prederef;
 | |
|       begin
 | |
|          restype.resolve;
 | |
| {$ifdef SYNONYM}
 | |
|          if assigned(restype.def) then
 | |
|           begin
 | |
|             if (sp_primary_typesym in symoptions) then
 | |
|               begin
 | |
|                  if restype.def^.typesym<>@self then
 | |
|                    synonym:=restype.def^.typesym;
 | |
|                  restype.def^.typesym:=@self;
 | |
|               end
 | |
|             else
 | |
|               begin
 | |
|                  if assigned(restype.def^.typesym) then
 | |
|                    begin
 | |
|                       synonym:=restype.def^.typesym^.synonym;
 | |
|                       if restype.def^.typesym<>@self then
 | |
|                         restype.def^.typesym^.synonym:=@self;
 | |
|                    end
 | |
|                  else
 | |
|                    restype.def^.typesym:=@self;
 | |
|               end;
 | |
|             if (restype.def^.deftype=recorddef) and assigned(precorddef(restype.def)^.symtable) and
 | |
|                (restype.def^.typesym=@self) then
 | |
|               precorddef(restype.def)^.symtable^.name:=stringdup('record '+name);
 | |
|           end;
 | |
| {$endif}
 | |
|          {KAZ: another test for system unit: current_module^.used_units.first is nil iif system unit}
 | |
|          if not assigned(rec_tguid) and { system unit loaded first and TGUID be defined in system unit }
 | |
|             (_name^='TGUID') and { name: TGUID and size=16 bytes that is 128 bits }
 | |
|             assigned(restype.def) and (restype.def^.size=16) then
 | |
|            rec_tguid:=precorddef(restype.def);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure ttypesym.write;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          restype.write;
 | |
|          current_ppu^.writeentry(ibtypesym);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure ttypesym.load_references;
 | |
|       begin
 | |
|          inherited load_references;
 | |
|          if (restype.def^.deftype=recorddef) then
 | |
|            precorddef(restype.def)^.symtable^.load_browser;
 | |
|          if (restype.def^.deftype=objectdef) then
 | |
|            pobjectdef(restype.def)^.symtable^.load_browser;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function ttypesym.write_references : boolean;
 | |
|       begin
 | |
|         if not inherited write_references then
 | |
|          { write address of this symbol if record or object
 | |
|            even if no real refs are there
 | |
|            because we need it for the symtable }
 | |
|          if (restype.def^.deftype=recorddef) or
 | |
|             (restype.def^.deftype=objectdef) then
 | |
|           begin
 | |
|             writesymref(@self);
 | |
|             current_ppu^.writeentry(ibsymref);
 | |
|           end;
 | |
|          write_references:=true;
 | |
|          if (restype.def^.deftype=recorddef) then
 | |
|            precorddef(restype.def)^.symtable^.write_browser;
 | |
|          if (restype.def^.deftype=objectdef) then
 | |
|            pobjectdef(restype.def)^.symtable^.write_browser;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {$ifdef BrowserLog}
 | |
|     procedure ttypesym.add_to_browserlog;
 | |
|       begin
 | |
|          inherited add_to_browserlog;
 | |
|          if (restype.def^.deftype=recorddef) then
 | |
|            precorddef(restype.def)^.symtable^.writebrowserlog;
 | |
|          if (restype.def^.deftype=objectdef) then
 | |
|            pobjectdef(restype.def)^.symtable^.writebrowserlog;
 | |
|       end;
 | |
| {$endif BrowserLog}
 | |
| 
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     function ttypesym.stabstring : pchar;
 | |
|     var
 | |
|       stabchar : string[2];
 | |
|       short : string;
 | |
|     begin
 | |
|       if restype.def^.deftype in tagtypes then
 | |
|         stabchar := 'Tt'
 | |
|       else
 | |
|         stabchar := 't';
 | |
|       short := '"'+name+':'+stabchar+restype.def^.numberstring
 | |
|                +'",'+tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',0';
 | |
|       stabstring := strpnew(short);
 | |
|     end;
 | |
| 
 | |
|     procedure ttypesym.concatstabto(asmlist : paasmoutput);
 | |
|       begin
 | |
|       {not stabs for forward defs }
 | |
|       if assigned(restype.def) then
 | |
|         if (restype.def^.typesym = @self) then
 | |
|           restype.def^.concatstabto(asmlist)
 | |
|         else
 | |
|           inherited concatstabto(asmlist);
 | |
|       end;
 | |
| {$endif GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TSYSSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tsyssym.init(const n : string;l : longint);
 | |
|       begin
 | |
|          inherited init(n);
 | |
|          typ:=syssym;
 | |
|          number:=l;
 | |
|       end;
 | |
| 
 | |
|     constructor tsyssym.load;
 | |
|       begin
 | |
|          tsym.load;
 | |
|          typ:=syssym;
 | |
|          number:=readlong;
 | |
|       end;
 | |
| 
 | |
|     destructor tsyssym.done;
 | |
|       begin
 | |
|         inherited done;
 | |
|       end;
 | |
| 
 | |
|     procedure tsyssym.write;
 | |
|       begin
 | |
|          tsym.write;
 | |
|          writelong(number);
 | |
|          current_ppu^.writeentry(ibsyssym);
 | |
|       end;
 | |
| 
 | |
| {$ifdef GDB}
 | |
|     procedure tsyssym.concatstabto(asmlist : paasmoutput);
 | |
|       begin
 | |
|       end;
 | |
| {$endif GDB}
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                                   TMACROSYM
 | |
| ****************************************************************************}
 | |
| 
 | |
|     constructor tmacrosym.init(const n : string);
 | |
|       begin
 | |
|          inherited init(n);
 | |
|          typ:=macrosym;
 | |
|          defined:=true;
 | |
|          defined_at_startup:=false;
 | |
|          is_used:=false;
 | |
|          buftext:=nil;
 | |
|          buflen:=0;
 | |
|       end;
 | |
| 
 | |
|     destructor tmacrosym.done;
 | |
|       begin
 | |
|          if assigned(buftext) then
 | |
|            freemem(buftext,buflen);
 | |
|          inherited done;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {
 | |
|   $Log$
 | |
|   Revision 1.14  2000-11-28 00:28:07  pierre
 | |
|    * stabs fixing
 | |
| 
 | |
|   Revision 1.13  2000/11/04 14:25:22  florian
 | |
|     + merged Attila's changes for interfaces, not tested yet
 | |
| 
 | |
|   Revision 1.12  2000/10/31 22:02:52  peter
 | |
|     * symtable splitted, no real code changes
 | |
| 
 | |
|   Revision 1.11  2000/10/21 18:16:12  florian
 | |
|     * a lot of changes:
 | |
|        - basic dyn. array support
 | |
|        - basic C++ support
 | |
|        - some work for interfaces done
 | |
|        ....
 | |
| 
 | |
|   Revision 1.10  2000/10/15 07:47:53  peter
 | |
|     * unit names and procedure names are stored mixed case
 | |
| 
 | |
|   Revision 1.9  2000/09/24 21:19:52  peter
 | |
|     * delphi compile fixes
 | |
| 
 | |
|   Revision 1.8  2000/09/19 23:08:03  pierre
 | |
|    * fixes for local class debuggging problem (merged)
 | |
| 
 | |
|   Revision 1.7  2000/08/27 20:19:39  peter
 | |
|     * store strings with case in ppu, when an internal symbol is created
 | |
|       a '$' is prefixed so it's not automatic uppercased
 | |
| 
 | |
|   Revision 1.6  2000/08/21 11:27:44  pierre
 | |
|    * fix the stabs problems
 | |
| 
 | |
|   Revision 1.5  2000/08/16 13:06:07  florian
 | |
|     + support of 64 bit integer constants
 | |
| 
 | |
|   Revision 1.4  2000/08/13 12:54:56  peter
 | |
|     * class member decl wrong then no other error after it
 | |
|     * -vb has now also line numbering
 | |
|     * -vb is also used for interface/implementation different decls and
 | |
|       doesn't list the current function (merged)
 | |
| 
 | |
|   Revision 1.3  2000/07/13 12:08:27  michael
 | |
|   + patched to 1.1.0 with former 1.09patch from peter
 | |
| 
 | |
|   Revision 1.2  2000/07/13 11:32:49  michael
 | |
|   + removed logs
 | |
| 
 | |
| } | 
