paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 00:47:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

* problem with previous REGALLOC solved

Browse Source 
* improved property support
This commit is contained in:
florian 1998-04-09 22:16:33 +00:00
parent b69a1a8fd9
commit 50cbe1751e
5 changed files with 533 additions and 419 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
compiler/cgi386.pas
View File

@ -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

269
compiler/pass_1.pas
View File

@ -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

96
compiler/pdecl.pas
View File

@ -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

548
compiler/pexpr.pas
View File

@ -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

13
compiler/tgeni386.pas
View File

@ -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