From df4eb26ed09a16b910c98483be624bd39311e94e Mon Sep 17 00:00:00 2001 From: florian Date: Mon, 25 Sep 2000 15:37:14 +0000 Subject: [PATCH] * more fixes --- compiler/ncnv.pas | 1086 ++++++++++++++++++++++++++++++++++++++++++++ compiler/nld.pas | 73 ++- compiler/nmem.pas | 7 +- compiler/nodeh.inc | 10 +- 4 files changed, 1168 insertions(+), 8 deletions(-) create mode 100644 compiler/ncnv.pas diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas new file mode 100644 index 0000000000..879c4ace03 --- /dev/null +++ b/compiler/ncnv.pas @@ -0,0 +1,1086 @@ +{ + $Id$ + Copyright (c) 2000 by Florian Klaempfl + + Type checking and register allocation for type converting 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 ncnv; + +{$i defines.inc} + +interface + + uses + node; + + type + ttypeconvnode = class(tunarynode) + convtyp : tconverttype; + constructor create(node : tnode;t : pdef);virtual; + function getcopy : tnode;override; + function pass_1 : tnode;override; + end; + + tasnode = class(tbinarynode) + constructor create(l,r : tnode);virtual; + function pass_1 : tnode;override; + end; + + tisnode = class(tbinarynode) + constructor create(l,r : tnode);virtual; + function pass_1 : tnode;override; + end; + + var + ctypeconvnode : class of ttypeconvnode; + casnode : class of tasnode; + cisnode : class of tisnode; + + function gentypeconvnode(node : tnode;t : pdef) : tnode; + + procedure arrayconstructor_to_set(var p:ptree); + +implementation + + uses + globtype,systems,tokens, + cutils,cobjects,verbose,globals, + symconst,symtable,aasm,types, +{$ifdef newcg} + cgbase, +{$else newcg} + hcodegen, +{$endif newcg} + htypechk,pass_1,cpubase; + + +{***************************************************************************** + Array constructor to Set Conversion +*****************************************************************************} + + procedure arrayconstructor_to_set(var p:ptree); + var + constp, + buildp, + p2,p3,p4 : ptree; + pd : pdef; + constset : pconstset; + constsetlo, + constsethi : longint; + + procedure update_constsethi(p:pdef); + begin + if ((p^.deftype=orddef) and + (porddef(p)^.high>=constsethi)) then + begin + constsethi:=porddef(p)^.high; + if pd=nil then + begin + if (constsethi>255) or + (porddef(p)^.low<0) then + pd:=u8bitdef + else + pd:=p; + end; + if constsethi>255 then + constsethi:=255; + end + else if ((p^.deftype=enumdef) and + (penumdef(p)^.max>=constsethi)) then + begin + if pd=nil then + pd:=p; + constsethi:=penumdef(p)^.max; + end; + end; + + procedure do_set(pos : longint); + var + mask,l : longint; + begin + if (pos>255) or (pos<0) then + Message(parser_e_illegal_set_expr); + if pos>constsethi then + constsethi:=pos; + if pos0 then + Message(parser_e_illegal_set_expr); + constset^[l]:=constset^[l] or mask; + end; + + var + l : longint; + lr,hr : longint; + + begin + new(constset); + FillChar(constset^,sizeof(constset^),0); + pd:=nil; + constsetlo:=0; + constsethi:=0; + constp:=gensinglenode(setconstn,nil); + constp^.value_set:=constset; + buildp:=constp; + if assigned(p^.left) then + begin + while assigned(p) do + begin + p4:=nil; { will contain the tree to create the set } + { split a range into p2 and p3 } + if p^.left^.treetype=arrayconstructrangen then + begin + p2:=p^.left^.left; + p3:=p^.left^.right; + { node is not used anymore } + putnode(p^.left); + end + else + begin + p2:=p^.left; + p3:=nil; + end; + firstpass(p2); + if assigned(p3) then + firstpass(p3); + if codegenerror then + break; + case p2^.resulttype^.deftype of + enumdef, + orddef: + begin + getrange(p2^.resulttype,lr,hr); + if assigned(p3) then + begin + { this isn't good, you'll get problems with + type t010 = 0..10; + ts = set of t010; + var s : ts;b : t010 + begin s:=[1,2,b]; end. + if is_integer(p3^.resulttype) then + begin + p3:=gentypeconvnode(p3,u8bitdef); + firstpass(p3); + end; + } + + if assigned(pd) and not(is_equal(pd,p3^.resulttype)) then + begin + aktfilepos:=p3^.fileinfo; + CGMessage(type_e_typeconflict_in_set); + end + else + begin + if (p2^.treetype=ordconstn) and (p3^.treetype=ordconstn) then + begin + if not(is_integer(p3^.resulttype)) then + pd:=p3^.resulttype + else + begin + p3:=gentypeconvnode(p3,u8bitdef); + p2:=gentypeconvnode(p2,u8bitdef); + firstpass(p2); + firstpass(p3); + end; + + for l:=p2^.value to p3^.value do + do_set(l); + disposetree(p3); + disposetree(p2); + end + else + begin + update_constsethi(p2^.resulttype); + p2:=gentypeconvnode(p2,pd); + firstpass(p2); + + update_constsethi(p3^.resulttype); + p3:=gentypeconvnode(p3,pd); + firstpass(p3); + + + if assigned(pd) then + p3:=gentypeconvnode(p3,pd) + else + p3:=gentypeconvnode(p3,u8bitdef); + firstpass(p3); + p4:=gennode(setelementn,p2,p3); + end; + end; + end + else + begin + { Single value } + if p2^.treetype=ordconstn then + begin + if not(is_integer(p2^.resulttype)) then + update_constsethi(p2^.resulttype) + else + begin + p2:=gentypeconvnode(p2,u8bitdef); + firstpass(p2); + end; + + do_set(p2^.value); + disposetree(p2); + end + else + begin + update_constsethi(p2^.resulttype); + + if assigned(pd) then + p2:=gentypeconvnode(p2,pd) + else + p2:=gentypeconvnode(p2,u8bitdef); + firstpass(p2); + + p4:=gennode(setelementn,p2,nil); + end; + end; + end; + stringdef : begin + { if we've already set elements which are constants } + { throw an error } + if ((pd=nil) and assigned(buildp)) or + not(is_equal(pd,cchardef)) then + CGMessage(type_e_typeconflict_in_set) + else + for l:=1 to length(pstring(p2^.value_str)^) do + do_set(ord(pstring(p2^.value_str)^[l])); + if pd=nil then + pd:=cchardef; + disposetree(p2); + end; + else + CGMessage(type_e_ordinal_expr_expected); + end; + { insert the set creation tree } + if assigned(p4) then + buildp:=gennode(addn,buildp,p4); + { load next and dispose current node } + p2:=p; + p:=p^.right; + putnode(p2); + end; + if (pd=nil) then + begin + pd:=u8bitdef; + constsethi:=255; + end; + end + else + begin + { empty set [], only remove node } + putnode(p); + end; + { set the initial set type } + constp^.resulttype:=new(psetdef,init(pd,constsethi)); + { set the new tree } + p:=buildp; + end; + + +{***************************************************************************** + TTYPECONVNODE +*****************************************************************************} + + type + tfirstconvproc = procedure(var p : ptree); + + procedure first_int_to_int(var p : ptree); + begin + if (p^.left^.location.loc<>LOC_REGISTER) and + (p^.resulttype^.size>p^.left^.resulttype^.size) then + p^.location.loc:=LOC_REGISTER; + if is_64bitint(p^.resulttype) then + p^.registers32:=max(p^.registers32,2) + else + p^.registers32:=max(p^.registers32,1); + end; + + + procedure first_cstring_to_pchar(var p : ptree); + begin + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_string_to_chararray(var p : ptree); + begin + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_string_to_string(var p : ptree); + var + hp : ptree; + begin + if pstringdef(p^.resulttype)^.string_typ<> + pstringdef(p^.left^.resulttype)^.string_typ then + begin + if p^.left^.treetype=stringconstn then + begin + p^.left^.stringtype:=pstringdef(p^.resulttype)^.string_typ; + p^.left^.resulttype:=p^.resulttype; + { remove typeconv node } + hp:=p; + p:=p^.left; + putnode(hp); + exit; + end + else + procinfo^.flags:=procinfo^.flags or pi_do_call; + end; + { for simplicity lets first keep all ansistrings + as LOC_MEM, could also become LOC_REGISTER } + if pstringdef(p^.resulttype)^.string_typ in [st_ansistring,st_widestring] then + { we may use ansistrings so no fast exit here } + procinfo^.no_fast_exit:=true; + p^.location.loc:=LOC_MEM; + end; + + + procedure first_char_to_string(var p : ptree); + var + hp : ptree; + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genstringconstnode(chr(p^.left^.value),st_default); + hp^.stringtype:=pstringdef(p^.resulttype)^.string_typ; + firstpass(hp); + disposetree(p); + p:=hp; + end + else + p^.location.loc:=LOC_MEM; + end; + + + procedure first_nothing(var p : ptree); + begin + p^.location.loc:=LOC_MEM; + end; + + + procedure first_array_to_pointer(var p : ptree); + begin + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_int_to_real(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=ordconstn then + begin + t:=genrealconstnode(p^.left^.value,pfloatdef(p^.resulttype)); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + if p^.registersfpu<1 then + p^.registersfpu:=1; + p^.location.loc:=LOC_FPU; + end; + + + procedure first_int_to_fix(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=ordconstn then + begin + t:=genfixconstnode(p^.left^.value shl 16,p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_real_to_fix(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=fixconstn then + begin + t:=genfixconstnode(round(p^.left^.value_real*65536),p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + { at least one fpu and int register needed } + if p^.registers32<1 then + p^.registers32:=1; + if p^.registersfpu<1 then + p^.registersfpu:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_fix_to_real(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=fixconstn then + begin + t:=genrealconstnode(round(p^.left^.value_fix/65536.0),p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + if p^.registersfpu<1 then + p^.registersfpu:=1; + p^.location.loc:=LOC_FPU; + end; + + + procedure first_real_to_real(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=realconstn then + begin + t:=genrealconstnode(p^.left^.value_real,p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end; + { comp isn't a floating type } +{$ifdef i386} + if (pfloatdef(p^.resulttype)^.typ=s64comp) and + (pfloatdef(p^.left^.resulttype)^.typ<>s64comp) and + not (p^.explizit) then + CGMessage(type_w_convert_real_2_comp); +{$endif} + if p^.registersfpu<1 then + p^.registersfpu:=1; + p^.location.loc:=LOC_FPU; + end; + + + procedure first_pointer_to_array(var p : ptree); + begin + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REFERENCE; + end; + + + procedure first_chararray_to_string(var p : ptree); + begin + { the only important information is the location of the } + { result } + { other stuff is done by firsttypeconv } + p^.location.loc:=LOC_MEM; + end; + + + procedure first_cchar_to_pchar(var p : ptree); + begin + p^.left:=gentypeconvnode(p^.left,cshortstringdef); + { convert constant char to constant string } + firstpass(p^.left); + { evalute tree } + firstpass(p); + end; + + + procedure first_bool_to_int(var p : ptree); + begin + { byte(boolean) or word(wordbool) or longint(longbool) must + be accepted for var parameters } + if (p^.explizit) and + (p^.left^.resulttype^.size=p^.resulttype^.size) and + (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then + exit; + p^.location.loc:=LOC_REGISTER; + if p^.registers32<1 then + p^.registers32:=1; + end; + + + procedure first_int_to_bool(var p : ptree); + begin + { byte(boolean) or word(wordbool) or longint(longbool) must + be accepted for var parameters } + if (p^.explizit) and + (p^.left^.resulttype^.size=p^.resulttype^.size) and + (p^.left^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then + exit; + p^.location.loc:=LOC_REGISTER; + { need if bool to bool !! + not very nice !! + p^.left:=gentypeconvnode(p^.left,s32bitdef); + p^.left^.explizit:=true; + firstpass(p^.left); } + if p^.registers32<1 then + p^.registers32:=1; + end; + + + procedure first_bool_to_bool(var p : ptree); + begin + p^.location.loc:=LOC_REGISTER; + if p^.registers32<1 then + p^.registers32:=1; + end; + + + procedure first_proc_to_procvar(var p : ptree); + begin + { hmmm, I'am not sure if that is necessary (FK) } + firstpass(p^.left); + if codegenerror then + exit; + + if (p^.left^.location.loc<>LOC_REFERENCE) then + CGMessage(cg_e_illegal_expression); + + p^.registers32:=p^.left^.registers32; + if p^.registers32<1 then + p^.registers32:=1; + p^.location.loc:=LOC_REGISTER; + end; + + + procedure first_load_smallset(var p : ptree); + begin + end; + + + procedure first_cord_to_pointer(var p : ptree); + var + t : ptree; + begin + if p^.left^.treetype=ordconstn then + begin + t:=genpointerconstnode(p^.left^.value,p^.resulttype); + firstpass(t); + disposetree(p); + p:=t; + exit; + end + else + internalerror(432472389); + end; + + + procedure first_pchar_to_string(var p : ptree); + begin + p^.location.loc:=LOC_REFERENCE; + end; + + + procedure first_ansistring_to_pchar(var p : ptree); + begin + p^.location.loc:=LOC_REGISTER; + if p^.registers32<1 then + p^.registers32:=1; + end; + + + procedure first_arrayconstructor_to_set(var p:ptree); + var + hp : ptree; + begin + if p^.left^.treetype<>arrayconstructn then + internalerror(5546); + { remove typeconv node } + hp:=p; + p:=p^.left; + putnode(hp); + { create a set constructor tree } + arrayconstructor_to_set(p); + { now firstpass the set } + firstpass(p); + end; + + + procedure firsttypeconv(var p : ptree); + var + hp : ptree; + aprocdef : pprocdef; + const + firstconvert : array[tconverttype] of tfirstconvproc = ( + first_nothing, {equal} + first_nothing, {not_possible} + first_string_to_string, + first_char_to_string, + first_pchar_to_string, + first_cchar_to_pchar, + first_cstring_to_pchar, + first_ansistring_to_pchar, + first_string_to_chararray, + first_chararray_to_string, + first_array_to_pointer, + first_pointer_to_array, + first_int_to_int, + first_int_to_bool, + first_bool_to_bool, + first_bool_to_int, + first_real_to_real, + first_int_to_real, + first_int_to_fix, + first_real_to_fix, + first_fix_to_real, + first_proc_to_procvar, + first_arrayconstructor_to_set, + first_load_smallset, + first_cord_to_pointer + ); + begin + aprocdef:=nil; + { if explicite type cast, then run firstpass } + if (p^.explizit) or not assigned(p^.left^.resulttype) then + firstpass(p^.left); + if (p^.left^.treetype=typen) and (p^.left^.resulttype=generrordef) then + begin + codegenerror:=true; + Message(parser_e_no_type_not_allowed_here); + end; + if codegenerror then + begin + p^.resulttype:=generrordef; + exit; + end; + + if not assigned(p^.left^.resulttype) then + begin + codegenerror:=true; + internalerror(52349); + exit; + end; + + { load the value_str from the left part } + p^.registers32:=p^.left^.registers32; + p^.registersfpu:=p^.left^.registersfpu; +{$ifdef SUPPORT_MMX} + p^.registersmmx:=p^.left^.registersmmx; +{$endif} + set_location(p^.location,p^.left^.location); + + { remove obsolete type conversions } + if is_equal(p^.left^.resulttype,p^.resulttype) then + begin + { becuase is_equal only checks the basetype for sets we need to + check here if we are loading a smallset into a normalset } + if (p^.resulttype^.deftype=setdef) and + (p^.left^.resulttype^.deftype=setdef) and + (psetdef(p^.resulttype)^.settype<>smallset) and + (psetdef(p^.left^.resulttype)^.settype=smallset) then + begin + { try to define the set as a normalset if it's a constant set } + if p^.left^.treetype=setconstn then + begin + p^.resulttype:=p^.left^.resulttype; + psetdef(p^.resulttype)^.settype:=normset + end + else + p^.convtyp:=tc_load_smallset; + exit; + end + else + begin + hp:=p; + p:=p^.left; + p^.resulttype:=hp^.resulttype; + putnode(hp); + exit; + end; + end; + aprocdef:=assignment_overloaded(p^.left^.resulttype,p^.resulttype); + if assigned(aprocdef) then + begin + procinfo^.flags:=procinfo^.flags or pi_do_call; + hp:=gencallnode(overloaded_operators[_assignment],nil); + { tell explicitly which def we must use !! (PM) } + hp^.procdefinition:=aprocdef; + hp^.left:=gencallparanode(p^.left,nil); + putnode(p); + p:=hp; + firstpass(p); + exit; + end; + + if isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype,p^.explizit)=0 then + begin + {Procedures have a resulttype of voiddef and functions of their + own resulttype. They will therefore always be incompatible with + a procvar. Because isconvertable cannot check for procedures we + use an extra check for them.} + if (m_tp_procvar in aktmodeswitches) then + begin + if (p^.resulttype^.deftype=procvardef) and + (is_procsym_load(p^.left) or is_procsym_call(p^.left)) then + begin + if is_procsym_call(p^.left) then + begin + {if p^.left^.right=nil then + begin} + if (p^.left^.symtableprocentry^.owner^.symtabletype=objectsymtable){ and + (pobjectdef(p^.left^.symtableprocentry^.owner^.defowner)^.is_class) }then + hp:=genloadmethodcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc, + getcopy(p^.left^.methodpointer)) + else + hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc); + disposetree(p^.left); + firstpass(hp); + p^.left:=hp; + aprocdef:=pprocdef(p^.left^.resulttype); + (* end + else + begin + p^.left^.right^.treetype:=loadn; + p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry; + P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition; + hp:=p^.left^.right; + putnode(p^.left); + p^.left:=hp; + { should we do that ? } + firstpass(p^.left); + if not is_equal(p^.left^.resulttype,p^.resulttype) then + begin + CGMessage(type_e_mismatch); + exit; + end + else + begin + hp:=p; + p:=p^.left; + p^.resulttype:=hp^.resulttype; + putnode(hp); + exit; + end; + end; *) + end + else + begin + if (p^.left^.treetype<>addrn) then + aprocdef:=pprocsym(p^.left^.symtableentry)^.definition; + end; + p^.convtyp:=tc_proc_2_procvar; + { Now check if the procedure we are going to assign to + the procvar, is compatible with the procvar's type } + if assigned(aprocdef) then + begin + if not proc_to_procvar_equal(aprocdef,pprocvardef(p^.resulttype)) then + CGMessage2(type_e_incompatible_types,aprocdef^.typename,p^.resulttype^.typename); + firstconvert[p^.convtyp](p); + end + else + CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + exit; + end; + end; + if p^.explizit then + begin + { check if the result could be in a register } + if not(p^.resulttype^.is_intregable) and + not(p^.resulttype^.is_fpuregable) then + make_not_regable(p^.left); + { boolean to byte are special because the + location can be different } + + if is_integer(p^.resulttype) and + is_boolean(p^.left^.resulttype) then + begin + p^.convtyp:=tc_bool_2_int; + firstconvert[p^.convtyp](p); + exit; + end; + { ansistring to pchar } + if is_pchar(p^.resulttype) and + is_ansistring(p^.left^.resulttype) then + begin + p^.convtyp:=tc_ansistring_2_pchar; + firstconvert[p^.convtyp](p); + exit; + end; + { do common tc_equal cast } + p^.convtyp:=tc_equal; + + { enum to ordinal will always be s32bit } + if (p^.left^.resulttype^.deftype=enumdef) and + is_ordinal(p^.resulttype) then + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + disposetree(p); + firstpass(hp); + p:=hp; + exit; + end + else + begin + if isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then + CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + end; + end + + { ordinal to enumeration } + else + if (p^.resulttype^.deftype=enumdef) and + is_ordinal(p^.left^.resulttype) then + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + disposetree(p); + firstpass(hp); + p:=hp; + exit; + end + else + begin + if IsConvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn,false)=0 then + CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + end; + end + + { nil to ordinal node } + else if is_ordinal(p^.resulttype) and + (p^.left^.treetype=niln) then + begin + hp:=genordinalconstnode(0,p^.resulttype); + firstpass(hp); + disposetree(p); + p:=hp; + exit; + end + + {Are we typecasting an ordconst to a char?} + else + if is_char(p^.resulttype) and + is_ordinal(p^.left^.resulttype) then + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + firstpass(hp); + disposetree(p); + p:=hp; + exit; + end + else + begin + if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then + CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + end; + end + + { Are we char to ordinal } + else + if is_char(p^.left^.resulttype) and + is_ordinal(p^.resulttype) then + begin + if p^.left^.treetype=ordconstn then + begin + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + firstpass(hp); + disposetree(p); + p:=hp; + exit; + end + else + begin + if IsConvertable(u8bitdef,p^.resulttype,p^.convtyp,ordconstn,false)=0 then + CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + end; + end + + { only if the same size or formal def } + { why do we allow typecasting of voiddef ?? (PM) } + else + begin + if not( + (p^.left^.resulttype^.deftype=formaldef) or + (p^.left^.resulttype^.size=p^.resulttype^.size) or + (is_equal(p^.left^.resulttype,voiddef) and + (p^.left^.treetype=derefn)) + ) then + CGMessage(cg_e_illegal_type_conversion); + if ((p^.left^.resulttype^.deftype=orddef) and + (p^.resulttype^.deftype=pointerdef)) or + ((p^.resulttype^.deftype=orddef) and + (p^.left^.resulttype^.deftype=pointerdef)) + {$ifdef extdebug}and (p^.firstpasscount=0){$endif} then + CGMessage(cg_d_pointer_to_longint_conv_not_portable); + end; + + { the conversion into a strutured type is only } + { possible, if the source is no register } + if ((p^.resulttype^.deftype in [recorddef,stringdef,arraydef]) or + ((p^.resulttype^.deftype=objectdef) and not(pobjectdef(p^.resulttype)^.is_class)) + ) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) { and + it also works if the assignment is overloaded + YES but this code is not executed if assignment is overloaded (PM) + not assigned(assignment_overloaded(p^.left^.resulttype,p^.resulttype))} then + CGMessage(cg_e_illegal_type_conversion); + end + else + CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + end; + + { tp7 procvar support, when right is not a procvardef and we got a + loadn of a procvar then convert to a calln, the check for the + result is already done in is_convertible, also no conflict with + @procvar is here because that has an extra addrn } + if (m_tp_procvar in aktmodeswitches) and + (p^.resulttype^.deftype<>procvardef) and + (p^.left^.resulttype^.deftype=procvardef) and + (p^.left^.treetype=loadn) then + begin + hp:=gencallnode(nil,nil); + hp^.right:=p^.left; + firstpass(hp); + p^.left:=hp; + end; + + + { ordinal contants can be directly converted } + { but not int64/qword } + if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) and + not(is_64bitint(p^.resulttype)) then + begin + { range checking is done in genordinalconstnode (PFV) } + hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + disposetree(p); + firstpass(hp); + p:=hp; + exit; + end; + if p^.convtyp<>tc_equal then + firstconvert[p^.convtyp](p); + end; + + +{***************************************************************************** + TISNODE +*****************************************************************************} + + constructor tisnode.create(l,r : tnode); + + begin + inherited create(isn,l,r); + end; + + function tisnode.pass_1 : tnode; + begin + pass_1:=nil; + firstpass(p^.left); + set_varstate(p^.left,true); + firstpass(p^.right); + set_varstate(p^.right,true); + if codegenerror then + exit; + + if (p^.right^.resulttype^.deftype<>classrefdef) then + CGMessage(type_e_mismatch); + + left_right_max(p); + + { left must be a class } + if (p^.left^.resulttype^.deftype<>objectdef) or + not(pobjectdef(p^.left^.resulttype)^.is_class) then + CGMessage(type_e_mismatch); + + { the operands must be related } + if (not(pobjectdef(p^.left^.resulttype)^.is_related( + pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)))) and + (not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)^.is_related( + pobjectdef(p^.left^.resulttype)))) then + CGMessage(type_e_mismatch); + + p^.location.loc:=LOC_FLAGS; + p^.resulttype:=booldef; + end; + + +{***************************************************************************** + TASNODE +*****************************************************************************} + + constructor tasnode.create(l,r : tnode); + + begin + inherited create(asn,l,r); + end; + + function tasnode.pass_1 : tnode; + begin + pass_1:=nil; + firstpass(p^.right); + set_varstate(p^.right,true); + firstpass(p^.left); + set_varstate(p^.left,true); + if codegenerror then + exit; + + if (p^.right^.resulttype^.deftype<>classrefdef) then + CGMessage(type_e_mismatch); + + left_right_max(p); + + { left must be a class } + if (p^.left^.resulttype^.deftype<>objectdef) or + not(pobjectdef(p^.left^.resulttype)^.is_class) then + CGMessage(type_e_mismatch); + + { the operands must be related } + if (not(pobjectdef(p^.left^.resulttype)^.is_related( + pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)))) and + (not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.pointertype.def)^.is_related( + pobjectdef(p^.left^.resulttype)))) then + CGMessage(type_e_mismatch); + + set_location(p^.location,p^.left^.location); + p^.resulttype:=pclassrefdef(p^.right^.resulttype)^.pointertype.def; + end; + + +begin + ctypeconvnode:=ttypeconvnode; + casnode:=tasnode; + cisnode:=tisnode; +end. +{ + $Log$ + Revision 1.1 2000-09-25 15:37:14 florian + * more fixes + +} \ No newline at end of file diff --git a/compiler/nld.pas b/compiler/nld.pas index 776ca73592..776fe9f99c 100644 --- a/compiler/nld.pas +++ b/compiler/nld.pas @@ -21,6 +21,9 @@ **************************************************************************** } unit nld; + +{$i defines.inc} + interface uses @@ -71,7 +74,7 @@ interface ttypenode = class(tnode) typenodetype : pdef; - typenodesym:ptypesym + typenodesym:ptypesym; constructor create(t : pdef;sym:ptypesym);virtual; function getcopy : tnode;override; function pass_1 : tnode;override; @@ -85,7 +88,11 @@ interface carrayconstructnode : class of tarrayconstructnode; ctypenode : class of ttypenode; + function genloadnode(v : pvarsym;st : psymtable) : tloadnode; function gentypenode(t : pdef;sym:ptypesym) : ttypenode; + function genloadcallnode(v: pprocsym;st: psymtable): tloadnode; + function genloadmethodcallnode(v: pprocsym;st: psymtable; mp: tnode): tloadnode; + function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : tloadnode; implementation @@ -108,8 +115,64 @@ implementation function genloadnode(v : pvarsym;st : psymtable) : tloadnode; + var + n : tloadnode; + begin - genloadnode:=cloadnode.create(v,st); + n:=cloadnode.create(v,st); +{$fidef NEWST} + n.resulttype:=v^.definition; +{$else NEWST} + n.resulttype:=v^.vartype.def; +{$endif NEWST} + genloadnode:=n: + end; + + function genloadcallnode(v: pprocsym;st: psymtable): tloadnode; + var + n : tloadnode; + + begin + n:=cloadnode.create(v,st); +{$ifdef NEWST} + n.resulttype:=nil; {We don't know which overloaded procedure is + wanted...} +{$else NEWST} + n.resulttype:=v^.definition; +{$endif NEWST} + genloadcallnode:=n; + end; + + function genloadmethodcallnode(v: pprocsym;st: psymtable; mp: tnode): tloadnode; + var + n : tloadnode; + + begin + n:=cloadnode.create(v,st); +{$ifdef NEWST} + n.resulttype:=nil; {We don't know which overloaded procedure is + wanted...} +{$else NEWST} + n.resulttype:=v^.definition; +{$endif NEWST} + p^.left:=mp; + genloadmethodcallnode:=v; + end; + + + function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : tloadnode; + + var + n : tloadnode; + + begin + n:=cloadnode.create(sym,st); +{$ifdef NEWST} + n.resulttype:=sym^.definition; +{$else NEWST} + n.resulttype:=sym^.typedconsttype.def; +{$endif NEWST} + gentypedconstloadnode:=n; end; function gentypenode(t : pdef;sym:ptypesym) : ttypenode; @@ -690,7 +753,9 @@ begin end. { $Log$ - Revision 1.1 2000-09-25 14:55:05 florian - * initial revision + Revision 1.2 2000-09-25 15:37:14 florian + * more fixes + Revision 1.1 2000/09/25 14:55:05 florian + * initial revision } \ No newline at end of file diff --git a/compiler/nmem.pas b/compiler/nmem.pas index 6a62dc3515..80c4a5b313 100644 --- a/compiler/nmem.pas +++ b/compiler/nmem.pas @@ -130,7 +130,7 @@ implementation globtype,systems, cutils,cobjects,verbose,globals, symconst,aasm,types, - htypechk,pass_1,ncal + htypechk,pass_1,ncal,nld {$ifdef newcg} ,cgbase {$else newcg} @@ -884,7 +884,10 @@ implementation end. { $Log$ - Revision 1.2 2000-09-25 15:05:25 florian + Revision 1.3 2000-09-25 15:37:14 florian + * more fixes + + Revision 1.2 2000/09/25 15:05:25 florian * some updates Revision 1.1 2000/09/25 09:58:22 florian diff --git a/compiler/nodeh.inc b/compiler/nodeh.inc index 99ec440908..044faeab57 100644 --- a/compiler/nodeh.inc +++ b/compiler/nodeh.inc @@ -204,7 +204,10 @@ nf_cargs, nf_cargswap, nf_forcevaria, - nf_novariaallowed + nf_novariaallowed, + + { ttypeconvnode } + nf_explizit ); tnodeflagset = set of tnodeflags; @@ -320,7 +323,10 @@ { $Log$ - Revision 1.5 2000-09-25 15:05:25 florian + Revision 1.6 2000-09-25 15:37:14 florian + * more fixes + + Revision 1.5 2000/09/25 15:05:25 florian * some updates Revision 1.4 2000/09/24 21:15:34 florian