From 4d6f20c0d47763a457959e120ac41e10cb8f90eb Mon Sep 17 00:00:00 2001 From: florian Date: Tue, 26 Sep 2000 14:59:34 +0000 Subject: [PATCH] * more conversion work done --- compiler/ncnv.pas | 507 ++++++++-------- compiler/ncon.pas | 316 +++++++++- compiler/ninl.pas | 1383 ++++++++++++++++++++++++++++++++++++++++++++ compiler/nodeh.inc | 10 +- 4 files changed, 1948 insertions(+), 268 deletions(-) create mode 100644 compiler/ninl.pas diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 879c4ace03..131bf37c55 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -27,7 +27,7 @@ unit ncnv; interface uses - node; + node,symtable; type ttypeconvnode = class(tunarynode) @@ -61,7 +61,7 @@ implementation uses globtype,systems,tokens, cutils,cobjects,verbose,globals, - symconst,symtable,aasm,types, + symconst,aasm,types, {$ifdef newcg} cgbase, {$else newcg} @@ -86,7 +86,7 @@ implementation procedure update_constsethi(p:pdef); begin - if ((p^.deftype=orddef) and + if ((deftype=orddef) and (porddef(p)^.high>=constsethi)) then begin constsethi:=porddef(p)^.high; @@ -101,7 +101,7 @@ implementation if constsethi>255 then constsethi:=255; end - else if ((p^.deftype=enumdef) and + else if ((deftype=enumdef) and (penumdef(p)^.max>=constsethi)) then begin if pd=nil then @@ -139,24 +139,24 @@ implementation constsetlo:=0; constsethi:=0; constp:=gensinglenode(setconstn,nil); - constp^.value_set:=constset; + constvalue_set:=constset; buildp:=constp; - if assigned(p^.left) then + if assigned(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 + if left.treetype=arrayconstructrangen then begin - p2:=p^.left^.left; - p3:=p^.left^.right; + p2:=left.left; + p3:=left.right; { node is not used anymore } - putnode(p^.left); + putnode(left); end else begin - p2:=p^.left; + p2:=left; p3:=nil; end; firstpass(p2); @@ -278,7 +278,7 @@ implementation buildp:=gennode(addn,buildp,p4); { load next and dispose current node } p2:=p; - p:=p^.right; + p:=right; putnode(p2); end; if (pd=nil) then @@ -293,7 +293,7 @@ implementation putnode(p); end; { set the initial set type } - constp^.resulttype:=new(psetdef,init(pd,constsethi)); + constresulttype:=new(psetdef,init(pd,constsethi)); { set the new tree } p:=buildp; end; @@ -304,31 +304,31 @@ implementation *****************************************************************************} type - tfirstconvproc = procedure(var p : ptree); + tfirstconvproc = procedure of object; 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) + if (left.location.loc<>LOC_REGISTER) and + (resulttype^.size>left.resulttype^.size) then + location.loc:=LOC_REGISTER; + if is_64bitint(resulttype) then + registers32:=max(registers32,2) else - p^.registers32:=max(p^.registers32,1); + registers32:=max(registers32,1); end; procedure first_cstring_to_pchar(var p : ptree); begin - p^.registers32:=1; - p^.location.loc:=LOC_REGISTER; + registers32:=1; + location.loc:=LOC_REGISTER; end; procedure first_string_to_chararray(var p : ptree); begin - p^.registers32:=1; - p^.location.loc:=LOC_REGISTER; + registers32:=1; + location.loc:=LOC_REGISTER; end; @@ -336,16 +336,16 @@ implementation var hp : ptree; begin - if pstringdef(p^.resulttype)^.string_typ<> - pstringdef(p^.left^.resulttype)^.string_typ then + if pstringdef(resulttype)^.string_typ<> + pstringdef(left.resulttype)^.string_typ then begin - if p^.left^.treetype=stringconstn then + if left.treetype=stringconstn then begin - p^.left^.stringtype:=pstringdef(p^.resulttype)^.string_typ; - p^.left^.resulttype:=p^.resulttype; + left.stringtype:=pstringdef(resulttype)^.string_typ; + left.resulttype:=resulttype; { remove typeconv node } hp:=p; - p:=p^.left; + p:=left; putnode(hp); exit; end @@ -354,10 +354,10 @@ implementation 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 + if pstringdef(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; + location.loc:=LOC_MEM; end; @@ -365,30 +365,30 @@ implementation var hp : ptree; begin - if p^.left^.treetype=ordconstn then + if left.treetype=ordconstn then begin - hp:=genstringconstnode(chr(p^.left^.value),st_default); - hp^.stringtype:=pstringdef(p^.resulttype)^.string_typ; + hp:=genstringconstnode(chr(left.value),st_default); + hp.stringtype:=pstringdef(resulttype)^.string_typ; firstpass(hp); disposetree(p); p:=hp; end else - p^.location.loc:=LOC_MEM; + location.loc:=LOC_MEM; end; procedure first_nothing(var p : ptree); begin - p^.location.loc:=LOC_MEM; + 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; + if registers32<1 then + registers32:=1; + location.loc:=LOC_REGISTER; end; @@ -396,17 +396,17 @@ implementation var t : ptree; begin - if p^.left^.treetype=ordconstn then + if left.treetype=ordconstn then begin - t:=genrealconstnode(p^.left^.value,pfloatdef(p^.resulttype)); + t:=genrealconstnode(left.value,pfloatdef(resulttype)); firstpass(t); disposetree(p); p:=t; exit; end; - if p^.registersfpu<1 then - p^.registersfpu:=1; - p^.location.loc:=LOC_FPU; + if registersfpu<1 then + registersfpu:=1; + location.loc:=LOC_FPU; end; @@ -414,17 +414,17 @@ implementation var t : ptree; begin - if p^.left^.treetype=ordconstn then + if left.treetype=ordconstn then begin - t:=genfixconstnode(p^.left^.value shl 16,p^.resulttype); + t:=genfixconstnode(left.value shl 16,resulttype); firstpass(t); disposetree(p); p:=t; exit; end; - if p^.registers32<1 then - p^.registers32:=1; - p^.location.loc:=LOC_REGISTER; + if registers32<1 then + registers32:=1; + location.loc:=LOC_REGISTER; end; @@ -432,20 +432,20 @@ implementation var t : ptree; begin - if p^.left^.treetype=fixconstn then + if left.treetype=fixconstn then begin - t:=genfixconstnode(round(p^.left^.value_real*65536),p^.resulttype); + t:=genfixconstnode(round(left.value_real*65536),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; + if registers32<1 then + registers32:=1; + if registersfpu<1 then + registersfpu:=1; + location.loc:=LOC_REGISTER; end; @@ -453,17 +453,17 @@ implementation var t : ptree; begin - if p^.left^.treetype=fixconstn then + if left.treetype=fixconstn then begin - t:=genrealconstnode(round(p^.left^.value_fix/65536.0),p^.resulttype); + t:=genrealconstnode(round(left.value_fix/65536.0),resulttype); firstpass(t); disposetree(p); p:=t; exit; end; - if p^.registersfpu<1 then - p^.registersfpu:=1; - p^.location.loc:=LOC_FPU; + if registersfpu<1 then + registersfpu:=1; + location.loc:=LOC_FPU; end; @@ -471,9 +471,9 @@ implementation var t : ptree; begin - if p^.left^.treetype=realconstn then + if left.treetype=realconstn then begin - t:=genrealconstnode(p^.left^.value_real,p^.resulttype); + t:=genrealconstnode(left.value_real,resulttype); firstpass(t); disposetree(p); p:=t; @@ -481,22 +481,22 @@ implementation 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 + if (pfloatdef(resulttype)^.typ=s64comp) and + (pfloatdef(left.resulttype)^.typ<>s64comp) and + not (explizit) then CGMessage(type_w_convert_real_2_comp); {$endif} - if p^.registersfpu<1 then - p^.registersfpu:=1; - p^.location.loc:=LOC_FPU; + if registersfpu<1 then + registersfpu:=1; + 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; + if registers32<1 then + registers32:=1; + location.loc:=LOC_REFERENCE; end; @@ -505,15 +505,15 @@ implementation { the only important information is the location of the } { result } { other stuff is done by firsttypeconv } - p^.location.loc:=LOC_MEM; + location.loc:=LOC_MEM; end; procedure first_cchar_to_pchar(var p : ptree); begin - p^.left:=gentypeconvnode(p^.left,cshortstringdef); + left:=gentypeconvnode(left,cshortstringdef); { convert constant char to constant string } - firstpass(p^.left); + firstpass(left); { evalute tree } firstpass(p); end; @@ -523,13 +523,13 @@ implementation 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 + if (explizit) and + (left.resulttype^.size=resulttype^.size) and + (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; + location.loc:=LOC_REGISTER; + if registers32<1 then + registers32:=1; end; @@ -537,43 +537,43 @@ implementation 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 + if (explizit) and + (left.resulttype^.size=resulttype^.size) and + (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then exit; - p^.location.loc:=LOC_REGISTER; + 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; + left:=gentypeconvnode(left,s32bitdef); + left.explizit:=true; + firstpass(left); } + if registers32<1 then + 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; + location.loc:=LOC_REGISTER; + if registers32<1 then + 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); + firstpass(left); if codegenerror then exit; - if (p^.left^.location.loc<>LOC_REFERENCE) then + if (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; + registers32:=left.registers32; + if registers32<1 then + registers32:=1; + location.loc:=LOC_REGISTER; end; @@ -586,9 +586,9 @@ implementation var t : ptree; begin - if p^.left^.treetype=ordconstn then + if left.treetype=ordconstn then begin - t:=genpointerconstnode(p^.left^.value,p^.resulttype); + t:=genpointerconstnode(left.value,resulttype); firstpass(t); disposetree(p); p:=t; @@ -601,15 +601,15 @@ implementation procedure first_pchar_to_string(var p : ptree); begin - p^.location.loc:=LOC_REFERENCE; + 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; + location.loc:=LOC_REGISTER; + if registers32<1 then + registers32:=1; end; @@ -617,11 +617,11 @@ implementation var hp : ptree; begin - if p^.left^.treetype<>arrayconstructn then + if left.treetype<>arrayconstructn then internalerror(5546); { remove typeconv node } hp:=p; - p:=p^.left; + p:=left; putnode(hp); { create a set constructor tree } arrayconstructor_to_set(p); @@ -665,20 +665,20 @@ implementation 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 + if (explizit) or not assigned(left.resulttype) then + firstpass(left); + if (left.treetype=typen) and (left.resulttype=generrordef) then begin codegenerror:=true; Message(parser_e_no_type_not_allowed_here); end; if codegenerror then begin - p^.resulttype:=generrordef; + resulttype:=generrordef; exit; end; - if not assigned(p^.left^.resulttype) then + if not assigned(left.resulttype) then begin codegenerror:=true; internalerror(52349); @@ -686,57 +686,57 @@ implementation end; { load the value_str from the left part } - p^.registers32:=p^.left^.registers32; - p^.registersfpu:=p^.left^.registersfpu; + registers32:=left.registers32; + registersfpu:=left.registersfpu; {$ifdef SUPPORT_MMX} - p^.registersmmx:=p^.left^.registersmmx; + registersmmx:=left.registersmmx; {$endif} - set_location(p^.location,p^.left^.location); + set_location(location,left.location); { remove obsolete type conversions } - if is_equal(p^.left^.resulttype,p^.resulttype) then + if is_equal(left.resulttype,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 + if (resulttype^.deftype=setdef) and + (left.resulttype^.deftype=setdef) and + (psetdef(resulttype)^.settype<>smallset) and + (psetdef(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 + if left.treetype=setconstn then begin - p^.resulttype:=p^.left^.resulttype; - psetdef(p^.resulttype)^.settype:=normset + resulttype:=left.resulttype; + psetdef(resulttype)^.settype:=normset end else - p^.convtyp:=tc_load_smallset; + convtyp:=tc_load_smallset; exit; end else begin hp:=p; - p:=p^.left; - p^.resulttype:=hp^.resulttype; + p:=left; + resulttype:=hp.resulttype; putnode(hp); exit; end; end; - aprocdef:=assignment_overloaded(p^.left^.resulttype,p^.resulttype); + aprocdef:=assignment_overloaded(left.resulttype,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); + hp.procdefinition:=aprocdef; + hp.left:=gencallparanode(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 + if isconvertable(left.resulttype,resulttype,convtyp,left.treetype,explizit)=0 then begin {Procedures have a resulttype of voiddef and functions of their own resulttype. They will therefore always be incompatible with @@ -744,35 +744,35 @@ implementation 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 + if (resulttype^.deftype=procvardef) and + (is_procsym_load(left) or is_procsym_call(left)) then begin - if is_procsym_call(p^.left) then + if is_procsym_call(left) then begin - {if p^.left^.right=nil then + {if 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)) + if (left.symtableprocentry^.owner^.symtabletype=objectsymtable){ and + (pobjectdef(left.symtableprocentry^.owner^.defowner)^.is_class) }then + hp:=genloadmethodcallnode(pprocsym(left.symtableprocentry),left.symtableproc, + getcopy(left.methodpointer)) else - hp:=genloadcallnode(pprocsym(p^.left^.symtableprocentry),p^.left^.symtableproc); - disposetree(p^.left); + hp:=genloadcallnode(pprocsym(left.symtableprocentry),left.symtableproc); + disposetree(left); firstpass(hp); - p^.left:=hp; - aprocdef:=pprocdef(p^.left^.resulttype); + left:=hp; + aprocdef:=pprocdef(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; + left.right.treetype:=loadn; + left.right.symtableentry:=left.right.symtableentry; + left.right.resulttype:=pvarsym(left.symtableentry)^.definition; + hp:=left.right; + putnode(left); + left:=hp; { should we do that ? } - firstpass(p^.left); - if not is_equal(p^.left^.resulttype,p^.resulttype) then + firstpass(left); + if not is_equal(left.resulttype,resulttype) then begin CGMessage(type_e_mismatch); exit; @@ -780,8 +780,8 @@ implementation else begin hp:=p; - p:=p^.left; - p^.resulttype:=hp^.resulttype; + p:=left; + resulttype:=hp.resulttype; putnode(hp); exit; end; @@ -789,57 +789,57 @@ implementation end else begin - if (p^.left^.treetype<>addrn) then - aprocdef:=pprocsym(p^.left^.symtableentry)^.definition; + if (left.treetype<>addrn) then + aprocdef:=pprocsym(left.symtableentry)^.definition; end; - p^.convtyp:=tc_proc_2_procvar; + 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); + if not proc_to_procvar_equal(aprocdef,pprocvardef(resulttype)) then + CGMessage2(type_e_incompatible_types,aprocdef^.typename,resulttype^.typename); + firstconvert[convtyp](p); end else - CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename); exit; end; end; - if p^.explizit then + if 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); + if not(resulttype^.is_intregable) and + not(resulttype^.is_fpuregable) then + make_not_regable(left); { boolean to byte are special because the location can be different } - if is_integer(p^.resulttype) and - is_boolean(p^.left^.resulttype) then + if is_integer(resulttype) and + is_boolean(left.resulttype) then begin - p^.convtyp:=tc_bool_2_int; - firstconvert[p^.convtyp](p); + convtyp:=tc_bool_2_int; + firstconvert[convtyp](p); exit; end; { ansistring to pchar } - if is_pchar(p^.resulttype) and - is_ansistring(p^.left^.resulttype) then + if is_pchar(resulttype) and + is_ansistring(left.resulttype) then begin - p^.convtyp:=tc_ansistring_2_pchar; - firstconvert[p^.convtyp](p); + convtyp:=tc_ansistring_2_pchar; + firstconvert[convtyp](p); exit; end; { do common tc_equal cast } - p^.convtyp:=tc_equal; + convtyp:=tc_equal; { enum to ordinal will always be s32bit } - if (p^.left^.resulttype^.deftype=enumdef) and - is_ordinal(p^.resulttype) then + if (left.resulttype^.deftype=enumdef) and + is_ordinal(resulttype) then begin - if p^.left^.treetype=ordconstn then + if left.treetype=ordconstn then begin - hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + hp:=genordinalconstnode(left.value,resulttype); disposetree(p); firstpass(hp); p:=hp; @@ -847,19 +847,19 @@ implementation 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); + if isconvertable(s32bitdef,resulttype,convtyp,ordconstn,false)=0 then + CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename); end; end { ordinal to enumeration } else - if (p^.resulttype^.deftype=enumdef) and - is_ordinal(p^.left^.resulttype) then + if (resulttype^.deftype=enumdef) and + is_ordinal(left.resulttype) then begin - if p^.left^.treetype=ordconstn then + if left.treetype=ordconstn then begin - hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + hp:=genordinalconstnode(left.value,resulttype); disposetree(p); firstpass(hp); p:=hp; @@ -867,16 +867,16 @@ implementation 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); + if IsConvertable(left.resulttype,s32bitdef,convtyp,ordconstn,false)=0 then + CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename); end; end { nil to ordinal node } - else if is_ordinal(p^.resulttype) and - (p^.left^.treetype=niln) then + else if is_ordinal(resulttype) and + (left.treetype=niln) then begin - hp:=genordinalconstnode(0,p^.resulttype); + hp:=genordinalconstnode(0,resulttype); firstpass(hp); disposetree(p); p:=hp; @@ -885,12 +885,12 @@ implementation {Are we typecasting an ordconst to a char?} else - if is_char(p^.resulttype) and - is_ordinal(p^.left^.resulttype) then + if is_char(resulttype) and + is_ordinal(left.resulttype) then begin - if p^.left^.treetype=ordconstn then + if left.treetype=ordconstn then begin - hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + hp:=genordinalconstnode(left.value,resulttype); firstpass(hp); disposetree(p); p:=hp; @@ -898,19 +898,19 @@ implementation 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); + if IsConvertable(left.resulttype,u8bitdef,convtyp,ordconstn,false)=0 then + CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename); end; end { Are we char to ordinal } else - if is_char(p^.left^.resulttype) and - is_ordinal(p^.resulttype) then + if is_char(left.resulttype) and + is_ordinal(resulttype) then begin - if p^.left^.treetype=ordconstn then + if left.treetype=ordconstn then begin - hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + hp:=genordinalconstnode(left.value,resulttype); firstpass(hp); disposetree(p); p:=hp; @@ -918,8 +918,8 @@ implementation 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); + if IsConvertable(u8bitdef,resulttype,convtyp,ordconstn,false)=0 then + CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename); end; end @@ -928,32 +928,32 @@ implementation 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)) + (left.resulttype^.deftype=formaldef) or + (left.resulttype^.size=resulttype^.size) or + (is_equal(left.resulttype,voiddef) and + (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 + if ((left.resulttype^.deftype=orddef) and + (resulttype^.deftype=pointerdef)) or + ((resulttype^.deftype=orddef) and + (left.resulttype^.deftype=pointerdef)) + {$ifdef extdebug}and (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 + if ((resulttype^.deftype in [recorddef,stringdef,arraydef]) or + ((resulttype^.deftype=objectdef) and not(pobjectdef(resulttype)^.is_class)) + ) and (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 + not assigned(assignment_overloaded(left.resulttype,resulttype))} then CGMessage(cg_e_illegal_type_conversion); end else - CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); + CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename); end; { tp7 procvar support, when right is not a procvardef and we got a @@ -961,31 +961,31 @@ implementation 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 + (resulttype^.deftype<>procvardef) and + (left.resulttype^.deftype=procvardef) and + (left.treetype=loadn) then begin hp:=gencallnode(nil,nil); - hp^.right:=p^.left; + hp.right:=left; firstpass(hp); - p^.left:=hp; + 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 + if (left.treetype=ordconstn) and is_ordinal(resulttype) and + not(is_64bitint(resulttype)) then begin { range checking is done in genordinalconstnode (PFV) } - hp:=genordinalconstnode(p^.left^.value,p^.resulttype); + hp:=genordinalconstnode(left.value,resulttype); disposetree(p); firstpass(hp); p:=hp; exit; end; - if p^.convtyp<>tc_equal then - firstconvert[p^.convtyp](p); + if convtyp<>tc_equal then + firstconvert[convtyp](p); end; @@ -1002,32 +1002,32 @@ implementation 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); + firstpass(left); + set_varstate(left,true); + firstpass(right); + set_varstate(right,true); if codegenerror then exit; - if (p^.right^.resulttype^.deftype<>classrefdef) then + if (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 + if (left.resulttype^.deftype<>objectdef) or + not(pobjectdef(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 + if (not(pobjectdef(left.resulttype)^.is_related( + pobjectdef(pclassrefdef(right.resulttype)^.pointertype.def)))) and + (not(pobjectdef(pclassrefdef(right.resulttype)^.pointertype.def)^.is_related( + pobjectdef(left.resulttype)))) then CGMessage(type_e_mismatch); - p^.location.loc:=LOC_FLAGS; - p^.resulttype:=booldef; + location.loc:=LOC_FLAGS; + resulttype:=booldef; end; @@ -1044,32 +1044,32 @@ implementation 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); + firstpass(right); + right.set_varstate(true); + firstpass(left); + left.set_varstate(true); if codegenerror then exit; - if (p^.right^.resulttype^.deftype<>classrefdef) then + if (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 + if (left.resulttype^.deftype<>objectdef) or + not(pobjectdef(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 + if (not(pobjectdef(left.resulttype)^.is_related( + pobjectdef(pclassrefdef(right.resulttype)^.pointertype.def)))) and + (not(pobjectdef(pclassrefdef(right.resulttype)^.pointertype.def)^.is_related( + pobjectdef(left.resulttype)))) then CGMessage(type_e_mismatch); - set_location(p^.location,p^.left^.location); - p^.resulttype:=pclassrefdef(p^.right^.resulttype)^.pointertype.def; + set_location(location,left.location); + resulttype:=pclassrefdef(right.resulttype)^.pointertype.def; end; @@ -1080,7 +1080,10 @@ begin end. { $Log$ - Revision 1.1 2000-09-25 15:37:14 florian + Revision 1.2 2000-09-26 14:59:34 florian + * more conversion work done + + Revision 1.1 2000/09/25 15:37:14 florian * more fixes } \ No newline at end of file diff --git a/compiler/ncon.pas b/compiler/ncon.pas index 3ad51d7f40..95a181d363 100644 --- a/compiler/ncon.pas +++ b/compiler/ncon.pas @@ -1,6 +1,6 @@ { $Id$ - Copyright (c) 1998-2000 by Florian Klaempfl + Copyright (c) 2000 by Florian Klaempfl Type checking and register allocation for constants @@ -27,66 +27,172 @@ unit ncon; interface uses - globtype,node,aasm,cpuinfo,symconst; + globtype,node,aasm,cpuinfo,symconst,symtable; type trealconstnode = class(tnode) value_real : bestreal; lab_real : pasmlabel; - // !!!!!!! needs at least create, getcopy + constructor create(v : bestreal;def : pdef);virtual; + function getcopy : tnode;override; function pass_1 : tnode;override; end; tfixconstnode = class(tnode) value_fix: longint; - // !!!!!!! needs at least create, getcopy + constructor create(v : longint;def : pdef);virtual; + function getcopy : tnode;override; function pass_1 : tnode;override; end; tordconstnode = class(tnode) value : TConstExprInt; - // !!!!!!! needs at least create, getcopy + constructor create(v : tconstexprint;def : pdef);virtual; + function getcopy : tnode;override; function pass_1 : tnode;override; end; tpointerconstnode = class(tnode) value : TPointerOrd; - // !!!!!!! needs at least create, getcopy + constructor create(v : tpointerord;def : pdef);virtual; + function getcopy : tnode;override; function pass_1 : tnode;override; end; tstringconstnode = class(tnode) value_str : pchar; - length : longint; + len : longint; lab_str : pasmlabel; stringtype : tstringtype; - // !!!!!!! needs at least create, getcopy, destroy + constructor createstr(const s : string;st:tstringtype);virtual; + constructor createpchar(s : pchar;l : longint);virtual; + function getcopy : tnode;override; function pass_1 : tnode;override; + function getpcharcopy : pchar; end; - tsetconstnode = class(tnode) + tsetconstnode = class(tunarynode) value_set : pconstset; lab_set : pasmlabel; - // !!!!!!! needs at least create, getcopy + constructor create(s : pconstset;settype : psetdef);virtual; + function getcopy : tnode;override; function pass_1 : tnode;override; end; tnilnode = class(tnode) - // !!!!!!! needs at least create + constructor create;virtual; function pass_1 : tnode;override; end; + var + crealconstnode : class of trealconstnode; + cfixconstnode : class of tfixconstnode; + cordconstnode : class of tordconstnode; + cpointerconstnode : class of tpointerconstnode; + cstringconstnode : class of tstringconstnode; + csetconstnode : class of tsetconstnode; + cnilnode : class of tnilnode; + + function genordinalconstnode(v : TConstExprInt;def : pdef) : tordconstnode; + { same as genordinalconstnode, but the resulttype } + { is determines automatically } + function genintconstnode(v : TConstExprInt) : tordconstnode; + function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode; + function genenumnode(v : penumsym) : tordconstnode; + function genfixconstnode(v : longint;def : pdef) : tfixconstnode; + function genrealconstnode(v : bestreal;def : pdef) : trealconstnode; + { allow pchar or string for defining a pchar node } + function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode; + { length is required for ansistrings } + function genpcharconstnode(s : pchar;length : longint) : tstringconstnode; + + function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode; + implementation uses cobjects,verbose,globals,systems, - symtable,types, - hcodegen,pass_1,cpubase; + types,hcodegen,pass_1,cpubase; + + function genordinalconstnode(v : tconstexprint;def : pdef) : tordconstnode; + begin + genordinalconstnode:=cordconstnode.create(v,def); + end; + + function genintconstnode(v : TConstExprInt) : tordconstnode; + + var + i : TConstExprInt; + + begin + { we need to bootstrap this code, so it's a little bit messy } + i:=2147483647; + if (v<=i) and (v>=-i-1) then + genintconstnode:=genordinalconstnode(v,s32bitdef) + else + genintconstnode:=genordinalconstnode(v,cs64bitdef); + end; + + function genpointerconstnode(v : tpointerord;def : pdef) : tpointerconstnode; + begin + genpointerconstnode:=cpointerconstnode.create(v,def); + end; + + function genenumnode(v : penumsym) : tordconstnode; + begin + genenumnode:=cordconstnode.create(v^.value,v^.definition); + end; + + function gensetconstnode(s : pconstset;settype : psetdef) : tsetconstnode; + begin + gensetconstnode:=csetconstnode.create(s,settype); + end; + + function genrealconstnode(v : bestreal;def : pdef) : trealconstnode; + begin + genrealconstnode:=crealconstnode.create(v,def); + end; + + function genfixconstnode(v : longint;def : pdef) : tfixconstnode; + begin + genfixconstnode:=cfixconstnode.create(v,def); + end; + + function genstringconstnode(const s : string;st:tstringtype) : tstringconstnode; + begin + genstringconstnode:=cstringconstnode.createstr(s,st); + end; + + function genpcharconstnode(s : pchar;length : longint) : tstringconstnode; + begin + genpcharconstnode:=cstringconstnode.createpchar(s,length); + end; {***************************************************************************** TREALCONSTNODE *****************************************************************************} + constructor trealconstnode.create(v : bestreal;def : pdef); + + begin + inherited create(realconstn); + resulttype:=def; + value_real:=v; + lab_real:=nil; + end; + + function trealconstnode.getcopy : tnode; + + var + n : trealconstnode; + + begin + n:=trealconstnode(inherited getcopy); + n.value_real:=value_real; + n.lab_real:=lab_real; + getcopy:=n; + end; + function trealconstnode.pass_1 : tnode; begin pass_1:=nil; @@ -104,7 +210,27 @@ implementation TFIXCONSTNODE *****************************************************************************} + constructor tfixconstnode.create(v : longint;def : pdef); + + begin + inherited create(fixconstn); + resulttype:=def; + value_fix:=v; + end; + + function tfixconstnode.getcopy : tnode; + + var + n : tfixconstnode; + + begin + n:=tfixconstnode(inherited getcopy); + n.value_fix:=value_fix; + getcopy:=n; + end; + function tfixconstnode.pass_1 : tnode; + begin pass_1:=nil; location.loc:=LOC_MEM; @@ -115,6 +241,32 @@ implementation TORDCONSTNODE *****************************************************************************} + constructor tordconstnode.create(v : tconstexprint;def : pdef); + + begin + inherited create(ordconstn); + value:=v; + resulttype:=def; +{$ifdef NEWST} + if typeof(resulttype^)=typeof(Torddef) then + testrange(resulttype,value); +{$else NEWST} + if resulttype^.deftype=orddef then + testrange(resulttype,value); +{$endif ELSE} + end; + + function tordconstnode.getcopy : tnode; + + var + n : tordconstnode; + + begin + n:=tordconstnode(inherited getcopy); + n.value:=value; + getcopy:=n; + end; + function tordconstnode.pass_1 : tnode; begin pass_1:=nil; @@ -126,6 +278,25 @@ implementation TPOINTERCONSTNODE *****************************************************************************} + constructor tpointerconstnode.create(v : tpointerord;def : pdef); + + begin + inherited create(pointerconstn); + value:=v; + resulttype:=def; + end; + + function tpointerconstnode.getcopy : tnode; + + var + n : tpointerconstnode; + + begin + n:=tpointerconstnode(inherited getcopy); + n.value:=value; + getcopy:=n; + end; + function tpointerconstnode.pass_1 : tnode; begin pass_1:=nil; @@ -137,6 +308,72 @@ implementation TSTRINGCONSTNODE *****************************************************************************} + constructor tstringconstnode.createstr(const s : string;st:tstringtype); + + var + l : longint; + + begin + inherited create(stringconstn); + l:=length(s); + len:=l; + { stringdup write even past a #0 } + getmem(value_str,l+1); + move(s[1],value_str^,l); + value_str[l]:=#0; + lab_str:=nil; + if st=st_default then + begin + if cs_ansistrings in aktlocalswitches then + stringtype:=st_ansistring + else + stringtype:=st_shortstring; + end + else + stringtype:=st; + case stringtype of + st_shortstring : + resulttype:=cshortstringdef; + st_ansistring : + resulttype:=cansistringdef; + else + internalerror(44990099); + end; + end; + + constructor tstringconstnode.createpchar(s : pchar;l : longint); + + begin + inherited create(stringconstn); + len:=l; + if (cs_ansistrings in aktlocalswitches) or + (len>255) then + begin + stringtype:=st_ansistring; + resulttype:=cansistringdef; + end + else + begin + stringtype:=st_shortstring; + resulttype:=cshortstringdef; + end; + value_str:=s; + lab_str:=nil; + end; + + function tstringconstnode.getcopy : tnode; + + var + n : tstringconstnode; + + begin + n:=tstringconstnode(inherited getcopy); + n.stringtype:=stringtype; + n.len:=len; + n.value_str:=getpcharcopy; + n.lab_str:=lab_str; + end; + function tstringconstnode.pass_1 : tnode; begin pass_1:=nil; @@ -157,11 +394,45 @@ implementation location.loc:=LOC_MEM; end; + function tstringconstnode.getpcharcopy : pchar; + var + pc : pchar; + begin + pc:=nil; + getmem(pc,len+1); + if pc=nil then + Message(general_f_no_memory_left); + move(value_str^,pc^,len+1); + getpcharcopy:=pc; + end; + {***************************************************************************** TSETCONSTNODE *****************************************************************************} + constructor tsetconstnode.create(s : pconstset;settype : psetdef); + + begin + inherited create(setconstn,nil); + resulttype:=settype; + new(value_set); + value_set^:=s^; + end; + + function tsetconstnode.getcopy : tnode; + + var + n : tsetconstnode; + + begin + n:=tsetconstnode(inherited getcopy); + new(n.value_set); + n.value_set^:=value_set^; + n.lab_set:=lab_set; + getcopy:=n; + end; + function tsetconstnode.pass_1 : tnode; begin pass_1:=nil; @@ -172,6 +443,12 @@ implementation TNILNODE *****************************************************************************} + constructor tnilnode.create; + + begin + inherited create(niln); + end; + function tnilnode.pass_1 : tnode; begin pass_1:=nil; @@ -179,10 +456,21 @@ implementation location.loc:=LOC_MEM; end; +begin + crealconstnode:=trealconstnode; + cfixconstnode:=tfixconstnode; + cordconstnode:=tordconstnode; + cpointerconstnode:=tpointerconstnode; + cstringconstnode:=tstringconstnode; + csetconstnode:=tsetconstnode; + cnilnode:=tnilnode; end. { $Log$ - Revision 1.3 2000-09-24 21:15:34 florian + Revision 1.4 2000-09-26 14:59:34 florian + * more conversion work done + + Revision 1.3 2000/09/24 21:15:34 florian * some errors fix to get more stuff compilable Revision 1.2 2000/09/24 15:06:19 peter diff --git a/compiler/ninl.pas b/compiler/ninl.pas new file mode 100644 index 0000000000..9079c32441 --- /dev/null +++ b/compiler/ninl.pas @@ -0,0 +1,1383 @@ +{ + $Id$ + Copyright (c) 1998-2000 by Florian Klaempfl + + Type checking and register allocation for inline 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 ninl; + +{$i defines.inc} + +interface + + uses + node; + + type + type + tinlinenode = class(tunarynode) + inlinenumber : byte; + constructor create(number : byte;is_const:boolean;l : tnode);virtual; + function getcopy : tnode;override; + function pass_1 : tnode;override; + end; + + var + cinlinenode : class of tinlinenode; + + function geninlinenode(number : byte;is_const:boolean;l : tnode) : tinlinenode; + +implementation + + uses + cobjects,verbose,globals,systems, + globtype, + symconst,symtable,aasm,types, + htypechk,pass_1, + ncal,cpubase +{$ifdef newcg} + ,cgbase + ,tgobj + ,tgcpu +{$else newcg} + ,hcodegen +{$ifdef i386} + ,tgeni386 +{$endif} +{$endif newcg} + ; + + function geninlinenode(number : byte;is_const:boolean;l : tnode) : tinlinenode; + + begin + geninlinenode:=cinlinenode.create(number,is_const,l); + end: + +{***************************************************************************** + TINLINENODE +*****************************************************************************} + + constructor tinlinenode.create(number : byte;is_const:boolean;l : tnode); + + begin + inherited create(inlinen,l); + if is_const then + include(flags,nf_is_const); + inlinenumber:=number; + end; + + function tinlinenode.getcopy : tnode; + + var + n : tinlinenode; + + begin + n:=tinlinenode(inherited getcopy); + n.inlinenumber:=inlinenumber; + end; + +{$ifdef fpc} +{$maxfpuregisters 0} +{$endif fpc} + function tinlinenode.pass_1 : tnode;override; + var + vl,vl2 : longint; + vr : bestreal; + p1,hp,hpp : tnode; +{$ifndef NOCOLONCHECK} + frac_para,length_para : tnode; +{$endif ndef NOCOLONCHECK} + extra_register, + isreal, + dowrite, + file_is_typed : boolean; + + procedure do_lowhigh(adef : pdef); + + var + v : longint; + enum : penumsym; + + begin + case Adef^.deftype of + orddef: + begin + if inlinenumber=in_low_x then + v:=porddef(adef)^.low + else + v:=porddef(adef)^.high; + hp:=genordinalconstnode(v,adef); + firstpass(hp); + disposetree(p); + p:=hp; + end; + enumdef: + begin + enum:=Penumdef(Adef)^.firstenum; + if inlinenumber=in_high_x then + while enum^.nextenum<>nil do + enum:=enum^.nextenum; + hp:=genenumnode(enum); + disposetree(p); + p:=hp; + end; + else + internalerror(87); + end; + end; + + function getconstrealvalue : bestreal; + + begin + case left.treetype of + ordconstn: + getconstrealvalue:=left.value; + realconstn: + getconstrealvalue:=left.value_real; + else + internalerror(309992); + end; + end; + + procedure setconstrealvalue(r : bestreal); + + var + hp : tnode; + + begin + hp:=genrealconstnode(r,bestrealdef^); + disposetree(p); + p:=hp; + firstpass(p); + end; + + procedure handleextendedfunction; + + begin + location.loc:=LOC_FPU; + resulttype:=s80floatdef; + { redo firstpass for varstate status PM } + set_varstate(left,true); + if (left.resulttype^.deftype<>floatdef) or + (pfloatdef(left.resulttype)^.typ<>s80real) then + begin + left:=gentypeconvnode(left,s80floatdef); + firstpass(left); + end; + registers32:=left.registers32; + registersfpu:=left.registersfpu; +{$ifdef SUPPORT_MMX} + registersmmx:=left.registersmmx; +{$endif SUPPORT_MMX} + end; + + begin + { if we handle writeln; left contains no valid address } + if assigned(left) then + begin + if left.treetype=callparan then + firstcallparan(left,nil,false) + else + firstpass(left); + left_right_max(p); + set_location(location,left.location); + end; + inc(parsing_para_level); + { handle intern constant functions in separate case } + if inlineconst then + begin + hp:=nil; + { no parameters? } + if not assigned(left) then + begin + case inlinenumber of + in_const_pi : + hp:=genrealconstnode(pi,bestrealdef^); + else + internalerror(89); + end; + end + else + { process constant expression with parameter } + begin + vl:=0; + vl2:=0; { second parameter Ex: ptr(vl,vl2) } + vr:=0; + isreal:=false; + case left.treetype of + realconstn : + begin + isreal:=true; + vr:=left.value_real; + end; + ordconstn : + vl:=left.value; + callparan : + begin + { both exists, else it was not generated } + vl:=left.left.value; + vl2:=left.right.left.value; + end; + else + CGMessage(cg_e_illegal_expression); + end; + case inlinenumber of + in_const_trunc : + begin + if isreal then + begin + if (vr>=2147483648.0) or (vr<=-2147483649.0) then + begin + CGMessage(parser_e_range_check_error); + hp:=genordinalconstnode(1,s32bitdef) + end + else + hp:=genordinalconstnode(trunc(vr),s32bitdef) + end + else + hp:=genordinalconstnode(trunc(vl),s32bitdef); + end; + in_const_round : + begin + if isreal then + begin + if (vr>=2147483647.5) or (vr<=-2147483648.5) then + begin + CGMessage(parser_e_range_check_error); + hp:=genordinalconstnode(1,s32bitdef) + end + else + hp:=genordinalconstnode(round(vr),s32bitdef) + end + else + hp:=genordinalconstnode(round(vl),s32bitdef); + end; + in_const_frac : + begin + if isreal then + hp:=genrealconstnode(frac(vr),bestrealdef^) + else + hp:=genrealconstnode(frac(vl),bestrealdef^); + end; + in_const_int : + begin + if isreal then + hp:=genrealconstnode(int(vr),bestrealdef^) + else + hp:=genrealconstnode(int(vl),bestrealdef^); + end; + in_const_abs : + begin + if isreal then + hp:=genrealconstnode(abs(vr),bestrealdef^) + else + hp:=genordinalconstnode(abs(vl),left.resulttype); + end; + in_const_sqr : + begin + if isreal then + hp:=genrealconstnode(sqr(vr),bestrealdef^) + else + hp:=genordinalconstnode(sqr(vl),left.resulttype); + end; + in_const_odd : + begin + if isreal then + CGMessage1(type_e_integer_expr_expected,left.resulttype^.typename) + else + hp:=genordinalconstnode(byte(odd(vl)),booldef); + end; + in_const_swap_word : + begin + if isreal then + CGMessage1(type_e_integer_expr_expected,left.resulttype^.typename) + else + hp:=genordinalconstnode((vl and $ff) shl 8+(vl shr 8),left.resulttype); + end; + in_const_swap_long : + begin + if isreal then + CGMessage(type_e_mismatch) + else + hp:=genordinalconstnode((vl and $ffff) shl 16+(vl shr 16),left.resulttype); + end; + in_const_ptr : + begin + if isreal then + CGMessage(type_e_mismatch) + else + hp:=genordinalconstnode((vl2 shl 16) or vl,voidpointerdef); + end; + in_const_sqrt : + begin + if isreal then + begin + if vr<0.0 then + CGMessage(type_e_wrong_math_argument) + else + hp:=genrealconstnode(sqrt(vr),bestrealdef^) + end + else + begin + if vl<0 then + CGMessage(type_e_wrong_math_argument) + else + hp:=genrealconstnode(sqrt(vl),bestrealdef^); + end; + end; + in_const_arctan : + begin + if isreal then + hp:=genrealconstnode(arctan(vr),bestrealdef^) + else + hp:=genrealconstnode(arctan(vl),bestrealdef^); + end; + in_const_cos : + begin + if isreal then + hp:=genrealconstnode(cos(vr),bestrealdef^) + else + hp:=genrealconstnode(cos(vl),bestrealdef^); + end; + in_const_sin : + begin + if isreal then + hp:=genrealconstnode(sin(vr),bestrealdef^) + else + hp:=genrealconstnode(sin(vl),bestrealdef^); + end; + in_const_exp : + begin + if isreal then + hp:=genrealconstnode(exp(vr),bestrealdef^) + else + hp:=genrealconstnode(exp(vl),bestrealdef^); + end; + in_const_ln : + begin + if isreal then + begin + if vr<=0.0 then + CGMessage(type_e_wrong_math_argument) + else + hp:=genrealconstnode(ln(vr),bestrealdef^) + end + else + begin + if vl<=0 then + CGMessage(type_e_wrong_math_argument) + else + hp:=genrealconstnode(ln(vl),bestrealdef^); + end; + end; + else + internalerror(88); + end; + end; + disposetree(p); + if hp=nil then + hp:=genzeronode(errorn); + firstpass(hp); + p:=hp; + end + else + begin + case inlinenumber of + in_lo_qword, + in_hi_qword, + in_lo_long, + in_hi_long, + in_lo_word, + in_hi_word: + + begin + set_varstate(left,true); + if registers32<1 then + registers32:=1; + if inlinenumber in [in_lo_word,in_hi_word] then + resulttype:=u8bitdef + else if inlinenumber in [in_lo_qword,in_hi_qword] then + begin + resulttype:=u32bitdef; + if (m_tp in aktmodeswitches) or + (m_delphi in aktmodeswitches) then + CGMessage(type_w_maybe_wrong_hi_lo); + end + else + begin + resulttype:=u16bitdef; + if (m_tp in aktmodeswitches) or + (m_delphi in aktmodeswitches) then + CGMessage(type_w_maybe_wrong_hi_lo); + end; + location.loc:=LOC_REGISTER; + if not is_integer(left.resulttype) then + CGMessage(type_e_mismatch) + else + begin + if left.treetype=ordconstn then + begin + case inlinenumber of + in_lo_word : hp:=genordinalconstnode(left.value and $ff,left.resulttype); + in_hi_word : hp:=genordinalconstnode(left.value shr 8,left.resulttype); + in_lo_long : hp:=genordinalconstnode(left.value and $ffff,left.resulttype); + in_hi_long : hp:=genordinalconstnode(left.value shr 16,left.resulttype); + in_lo_qword : hp:=genordinalconstnode(left.value and $ffffffff,left.resulttype); + in_hi_qword : hp:=genordinalconstnode(left.value shr 32,left.resulttype); + end; + disposetree(p); + firstpass(hp); + p:=hp; + end; + end; + end; + + in_sizeof_x: + begin + set_varstate(left,false); + if push_high_param(left.resulttype) then + begin + getsymonlyin(left.symtable,'high'+pvarsym(left.symtableentry)^.name); + hp:=gennode(addn,genloadnode(pvarsym(srsym),left.symtable), + genordinalconstnode(1,s32bitdef)); + if (left.resulttype^.deftype=arraydef) and + (parraydef(left.resulttype)^.elesize<>1) then + hp:=gennode(muln,hp,genordinalconstnode(parraydef(left.resulttype)^.elesize,s32bitdef)); + disposetree(p); + p:=hp; + firstpass(p); + end; + if registers32<1 then + registers32:=1; + resulttype:=s32bitdef; + location.loc:=LOC_REGISTER; + end; + + in_typeof_x: + begin + set_varstate(left,false); + if registers32<1 then + registers32:=1; + location.loc:=LOC_REGISTER; + resulttype:=voidpointerdef; + end; + + in_ord_x: + begin + set_varstate(left,true); + if (left.treetype=ordconstn) then + begin + hp:=genordinalconstnode(left.value,s32bitdef); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + { otherwise you get a crash if you try ord on an expression containing } + { an undeclared variable (JM) } + if not assigned(left.resulttype) then + exit; + if (left.resulttype^.deftype=orddef) then + if (porddef(left.resulttype)^.typ in [uchar,uwidechar,bool8bit]) then + case porddef(left.resulttype)^.typ of + uchar: + begin + hp:=gentypeconvnode(left,u8bitdef); + putnode(p); + p:=hp; + explizit:=true; + firstpass(p); + end; + uwidechar: + begin + hp:=gentypeconvnode(left,u16bitdef); + putnode(p); + p:=hp; + explizit:=true; + firstpass(p); + end; + bool8bit: + begin + hp:=gentypeconvnode(left,u8bitdef); + putnode(p); + p:=hp; + convtyp:=tc_bool_2_int; + explizit:=true; + firstpass(p); + end + end + { can this happen ? } + else if (porddef(left.resulttype)^.typ=uvoid) then + CGMessage(type_e_mismatch) + else + { all other orddef need no transformation } + begin + hp:=left; + putnode(p); + p:=hp; + end + else if (left.resulttype^.deftype=enumdef) then + begin + hp:=gentypeconvnode(left,s32bitdef); + putnode(p); + p:=hp; + explizit:=true; + firstpass(p); + end + else + begin + { can anything else be ord() ?} + CGMessage(type_e_mismatch); + end; + end; + end; + + in_chr_byte: + begin + set_varstate(left,true); + hp:=gentypeconvnode(left,cchardef); + putnode(p); + p:=hp; + explizit:=true; + firstpass(p); + end; + + in_length_string: + begin + set_varstate(left,true); + if is_ansistring(left.resulttype) then + resulttype:=s32bitdef + else + resulttype:=u8bitdef; + { we don't need string conversations here } + if (left.treetype=typeconvn) and + (left.left.resulttype^.deftype=stringdef) then + begin + hp:=left.left; + putnode(left); + left:=hp; + end; + + { check the type, must be string or char } + if (left.resulttype^.deftype<>stringdef) and + (not is_char(left.resulttype)) then + CGMessage(type_e_mismatch); + + { evaluates length of constant strings direct } + if (left.treetype=stringconstn) then + begin + hp:=genordinalconstnode(left.length,s32bitdef); + disposetree(p); + firstpass(hp); + p:=hp; + end + { length of char is one allways } + else if is_constcharnode(left) then + begin + hp:=genordinalconstnode(1,s32bitdef); + disposetree(p); + firstpass(hp); + p:=hp; + end; + end; + + in_typeinfo_x: + begin + resulttype:=voidpointerdef; + location.loc:=LOC_REGISTER; + registers32:=1; + end; + + in_assigned_x: + begin + set_varstate(left,true); + resulttype:=booldef; + location.loc:=LOC_FLAGS; + end; + + in_ofs_x, + in_seg_x : + set_varstate(left,false); + in_pred_x, + in_succ_x: + begin + resulttype:=left.resulttype; + if is_64bitint(resulttype) then + begin + if (registers32<2) then + registers32:=2 + end + else + begin + if (registers32<1) then + registers32:=1; + end; + location.loc:=LOC_REGISTER; + set_varstate(left,true); + if not is_ordinal(resulttype) then + CGMessage(type_e_ordinal_expr_expected) + else + begin + if (resulttype^.deftype=enumdef) and + (penumdef(resulttype)^.has_jumps) then + CGMessage(type_e_succ_and_pred_enums_with_assign_not_possible) + else + if left.treetype=ordconstn then + begin + if inlinenumber=in_succ_x then + hp:=genordinalconstnode(left.value+1,left.resulttype) + else + hp:=genordinalconstnode(left.value-1,left.resulttype); + disposetree(p); + firstpass(hp); + p:=hp; + end; + end; + end; + + in_inc_x, + in_dec_x: + begin + resulttype:=voiddef; + if assigned(left) then + begin + firstcallparan(left,nil,true); + set_varstate(left,true); + if codegenerror then + exit; + { first param must be var } + valid_for_assign(left.left,false); + { check type } + if (left.resulttype^.deftype in [enumdef,pointerdef]) or + is_ordinal(left.resulttype) then + begin + { two paras ? } + if assigned(left.right) then + begin + { insert a type conversion } + { the second param is always longint } + left.right.left:=gentypeconvnode(left.right.left,s32bitdef); + { check the type conversion } + firstpass(left.right.left); + + { need we an additional register ? } + if not(is_constintnode(left.right.left)) and + (left.right.left.location.loc in [LOC_MEM,LOC_REFERENCE]) and + (left.right.left.registers32<=1) then + inc(registers32); + + { do we need an additional register to restore the first parameter? } + if left.right.left.registers32>=registers32 then + inc(registers32); + + if assigned(left.right.right) then + CGMessage(cg_e_illegal_expression); + end; + end + else + CGMessage(type_e_ordinal_expr_expected); + end + else + CGMessage(type_e_mismatch); + end; + + in_read_x, + in_readln_x, + in_write_x, + in_writeln_x : + begin + { needs a call } + procinfo^.flags:=procinfo^.flags or pi_do_call; + resulttype:=voiddef; + { true, if readln needs an extra register } + extra_register:=false; + { we must know if it is a typed file or not } + { but we must first do the firstpass for it } + file_is_typed:=false; + if assigned(left) then + begin + dowrite:=(inlinenumber in [in_write_x,in_writeln_x]); + firstcallparan(left,nil,true); + set_varstate(left,dowrite); + { now we can check } + hp:=left; + while assigned(hp.right) do + hp:=hp.right; + { if resulttype is not assigned, then automatically } + { file is not typed. } + if assigned(hp) and assigned(hp.resulttype) then + Begin + if (hp.resulttype^.deftype=filedef) then + if (pfiledef(hp.resulttype)^.filetyp=ft_untyped) then + begin + if (inlinenumber in [in_readln_x,in_writeln_x]) then + CGMessage(type_e_no_readln_writeln_for_typed_file) + else + CGMessage(type_e_no_read_write_for_untyped_file); + end + else if (pfiledef(hp.resulttype)^.filetyp=ft_typed) then + begin + file_is_typed:=true; + { test the type } + if (inlinenumber in [in_readln_x,in_writeln_x]) then + CGMessage(type_e_no_readln_writeln_for_typed_file); + hpp:=left; + while (hpp<>hp) do + begin + if (hpp.left.treetype=typen) then + CGMessage(type_e_cant_read_write_type); + if not is_equal(hpp.resulttype,pfiledef(hp.resulttype)^.typedfiletype.def) then + CGMessage(type_e_mismatch); + { generate the high() value for the shortstring } + if ((not dowrite) and is_shortstring(hpp.left.resulttype)) or + (is_chararray(hpp.left.resulttype)) then + gen_high_tree(hpp,true); + { read(ln) is call by reference (JM) } + if not dowrite then + make_not_regable(hpp.left); + hpp:=hpp.right; + end; + end; + end; { endif assigned(hp) } + + { insert type conversions for write(ln) } + if (not file_is_typed) then + begin + hp:=left; + while assigned(hp) do + begin + incrementregisterpushed($ff); + if (hp.left.treetype=typen) then + CGMessage(type_e_cant_read_write_type); + if assigned(hp.left.resulttype) then + begin + isreal:=false; + { support writeln(procvar) } + if (hp.left.resulttype^.deftype=procvardef) then + begin + p1:=gencallnode(nil,nil); + p1^.right:=hp.left; + p1^.resulttype:=pprocvardef(hp.left.resulttype)^.rettype.def; + firstpass(p1); + hp.left:=p1; + end; + case hp.left.resulttype^.deftype of + filedef : + begin + { only allowed as first parameter } + if assigned(hp.right) then + CGMessage(type_e_cant_read_write_type); + end; + stringdef : + begin + { generate the high() value for the shortstring } + if (not dowrite) and + is_shortstring(hp.left.resulttype) then + gen_high_tree(hp,true); + end; + pointerdef : + begin + if not is_pchar(hp.left.resulttype) then + CGMessage(type_e_cant_read_write_type); + end; + floatdef : + begin + isreal:=true; + end; + orddef : + begin + case porddef(hp.left.resulttype)^.typ of + uchar, + u32bit,s32bit, + u64bit,s64bit: + ; + u8bit,s8bit, + u16bit,s16bit : + if dowrite then + hp.left:=gentypeconvnode(hp.left,s32bitdef); + bool8bit, + bool16bit, + bool32bit : + if dowrite then + hp.left:=gentypeconvnode(hp.left,booldef) + else + CGMessage(type_e_cant_read_write_type); + else + CGMessage(type_e_cant_read_write_type); + end; + if not(dowrite) and + not(is_64bitint(hp.left.resulttype)) then + extra_register:=true; + end; + arraydef : + begin + if is_chararray(hp.left.resulttype) then + gen_high_tree(hp,true) + else + CGMessage(type_e_cant_read_write_type); + end; + else + CGMessage(type_e_cant_read_write_type); + end; + + { some format options ? } + if hp.is_colon_para then + begin + if hp.right.is_colon_para then + begin + frac_para:=hp; + length_para:=hp.right; + hp:=hp.right; + hpp:=hp.right; + end + else + begin + length_para:=hp; + frac_para:=nil; + hpp:=hp.right; + end; + { can be nil if you use "write(e:0:6)" while e is undeclared (JM) } + if assigned(hpp.left.resulttype) then + isreal:=(hpp.left.resulttype^.deftype=floatdef) + else exit; + if (not is_integer(length_para^.left.resulttype)) then + CGMessage1(type_e_integer_expr_expected,length_para^.left.resulttype^.typename) + else + length_para^.left:=gentypeconvnode(length_para^.left,s32bitdef); + if assigned(frac_para) then + begin + if isreal then + begin + if (not is_integer(frac_para^.left.resulttype)) then + CGMessage1(type_e_integer_expr_expected,frac_para^.left.resulttype^.typename) + else + frac_para^.left:=gentypeconvnode(frac_para^.left,s32bitdef); + end + else + CGMessage(parser_e_illegal_colon_qualifier); + end; + { do the checking for the colon'd arg } + hp:=length_para; + end; + end; + hp:=hp.right; + end; + end; + { pass all parameters again for the typeconversions } + if codegenerror then + exit; + firstcallparan(left,nil,true); + set_varstate(left,true); + { calc registers } + left_right_max(p); + if extra_register then + inc(registers32); + end; + end; + + in_settextbuf_file_x : + begin + { warning here left is the callparannode + not the argument directly } + { left.left is text var } + { left.right.left is the buffer var } + { firstcallparan(left,nil); + already done in firstcalln } + { now we know the type of buffer } + getsymonlyin(systemunit,'SETTEXTBUF'); + hp:=gencallnode(pprocsym(srsym),systemunit); + hp.left:=gencallparanode( + genordinalconstnode(left.left.resulttype^.size,s32bitdef),left); + putnode(p); + p:=hp; + firstpass(p); + end; + + { the firstpass of the arg has been done in firstcalln ? } + in_reset_typedfile, + in_rewrite_typedfile : + begin + procinfo^.flags:=procinfo^.flags or pi_do_call; + firstpass(left); + set_varstate(left,true); + resulttype:=voiddef; + end; + + in_str_x_string : + begin + procinfo^.flags:=procinfo^.flags or pi_do_call; + resulttype:=voiddef; + { check the amount of parameters } + if not(assigned(left)) or + not(assigned(left.right)) then + begin + CGMessage(parser_e_wrong_parameter_size); + exit; + end; + { first pass just the string for first local use } + hp:=left.right; + left.right:=nil; + firstcallparan(left,nil,true); + set_varstate(left,false); + { remove warning when result is passed } + set_funcret_is_valid(left.left); + left.right:=hp; + firstcallparan(left.right,nil,true); + set_varstate(left.right,true); + hp:=left; + { valid string ? } + if not assigned(hp) or + (hp.left.resulttype^.deftype<>stringdef) or + (hp.right=nil) then + CGMessage(cg_e_illegal_expression); + { we need a var parameter } + valid_for_assign(hp.left,false); + { generate the high() value for the shortstring } + if is_shortstring(hp.left.resulttype) then + gen_high_tree(hp,true); + + { !!!! check length of string } + + while assigned(hp.right) do + hp:=hp.right; + + if not assigned(hp.resulttype) then + exit; + { check and convert the first param } + if (hp.is_colon_para) or + not assigned(hp.resulttype) then + CGMessage(cg_e_illegal_expression); + + isreal:=false; + case hp.resulttype^.deftype of + orddef : + begin + case porddef(hp.left.resulttype)^.typ of + u32bit,s32bit, + s64bit,u64bit: + ; + u8bit,s8bit, + u16bit,s16bit: + hp.left:=gentypeconvnode(hp.left,s32bitdef); + else + CGMessage(type_e_integer_or_real_expr_expected); + end; + end; + floatdef : + begin + isreal:=true; + end; + else + CGMessage(type_e_integer_or_real_expr_expected); + end; + + { some format options ? } + hpp:=left.right; + if assigned(hpp) and hpp.is_colon_para then + begin + firstpass(hpp.left); + set_varstate(hpp.left,true); + if (not is_integer(hpp.left.resulttype)) then + CGMessage1(type_e_integer_expr_expected,hpp.left.resulttype^.typename) + else + hpp.left:=gentypeconvnode(hpp.left,s32bitdef); + hpp:=hpp.right; + if assigned(hpp) and hpp.is_colon_para then + begin + if isreal then + begin + if (not is_integer(hpp.left.resulttype)) then + CGMessage1(type_e_integer_expr_expected,hpp.left.resulttype^.typename) + else + begin + firstpass(hpp.left); + set_varstate(hpp.left,true); + hpp.left:=gentypeconvnode(hpp.left,s32bitdef); + end; + end + else + CGMessage(parser_e_illegal_colon_qualifier); + end; + end; + + { pass all parameters again for the typeconversions } + if codegenerror then + exit; + firstcallparan(left,nil,true); + { calc registers } + left_right_max(p); + end; + + in_val_x : + begin + procinfo^.flags:=procinfo^.flags or pi_do_call; + resulttype:=voiddef; + { check the amount of parameters } + if not(assigned(left)) or + not(assigned(left.right)) then + begin + CGMessage(parser_e_wrong_parameter_size); + exit; + end; + If Assigned(left.right.right) Then + {there is a "code" parameter} + Begin + { first pass just the code parameter for first local use} + hp := left.right; + left.right := nil; + make_not_regable(left.left); + firstcallparan(left, nil,true); + set_varstate(left,false); + if codegenerror then exit; + left.right := hp; + {code has to be a var parameter} + if valid_for_assign(left.left,false) then + begin + if (left.left.resulttype^.deftype <> orddef) or + not(porddef(left.left.resulttype)^.typ in + [u16bit,s16bit,u32bit,s32bit]) then + CGMessage(type_e_mismatch); + end; + hpp := left.right + End + Else hpp := left; + {now hpp = the destination value tree} + { first pass just the destination parameter for first local use} + hp:=hpp.right; + hpp.right:=nil; + {hpp = destination} + make_not_regable(hpp.left); + firstcallparan(hpp,nil,true); + set_varstate(hpp,false); + + if codegenerror then + exit; + { remove warning when result is passed } + set_funcret_is_valid(hpp.left); + hpp.right := hp; + if valid_for_assign(hpp.left,false) then + begin + If Not((hpp.left.resulttype^.deftype = floatdef) or + ((hpp.left.resulttype^.deftype = orddef) And + (POrdDef(hpp.left.resulttype)^.typ in + [u32bit,s32bit, + u8bit,s8bit,u16bit,s16bit,s64bit,u64bit]))) Then + CGMessage(type_e_mismatch); + end; + {hp = source (String)} + { count_ref := false; WHY ?? } + firstcallparan(hp,nil,true); + set_varstate(hp,true); + if codegenerror then + exit; + { if not a stringdef then insert a type conv which + does the other type checking } + If (hp.left.resulttype^.deftype<>stringdef) then + begin + hp.left:=gentypeconvnode(hp.left,cshortstringdef); + firstpass(hp); + end; + { calc registers } + left_right_max(p); + + { val doesn't calculate the registers really } + { correct, we need one register extra (FK) } + if is_64bitint(hpp.left.resulttype) then + inc(registers32,2) + else + inc(registers32,1); + end; + + in_include_x_y, + in_exclude_x_y: + begin + resulttype:=voiddef; + if assigned(left) then + begin + firstcallparan(left,nil,true); + set_varstate(left,true); + registers32:=left.registers32; + registersfpu:=left.registersfpu; +{$ifdef SUPPORT_MMX} + registersmmx:=left.registersmmx; +{$endif SUPPORT_MMX} + { remove warning when result is passed } + set_funcret_is_valid(left.left); + { first param must be var } + valid_for_assign(left.left,false); + { check type } + if assigned(left.resulttype) and + (left.resulttype^.deftype=setdef) then + begin + { two paras ? } + if assigned(left.right) then + begin + { insert a type conversion } + { to the type of the set elements } + left.right.left:=gentypeconvnode( + left.right.left, + psetdef(left.resulttype)^.elementtype.def); + { check the type conversion } + firstpass(left.right.left); + { only three parameters are allowed } + if assigned(left.right.right) then + CGMessage(cg_e_illegal_expression); + end; + end + else + CGMessage(type_e_mismatch); + end + else + CGMessage(type_e_mismatch); + end; + + in_low_x, + in_high_x: + begin + set_varstate(left,false); + { this fixes tests\webtbs\tbug879.pp (FK) + if left.treetype in [typen,loadn,subscriptn] then + begin + } + case left.resulttype^.deftype of + orddef,enumdef: + begin + do_lowhigh(left.resulttype); + firstpass(p); + end; + setdef: + begin + do_lowhigh(Psetdef(left.resulttype)^.elementtype.def); + firstpass(p); + end; + arraydef: + begin + if inlinenumber=in_low_x then + begin + hp:=genordinalconstnode(Parraydef(left.resulttype)^.lowrange, + Parraydef(left.resulttype)^.rangetype.def); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + if is_open_array(left.resulttype) or + is_array_of_const(left.resulttype) then + begin + getsymonlyin(left.symtable,'high'+pvarsym(left.symtableentry)^.name); + hp:=genloadnode(pvarsym(srsym),left.symtable); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + hp:=genordinalconstnode(Parraydef(left.resulttype)^.highrange, + Parraydef(left.resulttype)^.rangetype.def); + disposetree(p); + p:=hp; + firstpass(p); + end; + end; + end; + stringdef: + begin + if inlinenumber=in_low_x then + begin + hp:=genordinalconstnode(0,u8bitdef); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + if is_open_string(left.resulttype) then + begin + getsymonlyin(left.symtable,'high'+pvarsym(left.symtableentry)^.name); + hp:=genloadnode(pvarsym(srsym),left.symtable); + disposetree(p); + p:=hp; + firstpass(p); + end + else + begin + hp:=genordinalconstnode(Pstringdef(left.resulttype)^.len,u8bitdef); + disposetree(p); + p:=hp; + firstpass(p); + end; + end; + end; + else + CGMessage(type_e_mismatch); + end; + { + end + else + CGMessage(type_e_varid_or_typeid_expected); + } + end; + + in_cos_extended: + begin + if left.treetype in [ordconstn,realconstn] then + setconstrealvalue(cos(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_sin_extended: + begin + if left.treetype in [ordconstn,realconstn] then + setconstrealvalue(sin(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_arctan_extended: + begin + if left.treetype in [ordconstn,realconstn] then + setconstrealvalue(arctan(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_pi: + if block_type=bt_const then + setconstrealvalue(pi) + else + begin + location.loc:=LOC_FPU; + resulttype:=s80floatdef; + end; + + in_abs_extended: + begin + if left.treetype in [ordconstn,realconstn] then + setconstrealvalue(abs(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_sqr_extended: + begin + if left.treetype in [ordconstn,realconstn] then + setconstrealvalue(sqr(getconstrealvalue)) + else + handleextendedfunction; + end; + + in_sqrt_extended: + begin + if left.treetype in [ordconstn,realconstn] then + begin + vr:=getconstrealvalue; + if vr<0.0 then + begin + CGMessage(type_e_wrong_math_argument); + setconstrealvalue(0); + end + else + setconstrealvalue(sqrt(vr)); + end + else + handleextendedfunction; + end; + + in_ln_extended: + begin + if left.treetype in [ordconstn,realconstn] then + begin + vr:=getconstrealvalue; + if vr<=0.0 then + begin + CGMessage(type_e_wrong_math_argument); + setconstrealvalue(0); + end + else + setconstrealvalue(ln(vr)); + end + else + handleextendedfunction; + end; + +{$ifdef SUPPORT_MMX} + in_mmx_pcmpeqb..in_mmx_pcmpgtw: + begin + end; +{$endif SUPPORT_MMX} + in_assert_x_y : + begin + resulttype:=voiddef; + if assigned(left) then + begin + firstcallparan(left,nil,true); + set_varstate(left,true); + registers32:=left.registers32; + registersfpu:=left.registersfpu; +{$ifdef SUPPORT_MMX} + registersmmx:=left.registersmmx; +{$endif SUPPORT_MMX} + { check type } + if is_boolean(left.resulttype) then + begin + { must always be a string } + left.right.left:=gentypeconvnode(left.right.left,cshortstringdef); + firstpass(left.right.left); + end + else + CGMessage(type_e_mismatch); + end + else + CGMessage(type_e_mismatch); + { We've checked the whole statement for correctness, now we + can remove it if assertions are off } + if not(cs_do_assertion in aktlocalswitches) then + begin + disposetree(left); + putnode(p); + { we need a valid node, so insert a nothingn } + p:=genzeronode(nothingn); + end; + end; + + else + internalerror(8); + end; + end; + { generate an error if no resulttype is set } + if not assigned(resulttype) then + resulttype:=generrordef; + dec(parsing_para_level); + end; +{$ifdef fpc} +{$maxfpuregisters default} +{$endif fpc} + +begin + cinlinenode:=tinlinenode; +end. +{ + $Log$ + Revision 1.1 2000-09-26 14:59:34 florian + * more conversion work done + +} \ No newline at end of file diff --git a/compiler/nodeh.inc b/compiler/nodeh.inc index 044faeab57..8bf7e9053b 100644 --- a/compiler/nodeh.inc +++ b/compiler/nodeh.inc @@ -207,7 +207,10 @@ nf_novariaallowed, { ttypeconvnode } - nf_explizit + nf_explizit, + + { tinlinenode } + nf_inlineconst ); tnodeflagset = set of tnodeflags; @@ -323,7 +326,10 @@ { $Log$ - Revision 1.6 2000-09-25 15:37:14 florian + Revision 1.7 2000-09-26 14:59:34 florian + * more conversion work done + + Revision 1.6 2000/09/25 15:37:14 florian * more fixes Revision 1.5 2000/09/25 15:05:25 florian