From c36ae78617a99b13f89e1de941b4ace9e52d0053 Mon Sep 17 00:00:00 2001 From: peter Date: Tue, 15 Jun 1999 18:58:33 +0000 Subject: [PATCH] * merged --- compiler/pexpr.pas | 108 ++++++++------- compiler/tccnv.pas | 329 +++++++++++++++++++++++---------------------- compiler/tcinl.pas | 12 +- 3 files changed, 236 insertions(+), 213 deletions(-) diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 3801212771..bfcab9b3cd 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -109,6 +109,29 @@ unit pexpr; end; + procedure check_tp_procvar(var p : ptree); + var + p1 : ptree; + begin + if (m_tp_procvar in aktmodeswitches) and +{ (not afterassignment) and } + (not in_args) and + (p^.treetype in [loadn]) then + begin + { support if procvar then for tp7 and many other expression like this } + firstpass(p); + if p^.resulttype^.deftype=procvardef then + begin + p1:=gencallnode(nil,nil); + p1^.right:=p; + p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef; + firstpass(p1); + p:=p1; + end; + end; + end; + + function statement_syssym(l : longint;var pd : pdef) : ptree; var p1,p2,paras : ptree; @@ -539,21 +562,14 @@ unit pexpr; var hp : ptree; begin - hp:=nil; - if ((procvar^.options and pomethodpointer)<>0) then - begin - if assigned(t^.methodpointer) and - (t^.methodpointer^.resulttype^.deftype=objectdef) and - (pobjectdef(t^.methodpointer^.resulttype)^.isclass) and - (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then - hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer)) - else - Message(type_e_mismatch); - end - else if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,getprocvardef)) then - begin - hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable); - end; + hp:=nil; + if (proc_to_procvar_equal(pprocsym(t^.symtableentry)^.definition,procvar)) then + begin + if ((procvar^.options and pomethodpointer)<>0) then + hp:=genloadmethodcallnode(pprocsym(t^.symtableprocentry),t^.symtable,getcopy(t^.methodpointer)) + else + hp:=genloadcallnode(pprocsym(t^.symtableprocentry),t^.symtable); + end; if assigned(hp) then begin disposetree(t); @@ -606,10 +622,16 @@ unit pexpr; { read the expression } getprocvar:=ppropertysym(sym)^.proptype^.deftype=procvardef; p2:=comp_expr(true); - if (p2^.treetype<>errorn) and getprocvar then - handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2); + if getprocvar then + begin + if (p2^.treetype=calln) then + handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2) + else + if (p2^.treetype=typeconvn) and + (p2^.left^.treetype=calln) then + handle_procvar(pprocvardef(ppropertysym(sym)^.proptype),p2^.left); + end; p1^.left:=gencallparanode(p2,p1^.left); -{ firstcallparan(p1^.left,nil); } getprocvar:=false; end else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then @@ -1763,6 +1785,9 @@ unit pexpr; { generate error node if no node is created } if not assigned(p1) then p1:=genzeronode(errorn); + { tp7 procvar handling } + if (m_tp_procvar in aktmodeswitches) then + check_tp_procvar(p1); factor:=p1; check_tokenpos; end; @@ -1858,27 +1883,6 @@ unit pexpr; sub_expr:=p1; end; - procedure check_tp_procvar(var p : ptree); - var - p1 : ptree; - begin - if (m_tp_procvar in aktmodeswitches) and - (not afterassignment) and - (not in_args) and (p^.treetype=loadn) then - begin - { support if procvar then for tp7 and many other expression like this } - firstpass(p); - if p^.resulttype^.deftype=procvardef then - begin - p1:=gencallnode(nil,nil); - p1^.right:=p; - p1^.resulttype:=pprocvardef(p^.resulttype)^.retdef; - firstpass(p1); - p:=p1; - end; - end; - end; - function comp_expr(accept_equal : boolean):Ptree; var @@ -1889,8 +1893,6 @@ unit pexpr; afterassignment:=true; p1:=sub_expr(opcompare,accept_equal); afterassignment:=oldafterassignment; - if (m_tp_procvar in aktmodeswitches) then - check_tp_procvar(p1); comp_expr:=p1; end; @@ -1929,12 +1931,16 @@ unit pexpr; getprocvardef:=pprocvardef(p1^.resulttype); end; p2:=sub_expr(opcompare,true); - if getprocvar and (p2^.treetype=calln) then - handle_procvar(getprocvardef,p2); - { also allow p:= proc(t); !! (PM) } - if getprocvar and (p2^.treetype=typeconvn) and - (p2^.left^.treetype=calln) then - handle_procvar(getprocvardef,p2^.left); + if getprocvar then + begin + if (p2^.treetype=calln) then + handle_procvar(getprocvardef,p2) + else + { also allow p:= proc(t); !! (PM) } + if (p2^.treetype=typeconvn) and + (p2^.left^.treetype=calln) then + handle_procvar(getprocvardef,p2^.left); + end; getprocvar:=false; p1:=gennode(assignn,p1,p2); end; @@ -2018,9 +2024,15 @@ unit pexpr; end. { $Log$ - Revision 1.113 1999-06-13 22:41:05 peter + Revision 1.114 1999-06-15 18:58:33 peter + * merged + + Revision 1.113 1999/06/13 22:41:05 peter * merged from fixes + Revision 1.112.2.2 1999/06/15 18:54:52 peter + * more procvar fixes + Revision 1.112.2.1 1999/06/13 22:38:09 peter * tp_procvar check for loading of procvars when getaddr=false diff --git a/compiler/tccnv.pas b/compiler/tccnv.pas index dfbd6ee1d7..871e2c585f 100644 --- a/compiler/tccnv.pas +++ b/compiler/tccnv.pas @@ -643,182 +643,181 @@ implementation 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 (p^.resulttype^.deftype=procvardef) and - ((m_tp_procvar in aktmodeswitches) or - { method pointer use always the TP syntax } - ((pprocvardef(p^.resulttype)^.options and pomethodpointer)<>0) - ) and - ((is_procsym_load(p^.left) or is_procsym_call(p^.left))) then - begin - if is_procsym_call(p^.left) then + 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 - p^.left^.treetype:=loadn; - { are at same offset so this could be spared, but - it more secure to do it anyway } - p^.left^.symtableentry:=p^.left^.symtableprocentry; - p^.left^.resulttype:=pprocsym(p^.left^.symtableentry)^.definition; - 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; + if p^.left^.right=nil then + begin + p^.left^.treetype:=loadn; + { are at same offset so this could be spared, but + it more secure to do it anyway } + p^.left^.symtableentry:=p^.left^.symtableprocentry; + p^.left^.resulttype:=pprocsym(p^.left^.symtableentry)^.definition; + 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 + 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 + 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 proc_to_procvar_equal(aprocdef,pprocvardef(p^.resulttype)) then + 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 + else CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); - exit; - end - else - begin - if p^.explizit then + exit; + end; + end; + if p^.explizit then + begin + { 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 - { boolean to byte are special because the - location can be different } + 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 + CGMessage(cg_e_illegal_type_conversion); + end; + end - 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; - 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; - { wenn Aufz„hltyp nach Ordinal konvertiert werden soll } - { dann Aufz„hltyp=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 - CGMessage(cg_e_illegal_type_conversion); - 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 - CGMessage(cg_e_illegal_type_conversion); - end; - 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 - { this is wrong because it converts to a 4 byte long var !! - if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then } - if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then - CGMessage(cg_e_illegal_type_conversion); - 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)^.isclass)) - ) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) and - {it also works if the assignment is overloaded } - not is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then - CGMessage(cg_e_illegal_type_conversion); - end + { ordinal to enumeration } else - CGMessage2(type_e_incompatible_types,p^.left^.resulttype^.typename,p^.resulttype^.typename); - end + 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 + CGMessage(cg_e_illegal_type_conversion); + end; + 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 + { this is wrong because it converts to a 4 byte long var !! + if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn nur Dummy ) then } + if IsConvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn,false)=0 then + CGMessage(cg_e_illegal_type_conversion); + 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)^.isclass)) + ) and (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) and + {it also works if the assignment is overloaded } + not is_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; + { ordinal contants can be directly converted } if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) then begin @@ -913,9 +912,15 @@ implementation end. { $Log$ - Revision 1.36 1999-06-13 22:41:06 peter + Revision 1.37 1999-06-15 18:58:35 peter + * merged + + Revision 1.36 1999/06/13 22:41:06 peter * merged from fixes + Revision 1.35.2.2 1999/06/15 18:54:53 peter + * more procvar fixes + Revision 1.35.2.1 1999/06/13 22:39:19 peter * use proc_to_procvar_equal diff --git a/compiler/tcinl.pas b/compiler/tcinl.pas index d15b7e60f5..37253aa47f 100644 --- a/compiler/tcinl.pas +++ b/compiler/tcinl.pas @@ -612,8 +612,8 @@ implementation if assigned(hp^.left^.resulttype) then begin isreal:=false; - { support writeln(procvar) for tp7 } - if (m_tp_procvar in aktmodeswitches) and (hp^.left^.resulttype^.deftype=procvardef) then + { support writeln(procvar) } + if (hp^.left^.resulttype^.deftype=procvardef) then begin p1:=gencallnode(nil,nil); p1^.right:=hp^.left; @@ -1101,7 +1101,13 @@ implementation end. { $Log$ - Revision 1.35 1999-05-27 19:45:19 peter + Revision 1.36 1999-06-15 18:58:36 peter + * merged + + Revision 1.35.2.1 1999/06/15 18:54:54 peter + * more procvar fixes + + Revision 1.35 1999/05/27 19:45:19 peter * removed oldasm * plabel -> pasmlabel * -a switches to source writing automaticly