From d4194bce5392208dbcefa3096944993488df12f7 Mon Sep 17 00:00:00 2001 From: florian Date: Tue, 17 May 2005 21:17:35 +0000 Subject: [PATCH] * array of const for currency, classes and interfaces fixed git-svn-id: trunk@11 - --- compiler/ncgld.pas | 1916 +++++++++++++++++----------------- compiler/nld.pas | 2451 ++++++++++++++++++++++---------------------- 2 files changed, 2189 insertions(+), 2178 deletions(-) diff --git a/compiler/ncgld.pas b/compiler/ncgld.pas index f9665eec43..bbfcc42f29 100644 --- a/compiler/ncgld.pas +++ b/compiler/ncgld.pas @@ -1,953 +1,963 @@ -{ - $Id: ncgld.pas,v 1.140 2005/04/08 15:18:08 peter Exp $ - Copyright (c) 1998-2002 by Florian Klaempfl - - Generate assembler for nodes that handle loads and assignments which - are the same for all (most) processors - - 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 ncgld; - -{$i fpcdefs.inc} - -interface - - uses - node,nld; - - type - tcgloadnode = class(tloadnode) - procedure pass_2;override; - procedure generate_picvaraccess;virtual; - end; - - tcgassignmentnode = class(tassignmentnode) - procedure pass_2;override; - end; - - tcgarrayconstructornode = class(tarrayconstructornode) - procedure pass_2;override; - end; - - tcgrttinode = class(trttinode) - procedure pass_2;override; - end; - - -implementation - - uses - cutils, - systems, - verbose,globtype,globals, - symconst,symtype,symdef,symsym,defutil,paramgr, - ncnv,ncon,nmem,nbas, - aasmbase,aasmtai,aasmcpu, - cgbase,pass_2, - procinfo, - cpubase,parabase, - tgobj,ncgutil, - cgutils,cgobj, - ncgbas; - -{***************************************************************************** - SecondLoad -*****************************************************************************} - - procedure tcgloadnode.generate_picvaraccess; - begin -{$ifndef sparc} - location.reference.base:=current_procinfo.got; - location.reference.symbol:=objectlibrary.newasmsymbol(tglobalvarsym(symtableentry).mangledname+'@GOT',AB_EXTERNAL,AT_DATA); -{$endif sparc} - end; - - - procedure tcgloadnode.pass_2; - var - hregister : tregister; - symtabletype : tsymtabletype; - href : treference; - newsize : tcgsize; - endrelocatelab, - norelocatelab : tasmlabel; - paraloc1 : tcgpara; - begin - { we don't know the size of all arrays } - newsize:=def_cgsize(resulttype.def); - location_reset(location,LOC_REFERENCE,newsize); - case symtableentry.typ of - absolutevarsym : - begin - { this is only for toasm and toaddr } - case tabsolutevarsym(symtableentry).abstyp of - toaddr : - begin -{$ifdef i386} - if tabsolutevarsym(symtableentry).absseg then - location.reference.segment:=NR_FS; -{$endif i386} - location.reference.offset:=tabsolutevarsym(symtableentry).addroffset; - end; - toasm : - location.reference.symbol:=objectlibrary.newasmsymbol(tabsolutevarsym(symtableentry).mangledname,AB_EXTERNAL,AT_DATA); - else - internalerror(200310283); - end; - end; - constsym: - begin - if tconstsym(symtableentry).consttyp=constresourcestring then - begin - location_reset(location,LOC_CREFERENCE,OS_ADDR); - location.reference.symbol:=objectlibrary.newasmsymbol(make_mangledname('RESOURCESTRINGLIST',tconstsym(symtableentry).owner,''),AB_EXTERNAL,AT_DATA); - location.reference.offset:=tconstsym(symtableentry).resstrindex*(4+sizeof(aint)*3)+4+sizeof(aint); - end - else - internalerror(22798); - end; - globalvarsym, - localvarsym, - paravarsym : - begin - symtabletype:=symtable.symtabletype; - hregister:=NR_NO; - { DLL variable } - if (vo_is_dll_var in tabstractvarsym(symtableentry).varoptions) then - begin - if target_info.system=system_powerpc_darwin then - begin - generate_picvaraccess; - if not(pi_needs_got in current_procinfo.flags) then - internalerror(200403022); - end - else - begin - hregister:=cg.getaddressregister(exprasmlist); - location.reference.symbol:=objectlibrary.newasmsymbol(tglobalvarsym(symtableentry).mangledname,AB_EXTERNAL,AT_DATA); - cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,location.reference,hregister); - reference_reset_base(location.reference,hregister,0); - end; - end - { Thread variable } - else if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then - begin - { - Thread var loading is optimized to first check if - a relocate function is available. When the function - is available it is called to retrieve the address. - Otherwise the address is loaded with the symbol - - The code needs to be in the order to first handle the - call and then the address load to be sure that the - register that is used for returning is the same (PFV) - } - objectlibrary.getlabel(norelocatelab); - objectlibrary.getlabel(endrelocatelab); - { make sure hregister can't allocate the register necessary for the parameter } - paraloc1.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); - hregister:=cg.getaddressregister(exprasmlist); - reference_reset_symbol(href,objectlibrary.newasmsymbol('FPC_THREADVAR_RELOCATE',AB_EXTERNAL,AT_DATA),0); - cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,hregister); - cg.a_cmp_const_reg_label(exprasmlist,OS_ADDR,OC_EQ,0,hregister,norelocatelab); - { don't save the allocated register else the result will be destroyed later } - reference_reset_symbol(href,objectlibrary.newasmsymbol(tglobalvarsym(symtableentry).mangledname,AB_EXTERNAL,AT_DATA),0); - paramanager.allocparaloc(exprasmlist,paraloc1); - cg.a_param_ref(exprasmlist,OS_ADDR,href,paraloc1); - paramanager.freeparaloc(exprasmlist,paraloc1); - paraloc1.done; - cg.alloccpuregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default)); - cg.a_call_reg(exprasmlist,hregister); - cg.dealloccpuregisters(exprasmlist,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default)); - cg.getcpuregister(exprasmlist,NR_FUNCTION_RESULT_REG); - cg.ungetcpuregister(exprasmlist,NR_FUNCTION_RESULT_REG); - hregister:=cg.getaddressregister(exprasmlist); - cg.a_load_reg_reg(exprasmlist,OS_INT,OS_ADDR,NR_FUNCTION_RESULT_REG,hregister); - cg.a_jmp_always(exprasmlist,endrelocatelab); - cg.a_label(exprasmlist,norelocatelab); - { no relocation needed, load the address of the variable only, the - layout of a threadvar is (4 bytes pointer): - 0 - Threadvar index - 4 - Threadvar value in single threading } - reference_reset_symbol(href,objectlibrary.newasmsymbol(tglobalvarsym(symtableentry).mangledname,AB_EXTERNAL,AT_DATA),sizeof(aint)); - cg.a_loadaddr_ref_reg(exprasmlist,href,hregister); - cg.a_label(exprasmlist,endrelocatelab); - location.reference.base:=hregister; - end - { Nested variable } - else if assigned(left) then - begin - if not(symtabletype in [localsymtable,parasymtable]) then - internalerror(200309285); - secondpass(left); - if left.location.loc<>LOC_REGISTER then - internalerror(200309286); - if tabstractnormalvarsym(symtableentry).localloc.loc<>LOC_REFERENCE then - internalerror(200409241); - hregister:=left.location.register; - reference_reset_base(location.reference,hregister,tabstractnormalvarsym(symtableentry).localloc.reference.offset); - end - { Normal (or external) variable } - else - begin -{$ifdef OLDREGVARS} - { in case it is a register variable: } - if tvarsym(symtableentry).localloc.loc in [LOC_REGISTER,LOC_FPUREGISTER] then - begin - case getregtype(tvarsym(symtableentry).localloc.register) of - R_FPUREGISTER : - begin - location_reset(location,LOC_CFPUREGISTER,def_cgsize(resulttype.def)); - location.register:=tvarsym(symtableentry).localloc.register; - end; - R_INTREGISTER : - begin - location_reset(location,LOC_CREGISTER,def_cgsize(resulttype.def)); - location.register:=tvarsym(symtableentry).localloc.register; - hregister := location.register; - end; - else - internalerror(200301172); - end; - end - else -{$endif OLDREGVARS} - begin - case symtabletype of - stt_exceptsymtable, - localsymtable, - parasymtable : - location:=tabstractnormalvarsym(symtableentry).localloc; - globalsymtable, - staticsymtable : - begin - if (target_info.system=system_powerpc_darwin) and - (cs_create_pic in aktmoduleswitches) then - begin - generate_picvaraccess; - if not(pi_needs_got in current_procinfo.flags) then - internalerror(200403023); - end - else - begin - if tabstractnormalvarsym(symtableentry).localloc.loc=LOC_INVALID then - reference_reset_symbol(location.reference,objectlibrary.newasmsymbol(tglobalvarsym(symtableentry).mangledname,AB_EXTERNAL,AT_DATA),0) - else - location:=tglobalvarsym(symtableentry).localloc; - end; - end; - else - internalerror(200305102); - end; - end; - end; - - { handle call by reference variables when they are not - alreayd copied to local copies. Also ignore the reference - when we need to load the self pointer for objects } - if is_addr_param_load then - begin - if (location.loc in [LOC_CREGISTER,LOC_REGISTER]) then - hregister:=location.register - else - begin - hregister:=cg.getaddressregister(exprasmlist); - { we need to load only an address } - location.size:=OS_ADDR; - cg.a_load_loc_reg(exprasmlist,location.size,location,hregister); - end; - location_reset(location,LOC_REFERENCE,newsize); - location.reference.base:=hregister; - end; - - { make const a LOC_CREFERENCE } - if (tabstractvarsym(symtableentry).varspez=vs_const) and - (location.loc=LOC_REFERENCE) then - location.loc:=LOC_CREFERENCE; - end; - procsym: - begin - if not assigned(procdef) then - internalerror(200312011); - if assigned(left) then - begin - { - THIS IS A TERRIBLE HACK!!!!!! WHICH WILL NOT WORK - ON 64-BIT SYSTEMS: SINCE PROCSYM FOR METHODS - CONSISTS OF TWO OS_ADDR, so you cannot set it - to OS_64 - how to solve?? Carl - Solved. Florian - } - if (sizeof(aint) = 4) then - location_reset(location,LOC_CREFERENCE,OS_64) - else if (sizeof(aint) = 8) then - location_reset(location,LOC_CREFERENCE,OS_128) - else - internalerror(20020520); - tg.GetTemp(exprasmlist,2*sizeof(aint),tt_normal,location.reference); - secondpass(left); - - { load class instance address } - case left.location.loc of - LOC_CREGISTER, - LOC_REGISTER: - begin - { this is not possible for objects } - if is_object(left.resulttype.def) then - internalerror(200304234); - hregister:=left.location.register; - end; - LOC_CREFERENCE, - LOC_REFERENCE: - begin - hregister:=cg.getaddressregister(exprasmlist); - if is_class_or_interface(left.resulttype.def) then - cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.reference,hregister) - else - cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,hregister); - location_freetemp(exprasmlist,left.location); - end; - else - internalerror(26019); - end; - - { store the class instance address } - href:=location.reference; - inc(href.offset,sizeof(aint)); - cg.a_load_reg_ref(exprasmlist,OS_ADDR,OS_ADDR,hregister,href); - - { virtual method ? } - if (po_virtualmethod in procdef.procoptions) then - begin - { load vmt pointer } - reference_reset_base(href,hregister,0); - hregister:=cg.getaddressregister(exprasmlist); - cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,hregister); - { load method address } - reference_reset_base(href,hregister,procdef._class.vmtmethodoffset(procdef.extnumber)); - hregister:=cg.getaddressregister(exprasmlist); - cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,hregister); - { ... and store it } - cg.a_load_reg_ref(exprasmlist,OS_ADDR,OS_ADDR,hregister,location.reference); - end - else - begin - { load address of the function } - reference_reset_symbol(href,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION),0); - hregister:=cg.getaddressregister(exprasmlist); - cg.a_loadaddr_ref_reg(exprasmlist,href,hregister); - cg.a_load_reg_ref(exprasmlist,OS_ADDR,OS_ADDR,hregister,location.reference); - end; - end - else - begin - {!!!!! Be aware, work on virtual methods too } - location.reference.symbol:=objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION); - end; - end; - typedconstsym : - begin - location.reference.symbol:=objectlibrary.newasmsymbol(ttypedconstsym(symtableentry).mangledname,AB_EXTERNAL,AT_DATA); - end; - labelsym : - begin - location.reference.symbol:=objectlibrary.newasmsymbol(tlabelsym(symtableentry).mangledname,AB_EXTERNAL,AT_FUNCTION); - end; - else internalerror(4); - end; - end; - - -{***************************************************************************** - SecondAssignment -*****************************************************************************} - - procedure tcgassignmentnode.pass_2; - var - otlabel,hlabel,oflabel : tasmlabel; - fputyp : tfloattype; - href : treference; - releaseright : boolean; - len : aint; - r:Tregister; - - begin - location_reset(location,LOC_VOID,OS_NO); - - otlabel:=truelabel; - oflabel:=falselabel; - objectlibrary.getlabel(truelabel); - objectlibrary.getlabel(falselabel); - - { - in most cases we can process first the right node which contains - the most complex code. Exceptions for this are: - - result is in flags, loading left will then destroy the flags - - result is a jump, loading left must be already done before the jump is made - - result need reference count, when left points to a value used in - right then decreasing the refcnt on left can possibly release - the memory before right increased the refcnt, result is that an - empty value is assigned - - calln, call destroys most registers and is therefor 'complex' - - But not when the result is in the flags, then - loading the left node afterwards can destroy the flags. - } - if not(right.expectloc in [LOC_FLAGS,LOC_JUMP]) and - ((right.nodetype=calln) or - (right.resulttype.def.needs_inittable) or - (right.registersint>=left.registersint)) then - begin - secondpass(right); - { increment source reference counter, this is - useless for string constants} - if (right.resulttype.def.needs_inittable) and - (right.nodetype<>stringconstn) then - begin - location_force_mem(exprasmlist,right.location); - location_get_data_ref(exprasmlist,right.location,href,false); - cg.g_incrrefcount(exprasmlist,right.resulttype.def,href); - end; - if codegenerror then - exit; - - if not(nf_concat_string in flags) then - begin - { left can't be never a 64 bit LOC_REGISTER, so the 3. arg } - { can be false } - secondpass(left); - { decrement destination reference counter } - if (left.resulttype.def.needs_inittable) then - begin - location_get_data_ref(exprasmlist,left.location,href,false); - cg.g_decrrefcount(exprasmlist,left.resulttype.def,href); - end; - if codegenerror then - exit; - end; - end - else - begin - { calculate left sides } - { don't do it yet if it's a crgister (JM) } - if not(nf_concat_string in flags) then - begin - secondpass(left); - { decrement destination reference counter } - if (left.resulttype.def.needs_inittable) then - begin - location_get_data_ref(exprasmlist,left.location,href,false); - cg.g_decrrefcount(exprasmlist,left.resulttype.def,href); - end; - if codegenerror then - exit; - end; - - { left can't be never a 64 bit LOC_REGISTER, so the 3. arg } - { can be false } - secondpass(right); - { increment source reference counter, this is - useless for string constants} - if (right.resulttype.def.needs_inittable) and - (right.nodetype<>stringconstn) then - begin - location_force_mem(exprasmlist,right.location); - location_get_data_ref(exprasmlist,right.location,href,false); - cg.g_incrrefcount(exprasmlist,right.resulttype.def,href); - end; - - if codegenerror then - exit; - end; - - releaseright:=true; - - { optimize temp to temp copies } -(* if (left.nodetype = temprefn) and - { we may store certain temps in registers in the future, then this } - { optimization will have to be adapted } - (left.location.loc = LOC_REFERENCE) and - (right.location.loc = LOC_REFERENCE) and - tg.istemp(right.location.reference) and - (tg.sizeoftemp(exprasmlist,right.location.reference) = tg.sizeoftemp(exprasmlist,left.location.reference)) then - begin - { in theory, we should also make sure the left temp type is } - { already more or less of the same kind (ie. we must not } - { assign an ansistring to a normaltemp). In practice, the } - { assignment node will have already taken care of this for us } - tcgtemprefnode(left).changelocation(right.location.reference); - end - { shortstring assignments are handled separately } - else *) - if is_shortstring(left.resulttype.def) then - begin - { - we can get here only in the following situations - for the right node: - - empty constant string - - char - } - - { empty constant string } - if (right.nodetype=stringconstn) and - (tstringconstnode(right).len=0) then - begin - cg.a_load_const_ref(exprasmlist,OS_8,0,left.location.reference); - end - { char loading } - else if is_char(right.resulttype.def) then - begin - if right.nodetype=ordconstn then - begin - if (target_info.endian = endian_little) then - cg.a_load_const_ref(exprasmlist,OS_16,(tordconstnode(right).value shl 8) or 1, - left.location.reference) - else - cg.a_load_const_ref(exprasmlist,OS_16,tordconstnode(right).value or (1 shl 8), - left.location.reference); - end - else - begin - href:=left.location.reference; - cg.a_load_const_ref(exprasmlist,OS_8,1,href); - inc(href.offset,1); - case right.location.loc of - LOC_REGISTER, - LOC_CREGISTER : - begin - r:=cg.makeregsize(exprasmlist,right.location.register,OS_8); - cg.a_load_reg_ref(exprasmlist,OS_8,OS_8,r,href); - end; - LOC_REFERENCE, - LOC_CREFERENCE : - cg.a_load_ref_ref(exprasmlist,OS_8,OS_8,right.location.reference,href); - else - internalerror(200205111); - end; - end; - end - else - internalerror(200204249); - end - else - begin - case right.location.loc of - LOC_CONSTANT : - begin -{$ifndef cpu64bit} - if right.location.size in [OS_64,OS_S64] then - cg64.a_load64_const_loc(exprasmlist,right.location.value64,left.location) - else -{$endif cpu64bit} - cg.a_load_const_loc(exprasmlist,right.location.value,left.location); - end; - LOC_REFERENCE, - LOC_CREFERENCE : - begin - case left.location.loc of - LOC_REGISTER, - LOC_CREGISTER : - begin -{$ifndef cpu64bit} - if left.location.size in [OS_64,OS_S64] then - cg64.a_load64_ref_reg(exprasmlist,right.location.reference,left.location.register64) - else -{$endif cpu64bit} - cg.a_load_ref_reg(exprasmlist,right.location.size,left.location.size,right.location.reference,left.location.register); - end; - LOC_FPUREGISTER, - LOC_CFPUREGISTER : - begin - cg.a_loadfpu_ref_reg(exprasmlist, - right.location.size, - right.location.reference, - left.location.register); - end; - LOC_REFERENCE, - LOC_CREFERENCE : - begin -{$warning HACK: unaligned test, maybe remove all unaligned locations (array of char) from the compiler} - { Use unaligned copy when the offset is not aligned } - len:=left.resulttype.def.size; - if (right.location.reference.offset mod sizeof(aint)<>0) or - (left.location.reference.offset mod sizeof(aint)<>0) or - (right.resulttype.def.alignmentLOC_REGISTER then + internalerror(200309286); + if tabstractnormalvarsym(symtableentry).localloc.loc<>LOC_REFERENCE then + internalerror(200409241); + hregister:=left.location.register; + reference_reset_base(location.reference,hregister,tabstractnormalvarsym(symtableentry).localloc.reference.offset); + end + { Normal (or external) variable } + else + begin +{$ifdef OLDREGVARS} + { in case it is a register variable: } + if tvarsym(symtableentry).localloc.loc in [LOC_REGISTER,LOC_FPUREGISTER] then + begin + case getregtype(tvarsym(symtableentry).localloc.register) of + R_FPUREGISTER : + begin + location_reset(location,LOC_CFPUREGISTER,def_cgsize(resulttype.def)); + location.register:=tvarsym(symtableentry).localloc.register; + end; + R_INTREGISTER : + begin + location_reset(location,LOC_CREGISTER,def_cgsize(resulttype.def)); + location.register:=tvarsym(symtableentry).localloc.register; + hregister := location.register; + end; + else + internalerror(200301172); + end; + end + else +{$endif OLDREGVARS} + begin + case symtabletype of + stt_exceptsymtable, + localsymtable, + parasymtable : + location:=tabstractnormalvarsym(symtableentry).localloc; + globalsymtable, + staticsymtable : + begin + if (target_info.system=system_powerpc_darwin) and + (cs_create_pic in aktmoduleswitches) then + begin + generate_picvaraccess; + if not(pi_needs_got in current_procinfo.flags) then + internalerror(200403023); + end + else + begin + if tabstractnormalvarsym(symtableentry).localloc.loc=LOC_INVALID then + reference_reset_symbol(location.reference,objectlibrary.newasmsymbol(tglobalvarsym(symtableentry).mangledname,AB_EXTERNAL,AT_DATA),0) + else + location:=tglobalvarsym(symtableentry).localloc; + end; + end; + else + internalerror(200305102); + end; + end; + end; + + { handle call by reference variables when they are not + alreayd copied to local copies. Also ignore the reference + when we need to load the self pointer for objects } + if is_addr_param_load then + begin + if (location.loc in [LOC_CREGISTER,LOC_REGISTER]) then + hregister:=location.register + else + begin + hregister:=cg.getaddressregister(exprasmlist); + { we need to load only an address } + location.size:=OS_ADDR; + cg.a_load_loc_reg(exprasmlist,location.size,location,hregister); + end; + location_reset(location,LOC_REFERENCE,newsize); + location.reference.base:=hregister; + end; + + { make const a LOC_CREFERENCE } + if (tabstractvarsym(symtableentry).varspez=vs_const) and + (location.loc=LOC_REFERENCE) then + location.loc:=LOC_CREFERENCE; + end; + procsym: + begin + if not assigned(procdef) then + internalerror(200312011); + if assigned(left) then + begin + { + THIS IS A TERRIBLE HACK!!!!!! WHICH WILL NOT WORK + ON 64-BIT SYSTEMS: SINCE PROCSYM FOR METHODS + CONSISTS OF TWO OS_ADDR, so you cannot set it + to OS_64 - how to solve?? Carl + Solved. Florian + } + if (sizeof(aint) = 4) then + location_reset(location,LOC_CREFERENCE,OS_64) + else if (sizeof(aint) = 8) then + location_reset(location,LOC_CREFERENCE,OS_128) + else + internalerror(20020520); + tg.GetTemp(exprasmlist,2*sizeof(aint),tt_normal,location.reference); + secondpass(left); + + { load class instance address } + case left.location.loc of + LOC_CREGISTER, + LOC_REGISTER: + begin + { this is not possible for objects } + if is_object(left.resulttype.def) then + internalerror(200304234); + hregister:=left.location.register; + end; + LOC_CREFERENCE, + LOC_REFERENCE: + begin + hregister:=cg.getaddressregister(exprasmlist); + if is_class_or_interface(left.resulttype.def) then + cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.reference,hregister) + else + cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,hregister); + location_freetemp(exprasmlist,left.location); + end; + else + internalerror(26019); + end; + + { store the class instance address } + href:=location.reference; + inc(href.offset,sizeof(aint)); + cg.a_load_reg_ref(exprasmlist,OS_ADDR,OS_ADDR,hregister,href); + + { virtual method ? } + if (po_virtualmethod in procdef.procoptions) then + begin + { load vmt pointer } + reference_reset_base(href,hregister,0); + hregister:=cg.getaddressregister(exprasmlist); + cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,hregister); + { load method address } + reference_reset_base(href,hregister,procdef._class.vmtmethodoffset(procdef.extnumber)); + hregister:=cg.getaddressregister(exprasmlist); + cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,hregister); + { ... and store it } + cg.a_load_reg_ref(exprasmlist,OS_ADDR,OS_ADDR,hregister,location.reference); + end + else + begin + { load address of the function } + reference_reset_symbol(href,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION),0); + hregister:=cg.getaddressregister(exprasmlist); + cg.a_loadaddr_ref_reg(exprasmlist,href,hregister); + cg.a_load_reg_ref(exprasmlist,OS_ADDR,OS_ADDR,hregister,location.reference); + end; + end + else + begin + {!!!!! Be aware, work on virtual methods too } + location.reference.symbol:=objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION); + end; + end; + typedconstsym : + begin + location.reference.symbol:=objectlibrary.newasmsymbol(ttypedconstsym(symtableentry).mangledname,AB_EXTERNAL,AT_DATA); + end; + labelsym : + begin + location.reference.symbol:=objectlibrary.newasmsymbol(tlabelsym(symtableentry).mangledname,AB_EXTERNAL,AT_FUNCTION); + end; + else internalerror(4); + end; + end; + + +{***************************************************************************** + SecondAssignment +*****************************************************************************} + + procedure tcgassignmentnode.pass_2; + var + otlabel,hlabel,oflabel : tasmlabel; + fputyp : tfloattype; + href : treference; + releaseright : boolean; + len : aint; + r:Tregister; + + begin + location_reset(location,LOC_VOID,OS_NO); + + otlabel:=truelabel; + oflabel:=falselabel; + objectlibrary.getlabel(truelabel); + objectlibrary.getlabel(falselabel); + + { + in most cases we can process first the right node which contains + the most complex code. Exceptions for this are: + - result is in flags, loading left will then destroy the flags + - result is a jump, loading left must be already done before the jump is made + - result need reference count, when left points to a value used in + right then decreasing the refcnt on left can possibly release + the memory before right increased the refcnt, result is that an + empty value is assigned + - calln, call destroys most registers and is therefor 'complex' + + But not when the result is in the flags, then + loading the left node afterwards can destroy the flags. + } + if not(right.expectloc in [LOC_FLAGS,LOC_JUMP]) and + ((right.nodetype=calln) or + (right.resulttype.def.needs_inittable) or + (right.registersint>=left.registersint)) then + begin + secondpass(right); + { increment source reference counter, this is + useless for string constants} + if (right.resulttype.def.needs_inittable) and + (right.nodetype<>stringconstn) then + begin + location_force_mem(exprasmlist,right.location); + location_get_data_ref(exprasmlist,right.location,href,false); + cg.g_incrrefcount(exprasmlist,right.resulttype.def,href); + end; + if codegenerror then + exit; + + if not(nf_concat_string in flags) then + begin + { left can't be never a 64 bit LOC_REGISTER, so the 3. arg } + { can be false } + secondpass(left); + { decrement destination reference counter } + if (left.resulttype.def.needs_inittable) then + begin + location_get_data_ref(exprasmlist,left.location,href,false); + cg.g_decrrefcount(exprasmlist,left.resulttype.def,href); + end; + if codegenerror then + exit; + end; + end + else + begin + { calculate left sides } + { don't do it yet if it's a crgister (JM) } + if not(nf_concat_string in flags) then + begin + secondpass(left); + { decrement destination reference counter } + if (left.resulttype.def.needs_inittable) then + begin + location_get_data_ref(exprasmlist,left.location,href,false); + cg.g_decrrefcount(exprasmlist,left.resulttype.def,href); + end; + if codegenerror then + exit; + end; + + { left can't be never a 64 bit LOC_REGISTER, so the 3. arg } + { can be false } + secondpass(right); + { increment source reference counter, this is + useless for string constants} + if (right.resulttype.def.needs_inittable) and + (right.nodetype<>stringconstn) then + begin + location_force_mem(exprasmlist,right.location); + location_get_data_ref(exprasmlist,right.location,href,false); + cg.g_incrrefcount(exprasmlist,right.resulttype.def,href); + end; + + if codegenerror then + exit; + end; + + releaseright:=true; + + { optimize temp to temp copies } +(* if (left.nodetype = temprefn) and + { we may store certain temps in registers in the future, then this } + { optimization will have to be adapted } + (left.location.loc = LOC_REFERENCE) and + (right.location.loc = LOC_REFERENCE) and + tg.istemp(right.location.reference) and + (tg.sizeoftemp(exprasmlist,right.location.reference) = tg.sizeoftemp(exprasmlist,left.location.reference)) then + begin + { in theory, we should also make sure the left temp type is } + { already more or less of the same kind (ie. we must not } + { assign an ansistring to a normaltemp). In practice, the } + { assignment node will have already taken care of this for us } + tcgtemprefnode(left).changelocation(right.location.reference); + end + { shortstring assignments are handled separately } + else *) + if is_shortstring(left.resulttype.def) then + begin + { + we can get here only in the following situations + for the right node: + - empty constant string + - char + } + + { empty constant string } + if (right.nodetype=stringconstn) and + (tstringconstnode(right).len=0) then + begin + cg.a_load_const_ref(exprasmlist,OS_8,0,left.location.reference); + end + { char loading } + else if is_char(right.resulttype.def) then + begin + if right.nodetype=ordconstn then + begin + if (target_info.endian = endian_little) then + cg.a_load_const_ref(exprasmlist,OS_16,(tordconstnode(right).value shl 8) or 1, + left.location.reference) + else + cg.a_load_const_ref(exprasmlist,OS_16,tordconstnode(right).value or (1 shl 8), + left.location.reference); + end + else + begin + href:=left.location.reference; + cg.a_load_const_ref(exprasmlist,OS_8,1,href); + inc(href.offset,1); + case right.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + begin + r:=cg.makeregsize(exprasmlist,right.location.register,OS_8); + cg.a_load_reg_ref(exprasmlist,OS_8,OS_8,r,href); + end; + LOC_REFERENCE, + LOC_CREFERENCE : + cg.a_load_ref_ref(exprasmlist,OS_8,OS_8,right.location.reference,href); + else + internalerror(200205111); + end; + end; + end + else + internalerror(200204249); + end + else + begin + case right.location.loc of + LOC_CONSTANT : + begin +{$ifndef cpu64bit} + if right.location.size in [OS_64,OS_S64] then + cg64.a_load64_const_loc(exprasmlist,right.location.value64,left.location) + else +{$endif cpu64bit} + cg.a_load_const_loc(exprasmlist,right.location.value,left.location); + end; + LOC_REFERENCE, + LOC_CREFERENCE : + begin + case left.location.loc of + LOC_REGISTER, + LOC_CREGISTER : + begin +{$ifndef cpu64bit} + if left.location.size in [OS_64,OS_S64] then + cg64.a_load64_ref_reg(exprasmlist,right.location.reference,left.location.register64) + else +{$endif cpu64bit} + cg.a_load_ref_reg(exprasmlist,right.location.size,left.location.size,right.location.reference,left.location.register); + end; + LOC_FPUREGISTER, + LOC_CFPUREGISTER : + begin + cg.a_loadfpu_ref_reg(exprasmlist, + right.location.size, + right.location.reference, + left.location.register); + end; + LOC_REFERENCE, + LOC_CREFERENCE : + begin +{$warning HACK: unaligned test, maybe remove all unaligned locations (array of char) from the compiler} + { Use unaligned copy when the offset is not aligned } + len:=left.resulttype.def.size; + if (right.location.reference.offset mod sizeof(aint)<>0) or + (left.location.reference.offset mod sizeof(aint)<>0) or + (right.resulttype.def.alignmentcurrent_procinfo.procdef.parast.symtablelevel) then - begin - if assigned(left) then - internalerror(200309289); - left:=cloadparentfpnode.create(tprocdef(symtable.defowner)); - { reference in nested procedures, variable needs to be in memory } - make_not_regable(self); - end; - { static variables referenced in procedures or from finalization, - variable needs to be in memory. - It is too hard and the benefit is too small to detect whether a - variable is only used in the finalization to add support for it (PFV) } - if (symtable.symtabletype=staticsymtable) and - ( - (symtable.symtablelevel<>current_procinfo.procdef.localst.symtablelevel) or - (current_procinfo.procdef.proctypeoption=potype_unitfinalize) - ) then - make_not_regable(self); - end; - { fix self type which is declared as voidpointer in the - definition } - if vo_is_self in tabstractvarsym(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 tabstractvarsym(symtableentry).varoptions then - begin - resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class); - resulttype.setdef(tclassrefdef.create(resulttype)); - end - else - resulttype:=tabstractvarsym(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; - labelsym: - resulttype:=voidtype; - 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; - registersint:=0; - registersfpu:=0; -{$ifdef SUPPORT_MMX} - registersmmx:=0; -{$endif SUPPORT_MMX} - if (cs_create_pic in aktmoduleswitches) and - not(symtableentry.typ in [paravarsym,localvarsym]) then - include(current_procinfo.flags,pi_needs_got); - - case symtableentry.typ of - absolutevarsym : - ; - constsym: - begin - if tconstsym(symtableentry).consttyp=constresourcestring then - expectloc:=LOC_CREFERENCE; - end; - globalvarsym, - localvarsym, - paravarsym : - begin - if assigned(left) then - firstpass(left); - if not is_addr_param_load and - tabstractvarsym(symtableentry).is_regvar then - begin - case tabstractvarsym(symtableentry).varregable of - vr_intreg : - expectloc:=LOC_CREGISTER; - vr_fpureg : - expectloc:=LOC_CFPUREGISTER; - vr_mmreg : - expectloc:=LOC_CMMREGISTER; - end - end - else - if (tabstractvarsym(symtableentry).varspez=vs_const) then - expectloc:=LOC_CREFERENCE; - { we need a register for call by reference parameters } - if paramanager.push_addr_param(tabstractvarsym(symtableentry).varspez,tabstractvarsym(symtableentry).vartype.def,pocall_default) then - registersint:=1; - if ([vo_is_thread_var,vo_is_dll_var]*tabstractvarsym(symtableentry).varoptions)<>[] then - registersint:=1; - if (target_info.system=system_powerpc_darwin) and (vo_is_dll_var in tabstractvarsym(symtableentry).varoptions) then - include(current_procinfo.flags,pi_needs_got); - { call to get address of threadvar } - if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then - include(current_procinfo.flags,pi_do_call); - if nf_write in flags then - Tabstractvarsym(symtableentry).trigger_notifications(vn_onwrite) - else - Tabstractvarsym(symtableentry).trigger_notifications(vn_onread); - { count variable references } - if cg.t_times>1 then - inc(tabstractvarsym(symtableentry).refs,cg.t_times-1); - end; - typedconstsym : - ; - procsym : - begin - { method pointer ? } - if assigned(left) then - begin - expectloc:=LOC_CREFERENCE; - firstpass(left); - registersint:=max(registersint,left.registersint); - registersfpu:=max(registersfpu,left.registersfpu); - {$ifdef SUPPORT_MMX} - registersmmx:=max(registersmmx,left.registersmmx); - {$endif SUPPORT_MMX} - end; - end; - labelsym : - ; - 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 :=+ } - 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_'+Tstringdef(left.resulttype.def).stringtypname+'_append_char',hp) - else if is_shortstring(tbinarynode(right).right.resulttype.def) then - result:=ccallnode.createintern('fpc_'+Tstringdef(left.resulttype.def).stringtypname+'_append_shortstring',hp) - else - result:=ccallnode.createintern('fpc_'+Tstringdef(left.resulttype.def).stringtypname+'_append_ansistring',hp); - tbinarynode(right).right:=nil; - left:=nil; - exit; - end; - end; - end - else - if is_shortstring(left.resulttype.def) then - begin - { fold :=+, - + 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,[]); - set_varstate(right,vs_used,[vsf_must_be_valid]); - if codegenerror then - exit; - - { tp procvar support, when we don't expect a procvar - then we need to call the procvar } - if (left.resulttype.def.deftype<>procvardef) then - maybe_call_procvar(right,true); - - { 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_internal - (crttinode.create(tstoreddef(left.resulttype.def),initrtti)), - ccallparanode.create(ctypeconvnode.create_internal(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]) and - not is_boolean(left.resulttype.def) 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_internal - (right,voidpointertype), - ccallparanode.create(ctypeconvnode.create_internal - (left,voidpointertype),nil)); - result:=ccallnode.createintern('fpc_intf_assign',hp); - left:=nil; - right:=nil; - exit; - end; - { call helpers for variant, they can contain non ref. counted types like - vararrays which must be really copied } - if left.resulttype.def.deftype=variantdef then - begin - hp:=ccallparanode.create(ctypeconvnode.create_internal( - caddrnode.create_internal(right),voidpointertype), - ccallparanode.create(ctypeconvnode.create_internal( - caddrnode.create_internal(left),voidpointertype), - nil)); - result:=ccallnode.createintern('fpc_variant_copy',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; - - - registersint:=left.registersint+right.registersint; - 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,[vsf_must_be_valid]); - set_varstate(right,vs_used,[vsf_must_be_valid]); - 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,[vsf_must_be_valid]); - 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; - { Set the type of empty or varia arrays to void. Also - do this if the type is array of const/open array - because those can't be used with setelementtype } - if not assigned(htype.def) or - varia or - is_array_of_const(htype.def) or - is_open_array(htype.def) then - htype:=voidtype; - resulttype.setdef(tarraydef.create(0,len-1,s32inttype)); - 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 - hp : tarrayconstructornode; - dovariant : boolean; - 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_internal(hp.left,s32inttype); - arraydef : - begin - if is_chararray(hp.left.resulttype.def) then - hp.left:=ctypeconvnode.create_internal(hp.left,charpointertype) - else - if is_widechararray(hp.left.resulttype.def) then - hp.left:=ctypeconvnode.create_internal(hp.left,widecharpointertype) - else - CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename); - end; - orddef : - begin - if is_integer(hp.left.resulttype.def) and - not(is_64bitint(hp.left.resulttype.def)) then - hp.left:=ctypeconvnode.create(hp.left,s32inttype); - 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; - do_variant:boolean; - begin - do_variant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant; - 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 - if hp.left<>nil then - begin - {This check is pessimistic; a call will happen depending - on the location in which the elements will be found in - pass 2.} - if not do_variant then - include(current_procinfo.flags,pi_do_call); - firstpass(hp.left); - end; - 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(parser_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; - - -begin - cloadnode:=tloadnode; - cassignmentnode:=tassignmentnode; - carrayconstructorrangenode:=tarrayconstructorrangenode; - carrayconstructornode:=tarrayconstructornode; - ctypenode:=ttypenode; - crttinode:=trttinode; -end. -{ - $Log: nld.pas,v $ - Revision 1.148 2005/03/28 13:36:15 florian - + variants are now assigned using fpc_variant_copy - - Revision 1.147 2005/03/25 22:20:19 peter - * add hint when passing an uninitialized variable to a var parameter - - Revision 1.146 2005/03/18 16:41:27 peter - don't check size differences for booleans - - Revision 1.145 2005/02/14 17:13:06 peter - * truncate log - - Revision 1.144 2005/02/11 16:25:26 peter - * fix IE with array of const in array of conts - - Revision 1.143 2005/01/23 17:14:21 florian - + optimized code generation on sparc - + some stuff for pic code on sparc added - -} +{ + $Id: nld.pas,v 1.148 2005/03/28 13:36:15 florian Exp $ + 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,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 is_addr_param_load:boolean; + 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; + 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; + + + +implementation + + uses + cutils,verbose,globtype,globals,systems, + symnot, + defutil,defcmp, + htypechk,pass_1,procinfo,paramgr, + ncon,ninl,ncnv,nmem,ncal,nutils, + cgobj,cgbase + ; + +{***************************************************************************** + 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.is_addr_param_load:boolean; + begin + result:=(symtable.symtabletype=parasymtable) and + (symtableentry.typ=paravarsym) and + not(vo_has_local_copy in tparavarsym(symtableentry).varoptions) and + not(nf_load_self_pointer in flags) and + paramanager.push_addr_param(tparavarsym(symtableentry).varspez,tparavarsym(symtableentry).vartype.def,tprocdef(symtable.defowner).proccalloption); + end; + + + function tloadnode.det_resulttype:tnode; + begin + result:=nil; + case symtableentry.typ of + absolutevarsym : + resulttype:=tabsolutevarsym(symtableentry).vartype; + constsym: + begin + if tconstsym(symtableentry).consttyp=constresourcestring then + begin + {$ifdef ansistring_bits} + case aktansistring_bits of + sb_16: + resulttype:=cansistringtype16; + sb_32: + resulttype:=cansistringtype32; + sb_64: + resulttype:=cansistringtype64; + end; + {$else} + resulttype:=cansistringtype + {$endif} + end + else + internalerror(22799); + end; + globalvarsym, + paravarsym, + localvarsym : + begin + inc(tabstractvarsym(symtableentry).refs); + { Nested variable? The we need to load the framepointer of + the parent procedure } + if assigned(current_procinfo) then + begin + 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)); + { reference in nested procedures, variable needs to be in memory } + make_not_regable(self); + end; + { static variables referenced in procedures or from finalization, + variable needs to be in memory. + It is too hard and the benefit is too small to detect whether a + variable is only used in the finalization to add support for it (PFV) } + if (symtable.symtabletype=staticsymtable) and + ( + (symtable.symtablelevel<>current_procinfo.procdef.localst.symtablelevel) or + (current_procinfo.procdef.proctypeoption=potype_unitfinalize) + ) then + make_not_regable(self); + end; + { fix self type which is declared as voidpointer in the + definition } + if vo_is_self in tabstractvarsym(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 tabstractvarsym(symtableentry).varoptions then + begin + resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class); + resulttype.setdef(tclassrefdef.create(resulttype)); + end + else + resulttype:=tabstractvarsym(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; + labelsym: + resulttype:=voidtype; + 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; + registersint:=0; + registersfpu:=0; +{$ifdef SUPPORT_MMX} + registersmmx:=0; +{$endif SUPPORT_MMX} + if (cs_create_pic in aktmoduleswitches) and + not(symtableentry.typ in [paravarsym,localvarsym]) then + include(current_procinfo.flags,pi_needs_got); + + case symtableentry.typ of + absolutevarsym : + ; + constsym: + begin + if tconstsym(symtableentry).consttyp=constresourcestring then + expectloc:=LOC_CREFERENCE; + end; + globalvarsym, + localvarsym, + paravarsym : + begin + if assigned(left) then + firstpass(left); + if not is_addr_param_load and + tabstractvarsym(symtableentry).is_regvar then + begin + case tabstractvarsym(symtableentry).varregable of + vr_intreg : + expectloc:=LOC_CREGISTER; + vr_fpureg : + expectloc:=LOC_CFPUREGISTER; + vr_mmreg : + expectloc:=LOC_CMMREGISTER; + end + end + else + if (tabstractvarsym(symtableentry).varspez=vs_const) then + expectloc:=LOC_CREFERENCE; + { we need a register for call by reference parameters } + if paramanager.push_addr_param(tabstractvarsym(symtableentry).varspez,tabstractvarsym(symtableentry).vartype.def,pocall_default) then + registersint:=1; + if ([vo_is_thread_var,vo_is_dll_var]*tabstractvarsym(symtableentry).varoptions)<>[] then + registersint:=1; + if (target_info.system=system_powerpc_darwin) and (vo_is_dll_var in tabstractvarsym(symtableentry).varoptions) then + include(current_procinfo.flags,pi_needs_got); + { call to get address of threadvar } + if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then + include(current_procinfo.flags,pi_do_call); + if nf_write in flags then + Tabstractvarsym(symtableentry).trigger_notifications(vn_onwrite) + else + Tabstractvarsym(symtableentry).trigger_notifications(vn_onread); + { count variable references } + if cg.t_times>1 then + inc(tabstractvarsym(symtableentry).refs,cg.t_times-1); + end; + typedconstsym : + ; + procsym : + begin + { method pointer ? } + if assigned(left) then + begin + expectloc:=LOC_CREFERENCE; + firstpass(left); + registersint:=max(registersint,left.registersint); + registersfpu:=max(registersfpu,left.registersfpu); + {$ifdef SUPPORT_MMX} + registersmmx:=max(registersmmx,left.registersmmx); + {$endif SUPPORT_MMX} + end; + end; + labelsym : + ; + 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 :=+ } + 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_'+Tstringdef(left.resulttype.def).stringtypname+'_append_char',hp) + else if is_shortstring(tbinarynode(right).right.resulttype.def) then + result:=ccallnode.createintern('fpc_'+Tstringdef(left.resulttype.def).stringtypname+'_append_shortstring',hp) + else + result:=ccallnode.createintern('fpc_'+Tstringdef(left.resulttype.def).stringtypname+'_append_ansistring',hp); + tbinarynode(right).right:=nil; + left:=nil; + exit; + end; + end; + end + else + if is_shortstring(left.resulttype.def) then + begin + { fold :=+, + + 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,[]); + set_varstate(right,vs_used,[vsf_must_be_valid]); + if codegenerror then + exit; + + { tp procvar support, when we don't expect a procvar + then we need to call the procvar } + if (left.resulttype.def.deftype<>procvardef) then + maybe_call_procvar(right,true); + + { 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_internal + (crttinode.create(tstoreddef(left.resulttype.def),initrtti)), + ccallparanode.create(ctypeconvnode.create_internal(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]) and + not is_boolean(left.resulttype.def) 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_internal + (right,voidpointertype), + ccallparanode.create(ctypeconvnode.create_internal + (left,voidpointertype),nil)); + result:=ccallnode.createintern('fpc_intf_assign',hp); + left:=nil; + right:=nil; + exit; + end; + { call helpers for variant, they can contain non ref. counted types like + vararrays which must be really copied } + if left.resulttype.def.deftype=variantdef then + begin + hp:=ccallparanode.create(ctypeconvnode.create_internal( + caddrnode.create_internal(right),voidpointertype), + ccallparanode.create(ctypeconvnode.create_internal( + caddrnode.create_internal(left),voidpointertype), + nil)); + result:=ccallnode.createintern('fpc_variant_copy',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; + + + registersint:=left.registersint+right.registersint; + 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,[vsf_must_be_valid]); + set_varstate(right,vs_used,[vsf_must_be_valid]); + 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,[vsf_must_be_valid]); + 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; + { Set the type of empty or varia arrays to void. Also + do this if the type is array of const/open array + because those can't be used with setelementtype } + if not assigned(htype.def) or + varia or + is_array_of_const(htype.def) or + is_open_array(htype.def) then + htype:=voidtype; + resulttype.setdef(tarraydef.create(0,len-1,s32inttype)); + 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 + hp : tarrayconstructornode; + dovariant : boolean; + 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_internal(hp.left,s32inttype); + arraydef : + begin + if is_chararray(hp.left.resulttype.def) then + hp.left:=ctypeconvnode.create_internal(hp.left,charpointertype) + else + if is_widechararray(hp.left.resulttype.def) then + hp.left:=ctypeconvnode.create_internal(hp.left,widecharpointertype) + else + CGMessagePos1(hp.left.fileinfo,type_e_wrong_type_in_array_constructor,hp.left.resulttype.def.typename); + end; + orddef : + begin + if is_integer(hp.left.resulttype.def) and + not(is_64bitint(hp.left.resulttype.def)) then + hp.left:=ctypeconvnode.create(hp.left,s32inttype); + end; + floatdef : + if not(is_currency(hp.left.resulttype.def)) then + 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; + do_variant:boolean; + begin + do_variant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant; + 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 + if hp.left<>nil then + begin + {This check is pessimistic; a call will happen depending + on the location in which the elements will be found in + pass 2.} + if not do_variant then + include(current_procinfo.flags,pi_do_call); + firstpass(hp.left); + end; + 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(parser_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; + + +begin + cloadnode:=tloadnode; + cassignmentnode:=tassignmentnode; + carrayconstructorrangenode:=tarrayconstructorrangenode; + carrayconstructornode:=tarrayconstructornode; + ctypenode:=ttypenode; + crttinode:=trttinode; +end. +{ + $Log: nld.pas,v $ + Revision 1.148 2005/03/28 13:36:15 florian + + variants are now assigned using fpc_variant_copy + + Revision 1.147 2005/03/25 22:20:19 peter + * add hint when passing an uninitialized variable to a var parameter + + Revision 1.146 2005/03/18 16:41:27 peter + don't check size differences for booleans + + Revision 1.145 2005/02/14 17:13:06 peter + * truncate log + + Revision 1.144 2005/02/11 16:25:26 peter + * fix IE with array of const in array of conts + + Revision 1.143 2005/01/23 17:14:21 florian + + optimized code generation on sparc + + some stuff for pic code on sparc added + +}