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

* procvar handling for tp procvar mode fixed

Browse Source 
* proc to procvar moved from addrnode to typeconvnode
  * inlininginfo is now allocated only for inline routines that
    can be inlined, introduced a new flag po_has_inlining_info
This commit is contained in:
peter 2004-12-05 12:28:10 +00:00
parent efda160d12
commit 2b6456fe16
23 changed files with 756 additions and 681 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
compiler/defcmp.pas
View File

@ -41,7 +41,7 @@ interface
tcompare_defs_option = (cdo_internal,cdo_explicit,cdo_check_operator,cdo_allow_variant);
tcompare_defs_options = set of tcompare_defs_option;
tconverttype = (
tconverttype = (tc_none,
tc_equal,
tc_not_possible,
tc_string_2_string,
@ -165,6 +165,9 @@ implementation
hd3 : tobjectdef;
hpd : tprocdef;
begin
eq:=te_incompatible;
doconv:=tc_not_possible;
{ safety check }
if not(assigned(def_from) and assigned(def_to)) then
begin
@ -175,14 +178,13 @@ implementation
{ same def? then we've an exact match }
if def_from=def_to then
begin
doconv:=tc_equal;
compare_defs_ext:=te_exact;
exit;
end;
{ we walk the wanted (def_to) types and check then the def_from
types if there is a conversion possible }
eq:=te_incompatible;
doconv:=tc_not_possible;
case def_to.deftype of
orddef :
begin
@ -786,13 +788,10 @@ implementation
end;
procvardef :
begin
{ procedure variable can be assigned to an void pointer }
{ Not anymore. Use the @ operator now.}
if not(m_tp_procvar in aktmodeswitches) and
{ method pointers can't be assigned to void pointers
not(tprocvardef(def_from).is_methodpointer) and }
(tpointerdef(def_to).pointertype.def.deftype=orddef) and
(torddef(tpointerdef(def_to).pointertype.def).typ=uvoid) then
{ procedure variable can be assigned to an void pointer,
this not allowed for methodpointers }
if is_void(tpointerdef(def_to).pointertype.def) and
tprocvardef(def_from).is_addressonly then
begin
doconv:=tc_equal;
eq:=te_convert_l1;
@ -879,8 +878,8 @@ implementation
{ for example delphi allows the assignement from pointers }
{ to procedure variables }
if (m_pointer_2_procedure in aktmodeswitches) and
(tpointerdef(def_from).pointertype.def.deftype=orddef) and
(torddef(tpointerdef(def_from).pointertype.def).typ=uvoid) then
is_void(tpointerdef(def_from).pointertype.def) and
tprocvardef(def_to).is_addressonly then
begin
doconv:=tc_equal;
eq:=te_convert_l1;
@ -1312,7 +1311,13 @@ implementation
end.
{
$Log$
Revision 1.61 2004-11-29 17:32:56 peter
Revision 1.62 2004-12-05 12:28:10 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.61 2004/11/29 17:32:56 peter
* prevent some IEs with delphi methodpointers
Revision 1.60 2004/11/26 22:33:54 peter

124
compiler/htypechk.pas
View File

@ -128,8 +128,8 @@ interface
procedure make_not_regable(p : tnode);
procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word);
{ subroutine handling }
function is_procsym_load(p:tnode):boolean;
{ procvar handling }
function is_procvar_load(p:tnode):boolean;
procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef);
{ sets varsym varstate field correctly }
@ -143,6 +143,7 @@ interface
function valid_for_formal_const(p : tnode) : boolean;
function valid_for_var(p:tnode):boolean;
function valid_for_assignment(p:tnode):boolean;
function valid_for_addr(p : tnode) : boolean;
implementation
@ -152,12 +153,12 @@ implementation
cutils,verbose,globals,
symtable,
defutil,defcmp,
nbas,ncnv,nld,nmem,ncal,nmat,nutils,
nbas,ncnv,nld,nmem,ncal,nmat,ninl,nutils,
cgbase,procinfo
;
type
TValidAssign=(Valid_Property,Valid_Void,Valid_Const);
TValidAssign=(Valid_Property,Valid_Void,Valid_Const,Valid_Addr);
TValidAssigns=set of TValidAssign;
@ -703,22 +704,16 @@ implementation
Subroutine Handling
****************************************************************************}
function is_procsym_load(p:tnode):boolean;
function is_procvar_load(p:tnode):boolean;
begin
{ ignore vecn,subscriptn }
repeat
case p.nodetype of
vecn :
p:=tvecnode(p).left;
subscriptn :
p:=tsubscriptnode(p).left;
else
break;
end;
until false;
is_procsym_load:=((p.nodetype=loadn) and (tloadnode(p).symtableentry.typ=procsym)) or
((p.nodetype=addrn) and (taddrnode(p).left.nodetype=loadn)
and (tloadnode(taddrnode(p).left).symtableentry.typ=procsym)) ;
result:=false;
{ remove voidpointer typecast for tp procvars }
if (m_tp_procvar in aktmodeswitches) and
(p.nodetype=typeconvn) and
is_voidpointer(p.resulttype.def) then
p:=tunarynode(p).left;
result:=(p.nodetype=typeconvn) and
(ttypeconvnode(p).convtype=tc_proc_2_procvar);
end;
@ -832,8 +827,13 @@ implementation
gotderef : boolean;
fromdef,
todef : tdef;
errmsg : longint;
begin
valid_for_assign:=false;
if valid_const in opts then
errmsg:=type_e_variable_id_expected
else
errmsg:=type_e_argument_cant_be_assigned;
result:=false;
gotsubscript:=false;
gotvec:=false;
gotderef:=false;
@ -844,7 +844,7 @@ implementation
if not(valid_void in opts) and
is_void(hp.resulttype.def) then
begin
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
CGMessagePos(hp.fileinfo,errmsg);
exit;
end;
while assigned(hp) do
@ -853,7 +853,7 @@ implementation
if (nf_isproperty in hp.flags) then
begin
if (valid_property in opts) then
valid_for_assign:=true
result:=true
else
begin
{ check return type }
@ -867,18 +867,26 @@ implementation
gotclass:=true;
end;
{ 1. if it returns a pointer and we've found a deref,
2. if it returns a class or record and a subscription or with is found }
2. if it returns a class or record and a subscription or with is found
3. if the address is needed of a field (subscriptn) }
if (gotpointer and gotderef) or
(gotclass and (gotsubscript or gotwith)) then
valid_for_assign:=true
(
gotclass and
(gotsubscript or gotwith)
) or
(
(Valid_Addr in opts) and
(hp.nodetype=subscriptn)
) then
result:=true
else
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
CGMessagePos(hp.fileinfo,errmsg);
end;
exit;
end;
if (Valid_Const in opts) and is_constnode(hp) then
begin
valid_for_assign:=true;
result:=true;
exit;
end;
case hp.nodetype of
@ -924,7 +932,7 @@ implementation
if not(gotsubscript or gotvec or gotderef) and
not(ttypeconvnode(hp).assign_allowed) then
begin
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
CGMessagePos(hp.fileinfo,errmsg);
exit;
end;
case hp.resulttype.def.deftype of
@ -955,7 +963,7 @@ implementation
of reference. }
if not(gotsubscript or gotderef or gotvec) then
begin
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
CGMessagePos(hp.fileinfo,errmsg);
exit;
end;
hp:=tunarynode(hp).left;
@ -981,16 +989,15 @@ implementation
if ((hp.resulttype.def.deftype=pointerdef) or
(is_integer(hp.resulttype.def) and gotpointer)) and
gotderef then
valid_for_assign:=true
result:=true
else
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
addrn :
begin
if gotderef or
(nf_procvarload in hp.flags) then
valid_for_assign:=true
if gotderef then
result:=true
else
CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
exit;
@ -1022,9 +1029,18 @@ implementation
2. if it returns a class or record and a subscription or with is found }
if (gotpointer and gotderef) or
(gotclass and (gotsubscript or gotwith)) then
valid_for_assign:=true
result:=true
else
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
CGMessagePos(hp.fileinfo,errmsg);
exit;
end;
inlinen :
begin
if (valid_const in opts) and
(tinlinenode(hp).inlinenumber in [in_typeof_x]) then
result:=true
else
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
loadn :
@ -1044,7 +1060,7 @@ implementation
begin
{ allow p^:= constructions with p is const parameter }
if gotderef or (Valid_Const in opts) then
valid_for_assign:=true
result:=true
else
CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const);
exit;
@ -1059,18 +1075,34 @@ implementation
end
else
begin
valid_for_assign:=true;
result:=true;
exit;
end;
end;
typedconstsym :
begin
if ttypedconstsym(tloadnode(hp).symtableentry).is_writable then
valid_for_assign:=true
result:=true
else
CGMessagePos(hp.fileinfo,type_e_no_assign_to_const);
exit;
end;
procsym :
begin
if (Valid_Const in opts) then
result:=true
else
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
labelsym :
begin
if (Valid_Addr in opts) then
result:=true
else
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
exit;
end;
else
begin
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
@ -1102,7 +1134,7 @@ implementation
function valid_for_formal_const(p : tnode) : boolean;
begin
valid_for_formal_const:=is_procsym_load(p) or (p.resulttype.def.deftype=formaldef) or
valid_for_formal_const:=(p.resulttype.def.deftype=formaldef) or
valid_for_assign(p,[valid_void,valid_const,valid_property]);
end;
@ -1113,6 +1145,12 @@ implementation
end;
function valid_for_addr(p : tnode) : boolean;
begin
result:=valid_for_assign(p,[valid_const,valid_addr,valid_void]);
end;
procedure var_para_allowed(var eq:tequaltype;def_from,def_to:Tdef);
begin
{ Note: eq must be already valid, it will only be updated! }
@ -1933,7 +1971,13 @@ implementation
end.
{
$Log$
Revision 1.105 2004-11-29 21:40:54 peter
Revision 1.106 2004-12-05 12:28:10 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.105 2004/11/29 21:40:54 peter
* fixed wrong calculation for checking default parameters
Revision 1.104 2004/11/15 23:35:31 peter

21
compiler/ncal.pas
View File

@ -24,8 +24,6 @@ unit ncal;
{$i fpcdefs.inc}
{ define NODEINLINE}
interface
uses
@ -2053,7 +2051,7 @@ type
tempnode := ctempcreatenode.create(voidpointertype,voidpointertype.def.size,tt_persistent,tparavarsym(para.parasym).varregable<>vr_none);
addstatement(createstatement,tempnode);
addstatement(createstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
caddrnode.create(para.left)));
caddrnode.create_internal(para.left)));
para.left := ctypeconvnode.create_internal(cderefnode.create(ctemprefnode.create(tempnode)),para.left.resulttype);
addstatement(deletestatement,ctempdeletenode.create(tempnode));
end;
@ -2081,7 +2079,8 @@ type
body : tnode;
i: longint;
begin
if not assigned(tprocdef(procdefinition).inlininginfo^.code) then
if not(assigned(tprocdef(procdefinition).inlininginfo) and
assigned(tprocdef(procdefinition).inlininginfo^.code)) then
internalerror(200412021);
{ inherit flags }
current_procinfo.flags := current_procinfo.flags + ((procdefinition as tprocdef).inlininginfo^.flags*inherited_inlining_flags);
@ -2121,15 +2120,13 @@ type
begin
result:=nil;
{$ifdef NODEINLINE}
{ Can we inline the procedure? }
if (procdefinition.proccalloption=pocall_inline) and
{ can we inline this procedure at the node level? }
(tprocdef(procdefinition).inlininginfo^.inlinenode) then
(po_has_inlininginfo in procdefinition.procoptions) then
begin
result:=pass1_inline;
exit;
end;
{$endif NODEINLINE}
{ calculate the parameter info for the procdef }
if not procdefinition.has_paraloc_info then
@ -2435,7 +2432,13 @@ begin
end.
{
$Log$
Revision 1.267 2004-12-03 16:07:04 peter
Revision 1.268 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.267 2004/12/03 16:07:04 peter
* fix crashes with nodeinlining
Revision 1.266 2004/12/02 19:26:14 peter

19
compiler/ncgcal.pas
View File

@ -402,16 +402,7 @@ implementation
if (parasym.varspez=vs_const) and
(left.location.loc=LOC_CONSTANT) then
location_force_mem(exprasmlist,left.location);
{ allow (typecasted) @var }
hp:=left;
while (hp.nodetype=typeconvn) do
hp:=ttypeconvnode(hp).left;
if (hp.nodetype=addrn) and
(not(nf_procvarload in hp.flags)) then
cg.a_param_loc(exprasmlist,left.location,tempcgpara)
else
push_addr_para;
push_addr_para;
end
{ Normal parameter }
else
@ -1262,7 +1253,13 @@ begin
end.
{
$Log$
Revision 1.189 2004-12-02 19:26:15 peter
Revision 1.190 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.189 2004/12/02 19:26:15 peter
* disable pass2inline
Revision 1.188 2004/11/21 18:13:31 peter

23
compiler/ncgcnv.pas
View File

@ -319,20 +319,15 @@ interface
procedure tcgtypeconvnode.second_proc_to_procvar;
begin
{ method pointer ? }
if tabstractprocdef(left.resulttype.def).is_methodpointer and
not(tabstractprocdef(left.resulttype.def).is_addressonly) then
if tabstractprocdef(resulttype.def).is_addressonly then
begin
location_copy(location,left.location);
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=cg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,location.register);
end
else
begin
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=cg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,location.register);
end;
location_copy(location,left.location);
end;
@ -534,7 +529,13 @@ end.
{
$Log$
Revision 1.65 2004-11-29 21:02:08 peter
Revision 1.66 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.65 2004/11/29 21:02:08 peter
* location_force_reg in second_nothing can reuse LOC_CREGISTER
Revision 1.64 2004/11/29 17:32:56 peter

27
compiler/ncgmem.pas
View File

@ -207,26 +207,9 @@ implementation
begin
secondpass(left);
{ when loading procvar we do nothing with this node, so load the
location of left }
if nf_procvarload in flags then
begin
location_copy(location,left.location);
exit;
end;
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=cg.getaddressregister(exprasmlist);
{ @ on a procvar means returning an address to the procedure that
is stored in it }
if (m_tp_procvar in aktmodeswitches) and
(left.nodetype=loadn) and
(tloadnode(left).resulttype.def.deftype=procvardef) and
assigned(tloadnode(left).symtableentry) and
(tloadnode(left).symtableentry.typ in [globalvarsym,localvarsym,paravarsym]) then
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.reference,location.register)
else
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,location.register);
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,location.register);
end;
@ -878,7 +861,13 @@ begin
end.
{
$Log$
Revision 1.102 2004-11-08 22:09:59 peter
Revision 1.103 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.102 2004/11/08 22:09:59 peter
* tvarsym splitted
Revision 1.101 2004/11/01 23:30:11 peter

12
compiler/ncgset.pas
View File

@ -91,7 +91,7 @@ implementation
paramgr,
pass_2,tgobj,
nbas,ncon,nflw,
ncgutil,regvars,cpuinfo,
ncgutil,regvars,
cgutils;
@ -806,7 +806,7 @@ implementation
end
else
begin
max_dist:=4*aword(labels);
max_dist:=4*labelcnt;
if jumptable_no_range then
max_linear_list:=4
else
@ -870,7 +870,13 @@ begin
end.
{
$Log$
Revision 1.71 2004-11-30 18:13:39 jonas
Revision 1.72 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.71 2004/11/30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.70 2004/10/31 21:45:03 peter

16
compiler/ncgutil.pas
View File

@ -105,8 +105,10 @@ interface
procedure gen_alloc_symtable(list:TAAsmoutput;st:tsymtable);
procedure gen_free_symtable(list:TAAsmoutput;st:tsymtable);
{$ifdef PASS2INLINE}
procedure gen_alloc_inline_parast(list:TAAsmoutput;pd:tprocdef);
procedure gen_alloc_inline_funcret(list:TAAsmoutput;pd:tprocdef);
{$endif PASS2INLINE}
{ rtti and init/final }
procedure generate_rtti(p:Ttypesym);
@ -2075,6 +2077,7 @@ implementation
end;
{$ifdef PASS2INLINE}
procedure gen_alloc_inline_parast(list:TAAsmoutput;pd:tprocdef);
var
sym : tsym;
@ -2166,12 +2169,12 @@ implementation
end;
LOC_REGISTER:
begin
{$ifndef cpu64bit}
{$ifndef cpu64bit}
if callerparaloc.size in [OS_64,OS_S64] then
begin
end
else
{$endif cpu64bit}
{$endif cpu64bit}
begin
pd.funcretloc[calleeside].register:=cg.getintregister(list,pd.funcretloc[calleeside].size);
pd.funcretloc[callerside].register:=pd.funcretloc[calleeside].register;
@ -2204,6 +2207,7 @@ implementation
end;
end;
end;
{$endif PASS2INLINE}
{ persistent rtti generation }
@ -2282,7 +2286,13 @@ implementation
end.
{
$Log$
Revision 1.246 2004-12-03 16:06:31 peter
Revision 1.247 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.246 2004/12/03 16:06:31 peter
* fix for int64 parameters passed in a single LOC_REFERENCE of 8 bytes
Revision 1.245 2004/11/21 18:13:31 peter

664
compiler/ncnv.pas
View File

@ -40,6 +40,7 @@ interface
constructor create(node : tnode;const t : ttype);virtual;
constructor create_explicit(node : tnode;const t : ttype);
constructor create_internal(node : tnode;const t : ttype);
constructor create_proc_to_procvar(node : tnode);
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure buildderefimpl;override;
@ -75,6 +76,7 @@ interface
function resulttype_call_helper(c : tconverttype) : tnode;
function resulttype_variant_to_enum : tnode;
function resulttype_enum_to_variant : tnode;
function resulttype_proc_to_procvar : tnode;
protected
function first_int_to_int : tnode;virtual;
function first_cstring_to_pchar : tnode;virtual;
@ -198,9 +200,9 @@ interface
implementation
uses
globtype,systems,
cclasses,globtype,systems,
cutils,verbose,globals,widestr,
symconst,symdef,symsym,symtable,
symconst,symdef,symsym,symbase,symtable,
ncon,ncal,nset,nadd,ninl,nmem,nmat,nutils,
cgbase,procinfo,
htypechk,pass_1,cpuinfo;
@ -500,7 +502,7 @@ implementation
begin
inherited create(typeconvn,node);
convtype:=tc_not_possible;
convtype:=tc_none;
totype:=t;
if t.def=nil then
internalerror(200103281);
@ -526,6 +528,14 @@ implementation
end;
constructor ttypeconvnode.create_proc_to_procvar(node : tnode);
begin
self.create(node,voidtype);
convtype:=tc_proc_2_procvar;
end;
constructor ttypeconvnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
@ -948,6 +958,7 @@ implementation
{ evaluate again, reset resulttype so the convert_typ
will be calculated again and cstring_to_pchar will
be used for futher conversion }
convtype:=tc_none;
result:=det_resulttype;
end;
@ -1027,7 +1038,7 @@ implementation
begin
result := ccallnode.createinternres(
'fpc_variant_to_dynarray',
ccallparanode.create(caddrnode.create(crttinode.create(tstoreddef(resulttype.def),initrtti)),
ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(resulttype.def),initrtti)),
ccallparanode.create(left,nil)
),resulttype);
resulttypepass(result);
@ -1040,7 +1051,7 @@ implementation
begin
result := ccallnode.createinternres(
'fpc_dynarray_to_variant',
ccallparanode.create(caddrnode.create(crttinode.create(tstoreddef(resulttype.def),initrtti)),
ccallparanode.create(caddrnode.create_internal(crttinode.create(tstoreddef(resulttype.def),initrtti)),
ccallparanode.create(ctypeconvnode.create_explicit(left,voidpointertype),nil)
),resulttype);
resulttypepass(result);
@ -1070,10 +1081,61 @@ implementation
end;
procedure copyparasym(p:TNamedIndexItem;arg:pointer);
var
newparast : tsymtable absolute arg;
vs : tparavarsym;
begin
if tsym(p).typ<>paravarsym then
exit;
with tparavarsym(p) do
begin
vs:=tparavarsym.create(realname,paranr,varspez,vartype);
vs.varoptions:=varoptions;
vs.defaultconstsym:=defaultconstsym;
newparast.insert(vs);
end;
end;
function ttypeconvnode.resulttype_proc_to_procvar : tnode;
var
pd : tabstractprocdef;
begin
result:=nil;
pd:=tabstractprocdef(left.resulttype.def);
{ create procvardef }
resulttype.setdef(tprocvardef.create(pd.parast.symtablelevel));
tprocvardef(resulttype.def).proctypeoption:=pd.proctypeoption;
tprocvardef(resulttype.def).proccalloption:=pd.proccalloption;
tprocvardef(resulttype.def).procoptions:=pd.procoptions;
tprocvardef(resulttype.def).rettype:=pd.rettype;
{ method ? then set the methodpointer flag }
if (pd.owner.symtabletype=objectsymtable) then
include(tprocvardef(resulttype.def).procoptions,po_methodpointer);
{ only need the address of the method? this is needed
for @tobject.create. In this case there will be a loadn without
a methodpointer. }
if (left.nodetype=loadn) and
not assigned(tloadnode(left).left) then
include(tprocvardef(resulttype.def).procoptions,po_addressonly);
{ Add parameters use only references, we don't need to keep the
parast. We use the parast from the original function to calculate
our parameter data and reset it afterwards }
pd.parast.foreach_static(@copyparasym,tprocvardef(resulttype.def).parast);
tprocvardef(resulttype.def).calcparas;
end;
function ttypeconvnode.resulttype_call_helper(c : tconverttype) : tnode;
{$ifdef fpc}
const
resulttypeconvert : array[tconverttype] of pointer = (
{none} nil,
{equal} nil,
{not_possible} nil,
{ string_2_string } @ttypeconvnode.resulttype_string_to_string,
@ -1094,7 +1156,7 @@ implementation
{ real_2_real } @ttypeconvnode.resulttype_real_to_real,
{ int_2_real } @ttypeconvnode.resulttype_int_to_real,
{ real_2_currency } @ttypeconvnode.resulttype_real_to_currency,
{ proc_2_procvar } nil,
{ proc_2_procvar } @ttypeconvnode.resulttype_proc_to_procvar,
{ arrayconstructor_2_set } @ttypeconvnode.resulttype_arrayconstructor_to_set,
{ load_smallset } nil,
{ cord_2_pointer } @ttypeconvnode.resulttype_cord_to_pointer,
@ -1103,12 +1165,12 @@ implementation
{ class_2_intf } nil,
{ char_2_char } @ttypeconvnode.resulttype_char_to_char,
{ normal_2_smallset} nil,
{ dynarray_2_openarray} @resulttype_dynarray_to_openarray,
{ pwchar_2_string} @resulttype_pwchar_to_string,
{ variant_2_dynarray} @resulttype_variant_to_dynarray,
{ dynarray_2_variant} @resulttype_dynarray_to_variant,
{ variant_2_enum} @resulttype_variant_to_enum,
{ enum_2_variant} @resulttype_enum_to_variant
{ dynarray_2_openarray} @ttypeconvnode.resulttype_dynarray_to_openarray,
{ pwchar_2_string} @ttypeconvnode.resulttype_pwchar_to_string,
{ variant_2_dynarray} @ttypeconvnode.resulttype_variant_to_dynarray,
{ dynarray_2_variant} @ttypeconvnode.resulttype_dynarray_to_variant,
{ variant_2_enum} @ttypeconvnode.resulttype_variant_to_enum,
{ enum_2_variant} @ttypeconvnode.resulttype_enum_to_variant
);
type
tprocedureofobject = function : tnode of object;
@ -1183,7 +1245,8 @@ implementation
{ tp procvar support. Skip typecasts to record or set. Those
convert on the procvar value. This is used to access the
fields of a methodpointer }
if not(resulttype.def.deftype in [recorddef,setdef]) then
if not(nf_load_procvar in flags) and
not(resulttype.def.deftype in [recorddef,setdef]) then
maybe_call_procvar(left,true);
{ convert array constructors to sets, because there is no conversion
@ -1195,242 +1258,229 @@ implementation
resulttypepass(left);
end;
cdoptions:=[cdo_check_operator,cdo_allow_variant];
if nf_explicit in flags then
include(cdoptions,cdo_explicit);
if nf_internal in flags then
include(cdoptions,cdo_internal);
eq:=compare_defs_ext(left.resulttype.def,resulttype.def,left.nodetype,convtype,aprocdef,cdoptions);
case eq of
te_exact,
te_equal :
begin
{ because is_equal only checks the basetype for sets we need to
check here if we are loading a smallset into a normalset }
if (resulttype.def.deftype=setdef) and
(left.resulttype.def.deftype=setdef) and
((tsetdef(resulttype.def).settype = smallset) xor
(tsetdef(left.resulttype.def).settype = smallset)) then
if convtype=tc_none then
begin
cdoptions:=[cdo_check_operator,cdo_allow_variant];
if nf_explicit in flags then
include(cdoptions,cdo_explicit);
if nf_internal in flags then
include(cdoptions,cdo_internal);
eq:=compare_defs_ext(left.resulttype.def,resulttype.def,left.nodetype,convtype,aprocdef,cdoptions);
case eq of
te_exact,
te_equal :
begin
{ constant sets can be converted by changing the type only }
if (left.nodetype=setconstn) then
begin
left.resulttype:=resulttype;
result:=left;
left:=nil;
exit;
end;
{ because is_equal only checks the basetype for sets we need to
check here if we are loading a smallset into a normalset }
if (resulttype.def.deftype=setdef) and
(left.resulttype.def.deftype=setdef) and
((tsetdef(resulttype.def).settype = smallset) xor
(tsetdef(left.resulttype.def).settype = smallset)) then
begin
{ constant sets can be converted by changing the type only }
if (left.nodetype=setconstn) then
begin
left.resulttype:=resulttype;
result:=left;
left:=nil;
exit;
end;
if (tsetdef(resulttype.def).settype <> smallset) then
convtype:=tc_load_smallset
if (tsetdef(resulttype.def).settype <> smallset) then
convtype:=tc_load_smallset
else
convtype := tc_normal_2_smallset;
exit;
end
else
convtype := tc_normal_2_smallset;
begin
{ Only leave when there is no conversion to do.
We can still need to call a conversion routine,
like the routine to convert a stringconstnode }
if convtype in [tc_equal,tc_not_possible] then
begin
left.resulttype:=resulttype;
result:=left;
left:=nil;
exit;
end;
end;
end;
te_convert_l1,
te_convert_l2,
te_convert_l3 :
begin
{ nothing to do }
end;
te_convert_operator :
begin
include(current_procinfo.flags,pi_do_call);
inc(aprocdef.procsym.refs);
hp:=ccallnode.create(ccallparanode.create(left,nil),Tprocsym(aprocdef.procsym),nil,nil,[]);
{ tell explicitly which def we must use !! (PM) }
tcallnode(hp).procdefinition:=aprocdef;
left:=nil;
result:=hp;
exit;
end
else
begin
{ Only leave when there is no conversion to do.
We can still need to call a conversion routine,
like the routine to convert a stringconstnode }
if convtype in [tc_equal,tc_not_possible] then
begin
left.resulttype:=resulttype;
result:=left;
left:=nil;
exit;
end;
end;
end;
end;
te_convert_l1,
te_convert_l2,
te_convert_l3 :
begin
{ nothing to do }
end;
te_convert_operator :
begin
include(current_procinfo.flags,pi_do_call);
inc(aprocdef.procsym.refs);
hp:=ccallnode.create(ccallparanode.create(left,nil),Tprocsym(aprocdef.procsym),nil,nil,[]);
{ tell explicitly which def we must use !! (PM) }
tcallnode(hp).procdefinition:=aprocdef;
left:=nil;
result:=hp;
exit;
end;
te_incompatible :
begin
{ Procedures have a resulttype.def of voiddef and functions of their
own resulttype.def. They will therefore always be incompatible with
a procvar. Because isconvertable cannot check for procedures we
use an extra check for them.}
if (m_tp_procvar in aktmodeswitches) and
(resulttype.def.deftype=procvardef) then
begin
if is_procsym_load(left) then
begin
if (left.nodetype<>addrn) then
begin
convtype:=tc_proc_2_procvar;
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if not(nf_explicit in flags) and
(proc_to_procvar_equal(tprocsym(tloadnode(left).symtableentry).first_procdef,
tprocvardef(resulttype.def),true)=te_incompatible) then
IncompatibleTypes(tprocsym(tloadnode(left).symtableentry).first_procdef,resulttype.def);
exit;
end;
end
else
if (left.nodetype=calln) and
(tcallnode(left).para_count=0) then
te_incompatible :
begin
{ Procedures have a resulttype.def of voiddef and functions of their
own resulttype.def. They will therefore always be incompatible with
a procvar. Because isconvertable cannot check for procedures we
use an extra check for them.}
if (m_tp_procvar in aktmodeswitches) and
(resulttype.def.deftype=procvardef) then
begin
if assigned(tcallnode(left).right) then
begin
{ this is already a procvar, if it is really equal
is checked below }
convtype:=tc_equal;
hp:=tcallnode(left).right.getcopy;
currprocdef:=tprocdef(hp.resulttype.def);
end
else
begin
convtype:=tc_proc_2_procvar;
currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).search_procdef_byprocvardef(Tprocvardef(resulttype.def));
hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
currprocdef,tcallnode(left).symtableproc);
if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then
begin
if assigned(tcallnode(left).methodpointer) then
begin
{ Under certain circumstances the methodpointer is a loadvmtaddrn
which isn't possible if it is used as a method pointer, so
fix this.
If you change this, ensure that tests/tbs/tw2669.pp still works }
if tcallnode(left).methodpointer.nodetype=loadvmtaddrn then
tloadnode(hp).set_mp(tloadvmtaddrnode(tcallnode(left).methodpointer).left.getcopy)
else
tloadnode(hp).set_mp(tcallnode(left).methodpointer.getcopy);
end
else
tloadnode(hp).set_mp(load_self_node);
end;
resulttypepass(hp);
end;
left.free;
left:=hp;
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if not(nf_explicit in flags) and
(proc_to_procvar_equal(currprocdef,
tprocvardef(resulttype.def),true)=te_incompatible) then
IncompatibleTypes(left.resulttype.def,resulttype.def);
exit;
end;
end;
{ Handle explicit type conversions }
if nf_explicit in flags then
begin
{ do common tc_equal cast }
convtype:=tc_equal;
{ ordinal constants can be resized to 1,2,4,8 bytes }
if (left.nodetype=ordconstn) then
begin
{ Insert typeconv for ordinal to the correct size first on left, after
that the other conversion can be done }
htype.reset;
case longint(resulttype.def.size) of
1 :
htype:=s8inttype;
2 :
htype:=s16inttype;
4 :
htype:=s32inttype;
8 :
htype:=s64inttype;
end;
{ we need explicit, because it can also be an enum }
if assigned(htype.def) then
inserttypeconv_internal(left,htype)
else
CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
end;
{ check if the result could be in a register }
if (not(tstoreddef(resulttype.def).is_intregable) and
not(tstoreddef(resulttype.def).is_fpuregable)) or
((left.resulttype.def.deftype = floatdef) and
(resulttype.def.deftype <> floatdef)) then
make_not_regable(left);
{ class to class or object to object, with checkobject support }
if (resulttype.def.deftype=objectdef) and
(left.resulttype.def.deftype=objectdef) then
begin
if (cs_check_object in aktlocalswitches) then
begin
if is_class_or_interface(resulttype.def) then
begin
{ we can translate the typeconvnode to 'as' when
typecasting to a class or interface }
hp:=casnode.create(left,cloadvmtaddrnode.create(ctypenode.create(resulttype)));
left:=nil;
result:=hp;
exit;
end;
end
else
begin
{ check if the types are related }
if not(nf_internal in flags) and
(not(tobjectdef(left.resulttype.def).is_related(tobjectdef(resulttype.def)))) and
(not(tobjectdef(resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
if (left.nodetype=calln) and
(tcallnode(left).para_count=0) then
begin
if assigned(tcallnode(left).right) then
begin
{ Give an error when typecasting class to interface, this is compatible
with delphi }
if is_interface(resulttype.def) and
not is_interface(left.resulttype.def) then
CGMessage2(type_e_classes_not_related,
FullTypeName(left.resulttype.def,resulttype.def),
FullTypeName(resulttype.def,left.resulttype.def))
else
CGMessage2(type_w_classes_not_related,
FullTypeName(left.resulttype.def,resulttype.def),
FullTypeName(resulttype.def,left.resulttype.def))
{ this is already a procvar, if it is really equal
is checked below }
convtype:=tc_equal;
hp:=tcallnode(left).right.getcopy;
currprocdef:=tprocdef(hp.resulttype.def);
end
else
begin
convtype:=tc_proc_2_procvar;
currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).search_procdef_byprocvardef(Tprocvardef(resulttype.def));
hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
currprocdef,tcallnode(left).symtableproc);
if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then
begin
if assigned(tcallnode(left).methodpointer) then
begin
{ Under certain circumstances the methodpointer is a loadvmtaddrn
which isn't possible if it is used as a method pointer, so
fix this.
If you change this, ensure that tests/tbs/tw2669.pp still works }
if tcallnode(left).methodpointer.nodetype=loadvmtaddrn then
tloadnode(hp).set_mp(tloadvmtaddrnode(tcallnode(left).methodpointer).left.getcopy)
else
tloadnode(hp).set_mp(tcallnode(left).methodpointer.getcopy);
end
else
tloadnode(hp).set_mp(load_self_node);
end;
resulttypepass(hp);
end;
end;
end
else
begin
{ only if the same size or formal def }
if not(
(left.resulttype.def.deftype=formaldef) or
(
not(is_open_array(left.resulttype.def)) and
(left.resulttype.def.size=resulttype.def.size)
) or
(
is_void(left.resulttype.def) and
(left.nodetype=derefn)
)
) then
CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
left.free;
left:=hp;
{ Now check if the procedure we are going to assign to
the procvar, is compatible with the procvar's type }
if not(nf_explicit in flags) and
(proc_to_procvar_equal(currprocdef,
tprocvardef(resulttype.def),true)=te_incompatible) then
IncompatibleTypes(left.resulttype.def,resulttype.def);
exit;
end;
end;
end
{ Handle explicit type conversions }
if nf_explicit in flags then
begin
{ do common tc_equal cast }
convtype:=tc_equal;
{ ordinal constants can be resized to 1,2,4,8 bytes }
if (left.nodetype=ordconstn) then
begin
{ Insert typeconv for ordinal to the correct size first on left, after
that the other conversion can be done }
htype.reset;
case longint(resulttype.def.size) of
1 :
htype:=s8inttype;
2 :
htype:=s16inttype;
4 :
htype:=s32inttype;
8 :
htype:=s64inttype;
end;
{ we need explicit, because it can also be an enum }
if assigned(htype.def) then
inserttypeconv_internal(left,htype)
else
CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
end;
{ check if the result could be in a register }
if (not(tstoreddef(resulttype.def).is_intregable) and
not(tstoreddef(resulttype.def).is_fpuregable)) or
((left.resulttype.def.deftype = floatdef) and
(resulttype.def.deftype <> floatdef)) then
make_not_regable(left);
{ class to class or object to object, with checkobject support }
if (resulttype.def.deftype=objectdef) and
(left.resulttype.def.deftype=objectdef) then
begin
if (cs_check_object in aktlocalswitches) then
begin
if is_class_or_interface(resulttype.def) then
begin
{ we can translate the typeconvnode to 'as' when
typecasting to a class or interface }
hp:=casnode.create(left,cloadvmtaddrnode.create(ctypenode.create(resulttype)));
left:=nil;
result:=hp;
exit;
end;
end
else
begin
{ check if the types are related }
if not(nf_internal in flags) and
(not(tobjectdef(left.resulttype.def).is_related(tobjectdef(resulttype.def)))) and
(not(tobjectdef(resulttype.def).is_related(tobjectdef(left.resulttype.def)))) then
begin
{ Give an error when typecasting class to interface, this is compatible
with delphi }
if is_interface(resulttype.def) and
not is_interface(left.resulttype.def) then
CGMessage2(type_e_classes_not_related,
FullTypeName(left.resulttype.def,resulttype.def),
FullTypeName(resulttype.def,left.resulttype.def))
else
CGMessage2(type_w_classes_not_related,
FullTypeName(left.resulttype.def,resulttype.def),
FullTypeName(resulttype.def,left.resulttype.def))
end;
end;
end
else
begin
{ only if the same size or formal def }
if not(
(left.resulttype.def.deftype=formaldef) or
(
not(is_open_array(left.resulttype.def)) and
(left.resulttype.def.size=resulttype.def.size)
) or
(
is_void(left.resulttype.def) and
(left.nodetype=derefn)
)
) then
CGMessage2(type_e_illegal_type_conversion,left.resulttype.def.gettypename,resulttype.def.gettypename);
end;
end
else
IncompatibleTypes(left.resulttype.def,resulttype.def);
end;
else
IncompatibleTypes(left.resulttype.def,resulttype.def);
internalerror(200211231);
end;
else
internalerror(200211231);
end;
end;
{ Give hint or warning for unportable code, exceptions are
- typecasts from constants
- void }
@ -1753,20 +1803,20 @@ implementation
function ttypeconvnode.first_proc_to_procvar : tnode;
begin
first_proc_to_procvar:=nil;
if assigned(tunarynode(left).left) then
begin
if (left.expectloc<>LOC_CREFERENCE) then
CGMessage(parser_e_illegal_expression);
registersint:=left.registersint;
expectloc:=left.expectloc
end
else
if tabstractprocdef(resulttype.def).is_addressonly then
begin
registersint:=left.registersint;
if registersint<1 then
registersint:=1;
expectloc:=LOC_REGISTER;
end
else
begin
if not(left.expectloc in [LOC_CREFERENCE,LOC_REFERENCE]) then
CGMessage(parser_e_illegal_expression);
registersint:=left.registersint;
expectloc:=left.expectloc
end
end;
@ -1920,6 +1970,7 @@ implementation
const
firstconvert : array[tconverttype] of pointer = (
nil, { none }
@ttypeconvnode._first_nothing, {equal}
@ttypeconvnode._first_nothing, {not_possible}
nil, { removed in resulttype_string_to_string }
@ -2151,44 +2202,44 @@ implementation
procedure ttypeconvnode.second_call_helper(c : tconverttype);
{$ifdef fpc}
const
secondconvert : array[tconverttype] of pointer = (
@_second_nothing, {equal}
@_second_nothing, {not_possible}
@_second_nothing, {second_string_to_string, handled in resulttype pass }
@_second_char_to_string,
@_second_nothing, {char_to_charray}
@_second_nothing, { pchar_to_string, handled in resulttype pass }
@_second_nothing, {cchar_to_pchar}
@_second_cstring_to_pchar,
@_second_ansistring_to_pchar,
@_second_string_to_chararray,
@_second_nothing, { chararray_to_string, handled in resulttype pass }
@_second_array_to_pointer,
@_second_pointer_to_array,
@_second_int_to_int,
@_second_int_to_bool,
@_second_bool_to_bool,
@_second_bool_to_int,
@_second_real_to_real,
@_second_int_to_real,
@_second_nothing, { real_to_currency, handled in resulttype pass }
@_second_proc_to_procvar,
@_second_nothing, { arrayconstructor_to_set }
@_second_nothing, { second_load_smallset, handled in first pass }
@_second_cord_to_pointer,
@_second_nothing, { interface 2 string }
@_second_nothing, { interface 2 guid }
@_second_class_to_intf,
@_second_char_to_char,
@_second_nothing, { normal_2_smallset }
@_second_nothing, { dynarray_2_openarray }
@_second_nothing, { pwchar_2_string }
@_second_nothing, { variant_2_dynarray }
@_second_nothing, { dynarray_2_variant}
@_second_nothing, { variant_2_enum }
@_second_nothing { enum_2_variant }
@ttypeconvnode._second_nothing, {none}
@ttypeconvnode._second_nothing, {equal}
@ttypeconvnode._second_nothing, {not_possible}
@ttypeconvnode._second_nothing, {second_string_to_string, handled in resulttype pass }
@ttypeconvnode._second_char_to_string,
@ttypeconvnode._second_nothing, {char_to_charray}
@ttypeconvnode._second_nothing, { pchar_to_string, handled in resulttype pass }
@ttypeconvnode._second_nothing, {cchar_to_pchar}
@ttypeconvnode._second_cstring_to_pchar,
@ttypeconvnode._second_ansistring_to_pchar,
@ttypeconvnode._second_string_to_chararray,
@ttypeconvnode._second_nothing, { chararray_to_string, handled in resulttype pass }
@ttypeconvnode._second_array_to_pointer,
@ttypeconvnode._second_pointer_to_array,
@ttypeconvnode._second_int_to_int,
@ttypeconvnode._second_int_to_bool,
@ttypeconvnode._second_bool_to_bool,
@ttypeconvnode._second_bool_to_int,
@ttypeconvnode._second_real_to_real,
@ttypeconvnode._second_int_to_real,
@ttypeconvnode._second_nothing, { real_to_currency, handled in resulttype pass }
@ttypeconvnode._second_proc_to_procvar,
@ttypeconvnode._second_nothing, { arrayconstructor_to_set }
@ttypeconvnode._second_nothing, { second_load_smallset, handled in first pass }
@ttypeconvnode._second_cord_to_pointer,
@ttypeconvnode._second_nothing, { interface 2 string }
@ttypeconvnode._second_nothing, { interface 2 guid }
@ttypeconvnode._second_class_to_intf,
@ttypeconvnode._second_char_to_char,
@ttypeconvnode._second_nothing, { normal_2_smallset }
@ttypeconvnode._second_nothing, { dynarray_2_openarray }
@ttypeconvnode._second_nothing, { pwchar_2_string }
@ttypeconvnode._second_nothing, { variant_2_dynarray }
@ttypeconvnode._second_nothing, { dynarray_2_variant}
@ttypeconvnode._second_nothing, { variant_2_enum }
@ttypeconvnode._second_nothing { enum_2_variant }
);
type
tprocedureofobject = procedure of object;
@ -2206,46 +2257,7 @@ implementation
r.obj:=self;
tprocedureofobject(r)();
end;
{$else fpc}
begin
case c of
tc_equal,
tc_not_possible,
tc_string_2_string : second_nothing;
tc_char_2_string : second_char_to_string;
tc_char_2_chararray : second_nothing;
tc_pchar_2_string : second_nothing;
tc_cchar_2_pchar : second_nothing;
tc_cstring_2_pchar : second_cstring_to_pchar;
tc_ansistring_2_pchar : second_ansistring_to_pchar;
tc_string_2_chararray : second_string_to_chararray;
tc_chararray_2_string : second_nothing;
tc_array_2_pointer : second_array_to_pointer;
tc_pointer_2_array : second_pointer_to_array;
tc_int_2_int : second_int_to_int;
tc_int_2_bool : second_int_to_bool;
tc_bool_2_bool : second_bool_to_bool;
tc_bool_2_int : second_bool_to_int;
tc_real_2_real : second_real_to_real;
tc_int_2_real : second_int_to_real;
tc_real_2_currency : second_nothing;
tc_proc_2_procvar : second_proc_to_procvar;
tc_arrayconstructor_2_set : second_nothing;
tc_load_smallset : second_nothing;
tc_cord_2_pointer : second_cord_to_pointer;
tc_intf_2_string : second_nothing;
tc_intf_2_guid : second_nothing;
tc_class_2_intf : second_class_to_intf;
tc_char_2_char : second_char_to_char;
tc_normal_2_smallset : second_nothing;
tc_dynarray_2_openarray : second_nothing;
tc_pwchar_2_string : second_nothing;
tc_variant_2_dynarray : second_nothing;
tc_dynarray_2_variant : second_nothing;
else internalerror(2002101101);
end;
end;
{$endif fpc}
{*****************************************************************************
TISNODE
@ -2486,7 +2498,13 @@ begin
end.
{
$Log$
Revision 1.165 2004-12-05 12:15:11 florian
Revision 1.166 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.165 2004/12/05 12:15:11 florian
* fixed compiler side of variant <-> dyn. array conversion
Revision 1.164 2004/11/26 22:34:28 peter

12
compiler/ninl.pas
View File

@ -424,7 +424,7 @@ implementation
{ assign the address of the file to the temp }
addstatement(newstatement,
cassignmentnode.create(ctemprefnode.create(filetemp),
caddrnode.create(filepara.left)));
caddrnode.create_internal(filepara.left)));
resulttypepass(newstatement.left);
{ create a new fileparameter as follows: file_type(temp^) }
{ (so that we pass the value and not the address of the temp }
@ -2160,7 +2160,7 @@ implementation
tempnode := ctempcreatenode.create(voidpointertype,voidpointertype.def.size,tt_persistent,true);
addstatement(newstatement,tempnode);
addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
caddrnode.create(tcallparanode(left).left.getcopy)));
caddrnode.create_internal(tcallparanode(left).left.getcopy)));
hp := cderefnode.create(ctemprefnode.create(tempnode));
inserttypeconv_internal(hp,tcallparanode(left).left.resulttype);
end
@ -2463,7 +2463,13 @@ begin
end.
{
$Log$
Revision 1.155 2004-11-26 22:33:00 peter
Revision 1.156 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.155 2004/11/26 22:33:00 peter
* fixed read temp for result
Revision 1.154 2004/11/21 21:27:31 peter

10
compiler/nld.pas
View File

@ -595,7 +595,7 @@ implementation
if is_dynamic_array(left.resulttype.def) and
(right.nodetype=niln) then
begin
hp:=ccallparanode.create(caddrnode.create
hp:=ccallparanode.create(caddrnode.create_internal
(crttinode.create(tstoreddef(left.resulttype.def),initrtti)),
ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),nil));
result := ccallnode.createintern('fpc_dynarray_clear',hp);
@ -1172,7 +1172,13 @@ begin
end.
{
$Log$
Revision 1.139 2004-11-08 22:09:59 peter
Revision 1.140 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.139 2004/11/08 22:09:59 peter
* tvarsym splitted
Revision 1.138 2004/11/02 12:55:16 peter

226
compiler/nmem.pas
View File

@ -56,6 +56,7 @@ interface
getprocvardef : tprocvardef;
getprocvardefderef : tderef;
constructor create(l : tnode);virtual;
constructor create_internal(l : tnode); virtual;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
procedure mark_write;override;
@ -127,7 +128,7 @@ implementation
uses
globtype,systems,
cutils,cclasses,verbose,globals,
cutils,verbose,globals,
symconst,symbase,defutil,defcmp,
nbas,nutils,
htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase,procinfo
@ -255,6 +256,13 @@ implementation
end;
constructor taddrnode.create_internal(l : tnode);
begin
self.create(l);
include(flags,nf_internal);
end;
constructor taddrnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
begin
inherited ppuload(t,ppufile);
@ -301,29 +309,11 @@ implementation
end;
procedure copyparasym(p:TNamedIndexItem;arg:pointer);
var
newparast : tsymtable absolute arg;
vs : tparavarsym;
begin
if tsym(p).typ<>paravarsym then
exit;
with tparavarsym(p) do
begin
vs:=tparavarsym.create(realname,paranr,varspez,vartype);
vs.varoptions:=varoptions;
// vs.paraloc[callerside]:=paraloc[callerside].getcopy;
// vs.paraloc[callerside]:=paraloc[callerside].getcopy;
vs.defaultconstsym:=defaultconstsym;
newparast.insert(vs);
end;
end;
function taddrnode.det_resulttype:tnode;
var
hp : tnode;
hp3 : tabstractprocdef;
hsym : tfieldvarsym;
isprocvar : boolean;
begin
result:=nil;
resulttypepass(left);
@ -340,137 +330,94 @@ implementation
exit;
end;
{ tp @procvar support (type of @procvar is a void pointer)
Note: we need to leave the addrn in the tree,
else we can't see the difference between @procvar and procvar.
we set the procvarload flag so a secondpass does nothing for
this node (PFV) }
if (m_tp_procvar in aktmodeswitches) then
begin
case left.nodetype of
calln :
begin
{ a load of a procvar can't have parameters }
if assigned(tcallnode(left).left) then
CGMessage(parser_e_illegal_expression);
{ is it a procvar? }
hp:=tcallnode(left).right;
if assigned(hp) then
begin
{ remove calln node }
tcallnode(left).right:=nil;
left.free;
left:=hp;
include(flags,nf_procvarload);
end;
end;
loadn,
subscriptn,
typeconvn,
vecn,
derefn :
begin
if left.resulttype.def.deftype=procvardef then
include(flags,nf_procvarload);
end;
end;
if nf_procvarload in flags then
begin
resulttype:=voidpointertype;
exit;
end;
end;
{ proc 2 procvar ? }
if left.nodetype=calln then
{ if it were a valid construct, the addr node would already have }
{ been removed in the parser. This happens for (in FPC mode) }
{ procvar1 := @procvar2(parameters); }
CGMessage(parser_e_illegal_expression)
else
if (left.nodetype=loadn) and (tloadnode(left).symtableentry.typ=procsym) then
{ Handle @proc special, also @procvar in tp-mode needs
special handling }
if (left.resulttype.def.deftype=procdef) or
((left.resulttype.def.deftype=procvardef) and
(m_tp_procvar in aktmodeswitches)) then
begin
{ result is a procedure variable }
{ No, to be TP compatible, you must return a voidpointer to
the procedure that is stored in the procvar.}
if not(m_tp_procvar in aktmodeswitches) then
isprocvar:=(left.resulttype.def.deftype=procvardef);
if not isprocvar then
begin
if assigned(getprocvardef) and
(tprocsym(tloadnode(left).symtableentry).procdef_count>1) then
left:=ctypeconvnode.create_proc_to_procvar(left);
resulttypepass(left);
end;
{ In tp procvar mode the result is always a voidpointer. Insert
a typeconversion to voidpointer. For methodpointers we need
to load the proc field }
if (m_tp_procvar in aktmodeswitches) then
begin
if tabstractprocdef(left.resulttype.def).is_addressonly then
begin
hp3:=tprocsym(tloadnode(left).symtableentry).search_procdef_byprocvardef(getprocvardef);
if not assigned(hp3) then
begin
IncompatibleTypes(tprocsym(tloadnode(left).symtableentry).first_procdef,getprocvardef);
exit;
end;
result:=ctypeconvnode.create_internal(left,voidpointertype);
include(result.flags,nf_load_procvar);
left:=nil;
end
else
hp3:=tabstractprocdef(tprocsym(tloadnode(left).symtableentry).first_procdef);
{ create procvardef }
resulttype.setdef(tprocvardef.create(hp3.parast.symtablelevel));
tprocvardef(resulttype.def).proctypeoption:=hp3.proctypeoption;
tprocvardef(resulttype.def).proccalloption:=hp3.proccalloption;
tprocvardef(resulttype.def).procoptions:=hp3.procoptions;
tprocvardef(resulttype.def).rettype:=hp3.rettype;
{ method ? then set the methodpointer flag }
if (hp3.owner.symtabletype=objectsymtable) then
include(tprocvardef(resulttype.def).procoptions,po_methodpointer);
{ only need the address of the method? this is needed
for @tobject.create }
if assigned(tloadnode(left).left) then
include(flags,nf_procvarload)
else
include(tprocvardef(resulttype.def).procoptions,po_addressonly);
{ Add parameters use only references, we don't need to keep the
parast. We use the parast from the original function to calculate
our parameter data and reset it afterwards }
hp3.parast.foreach_static(@copyparasym,tprocvardef(resulttype.def).parast);
tprocvardef(resulttype.def).calcparas;
else
begin
{ For procvars we need to return the proc field of the
methodpointer }
if isprocvar then
begin
{ find proc field in methodpointer record }
hsym:=tfieldvarsym(trecorddef(methodpointertype.def).symtable.search('proc'));
if not assigned(hsym) then
internalerror(200412041);
{ Load tmehodpointer(left).proc }
result:=csubscriptnode.create(
hsym,
ctypeconvnode.create_internal(left,methodpointertype));
left:=nil;
end
else
CGMessage(type_e_variable_id_expected);
end;
end
else
begin
if assigned(tloadnode(left).left) then
CGMessage(parser_e_illegal_expression);
resulttype:=voidpointertype;
{ Return the typeconvn only }
result:=left;
left:=nil;
end;
end
else
begin
{ what are we getting the address from an absolute sym? }
hp:=left;
while assigned(hp) and (hp.nodetype in [vecn,derefn,subscriptn]) do
hp:=tunarynode(hp).left;
while assigned(hp) and (hp.nodetype in [typeconvn,vecn,derefn,subscriptn]) do
hp:=tunarynode(hp).left;
if not assigned(hp) then
internalerror(200412042);
{$ifdef i386}
if assigned(hp) and
(hp.nodetype=loadn) and
if (hp.nodetype=loadn) and
((tloadnode(hp).symtableentry.typ=absolutevarsym) and
tabsolutevarsym(tloadnode(hp).symtableentry).absseg) then
begin
if not(nf_typedaddr in flags) then
resulttype:=voidfarpointertype
else
resulttype.setdef(tpointerdef.createfar(left.resulttype));
end
tabsolutevarsym(tloadnode(hp).symtableentry).absseg) then
begin
if not(nf_typedaddr in flags) then
resulttype:=voidfarpointertype
else
resulttype.setdef(tpointerdef.createfar(left.resulttype));
end
else
{$endif i386}
begin
if not(nf_typedaddr in flags) then
resulttype:=voidpointertype
else
resulttype.setdef(tpointerdef.create(left.resulttype));
end;
if (nf_internal in flags) or
valid_for_addr(left) then
begin
if not(nf_typedaddr in flags) then
resulttype:=voidpointertype
else
resulttype.setdef(tpointerdef.create(left.resulttype));
end
else
CGMessage(type_e_variable_id_expected);
end;
{ this is like the function addr }
inc(parsing_para_level);
set_varstate(left,vs_used,false);
dec(parsing_para_level);
end;
@ -481,19 +428,6 @@ implementation
if codegenerror then
exit;
if nf_procvarload in flags then
begin
registersint:=left.registersint;
registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
if registersint<1 then
registersint:=1;
expectloc:=left.expectloc;
exit;
end;
{ we should allow loc_mem for @string }
if not(left.expectloc in [LOC_CREFERENCE,LOC_REFERENCE]) then
begin
@ -997,7 +931,13 @@ begin
end.
{
$Log$
Revision 1.91 2004-11-29 17:32:56 peter
Revision 1.92 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.91 2004/11/29 17:32:56 peter
* prevent some IEs with delphi methodpointers
Revision 1.90 2004/11/26 22:33:24 peter

10
compiler/node.pas
View File

@ -205,7 +205,6 @@ interface
nf_isproperty,
{ taddrnode }
nf_procvarload,
nf_typedaddr,
{ tderefnode }
@ -235,6 +234,7 @@ interface
{ ttypeconvnode }
nf_explicit,
nf_internal, { no warnings/hints generated }
nf_load_procvar,
{ tinlinenode }
nf_inlineconst,
@ -1139,7 +1139,13 @@ implementation
end.
{
$Log$
Revision 1.91 2004-12-02 19:26:15 peter
Revision 1.92 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.91 2004/12/02 19:26:15 peter
* disable pass2inline
Revision 1.90 2004/11/02 12:55:16 peter

20
compiler/nutils.pas
View File

@ -417,11 +417,11 @@ implementation
begin
result:=ccallnode.createintern('fpc_initialize',
ccallparanode.create(
caddrnode.create(
caddrnode.create_internal(
crttinode.create(
tstoreddef(p.resulttype.def),initrtti)),
ccallparanode.create(
caddrnode.create(p),
caddrnode.create_internal(p),
nil)));
end;
end;
@ -433,11 +433,11 @@ implementation
resulttypepass(p);
result:=ccallnode.createintern('fpc_finalize',
ccallparanode.create(
caddrnode.create(
caddrnode.create_internal(
crttinode.create(
tstoreddef(p.resulttype.def),initrtti)),
ccallparanode.create(
caddrnode.create(p),
caddrnode.create_internal(p),
nil)));
end;
@ -466,9 +466,9 @@ implementation
end;
loadn:
begin
{ threadvars need a helper call }
{ threadvars need a helper call }
if (tloadnode(p).symtableentry.typ=globalvarsym) and
(vo_is_thread_var in tglobalvarsym(tloadnode(p).symtableentry).varoptions) then
(vo_is_thread_var in tglobalvarsym(tloadnode(p).symtableentry).varoptions) then
inc(result,5)
else
inc(result);
@ -530,7 +530,13 @@ end.
{
$Log$
Revision 1.23 2004-12-02 19:26:15 peter
Revision 1.24 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.23 2004/12/02 19:26:15 peter
* disable pass2inline
Revision 1.22 2004/11/28 19:29:45 jonas

22
compiler/pdecsub.pas
View File

@ -1821,12 +1821,12 @@ const
{ External Procedures }
if (po_external in pd.procoptions) then
begin
{ import by number? }
{ import by number? }
if pd.import_nr<>0 then
begin
{ Nothing to do }
end
else
begin
{ Nothing to do }
end
else
{ external name specified }
if assigned(pd.import_name) then
begin
@ -1838,12 +1838,12 @@ const
(target_info.system in [system_i386_win32,system_i386_wdosx,
system_i386_emx,system_i386_os2])
) then
begin
begin
if not(pd.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
pd.setmangledname(pd.import_name^)
else
pd.setmangledname(target_info.Cprefix+pd.import_name^);
end;
end;
end
else
begin
@ -2358,7 +2358,13 @@ const
end.
{
$Log$
Revision 1.216 2004-12-05 00:32:56 olle
Revision 1.217 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.216 2004/12/05 00:32:56 olle
+ bugfix for $Z+ for mode macpas
Revision 1.215 2004/11/29 21:50:08 peter

10
compiler/pexpr.pas
View File

@ -321,7 +321,7 @@ implementation
htype.setdef(tpointerdef.create(p1.resulttype));
temp:=ctempcreatenode.create(htype,sizeof(aint),tt_persistent,false);
addstatement(newstatement,temp);
addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(temp),caddrnode.create(p1)));
addstatement(newstatement,cassignmentnode.create(ctemprefnode.create(temp),caddrnode.create_internal(p1)));
addstatement(newstatement,cassignmentnode.create(
cderefnode.create(ctemprefnode.create(temp)),
caddnode.create(ntyp,
@ -2505,7 +2505,13 @@ implementation
end.
{
$Log$
Revision 1.174 2004-11-21 17:54:59 peter
Revision 1.175 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.174 2004/11/21 17:54:59 peter
* ttempcreatenode.create_reg merged into .create with parameter
whether a register is allowed
* funcret_paraloc renamed to funcretloc

20
compiler/pinline.pas
View File

@ -327,7 +327,7 @@ implementation
{ create call to fpc_initialize }
if tpointerdef(p1.resulttype.def).pointertype.def.needs_inittable then
begin
para := ccallparanode.create(caddrnode.create(crttinode.create
para := ccallparanode.create(caddrnode.create_internal(crttinode.create
(tstoreddef(tpointerdef(p1.resulttype.def).pointertype.def),initrtti)),
ccallparanode.create(ctemprefnode.create
(temp),nil));
@ -495,11 +495,11 @@ implementation
ppn.left:=nil;
{ create call to fpc_dynarr_setlength }
npara:=ccallparanode.create(caddrnode.create
npara:=ccallparanode.create(caddrnode.create_internal
(ctemprefnode.create(temp)),
ccallparanode.create(cordconstnode.create
(counter,s32inttype,true),
ccallparanode.create(caddrnode.create
ccallparanode.create(caddrnode.create_internal
(crttinode.create(tstoreddef(destppn.resulttype.def),initrtti)),
ccallparanode.create(ctypeconvnode.create_internal(destppn,voidpointertype),nil))));
addstatement(newstatement,ccallnode.createintern('fpc_dynarray_setlength',npara));
@ -593,9 +593,9 @@ implementation
(destppn.left.resulttype.def.size,s32inttype,true),
ccallparanode.create(ctypeconvnode.create
(ppn.left,s32inttype),
ccallparanode.create(caddrnode.create
ccallparanode.create(caddrnode.create_internal
(crttinode.create(tstoreddef(destppn.left.resulttype.def),initrtti)),
ccallparanode.create(caddrnode.create
ccallparanode.create(caddrnode.create_internal
(destppn.left),nil))));
newblock:=ccallnode.createintern('fpc_finalize_array',npara);
destppn.left:=nil;
@ -724,7 +724,7 @@ implementation
{ create call to fpc_dynarray_copy }
npara:=ccallparanode.create(highppn,
ccallparanode.create(lowppn,
ccallparanode.create(caddrnode.create
ccallparanode.create(caddrnode.create_internal
(crttinode.create(tstoreddef(ppn.left.resulttype.def),initrtti)),
ccallparanode.create
(ctypeconvnode.create_internal(ppn.left,voidpointertype),
@ -754,7 +754,13 @@ implementation
end.
{
$Log$
Revision 1.37 2004-11-21 17:54:59 peter
Revision 1.38 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.37 2004/11/21 17:54:59 peter
* ttempcreatenode.create_reg merged into .create with parameter
whether a register is allowed
* funcret_paraloc renamed to funcretloc

10
compiler/pstatmnt.pas
View File

@ -489,7 +489,7 @@ implementation
end
else
begin
hp:=caddrnode.create(p);
hp:=caddrnode.create_internal(p);
refp:=cderefnode.create(ctemprefnode.create(loadp));
end;
addstatement(newstatement,loadp);
@ -1147,7 +1147,13 @@ implementation
end.
{
$Log$
Revision 1.146 2004-11-30 18:13:39 jonas
Revision 1.147 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.146 2004/11/30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.145 2004/11/21 17:54:59 peter

37
compiler/psub.pas
View File

@ -928,11 +928,9 @@ implementation
if assigned(code) then
begin
{ the inline procedure has already got a copy of the tree
stored in current_procinfo.procdef.code }
stored in procdef.inlininginfo }
code.free;
code:=nil;
if (procdef.proccalloption<>pocall_inline) then
procdef.inlininginfo^.code:=nil;
end;
end;
@ -943,8 +941,7 @@ implementation
currpara : tparavarsym;
begin
result := false;
if not assigned(procdef.inlininginfo^.code) or
(po_assembler in procdef.procoptions) then
if (po_assembler in procdef.procoptions) then
exit;
for i:=0 to procdef.paras.count-1 do
begin
@ -1039,19 +1036,19 @@ implementation
end;
end;
{ store a copy of the original tree for inline, for
normal procedures only store a reference to the
current tree }
if (procdef.proccalloption=pocall_inline) then
begin
procdef.inlininginfo^.code:=code.getcopy;
procdef.inlininginfo^.flags:=current_procinfo.flags;
procdef.inlininginfo^.inlinenode:=checknodeinlining(procdef);
if procdef.inlininginfo^.code.nodetype=blockn then
include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
end
else
procdef.inlininginfo^.code:=code;
{ Can we inline this procedure? }
if checknodeinlining(procdef) then
begin
new(procdef.inlininginfo);
include(procdef.procoptions,po_has_inlininginfo);
procdef.inlininginfo^.code:=code.getcopy;
procdef.inlininginfo^.flags:=current_procinfo.flags;
if procdef.inlininginfo^.code.nodetype=blockn then
include(procdef.inlininginfo^.code.flags,nf_block_with_exit);
end;
end;
{ Print the node to tree.log }
if paraprintnodetree=1 then
@ -1430,7 +1427,13 @@ implementation
end.
{
$Log$
Revision 1.221 2004-12-02 19:26:15 peter
Revision 1.222 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.221 2004/12/02 19:26:15 peter
* disable pass2inline
Revision 1.220 2004/11/29 18:50:15 peter

46
compiler/ptconst.pas
View File

@ -42,7 +42,7 @@ implementation
symconst,symbase,symdef,symtable,
aasmbase,aasmtai,aasmcpu,defutil,defcmp,
{ pass 1 }
node,
node,htypechk,
nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,
{ parser specific stuff }
pbase,pexpr,
@ -61,7 +61,7 @@ implementation
Psetbytes = ^setbytes;
var
len,base : longint;
p,hp,hpstart : tnode;
p,hp : tnode;
i,j,l,
varalign : longint;
offset,
@ -369,32 +369,17 @@ implementation
Message(parser_e_illegal_expression);
end
else
if p.nodetype=addrn then
if (p.nodetype=addrn) or
is_procvar_load(p) then
begin
{ support @@procvar in tp mode }
if (m_tp_procvar in aktmodeswitches) and
(taddrnode(p).left.nodetype=addrn) then
p:=taddrnode(p).left;
{ insert typeconv }
inserttypeconv(p,t);
{ if a typeconv node was inserted then check if it was an tc_equal. If
true then we remove the node. If not tc_equal then we leave the typeconvn
and the nodetype=loadn will always be false and generate the error (PFV) }
if (p.nodetype=typeconvn) then
begin
if (ttypeconvnode(p).convtype=tc_equal) then
hpstart:=taddrnode(ttypeconvnode(p).left).left
else
hpstart:=p;
end
else
hpstart:=taddrnode(p).left;
hp:=hpstart;
while assigned(hp) and (hp.nodetype in [subscriptn,vecn]) do
hp:=p;
while assigned(hp) and (hp.nodetype in [addrn,typeconvn,subscriptn,vecn]) do
hp:=tunarynode(hp).left;
if (hp.nodetype=loadn) then
begin
hp:=hpstart;
hp:=p;
offset:=0;
while assigned(hp) and (hp.nodetype<>loadn) do
begin
@ -423,7 +408,14 @@ implementation
Message(parser_e_illegal_expression);
end;
subscriptn :
inc(offset,tsubscriptnode(hp).vs.fieldoffset)
inc(offset,tsubscriptnode(hp).vs.fieldoffset);
typeconvn :
begin
if not(ttypeconvnode(hp).convtype in [tc_equal,tc_proc_2_procvar]) then
Message(parser_e_illegal_expression);
end;
addrn :
;
else
Message(parser_e_illegal_expression);
end;
@ -1089,7 +1081,13 @@ implementation
end.
{
$Log$
Revision 1.96 2004-11-09 17:26:47 peter
Revision 1.97 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.96 2004/11/09 17:26:47 peter
* fixed wrong typecasts
Revision 1.95 2004/11/08 22:09:59 peter

11
compiler/symconst.pas
View File

@ -248,7 +248,8 @@ type
po_has_mangledname,
po_has_public_name,
po_forward,
po_global
po_global,
po_has_inlininginfo
);
tprocoptions=set of tprocoption;
@ -428,7 +429,13 @@ initialization
end.
{
$Log$
Revision 1.95 2004-11-19 08:17:02 michael
Revision 1.96 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.95 2004/11/19 08:17:02 michael
* Split po_public into po_public and po_global (Peter)
Revision 1.94 2004/11/17 22:21:35 peter

54
compiler/symdef.pas
View File

@ -494,10 +494,9 @@ interface
end;
tinlininginfo = record
{ node tree }
code : tnode;
{ node tree }
code : tnode;
flags : tprocinfoflags;
inlinenode : boolean;
end;
pinlininginfo = ^tinlininginfo;
@ -3605,8 +3604,7 @@ implementation
import_dll:=nil;
import_name:=nil;
import_nr:=0;
new(inlininginfo);
fillchar(inlininginfo^,sizeof(tinlininginfo),0);
inlininginfo:=nil;
{$ifdef GDB}
isstabwritten := false;
{$endif GDB}
@ -3639,22 +3637,24 @@ implementation
import_name:=nil;
import_nr:=0;
{ inline stuff }
if proccalloption=pocall_inline then
if (po_has_inlininginfo in procoptions) then
begin
ppufile.getderef(funcretsymderef);
new(inlininginfo);
ppufile.getsmallset(inlininginfo^.flags);
inlininginfo^.inlinenode:=boolean(ppufile.getbyte);
end
else
funcretsym:=nil;
begin
inlininginfo:=nil;
funcretsym:=nil;
end;
{ load para symtable }
parast:=tparasymtable.create(level);
tparasymtable(parast).ppuload(ppufile);
parast.defowner:=self;
{ load local symtable }
if ((proccalloption=pocall_inline) or
((current_module.flags and uf_local_browser)<>0)) then
if (po_has_inlininginfo in procoptions) or
((current_module.flags and uf_local_browser)<>0) then
begin
localst:=tlocalsymtable.create(level);
tlocalsymtable(localst).ppuload(ppufile);
@ -3663,10 +3663,8 @@ implementation
else
localst:=nil;
{ inline stuff }
if proccalloption=pocall_inline then
inlininginfo^.code:=ppuloadnodetree(ppufile)
else
inlininginfo := nil;
if (po_has_inlininginfo in procoptions) then
inlininginfo^.code:=ppuloadnodetree(ppufile);
{ default values for no persistent data }
if (cs_link_deffile in aktglobalswitches) and
(tf_need_export in target_info.flags) and
@ -3704,7 +3702,7 @@ implementation
memproclocalst.start;
{$endif MEMDEBUG}
end;
if (proccalloption=pocall_inline) and assigned(inlininginfo) then
if assigned(inlininginfo) then
begin
{$ifdef MEMDEBUG}
memprocnodetree.start;
@ -3713,11 +3711,10 @@ implementation
{$ifdef MEMDEBUG}
memprocnodetree.start;
{$endif MEMDEBUG}
dispose(inlininginfo);
end;
stringdispose(import_dll);
stringdispose(import_name);
if assigned(inlininginfo) then
dispose(inlininginfo);
if (po_msgstr in procoptions) then
strdispose(messageinf.str);
if assigned(_mangledname) then
@ -3768,13 +3765,11 @@ implementation
{ inline stuff }
oldintfcrc:=ppufile.do_crc;
ppufile.do_crc:=false;
if proccalloption=pocall_inline then
if (po_has_inlininginfo in procoptions) then
begin
ppufile.putderef(funcretsymderef);
ppufile.putsmallset(inlininginfo^.flags);
ppufile.putbyte(byte(inlininginfo^.inlinenode));
end;
ppufile.do_crc:=oldintfcrc;
{ write this entry }
@ -3785,7 +3780,7 @@ implementation
{ save localsymtable for inline procedures or when local
browser info is requested, this has no influence on the crc }
if (proccalloption=pocall_inline) or
if (po_has_inlininginfo in procoptions) or
((current_module.flags and uf_local_browser)<>0) then
begin
{ we must write a localsymtable }
@ -3800,9 +3795,8 @@ implementation
{ node tree for inlining }
oldintfcrc:=ppufile.do_crc;
ppufile.do_crc:=false;
if proccalloption=pocall_inline then
if (po_has_inlininginfo in procoptions) then
ppuwritenodetree(ppufile,inlininginfo^.code);
ppufile.do_crc:=oldintfcrc;
aktparasymtable:=oldparasymtable;
@ -4155,7 +4149,7 @@ implementation
{ Locals }
if assigned(localst) and
((proccalloption=pocall_inline) or
((po_has_inlininginfo in procoptions) or
((current_module.flags and uf_local_browser)<>0)) then
begin
tlocalsymtable(localst).buildderef;
@ -4163,7 +4157,7 @@ implementation
end;
{ inline tree }
if (proccalloption=pocall_inline) then
if (po_has_inlininginfo in procoptions) then
begin
funcretsymderef.build(funcretsym);
inlininginfo^.code.buildderefimpl;
@ -4221,7 +4215,7 @@ implementation
end;
{ Inline }
if (proccalloption=pocall_inline) then
if (po_has_inlininginfo in procoptions) then
begin
inlininginfo^.code.derefimpl;
{ funcretsym, this is always located in the localst }
@ -6129,7 +6123,13 @@ implementation
end.
{
$Log$
Revision 1.281 2004-12-03 15:57:39 peter
Revision 1.282 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.281 2004/12/03 15:57:39 peter
* int64 can also be put in a register
Revision 1.280 2004/11/30 18:13:39 jonas

12
compiler/systems/t_win32.pas
View File

@ -244,9 +244,9 @@ implementation
procedure timportlibwin32.generatesmartlib;
var
hp1 : timportlist;
mangledstring : string;
{$ifdef GDB}
importname : string;
mangledstring : string;
suffix : integer;
{$endif GDB}
hp2 : twin32imported_item;
@ -395,9 +395,9 @@ implementation
hp1 : timportlist;
hp2 : twin32imported_item;
l1,l2,l3,l4 : tasmlabel;
mangledstring : string;
{$ifdef GDB}
importname : string;
mangledstring : string;
suffix : integer;
{$endif GDB}
href : treference;
@ -1623,7 +1623,13 @@ initialization
end.
{
$Log$
Revision 1.45 2004-11-18 10:06:19 michael
Revision 1.46 2004-12-05 12:28:11 peter
* procvar handling for tp procvar mode fixed
* proc to procvar moved from addrnode to typeconvnode
* inlininginfo is now allocated only for inline routines that
can be inlined, introduced a new flag po_has_inlining_info
Revision 1.45 2004/11/18 10:06:19 michael
+ Fix for win32 cycle
Revision 1.44 2004/11/17 22:22:12 peter