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

* self moved to hidden parameter

Browse Source 
* removed hdisposen,hnewn,selfn
This commit is contained in:
peter 2003-05-09 17:47:02 +00:00
parent cb49935ca1
commit 1a2eedd767
32 changed files with 971 additions and 1047 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
compiler/cgbase.pas
View File

@ -416,6 +416,22 @@ implementation
framepointer_offset:=procdef.parast.address_fixup;
inc(procdef.parast.address_fixup,POINTER_SIZE);
end;
end;
procedure tprocinfo.after_header;
var
srsym : tvarsym;
begin
{ Retrieve function result offset }
if assigned(procdef.funcretsym) then
begin
current_procinfo.return_offset:=tvarsym(procdef.funcretsym).address+
tvarsym(procdef.funcretsym).owner.address_fixup;
if tvarsym(procdef.funcretsym).owner.symtabletype=localsymtable then
current_procinfo.return_offset:=tg.direction*current_procinfo.return_offset;
end;
{ retrieve offsets of self/vmt }
if assigned(procdef._class) then
begin
if (po_containsself in procdef.procoptions) then
@ -426,29 +442,37 @@ implementation
{ self isn't pushed in nested procedure of methods }
if (procdef.parast.symtablelevel=normal_function_level) then
begin
selfpointer_offset:=procdef.parast.address_fixup;
inc(procdef.parast.address_fixup,POINTER_SIZE);
srsym:=tvarsym(procdef.parast.search('self'));
if not assigned(srsym) then
internalerror(200305058);
selfpointer_offset:=tvarsym(srsym).address+srsym.owner.address_fixup;
end;
{ Special parameters for de-/constructors }
case procdef.proctypeoption of
potype_constructor :
begin
vmtpointer_offset:=procdef.parast.address_fixup;
inc(procdef.parast.address_fixup,POINTER_SIZE);
srsym:=tvarsym(procdef.parast.search('vmt'));
if not assigned(srsym) then
internalerror(200305058);
vmtpointer_offset:=tvarsym(srsym).address+srsym.owner.address_fixup;
end;
potype_destructor :
begin
if is_object(procdef._class) then
begin
vmtpointer_offset:=procdef.parast.address_fixup;
inc(procdef.parast.address_fixup,POINTER_SIZE);
srsym:=tvarsym(procdef.parast.search('vmt'));
if not assigned(srsym) then
internalerror(200305058);
vmtpointer_offset:=tvarsym(srsym).address+srsym.owner.address_fixup;
end
else
if is_class(procdef._class) then
begin
inheritedflag_offset:=procdef.parast.address_fixup;
inc(procdef.parast.address_fixup,POINTER_SIZE);
srsym:=tvarsym(procdef.parast.search('vmt'));
if not assigned(srsym) then
internalerror(200305058);
inheritedflag_offset:=tvarsym(srsym).address+srsym.owner.address_fixup;
end
else
internalerror(200303261);
@ -458,19 +482,6 @@ implementation
end;
procedure tprocinfo.after_header;
begin
{ Retrieve function result offset }
if assigned(procdef.funcretsym) then
begin
current_procinfo.return_offset:=tvarsym(procdef.funcretsym).address+
tvarsym(procdef.funcretsym).owner.address_fixup;
if tvarsym(procdef.funcretsym).owner.symtabletype=localsymtable then
current_procinfo.return_offset:=tg.direction*current_procinfo.return_offset;
end;
end;
procedure tprocinfo.after_pass1;
begin
end;
@ -630,7 +641,11 @@ implementation
end.
{
$Log$
Revision 1.45 2003-04-27 11:21:32 peter
Revision 1.46 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.45 2003/04/27 11:21:32 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be

12
compiler/cgobj.pas
View File

@ -1333,10 +1333,8 @@ unit cgobj;
{ call the special incr function or the generic addref }
if incrfunc<>'' then
begin
if loadref then
a_param_ref(list,OS_ADDR,ref,paramanager.getintparaloc(1))
else
a_paramaddr_ref(list,ref,paramanager.getintparaloc(1));
{ these functions get the pointer by value }
a_param_ref(list,OS_ADDR,ref,paramanager.getintparaloc(1));
a_call_name(list,incrfunc);
end
else
@ -1882,7 +1880,11 @@ finalization
end.
{
$Log$
Revision 1.94 2003-05-01 12:23:46 jonas
Revision 1.95 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.94 2003/05/01 12:23:46 jonas
* fix for op_reg_reg_reg in case the destination is the same as the first
source register

118
compiler/defcmp.pas
View File

@ -1058,84 +1058,102 @@ implementation
function compare_paras(paralist1,paralist2 : TLinkedList; acp : compare_type;allowdefaults:boolean):tequaltype;
var
def1,def2 : TParaItem;
currpara1,
currpara2 : TParaItem;
eq,lowesteq : tequaltype;
hpd : tprocdef;
hpd : tprocdef;
convtype : tconverttype;
begin
compare_paras:=te_incompatible;
{ we need to parse the list from left-right so the
not-default parameters are checked first }
lowesteq:=high(tequaltype);
def1:=TParaItem(paralist1.first);
def2:=TParaItem(paralist2.first);
while (assigned(def1)) and (assigned(def2)) do
currpara1:=TParaItem(paralist1.first);
currpara2:=TParaItem(paralist2.first);
while (assigned(currpara1)) and (assigned(currpara2)) do
begin
eq:=te_incompatible;
{ Unique types must match exact }
if ((df_unique in def1.paratype.def.defoptions) or (df_unique in def2.paratype.def.defoptions)) and
(def1.paratype.def<>def2.paratype.def) then
if ((df_unique in currpara1.paratype.def.defoptions) or (df_unique in currpara2.paratype.def.defoptions)) and
(currpara1.paratype.def<>currpara2.paratype.def) then
exit;
case acp of
cp_value_equal_const :
{ Handle hidden parameters separately, because self is
defined as voidpointer for methodpointers }
if (currpara1.is_hidden or
currpara2.is_hidden) then
begin
eq:=te_equal;
if not(vo_is_self in tvarsym(currpara1.parasym).varoptions) and
not(vo_is_self in tvarsym(currpara2.parasym).varoptions) then
begin
if (
(def1.paratyp<>def2.paratyp) and
((def1.paratyp in [vs_var,vs_out]) or
(def2.paratyp in [vs_var,vs_out]))
) then
exit;
eq:=compare_defs(def1.paratype.def,def2.paratype.def,nothingn);
if (currpara1.paratyp<>currpara2.paratyp) then
exit;
eq:=compare_defs(currpara1.paratype.def,currpara2.paratype.def,nothingn);
end;
cp_all :
begin
if (def1.paratyp<>def2.paratyp) then
exit;
eq:=compare_defs(def1.paratype.def,def2.paratype.def,nothingn);
end;
cp_procvar :
begin
if (def1.paratyp<>def2.paratyp) then
exit;
eq:=compare_defs_ext(def1.paratype.def,def2.paratype.def,nothingn,
false,true,convtype,hpd);
if (eq>te_incompatible) and
(eq<te_equal) and
not(
(convtype in [tc_equal,tc_int_2_int]) and
(def1.paratype.def.size=def2.paratype.def.size)
end
else
begin
case acp of
cp_value_equal_const :
begin
if (
(currpara1.paratyp<>currpara2.paratyp) and
((currpara1.paratyp in [vs_var,vs_out]) or
(currpara2.paratyp in [vs_var,vs_out]))
) then
begin
eq:=te_incompatible;
end;
exit;
eq:=compare_defs(currpara1.paratype.def,currpara2.paratype.def,nothingn);
end;
cp_all :
begin
if (currpara1.paratyp<>currpara2.paratyp) then
exit;
eq:=compare_defs(currpara1.paratype.def,currpara2.paratype.def,nothingn);
end;
cp_procvar :
begin
if (currpara1.paratyp<>currpara2.paratyp) then
exit;
eq:=compare_defs_ext(currpara1.paratype.def,currpara2.paratype.def,nothingn,
false,true,convtype,hpd);
if (eq>te_incompatible) and
(eq<te_equal) and
not(
(convtype in [tc_equal,tc_int_2_int]) and
(currpara1.paratype.def.size=currpara2.paratype.def.size)
) then
begin
eq:=te_incompatible;
end;
end;
else
eq:=compare_defs(currpara1.paratype.def,currpara2.paratype.def,nothingn);
end;
else
eq:=compare_defs(def1.paratype.def,def2.paratype.def,nothingn);
end;
end;
{ check type }
if eq=te_incompatible then
exit;
if eq<lowesteq then
lowesteq:=eq;
{ also check default value if both have it declared }
if assigned(def1.defaultvalue) and
assigned(def2.defaultvalue) then
if assigned(currpara1.defaultvalue) and
assigned(currpara2.defaultvalue) then
begin
if not equal_constsym(tconstsym(def1.defaultvalue),tconstsym(def2.defaultvalue)) then
if not equal_constsym(tconstsym(currpara1.defaultvalue),tconstsym(currpara2.defaultvalue)) then
exit;
end;
def1:=TParaItem(def1.next);
def2:=TParaItem(def2.next);
currpara1:=TParaItem(currpara1.next);
currpara2:=TParaItem(currpara2.next);
end;
{ when both lists are empty then the parameters are equal. Also
when one list is empty and the other has a parameter with default
value assigned then the parameters are also equal }
if ((def1=nil) and (def2=nil)) or
if ((currpara1=nil) and (currpara2=nil)) or
(allowdefaults and
((assigned(def1) and assigned(def1.defaultvalue)) or
(assigned(def2) and assigned(def2.defaultvalue)))) then
((assigned(currpara1) and assigned(currpara1.defaultvalue)) or
(assigned(currpara2) and assigned(currpara2.defaultvalue)))) then
compare_paras:=lowesteq;
end;
@ -1193,7 +1211,11 @@ implementation
end.
{
$Log$
Revision 1.23 2003-04-23 20:16:04 peter
Revision 1.24 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.23 2003/04/23 20:16:04 peter
+ added currency support based on int64
+ is_64bit for use in cg units instead of is_64bitint
* removed cgmessage from n386add, replace with internalerrors

7
compiler/fpcdefs.inc
View File

@ -59,7 +59,6 @@
{$ifdef powerpc}
{$define callparatemp}
{$define vs_hidden_self}
{$endif powerpc}
{ FPU Emulator support }
@ -74,7 +73,11 @@
{
$Log$
Revision 1.18 2003-04-30 09:42:42 florian
Revision 1.19 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.18 2003/04/30 09:42:42 florian
+ first changes to make self a hidden parameter
Revision 1.17 2003/04/24 22:29:57 florian

13
compiler/htypechk.pas
View File

@ -440,8 +440,8 @@ implementation
{ the nil as symtable signs firstcalln that this is
an overloaded operator }
inc(overloaded_operators[optoken].refs);
ht:=ccallnode.create(nil,overloaded_operators[optoken],nil,nil);
inc(tcallnode(ht).symtableprocentry.refs);
{ we already know the procdef to use for equal, so it can
skip the overload choosing in callnode.det_resulttype }
if assigned(operpd) then
@ -859,11 +859,6 @@ implementation
CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
exit;
end;
selfn :
begin
valid_for_assign:=true;
exit;
end;
calln :
begin
{ check return type }
@ -998,7 +993,11 @@ implementation
end.
{
$Log$
Revision 1.62 2003-04-27 11:21:32 peter
Revision 1.63 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.62 2003/04/27 11:21:32 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be

8
compiler/link.pas
View File

@ -190,6 +190,8 @@ begin
3. global libary dir
4. exe path of the compiler }
found:=FindFile(s,'.'+source_info.DirSep,foundfile);
if (not found) and (current_module.outputpath^<>'') then
found:=FindFile(s,current_module.outputpath^,foundfile);
if (not found) then
found:=current_module.locallibrarysearchpath.FindFile(s,foundfile);
if (not found) then
@ -654,7 +656,11 @@ initialization
end.
{
$Log$
Revision 1.35 2003-04-26 09:16:07 peter
Revision 1.36 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.35 2003/04/26 09:16:07 peter
* .o files belonging to the unit are first searched in the same dir
as the .ppu

244
compiler/ncal.pas
View File

@ -65,6 +65,8 @@ interface
{$ifdef EXTDEBUG}
procedure candidates_dump_info(lvl:longint;procs:pcandidate);
{$endif EXTDEBUG}
function gen_self_tree:tnode;
function gen_vmt_tree:tnode;
procedure bind_paraitem;
public
{ the symbol containing the definition of the procedure }
@ -89,6 +91,7 @@ interface
{ only the processor specific nodes need to override this }
{ constructor }
constructor create(l:tnode; v : tprocsym;st : tsymtable; mp : tnode);virtual;
constructor create_procvar(l,r:tnode);
constructor createintern(const name: string; params: tnode);
constructor createinternres(const name: string; params: tnode; const res: ttype);
constructor createinternreturn(const name: string; params: tnode; returnnode : tnode);
@ -112,7 +115,6 @@ interface
function track_state_pass(exec_known:boolean):boolean;override;
{$endif state_tracking}
function docompare(p: tnode): boolean; override;
procedure set_procvar(procvar:tnode);
procedure printnodedata(var t:text);override;
private
{$ifdef callparatemp}
@ -888,6 +890,20 @@ type
end;
constructor tcallnode.create_procvar(l,r:tnode);
begin
inherited create(calln,l,r);
symtableprocentry:=nil;
symtableproc:=nil;
include(flags,nf_return_value_used);
methodpointer:=nil;
procdefinition:=nil;
restypeset:=false;
funcretnode:=nil;
paralength:=-1;
end;
constructor tcallnode.createintern(const name: string; params: tnode);
var
srsym: tsym;
@ -985,12 +1001,6 @@ type
end;
procedure tcallnode.set_procvar(procvar:tnode);
begin
right:=procvar;
end;
function tcallnode.getcopy : tnode;
var
n : tcallnode;
@ -1070,7 +1080,7 @@ type
}
if assigned(methodpointer) and assigned(methodpointer.resulttype.def) then
if (methodpointer.resulttype.def.deftype = classrefdef) and
(methodpointer.nodetype in [typen,loadvmtn]) then
(methodpointer.nodetype in [typen,loadvmtaddrn]) then
begin
if (tclassrefdef(methodpointer.resulttype.def).pointertype.def.deftype = objectdef) then
objectdf := tobjectdef(tclassrefdef(methodpointer.resulttype.def).pointertype.def);
@ -1573,6 +1583,131 @@ type
end;
function tcallnode.gen_self_tree:tnode;
var
selftree : tnode;
begin
selftree:=nil;
{ constructors }
if (procdefinition.proctypeoption=potype_constructor) then
begin
if not(nf_inherited in flags) then
begin
{ push 0 as self when allocation is needed }
if (methodpointer.resulttype.def.deftype=classrefdef) or
(nf_new_call in flags) then
selftree:=cpointerconstnode.create(0,voidpointertype)
else
begin
if methodpointer.nodetype=typen then
selftree:=load_self
else
selftree:=methodpointer.getcopy;
end;
end
else
selftree:=load_self;
end
else
begin
{ Calling a static/class method from a non-static/class method,
then we need to load self with the VMT }
if (
(po_classmethod in procdefinition.procoptions) and
not(assigned(current_procdef) and
(po_classmethod in current_procdef.procoptions))
) or
(
(po_staticmethod in procdefinition.procoptions) and
not(assigned(current_procdef) and
(po_staticmethod in current_procdef.procoptions))
) then
begin
if (procdefinition.deftype<>procdef) then
internalerror(200305062);
if (oo_has_vmt in tprocdef(procdefinition)._class.objectoptions) then
begin
if methodpointer.resulttype.def.deftype=classrefdef then
selftree:=methodpointer.getcopy
else
selftree:=cloadvmtaddrnode.create(methodpointer.getcopy);
end
else
selftree:=cpointerconstnode.create(0,voidpointertype);
end
else
begin
if methodpointer.nodetype=typen then
selftree:=load_self
else
selftree:=methodpointer.getcopy;
end;
end;
result:=selftree;
end;
function tcallnode.gen_vmt_tree:tnode;
var
vmttree : tnode;
begin
vmttree:=nil;
if not(procdefinition.proctypeoption in [potype_constructor,potype_destructor]) then
internalerror(200305051);
{ inherited call, no create/destroy }
if (nf_inherited in flags) then
vmttree:=cpointerconstnode.create(0,voidpointertype)
else
{ constructor with extended syntax called from new }
if (nf_new_call in flags) then
vmttree:=cloadvmtaddrnode.create(ctypenode.create(methodpointer.resulttype))
else
{ destructor with extended syntax called from dispose }
if (nf_dispose_call in flags) then
vmttree:=cloadvmtaddrnode.create(methodpointer.getcopy)
else
if (methodpointer.resulttype.def.deftype=classrefdef) then
begin
{ constructor call via classreference => allocate memory }
if (procdefinition.proctypeoption=potype_constructor) and
is_class(tclassrefdef(methodpointer.resulttype.def).pointertype.def) then
vmttree:=methodpointer.getcopy
else
vmttree:=cpointerconstnode.create(0,voidpointertype);
end
else
{ class }
if is_class(methodpointer.resulttype.def) then
begin
{ destructor: release instance, flag(vmt)=1
constructor: direct call, do nothing, leave vmt=0 }
if (procdefinition.proctypeoption=potype_destructor) then
begin
{ do not release when called from member function
without specifying self explicit }
if (nf_member_call in flags) then
vmttree:=cpointerconstnode.create(0,voidpointertype)
else
vmttree:=cpointerconstnode.create(1,voidpointertype);
end
else
vmttree:=cpointerconstnode.create(0,voidpointertype);
end
else
{ object }
begin
{ destructor: direct call, no dispose, vmt=0
constructor: initialize object, load vmt }
if (procdefinition.proctypeoption=potype_constructor) then
vmttree:=cloadvmtaddrnode.create(ctypenode.create(methodpointer.resulttype))
else
vmttree:=cpointerconstnode.create(0,voidpointertype);
end;
result:=vmttree;
end;
procedure tcallnode.bind_paraitem;
var
@ -1636,7 +1771,21 @@ type
internalerror(200304082);
{ we need the information of the next parameter }
hiddentree:=gen_high_tree(pt.left,is_open_string(tparaitem(currpara.previous).paratype.def));
end;
end
else
if vo_is_self in tvarsym(currpara.parasym).varoptions then
begin
{$warning todo methodpointer}
if (right=nil) then
hiddentree:=gen_self_tree
else
hiddentree:=cnothingnode.create;
end
else
if vo_is_vmt in tvarsym(currpara.parasym).varoptions then
begin
hiddentree:=gen_vmt_tree;
end;
{ add the hidden parameter }
if not assigned(hiddentree) then
internalerror(200304073);
@ -1767,13 +1916,8 @@ type
(symtableprocentry.procdef_count=1) then
begin
hpt:=cloadnode.create(tprocsym(symtableprocentry),symtableproc);
if (symtableprocentry.owner.symtabletype=objectsymtable) then
begin
if assigned(methodpointer) then
tloadnode(hpt).set_mp(methodpointer.getcopy)
else
tloadnode(hpt).set_mp(cselfnode.create(tobjectdef(symtableprocentry.owner.defowner)));
end;
if assigned(methodpointer) then
tloadnode(hpt).set_mp(methodpointer.getcopy);
resulttypepass(hpt);
result:=hpt;
end
@ -1920,7 +2064,7 @@ type
{ direct call to inherited abstract method, then we
can already give a error in the compiler instead
of a runtime error }
if (methodpointer.nodetype=typen) and
if (nf_inherited in flags) and
(po_abstractmethod in procdefinition.procoptions) then
CGMessage(cg_e_cant_call_abstract_method);
@ -1928,13 +2072,13 @@ type
{ called in a con- or destructor then a warning }
{ will be made }
{ con- and destructors need a pointer to the vmt }
if (methodpointer.nodetype=typen) and
if (nf_inherited in flags) and
(procdefinition.proctypeoption in [potype_constructor,potype_destructor]) and
is_object(methodpointer.resulttype.def) and
not(current_procdef.proctypeoption in [potype_constructor,potype_destructor]) then
CGMessage(cg_w_member_cd_call_from_method);
if not(methodpointer.nodetype in [typen,hnewn]) then
if methodpointer.nodetype<>typen then
begin
hpt:=methodpointer;
while assigned(hpt) and (hpt.nodetype in [subscriptn,vecn]) do
@ -1968,12 +2112,39 @@ type
(tloadnode(hpt).symtableentry.typ=varsym) then
tvarsym(tloadnode(hpt).symtableentry).varstate:=vs_used;
end;
end
else
begin
{ When this is method the methodpointer must be available }
if procdefinition.owner.symtabletype=objectsymtable then
internalerror(200305061);
end;
{ bind paraitems to the callparanodes and insert hidden parameters }
aktcallprocdef:=procdefinition;
bind_paraitem;
{ methodpointer is only needed for virtual calls, and
it should then be loaded with the VMT }
if (po_virtualmethod in procdefinition.procoptions) and
not(assigned(methodpointer) and
(methodpointer.nodetype=typen)) then
begin
if not assigned(methodpointer) then
internalerror(200305063);
if (methodpointer.resulttype.def.deftype<>classrefdef) then
begin
methodpointer:=cloadvmtaddrnode.create(methodpointer);
resulttypepass(methodpointer);
end;
end
else
begin
{ not needed anymore }
methodpointer.free;
methodpointer:=nil;
end;
{ insert type conversions for parameters }
if assigned(left) then
tcallparanode(left).insert_typeconv(true);
@ -2214,29 +2385,18 @@ type
if (methodpointer<>nil) then
begin
if methodpointer.nodetype<>typen then
firstpass(methodpointer);
begin
firstpass(methodpointer);
registersfpu:=max(methodpointer.registersfpu,registersfpu);
registers32:=max(methodpointer.registers32,registers32);
{$ifdef SUPPORT_MMX }
registersmmx:=max(methodpointer.registersmmx,registersmmx);
{$endif SUPPORT_MMX}
end;
{ if we are calling the constructor }
if procdefinition.proctypeoption in [potype_constructor] then
if procdefinition.proctypeoption=potype_constructor then
verifyabstractcalls;
case methodpointer.nodetype of
{ but only, if this is not a supporting node }
typen: ;
{ we need one register for new return value PM }
hnewn : if registers32=0 then
registers32:=1;
else
begin
{ this is not a good reason to accept it in FPC if we produce
wrong code for it !!! (PM) }
registersfpu:=max(methodpointer.registersfpu,registersfpu);
registers32:=max(methodpointer.registers32,registers32);
{$ifdef SUPPORT_MMX }
registersmmx:=max(methodpointer.registersmmx,registersmmx);
{$endif SUPPORT_MMX}
end;
end;
end;
if inlined then
@ -2517,7 +2677,11 @@ begin
end.
{
$Log$
Revision 1.148 2003-05-05 14:53:16 peter
Revision 1.149 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.148 2003/05/05 14:53:16 peter
* vs_hidden replaced by is_hidden boolean
Revision 1.147 2003/04/27 11:21:33 peter

420
compiler/ncgcal.pas
View File

@ -40,10 +40,7 @@ interface
end;
tcgcallnode = class(tcallnode)
private
function push_self_and_vmt(needvmtreg:boolean):tregister;
protected
// funcretref : treference;
refcountedtemp : treference;
procedure handle_return_value(inlined:boolean);
{# This routine is used to push the current frame pointer
@ -148,6 +145,45 @@ implementation
else
push_value_para(exprasmlist,left,calloption,para_offset,para_alignment,paraitem.paraloc);
end
{ hidden parameters }
else if paraitem.is_hidden then
begin
{ don't push a node that already generated a pointer type
by address for implicit hidden parameters }
if (vo_is_funcret in tvarsym(paraitem.parasym).varoptions) or
(not(left.resulttype.def.deftype in [pointerdef,classrefdef]) and
paramanager.push_addr_param(paraitem.paratype.def,calloption)) then
begin
if not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
internalerror(200305071);
inc(pushedparasize,POINTER_SIZE);
if calloption=pocall_inline then
begin
{$ifdef newra}
tmpreg:=rg.getaddressregister(exprasmlist);
{$else}
tmpreg:=cg.get_scratch_reg_address(exprasmlist);
{$endif}
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,tmpreg);
reference_reset_base(href,current_procinfo.framepointer,para_offset-pushedparasize);
cg.a_load_reg_ref(exprasmlist,OS_ADDR,tmpreg,href);
{$ifdef newra}
rg.ungetregisterint(exprasmlist,tmpreg);
{$else}
cg.free_scratch_reg(exprasmlist,tmpreg);
{$endif}
end
else
cg.a_paramaddr_ref(exprasmlist,left.location.reference,paraitem.paraloc);
location_release(exprasmlist,left.location);
end
else
begin
push_value_para(exprasmlist,left,calloption,
para_offset,para_alignment,paraitem.paraloc);
end;
end
{ filter array of const c styled args }
else if is_array_of_const(left.resulttype.def) and (nf_cargs in left.flags) then
begin
@ -210,7 +246,7 @@ implementation
{ passing self to a var parameter is allowed in
TP and delphi }
if not((left.location.loc=LOC_CREFERENCE) and
(left.nodetype=selfn)) then
is_self_node(left)) then
internalerror(200106041);
end;
if (paraitem.paratyp=vs_out) and
@ -241,16 +277,13 @@ implementation
end
else
begin
{ open array must always push the address, this is needed to
also push addr of small open arrays and with cdecl functions (PFV) }
if (
assigned(paraitem.paratype.def) and
(is_open_array(paraitem.paratype.def) or
is_array_of_const(paraitem.paratype.def))
) or
(
paramanager.push_addr_param(resulttype.def,calloption)
) then
{ don't push a node that already generated a pointer type
by address for implicit hidden parameters }
if (not(
paraitem.is_hidden and
(left.resulttype.def.deftype in [pointerdef,classrefdef])
) and
paramanager.push_addr_param(paraitem.paratype.def,calloption)) then
begin
if not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
begin
@ -341,328 +374,6 @@ implementation
end;
function tcgcallnode.push_self_and_vmt(needvmtreg:boolean):tregister;
var
href : treference;
vmtloc,selfloc : tlocation;
self_is_vmt,
vmtrefaddr,
selfrefaddr : boolean;
procedure selfloc_to_register;
var
hregister : tregister;
begin
case selfloc.loc of
LOC_REGISTER :
hregister:=selfloc.register;
LOC_CREFERENCE,
LOC_REFERENCE :
begin
hregister:=rg.getaddressregister(exprasmlist);
if selfrefaddr then
begin
cg.a_loadaddr_ref_reg(exprasmlist,selfloc.reference,hregister);
selfrefaddr:=false;
end
else
cg.a_load_ref_reg(exprasmlist,OS_ADDR,selfloc.reference,hregister);
reference_release(exprasmlist,selfloc.reference);
end;
else
internalerror(200303269);
end;
location_reset(selfloc,LOC_REGISTER,OS_ADDR);
selfloc.register:=hregister;
end;
begin
result.enum:=R_INTREGISTER;
result.number:=NR_NO;
location_reset(vmtloc,LOC_CONSTANT,OS_ADDR);
location_reset(selfloc,LOC_CONSTANT,OS_ADDR);
vmtrefaddr:=false;
selfrefaddr:=false;
self_is_vmt:=false;
{ generate fake methodpointer node for withsymtable }
if (symtableproc.symtabletype=withsymtable) then
begin
methodpointer:=cnothingnode.create;
methodpointer.resulttype:=twithnode(twithsymtable(symtableproc).withnode).left.resulttype;
end;
if assigned(methodpointer) then
begin
case methodpointer.nodetype of
typen:
begin
if (sp_static in symtableprocentry.symoptions) then
begin
self_is_vmt:=true;
if (oo_has_vmt in tobjectdef(methodpointer.resulttype.def).objectoptions) then
begin
location_reset(vmtloc,LOC_REFERENCE,OS_NO);
reference_reset_symbol(vmtloc.reference,objectlibrary.newasmsymboldata(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),0);
vmtrefaddr:=true;
end;
end
else
begin
{ normal member call, load self. Not for classes
when we call the constructor }
if not(
is_class(methodpointer.resulttype.def) and
(procdefinition.proctypeoption=potype_constructor) and
(current_procdef.proctypeoption<>potype_constructor)
) then
begin
location_reset(selfloc,LOC_REGISTER,OS_ADDR);
selfloc.register:=cg.g_load_self(exprasmlist);
end;
end;
if (procdefinition.proctypeoption in [potype_constructor,potype_destructor]) then
begin
if is_object(methodpointer.resulttype.def) then
begin
{ reset self when calling constructor from destructor }
if (procdefinition.proctypeoption=potype_constructor) and
assigned(current_procdef) and
(current_procdef.proctypeoption=potype_destructor) then
begin
location_release(exprasmlist,selfloc);
location_reset(selfloc,LOC_CONSTANT,OS_ADDR);
end;
end;
end;
end;
hnewn:
begin
{ constructor with extended syntax called from new }
{ vmt }
location_reset(vmtloc,LOC_REFERENCE,OS_ADDR);
reference_reset_symbol(vmtloc.reference,objectlibrary.newasmsymboldata(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),0);
vmtrefaddr:=true;
end;
hdisposen:
begin
{ destructor with extended syntax called from dispose }
{ hdisposen always deliver LOC_REFERENCE }
secondpass(methodpointer);
{ vmt }
location_reset(vmtloc,LOC_REFERENCE,OS_ADDR);
reference_reset_symbol(vmtloc.reference,objectlibrary.newasmsymboldata(tobjectdef(methodpointer.resulttype.def).vmt_mangledname),0);
vmtrefaddr:=true;
{ self, load in register first when it requires a virtual call }
location_reset(selfloc,LOC_REFERENCE,OS_ADDR);
selfloc.reference:=methodpointer.location.reference;
selfrefaddr:=true;
end;
else
begin
{ call to an instance member }
if (symtableproc.symtabletype<>withsymtable) then
begin
secondpass(methodpointer);
case methodpointer.location.loc of
LOC_CREGISTER,
LOC_REGISTER:
begin
location_reset(selfloc,LOC_REGISTER,OS_ADDR);
selfloc.register:=methodpointer.location.register;
end;
LOC_CREFERENCE,
LOC_REFERENCE :
begin
location_reset(selfloc,LOC_REFERENCE,OS_ADDR);
selfloc.reference:=methodpointer.location.reference;
if (methodpointer.resulttype.def.deftype<>classrefdef) and
not(is_class_or_interface(methodpointer.resulttype.def)) then
selfrefaddr:=true;
end;
else
internalerror(200303212);
end;
end
else
begin
location_reset(selfloc,LOC_REFERENCE,OS_ADDR);
selfloc.reference:=twithnode(twithsymtable(symtableproc).withnode).withreference;
if (nf_islocal in twithnode(twithsymtable(symtableproc).withnode).flags) and
(twithsymtable(symtableproc).direct_with) and
not(is_class_or_interface(twithnode(twithsymtable(symtableproc).withnode).left.resulttype.def)) then
selfrefaddr:=true;
end;
if (po_staticmethod in procdefinition.procoptions) or
(po_classmethod in procdefinition.procoptions) then
begin
self_is_vmt:=true;
{ classref are already loaded with VMT }
if (methodpointer.resulttype.def.deftype=classrefdef) then
location_copy(vmtloc,selfloc)
else
begin
if (oo_has_vmt in tprocdef(procdefinition)._class.objectoptions) then
begin
{ load VMT from passed self }
selfloc_to_register;
cg.g_maybe_testself(exprasmlist,selfloc.register);
location_copy(vmtloc,selfloc);
reference_reset_base(href,vmtloc.register,tprocdef(procdefinition)._class.vmt_offset);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,vmtloc.register);
end;
end;
{ reset self }
location_reset(selfloc,LOC_CONSTANT,OS_ADDR);
end;
if (procdefinition.proctypeoption in [potype_constructor,potype_destructor]) then
begin
{ constructor call via classreference => allocate memory }
if (methodpointer.resulttype.def.deftype=classrefdef) then
begin
if (procdefinition.proctypeoption=potype_constructor) and
is_class(tclassrefdef(methodpointer.resulttype.def).pointertype.def) then
begin
self_is_vmt:=true;
{ vmt load from provided methodpointer that
was already loaded in selfloc }
location_copy(vmtloc,selfloc);
{ reset self }
location_reset(selfloc,LOC_CONSTANT,OS_ADDR);
end;
end
else
{ class }
if is_class(methodpointer.resulttype.def) then
begin
{ destructor: release instance, flag(vmt)=1
constructor: direct call, do nothing, leave vmt=0 }
if (procdefinition.proctypeoption=potype_destructor) then
begin
{ flag 1 for destructor: remove data }
location_reset(vmtloc,LOC_CONSTANT,OS_ADDR);
vmtloc.value:=1;
end;
end
else
{ object }
begin
{ destructor: direct call, no dispose, vmt=0
constructor: initialize object, load vmt }
if (procdefinition.proctypeoption=potype_constructor) then
begin
{ vmt }
location_reset(vmtloc,LOC_REFERENCE,OS_ADDR);
reference_reset_symbol(vmtloc.reference,objectlibrary.newasmsymboldata(
tobjectdef(methodpointer.resulttype.def).vmt_mangledname),0);
vmtrefaddr:=true;
end;
end;
end;
end;
end;
end
else
{ No methodpointer }
begin
if (po_staticmethod in procdefinition.procoptions) or
(po_classmethod in procdefinition.procoptions) then
begin
self_is_vmt:=true;
{ Load VMT from self? }
if (
(po_classmethod in procdefinition.procoptions) and
not(assigned(current_procdef) and
(po_classmethod in current_procdef.procoptions))
) or
(
(po_staticmethod in procdefinition.procoptions) and
not(assigned(current_procdef) and
(po_staticmethod in current_procdef.procoptions))
) then
begin
if (oo_has_vmt in tprocdef(procdefinition)._class.objectoptions) then
begin
{ load vmt from self passed to the current method }
location_reset(vmtloc,LOC_REGISTER,OS_ADDR);
vmtloc.register:=cg.g_load_self(exprasmlist);
cg.g_maybe_testself(exprasmlist,vmtloc.register);
reference_reset_base(href,vmtloc.register,tprocdef(procdefinition)._class.vmt_offset);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,vmtloc.register);
end;
end
else
begin
{ self is already VMT }
location_reset(vmtloc,LOC_REGISTER,OS_ADDR);
vmtloc.register:=cg.g_load_self(exprasmlist);
end;
end
else
begin
{ member call, load self }
location_reset(selfloc,LOC_REGISTER,OS_ADDR);
selfloc.register:=cg.g_load_self(exprasmlist);
end;
end;
{ Do we need to push the VMT as self for
class methods and static methods? }
if self_is_vmt then
begin
location_release(exprasmlist,selfloc);
location_copy(selfloc,vmtloc);
selfrefaddr:=vmtrefaddr;
end;
{ when we need the vmt in a register then we already
load self in a register so it can generate optimized code }
if needvmtreg then
selfloc_to_register;
{ constructor/destructor need vmt }
if (procdefinition.proctypeoption in [potype_constructor,potype_destructor]) then
begin
if vmtrefaddr then
cg.a_paramaddr_ref(exprasmlist,vmtloc.reference,paramanager.getintparaloc(2))
else
cg.a_param_loc(exprasmlist,vmtloc,paramanager.getintparaloc(2));
end;
if not self_is_vmt then
location_release(exprasmlist,vmtloc);
{ push self }
if selfrefaddr then
cg.a_paramaddr_ref(exprasmlist,selfloc.reference,paramanager.getintparaloc(1))
else
cg.a_param_loc(exprasmlist,selfloc,paramanager.getintparaloc(1));
if needvmtreg then
begin
{ self should already be loaded in a register }
if selfloc.register.number=NR_NO then
internalerror(2003032611);
{ load vmt from self, this is already done
for static/class methods }
if not self_is_vmt then
begin
cg.g_maybe_testself(exprasmlist,selfloc.register);
{ this is one point where we need vmt_offset (PM) }
reference_reset_base(href,selfloc.register,tprocdef(procdefinition)._class.vmt_offset);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,selfloc.register);
end;
result:=selfloc.register;
end
else
location_release(exprasmlist,selfloc);
end;
procedure tcgcallnode.push_framepointer;
var
href : treference;
@ -866,7 +577,6 @@ implementation
href : treference;
hp : tnode;
pp : tcallparanode;
virtual_vmt_call,
inlined : boolean;
inlinecode : tprocinlinenode;
store_parast_fixup,
@ -875,8 +585,8 @@ implementation
pop_size : longint;
returnref,
pararef : treference;
accreg,
vmtreg : tregister;
vmtreg,
accreg : tregister;
oldaktcallnode : tcallnode;
begin
iolabel:=nil;
@ -1022,18 +732,6 @@ implementation
if inlined or
(right=nil) then
begin
{ Virtual function call through VMT? }
vmtreg.enum:=R_INTREGISTER;
vmtreg.number:=NR_NO;
virtual_vmt_call:=(po_virtualmethod in procdefinition.procoptions) and
not(assigned(methodpointer) and
(methodpointer.nodetype=typen));
{ push self/vmt for methods }
if assigned(symtableproc) and
(symtableproc.symtabletype in [withsymtable,objectsymtable]) then
vmtreg:=push_self_and_vmt(virtual_vmt_call);
{ push base pointer ?}
{ never when inlining, since if necessary, the base pointer }
{ can/will be gottten from the current procedure's symtable }
@ -1047,8 +745,13 @@ implementation
rg.saveintregvars(exprasmlist,regs_to_push_int);
rg.saveotherregvars(exprasmlist,regs_to_push_other);
if virtual_vmt_call then
if (po_virtualmethod in procdefinition.procoptions) and
assigned(methodpointer) then
begin
secondpass(methodpointer);
location_force_reg(exprasmlist,methodpointer.location,OS_ADDR,false);
vmtreg:=methodpointer.location.register;
{ virtual methods require an index }
if tprocdef(procdefinition).extnumber=-1 then
internalerror(200304021);
@ -1067,7 +770,7 @@ implementation
cg.a_call_ref(exprasmlist,href);
{ release self }
rg.ungetregisterint(exprasmlist,vmtreg);
rg.ungetaddressregister(exprasmlist,vmtreg);
end
else
begin
@ -1133,6 +836,11 @@ implementation
begin
{ the old pop_size was already included in pushedparasize }
pop_size:=pushedparasize;
{ for Cdecl functions we don't need to pop the funcret when it
was pushed by para }
if (procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl]) and
paramanager.ret_in_param(procdefinition.rettype.def,procdefinition.proccalloption) then
dec(pop_size,POINTER_SIZE);
end;
{ Remove parameters/alignment from the stack }
@ -1437,7 +1145,11 @@ begin
end.
{
$Log$
Revision 1.58 2003-05-05 14:53:16 peter
Revision 1.59 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.58 2003/05/05 14:53:16 peter
* vs_hidden replaced by is_hidden boolean
Revision 1.57 2003/04/30 20:53:32 florian

10
compiler/ncginl.pas
View File

@ -57,7 +57,7 @@ implementation
symconst,symdef,defutil,symsym,
aasmbase,aasmtai,aasmcpu,
cginfo,cgbase,pass_1,pass_2,
cpubase,paramgr,
cpuinfo,cpubase,paramgr,
nbas,ncon,ncal,ncnv,nld,
tgobj,ncgutil,cgobj,rgobj,rgcpu
{$ifndef cpu64bit}
@ -420,7 +420,7 @@ implementation
addvalue,tcallparanode(left).left.location)
else
cg.a_op_const_loc(exprasmlist,addsubop[inlinenumber],
addvalue,tcallparanode(left).left.location);
aword(addvalue),tcallparanode(left).left.location);
end
else
begin
@ -682,7 +682,11 @@ end.
{
$Log$
Revision 1.29 2003-05-01 12:27:08 jonas
Revision 1.30 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.29 2003/05/01 12:27:08 jonas
* fixed include/exclude for normalsets
Revision 1.28 2003/04/27 11:21:33 peter

156
compiler/ncgmem.pas
View File

@ -34,15 +34,7 @@ interface
node,nmem;
type
tcgloadvmtnode = class(tloadvmtnode)
procedure pass_2;override;
end;
tcghnewnode = class(thnewnode)
procedure pass_2;override;
end;
tcghdisposenode = class(thdisposenode)
tcgloadvmtaddrnode = class(tloadvmtaddrnode)
procedure pass_2;override;
end;
@ -62,10 +54,6 @@ interface
procedure pass_2;override;
end;
tcgselfnode = class(tselfnode)
procedure pass_2;override;
end;
tcgwithnode = class(twithnode)
procedure pass_2;override;
end;
@ -113,67 +101,68 @@ implementation
TCGLOADNODE
*****************************************************************************}
procedure tcgloadvmtnode.pass_2;
procedure tcgloadvmtaddrnode.pass_2;
var
href : treference;
begin
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=rg.getaddressregister(exprasmlist);
{ on 80386, LEA is the same as mov imm32 }
reference_reset_symbol(href,
objectlibrary.newasmsymboldata(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname),0);
cg.a_loadaddr_ref_reg(exprasmlist,href,location.register);
end;
{*****************************************************************************
TCGHNEWNODE
*****************************************************************************}
procedure tcghnewnode.pass_2;
begin
location_reset(location,LOC_VOID,OS_NO);
{ completely resolved in first pass now }
end;
{*****************************************************************************
TCGHDISPOSENODE
*****************************************************************************}
procedure tcghdisposenode.pass_2;
begin
location_reset(location,LOC_REFERENCE,def_cgsize(resulttype.def));
secondpass(left);
if codegenerror then
exit;
case left.location.loc of
LOC_REGISTER:
begin
if not rg.isaddressregister(left.location.register) then
begin
location_release(exprasmlist,left.location);
location.reference.base := rg.getaddressregister(exprasmlist);
cg.a_load_reg_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.register,
location.reference.base);
end
else
location.reference.base := left.location.register;
end;
LOC_CREGISTER,
LOC_CREFERENCE,
LOC_REFERENCE:
begin
location_release(exprasmlist,left.location);
location.reference.base:=rg.getaddressregister(exprasmlist);
cg.a_load_loc_reg(exprasmlist,left.location,location.reference.base);
end;
if (left.nodetype<>typen) then
begin
{ left contains self, load vmt from self }
secondpass(left);
if is_object(left.resulttype.def) then
begin
case left.location.loc of
LOC_CREFERENCE,
LOC_REFERENCE:
begin
location_release(exprasmlist,left.location);
reference_reset_base(href,rg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,href.base);
end;
else
internalerror(200305056);
end;
end
else
internalerror(2002032217);
end;
begin
case left.location.loc of
LOC_REGISTER:
begin
if not rg.isaddressregister(left.location.register) then
begin
location_release(exprasmlist,left.location);
reference_reset_base(href,rg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_load_reg_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.register,href.base);
end
else
reference_reset_base(href,left.location.register,tobjectdef(left.resulttype.def).vmt_offset);
end;
LOC_CREGISTER,
LOC_CREFERENCE,
LOC_REFERENCE:
begin
location_release(exprasmlist,left.location);
reference_reset_base(href,rg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_load_loc_reg(exprasmlist,left.location,href.base);
end;
else
internalerror(200305057);
end;
end;
reference_release(exprasmlist,href);
location.register:=rg.getaddressregister(exprasmlist);
cg.g_maybe_testself(exprasmlist,href.base);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,href,location.register);
end
else
begin
reference_reset_symbol(href,
objectlibrary.newasmsymboldata(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname),0);
location.register:=rg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,href,location.register);
end;
end;
@ -342,26 +331,6 @@ implementation
location.size:=def_cgsize(resulttype.def);
end;
{*****************************************************************************
TCGSELFNODE
*****************************************************************************}
procedure tcgselfnode.pass_2;
begin
if (resulttype.def.deftype=classrefdef) or
(is_class(resulttype.def) or
(po_staticmethod in current_procdef.procoptions)) then
begin
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=cg.g_load_self(exprasmlist);
end
else
begin
location_reset(location,LOC_CREFERENCE,OS_ADDR);
location.reference.base:=cg.g_load_self(exprasmlist);
end;
end;
{*****************************************************************************
TCGWITHNODE
@ -933,20 +902,21 @@ implementation
begin
cloadvmtnode:=tcgloadvmtnode;
chnewnode:=tcghnewnode;
chdisposenode:=tcghdisposenode;
cloadvmtaddrnode:=tcgloadvmtaddrnode;
caddrnode:=tcgaddrnode;
cdoubleaddrnode:=tcgdoubleaddrnode;
cderefnode:=tcgderefnode;
csubscriptnode:=tcgsubscriptnode;
cselfnode:=tcgselfnode;
cwithnode:=tcgwithnode;
cvecnode:=tcgvecnode;
end.
{
$Log$
Revision 1.50 2003-05-07 09:16:23 mazen
Revision 1.51 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.50 2003/05/07 09:16:23 mazen
- non used units removed from uses clause
Revision 1.49 2003/04/27 11:21:33 peter

9
compiler/ncgutil.pas
View File

@ -1722,7 +1722,8 @@ implementation
if assigned(pd) then
begin
objectlibrary.getlabel(nodestroycall);
reference_reset_base(href,current_procinfo.framepointer,current_procinfo.selfpointer_offset);
{ check VMT pointer if this is an inherited constructor }
reference_reset_base(href,current_procinfo.framepointer,current_procinfo.vmtpointer_offset);
cg.a_cmp_const_ref_label(list,OS_ADDR,OC_EQ,0,href,nodestroycall);
r:=cg.g_load_self(list);
if is_class(current_procdef._class) then
@ -2006,7 +2007,11 @@ implementation
end.
{
$Log$
Revision 1.95 2003-04-29 07:28:52 michael
Revision 1.96 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.95 2003/04/29 07:28:52 michael
+ Patch from peter to fix wrong pushing of ansistring function results in open array
Revision 1.94 2003/04/28 21:17:38 peter

14
compiler/ncnv.pas
View File

@ -1127,6 +1127,7 @@ implementation
te_convert_operator :
begin
include(current_procinfo.flags,pi_do_call);
inc(overloaded_operators[_assignment].refs);
hp:=ccallnode.create(ccallparanode.create(left,nil),
overloaded_operators[_assignment],nil,nil);
{ tell explicitly which def we must use !! (PM) }
@ -1177,7 +1178,7 @@ implementation
if assigned(tcallnode(left).methodpointer) then
tloadnode(hp).set_mp(tcallnode(left).methodpointer.getcopy)
else
tloadnode(hp).set_mp(cselfnode.create(tobjectdef(tcallnode(left).symtableprocentry.owner.defowner)));
tloadnode(hp).set_mp(load_self);
end;
resulttypepass(hp);
end;
@ -1214,7 +1215,7 @@ implementation
begin
{ we can translate the typeconvnode to 'as' when
typecasting to a class or interface }
hp:=casnode.create(left,cloadvmtnode.create(ctypenode.create(resulttype)));
hp:=casnode.create(left,cloadvmtaddrnode.create(ctypenode.create(resulttype)));
left:=nil;
result:=hp;
exit;
@ -1277,8 +1278,7 @@ implementation
(left.resulttype.def.deftype=procvardef) and
(not is_void(tprocvardef(left.resulttype.def).rettype.def)) then
begin
hp:=ccallnode.create(nil,nil,nil,nil);
tcallnode(hp).set_procvar(left);
hp:=ccallnode.create_procvar(nil,left);
resulttypepass(hp);
left:=hp;
end;
@ -2091,7 +2091,11 @@ begin
end.
{
$Log$
Revision 1.109 2003-04-27 11:21:33 peter
Revision 1.110 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.109 2003/04/27 11:21:33 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be

12
compiler/ninl.pas
View File

@ -483,8 +483,7 @@ implementation
{ support writeln(procvar) }
if (para.left.resulttype.def.deftype=procvardef) then
begin
p1:=ccallnode.create(nil,nil,nil,nil);
tcallnode(p1).set_procvar(para.left);
p1:=ccallnode.create_procvar(nil,para.left);
resulttypepass(p1);
para.left:=p1;
end;
@ -576,8 +575,7 @@ implementation
{ support writeln(procvar) }
if (para.left.resulttype.def.deftype=procvardef) then
begin
p1:=ccallnode.create(nil,nil,nil,nil);
tcallnode(p1).set_procvar(para.left);
p1:=ccallnode.create_procvar(nil,para.left);
resulttypepass(p1);
para.left:=p1;
end;
@ -2351,7 +2349,11 @@ begin
end.
{
$Log$
Revision 1.109 2003-04-27 11:21:33 peter
Revision 1.110 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.109 2003/04/27 11:21:33 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be

50
compiler/nld.pas
View File

@ -128,6 +128,8 @@ interface
procedure load_procvar_from_calln(var p1:tnode);
function load_high_value(vs:tvarsym):tnode;
function load_self:tnode;
function is_self_node(p:tnode):boolean;
implementation
@ -199,6 +201,28 @@ implementation
end;
function load_self:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('self',srsym,srsymtable);
if assigned(srsym) then
result:=cloadnode.create(srsym,srsymtable)
else
CGMessage(cg_e_illegal_expression);
end;
function is_self_node(p:tnode):boolean;
begin
is_self_node:=(p.nodetype=loadn) and
(tloadnode(p).symtableentry.typ=varsym) and
(vo_is_self in tvarsym(tloadnode(p).symtableentry).varoptions);
end;
{*****************************************************************************
TLOADNODE
*****************************************************************************}
@ -320,7 +344,23 @@ implementation
if nf_absolute in flags then
tvarsym(symtableentry).varstate:=vs_used
else
resulttype:=tvarsym(symtableentry).vartype;
begin
{ fix self type which is declared as voidpointer in the
definition }
if vo_is_self in tvarsym(symtableentry).varoptions then
begin
if (po_classmethod in tprocdef(symtableentry.owner.defowner).procoptions) or
(po_staticmethod in tprocdef(symtableentry.owner.defowner).procoptions) then
begin
resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class);
resulttype.setdef(tclassrefdef.create(resulttype));
end
else
resulttype.setdef(tprocdef(symtableentry.owner.defowner)._class);
end
else
resulttype:=tvarsym(symtableentry).vartype;
end;
end;
typedconstsym :
if not(nf_absolute in flags) then
@ -861,7 +901,7 @@ implementation
hp : tarrayconstructornode;
dovariant : boolean;
htype : ttype;
orgflags : tnodeflagset;
orgflags : tnodeflags;
begin
dovariant:=(nf_forcevaria in flags) or tarraydef(resulttype.def).isvariant;
result:=nil;
@ -1127,7 +1167,11 @@ begin
end.
{
$Log$
Revision 1.90 2003-04-27 11:21:33 peter
Revision 1.91 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.90 2003/04/27 11:21:33 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be

10
compiler/nmat.pas
View File

@ -530,8 +530,9 @@ implementation
minusdef:=nil;
if assigned(overloaded_operators[_minus]) then
minusdef:=overloaded_operators[_minus].search_procdef_unary_operator(left.resulttype.def);
if minusdef<>nil then
if assigned(minusdef) then
begin
inc(overloaded_operators[_minus].refs);
t:=ccallnode.create(ccallparanode.create(left,nil),
overloaded_operators[_minus],nil,nil);
left:=nil;
@ -705,6 +706,7 @@ implementation
notdef:=overloaded_operators[_op_not].search_procdef_unary_operator(left.resulttype.def);
if notdef<>nil then
begin
inc(overloaded_operators[_op_not].refs);
t:=ccallnode.create(ccallparanode.create(left,nil),
overloaded_operators[_op_not],nil,nil);
left:=nil;
@ -793,7 +795,11 @@ begin
end.
{
$Log$
Revision 1.47 2003-04-25 20:59:33 peter
Revision 1.48 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.47 2003/04/25 20:59:33 peter
* removed funcretn,funcretsym, function result is now in varsym
and aliases for result and function name are added using absolutesym
* vs_hidden parameter for funcret passed in parameter

207
compiler/nmem.pas
View File

@ -32,30 +32,12 @@ interface
cpubase;
type
tloadvmtnode = class(tunarynode)
tloadvmtaddrnode = class(tunarynode)
constructor create(l : tnode);virtual;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
end;
tloadvmtnodeclass = class of tloadvmtnode;
thnewnode = class(tnode)
objtype : ttype;
constructor create(t:ttype);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
end;
thnewnodeclass = class of thnewnode;
thdisposenode = class(tunarynode)
constructor create(l : tnode);virtual;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
end;
thdisposenodeclass = class of thdisposenode;
tloadvmtaddrnodeclass = class of tloadvmtaddrnode;
taddrnode = class(tunarynode)
getprocvardef : tprocvardef;
@ -107,17 +89,6 @@ interface
end;
tvecnodeclass = class of tvecnode;
tselfnode = class(tnode)
classdef : tdef; { objectdef or classrefdef }
constructor create(_class : tdef);virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure derefimpl;override;
function pass_1 : tnode;override;
function det_resulttype:tnode;override;
end;
tselfnodeclass = class of tselfnode;
twithnode = class(tbinarynode)
withsymtable : twithsymtable;
tablecount : longint;
@ -134,15 +105,12 @@ interface
twithnodeclass = class of twithnode;
var
cloadvmtnode : tloadvmtnodeclass;
chnewnode : thnewnodeclass;
chdisposenode : thdisposenodeclass;
cloadvmtaddrnode : tloadvmtaddrnodeclass;
caddrnode : taddrnodeclass;
cdoubleaddrnode : tdoubleaddrnodeclass;
cderefnode : tderefnodeclass;
csubscriptnode : tsubscriptnodeclass;
cvecnode : tvecnodeclass;
cselfnode : tselfnodeclass;
cwithnode : twithnodeclass;
implementation
@ -156,118 +124,40 @@ implementation
;
{*****************************************************************************
TLOADVMTNODE
TLOADVMTADDRNODE
*****************************************************************************}
constructor tloadvmtnode.create(l : tnode);
constructor tloadvmtaddrnode.create(l : tnode);
begin
inherited create(loadvmtn,l);
inherited create(loadvmtaddrn,l);
end;
function tloadvmtnode.det_resulttype:tnode;
function tloadvmtaddrnode.det_resulttype:tnode;
begin
result:=nil;
resulttypepass(left);
if codegenerror then
exit;
if left.resulttype.def.deftype<>objectdef then
Message(parser_e_pointer_to_class_expected);
resulttype.setdef(tclassrefdef.create(left.resulttype));
end;
function tloadvmtnode.pass_1 : tnode;
function tloadvmtaddrnode.pass_1 : tnode;
begin
result:=nil;
registers32:=1;
expectloc:=LOC_REGISTER;
end;
{*****************************************************************************
THNEWNODE
*****************************************************************************}
constructor thnewnode.create(t:ttype);
begin
inherited create(hnewn);
objtype:=t;
end;
constructor thnewnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
ppufile.gettype(objtype);
end;
procedure thnewnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.puttype(objtype);
end;
procedure thnewnode.derefimpl;
begin
inherited derefimpl;
objtype.resolve;
end;
function thnewnode.det_resulttype:tnode;
begin
result:=nil;
if objtype.def.deftype<>objectdef then
Message(parser_e_pointer_to_class_expected);
resulttype:=objtype;
end;
function thnewnode.pass_1 : tnode;
begin
result:=nil;
expectloc:=LOC_VOID;
end;
{*****************************************************************************
THDISPOSENODE
*****************************************************************************}
constructor thdisposenode.create(l : tnode);
begin
inherited create(hdisposen,l);
end;
function thdisposenode.det_resulttype:tnode;
begin
result:=nil;
resulttypepass(left);
if codegenerror then
exit;
if (left.resulttype.def.deftype<>pointerdef) then
CGMessage1(type_e_pointer_type_expected,left.resulttype.def.typename);
resulttype:=tpointerdef(left.resulttype.def).pointertype;
end;
function thdisposenode.pass_1 : tnode;
begin
result:=nil;
firstpass(left);
if codegenerror then
exit;
registers32:=left.registers32;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
if left.nodetype<>typen then
begin
firstpass(left);
registers32:=left.registers32;
end;
if registers32<1 then
registers32:=1;
if left.expectloc=LOC_CREGISTER then
inc(registers32);
expectloc:=LOC_REFERENCE;
end;
@ -873,56 +763,6 @@ implementation
end;
{*****************************************************************************
TSELFNODE
*****************************************************************************}
constructor tselfnode.create(_class : tdef);
begin
inherited create(selfn);
classdef:=_class;
end;
constructor tselfnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
classdef:=tdef(ppufile.getderef);
end;
procedure tselfnode.ppuwrite(ppufile:tcompilerppufile);
begin
inherited ppuwrite(ppufile);
ppufile.putderef(classdef);
end;
procedure tselfnode.derefimpl;
begin
inherited derefimpl;
resolvedef(pointer(classdef));
end;
function tselfnode.det_resulttype:tnode;
begin
result:=nil;
resulttype.setdef(classdef);
end;
function tselfnode.pass_1 : tnode;
begin
result:=nil;
if (resulttype.def.deftype=classrefdef) or
is_class(resulttype.def) or
(po_staticmethod in current_procdef.procoptions) then
expectloc:=LOC_REGISTER
else
expectloc:=LOC_CREFERENCE;
end;
{*****************************************************************************
TWITHNODE
*****************************************************************************}
@ -1047,20 +887,21 @@ implementation
end;
begin
cloadvmtnode := tloadvmtnode;
chnewnode := thnewnode;
chdisposenode := thdisposenode;
cloadvmtaddrnode := tloadvmtaddrnode;
caddrnode := taddrnode;
cdoubleaddrnode := tdoubleaddrnode;
cderefnode := tderefnode;
csubscriptnode := tsubscriptnode;
cvecnode := tvecnode;
cselfnode := tselfnode;
cwithnode := twithnode;
end.
{
$Log$
Revision 1.52 2003-05-05 14:53:16 peter
Revision 1.53 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.52 2003/05/05 14:53:16 peter
* vs_hidden replaced by is_hidden boolean
Revision 1.51 2003/04/27 11:21:33 peter

34
compiler/node.pas
View File

@ -81,15 +81,12 @@ interface
vecn, {Represents array indexing}
pointerconstn, {Represents a pointer constant}
stringconstn, {Represents a string constant}
selfn, {Represents the self parameter}
notn, {Represents the not operator}
inlinen, {Internal procedures (i.e. writeln)}
niln, {Represents the nil pointer}
errorn, {This part of the tree could not be
parsed because of a compiler error}
typen, {A type name. Used for i.e. typeof(obj)}
hnewn, {The new operation, constructor call}
hdisposen, {The dispose operation with destructor call}
setelementn, {A set element(s) (i.e. [a,b] and also [a..b])}
setconstn, {A set constant (i.e. [1,2])}
blockn, {A block of statements}
@ -121,7 +118,7 @@ interface
tempdeleten, { for temps in the result/firstpass }
addoptn, { added for optimizations where we cannot suppress }
nothingn, {NOP, Do nothing}
loadvmtn, {Load the address of the VMT of a class/object}
loadvmtaddrn, {Load the address of the VMT of a class/object}
guidconstn, {A GUID COM Interface constant }
rttin {Rtti information so they can be accessed in result/firstpass}
);
@ -165,14 +162,11 @@ interface
'vecn',
'pointerconstn',
'stringconstn',
'selfn',
'notn',
'inlinen',
'niln',
'errorn',
'typen',
'hnewn',
'hdisposen',
'setelementn',
'setconstn',
'blockn',
@ -204,13 +198,13 @@ interface
'tempdeleten',
'addoptn',
'nothingn',
'loadvmtn',
'loadvmtaddrn',
'guidconstn',
'rttin');
type
{ all boolean field of ttree are now collected in flags }
tnodeflags = (
tnodeflag = (
nf_swapable, { tbinop operands can be swaped }
nf_swaped, { tbinop operands are swaped }
nf_error,
@ -223,7 +217,11 @@ interface
{ flags used by tcallnode }
nf_return_value_used,
nf_inherited,
nf_anon_inherited,
nf_new_call,
nf_dispose_call,
nf_member_call, { called with implicit methodpointer tree }
{ flags used by tcallparanode }
nf_varargs_para, { belongs this para to varargs }
@ -265,12 +263,12 @@ interface
nf_releasetemps
);
tnodeflagset = set of tnodeflags;
tnodeflags = set of tnodeflag;
const
{ contains the flags which must be equal for the equality }
{ of nodes }
flagsequal : tnodeflagset = [nf_error];
flagsequal : tnodeflags = [nf_error];
type
tnodelist = class
@ -291,7 +289,7 @@ interface
{ this field is set by concattolist }
parent : tnode;
{ there are some properties about the node stored }
flags : tnodeflagset;
flags : tnodeflags;
{ the number of registers needed to evalute the node }
registers32,registersfpu : longint; { must be longint !!!! }
{$ifdef SUPPORT_MMX}
@ -314,7 +312,7 @@ interface
procedure derefimpl;virtual;
{ toggles the flag }
procedure toggleflag(f : tnodeflags);
procedure toggleflag(f : tnodeflag);
{ the 1.1 code generator may override pass_1 }
{ and it need not to implement det_* then }
@ -584,7 +582,7 @@ implementation
end;
procedure tnode.toggleflag(f : tnodeflags);
procedure tnode.toggleflag(f : tnodeflag);
begin
if f in flags then
exclude(flags,f)
@ -630,7 +628,7 @@ implementation
write(t,' ,resulttype = <nil>');
writeln(t,', pos = (',fileinfo.line,',',fileinfo.column,')',
', loc = ',tcgloc2str[location.loc],
', inttgobj: = ',registers32,
', intregs = ',registers32,
', fpuregs = ',registersfpu);
end;
@ -990,7 +988,11 @@ implementation
end.
{
$Log$
Revision 1.58 2003-04-25 20:59:33 peter
Revision 1.59 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.58 2003/04/25 20:59:33 peter
* removed funcretn,funcretsym, function result is now in varsym
and aliases for result and function name are added using absolutesym
* vs_hidden parameter for funcret passed in parameter

9
compiler/pass_2.pas
View File

@ -107,14 +107,11 @@ implementation
'vecn', {vecn}
'pointerconst',{pointerconstn}
'stringconst', {stringconstn}
'selfn', {selfn}
'not', {notn}
'inline', {inlinen}
'niln', {niln}
'error', {errorn}
'nothing-typen', {typen}
'hnewn', {hnewn}
'hdisposen', {hdisposen}
'setelement', {setelementn}
'setconst', {setconstn}
'blockn', {blockn}
@ -306,7 +303,11 @@ implementation
end.
{
$Log$
Revision 1.49 2003-04-27 11:21:33 peter
Revision 1.50 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.49 2003/04/27 11:21:33 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be

21
compiler/pdecobj.pas
View File

@ -230,7 +230,9 @@ implementation
oldregisterdef:=registerdef;
registerdef:=false;
readprocdef:=tprocvardef.create(normal_function_level);
include(readprocdef.procoptions,po_methodpointer);
writeprocdef:=tprocvardef.create(normal_function_level);
include(writeprocdef.procoptions,po_methodpointer);
registerdef:=oldregisterdef;
if token<>_ID then
@ -278,8 +280,7 @@ implementation
varspez:=vs_value;
sc.reset;
repeat
readvs:=tvarsym.create(orgpattern,generrortype);
readvs.varspez:=varspez;
readvs:=tvarsym.create(orgpattern,varspez,generrortype);
readprocdef.parast.insert(readvs);
sc.insert(readvs);
consume(_ID);
@ -307,7 +308,7 @@ implementation
begin
readprocdef.concatpara(nil,tt,readvs,nil,false);
{ also update the writeprocdef }
hvs:=tvarsym.create(readvs.realname,generrortype);
hvs:=tvarsym.create(readvs.realname,vs_value,generrortype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,tt,hvs,nil,false);
readvs:=tvarsym(readvs.listnext);
@ -344,10 +345,10 @@ implementation
p.indextype.setdef(pt.resulttype.def);
include(p.propoptions,ppo_indexed);
{ concat a longint to the para templates }
hvs:=tvarsym.create('$index',p.indextype);
hvs:=tvarsym.create('$index',vs_value,p.indextype);
readprocdef.parast.insert(hvs);
readprocdef.concatpara(nil,p.indextype,hvs,nil,false);
hvs:=tvarsym.create('$index',p.indextype);
hvs:=tvarsym.create('$index',vs_value,p.indextype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,p.indextype,hvs,nil,false);
pt.free;
@ -422,7 +423,7 @@ implementation
{ write is a procedure with an extra value parameter
of the of the property }
writeprocdef.rettype:=voidtype;
hvs:=tvarsym.create('$value',p.proptype);
hvs:=tvarsym.create('$value',vs_value,p.proptype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,p.proptype,hvs,nil,false);
{ Insert hidden parameters }
@ -557,7 +558,7 @@ implementation
if (cs_constructor_name in aktglobalswitches) and
(pd.procsym.name<>'DONE') then
Message(parser_e_destructorname_must_be_done);
if not(pd.Para.empty) and
if not(pd.maxparacount=0) and
(m_fpc in aktmodeswitches) then
Message(parser_e_no_paras_for_destructor);
consume(_SEMICOLON);
@ -1145,7 +1146,11 @@ implementation
end.
{
$Log$
Revision 1.64 2003-05-05 14:53:16 peter
Revision 1.65 2003-05-09 17:47:02 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.64 2003/05/05 14:53:16 peter
* vs_hidden replaced by is_hidden boolean
Revision 1.63 2003/04/27 11:21:33 peter

114
compiler/pdecsub.pas
View File

@ -109,66 +109,94 @@ implementation
akttokenpos:=tprocdef(pd).fileinfo;
{ Generate result variable accessing function result }
vs:=tvarsym.create('$result',pd.rettype);
vs:=tvarsym.create('$result',vs_var,pd.rettype);
include(vs.varoptions,vo_is_funcret);
pd.parast.insert(vs);
pd.insertpara(vs.vartype,vs,nil,true);
{ Store the this symbol as funcretsym for procedures }
if pd.deftype=procdef then
tprocdef(pd).funcretsym:=vs;
{ Handle like a var parameter }
vs.varspez:=vs_var;
pd.parast.insert(vs);
{ Also insert a hidden parameter as first }
pd.insertpara(vs.vartype,vs,nil,true);
akttokenpos:=storepos;
end;
end;
procedure insert_self_and_vmt_para(pd:tabstractprocdef);
var
storepos : tfileposinfo;
vs : tvarsym;
tt : ttype;
vsp : tvarspez;
begin
if (pd.deftype=procvardef) and
pd.is_methodpointer then
pd.is_methodpointer then
begin
internalerror(200304301);
if not(po_containsself in pd.procoptions) then
begin
{ Generate self variable }
tt:=voidpointertype;
vs:=tvarsym.create('$self',vs_value,tt);
include(vs.varoptions,vo_is_self);
{ Insert as hidden parameter }
pd.parast.insert(vs);
pd.insertpara(vs.vartype,vs,nil,true);
end;
end
else
begin
if (pd is tprocdef) and
assigned(tprocdef(pd)._class) then
if (pd.deftype=procdef) and
assigned(tprocdef(pd)._class) and
(pd.parast.symtablelevel=normal_function_level) then
begin
storepos:=akttokenpos;
if pd.deftype=procdef then
akttokenpos:=tprocdef(pd).fileinfo;
akttokenpos:=tprocdef(pd).fileinfo;
{ Generate result variable accessing function result }
tt.setdef(tprocdef(pd)._class);
{ for unknwon reasons this doesn't work:
tt.setdef(tprocdef(pd)._class.typedef);
}
vs:=tvarsym.create('$self',tt);
include(vs.varoptions,vo_is_funcret);
{ Store the this symbol as funcretsym for procedures }
if pd.deftype=procdef then
tprocdef(pd).funcretsym:=vs;
{ Generate VMT variable for constructor/destructor }
if pd.proctypeoption in [potype_constructor,potype_destructor] then
begin
{ can't use classrefdef as type because inheriting
will then always file because of a type mismatch }
tt:=voidpointertype;
vs:=tvarsym.create('$vmt',vs_value,tt);
include(vs.varoptions,vo_is_vmt);
{ Insert as hidden parameter }
pd.parast.insert(vs);
pd.insertpara(vs.vartype,vs,nil,true);
end;
{ Handle self of objects like a var parameter }
if is_object(tprocdef(pd)._class) then
vs.varspez:=vs_var;
pd.parast.insert(vs);
{ Also insert a hidden parameter as first }
pd.insertpara(vs.vartype,vs,nil,true);
{ Generate self variable, for classes we need
to use the generic voidpointer to be compatible with
methodpointers.
Only needed when there is no explicit self para }
if not(po_containsself in pd.procoptions) then
begin
vsp:=vs_value;
if (po_staticmethod in pd.procoptions) or
(po_classmethod in pd.procoptions) then
begin
tt.setdef(tprocdef(pd)._class);
tt.setdef(tclassrefdef.create(tt));
end
else
begin
if is_object(tprocdef(pd)._class) then
vsp:=vs_var;
tt.setdef(tprocdef(pd)._class);
end;
vs:=tvarsym.create('$self',vsp,tt);
include(vs.varoptions,vo_is_self);
{ Insert as hidden parameter }
pd.parast.insert(vs);
pd.insertpara(vs.vartype,vs,nil,true);
end;
akttokenpos:=storepos;
end;
end;
end;
procedure insert_funcret_local(pd:tprocdef);
var
storepos : tfileposinfo;
@ -187,7 +215,7 @@ implementation
when it is returning in a register }
if not paramanager.ret_in_param(pd.rettype.def,pd.proccalloption) then
begin
vs:=tvarsym.create('$result',pd.rettype);
vs:=tvarsym.create('$result',vs_value,pd.rettype);
include(vs.varoptions,vo_is_funcret);
pd.localst.insert(vs);
pd.localst.insertvardata(vs);
@ -232,8 +260,7 @@ implementation
begin
if assigned(currpara.parasym) then
begin
hvs:=tvarsym.create('$high'+tvarsym(currpara.parasym).name,s32bittype);
hvs.varspez:=vs_const;
hvs:=tvarsym.create('$high'+tvarsym(currpara.parasym).name,vs_const,s32bittype);
include(hvs.varoptions,vo_is_high_value);
tvarsym(currpara.parasym).owner.insert(hvs);
tvarsym(currpara.parasym).highvarsym:=hvs;
@ -313,6 +340,7 @@ implementation
procedure check_self_para(pd:tabstractprocdef);
var
hpara : tparaitem;
vs : tvarsym;
begin
hpara:=pd.selfpara;
if assigned(hpara) and
@ -331,6 +359,10 @@ implementation
if compare_defs(hpara.paratype.def,tprocdef(pd)._class,nothingn)=te_incompatible then
CGMessage2(type_e_incompatible_types,hpara.paratype.def.typename,tprocdef(pd)._class.typename);
end;
{ add an alias for $self which is for internal use }
vs:=tabsolutesym.create_ref('$self',hpara.paratype,tstoredsym(hpara.parasym));
include(vs.varoptions,vo_is_self);
pd.parast.insert(vs);
end;
end;
@ -389,7 +421,7 @@ implementation
{ read identifiers and insert with error type }
sc.reset;
repeat
vs:=tvarsym.create(orgpattern,generrortype);
vs:=tvarsym.create(orgpattern,varspez,generrortype);
currparast.insert(vs);
if assigned(vs.owner) then
sc.insert(vs)
@ -484,7 +516,6 @@ implementation
begin
{ update varsym }
vs.vartype:=tt;
vs.varspez:=varspez;
{ For proc vars we only need the definitions }
if not is_procvar then
begin
@ -501,8 +532,9 @@ implementation
until not try_to_consume(_SEMICOLON);
{ remove parasymtable from stack }
sc.free;
{ check for a self parameter, only for normal procedures. For
procvars we need to wait until the 'of object' is parsed }
{ check for a self parameter which is needed to allow message
directive, only for normal procedures. For procvars we need
to wait until the 'of object' is parsed }
if not is_procvar then
check_self_para(pd);
{ reset object options }
@ -1775,9 +1807,7 @@ const
{ insert hidden high parameters }
insert_hidden_para(pd);
{ insert hidden self parameter }
{$ifdef vs_hidden_self}
insert_self_and_vmt_para(pd);
{$endif vs_hidden_self}
{ insert funcret parameter if required }
insert_funcret_para(pd);
@ -2170,7 +2200,11 @@ const
end.
{
$Log$
Revision 1.121 2003-05-05 14:53:16 peter
Revision 1.122 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.121 2003/05/05 14:53:16 peter
* vs_hidden replaced by is_hidden boolean
Revision 1.120 2003/04/30 09:42:42 florian

14
compiler/pdecvar.pas
View File

@ -87,7 +87,7 @@ implementation
if (symtablestack.symtabletype=objectsymtable) and
(sp_static in current_object_option) then
begin
vs2:=tvarsym.create('$'+lower(symtablestack.name^)+'_'+vs.name,tt);
vs2:=tvarsym.create('$'+lower(symtablestack.name^)+'_'+vs.name,vs_value,tt);
symtablestack.defowner.owner.insert(vs2);
symtablestack.defowner.owner.insertvardata(vs2);
end
@ -151,7 +151,7 @@ implementation
sorg:=orgpattern;
sc.reset;
repeat
vs:=tvarsym.create(orgpattern,generrortype);
vs:=tvarsym.create(orgpattern,vs_value,generrortype);
symtablestack.insert(vs);
if assigned(vs.owner) then
sc.insert(vs)
@ -507,7 +507,7 @@ implementation
symtablestack:=symtablestack.next;
read_type(casetype,'');
symtablestack:=oldsymtablestack;
vs:=tvarsym.create(sorg,casetype);
vs:=tvarsym.create(sorg,vs_value,casetype);
symtablestack.insert(vs);
symtablestack.insertvardata(vs);
end;
@ -560,7 +560,7 @@ implementation
symtablestack.dataalignment:=maxalignment;
uniontype.def:=uniondef;
uniontype.sym:=nil;
UnionSym:=tvarsym.create('case',uniontype);
UnionSym:=tvarsym.create('$case',vs_value,uniontype);
symtablestack:=symtablestack.next;
{ we do NOT call symtablestack.insert
on purpose PM }
@ -602,7 +602,11 @@ implementation
end.
{
$Log$
Revision 1.46 2003-04-25 20:59:33 peter
Revision 1.47 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.46 2003/04/25 20:59:33 peter
* removed funcretn,funcretsym, function result is now in varsym
and aliases for result and function name are added using absolutesym
* vs_hidden parameter for funcret passed in parameter

208
compiler/pexpr.pas
View File

@ -46,7 +46,7 @@ interface
function parse_paras(__colon,in_prop_paras : boolean) : tnode;
{ the ID token has to be consumed before calling this function }
procedure do_member_read(getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean);
procedure do_member_read(getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callnflags:tnodeflags);
{$ifdef int64funcresok}
function get_intconst:TConstExprInt;
@ -239,8 +239,7 @@ implementation
(p.resulttype.def.deftype=procvardef) and
(tprocvardef(p.resulttype.def).minparacount=0) then
begin
p1:=ccallnode.create(nil,nil,nil,nil);
tcallnode(p1).set_procvar(p);
p1:=ccallnode.create_procvar(nil,p);
resulttypepass(p1);
p:=p1;
end;
@ -315,13 +314,11 @@ implementation
consume(_RKLAMMER);
if p1.nodetype=typen then
ttypenode(p1).allowed:=true;
if (p1.resulttype.def.deftype = objectdef) or
((p1.resulttype.def.deftype = classrefdef) and
(p1.nodetype in [selfn,loadvmtn])) then
if (p1.resulttype.def.deftype = objectdef) then
statement_syssym:=geninlinenode(in_typeof_x,false,p1)
else
begin
Message(type_e_mismatch);
Message(parser_e_class_id_expected);
p1.destroy;
statement_syssym:=cerrornode.create;
end;
@ -634,19 +631,49 @@ implementation
end;
function maybe_load_methodpointer(st:tsymtable;var p1:tnode):boolean;
begin
maybe_load_methodpointer:=false;
if not assigned(p1) then
begin
case st.symtabletype of
withsymtable :
begin
if (st.defowner.deftype=objectdef) then
begin
p1:=tnode(twithsymtable(st).withrefnode).getcopy;
maybe_load_methodpointer:=true;
end;
end;
objectsymtable :
begin
p1:=load_self;
maybe_load_methodpointer:=true;
end;
end;
end;
end;
{ reads the parameter for a subroutine call }
procedure do_proc_call(sym:tsym;st:tsymtable;getaddr:boolean;var again : boolean;var p1:tnode);
var
membercall,
prevafterassn : boolean;
hs,hs1 : tvarsym;
vs : tvarsym;
para,p2 : tnode;
hst : tsymtable;
currpara : tparaitem;
aprocdef : tprocdef;
begin
prevafterassn:=afterassignment;
afterassignment:=false;
membercall:=false;
aprocdef:=nil;
{ when it is a call to a member we need to load the
methodpointer first }
membercall:=maybe_load_methodpointer(st,p1);
{ When we are expecting a procvar we also need
to get the address in some cases }
if assigned(getprocvardef) then
@ -666,34 +693,50 @@ implementation
end;
end;
{ want we only determine the address of }
{ a subroutine ? }
if not(getaddr) then
{ only need to get the address of the procedure? }
if getaddr then
begin
{ Retrieve info which procvar to call. For tp_procvar the
aprocdef is already loaded above so we can reuse it }
if not assigned(aprocdef) and
assigned(getprocvardef) then
aprocdef:=Tprocsym(sym).search_procdef_byprocvardef(getprocvardef);
{ generate a methodcallnode or proccallnode }
{ we shouldn't convert things like @tcollection.load }
p2:=cloadnode.create_procvar(sym,aprocdef,st);
if assigned(p1) then
begin
if (p1.nodetype<>typen) then
tloadnode(p2).set_mp(p1)
else
p1.free;
end;
p1:=p2;
{ no postfix operators }
again:=false;
end
else
begin
para:=nil;
if anon_inherited then
begin
hst:=symtablestack;
while assigned(hst) and (hst.symtabletype<>parasymtable) do
hst:=hst.next;
if assigned(hst) then
if not assigned(current_procdef) then
internalerror(200305054);
currpara:=tparaitem(current_procdef.para.first);
while assigned(currpara) do
begin
hs:=tvarsym(hst.symindex.first);
while assigned(hs) do
if not currpara.is_hidden then
begin
if hs.typ<>varsym then
internalerror(54382953);
vs:=tvarsym(currpara.parasym);
{ if there is a localcopy then use that }
if assigned(hs.localvarsym) then
hs1:=hs.localvarsym
else
hs1:=hs;
para:=ccallparanode.create(cloadnode.create(hs1,hs1.owner),para);
hs:=tvarsym(hs.indexnext);
if assigned(vs.localvarsym) then
vs:=vs.localvarsym;
para:=ccallparanode.create(cloadnode.create(vs,vs.owner),para);
end;
end
else
internalerror(54382954);
currpara:=tparaitem(currpara.next);
end;
end
else
begin
@ -704,47 +747,11 @@ implementation
end;
end;
p1:=ccallnode.create(para,tprocsym(sym),st,p1);
end
else
begin
{ address operator @: }
if not assigned(p1) then
begin
case st.symtabletype of
withsymtable :
begin
if (st.defowner.deftype=objectdef) then
p1:=tnode(twithsymtable(st).withrefnode).getcopy;
end;
objectsymtable :
begin
{ we must provide a method pointer, if it isn't given, }
{ it is self }
p1:=cselfnode.create(tobjectdef(st.defowner));
end;
end;
end;
{ Retrieve info which procvar to call. For tp_procvar the
aprocdef is already loaded above so we can reuse it }
if not assigned(aprocdef) and
assigned(getprocvardef) then
aprocdef:=Tprocsym(sym).search_procdef_byprocvardef(getprocvardef);
{ generate a methodcallnode or proccallnode }
{ we shouldn't convert things like @tcollection.load }
p2:=cloadnode.create_procvar(sym,aprocdef,st);
if assigned(p1) then
begin
if (p1.nodetype<>typen) then
tloadnode(p2).set_mp(p1)
else
p1.free;
end;
p1:=p2;
{ no postfix operators }
again:=false;
{ indicate if this call was generated by a member and
no explicit self is used, this is needed to determine
how to handle a destructor call (PFV) }
if membercall then
include(p1.flags,nf_member_call);
end;
afterassignment:=prevafterassn;
end;
@ -825,6 +832,7 @@ implementation
var
paras : tnode;
p2 : tnode;
membercall : boolean;
begin
paras:=nil;
{ property parameters? read them only if the property really }
@ -855,8 +863,11 @@ implementation
procsym :
begin
{ generate the method call }
membercall:=maybe_load_methodpointer(st,p1);
p1:=ccallnode.create(paras,
tprocsym(tpropertysym(sym).writeaccess.firstsym^.sym),st,p1);
if membercall then
include(tcallnode(p1).flags,nf_member_call);
paras:=nil;
consume(_ASSIGNMENT);
{ read the expression }
@ -905,7 +916,10 @@ implementation
procsym :
begin
{ generate the method call }
membercall:=maybe_load_methodpointer(st,p1);
p1:=ccallnode.create(paras,tprocsym(tpropertysym(sym).readaccess.firstsym^.sym),st,p1);
if membercall then
include(tcallnode(p1).flags,nf_member_call);
paras:=nil;
include(p1.flags,nf_isproperty);
end
@ -930,7 +944,7 @@ implementation
{ the ID token has to be consumed before calling this function }
procedure do_member_read(getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean);
procedure do_member_read(getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callnflags:tnodeflags);
var
static_name : string;
@ -967,6 +981,9 @@ implementation
do_proc_call(sym,sym.owner,
(getaddr and not(token in [_CARET,_POINT])),
again,p1);
{ add provided flags }
if (p1.nodetype=calln) then
p1.flags:=p1.flags+callnflags;
{ we need to know which procedure is called }
do_resulttypepass(p1);
{ now we know the real method e.g. we can check for a class method }
@ -1135,7 +1152,7 @@ implementation
srsym:=searchsym_in_class(tobjectdef(htype.def),pattern);
check_hints(srsym);
consume(_ID);
do_member_read(false,srsym,p1,again);
do_member_read(false,srsym,p1,again,[]);
end
else
begin
@ -1159,7 +1176,7 @@ implementation
else
begin
consume(_ID);
do_member_read(getaddr,srsym,p1,again);
do_member_read(getaddr,srsym,p1,again,[]);
end;
end;
end
@ -1183,7 +1200,7 @@ implementation
else
begin
consume(_ID);
do_member_read(getaddr,srsym,p1,again);
do_member_read(getaddr,srsym,p1,again,[]);
end;
end
else
@ -1193,7 +1210,7 @@ implementation
the type. For all other blocks we return
a loadvmt node }
if (block_type<>bt_type) then
p1:=cloadvmtnode.create(p1);
p1:=cloadvmtaddrnode.create(p1);
end;
end
else
@ -1579,7 +1596,7 @@ implementation
else
begin
consume(_ID);
do_member_read(getaddr,hsym,p1,again);
do_member_read(getaddr,hsym,p1,again,[]);
end;
end;
@ -1602,7 +1619,7 @@ implementation
else
begin
consume(_ID);
do_member_read(getaddr,hsym,p1,again);
do_member_read(getaddr,hsym,p1,again,[]);
end;
end;
@ -1635,25 +1652,24 @@ implementation
again:=false
else
if (token=_LKLAMMER) or
((tprocvardef(p1.resulttype.def).para.empty) and
((tprocvardef(p1.resulttype.def).maxparacount=0) and
(not((token in [_ASSIGNMENT,_UNEQUAL,_EQUAL]))) and
(not afterassignment) and
(not in_args)) then
begin
{ do this in a strange way }
{ it's not a clean solution }
p2:=p1;
p1:=ccallnode.create(nil,nil,nil,nil);
tcallnode(p1).set_procvar(p2);
if try_to_consume(_LKLAMMER) then
begin
tcallnode(p1).left:=parse_paras(false,false);
p2:=parse_paras(false,false);
consume(_RKLAMMER);
end;
end
else
p2:=nil;
p1:=ccallnode.create_procvar(p2,p1);
{ proc():= is never possible }
if token=_ASSIGNMENT then
begin
Message(cg_e_illegal_expression);
p1.free;
p1:=cerrornode.create;
again:=false;
end;
@ -1738,14 +1754,7 @@ implementation
end
else
begin
if (po_classmethod in current_procdef.procoptions) then
begin
{ self in class methods is a class reference type }
htype.setdef(current_procdef._class);
p1:=cselfnode.create(tclassrefdef.create(htype));
end
else
p1:=cselfnode.create(current_procdef._class);
p1:=load_self;
postfixoperators(p1,again);
end;
end;
@ -1784,15 +1793,14 @@ implementation
if assigned(sym) then
begin
check_hints(sym);
{ load the procdef from the inherited class and
not from self }
if sym.typ=procsym then
begin
htype.setdef(classh);
p1:=ctypenode.create(htype);
end;
do_member_read(false,sym,p1,again);
{ Add flag to indicate that inherited is used }
if p1.nodetype=calln then
include(p1.flags,nf_anon_inherited);
do_member_read(false,sym,p1,again,[nf_inherited,nf_anon_inherited]);
end
else
begin
@ -2314,7 +2322,11 @@ implementation
end.
{
$Log$
Revision 1.114 2003-05-01 07:59:42 florian
Revision 1.115 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.114 2003/05/01 07:59:42 florian
* introduced defaultordconsttype to decribe the default size of ordinal constants
on 64 bit CPUs it's equal to cs64bitdef while on 32 bit CPUs it's equal to s32bitdef
+ added defines CPU32 and CPU64 for 32 bit and 64 bit CPUs

115
compiler/pinline.pas
View File

@ -74,6 +74,7 @@ implementation
destructorname : stringid;
sym : tsym;
classh : tobjectdef;
callflag : tnodeflag;
destructorpos,
storepos : tfileposinfo;
begin
@ -140,20 +141,25 @@ implementation
end
else
begin
if is_new then
p2:=chnewnode.create(tpointerdef(p.resulttype.def).pointertype)
else
p2:=chdisposenode.create(p);
p2:=cderefnode.create(p.getcopy);
do_resulttypepass(p2);
if is_new then
do_member_read(false,sym,p2,again)
callflag:=nf_new_call
else
callflag:=nf_dispose_call;
if is_new then
do_member_read(false,sym,p2,again,[callflag])
else
begin
if not(m_fpc in aktmodeswitches) then
do_member_read(false,sym,p2,again)
do_member_read(false,sym,p2,again,[callflag])
else
begin
p2:=ccallnode.create(nil,tprocsym(sym),sym.owner,p2);
if is_new then
include(p2.flags,nf_new_call)
else
include(p2.flags,nf_dispose_call);
{ support dispose(p,done()); }
if try_to_consume(_LKLAMMER) then
begin
@ -168,7 +174,6 @@ implementation
end;
{ we need the real called method }
{ rg.cleartempgen;}
do_resulttypepass(p2);
if p2.nodetype<>calln then
@ -221,7 +226,7 @@ implementation
{ create statements with call to getmem+initialize or
finalize+freemem }
new_dispose_statement:=internalstatements(newstatement);
new_dispose_statement:=internalstatements(newstatement,true);
if is_new then
begin
@ -292,22 +297,31 @@ implementation
if p1.nodetype<>typen then
begin
Message(type_e_type_id_expected);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
p1.destroy;
p1:=cerrornode.create;
do_resulttypepass(p1);
new_function:=cerrornode.create;
exit;
end;
if (p1.resulttype.def.deftype<>pointerdef) then
Message1(type_e_pointer_type_expected,p1.resulttype.def.typename)
else
if token=_RKLAMMER then
begin
Message1(type_e_pointer_type_expected,p1.resulttype.def.typename);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
p1.destroy;
new_function:=cerrornode.create;
exit;
end;
if try_to_consume(_RKLAMMER) then
begin
if (tpointerdef(p1.resulttype.def).pointertype.def.deftype=objectdef) and
(oo_has_vmt in tobjectdef(tpointerdef(p1.resulttype.def).pointertype.def).objectoptions) then
Message(parser_w_use_extended_syntax_for_objects);
{ create statements with call to getmem+initialize }
newblock:=internalstatements(newstatement);
newblock:=internalstatements(newstatement,true);
{ create temp for result }
temp := ctempcreatenode.create(p1.resulttype,p1.resulttype.def.size,true);
@ -339,40 +353,45 @@ implementation
p1.destroy;
p1:=newblock;
consume(_RKLAMMER);
end
else
begin
p2:=chnewnode.create(tpointerdef(p1.resulttype.def).pointertype);
do_resulttypepass(p2);
consume(_COMMA);
afterassignment:=false;
{ determines the current object defintion }
classh:=tobjectdef(p2.resulttype.def);
if classh.deftype=objectdef then
if tpointerdef(p1.resulttype.def).pointertype.def.deftype<>objectdef then
begin
{ check for an abstract class }
if (oo_has_abstract in classh.objectoptions) then
Message(sym_e_no_instance_of_abstract_object);
{ search the constructor also in the symbol tables of
the parents }
sym:=searchsym_in_class(classh,pattern);
consume(_ID);
do_member_read(false,sym,p2,again);
{ we need to know which procedure is called }
do_resulttypepass(p2);
if (p2.nodetype<>calln) or
(assigned(tcallnode(p2).procdefinition) and
(tcallnode(p2).procdefinition.proctypeoption<>potype_constructor)) then
Message(parser_e_expr_have_to_be_constructor_call);
end
else
Message(parser_e_pointer_to_class_expected);
Message(parser_e_pointer_to_class_expected);
consume_all_until(_RKLAMMER);
consume(_RKLAMMER);
p1.destroy;
new_function:=cerrornode.create;
exit;
end;
classh:=tobjectdef(tpointerdef(p1.resulttype.def).pointertype.def);
{ check for an abstract class }
if (oo_has_abstract in classh.objectoptions) then
Message(sym_e_no_instance_of_abstract_object);
{ use the objectdef for loading the VMT }
p2:=p1;
p1:=ctypenode.create(tpointerdef(p1.resulttype.def).pointertype);
do_resulttypepass(p1);
{ search the constructor also in the symbol tables of
the parents }
afterassignment:=false;
sym:=searchsym_in_class(classh,pattern);
consume(_ID);
do_member_read(false,sym,p1,again,[nf_new_call]);
{ we need to know which procedure is called }
do_resulttypepass(p1);
if not(
(p1.nodetype=calln) and
assigned(tcallnode(p1).procdefinition) and
(tcallnode(p1).procdefinition.proctypeoption=potype_constructor)
) then
Message(parser_e_expr_have_to_be_constructor_call);
{ constructors return boolean, update resulttype to return
the pointer to the object }
p2.resulttype:=p1.resulttype;
p1.destroy;
p1:=p2;
p1.resulttype:=p2.resulttype;
p2.free;
consume(_RKLAMMER);
end;
new_function:=p1;
@ -465,7 +484,7 @@ implementation
begin
{ create statements with call initialize the arguments and
call fpc_dynarr_setlength }
newblock:=internalstatements(newstatement);
newblock:=internalstatements(newstatement,true);
{ get temp for array of lengths }
temp := ctempcreatenode.create(s32bittype,counter*s32bittype.def.size,true);
@ -627,7 +646,7 @@ implementation
end;
{ create statements with call }
copynode:=internalstatements(newstatement);
copynode:=internalstatements(newstatement,true);
if (counter=3) then
begin
@ -680,7 +699,15 @@ implementation
end.
{
$Log$
Revision 1.11 2002-11-26 22:59:09 peter
Revision 1.13 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.12 2002/04/25 20:15:40 florian
* block nodes within expressions shouldn't release the used registers,
fixed using a flag till the new rg is ready
Revision 1.11 2002/11/26 22:59:09 peter
* fix Copy(array,x,y)
Revision 1.10 2002/11/25 17:43:22 peter

10
compiler/pstatmnt.pas
View File

@ -597,11 +597,11 @@ implementation
is_class(ttypesym(srsym).restype.def) then
begin
ot:=ttypesym(srsym).restype;
sym:=tvarsym.create(objrealname,ot);
sym:=tvarsym.create(objrealname,vs_value,ot);
end
else
begin
sym:=tvarsym.create(objrealname,generrortype);
sym:=tvarsym.create(objrealname,vs_value,generrortype);
if (srsym.typ=typesym) then
Message1(type_e_class_type_expected,ttypesym(srsym).restype.def.typename)
else
@ -1131,7 +1131,11 @@ implementation
end.
{
$Log$
Revision 1.95 2003-04-30 22:15:59 florian
Revision 1.96 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.95 2003/04/30 22:15:59 florian
* some 64 bit adaptions in ncgadd
* x86-64 now uses ncgadd
* tparamanager.ret_in_acc doesn't return true anymore for a void-def

9
compiler/psub.pas
View File

@ -542,9 +542,8 @@ implementation
if copy(name,1,3)='val' then
begin
pd:=tprocdef(owner.defowner);
vs:=tvarsym.create(Copy(name,4,255),vartype);
vs:=tvarsym.create(Copy(name,4,255),varspez,vartype);
vs.fileinfo:=fileinfo;
vs.varspez:=varspez;
if not assigned(pd.localst) then
pd.insert_localst;
pd.localst.insert(vs);
@ -843,7 +842,11 @@ implementation
end.
{
$Log$
Revision 1.107 2003-04-27 11:21:34 peter
Revision 1.108 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.107 2003/04/27 11:21:34 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be

19
compiler/psystem.pas
View File

@ -198,12 +198,12 @@ implementation
vmtsymtable:=trecordsymtable.create;
vmttype.setdef(trecorddef.create(vmtsymtable));
pvmttype.setdef(tpointerdef.create(vmttype));
vmtsymtable.insert(tvarsym.create('$parent',pvmttype));
vmtsymtable.insert(tvarsym.create('$length',s32bittype));
vmtsymtable.insert(tvarsym.create('$mlength',s32bittype));
vmtsymtable.insert(tvarsym.create('$parent',vs_value,pvmttype));
vmtsymtable.insert(tvarsym.create('$length',vs_value,s32bittype));
vmtsymtable.insert(tvarsym.create('$mlength',vs_value,s32bittype));
vmtarraytype.setdef(tarraydef.create(0,1,s32bittype));
tarraydef(vmtarraytype.def).setelementtype(voidpointertype);
vmtsymtable.insert(tvarsym.create('$__pfn',vmtarraytype));
vmtsymtable.insert(tvarsym.create('$__pfn',vs_value,vmtarraytype));
addtype('$__vtbl_ptr_type',vmttype);
addtype('$pvmt',pvmttype);
vmtarraytype.setdef(tarraydef.create(0,1,s32bittype));
@ -389,14 +389,11 @@ implementation
nodeclass[vecn]:=cvecnode;
nodeclass[pointerconstn]:=cpointerconstnode;
nodeclass[stringconstn]:=cstringconstnode;
nodeclass[selfn]:=cselfnode;
nodeclass[notn]:=cnotnode;
nodeclass[inlinen]:=cinlinenode;
nodeclass[niln]:=cnilnode;
nodeclass[errorn]:=cerrornode;
nodeclass[typen]:=ctypenode;
nodeclass[hnewn]:=chnewnode;
nodeclass[hdisposen]:=chdisposenode;
nodeclass[setelementn]:=csetelementnode;
nodeclass[setconstn]:=csetconstnode;
nodeclass[blockn]:=cblocknode;
@ -428,7 +425,7 @@ implementation
nodeclass[tempdeleten]:=ctempdeletenode;
nodeclass[addoptn]:=caddnode;
nodeclass[nothingn]:=cnothingnode;
nodeclass[loadvmtn]:=cloadvmtnode;
nodeclass[loadvmtaddrn]:=cloadvmtaddrnode;
nodeclass[guidconstn]:=cguidconstnode;
nodeclass[rttin]:=crttinode;
end;
@ -491,7 +488,11 @@ implementation
end.
{
$Log$
Revision 1.48 2003-05-01 07:59:42 florian
Revision 1.49 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.48 2003/05/01 07:59:42 florian
* introduced defaultordconsttype to decribe the default size of ordinal constants
on 64 bit CPUs it's equal to cs64bitdef while on 32 bit CPUs it's equal to s32bitdef
+ added defines CPU32 and CPU64 for 32 bit and 64 bit CPUs

8
compiler/ptconst.pas
View File

@ -237,7 +237,7 @@ implementation
begin
p:=comp_expr(true);
case p.nodetype of
loadvmtn:
loadvmtaddrn:
begin
if not(tobjectdef(tclassrefdef(p.resulttype.def).pointertype.def).is_related(
tobjectdef(tclassrefdef(t.def).pointertype.def))) then
@ -1004,7 +1004,11 @@ implementation
end.
{
$Log$
Revision 1.68 2003-04-30 20:53:32 florian
Revision 1.69 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.68 2003/04/30 20:53:32 florian
* error when address of an abstract method is taken
* fixed some x86-64 problems
* merged some more x86-64 and i386 code

33
compiler/ptype.pas
View File

@ -455,6 +455,7 @@ implementation
var
p : tnode;
pd : tabstractprocdef;
is_func,
enumdupmsg : boolean;
begin
tt.reset;
@ -593,33 +594,25 @@ implementation
begin
tt.setdef(object_dec(name,nil));
end;
_PROCEDURE:
begin
consume(_PROCEDURE);
tt.setdef(tprocvardef.create(normal_function_level));
if token=_LKLAMMER then
parse_parameter_dec(tprocvardef(tt.def));
if token=_OF then
begin
consume(_OF);
consume(_OBJECT);
include(tprocvardef(tt.def).procoptions,po_methodpointer);
check_self_para(tprocvardef(tt.def));
end;
end;
_PROCEDURE,
_FUNCTION:
begin
consume(_FUNCTION);
is_func:=(token=_FUNCTION);
consume(token);
pd:=tprocvardef.create(normal_function_level);
if token=_LKLAMMER then
parse_parameter_dec(pd);
consume(_COLON);
single_type(pd.rettype,hs,false);
if is_func then
begin
consume(_COLON);
single_type(pd.rettype,hs,false);
end;
if token=_OF then
begin
consume(_OF);
consume(_OBJECT);
include(pd.procoptions,po_methodpointer);
check_self_para(pd);
end;
{ Add implicit hidden parameters and function result }
calc_parast(pd);
@ -635,7 +628,11 @@ implementation
end.
{
$Log$
Revision 1.53 2003-04-27 11:21:34 peter
Revision 1.54 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.53 2003/04/27 11:21:34 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be

8
compiler/symconst.pas
View File

@ -248,6 +248,8 @@ type
vo_is_exported,
vo_is_high_value,
vo_is_funcret,
vo_is_self,
vo_is_vmt,
vo_is_result { special result variable }
);
tvaroptions=set of tvaroption;
@ -350,7 +352,11 @@ implementation
end.
{
$Log$
Revision 1.53 2003-05-05 14:53:16 peter
Revision 1.54 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.53 2003/05/05 14:53:16 peter
* vs_hidden replaced by is_hidden boolean
Revision 1.52 2003/04/27 11:21:34 peter

29
compiler/symdef.pas
View File

@ -3334,13 +3334,16 @@ implementation
end;
if assigned(hp.paratype.def.typesym) then
begin
s:=s+' ';
if s<>'(' then
s:=s+' ';
hs:=hp.paratype.def.typesym.realname;
if hs[1]<>'$' then
s:=s+hp.paratype.def.typesym.realname
else
s:=s+hp.paratype.def.gettypename;
end;
end
else
s:=s+hp.paratype.def.gettypename;
{ default value }
if assigned(hp.defaultvalue) then
begin
@ -3643,6 +3646,9 @@ implementation
var
s : string;
begin
{$ifdef EXTDEBUG}
showhidden:=true;
{$endif EXTDEBUG}
s:='';
if assigned(_class) then
begin
@ -3660,8 +3666,7 @@ implementation
function tprocdef.is_methodpointer:boolean;
begin
result:=assigned(owner) and
(owner.symtabletype=objectsymtable);
result:=assigned(_class);
end;
@ -4287,7 +4292,13 @@ implementation
function tprocvardef.gettypename : string;
var
s: string;
showhidden : boolean;
begin
{$ifdef EXTDEBUG}
showhidden:=true;
{$else EXTDEBUG}
showhidden:=false;
{$endif EXTDEBUG}
s:='<';
if po_classmethod in procoptions then
s := s+'class method type of'
@ -4298,9 +4309,9 @@ implementation
s := s+'procedure variable type of';
if assigned(rettype.def) and
(rettype.def<>voidtype.def) then
s:=s+' function'+typename_paras(false)+':'+rettype.def.gettypename
s:=s+' function'+typename_paras(showhidden)+':'+rettype.def.gettypename
else
s:=s+' procedure'+typename_paras(false);
s:=s+' procedure'+typename_paras(showhidden);
if po_methodpointer in procoptions then
s := s+' of object';
gettypename := s+';'+ProcCallOptionStr[proccalloption]+'>';
@ -5751,7 +5762,11 @@ implementation
end.
{
$Log$
Revision 1.140 2003-05-05 14:53:16 peter
Revision 1.141 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.140 2003/05/05 14:53:16 peter
* vs_hidden replaced by is_hidden boolean
Revision 1.139 2003/05/01 07:59:43 florian

31
compiler/symsym.pas
View File

@ -184,9 +184,9 @@ interface
varstate : tvarstate;
paraitem : tparaitem;
notifications : Tlinkedlist;
constructor create(const n : string;const tt : ttype);
constructor create_dll(const n : string;const tt : ttype);
constructor create_C(const n,mangled : string;const tt : ttype);
constructor create(const n : string;vsp:tvarspez;const tt : ttype);
constructor create_dll(const n : string;vsp:tvarspez;const tt : ttype);
constructor create_C(const n,mangled : string;vsp:tvarspez;const tt : ttype);
constructor ppuload(ppufile:tcompilerppufile);
destructor destroy;override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
@ -981,7 +981,8 @@ implementation
p:=pdlistfirst;
while p<>nil do
begin
if p^.def.para.empty and is_boolean(p^.def.rettype.def) then
if (p^.def.maxparacount=0) and
is_boolean(p^.def.rettype.def) then
begin
search_procdef_nopara_boolret:=p^.def;
break;
@ -1455,14 +1456,14 @@ implementation
constructor tabsolutesym.create(const n : string;const tt : ttype);
begin
inherited create(n,tt);
inherited create(n,vs_value,tt);
typ:=absolutesym;
end;
constructor tabsolutesym.create_ref(const n : string;const tt : ttype;sym:tstoredsym);
begin
inherited create(n,tt);
inherited create(n,vs_value,tt);
typ:=absolutesym;
ref:=sym;
end;
@ -1577,13 +1578,13 @@ implementation
TVARSYM
****************************************************************************}
constructor tvarsym.create(const n : string;const tt : ttype);
constructor tvarsym.create(const n : string;vsp:tvarspez;const tt : ttype);
begin
inherited create(n);
typ:=varsym;
vartype:=tt;
_mangledname:=nil;
varspez:=vs_value;
varspez:=vsp;
address:=0;
localvarsym:=nil;
highvarsym:=nil;
@ -1605,16 +1606,16 @@ implementation
end;
constructor tvarsym.create_dll(const n : string;const tt : ttype);
constructor tvarsym.create_dll(const n : string;vsp:tvarspez;const tt : ttype);
begin
tvarsym(self).create(n,tt);
tvarsym(self).create(n,vsp,tt);
include(varoptions,vo_is_dll_var);
end;
constructor tvarsym.create_C(const n,mangled : string;const tt : ttype);
constructor tvarsym.create_C(const n,mangled : string;vsp:tvarspez;const tt : ttype);
begin
tvarsym(self).create(n,tt);
tvarsym(self).create(n,vsp,tt);
stringdispose(_mangledname);
_mangledname:=stringdup(mangled);
end;
@ -2557,7 +2558,11 @@ implementation
end.
{
$Log$
Revision 1.101 2003-05-05 14:53:16 peter
Revision 1.102 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.101 2003/05/05 14:53:16 peter
* vs_hidden replaced by is_hidden boolean
Revision 1.100 2003/04/27 11:21:34 peter

7
compiler/utils/ppudump.pp
View File

@ -784,6 +784,7 @@ begin
readsymref;
write (space,' Symbol : ');
readsymref;
writeln(space,' Is Hidden : ',(ppufile.getbyte<>0));
write (space,' Location : ');
writeln('<not yet implemented>');
paraloclen:=ppufile.getbyte;
@ -1937,7 +1938,11 @@ begin
end.
{
$Log$
Revision 1.41 2003-04-27 07:29:52 peter
Revision 1.42 2003-05-09 17:47:03 peter
* self moved to hidden parameter
* removed hdisposen,hnewn,selfn
Revision 1.41 2003/04/27 07:29:52 peter
* aktprocdef cleanup, aktprocdef is now always nil when parsing
a new procdef declaration
* aktprocsym removed