mirror of
				https://gitlab.com/freepascal.org/fpc/source.git
				synced 2025-10-31 19:31:37 +01:00 
			
		
		
		
	
		
			
				
	
	
		
			1629 lines
		
	
	
		
			55 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
			
		
		
	
	
			1629 lines
		
	
	
		
			55 KiB
		
	
	
	
		
			ObjectPascal
		
	
	
	
	
	
| {
 | |
|     $Id$
 | |
|     Copyright (c) 2000-2002 by Florian Klaempfl
 | |
| 
 | |
|     Type checking and register allocation for load/assignment nodes
 | |
| 
 | |
|     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 nld;
 | |
| 
 | |
| {$i fpcdefs.inc}
 | |
| 
 | |
| interface
 | |
| 
 | |
|     uses
 | |
|        node,
 | |
|        {$ifdef state_tracking}
 | |
|        nstate,
 | |
|        {$endif}
 | |
|        symconst,symppu,symbase,symtype,symsym,symdef;
 | |
| 
 | |
|     type
 | |
|        tloadnode = class(tunarynode)
 | |
|           symtableentry : tsym;
 | |
|           symtableentryderef : tderef;
 | |
|           symtable : tsymtable;
 | |
|           procdef : tprocdef;
 | |
|           procdefderef : tderef;
 | |
|           constructor create(v : tsym;st : tsymtable);virtual;
 | |
|           constructor create_procvar(v : tsym;d:tprocdef;st : tsymtable);virtual;
 | |
|           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
 | |
|           procedure ppuwrite(ppufile:tcompilerppufile);override;
 | |
|           procedure buildderefimpl;override;
 | |
|           procedure derefimpl;override;
 | |
|           procedure set_mp(p:tnode);
 | |
|           function  getcopy : tnode;override;
 | |
|           function  pass_1 : tnode;override;
 | |
|           function  det_resulttype:tnode;override;
 | |
|           procedure mark_write;override;
 | |
|           function  docompare(p: tnode): boolean; override;
 | |
|           procedure printnodedata(var t:text);override;
 | |
|        end;
 | |
|        tloadnodeclass = class of tloadnode;
 | |
| 
 | |
|        { different assignment types }
 | |
|        tassigntype = (at_normal,at_plus,at_minus,at_star,at_slash);
 | |
| 
 | |
|        tassignmentnode = class(tbinarynode)
 | |
|           assigntype : tassigntype;
 | |
|           constructor create(l,r : tnode);virtual;
 | |
|           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
 | |
|           procedure ppuwrite(ppufile:tcompilerppufile);override;
 | |
|           function getcopy : tnode;override;
 | |
|           function pass_1 : tnode;override;
 | |
|           function det_resulttype:tnode;override;
 | |
|        {$ifdef state_tracking}
 | |
|           function track_state_pass(exec_known:boolean):boolean;override;
 | |
|        {$endif state_tracking}
 | |
|           function docompare(p: tnode): boolean; override;
 | |
|        end;
 | |
|        tassignmentnodeclass = class of tassignmentnode;
 | |
| 
 | |
|        tarrayconstructorrangenode = class(tbinarynode)
 | |
|           constructor create(l,r : tnode);virtual;
 | |
|           function pass_1 : tnode;override;
 | |
|           function det_resulttype:tnode;override;
 | |
|        end;
 | |
|        tarrayconstructorrangenodeclass = class of tarrayconstructorrangenode;
 | |
| 
 | |
|        tarrayconstructornode = class(tbinarynode)
 | |
|           constructor create(l,r : tnode);virtual;
 | |
|           function getcopy : tnode;override;
 | |
|           function pass_1 : tnode;override;
 | |
|           function det_resulttype:tnode;override;
 | |
|           function docompare(p: tnode): boolean; override;
 | |
|           procedure force_type(tt:ttype);
 | |
|           procedure insert_typeconvs;
 | |
|        end;
 | |
|        tarrayconstructornodeclass = class of tarrayconstructornode;
 | |
| 
 | |
|        ttypenode = class(tnode)
 | |
|           allowed : boolean;
 | |
|           restype : ttype;
 | |
|           constructor create(t : ttype);virtual;
 | |
|           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
 | |
|           procedure ppuwrite(ppufile:tcompilerppufile);override;
 | |
|           procedure buildderefimpl;override;
 | |
|           procedure derefimpl;override;
 | |
|           function pass_1 : tnode;override;
 | |
|           function det_resulttype:tnode;override;
 | |
|           function docompare(p: tnode): boolean; override;
 | |
|        end;
 | |
|        ttypenodeclass = class of ttypenode;
 | |
| 
 | |
|        trttinode = class(tnode)
 | |
|           l1,l2  : longint;
 | |
|           rttitype : trttitype;
 | |
|           rttidef : tstoreddef;
 | |
|           rttidefderef : tderef;
 | |
|           constructor create(def:tstoreddef;rt:trttitype);virtual;
 | |
|           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
 | |
|           procedure ppuwrite(ppufile:tcompilerppufile);override;
 | |
|           procedure buildderefimpl;override;
 | |
|           procedure derefimpl;override;
 | |
|           function  getcopy : tnode;override;
 | |
|           function pass_1 : tnode;override;
 | |
|           procedure pass_2;override;
 | |
|           function det_resulttype:tnode;override;
 | |
|           function docompare(p: tnode): boolean; override;
 | |
|        end;
 | |
|        trttinodeclass = class of trttinode;
 | |
| 
 | |
|     var
 | |
|        cloadnode : tloadnodeclass;
 | |
|        cassignmentnode : tassignmentnodeclass;
 | |
|        carrayconstructorrangenode : tarrayconstructorrangenodeclass;
 | |
|        carrayconstructornode : tarrayconstructornodeclass;
 | |
|        ctypenode : ttypenodeclass;
 | |
|        crttinode : trttinodeclass;
 | |
| 
 | |
| 
 | |
|     procedure load_procvar_from_calln(var p1:tnode);
 | |
|     function load_high_value_node(vs:tvarsym):tnode;
 | |
|     function load_self_node:tnode;
 | |
|     function load_result_node:tnode;
 | |
|     function load_self_pointer_node:tnode;
 | |
|     function load_vmt_pointer_node:tnode;
 | |
|     function is_self_node(p:tnode):boolean;
 | |
| 
 | |
| 
 | |
| implementation
 | |
| 
 | |
|     uses
 | |
|       cutils,verbose,globtype,globals,systems,
 | |
|       symtable,symnot,
 | |
|       defutil,defcmp,
 | |
|       htypechk,pass_1,procinfo,paramgr,
 | |
|       ncon,ninl,ncnv,nmem,ncal,cpubase,cgobj,cgbase
 | |
|       ;
 | |
| 
 | |
| {*****************************************************************************
 | |
|                                  Helpers
 | |
| *****************************************************************************}
 | |
| 
 | |
|       procedure load_procvar_from_calln(var p1:tnode);
 | |
|         var
 | |
|           p2 : tnode;
 | |
|         begin
 | |
|           if p1.nodetype<>calln then
 | |
|             internalerror(200212251);
 | |
|           { was it a procvar, then we simply remove the calln and
 | |
|             reuse the right }
 | |
|           if assigned(tcallnode(p1).right) then
 | |
|             begin
 | |
|               p2:=tcallnode(p1).right;
 | |
|               tcallnode(p1).right:=nil;
 | |
|             end
 | |
|           else
 | |
|             begin
 | |
|               p2:=cloadnode.create_procvar(tcallnode(p1).symtableprocentry,
 | |
|                  tprocdef(tcallnode(p1).procdefinition),tcallnode(p1).symtableproc);
 | |
|               { when the methodpointer is typen we've something like:
 | |
|                 tobject.create. Then only the address is needed of the
 | |
|                 method without a self pointer }
 | |
|               if assigned(tcallnode(p1).methodpointer) and
 | |
|                  (tcallnode(p1).methodpointer.nodetype<>typen) then
 | |
|                begin
 | |
|                  tloadnode(p2).set_mp(tcallnode(p1).methodpointer);
 | |
|                  tcallnode(p1).methodpointer:=nil;
 | |
|                end;
 | |
|             end;
 | |
|           resulttypepass(p2);
 | |
|           p1.free;
 | |
|           p1:=p2;
 | |
|         end;
 | |
| 
 | |
| 
 | |
|     function load_high_value_node(vs:tvarsym):tnode;
 | |
|       var
 | |
|         srsym : tsym;
 | |
|         srsymtable : tsymtable;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         srsymtable:=vs.owner;
 | |
|         srsym:=searchsymonlyin(srsymtable,'high'+vs.name);
 | |
|         if assigned(srsym) then
 | |
|           begin
 | |
|             result:=cloadnode.create(srsym,srsymtable);
 | |
|             resulttypepass(result);
 | |
|           end
 | |
|         else
 | |
|           CGMessage(cg_e_illegal_expression);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function load_self_node:tnode;
 | |
|       var
 | |
|         srsym : tsym;
 | |
|         srsymtable : tsymtable;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         searchsym('self',srsym,srsymtable);
 | |
|         if assigned(srsym) then
 | |
|           begin
 | |
|             result:=cloadnode.create(srsym,srsymtable);
 | |
|             resulttypepass(result);
 | |
|           end
 | |
|         else
 | |
|           CGMessage(cg_e_illegal_expression);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function load_result_node:tnode;
 | |
|       var
 | |
|         srsym : tsym;
 | |
|         srsymtable : tsymtable;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         searchsym('result',srsym,srsymtable);
 | |
|         if assigned(srsym) then
 | |
|           begin
 | |
|             result:=cloadnode.create(srsym,srsymtable);
 | |
|             resulttypepass(result);
 | |
|           end
 | |
|         else
 | |
|           CGMessage(cg_e_illegal_expression);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function load_self_pointer_node:tnode;
 | |
|       var
 | |
|         srsym : tsym;
 | |
|         srsymtable : tsymtable;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         searchsym('self',srsym,srsymtable);
 | |
|         if assigned(srsym) then
 | |
|           begin
 | |
|             result:=cloadnode.create(srsym,srsymtable);
 | |
|             include(result.flags,nf_load_self_pointer);
 | |
|             resulttypepass(result);
 | |
|           end
 | |
|         else
 | |
|           CGMessage(cg_e_illegal_expression);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function load_vmt_pointer_node:tnode;
 | |
|       var
 | |
|         srsym : tsym;
 | |
|         srsymtable : tsymtable;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         searchsym('vmt',srsym,srsymtable);
 | |
|         if assigned(srsym) then
 | |
|           begin
 | |
|             result:=cloadnode.create(srsym,srsymtable);
 | |
|             resulttypepass(result);
 | |
|           end
 | |
|         else
 | |
|           CGMessage(cg_e_illegal_expression);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function is_self_node(p:tnode):boolean;
 | |
|       begin
 | |
|         is_self_node:=(p.nodetype=loadn) and
 | |
|                       (tloadnode(p).symtableentry.typ=varsym) and
 | |
|                       (vo_is_self in tvarsym(tloadnode(p).symtableentry).varoptions);
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {*****************************************************************************
 | |
|                              TLOADNODE
 | |
| *****************************************************************************}
 | |
| 
 | |
|     constructor tloadnode.create(v : tsym;st : tsymtable);
 | |
|       begin
 | |
|          inherited create(loadn,nil);
 | |
|          if not assigned(v) then
 | |
|           internalerror(200108121);
 | |
|          symtableentry:=v;
 | |
|          symtable:=st;
 | |
|          procdef:=nil;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tloadnode.create_procvar(v : tsym;d:tprocdef;st : tsymtable);
 | |
|       begin
 | |
|          inherited create(loadn,nil);
 | |
|          if not assigned(v) then
 | |
|           internalerror(200108121);
 | |
|          symtableentry:=v;
 | |
|          symtable:=st;
 | |
|          procdef:=d;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tloadnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
 | |
|       begin
 | |
|         inherited ppuload(t,ppufile);
 | |
|         ppufile.getderef(symtableentryderef);
 | |
|         symtable:=nil;
 | |
|         ppufile.getderef(procdefderef);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tloadnode.ppuwrite(ppufile:tcompilerppufile);
 | |
|       begin
 | |
|         inherited ppuwrite(ppufile);
 | |
|         ppufile.putderef(symtableentryderef);
 | |
|         ppufile.putderef(procdefderef);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tloadnode.buildderefimpl;
 | |
|       begin
 | |
|         inherited buildderefimpl;
 | |
|         symtableentryderef.build(symtableentry);
 | |
|         procdefderef.build(procdef);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tloadnode.derefimpl;
 | |
|       begin
 | |
|         inherited derefimpl;
 | |
|         symtableentry:=tsym(symtableentryderef.resolve);
 | |
|         symtable:=symtableentry.owner;
 | |
|         procdef:=tprocdef(procdefderef.resolve);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tloadnode.set_mp(p:tnode);
 | |
|       begin
 | |
|         { typen nodes should not be set }
 | |
|         if p.nodetype=typen then
 | |
|           internalerror(200301042);
 | |
|         left:=p;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tloadnode.getcopy : tnode;
 | |
|       var
 | |
|          n : tloadnode;
 | |
| 
 | |
|       begin
 | |
|          n:=tloadnode(inherited getcopy);
 | |
|          n.symtable:=symtable;
 | |
|          n.symtableentry:=symtableentry;
 | |
|          n.procdef:=procdef;
 | |
|          result:=n;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tloadnode.det_resulttype:tnode;
 | |
|       begin
 | |
|          result:=nil;
 | |
|          case symtableentry.typ of
 | |
|            absolutesym :
 | |
|              resulttype:=tabsolutesym(symtableentry).vartype;
 | |
|            constsym:
 | |
|              begin
 | |
|                if tconstsym(symtableentry).consttyp=constresourcestring then
 | |
|                  resulttype:=cansistringtype
 | |
|                else
 | |
|                  internalerror(22799);
 | |
|              end;
 | |
|            varsym :
 | |
|              begin
 | |
|                inc(tvarsym(symtableentry).refs);
 | |
|                { Nested variable? The we need to load the framepointer of
 | |
|                  the parent procedure }
 | |
|                if (symtable.symtabletype in [localsymtable,parasymtable]) and
 | |
|                   (symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) then
 | |
|                  begin
 | |
|                    if assigned(left) then
 | |
|                      internalerror(200309289);
 | |
|                    left:=cloadparentfpnode.create(tprocdef(symtable.defowner));
 | |
|                  end;
 | |
|                { fix self type which is declared as voidpointer in the
 | |
|                  definition }
 | |
|                if vo_is_self in tvarsym(symtableentry).varoptions then
 | |
|                  begin
 | |
|                    resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class);
 | |
|                    if (po_classmethod in tprocdef(symtableentry.owner.defowner).procoptions) or
 | |
|                       (po_staticmethod in tprocdef(symtableentry.owner.defowner).procoptions) then
 | |
|                      resulttype.setdef(tclassrefdef.create(resulttype))
 | |
|                    else if is_object(resulttype.def) and
 | |
|                            (nf_load_self_pointer in flags) then
 | |
|                      resulttype.setdef(tpointerdef.create(resulttype));
 | |
|                  end
 | |
|                else if vo_is_vmt in tvarsym(symtableentry).varoptions then
 | |
|                  begin
 | |
|                    resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class);
 | |
|                    resulttype.setdef(tclassrefdef.create(resulttype));
 | |
|                  end
 | |
|                else
 | |
|                  resulttype:=tvarsym(symtableentry).vartype;
 | |
|              end;
 | |
|            typedconstsym :
 | |
|              resulttype:=ttypedconstsym(symtableentry).typedconsttype;
 | |
|            procsym :
 | |
|              begin
 | |
|                if not assigned(procdef) then
 | |
|                 begin
 | |
|                   if Tprocsym(symtableentry).procdef_count>1 then
 | |
|                    CGMessage(parser_e_no_overloaded_procvars);
 | |
|                   procdef:=tprocsym(symtableentry).first_procdef;
 | |
|                 end;
 | |
| 
 | |
|                { the result is a procdef, addrn and proc_to_procvar
 | |
|                  typeconvn need this as resulttype so they know
 | |
|                  that the address needs to be returned }
 | |
|                resulttype.setdef(procdef);
 | |
| 
 | |
|                { process methodpointer }
 | |
|                if assigned(left) then
 | |
|                  resulttypepass(left);
 | |
|              end;
 | |
|            else
 | |
|              internalerror(200104141);
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
|     procedure Tloadnode.mark_write;
 | |
| 
 | |
|     begin
 | |
|       include(flags,nf_write);
 | |
|     end;
 | |
| 
 | |
|     function tloadnode.pass_1 : tnode;
 | |
|       begin
 | |
|          result:=nil;
 | |
|          expectloc:=LOC_REFERENCE;
 | |
|          registers32:=0;
 | |
|          registersfpu:=0;
 | |
| {$ifdef SUPPORT_MMX}
 | |
|          registersmmx:=0;
 | |
| {$endif SUPPORT_MMX}
 | |
|          case symtableentry.typ of
 | |
|             absolutesym :
 | |
|               ;
 | |
|             constsym:
 | |
|               begin
 | |
|                  if tconstsym(symtableentry).consttyp=constresourcestring then
 | |
|                    begin
 | |
|                       include(current_procinfo.flags,pi_needs_implicit_finally);
 | |
|                       expectloc:=LOC_CREFERENCE;
 | |
|                    end;
 | |
|               end;
 | |
|             varsym :
 | |
|               begin
 | |
|                 if assigned(left) then
 | |
|                   firstpass(left);
 | |
|                 if (tvarsym(symtableentry).varspez=vs_const) then
 | |
|                   expectloc:=LOC_CREFERENCE;
 | |
|                 { we need a register for call by reference parameters }
 | |
|                 if paramanager.push_addr_param(tvarsym(symtableentry).varspez,tvarsym(symtableentry).vartype.def,pocall_default) then
 | |
|                   registers32:=1;
 | |
|                 if ([vo_is_thread_var,vo_is_dll_var]*tvarsym(symtableentry).varoptions)<>[] then
 | |
|                   registers32:=1;
 | |
|                 { call to get address of threadvar }
 | |
|                 if (vo_is_thread_var in tvarsym(symtableentry).varoptions) then
 | |
|                   include(current_procinfo.flags,pi_do_call);
 | |
|                 if nf_write in flags then
 | |
|                   Tvarsym(symtableentry).trigger_notifications(vn_onwrite)
 | |
|                 else
 | |
|                   Tvarsym(symtableentry).trigger_notifications(vn_onread);
 | |
|                 { count variable references }
 | |
|                 if cg.t_times>1 then
 | |
|                   inc(tvarsym(symtableentry).refs,cg.t_times-1);
 | |
|               end;
 | |
|             typedconstsym :
 | |
|                 ;
 | |
|             procsym :
 | |
|                 begin
 | |
|                    { method pointer ? }
 | |
|                    if assigned(left) then
 | |
|                      begin
 | |
|                         expectloc:=LOC_CREFERENCE;
 | |
|                         firstpass(left);
 | |
|                         registers32:=max(registers32,left.registers32);
 | |
|                         registersfpu:=max(registersfpu,left.registersfpu);
 | |
|  {$ifdef SUPPORT_MMX}
 | |
|                         registersmmx:=max(registersmmx,left.registersmmx);
 | |
|  {$endif SUPPORT_MMX}
 | |
|                      end;
 | |
|                 end;
 | |
|            else
 | |
|              internalerror(200104143);
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tloadnode.docompare(p: tnode): boolean;
 | |
|       begin
 | |
|         docompare :=
 | |
|           inherited docompare(p) and
 | |
|           (symtableentry = tloadnode(p).symtableentry) and
 | |
|           (procdef = tloadnode(p).procdef) and
 | |
|           (symtable = tloadnode(p).symtable);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure Tloadnode.printnodedata(var t:text);
 | |
|       begin
 | |
|         inherited printnodedata(t);
 | |
|         write(t,printnodeindention,'symbol = ',symtableentry.name);
 | |
|         if symtableentry.typ=procsym then
 | |
|           write(t,printnodeindention,'procdef = ',procdef.mangledname);
 | |
|         writeln(t,'');
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {*****************************************************************************
 | |
|                              TASSIGNMENTNODE
 | |
| *****************************************************************************}
 | |
| 
 | |
|     constructor tassignmentnode.create(l,r : tnode);
 | |
| 
 | |
|       begin
 | |
|          inherited create(assignn,l,r);
 | |
|          l.mark_write;
 | |
|          assigntype:=at_normal;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor tassignmentnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
 | |
|       begin
 | |
|         inherited ppuload(t,ppufile);
 | |
|         assigntype:=tassigntype(ppufile.getbyte);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tassignmentnode.ppuwrite(ppufile:tcompilerppufile);
 | |
|       begin
 | |
|         inherited ppuwrite(ppufile);
 | |
|         ppufile.putbyte(byte(assigntype));
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tassignmentnode.getcopy : tnode;
 | |
| 
 | |
|       var
 | |
|          n : tassignmentnode;
 | |
| 
 | |
|       begin
 | |
|          n:=tassignmentnode(inherited getcopy);
 | |
|          n.assigntype:=assigntype;
 | |
|          getcopy:=n;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tassignmentnode.det_resulttype:tnode;
 | |
|       var
 | |
|         hp : tnode;
 | |
|         useshelper : boolean;
 | |
|         original_size : longint;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         resulttype:=voidtype;
 | |
|         original_size := 0;
 | |
| 
 | |
|         { must be made unique }
 | |
|         set_unique(left);
 | |
| 
 | |
|         resulttypepass(left);
 | |
| 
 | |
|         if is_ansistring(left.resulttype.def) then
 | |
|           begin
 | |
|             { fold <ansistring>:=<ansistring>+<char|shortstring|ansistring> }
 | |
|             if (right.nodetype=addn) and
 | |
|                left.isequal(tbinarynode(right).left) and
 | |
|                { don't fold multiple concatenations else we could get trouble
 | |
|                  with multiple uses of s
 | |
|                }
 | |
|                (tbinarynode(right).left.nodetype<>addn) and
 | |
|                (tbinarynode(right).right.nodetype<>addn) then
 | |
|               begin
 | |
|                 { don't do a resulttypepass(right), since then the addnode }
 | |
|                 { may insert typeconversions that make this optimization   }
 | |
|                 { opportunity quite difficult to detect (JM)               }
 | |
|                 resulttypepass(tbinarynode(right).left);
 | |
|                 resulttypepass(tbinarynode(right).right);
 | |
|                 if (is_char(tbinarynode(right).right.resulttype.def) or
 | |
|                    is_shortstring(tbinarynode(right).right.resulttype.def) or
 | |
|                    is_ansistring(tbinarynode(right).right.resulttype.def)) then
 | |
|                   begin
 | |
|                     { remove property flag so it'll not trigger an error }
 | |
|                     exclude(left.flags,nf_isproperty);
 | |
|                     { generate call to helper }
 | |
|                     hp:=ccallparanode.create(tbinarynode(right).right,
 | |
|                       ccallparanode.create(left,nil));
 | |
|                     if is_char(tbinarynode(right).right.resulttype.def) then
 | |
|                       result:=ccallnode.createintern('fpc_ansistr_append_char',hp)
 | |
|                     else if is_shortstring(tbinarynode(right).right.resulttype.def) then
 | |
|                       result:=ccallnode.createintern('fpc_ansistr_append_shortstring',hp)
 | |
|                     else
 | |
|                       result:=ccallnode.createintern('fpc_ansistr_append_ansistring',hp);
 | |
|                     tbinarynode(right).right:=nil;
 | |
|                     left:=nil;
 | |
|                     exit;
 | |
|                  end;
 | |
|               end;
 | |
|           end
 | |
|         else
 | |
|          if is_shortstring(left.resulttype.def) then
 | |
|           begin
 | |
|             { fold <shortstring>:=<shortstring>+<shortstring>,
 | |
|               <shortstring>+<char> is handled by an optimized node }
 | |
|             if (right.nodetype=addn) and
 | |
|                left.isequal(tbinarynode(right).left) and
 | |
|                { don't fold multiple concatenations else we could get trouble
 | |
|                  with multiple uses of s }
 | |
|                (tbinarynode(right).left.nodetype<>addn) and
 | |
|                (tbinarynode(right).right.nodetype<>addn) then
 | |
|               begin
 | |
|                 { don't do a resulttypepass(right), since then the addnode }
 | |
|                 { may insert typeconversions that make this optimization   }
 | |
|                 { opportunity quite difficult to detect (JM)               }
 | |
|                 resulttypepass(tbinarynode(right).left);
 | |
|                 resulttypepass(tbinarynode(right).right);
 | |
|                 if is_shortstring(tbinarynode(right).right.resulttype.def) then
 | |
|                   begin
 | |
|                     { remove property flag so it'll not trigger an error }
 | |
|                     exclude(left.flags,nf_isproperty);
 | |
|                     { generate call to helper }
 | |
|                     hp:=ccallparanode.create(tbinarynode(right).right,
 | |
|                       ccallparanode.create(left,nil));
 | |
|                     if is_shortstring(tbinarynode(right).right.resulttype.def) then
 | |
|                       result:=ccallnode.createintern('fpc_shortstr_append_shortstr',hp);
 | |
|                     tbinarynode(right).right:=nil;
 | |
|                     left:=nil;
 | |
|                     exit;
 | |
|                  end;
 | |
|               end;
 | |
|           end;
 | |
| 
 | |
|         resulttypepass(right);
 | |
|         set_varstate(left,vs_assigned,false);
 | |
|         set_varstate(right,vs_used,true);
 | |
|         if codegenerror then
 | |
|           exit;
 | |
| 
 | |
|         { assignments to formaldefs and open arrays aren't allowed }
 | |
|         if (left.resulttype.def.deftype=formaldef) or
 | |
|            is_open_array(left.resulttype.def) then
 | |
|           CGMessage(type_e_operator_not_allowed);
 | |
| 
 | |
|         { test if node can be assigned, properties are allowed }
 | |
|         valid_for_assignment(left);
 | |
| 
 | |
|         { assigning nil to a dynamic array clears the array }
 | |
|         if is_dynamic_array(left.resulttype.def) and
 | |
|            (right.nodetype=niln) then
 | |
|          begin
 | |
|            hp:=ccallparanode.create(caddrnode.create
 | |
|                    (crttinode.create(tstoreddef(left.resulttype.def),initrtti)),
 | |
|                ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil));
 | |
|            result := ccallnode.createintern('fpc_dynarray_clear',hp);
 | |
|            left:=nil;
 | |
|            exit;
 | |
|          end;
 | |
| 
 | |
|         { shortstring helpers can do the conversion directly,
 | |
|           so treat them separatly }
 | |
|         if (is_shortstring(left.resulttype.def)) then
 | |
|          begin
 | |
|            { insert typeconv, except for chars that are handled in
 | |
|              secondpass and except for ansi/wide string that can
 | |
|              be converted immediatly }
 | |
|            if not(is_char(right.resulttype.def) or
 | |
|                   (right.resulttype.def.deftype=stringdef)) then
 | |
|              inserttypeconv(right,left.resulttype);
 | |
|            if right.resulttype.def.deftype=stringdef then
 | |
|             begin
 | |
|               useshelper:=true;
 | |
|               { convert constant strings to shortstrings. But
 | |
|                 skip empty constant strings, that will be handled
 | |
|                 in secondpass }
 | |
|               if (right.nodetype=stringconstn) then
 | |
|                 begin
 | |
|                   { verify if range fits within shortstring }
 | |
|                   { just emit a warning, delphi gives an    }
 | |
|                   { error, only if the type definition of   }
 | |
|                   { of the string is less  < 255 characters }
 | |
|                   if not is_open_string(left.resulttype.def) and
 | |
|                      (tstringconstnode(right).len > tstringdef(left.resulttype.def).len) then
 | |
|                      cgmessage(type_w_string_too_long);
 | |
|                   inserttypeconv(right,left.resulttype);
 | |
|                   if (tstringconstnode(right).len=0) then
 | |
|                     useshelper:=false;
 | |
|                 end;
 | |
|              { rest is done in pass 1 (JM) }
 | |
|              if useshelper then
 | |
|                exit;
 | |
|             end
 | |
|          end
 | |
|         else
 | |
|           begin
 | |
|            { get the size before the type conversion - check for all nodes }
 | |
|            if assigned(right.resulttype.def) and
 | |
|               (right.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
 | |
|               (right.nodetype in [loadn,vecn,calln]) then
 | |
|              original_size := right.resulttype.def.size;
 | |
|            inserttypeconv(right,left.resulttype);
 | |
|           end;
 | |
| 
 | |
|         { check if the assignment may cause a range check error }
 | |
|         { if its not explicit, and only if the values are       }
 | |
|         { ordinals, enumdef and floatdef                        }
 | |
|         if (right.nodetype = typeconvn) and
 | |
|            not (nf_explicit in ttypeconvnode(right).flags) then
 | |
|          begin
 | |
|             if assigned(left.resulttype.def) and
 | |
|               (left.resulttype.def.deftype in [enumdef,orddef,floatdef]) then
 | |
|               begin
 | |
|                 if (original_size <> 0) and (left.resulttype.def.size < original_size) then
 | |
|                   begin
 | |
|                     if (cs_check_range in aktlocalswitches) then
 | |
|                       Message(type_w_smaller_possible_range_check)
 | |
|                     else
 | |
|                       Message(type_h_smaller_possible_range_check);
 | |
|                   end;
 | |
|               end;
 | |
|          end;
 | |
| 
 | |
|         { call helpers for interface }
 | |
|         if is_interfacecom(left.resulttype.def) then
 | |
|          begin
 | |
|            hp:=ccallparanode.create(ctypeconvnode.create_explicit
 | |
|                    (right,voidpointertype),
 | |
|                ccallparanode.create(ctypeconvnode.create_explicit
 | |
|                    (left,voidpointertype),nil));
 | |
|            result:=ccallnode.createintern('fpc_intf_assign',hp);
 | |
|            left:=nil;
 | |
|            right:=nil;
 | |
|            exit;
 | |
|          end;
 | |
| 
 | |
|         { check if local proc/func is assigned to procvar }
 | |
|         if right.resulttype.def.deftype=procvardef then
 | |
|           test_local_to_procvar(tprocvardef(right.resulttype.def),left.resulttype.def);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tassignmentnode.pass_1 : tnode;
 | |
|       var
 | |
|         hp: tnode;
 | |
|       begin
 | |
|          result:=nil;
 | |
|          expectloc:=LOC_VOID;
 | |
| 
 | |
|          firstpass(left);
 | |
|          firstpass(right);
 | |
|          { assignment to refcounted variable -> inc/decref }
 | |
|          if (not is_class(left.resulttype.def) and
 | |
|             left.resulttype.def.needs_inittable) then
 | |
|            include(current_procinfo.flags,pi_do_call);
 | |
| 
 | |
|          if codegenerror then
 | |
|            exit;
 | |
| 
 | |
| 
 | |
|         if (is_shortstring(left.resulttype.def)) then
 | |
|           begin
 | |
|            if right.resulttype.def.deftype=stringdef then
 | |
|             begin
 | |
|               if (right.nodetype<>stringconstn) or
 | |
|                  (tstringconstnode(right).len<>0) then
 | |
|                begin
 | |
|                  if (cs_optimize in aktglobalswitches) and
 | |
|                     (right.nodetype in [calln,blockn]) and
 | |
|                     (left.nodetype = temprefn) and
 | |
|                     is_shortstring(right.resulttype.def) and
 | |
|                     not is_open_string(left.resulttype.def) and
 | |
|                     (tstringdef(left.resulttype.def).len = 255) then
 | |
|                    begin
 | |
|                      { the blocknode case is handled in pass_2 at the temp }
 | |
|                      { reference level (mainly for callparatemp)  (JM)     }
 | |
|                      if (right.nodetype = calln) then
 | |
|                        begin
 | |
|                          tcallnode(right).funcretnode := left;
 | |
|                          result := right;
 | |
|                        end
 | |
|                      else
 | |
|                        exit;
 | |
|                    end
 | |
|                  else
 | |
|                    begin
 | |
|                      hp:=ccallparanode.create
 | |
|                            (right,
 | |
|                       ccallparanode.create(cinlinenode.create
 | |
|                            (in_high_x,false,left.getcopy),nil));
 | |
|                      result:=ccallnode.createinternreturn('fpc_'+tstringdef(right.resulttype.def).stringtypname+'_to_shortstr',hp,left);
 | |
|                      firstpass(result);
 | |
|                    end;
 | |
|                  left:=nil;
 | |
|                  right:=nil;
 | |
|                  exit;
 | |
|                end;
 | |
|             end;
 | |
|            end;
 | |
| 
 | |
|          if (cs_optimize in aktglobalswitches) and
 | |
|             (right.nodetype = calln) and
 | |
|             { left must be a temp, since otherwise as soon as you modify the }
 | |
|             { result, the current left node is modified and that one may     }
 | |
|             { still be an argument to the function or even accessed in the   }
 | |
|             { function                                                       }
 | |
|             (((left.nodetype = temprefn) and
 | |
|               paramanager.ret_in_param(right.resulttype.def,
 | |
|                 tcallnode(right).procdefinition.proccalloption)) or
 | |
|              { there's special support for ansi/widestrings in the callnode }
 | |
|              is_ansistring(right.resulttype.def) or
 | |
|              is_widestring(right.resulttype.def))  then
 | |
|            begin
 | |
|              tcallnode(right).funcretnode := left;
 | |
|              result := right;
 | |
|              left := nil;
 | |
|              right := nil;
 | |
|              exit;
 | |
|            end;
 | |
| 
 | |
| 
 | |
|          registers32:=left.registers32+right.registers32;
 | |
|          registersfpu:=max(left.registersfpu,right.registersfpu);
 | |
| {$ifdef SUPPORT_MMX}
 | |
|          registersmmx:=max(left.registersmmx,right.registersmmx);
 | |
| {$endif SUPPORT_MMX}
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tassignmentnode.docompare(p: tnode): boolean;
 | |
|       begin
 | |
|         docompare :=
 | |
|           inherited docompare(p) and
 | |
|           (assigntype = tassignmentnode(p).assigntype);
 | |
|       end;
 | |
| 
 | |
| {$ifdef state_tracking}
 | |
|     function Tassignmentnode.track_state_pass(exec_known:boolean):boolean;
 | |
| 
 | |
|     var se:Tstate_entry;
 | |
| 
 | |
|     begin
 | |
|         track_state_pass:=false;
 | |
|         if exec_known then
 | |
|             begin
 | |
|                 track_state_pass:=right.track_state_pass(exec_known);
 | |
|                 {Force a new resulttype pass.}
 | |
|                 right.resulttype.def:=nil;
 | |
|                 do_resulttypepass(right);
 | |
|                 resulttypepass(right);
 | |
|                 aktstate.store_fact(left.getcopy,right.getcopy);
 | |
|             end
 | |
|         else
 | |
|             aktstate.delete_fact(left);
 | |
|     end;
 | |
| {$endif}
 | |
| 
 | |
| 
 | |
| {*****************************************************************************
 | |
|                            TARRAYCONSTRUCTORRANGENODE
 | |
| *****************************************************************************}
 | |
| 
 | |
|     constructor tarrayconstructorrangenode.create(l,r : tnode);
 | |
| 
 | |
|       begin
 | |
|          inherited create(arrayconstructorrangen,l,r);
 | |
|       end;
 | |
| 
 | |
|     function tarrayconstructorrangenode.det_resulttype:tnode;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         resulttypepass(left);
 | |
|         resulttypepass(right);
 | |
|         set_varstate(left,vs_used,true);
 | |
|         set_varstate(right,vs_used,true);
 | |
|         if codegenerror then
 | |
|          exit;
 | |
|         resulttype:=left.resulttype;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tarrayconstructorrangenode.pass_1 : tnode;
 | |
|       begin
 | |
|         firstpass(left);
 | |
|         firstpass(right);
 | |
|         expectloc:=LOC_CREFERENCE;
 | |
|         calcregisters(self,0,0,0);
 | |
|         result:=nil;
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {****************************************************************************
 | |
|                             TARRAYCONSTRUCTORNODE
 | |
| *****************************************************************************}
 | |
| 
 | |
|     constructor tarrayconstructornode.create(l,r : tnode);
 | |
|       begin
 | |
|          inherited create(arrayconstructorn,l,r);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tarrayconstructornode.getcopy : tnode;
 | |
|       var
 | |
|          n : tarrayconstructornode;
 | |
|       begin
 | |
|          n:=tarrayconstructornode(inherited getcopy);
 | |
|          result:=n;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tarrayconstructornode.det_resulttype:tnode;
 | |
|       var
 | |
|         htype : ttype;
 | |
|         hp    : tarrayconstructornode;
 | |
|         len   : longint;
 | |
|         varia : boolean;
 | |
|       begin
 | |
|         result:=nil;
 | |
| 
 | |
|       { are we allowing array constructor? Then convert it to a set }
 | |
|         if not allow_array_constructor then
 | |
|          begin
 | |
|            hp:=tarrayconstructornode(getcopy);
 | |
|            arrayconstructor_to_set(tnode(hp));
 | |
|            result:=hp;
 | |
|            exit;
 | |
|          end;
 | |
| 
 | |
|       { only pass left tree, right tree contains next construct if any }
 | |
|         htype.reset;
 | |
|         len:=0;
 | |
|         varia:=false;
 | |
|         if assigned(left) then
 | |
|          begin
 | |
|            hp:=self;
 | |
|            while assigned(hp) do
 | |
|             begin
 | |
|               resulttypepass(hp.left);
 | |
|               set_varstate(hp.left,vs_used,true);
 | |
|               if (htype.def=nil) then
 | |
|                htype:=hp.left.resulttype
 | |
|               else
 | |
|                begin
 | |
|                  if ((nf_novariaallowed in flags) or (not varia)) and
 | |
|                     (not equal_defs(htype.def,hp.left.resulttype.def)) then
 | |
|                   begin
 | |
|                     varia:=true;
 | |
|                   end;
 | |
|                end;
 | |
|               inc(len);
 | |
|               hp:=tarrayconstructornode(hp.right);
 | |
|             end;
 | |
|          end;
 | |
|          if not assigned(htype.def) then
 | |
|           htype:=voidtype;
 | |
|          resulttype.setdef(tarraydef.create(0,len-1,s32bittype));
 | |
|          tarraydef(resulttype.def).setelementtype(htype);
 | |
|          tarraydef(resulttype.def).IsConstructor:=true;
 | |
|          tarraydef(resulttype.def).IsVariant:=varia;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tarrayconstructornode.force_type(tt:ttype);
 | |
|       var
 | |
|         hp : tarrayconstructornode;
 | |
|       begin
 | |
|         tarraydef(resulttype.def).setelementtype(tt);
 | |
|         tarraydef(resulttype.def).IsConstructor:=true;
 | |
|         tarraydef(resulttype.def).IsVariant:=false;
 | |
|         if assigned(left) then
 | |
|          begin
 | |
|            hp:=self;
 | |
|            while assigned(hp) do
 | |
|             begin
 | |
|               inserttypeconv(hp.left,tt);
 | |
|               hp:=tarrayconstructornode(hp.right);
 | |
|             end;
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure tarrayconstructornode.insert_typeconvs;
 | |
|       var
 | |
|         thp,
 | |
|         chp,
 | |
|         hp        : tarrayconstructornode;
 | |
|         dovariant : boolean;
 | |
|         htype     : ttype;
 | |
|         orgflags  : tnodeflags;
 | |
|       begin
 | |
|         dovariant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant;
 | |
|         { only pass left tree, right tree contains next construct if any }
 | |
|         if assigned(left) then
 | |
|          begin
 | |
|            hp:=self;
 | |
|            while assigned(hp) do
 | |
|             begin
 | |
|               resulttypepass(hp.left);
 | |
|               { Insert typeconvs for array of const }
 | |
|               if dovariant then
 | |
|                begin
 | |
|                  case hp.left.resulttype.def.deftype of
 | |
|                    enumdef :
 | |
|                      hp.left:=ctypeconvnode.create_explicit(hp.left,s32bittype);
 | |
|                    arraydef :
 | |
|                      hp.left:=ctypeconvnode.create(hp.left,charpointertype);
 | |
|                    orddef :
 | |
|                      begin
 | |
|                        if is_integer(hp.left.resulttype.def) and
 | |
|                           not(is_64bitint(hp.left.resulttype.def)) then
 | |
|                          hp.left:=ctypeconvnode.create(hp.left,s32bittype);
 | |
|                      end;
 | |
|                    floatdef :
 | |
|                      hp.left:=ctypeconvnode.create(hp.left,pbestrealtype^);
 | |
|                    procvardef :
 | |
|                      hp.left:=ctypeconvnode.create(hp.left,voidpointertype);
 | |
|                    stringdef,
 | |
|                    variantdef,
 | |
|                    pointerdef,
 | |
|                    classrefdef,
 | |
|                    objectdef : ;
 | |
|                    else
 | |
|                      CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename);
 | |
|                  end;
 | |
|                end;
 | |
|               resulttypepass(hp.left);
 | |
|               hp:=tarrayconstructornode(hp.right);
 | |
|             end;
 | |
|          end;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tarrayconstructornode.pass_1 : tnode;
 | |
|       var
 | |
|         hp : tarrayconstructornode;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         { Insert required type convs, this must be
 | |
|           done in pass 1, because the call must be
 | |
|           resulttypepassed already }
 | |
|         if assigned(left) then
 | |
|           begin
 | |
|             insert_typeconvs;
 | |
|             { call firstpass for all nodes }
 | |
|             hp:=self;
 | |
|             while assigned(hp) do
 | |
|               begin
 | |
|                 firstpass(hp.left);
 | |
|                 hp:=tarrayconstructornode(hp.right);
 | |
|               end;
 | |
|           end;
 | |
|         expectloc:=LOC_CREFERENCE;
 | |
|         calcregisters(self,0,0,0);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function tarrayconstructornode.docompare(p: tnode): boolean;
 | |
|       begin
 | |
|         docompare :=
 | |
|           inherited docompare(p);
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {*****************************************************************************
 | |
|                               TTYPENODE
 | |
| *****************************************************************************}
 | |
| 
 | |
|     constructor ttypenode.create(t : ttype);
 | |
|       begin
 | |
|          inherited create(typen);
 | |
|          restype:=t;
 | |
|          allowed:=false;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor ttypenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
 | |
|       begin
 | |
|         inherited ppuload(t,ppufile);
 | |
|         ppufile.gettype(restype);
 | |
|         allowed:=boolean(ppufile.getbyte);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure ttypenode.ppuwrite(ppufile:tcompilerppufile);
 | |
|       begin
 | |
|         inherited ppuwrite(ppufile);
 | |
|         ppufile.puttype(restype);
 | |
|         ppufile.putbyte(byte(allowed));
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure ttypenode.buildderefimpl;
 | |
|       begin
 | |
|         inherited buildderefimpl;
 | |
|         restype.buildderef;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure ttypenode.derefimpl;
 | |
|       begin
 | |
|         inherited derefimpl;
 | |
|         restype.resolve;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function ttypenode.det_resulttype:tnode;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         resulttype:=restype;
 | |
|         { check if it's valid }
 | |
|         if restype.def.deftype = errordef then
 | |
|           CGMessage(cg_e_illegal_expression);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function ttypenode.pass_1 : tnode;
 | |
|       begin
 | |
|          result:=nil;
 | |
|          expectloc:=LOC_VOID;
 | |
|          { a typenode can't generate code, so we give here
 | |
|            an error. Else it'll be an abstract error in pass_2.
 | |
|            Only when the allowed flag is set we don't generate
 | |
|            an error }
 | |
|          if not allowed then
 | |
|           Message(parser_e_no_type_not_allowed_here);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function ttypenode.docompare(p: tnode): boolean;
 | |
|       begin
 | |
|         docompare :=
 | |
|           inherited docompare(p);
 | |
|       end;
 | |
| 
 | |
| 
 | |
| {*****************************************************************************
 | |
|                               TRTTINODE
 | |
| *****************************************************************************}
 | |
| 
 | |
| 
 | |
|     constructor trttinode.create(def:tstoreddef;rt:trttitype);
 | |
|       begin
 | |
|          inherited create(rttin);
 | |
|          rttidef:=def;
 | |
|          rttitype:=rt;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     constructor trttinode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
 | |
|       begin
 | |
|         inherited ppuload(t,ppufile);
 | |
|         ppufile.getderef(rttidefderef);
 | |
|         rttitype:=trttitype(ppufile.getbyte);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure trttinode.ppuwrite(ppufile:tcompilerppufile);
 | |
|       begin
 | |
|         inherited ppuwrite(ppufile);
 | |
|         ppufile.putderef(rttidefderef);
 | |
|         ppufile.putbyte(byte(rttitype));
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure trttinode.buildderefimpl;
 | |
|       begin
 | |
|         inherited buildderefimpl;
 | |
|         rttidefderef.build(rttidef);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure trttinode.derefimpl;
 | |
|       begin
 | |
|         inherited derefimpl;
 | |
|         rttidef:=tstoreddef(rttidefderef.resolve);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function trttinode.getcopy : tnode;
 | |
|       var
 | |
|          n : trttinode;
 | |
|       begin
 | |
|          n:=trttinode(inherited getcopy);
 | |
|          n.rttidef:=rttidef;
 | |
|          n.rttitype:=rttitype;
 | |
|          result:=n;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function trttinode.det_resulttype:tnode;
 | |
|       begin
 | |
|         { rtti information will be returned as a void pointer }
 | |
|         result:=nil;
 | |
|         resulttype:=voidpointertype;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function trttinode.pass_1 : tnode;
 | |
|       begin
 | |
|         result:=nil;
 | |
|         expectloc:=LOC_CREFERENCE;
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     function trttinode.docompare(p: tnode): boolean;
 | |
|       begin
 | |
|         docompare :=
 | |
|           inherited docompare(p) and
 | |
|           (rttidef = trttinode(p).rttidef) and
 | |
|           (rttitype = trttinode(p).rttitype);
 | |
|       end;
 | |
| 
 | |
| 
 | |
|     procedure trttinode.pass_2;
 | |
|       begin
 | |
|         location_reset(location,LOC_CREFERENCE,OS_NO);
 | |
|         location.reference.symbol:=rttidef.get_rtti_label(rttitype);
 | |
|       end;
 | |
| 
 | |
| 
 | |
| begin
 | |
|    cloadnode:=tloadnode;
 | |
|    cassignmentnode:=tassignmentnode;
 | |
|    carrayconstructorrangenode:=tarrayconstructorrangenode;
 | |
|    carrayconstructornode:=tarrayconstructornode;
 | |
|    ctypenode:=ttypenode;
 | |
|    crttinode:=trttinode;
 | |
| end.
 | |
| {
 | |
|   $Log$
 | |
|   Revision 1.119  2003-12-01 18:44:15  peter
 | |
|     * fixed some crashes
 | |
|     * fixed varargs and register calling probs
 | |
| 
 | |
|   Revision 1.118  2003/11/26 14:25:26  michael
 | |
|   + Applied patch from peter to support ansistrings in array constructors
 | |
| 
 | |
|   Revision 1.117  2003/11/23 17:39:33  peter
 | |
|     * removed obsolete nf_cargs flag
 | |
| 
 | |
|   Revision 1.116  2003/10/28 15:36:01  peter
 | |
|     * absolute to object field supported, fixes tb0458
 | |
| 
 | |
|   Revision 1.115  2003/10/23 14:44:07  peter
 | |
|     * splitted buildderef and buildderefimpl to fix interface crc
 | |
|       calculation
 | |
| 
 | |
|   Revision 1.114  2003/10/22 20:40:00  peter
 | |
|     * write derefdata in a separate ppu entry
 | |
| 
 | |
|   Revision 1.113  2003/10/17 14:38:32  peter
 | |
|     * 64k registers supported
 | |
|     * fixed some memory leaks
 | |
| 
 | |
|   Revision 1.112  2003/10/10 17:48:13  peter
 | |
|     * old trgobj moved to x86/rgcpu and renamed to trgx86fpu
 | |
|     * tregisteralloctor renamed to trgobj
 | |
|     * removed rgobj from a lot of units
 | |
|     * moved location_* and reference_* to cgobj
 | |
|     * first things for mmx register allocation
 | |
| 
 | |
|   Revision 1.111  2003/10/09 21:31:37  daniel
 | |
|     * Register allocator splitted, ans abstract now
 | |
| 
 | |
|   Revision 1.110  2003/10/08 19:19:45  peter
 | |
|     * set_varstate cleanup
 | |
| 
 | |
|   Revision 1.109  2003/10/05 21:21:52  peter
 | |
|     * c style array of const generates callparanodes
 | |
|     * varargs paraloc fixes
 | |
| 
 | |
|   Revision 1.108  2003/10/01 20:34:48  peter
 | |
|     * procinfo unit contains tprocinfo
 | |
|     * cginfo renamed to cgbase
 | |
|     * moved cgmessage to verbose
 | |
|     * fixed ppc and sparc compiles
 | |
| 
 | |
|   Revision 1.107  2003/09/28 17:55:03  peter
 | |
|     * parent framepointer changed to hidden parameter
 | |
|     * tloadparentfpnode added
 | |
| 
 | |
|   Revision 1.106  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.105  2003/09/16 16:17:01  peter
 | |
|     * varspez in calls to push_addr_param
 | |
| 
 | |
|   Revision 1.104  2003/09/07 22:09:35  peter
 | |
|     * preparations for different default calling conventions
 | |
|     * various RA fixes
 | |
| 
 | |
|   Revision 1.103  2003/07/08 15:20:56  peter
 | |
|     * don't allow add/assignments for formaldef
 | |
|     * formaldef size changed to 0
 | |
| 
 | |
|   Revision 1.102  2003/06/13 21:19:30  peter
 | |
|     * current_procdef removed, use current_procinfo.procdef instead
 | |
| 
 | |
|   Revision 1.101  2003/06/08 20:01:53  jonas
 | |
|     * optimized assignments with on the right side a function that returns
 | |
|       an ansi- or widestring
 | |
| 
 | |
|   Revision 1.100  2003/06/08 18:27:15  jonas
 | |
|     + ability to change the location of a ttempref node with changelocation()
 | |
|       method. Useful to use instead of copying the contents from one temp to
 | |
|       another
 | |
|     + some shortstring optimizations in tassignmentnode that avoid some
 | |
|       copying (required some shortstring optimizations to be moved from
 | |
|       resulttype to firstpass, because they work on callnodes and string
 | |
|       addnodes are only changed to callnodes in the firstpass)
 | |
|     * allow setting/changing the funcretnode of callnodes after the
 | |
|       resulttypepass has been done, funcretnode is now a property
 | |
|     (all of the above should have a quite big effect on callparatemp)
 | |
| 
 | |
|   Revision 1.99  2003/06/07 20:26:32  peter
 | |
|     * re-resolving added instead of reloading from ppu
 | |
|     * tderef object added to store deref info for resolving
 | |
| 
 | |
|   Revision 1.98  2003/06/07 18:57:04  jonas
 | |
|     + added freeintparaloc
 | |
|     * ppc get/freeintparaloc now check whether the parameter regs are
 | |
|       properly allocated/deallocated (and get an extra list para)
 | |
|     * ppc a_call_* now internalerrors if pi_do_call is not yet set
 | |
|     * fixed lot of missing pi_do_call's
 | |
| 
 | |
|   Revision 1.97  2003/06/07 14:39:18  jonas
 | |
|     * set pi_do_call for accesses to threadvars
 | |
| 
 | |
|   Revision 1.96  2003/05/26 19:38:28  peter
 | |
|     * generic fpc_shorstr_concat
 | |
|     + fpc_shortstr_append_shortstr optimization
 | |
| 
 | |
|   Revision 1.95  2003/05/23 17:05:13  peter
 | |
|     * loadn procsym need to return procdef
 | |
| 
 | |
|   Revision 1.94  2003/05/23 14:27:35  peter
 | |
|     * remove some unit dependencies
 | |
|     * current_procinfo changes to store more info
 | |
| 
 | |
|   Revision 1.93  2003/05/11 21:37:03  peter
 | |
|     * moved implicit exception frame from ncgutil to psub
 | |
|     * constructor/destructor helpers moved from cobj/ncgutil to psub
 | |
| 
 | |
|   Revision 1.92  2003/05/11 14:45:12  peter
 | |
|     * tloadnode does not support objectsymtable,withsymtable anymore
 | |
|     * withnode cleanup
 | |
|     * direct with rewritten to use temprefnode
 | |
| 
 | |
|   Revision 1.91  2003/05/09 17:47:02  peter
 | |
|     * self moved to hidden parameter
 | |
|     * removed hdisposen,hnewn,selfn
 | |
| 
 | |
|   Revision 1.90  2003/04/27 11:21:33  peter
 | |
|     * aktprocdef renamed to current_procinfo.procdef
 | |
|     * procinfo renamed to current_procinfo
 | |
|     * procinfo will now be stored in current_module so it can be
 | |
|       cleaned up properly
 | |
|     * gen_main_procsym changed to create_main_proc and release_main_proc
 | |
|       to also generate a tprocinfo structure
 | |
|     * fixed unit implicit initfinal
 | |
| 
 | |
|   Revision 1.89  2003/04/27 07:29:50  peter
 | |
|     * current_procinfo.procdef cleanup, current_procdef is now always nil when parsing
 | |
|       a new procdef declaration
 | |
|     * aktprocsym removed
 | |
|     * lexlevel removed, use symtable.symtablelevel instead
 | |
|     * implicit init/final code uses the normal genentry/genexit
 | |
|     * funcret state checking updated for new funcret handling
 | |
| 
 | |
|   Revision 1.88  2003/04/26 00:28:42  peter
 | |
|     * removed load_funcret
 | |
| 
 | |
|   Revision 1.87  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.86  2003/04/23 20:16:04  peter
 | |
|     + added currency support based on int64
 | |
|     + is_64bit for use in cg units instead of is_64bitint
 | |
|     * removed cgmessage from n386add, replace with internalerrors
 | |
| 
 | |
|   Revision 1.85  2003/04/23 10:10:54  peter
 | |
|     * procvar is not compared in addrn
 | |
| 
 | |
|   Revision 1.84  2003/04/22 23:50:23  peter
 | |
|     * firstpass uses expectloc
 | |
|     * checks if there are differences between the expectloc and
 | |
|       location.loc from secondpass in EXTDEBUG
 | |
| 
 | |
|   Revision 1.83  2003/04/11 15:01:23  peter
 | |
|     * fix bug 2438
 | |
| 
 | |
|   Revision 1.82  2003/03/28 19:16:56  peter
 | |
|     * generic constructor working for i386
 | |
|     * remove fixed self register
 | |
|     * esi added as address register for i386
 | |
| 
 | |
|   Revision 1.81  2003/03/11 21:46:24  jonas
 | |
|     * lots of new regallocator fixes, both in generic and ppc-specific code
 | |
|       (ppc compiler still can't compile the linux system unit though)
 | |
| 
 | |
|   Revision 1.80  2003/01/07 16:52:58  jonas
 | |
|     * fixed ansistring+char and ansistring+shortstring optimizations (those
 | |
|       cases were always handled as ansistring+ansistring due to
 | |
|       typeconversions inserted by the add-node)
 | |
| 
 | |
|   Revision 1.79  2003/01/05 22:44:14  peter
 | |
|     * remove a lot of code to support typen in loadn-procsym
 | |
| 
 | |
|   Revision 1.78  2003/01/03 12:15:56  daniel
 | |
|     * Removed ifdefs around notifications
 | |
|       ifdefs around for loop optimizations remain
 | |
| 
 | |
|   Revision 1.77  2002/12/31 09:55:58  daniel
 | |
|    + Notification implementation complete
 | |
|    + Add for loop code optimization using notifications
 | |
|      results in 1.5-1.9% speed improvement in nestloop benchmark
 | |
|      Optimization incomplete, compiler does not cycle yet with
 | |
|      notifications enabled.
 | |
| 
 | |
|   Revision 1.76  2002/12/30 22:44:53  daniel
 | |
|   * Some work on notifications
 | |
| 
 | |
|   Revision 1.75  2002/12/27 15:27:25  peter
 | |
|     * remove property indicator when calling internal helpers
 | |
| 
 | |
|   Revision 1.74  2002/12/24 16:53:19  peter
 | |
|     * fix for tb0438
 | |
| 
 | |
|   Revision 1.73  2002/12/20 18:14:53  peter
 | |
|     * fix result of high_tree when high was not available
 | |
| 
 | |
|   Revision 1.72  2002/12/17 22:19:33  peter
 | |
|     * fixed pushing of records>8 bytes with stdcall
 | |
|     * simplified hightree loading
 | |
| 
 | |
|   Revision 1.71  2002/12/07 14:27:07  carl
 | |
|     * 3% memory optimization
 | |
|     * changed some types
 | |
|     + added type checking with different size for call node and for
 | |
|        parameters
 | |
| 
 | |
|   Revision 1.70  2002/12/02 19:38:06  carl
 | |
|     * fix some errors
 | |
| 
 | |
|   Revision 1.69  2002/11/29 20:02:44  carl
 | |
|    * warning / hint for possible loss of data in assignment
 | |
| 
 | |
|   Revision 1.68  2002/11/27 20:04:39  peter
 | |
|     * cdecl array of const fixes
 | |
| 
 | |
|   Revision 1.67  2002/11/27 15:33:47  peter
 | |
|     * the never ending story of tp procvar hacks
 | |
| 
 | |
|   Revision 1.66  2002/11/25 17:43:20  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.65  2002/11/18 17:31:57  peter
 | |
|     * pass proccalloption to ret_in_xxx and push_xxx functions
 | |
| 
 | |
|   Revision 1.64  2002/11/15 01:58:52  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.63  2002/10/17 12:44:09  florian
 | |
|     + s:=s+<string type> where s is an ansistring is done via calls to append_ansistring_*
 | |
| 
 | |
|   Revision 1.62  2002/10/05 12:43:25  carl
 | |
|     * fixes for Delphi 6 compilation
 | |
|      (warning : Some features do not work under Delphi)
 | |
| 
 | |
|   Revision 1.61  2002/10/03 21:26:08  carl
 | |
|     + compile-time range checking for strings
 | |
| 
 | |
|   Revision 1.60  2002/09/27 21:13:28  carl
 | |
|     * low-highval always checked if limit ober 2GB is reached (to avoid overflow)
 | |
| 
 | |
|   Revision 1.59  2002/09/26 15:02:05  florian
 | |
|     + support of passing variants to "array of const"
 | |
| 
 | |
|   Revision 1.58  2002/09/07 15:25:03  peter
 | |
|     * old logs removed and tabs fixed
 | |
| 
 | |
|   Revision 1.57  2002/09/03 16:26:26  daniel
 | |
|     * Make Tprocdef.defs protected
 | |
| 
 | |
|   Revision 1.56  2002/09/01 13:28:37  daniel
 | |
|    - write_access fields removed in favor of a flag
 | |
| 
 | |
|   Revision 1.55  2002/09/01 08:01:16  daniel
 | |
|    * Removed sets from Tcallnode.det_resulttype
 | |
|    + Added read/write notifications of variables. These will be usefull
 | |
|      for providing information for several optimizations. For example
 | |
|      the value of the loop variable of a for loop does matter is the
 | |
|      variable is read after the for loop, but if it's no longer used
 | |
|      or written, it doesn't matter and this can be used to optimize
 | |
|      the loop code generation.
 | |
| 
 | |
|   Revision 1.54  2002/08/25 19:25:19  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.53  2002/08/19 19:36:43  peter
 | |
|     * More fixes for cross unit inlining, all tnodes are now implemented
 | |
|     * Moved pocall_internconst to po_internconst because it is not a
 | |
|       calling type at all and it conflicted when inlining of these small
 | |
|       functions was requested
 | |
| 
 | |
|   Revision 1.52  2002/08/18 20:06:23  peter
 | |
|     * inlining is now also allowed in interface
 | |
|     * renamed write/load to ppuwrite/ppuload
 | |
|     * tnode storing in ppu
 | |
|     * nld,ncon,nbas are already updated for storing in ppu
 | |
| 
 | |
|   Revision 1.51  2002/08/17 22:09:46  florian
 | |
|     * result type handling in tcgcal.pass_2 overhauled
 | |
|     * better tnode.dowrite
 | |
|     * some ppc stuff fixed
 | |
| 
 | |
|   Revision 1.50  2002/08/17 09:23:37  florian
 | |
|     * first part of procinfo rewrite
 | |
| 
 | |
|   Revision 1.49  2002/07/20 11:57:54  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.48  2002/07/20 07:44:37  daniel
 | |
|   * Forgot to add a $ifdef extdebug
 | |
| 
 | |
|   Revision 1.47  2002/07/19 12:55:27  daniel
 | |
|   * Further developed state tracking in whilerepeatn
 | |
| 
 | |
|   Revision 1.46  2002/07/19 11:41:36  daniel
 | |
|   * State tracker work
 | |
|   * The whilen and repeatn are now completely unified into whilerepeatn. This
 | |
|     allows the state tracker to change while nodes automatically into
 | |
|     repeat nodes.
 | |
|   * Resulttypepass improvements to the notn. 'not not a' is optimized away and
 | |
|     'not(a>b)' is optimized into 'a<=b'.
 | |
|   * Resulttypepass improvements to the whilerepeatn. 'while not a' is optimized
 | |
|     by removing the notn and later switchting the true and falselabels. The
 | |
|     same is done with 'repeat until not a'.
 | |
| 
 | |
|   Revision 1.45  2002/07/15 18:03:15  florian
 | |
|     * readded removed changes
 | |
| 
 | |
|   Revision 1.43  2002/07/11 14:41:28  florian
 | |
|     * start of the new generic parameter handling
 | |
| 
 | |
|   Revision 1.44  2002/07/14 18:00:44  daniel
 | |
|   + Added the beginning of a state tracker. This will track the values of
 | |
|     variables through procedures and optimize things away.
 | |
| 
 | |
|   Revision 1.42  2002/05/18 13:34:10  peter
 | |
|     * readded missing revisions
 | |
| 
 | |
|   Revision 1.41  2002/05/16 19:46:38  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.39  2002/05/12 16:53:07  peter
 | |
|     * moved entry and exitcode to ncgutil and cgobj
 | |
|     * foreach gets extra argument for passing local data to the
 | |
|       iterator function
 | |
|     * -CR checks also class typecasts at runtime by changing them
 | |
|       into as
 | |
|     * fixed compiler to cycle with the -CR option
 | |
|     * fixed stabs with elf writer, finally the global variables can
 | |
|       be watched
 | |
|     * removed a lot of routines from cga unit and replaced them by
 | |
|       calls to cgobj
 | |
|     * u32bit-s32bit updates for and,or,xor nodes. When one element is
 | |
|       u32bit then the other is typecasted also to u32bit without giving
 | |
|       a rangecheck warning/error.
 | |
|     * fixed pascal calling method with reversing also the high tree in
 | |
|       the parast, detected by tcalcst3 test
 | |
| 
 | |
|   Revision 1.38  2002/04/25 20:16:39  peter
 | |
|     * moved more routines from cga/n386util
 | |
| 
 | |
|   Revision 1.37  2002/04/23 19:16:34  peter
 | |
|     * add pinline unit that inserts compiler supported functions using
 | |
|       one or more statements
 | |
|     * moved finalize and setlength from ninl to pinline
 | |
| 
 | |
| }
 | 
