{ $Id$ Copyright (c) 1993-98 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 tcld; interface uses tree; procedure firstload(var p : ptree); procedure firstassignment(var p : ptree); procedure firstfuncret(var p : ptree); procedure firstarrayconstructrange(var p:ptree); procedure firstarrayconstruct(var p : ptree); procedure firsttype(var p : ptree); implementation uses cobjects,verbose,globals,systems, symtable,aasm,types, hcodegen,htypechk,pass_1, tccnv {$ifdef i386} ,i386base ,tgeni386 {$endif} {$ifdef m68k} ,m68k,tgen68k {$endif} ; {***************************************************************************** FirstLoad *****************************************************************************} procedure firstload(var p : ptree); var p1 : ptree; begin if (p^.symtable^.symtabletype=withsymtable) and (pwithsymtable(p^.symtable)^.direct_with) and (p^.symtableentry^.typ=varsym) then begin p1:=getcopy(ptree(pwithsymtable(p^.symtable)^.withrefnode)); p1:=gensubscriptnode(pvarsym(p^.symtableentry),p1); putnode(p); p:=p1; firstpass(p); exit; end; p^.location.loc:=LOC_REFERENCE; p^.registers32:=0; p^.registersfpu:=0; {$ifdef SUPPORT_MMX} p^.registersmmx:=0; {$endif SUPPORT_MMX} if p^.symtableentry^.typ=funcretsym then begin p1:=genzeronode(funcretn); p1^.funcretprocinfo:=pprocinfo(pfuncretsym(p^.symtableentry)^.funcretprocinfo); p1^.retdef:=pfuncretsym(p^.symtableentry)^.funcretdef; firstpass(p1); putnode(p); p:=p1; exit; end; if p^.symtableentry^.typ=absolutesym then begin p^.resulttype:=pabsolutesym(p^.symtableentry)^.definition; if pabsolutesym(p^.symtableentry)^.abstyp=tovar then p^.symtableentry:=pabsolutesym(p^.symtableentry)^.ref; p^.symtable:=p^.symtableentry^.owner; p^.is_absolute:=true; end; case p^.symtableentry^.typ of absolutesym :; constsym: begin if pconstsym(p^.symtableentry)^.consttype=constresourcestring then begin p^.resulttype:=cansistringdef; p^.location.loc:=LOC_MEM; end else internalerror(22799); end; varsym : begin if not(p^.is_absolute) and (p^.resulttype=nil) then p^.resulttype:=pvarsym(p^.symtableentry)^.definition; if (p^.symtable^.symtabletype in [parasymtable,localsymtable]) and (lexlevel>p^.symtable^.symtablelevel) then begin { if the variable is in an other stackframe then we need a register to dereference } if (p^.symtable^.symtablelevel)>0 then begin p^.registers32:=1; { further, the variable can't be put into a register } pvarsym(p^.symtableentry)^.var_options:= pvarsym(p^.symtableentry)^.var_options and not vo_regable; end; end; if (pvarsym(p^.symtableentry)^.varspez=vs_const) then p^.location.loc:=LOC_MEM; { we need a register for call by reference parameters } if (pvarsym(p^.symtableentry)^.varspez=vs_var) or ((pvarsym(p^.symtableentry)^.varspez=vs_const) and push_addr_param(pvarsym(p^.symtableentry)^.definition)) or { call by value open arrays are also indirect addressed } is_open_array(pvarsym(p^.symtableentry)^.definition) then p^.registers32:=1; if p^.symtable^.symtabletype=withsymtable then inc(p^.registers32); if (pvarsym(p^.symtableentry)^.var_options and (vo_is_thread_var or vo_is_dll_var))<>0 then p^.registers32:=1; { a class variable is a pointer !!! yes, but we have to resolve the reference in an appropriate tree node (FK) if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oo_is_class)<>0) then p^.registers32:=1; } { count variable references } if must_be_valid and p^.is_first then begin if pvarsym(p^.symtableentry)^.is_valid=2 then if (assigned(pvarsym(p^.symtableentry)^.owner) and assigned(aktprocsym) and (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)) then begin if p^.symtable^.symtabletype=localsymtable then CGMessage1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name) else CGMessage1(sym_n_uninitialized_variable,pvarsym(p^.symtableentry)^.name); end; end; if count_ref then begin if (p^.is_first) then begin if (pvarsym(p^.symtableentry)^.is_valid=2) then pvarsym(p^.symtableentry)^.is_valid:=1; p^.is_first:=false; end; end; { this will create problem with local var set by under_procedures if (assigned(pvarsym(p^.symtableentry)^.owner) and assigned(aktprocsym) and ((pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst) or (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst))) then } if t_times<1 then inc(pvarsym(p^.symtableentry)^.refs) else inc(pvarsym(p^.symtableentry)^.refs,t_times); end; typedconstsym : if not p^.is_absolute then p^.resulttype:=ptypedconstsym(p^.symtableentry)^.definition; procsym : begin if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then CGMessage(parser_e_no_overloaded_procvars); p^.resulttype:=pprocsym(p^.symtableentry)^.definition; { method pointer ? } if assigned(p^.left) then begin firstpass(p^.left); p^.registers32:=max(p^.registers32,p^.left^.registers32); p^.registersfpu:=max(p^.registersfpu,p^.left^.registersfpu); {$ifdef SUPPORT_MMX} p^.registersmmx:=max(p^.registersmmx,p^.left^.registersmmx); {$endif SUPPORT_MMX} end; end; else internalerror(3); end; end; {***************************************************************************** FirstAssignment *****************************************************************************} procedure firstassignment(var p : ptree); var store_valid : boolean; hp : ptree; begin store_valid:=must_be_valid; must_be_valid:=false; { must be made unique } set_unique(p^.left); firstpass(p^.left); if codegenerror then exit; { assignements to open arrays aren't allowed } if is_open_array(p^.left^.resulttype) then CGMessage(type_e_mismatch); { test if we can avoid copying string to temp as in s:=s+...; (PM) } {$ifdef dummyi386} if ((p^.right^.treetype=addn) or (p^.right^.treetype=subn)) and equal_trees(p^.left,p^.right^.left) and (ret_in_acc(p^.left^.resulttype)) and (not cs_rangechecking in aktmoduleswitches^) then begin disposetree(p^.right^.left); hp:=p^.right; p^.right:=p^.right^.right; if hp^.treetype=addn then p^.assigntyp:=at_plus else p^.assigntyp:=at_minus; putnode(hp); end; if p^.assigntyp<>at_normal then begin { for fpu type there is no faster way } if is_fpu(p^.left^.resulttype) then case p^.assigntyp of at_plus : p^.right:=gennode(addn,getcopy(p^.left),p^.right); at_minus : p^.right:=gennode(subn,getcopy(p^.left),p^.right); at_star : p^.right:=gennode(muln,getcopy(p^.left),p^.right); at_slash : p^.right:=gennode(slashn,getcopy(p^.left),p^.right); end; end; {$endif i386} must_be_valid:=true; firstpass(p^.right); must_be_valid:=store_valid; if codegenerror then exit; { some string functions don't need conversion, so treat them separatly } if is_shortstring(p^.left^.resulttype) and (assigned(p^.right^.resulttype)) then begin if not (is_shortstring(p^.right^.resulttype) or is_ansistring(p^.right^.resulttype) or is_char(p^.right^.resulttype)) then begin p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype); firstpass(p^.right); if codegenerror then exit; end; { we call STRCOPY } procinfo.flags:=procinfo.flags or pi_do_call; hp:=p^.right; { test for s:=s+anything ... } { the problem is for s:=s+s+s; this is broken here !! } { while hp^.treetype=addn do hp:=hp^.left; if equal_trees(p^.left,hp) then begin p^.concat_string:=true; hp:=p^.right; while hp^.treetype=addn do begin hp^.use_strconcat:=true; hp:=hp^.left; end; end; } end else begin p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype); firstpass(p^.right); if codegenerror then exit; end; p^.resulttype:=voiddef; { p^.registers32:=max(p^.left^.registers32,p^.right^.registers32); p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); } p^.registers32:=p^.left^.registers32+p^.right^.registers32; p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu); {$ifdef SUPPORT_MMX} p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx); {$endif SUPPORT_MMX} end; {***************************************************************************** FirstFuncRet *****************************************************************************} procedure firstfuncret(var p : ptree); begin p^.resulttype:=p^.retdef; p^.location.loc:=LOC_REFERENCE; if ret_in_param(p^.retdef) or (@procinfo<>pprocinfo(p^.funcretprocinfo)) then p^.registers32:=1; { no claim if setting higher return value_str } if must_be_valid and (@procinfo=pprocinfo(p^.funcretprocinfo)) and not procinfo.funcret_is_valid then CGMessage(sym_w_function_result_not_set); if count_ref then pprocinfo(p^.funcretprocinfo)^.funcret_is_valid:=true; end; {***************************************************************************** FirstArrayConstructRange *****************************************************************************} procedure firstarrayconstructrange(var p:ptree); begin firstpass(p^.left); firstpass(p^.right); calcregisters(p,0,0,0); p^.resulttype:=p^.left^.resulttype; end; {***************************************************************************** FirstArrayConstruct *****************************************************************************} procedure firstarrayconstruct(var p : ptree); var pd : pdef; thp, chp, hp : ptree; len : longint; varia : boolean; begin { are we allowing array constructor? Then convert it to a set } if not allow_array_constructor then begin arrayconstructor_to_set(p); firstpass(p); exit; end; { only pass left tree, right tree contains next construct if any } pd:=nil; len:=0; varia:=false; if assigned(p^.left) then begin hp:=p; while assigned(hp) do begin firstpass(hp^.left); if not get_para_resulttype then begin case hp^.left^.resulttype^.deftype of enumdef : begin hp^.left:=gentypeconvnode(hp^.left,s32bitdef); firstpass(hp^.left); end; orddef : begin if is_integer(hp^.left^.resulttype) then begin hp^.left:=gentypeconvnode(hp^.left,s32bitdef); firstpass(hp^.left); end; end; floatdef : begin hp^.left:=gentypeconvnode(hp^.left,bestrealdef^); firstpass(hp^.left); end; stringdef : begin if p^.cargs then begin hp^.left:=gentypeconvnode(hp^.left,charpointerdef); firstpass(hp^.left); end; end; recorddef, arraydef : CGMessage(type_e_wrong_type_in_array_constructor); end; end; if (pd=nil) then pd:=hp^.left^.resulttype else if (not varia) and (not is_equal(pd,hp^.left^.resulttype)) then varia:=true; inc(len); hp:=hp^.right; end; { swap the tree for cargs } if p^.cargs and (not p^.cargswap) then begin chp:=nil; hp:=p; while assigned(hp) do begin thp:=hp^.right; hp^.right:=chp; chp:=hp; hp:=thp; end; p:=chp; p^.cargs:=true; p^.cargswap:=true; end; end; calcregisters(p,0,0,0); { looks a little bit dangerous to me } { len-1 gives problems with is_open_array if len=0, } { is_open_array checks now for isconstructor (FK) } { skip if already done ! (PM) } if not assigned(p^.resulttype) or (p^.resulttype^.deftype<>arraydef) or not parraydef(p^.resulttype)^.IsConstructor or (parraydef(p^.resulttype)^.lowrange<>0) or (parraydef(p^.resulttype)^.highrange<>len-1) then p^.resulttype:=new(parraydef,init(0,len-1,s32bitdef)); parraydef(p^.resulttype)^.definition:=pd; parraydef(p^.resulttype)^.IsConstructor:=true; parraydef(p^.resulttype)^.IsVariant:=varia; p^.location.loc:=LOC_MEM; end; {***************************************************************************** Type *****************************************************************************} procedure firsttype(var p : ptree); begin { do nothing, p^.resulttype is already set } end; end. { $Log$ Revision 1.36 1999-07-22 09:38:00 florian + resourcestring implemented + start of longstring support Revision 1.35 1999/06/17 13:19:59 pierre * merged from 0_99_12 branch Revision 1.34.2.1 1999/06/17 12:33:39 pierre * avoid warning with extdebug for arrayconstruct Revision 1.34 1999/06/01 19:26:39 peter * fixed bug 249 Revision 1.33 1999/05/27 19:45:21 peter * removed oldasm * plabel -> pasmlabel * -a switches to source writing automaticly * assembler readers OOPed * asmsymbol automaticly external * jumptables and other label fixes for asm readers Revision 1.32 1999/05/23 18:42:22 florian * better error recovering in typed constants * some problems with arrays of const fixed, some problems due my previous - the location type of array constructor is now LOC_MEM - the pushing of high fixed - parameter copying fixed - zero temp. allocation removed * small problem in the assembler writers fixed: ref to nil wasn't written correctly Revision 1.31 1999/05/19 15:26:41 florian * if a non local variables isn't initialized the compiler doesn't write any longer "local var. seems not to be ..." Revision 1.30 1999/05/19 10:31:55 florian * two bugs reported by Romio (bugs 13) are fixed: - empty array constructors are now handled correctly (e.g. for sysutils.format) - comparsion of ansistrings was sometimes coded wrong Revision 1.29 1999/05/17 23:51:45 peter * with temp vars now use a reference with a persistant temp instead of setting datasize Revision 1.27 1999/05/12 00:20:02 peter * removed R_DEFAULT_SEG * uniform float names Revision 1.26 1999/05/06 09:05:36 peter * generic write_float and str_float * fixed constant float conversions Revision 1.25 1999/05/01 13:24:54 peter * merged nasm compiler * old asm moved to oldasm/ Revision 1.24 1999/04/28 06:02:17 florian * changes of Bruessel: + message handler can now take an explicit self * typinfo fixed: sometimes the type names weren't written * the type checking for pointer comparisations and subtraction and are now more strict (was also buggy) * small bug fix to link.pas to support compiling on another drive * probable bug in popt386 fixed: call/jmp => push/jmp transformation didn't count correctly the jmp references + threadvar support * warning if ln/sqrt gets an invalid constant argument Revision 1.23 1999/04/21 21:57:33 pierre * previous log corrected Revision 1.22 1999/04/21 16:31:47 pierre * some wrong code in firstfuncret corrected Revision 1.21 1999/04/01 21:59:57 peter * type error for array constructor with array,record as argument Revision 1.20 1999/03/24 23:17:39 peter * fixed bugs 212,222,225,227,229,231,233 Revision 1.19 1999/03/18 11:21:52 peter * convert only to s32bit if integer or enum Revision 1.18 1999/03/16 21:02:10 peter * all array of const enum/ord are converted to s32bit Revision 1.17 1999/03/10 13:24:23 pierre * array of const type to definition field Revision 1.16 1999/02/22 02:15:52 peter * updates for ag386bin Revision 1.15 1999/02/15 13:13:19 pierre * fix for bug0216 Revision 1.14 1999/01/27 00:13:58 florian * "procedure of object"-stuff fixed Revision 1.13 1999/01/21 16:41:07 pierre * fix for constructor inside with statements Revision 1.12 1998/12/30 13:41:19 peter * released valuepara Revision 1.11 1998/11/18 17:45:28 peter * fixes for VALUEPARA Revision 1.10 1998/11/18 15:44:23 peter * VALUEPARA for tp7 compatible value parameters Revision 1.9 1998/11/17 00:36:49 peter * more ansistring fixes Revision 1.8 1998/11/10 10:09:18 peter * va_list -> array of const Revision 1.7 1998/11/05 14:26:48 peter * fixed variant warning with was sometimes said with sets Revision 1.6 1998/10/19 08:55:12 pierre * wrong stabs info corrected once again !! + variable vmt offset with vmt field only if required implemented now !!! Revision 1.5 1998/10/06 20:49:12 peter * m68k compiler compiles again Revision 1.4 1998/09/28 11:07:40 peter + floatdef support for array of const Revision 1.3 1998/09/27 10:16:27 florian * type casts pchar<->ansistring fixed * ansistring[..] calls does now an unique call Revision 1.2 1998/09/24 15:13:48 peter * fixed type node which was always set to void :( Revision 1.1 1998/09/23 20:42:24 peter * splitted pass_1 }