From 50cbe1751e3ed2324e5d8fbaba74ea5eb61bd0c0 Mon Sep 17 00:00:00 2001 From: florian Date: Thu, 9 Apr 1998 22:16:33 +0000 Subject: [PATCH] * problem with previous REGALLOC solved * improved property support --- compiler/cgi386.pas | 26 +- compiler/pass_1.pas | 269 +++++++++++---------- compiler/pdecl.pas | 96 +++++--- compiler/pexpr.pas | 548 +++++++++++++++++++++++------------------- compiler/tgeni386.pas | 13 +- 5 files changed, 533 insertions(+), 419 deletions(-) diff --git a/compiler/cgi386.pas b/compiler/cgi386.pas index 0d45343697..0b5c9a65cf 100644 --- a/compiler/cgi386.pas +++ b/compiler/cgi386.pas @@ -2080,7 +2080,6 @@ implementation var opsize : topsize; - {pushed,}withresult : boolean; otlabel,hlabel,oflabel : plabel; hregister : tregister; loc : tloc; @@ -2090,7 +2089,6 @@ implementation oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); - withresult:=false; { calculate left sides } secondpass(p^.left); case p^.left^.location.loc of @@ -2165,8 +2163,7 @@ implementation { we do not need destination anymore } del_reference(p^.left^.location.reference); { only source if withresult is set } - if not(withresult) then - del_reference(p^.right^.location.reference); + del_reference(p^.right^.location.reference); loadstring(p); ungetiftemp(p^.right^.location.reference); end @@ -2197,8 +2194,7 @@ implementation else begin concatcopy(p^.right^.location.reference, - p^.left^.location.reference,p^.left^.resulttype^.size, - withresult); + p^.left^.location.reference,p^.left^.resulttype^.size,false); ungetiftemp(p^.right^.location.reference); end; end; @@ -2824,7 +2820,12 @@ implementation exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); end; - exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); + { direct call to class constructor, don't allocate memory } + if is_con_or_destructor and (p^.methodpointer^.resulttype^.deftype=objectdef) and + (pobjectdef(p^.methodpointer^.resulttype)^.isclass) then + exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,0))) + else + exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); if is_con_or_destructor then begin { classes don't get a VMT pointer pushed } @@ -2960,6 +2961,7 @@ implementation if ((aktprocsym^.properties and sp_static)<>0) or ((aktprocsym^.definition^.options and poclassmethod)<>0) or ((p^.procdefinition^.options and postaticmethod)<>0) or + ((p^.procdefinition^.options and poconstructor)<>0) or { ESI is loaded earlier } ((p^.procdefinition^.options and poclassmethod)<>0)then begin @@ -2979,6 +2981,9 @@ implementation end; end else + { aktprocsym should be assigned, also in main program } + internalerror(12345); + { begin new(r); reset_reference(r^); @@ -2988,6 +2993,7 @@ implementation reset_reference(r^); r^.base:=R_EDI; end; + } if p^.procdefinition^.extnumber=-1 then internalerror($Da); r^.offset:=p^.procdefinition^.extnumber*4+12; @@ -5709,7 +5715,11 @@ do_jmp: end. { $Log$ - Revision 1.7 1998-04-09 14:28:05 jonas + Revision 1.8 1998-04-09 22:16:33 florian + * problem with previous REGALLOC solved + * improved property support + + Revision 1.7 1998/04/09 14:28:05 jonas + basic k6 and 6x86 optimizing support (-O7 and -O8) Revision 1.6 1998/04/08 11:34:20 peter diff --git a/compiler/pass_1.pas b/compiler/pass_1.pas index 08db72a2b5..6db2b095d5 100644 --- a/compiler/pass_1.pas +++ b/compiler/pass_1.pas @@ -2393,24 +2393,24 @@ unit pass_1; p^.resulttype:=p^.left^.resulttype; end { if we know the routine which is called, then the type } - { conversions are inserted } + { conversions are inserted } else begin if count_ref then - begin - store_valid:=must_be_valid; - if (defcoll^.paratyp<>vs_var) then - must_be_valid:=true - else - must_be_valid:=false; - { here we must add something for the implicit type } - { conversion from array of char to pchar } - if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp,p^.left^.treetype) then - if convtyp=tc_array_to_pointer then - must_be_valid:=false; - firstpass(p^.left); - must_be_valid:=store_valid; - End; + begin + store_valid:=must_be_valid; + if (defcoll^.paratyp<>vs_var) then + must_be_valid:=true + else + must_be_valid:=false; + { here we must add something for the implicit type } + { conversion from array of char to pchar } + if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp,p^.left^.treetype) then + if convtyp=tc_array_to_pointer then + must_be_valid:=false; + firstpass(p^.left); + must_be_valid:=store_valid; + end; if not((p^.left^.resulttype^.deftype=stringdef) and (defcoll^.data^.deftype=stringdef)) and (defcoll^.data^.deftype<>formaldef) then @@ -2438,7 +2438,7 @@ unit pass_1; ) and not(is_equal(p^.left^.resulttype,defcoll^.data))) then Message(parser_e_call_by_ref_without_typeconv); - { don't generate an type conversion for open arrays } + { don't generate an type conversion for open arrays } { else we loss the ranges } if not(is_open_array(defcoll^.data)) then begin @@ -2534,24 +2534,81 @@ unit pass_1; procs:=nil; { made this global for disposing !! } store_valid:=must_be_valid; - if not assigned(p^.procdefinition) then + must_be_valid:=false; + + { procedure variable ? } + if assigned(p^.right) then begin - must_be_valid:=false; - { procedure variable ? } - if not(assigned(p^.right)) then + { procedure does a call } + procinfo.flags:=procinfo.flags or pi_do_call; + + { calc the correture value for the register } +{$ifdef i386} + for regi:=R_EAX to R_EDI do + inc(reg_pushes[regi],t_times*2); +{$endif} +{$ifdef m68k} + for regi:=R_D0 to R_A6 do + inc(reg_pushes[regi],t_times*2); +{$endif} + { calculate the type of the parameters } + if assigned(p^.left) then begin - if assigned(p^.left) then - begin - old_count_ref:=count_ref; - count_ref:=false; - store_valid:=must_be_valid; - must_be_valid:=false; - firstcallparan(p^.left,nil); - count_ref:=old_count_ref; - must_be_valid:=store_valid; - if codegenerror then - exit; - end; + old_count_ref:=count_ref; + count_ref:=false; + firstcallparan(p^.left,nil); + count_ref:=old_count_ref; + if codegenerror then + exit; + end; + firstpass(p^.right); + + { check the parameters } + pdc:=pprocvardef(p^.right^.resulttype)^.para1; + pt:=p^.left; + while assigned(pdc) and assigned(pt) do + begin + pt:=pt^.right; + pdc:=pdc^.next; + end; + if assigned(pt) or assigned(pdc) then + Message(parser_e_illegal_parameter_list); + + { insert type conversions } + if assigned(p^.left) then + begin + old_count_ref:=count_ref; + count_ref:=true; + firstcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1); + count_ref:=old_count_ref; + if codegenerror then + exit; + end; + p^.resulttype:=pprocvardef(p^.right^.resulttype)^.retdef; + { this was missing, leads to a bug below if + the procvar is a function } + p^.procdefinition:=pprocdef(p^.right^.resulttype); + end + else + begin + { determine the type of the parameters } + if assigned(p^.left) then + begin + old_count_ref:=count_ref; + count_ref:=false; + store_valid:=must_be_valid; + must_be_valid:=false; + firstcallparan(p^.left,nil); + count_ref:=old_count_ref; + must_be_valid:=store_valid; + if codegenerror then + exit; + end; + + { do we know the procedure to call ? } + if not(assigned(p^.procdefinition)) then + begin + { determine length of parameter list } pt:=p^.left; paralength:=0; @@ -2876,117 +2933,61 @@ unit pass_1; p^.methodpointer:=nil; end; {$endif CHAINPROCSYMS} + end; { end of procedure to call determination } + { work trough all parameters to insert the type conversions } + if assigned(p^.left) then + begin + old_count_ref:=count_ref; + count_ref:=true; + firstcallparan(p^.left,p^.procdefinition^.para1); + count_ref:=old_count_ref; + end; - { work trough all parameters to insert the type conversions } - if assigned(p^.left) then - begin - old_count_ref:=count_ref; - count_ref:=true; - firstcallparan(p^.left,p^.procdefinition^.para1); - count_ref:=old_count_ref; - end; - { handle predefined procedures } - if (p^.procdefinition^.options and pointernproc)<>0 then - begin - { settextbuf needs two args } - if assigned(p^.left^.right) then - pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left) - else - begin - pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left^.left); - putnode(p^.left); - end; - putnode(p); - firstpass(pt); - { was placed after the exit } - { caused GPF } - { error caused and corrected by (PM) } - p:=pt; - - must_be_valid:=store_valid; - if codegenerror then - exit; - - dispose(procs); - exit; - end + { handle predefined procedures } + if (p^.procdefinition^.options and pointernproc)<>0 then + begin + { settextbuf needs two args } + if assigned(p^.left^.right) then + pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left) else - { no intern procedure => we do a call } - procinfo.flags:=procinfo.flags or pi_do_call; - - { calc the correture value for the register } -{$ifdef i386} - { calc the correture value for the register } - for regi:=R_EAX to R_EDI do begin - if (p^.procdefinition^.usedregisters and ($80 shr word(regi)))<>0 then - inc(reg_pushes[regi],t_times*2); + pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left^.left); + putnode(p^.left); end; -{$endif} -{$ifdef m68k} - for regi:=R_D0 to R_A6 do - begin - if (p^.procdefinition^.usedregisters and ($800 shr word(regi)))<>0 then - inc(reg_pushes[regi],t_times*2); - end; -{$endif} + putnode(p); + firstpass(pt); + { was placed after the exit } + { caused GPF } + { error caused and corrected by (PM) } + p:=pt; + + must_be_valid:=store_valid; + if codegenerror then + exit; + + dispose(procs); + exit; end else - begin - { procedure variable } - { die Typen der Parameter berechnen } - - { procedure does a call } - procinfo.flags:=procinfo.flags or pi_do_call; + { no intern procedure => we do a call } + procinfo.flags:=procinfo.flags or pi_do_call; + { calc the correture value for the register } {$ifdef i386} - { calc the correture value for the register } - for regi:=R_EAX to R_EDI do + for regi:=R_EAX to R_EDI do + begin + if (p^.procdefinition^.usedregisters and ($80 shr word(regi)))<>0 then inc(reg_pushes[regi],t_times*2); + end; {$endif} {$ifdef m68k} - { calc the correture value for the register } - for regi:=R_D0 to R_A6 do - inc(reg_pushes[regi],t_times*2); + for regi:=R_D0 to R_A6 do + begin + if (p^.procdefinition^.usedregisters and ($800 shr word(regi)))<>0 then + inc(reg_pushes[regi],t_times*2); + end; {$endif} - if assigned(p^.left) then - begin - old_count_ref:=count_ref; - count_ref:=false; - firstcallparan(p^.left,nil); - count_ref:=old_count_ref; - if codegenerror then - exit; - end; - firstpass(p^.right); - - { check the parameters } - pdc:=pprocvardef(p^.right^.resulttype)^.para1; - pt:=p^.left; - while assigned(pdc) and assigned(pt) do - begin - pt:=pt^.right; - pdc:=pdc^.next; - end; - if assigned(pt) or assigned(pdc) then - Message(parser_e_illegal_parameter_list); - - { insert type conversions } - if assigned(p^.left) then - begin - old_count_ref:=count_ref; - count_ref:=true; - firstcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1); - count_ref:=old_count_ref; - if codegenerror then - exit; - end; - p^.resulttype:=pprocvardef(p^.right^.resulttype)^.retdef; - { this was missing , leads to a bug below if - the procvar is a function } - p^.procdefinition:=pprocdef(p^.right^.resulttype); - end; - end; { not assigned(p^.procdefinition) } + end; { not assigned(p^.procdefinition) } { get a register for the return value } if (p^.resulttype<>pdef(voiddef)) then @@ -4495,7 +4496,11 @@ unit pass_1; end. { $Log$ - Revision 1.5 1998-04-08 16:58:04 pierre + Revision 1.6 1998-04-09 22:16:34 florian + * problem with previous REGALLOC solved + * improved property support + + Revision 1.5 1998/04/08 16:58:04 pierre * several bugfixes ADD ADC and AND are also sign extended nasm output OK (program still crashes at end diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index 8691920ac7..49f64f7bfe 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -370,6 +370,7 @@ unit pdecl; sc : pstringcontainer; hp : pdef; s : string; + pp : pprocdef; begin { check for a class } @@ -471,8 +472,11 @@ unit pdecl; { take the whole info: } p^.options:=ppropertysym(overriden)^.options; p^.index:=ppropertysym(overriden)^.index; + p^.proptype:=ppropertysym(overriden)^.proptype; p^.writeaccesssym:=ppropertysym(overriden)^.writeaccesssym; p^.readaccesssym:=ppropertysym(overriden)^.readaccesssym; + p^.writeaccessdef:=ppropertysym(overriden)^.writeaccessdef; + p^.readaccessdef:=ppropertysym(overriden)^.readaccessdef; end else begin @@ -480,6 +484,12 @@ unit pdecl; message(parser_e_no_property_found_to_override); end; end; + { create data defcoll to allow correct parameter checks } + new(datacoll); + datacoll^.paratyp:=vs_value; + datacoll^.data:=p^.proptype; + datacoll^.next:=nil; + if (token=ID) and (pattern='READ') then begin consume(ID); @@ -492,14 +502,27 @@ unit pdecl; { varsym aren't allowed for an indexed property or an property with parameters } if ((sym^.typ=varsym) and - (((p^.options and ppo_indexed)<>0) or - assigned(propertyparas))) or + { not necessary, an index forces propertyparas + to be assigned + } + { (((p^.options and ppo_indexed)<>0) or } + assigned(propertyparas)) or not(sym^.typ in [varsym,procsym]) then Message(parser_e_ill_property_access_sym); { search the matching definition } if sym^.typ=procsym then begin - { !!!!!! } + pp:=get_procdef; + if not(assigned(pp)) or + not(is_equal(pp^.retdef,p^.proptype)) then + Message(parser_e_ill_property_access_sym); + p^.readaccessdef:=pp; + end + else if sym^.typ=varsym then + begin + if not(is_equal(pvarsym(sym)^.definition, + p^.proptype)) then + Message(parser_e_ill_property_access_sym); end; p^.readaccesssym:=sym; end; @@ -513,16 +536,28 @@ unit pdecl; Message1(sym_e_unknown_id,pattern) else begin - { !!!! check sym } if ((sym^.typ=varsym) and - (((p^.options and ppo_indexed)<>0) - { or property paras })) or + assigned(propertyparas)) or not(sym^.typ in [varsym,procsym]) then Message(parser_e_ill_property_access_sym); { search the matching definition } if sym^.typ=procsym then begin - { !!!!!! } + { insert data entry to check access method } + datacoll^.next:=propertyparas; + propertyparas:=datacoll; + pp:=get_procdef; + { ... and remove it } + propertyparas:=propertyparas^.next; + if not(assigned(pp)) then + Message(parser_e_ill_property_access_sym); + p^.writeaccessdef:=pp; + end + else if sym^.typ=varsym then + begin + if not(is_equal(pvarsym(sym)^.definition, + p^.proptype)) then + Message(parser_e_ill_property_access_sym); end; p^.writeaccesssym:=sym; end; @@ -536,23 +571,7 @@ unit pdecl; if (token=ID) and (pattern='DEFAULT') then begin consume(ID); - if token=SEMICOLON then - begin - p2:=search_default_property(aktclass); - if assigned(p2) then - message1(parser_e_only_one_default_property, - pobjectdef(p2^.owner^.defowner)^.name^) - else - begin - p^.options:=p^.options and ppo_defaultproperty; - if not(assigned(propertyparas)) then - message(parser_e_property_need_paras); - end; - end - else - begin - { !!!!!!! storage } - end; + { !!!!!!! storage } consume(SEMICOLON); end else if (token=ID) and (pattern='NODEFAULT') then @@ -561,13 +580,32 @@ unit pdecl; { !!!!!!!! } end; symtablestack^.insert(p); + { default property ? } + consume(SEMICOLON); + if (token=ID) and (pattern='DEFAULT') then + begin + consume(ID); + p2:=search_default_property(aktclass); + if assigned(p2) then + message1(parser_e_only_one_default_property, + pobjectdef(p2^.owner^.defowner)^.name^) + else + begin + p^.options:=p^.options or ppo_defaultproperty; + if not(assigned(propertyparas)) then + message(parser_e_property_need_paras); + end; + consume(SEMICOLON); + end; { clean up } if assigned(datacoll) then dispose(datacoll); end else - consume(ID); - consume(SEMICOLON); + begin + consume(ID); + consume(SEMICOLON); + end; end; procedure destructor_head; @@ -1689,7 +1727,11 @@ unit pdecl; end. { $Log$ - Revision 1.5 1998-04-08 14:59:20 florian + Revision 1.6 1998-04-09 22:16:35 florian + * problem with previous REGALLOC solved + * improved property support + + Revision 1.5 1998/04/08 14:59:20 florian * problem with new expr_type solved Revision 1.4 1998/04/08 10:26:09 florian diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 1d0241ca17..94d15b5c6d 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -418,15 +418,140 @@ unit pexpr; afterassignment:=prevafterassn; end; + { the following procedure handles the access to a property symbol } + procedure handle_propertysym(sym : psym;var p1 : ptree; + var pd : pdef); + + var + paras : ptree; + oldafterassignment : boolean; + p2 : ptree; + + begin + paras:=nil; + { property parameters? } + if token=LECKKLAMMER then + begin + consume(LECKKLAMMER); + paras:=parse_paras(false,true); + consume(RECKKLAMMER); + end; + { indexed property } + if (ppropertysym(sym)^.options and ppo_indexed)<>0 then + begin + p2:=genordinalconstnode(ppropertysym(sym)^.index,s32bitdef); + paras:=gencallparanode(p2,paras); + end; + if not(afterassignment) and not(in_args) then + begin + { write property: } + { no result } + pd:=voiddef; + if assigned(ppropertysym(sym)^.writeaccesssym) then + begin + if ppropertysym(sym)^.writeaccesssym^.typ=procsym then + begin + { generate the method call } + p1:=genmethodcallnode(pprocsym( + ppropertysym(sym)^.writeaccesssym), + ppropertysym(sym)^.writeaccesssym^.owner,p1); + { we know the procedure to call, so + force the usage of that procedure } + p1^.procdefinition:=pprocdef(ppropertysym(sym)^.writeaccessdef); + p1^.left:=paras; + { to be on the save side } + oldafterassignment:=afterassignment; + consume(ASSIGNMENT); + { read the expression } + afterassignment:=true; + p2:=expr; + p1^.left:=gencallparanode(p2,p1^.left); + afterassignment:=oldafterassignment; + end + else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then + begin + if assigned(paras) then + message(parser_e_no_paras_allowed); + p1:=gensubscriptnode(pvarsym( + ppropertysym(sym)^.readaccesssym),p1); + { to be on the save side } + oldafterassignment:=afterassignment; + consume(ASSIGNMENT); + { read the expression } + afterassignment:=true; + p2:=expr; + p1:=gennode(assignn,p1,p2); + afterassignment:=oldafterassignment; + end + else + begin + p1:=genzeronode(errorn); + Message(parser_e_no_procedure_to_access_property); + end; + end + else + begin + p1:=genzeronode(errorn); + Message(parser_e_no_procedure_to_access_property); + end; + end + else + begin + { read property: } + pd:=ppropertysym(sym)^.proptype; + if assigned(ppropertysym(sym)^.readaccesssym) then + begin + if ppropertysym(sym)^.readaccesssym^.typ=varsym then + begin + if assigned(paras) then + message(parser_e_no_paras_allowed); + p1:=gensubscriptnode(pvarsym( + ppropertysym(sym)^.readaccesssym),p1); + pd:=pvarsym(sym)^.definition; + end + else if ppropertysym(sym)^.readaccesssym^.typ=procsym then + begin + { generate the method call } + p1:=genmethodcallnode(pprocsym( + ppropertysym(sym)^.readaccesssym), + ppropertysym(sym)^.readaccesssym^.owner,p1); + { we know the procedure to call, so + force the usage of that procedure } + p1^.procdefinition:=pprocdef(ppropertysym(sym)^.writeaccessdef); + { insert paras } + p1^.left:=paras; + + { if we should be delphi compatible } + { then force type conversion } + { isn't neccessary, the result types } + { have to match excatly } + {if cs_delphi2_compatible in aktswitches then + p1:=gentypeconvnode(p1,pd); + } + end + else + begin + p1:=genzeronode(errorn); + Message(sym_e_type_mismatch); + end; + end + else + begin + { error, no function to read property } + p1:=genzeronode(errorn); + Message(parser_e_no_procedure_to_access_property); + end; + end; + end; + + { the ID token has to be consumed before calling this function } procedure do_member_read(const sym : psym;var p1 : ptree; var pd : pdef;var again : boolean); var static_name : string; - paras : ptree; - oldafterassignment,isclassref : boolean; - p2 : ptree; + isclassref : boolean; begin if sym=nil then @@ -472,110 +597,7 @@ unit pexpr; begin if isclassref then Message(parser_e_only_class_methods_via_class_ref); - paras:=nil; - { property parameters? } - if token=LECKKLAMMER then - begin - consume(LECKKLAMMER); - paras:=parse_paras(false,true); - consume(RECKKLAMMER); - end; - { indexed property } - if (ppropertysym(sym)^.options and ppo_indexed)<>0 then - begin - p2:=genordinalconstnode(ppropertysym(sym)^.index,s32bitdef); - paras:=gencallparanode(p2,paras); - end; - if not(afterassignment) and not(in_args) then - begin - { write property: } - { no result } - pd:=voiddef; - if assigned(ppropertysym(sym)^.writeaccesssym) then - begin - if ppropertysym(sym)^.writeaccesssym^.typ=procsym then - begin - { generate the method call } - p1:=genmethodcallnode(pprocsym( - ppropertysym(sym)^.writeaccesssym), - ppropertysym(sym)^.writeaccesssym^.owner,p1); - p1^.left:=paras; - { to be on the save side } - oldafterassignment:=afterassignment; - consume(ASSIGNMENT); - { read the expression } - afterassignment:=true; - p2:=expr; - p1^.left:=gencallparanode(p2,p1^.left); - afterassignment:=oldafterassignment; - end - else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then - begin - if assigned(paras) then - message(parser_e_no_paras_allowed); - p1:=gensubscriptnode(pvarsym( - ppropertysym(sym)^.readaccesssym),p1); - { to be on the save side } - oldafterassignment:=afterassignment; - consume(ASSIGNMENT); - { read the expression } - afterassignment:=true; - p2:=expr; - p1:=gennode(assignn,p1,p2); - afterassignment:=oldafterassignment; - end - else - begin - p1:=genzeronode(errorn); - Message(parser_e_no_procedure_to_access_property); - end; - end - else - begin - p1:=genzeronode(errorn); - Message(parser_e_no_procedure_to_access_property); - end; - end - else - begin - { read property: } - pd:=ppropertysym(sym)^.proptype; - if assigned(ppropertysym(sym)^.readaccesssym) then - begin - if ppropertysym(sym)^.readaccesssym^.typ=varsym then - begin - if assigned(paras) then - message(parser_e_no_paras_allowed); - p1:=gensubscriptnode(pvarsym( - ppropertysym(sym)^.readaccesssym),p1); - pd:=pvarsym(sym)^.definition; - end - else if ppropertysym(sym)^.readaccesssym^.typ=procsym then - begin - { generate the method call } - p1:=genmethodcallnode(pprocsym( - ppropertysym(sym)^.readaccesssym), - ppropertysym(sym)^.readaccesssym^.owner,p1); - { insert paras } - p1^.left:=paras; - { if we should be delphi compatible } - { then force type conversion } - if cs_delphi2_compatible in aktswitches then - p1:=gentypeconvnode(p1,pd); - end - else - begin - p1:=genzeronode(errorn); - Message(sym_e_type_mismatch); - end; - end - else - begin - { error, no function to read property } - p1:=genzeronode(errorn); - Message(parser_e_no_procedure_to_access_property); - end; - end; + handle_propertysym(sym,p1,pd); end; else internalerror(16); end; @@ -595,6 +617,7 @@ unit pexpr; classh : pobjectdef; d : bestreal; constset : pconstset; + propsym : ppropertysym; { p1 and p2 must contain valid values } @@ -621,148 +644,171 @@ unit pexpr; pd:=ppointerdef(pd)^.definition; end; end; - LECKKLAMMER : begin - consume(LECKKLAMMER); - repeat - if (pd^.deftype<>arraydef) and - (pd^.deftype<>stringdef) and - (pd^.deftype<>pointerdef) then - begin - Message(cg_e_invalid_qualifier); - disposetree(p1); - p1:=genzeronode(errorn); - end - else if (pd^.deftype=pointerdef) then - begin - p2:=expr; - p1:=gennode(vecn,p1,p2); - pd:=ppointerdef(pd)^.definition; - end - else - begin - p2:=expr; - { support SEG:OFS for go32v2 Mem[] } - if (target_info.target=target_GO32V2) and - (p1^.treetype=loadn) and - assigned(p1^.symtableentry) and - assigned(p1^.symtableentry^.owner^.name) and - (p1^.symtableentry^.owner^.name^='SYSTEM') and - ((p1^.symtableentry^.name='MEM') or - (p1^.symtableentry^.name='MEMW') or - (p1^.symtableentry^.name='MEML')) then - begin - if (token=COLON) then - begin - consume(COLON); - p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2); - p2:=expr; - p2:=gennode(addn,p2,p3); - p1:=gennode(vecn,p1,p2); - p1^.memseg:=true; - p1^.memindex:=true; - end - else - begin - p1:=gennode(vecn,p1,p2); - p1^.memindex:=true; - end; - end - { else - if (target_info.target=target_GO32V2) and - assigned(p1^.symtableentry) and - assigned(p1^.symtableentry^.owner^.name) and - (p1^.symtableentry^.owner^.name^='SYSTEM') and - ((p1^.symtableentry^.name='PORT') or - (p1^.symtableentry^.name='PORTW') or - (p1^.symtableentry^.name='PORTL')) then - begin - p1:=gennode(vecn,p1,p2); - p1^.portindex:=true; - p - end; - end } - else - p1:=gennode(vecn,p1,p2); - if pd^.deftype=stringdef then - pd:=cchardef - else - pd:=parraydef(pd)^.definition; - end; - if token=COMMA then consume(COMMA) - else break; - until false; - consume(RECKKLAMMER); - end; - POINT : begin - consume(POINT); - case pd^.deftype of - recorddef: - begin - sym:=pvarsym(precdef(pd)^.symtable^.search(pattern)); - consume(ID); - if sym=nil then - begin - Message(sym_e_illegal_field); - disposetree(p1); - p1:=genzeronode(errorn); - end - else - begin - p1:=gensubscriptnode(sym,p1); - pd:=sym^.definition; - end; - end; - classrefdef: + LECKKLAMMER: + begin + if (pd^.deftype=objectdef) and + pobjectdef(pd)^.isclass then + begin + { default property } + propsym:=search_default_property(pobjectdef(pd)); + if not(assigned(propsym)) then + begin + disposetree(p1); + p1:=genzeronode(errorn); + again:=false; + end + else + begin + p1:=nil; + handle_propertysym(propsym,p1,pd); + end; + end + else + begin + consume(LECKKLAMMER); + repeat + if (pd^.deftype<>arraydef) and + (pd^.deftype<>stringdef) and + (pd^.deftype<>pointerdef) then + begin + Message(cg_e_invalid_qualifier); + disposetree(p1); + p1:=genzeronode(errorn); + again:=false; + end + else if (pd^.deftype=pointerdef) then + begin + p2:=expr; + p1:=gennode(vecn,p1,p2); + pd:=ppointerdef(pd)^.definition; + end + else + begin + p2:=expr; + { support SEG:OFS for go32v2 Mem[] } + if (target_info.target=target_GO32V2) and + (p1^.treetype=loadn) and + assigned(p1^.symtableentry) and + assigned(p1^.symtableentry^.owner^.name) and + (p1^.symtableentry^.owner^.name^='SYSTEM') and + ((p1^.symtableentry^.name='MEM') or + (p1^.symtableentry^.name='MEMW') or + (p1^.symtableentry^.name='MEML')) then + begin + if (token=COLON) then begin - classh:=pobjectdef(pclassrefdef(pd)^.definition); - sym:=nil; - while assigned(classh) do - begin - sym:=pvarsym(classh^.publicsyms^.search(pattern)); - srsymtable:=classh^.publicsyms; - if assigned(sym) then - break; - classh:=classh^.childof; - end; - consume(ID); - do_member_read(sym,p1,pd,again); + consume(COLON); + p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2); + p2:=expr; + p2:=gennode(addn,p2,p3); + p1:=gennode(vecn,p1,p2); + p1^.memseg:=true; + p1^.memindex:=true; + end + else + begin + p1:=gennode(vecn,p1,p2); + p1^.memindex:=true; end; - objectdef: - begin - classh:=pobjectdef(pd); - sym:=nil; - while assigned(classh) do - begin - sym:=pvarsym(classh^.publicsyms^.search(pattern)); - srsymtable:=classh^.publicsyms; - if assigned(sym) then - break; - classh:=classh^.childof; - end; - consume(ID); - do_member_read(sym,p1,pd,again); - end; - pointerdef: - begin - if ppointerdef(pd)^.definition^.deftype - in [recorddef,objectdef,classrefdef] then - begin - Message(cg_e_invalid_qualifier); - { exterror:=strpnew(' may be pointer deref ^ is missing'); - error(invalid_qualifizier); } - Comment(V_hint,' may be pointer deref ^ is missing'); - end - else - Message(cg_e_invalid_qualifier); - end - else - begin - Message(cg_e_invalid_qualifier); - disposetree(p1); - p1:=genzeronode(errorn); - end; - end; + end + { else + if (target_info.target=target_GO32V2) and + assigned(p1^.symtableentry) and + assigned(p1^.symtableentry^.owner^.name) and + (p1^.symtableentry^.owner^.name^='SYSTEM') and + ((p1^.symtableentry^.name='PORT') or + (p1^.symtableentry^.name='PORTW') or + (p1^.symtableentry^.name='PORTL')) then + begin + p1:=gennode(vecn,p1,p2); + p1^.portindex:=true; + p + end; + end } + else + p1:=gennode(vecn,p1,p2); + if pd^.deftype=stringdef then + pd:=cchardef + else + pd:=parraydef(pd)^.definition; end; + if token=COMMA then consume(COMMA) + else break; + until false; + consume(RECKKLAMMER); + end; + end; + POINT: + begin + consume(POINT); + case pd^.deftype of + recorddef: + begin + sym:=pvarsym(precdef(pd)^.symtable^.search(pattern)); + consume(ID); + if sym=nil then + begin + Message(sym_e_illegal_field); + disposetree(p1); + p1:=genzeronode(errorn); + end + else + begin + p1:=gensubscriptnode(sym,p1); + pd:=sym^.definition; + end; + end; + classrefdef: + begin + classh:=pobjectdef(pclassrefdef(pd)^.definition); + sym:=nil; + while assigned(classh) do + begin + sym:=pvarsym(classh^.publicsyms^.search(pattern)); + srsymtable:=classh^.publicsyms; + if assigned(sym) then + break; + classh:=classh^.childof; + end; + consume(ID); + do_member_read(sym,p1,pd,again); + end; + objectdef: + begin + classh:=pobjectdef(pd); + sym:=nil; + while assigned(classh) do + begin + sym:=pvarsym(classh^.publicsyms^.search(pattern)); + srsymtable:=classh^.publicsyms; + if assigned(sym) then + break; + classh:=classh^.childof; + end; + consume(ID); + do_member_read(sym,p1,pd,again); + end; + pointerdef: + begin + if ppointerdef(pd)^.definition^.deftype + in [recorddef,objectdef,classrefdef] then + begin + Message(cg_e_invalid_qualifier); + { exterror:=strpnew(' may be pointer deref ^ is missing'); + error(invalid_qualifizier); } + Comment(V_hint,' may be pointer deref ^ is missing'); + end + else + Message(cg_e_invalid_qualifier); + end + else + begin + Message(cg_e_invalid_qualifier); + disposetree(p1); + p1:=genzeronode(errorn); + end; + end; + end; else begin { is this a procedure variable ? } @@ -1049,7 +1095,9 @@ unit pexpr; assigned(aktprocsym) and ((aktprocsym^.definition^.options and poclassmethod)<>0) then Message(parser_e_only_class_methods); - { !!!!! } + { no method pointer } + p1:=nil; + handle_propertysym(srsym,p1,pd); end; errorsym: begin @@ -1577,7 +1625,11 @@ unit pexpr; end. { $Log$ - Revision 1.5 1998-04-08 10:26:09 florian + Revision 1.6 1998-04-09 22:16:35 florian + * problem with previous REGALLOC solved + * improved property support + + Revision 1.5 1998/04/08 10:26:09 florian * correct error handling of virtual constructors * problem with new type declaration handling fixed diff --git a/compiler/tgeni386.pas b/compiler/tgeni386.pas index 7fea62d625..a04070c11c 100644 --- a/compiler/tgeni386.pas +++ b/compiler/tgeni386.pas @@ -204,11 +204,12 @@ unit tgeni386; begin if not(r in [R_EAX,R_EBX,R_ECX,R_EDX]) then exit; -{$ifdef REGALLOC} - exprasmlist^.concat(new(pairegdealloc,init(r))); -{$endif REGALLOC} + unused:=unused+[r]; inc(usablereg32); end; +{$ifdef REGALLOC} + exprasmlist^.concat(new(pairegdealloc,init(r))); +{$endif REGALLOC} end; {$ifdef SUPPORT_MMX} @@ -600,7 +601,11 @@ begin end. { $Log$ - Revision 1.2 1998-04-09 15:46:39 florian + Revision 1.3 1998-04-09 22:16:36 florian + * problem with previous REGALLOC solved + * improved property support + + Revision 1.2 1998/04/09 15:46:39 florian + register allocation tracing stuff added Revision 1.1.1.1 1998/03/25 11:18:15 root