mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-05 19:27:58 +02:00
1656 lines
59 KiB
ObjectPascal
1656 lines
59 KiB
ObjectPascal
{
|
|
Copyright (c) 2000-2002 by Florian Klaempfl
|
|
|
|
Type checking and register allocation for load/assignment nodes
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit nld;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
node,
|
|
{$ifdef state_tracking}
|
|
nstate,
|
|
{$endif}
|
|
symconst,symbase,symtype,symsym,symdef;
|
|
|
|
type
|
|
Trttidatatype = (rdt_normal,rdt_ord2str,rdt_str2ord);
|
|
|
|
tloadnodeflags = (
|
|
loadnf_is_self,
|
|
{ tell the load node the address of the symbol into the location, i.e. location^ must
|
|
be used to access the symbol
|
|
this is for example needed to load self for objects }
|
|
loadnf_load_addr,
|
|
loadnf_inherited,
|
|
{ the loadnode is generated internally and a varspez=vs_const should be ignore,
|
|
this requires that the parameter is actually passed by value
|
|
Be really carefull when using this flag! }
|
|
loadnf_isinternal_ignoreconst,
|
|
|
|
loadnf_only_uninitialized_hint
|
|
);
|
|
|
|
tloadnode = class(tunarynode)
|
|
protected
|
|
fprocdef : tprocdef;
|
|
fprocdefderef : tderef;
|
|
function handle_threadvar_access: tnode; virtual;
|
|
public
|
|
loadnodeflags : set of tloadnodeflags;
|
|
symtableentry : tsym;
|
|
symtableentryderef : tderef;
|
|
symtable : TSymtable;
|
|
constructor create(v : tsym;st : TSymtable);virtual;
|
|
constructor create_procvar(v : tsym;d:tprocdef;st : TSymtable);virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
procedure buildderefimpl;override;
|
|
procedure derefimpl;override;
|
|
procedure set_mp(p:tnode);
|
|
function is_addr_param_load:boolean;virtual;
|
|
function dogetcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
procedure mark_write;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
procedure printnodedata(var t:text);override;
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure XMLPrintNodeData(var T: Text); override;
|
|
{$endif DEBUG_NODE_XML}
|
|
procedure setprocdef(p : tprocdef;forfuncref:boolean);
|
|
property procdef: tprocdef read fprocdef;
|
|
end;
|
|
tloadnodeclass = class of tloadnode;
|
|
|
|
{ different assignment types }
|
|
tassigntype = (at_normal,at_plus,at_minus,at_star,at_slash);
|
|
|
|
TAssignmentNodeFlag = (
|
|
anf_assign_done_in_right
|
|
);
|
|
|
|
TAssignmentNodeFlags = set of TAssignmentNodeFlag;
|
|
|
|
tassignmentnode = class(tbinarynode)
|
|
protected
|
|
function direct_shortstring_assignment: boolean; virtual;
|
|
public
|
|
assignmentnodeflags : TAssignmentNodeFlags;
|
|
assigntype : tassigntype;
|
|
constructor create(l,r : tnode);virtual;
|
|
{ no checks for validity of assignment }
|
|
constructor create_internal(l,r : tnode);virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
function dogetcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
function simplify(forinline : boolean) : tnode;override;
|
|
{$ifdef state_tracking}
|
|
function track_state_pass(exec_known:boolean):boolean;override;
|
|
{$endif state_tracking}
|
|
function docompare(p: tnode): boolean; override;
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure XMLPrintNodeInfo(var T: Text); override;
|
|
procedure XMLPrintNodeData(var T: Text); override;
|
|
{$endif DEBUG_NODE_XML}
|
|
end;
|
|
tassignmentnodeclass = class of tassignmentnode;
|
|
|
|
tarrayconstructorrangenode = class(tbinarynode)
|
|
constructor create(l,r : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
end;
|
|
tarrayconstructorrangenodeclass = class of tarrayconstructorrangenode;
|
|
|
|
TArrayConstructorNodeFlag = (
|
|
acnf_allow_array_constructor,
|
|
acnf_forcevaria,
|
|
acnf_novariaallowed
|
|
);
|
|
|
|
TArrayConstructorNodeFlags = set of TArrayConstructorNodeFlag;
|
|
|
|
tarrayconstructornode = class(tbinarynode)
|
|
arrayconstructornodeflags : TArrayConstructorNodeFlags;
|
|
private
|
|
function has_range_node:boolean;
|
|
protected
|
|
procedure wrapmanagedvarrec(var n : tnode);virtual;abstract;
|
|
public
|
|
constructor create(l,r : tnode);virtual;
|
|
constructor ppuload(t : tnodetype;ppufile : tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile : tcompilerppufile);override;
|
|
function dogetcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
procedure force_type(def:tdef);
|
|
procedure insert_typeconvs;
|
|
function isempty : boolean;
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure XMLPrintNodeInfo(var t : text);override;
|
|
{$endif DEBUG_NODE_XML}
|
|
end;
|
|
tarrayconstructornodeclass = class of tarrayconstructornode;
|
|
|
|
ttypenode = class(tnode)
|
|
allowed : boolean;
|
|
helperallowed : boolean;
|
|
typedef : tdef;
|
|
typedefderef : tderef;
|
|
typesym : tsym;
|
|
typesymderef : tderef;
|
|
constructor create(def:tdef);virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
procedure buildderefimpl;override;
|
|
procedure derefimpl;override;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
function dogetcopy : tnode;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
end;
|
|
ttypenodeclass = class of ttypenode;
|
|
|
|
trttinode = class(tnode)
|
|
l1,l2 : longint;
|
|
rttitype : trttitype;
|
|
rttidef : tstoreddef;
|
|
rttidefderef : tderef;
|
|
rttidatatype : Trttidatatype;
|
|
constructor create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
procedure buildderefimpl;override;
|
|
procedure derefimpl;override;
|
|
function dogetcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
end;
|
|
trttinodeclass = class of trttinode;
|
|
|
|
var
|
|
cloadnode : tloadnodeclass = tloadnode;
|
|
cassignmentnode : tassignmentnodeclass = tassignmentnode;
|
|
carrayconstructorrangenode : tarrayconstructorrangenodeclass = tarrayconstructorrangenode;
|
|
carrayconstructornode : tarrayconstructornodeclass = tarrayconstructornode;
|
|
ctypenode : ttypenodeclass = ttypenode;
|
|
crttinode : trttinodeclass = trttinode;
|
|
|
|
{ Current assignment node }
|
|
aktassignmentnode : tassignmentnode;
|
|
|
|
{ Create a node tree to load a variable if symbol is assigned, otherwise an error node.
|
|
Generates an internalerror if called for an absolutevarsym of the "tovar" kind (those
|
|
are only supported for expansion in the parser) }
|
|
function gen_load_var(sym: tabstractvarsym): tnode;
|
|
|
|
implementation
|
|
|
|
uses
|
|
verbose,globtype,globals,systems,constexp,compinnr,
|
|
ppu,
|
|
symtable,
|
|
defutil,defcmp,
|
|
cpuinfo,
|
|
htypechk,pass_1,procinfo,paramgr,
|
|
nbas,ncon,nflw,ninl,ncnv,nmem,ncal,nutils,
|
|
cgbase,
|
|
optloadmodifystore,wpobase
|
|
;
|
|
|
|
|
|
function gen_load_var(sym: tabstractvarsym): tnode;
|
|
begin
|
|
result:=nil;
|
|
if assigned(sym) then
|
|
begin
|
|
if (sym.typ<>absolutevarsym) or
|
|
(tabsolutevarsym(sym).abstyp<>tovar) then
|
|
begin
|
|
result:=cloadnode.create(sym,sym.owner);
|
|
end
|
|
else
|
|
internalerror(2020122601);
|
|
end
|
|
else
|
|
begin
|
|
result:=cerrornode.create;
|
|
CGMessage(parser_e_illegal_expression);
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TLOADNODE
|
|
*****************************************************************************}
|
|
|
|
function tloadnode.handle_threadvar_access: tnode;
|
|
begin
|
|
{ nothing special by default }
|
|
result:=nil;
|
|
end;
|
|
|
|
|
|
constructor tloadnode.create(v : tsym;st : TSymtable);
|
|
begin
|
|
inherited create(loadn,nil);
|
|
if not assigned(v) then
|
|
internalerror(200108121);
|
|
symtableentry:=v;
|
|
symtable:=st;
|
|
fprocdef:=nil;
|
|
end;
|
|
|
|
|
|
constructor tloadnode.create_procvar(v : tsym;d:tprocdef;st : TSymtable);
|
|
begin
|
|
inherited create(loadn,nil);
|
|
if not assigned(v) then
|
|
internalerror(200108122);
|
|
symtableentry:=v;
|
|
symtable:=st;
|
|
fprocdef:=d;
|
|
end;
|
|
|
|
|
|
constructor tloadnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.getderef(symtableentryderef);
|
|
symtable:=nil;
|
|
ppufile.getderef(fprocdefderef);
|
|
ppufile.getset(tppuset1(loadnodeflags));
|
|
end;
|
|
|
|
|
|
procedure tloadnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(symtableentryderef);
|
|
ppufile.putderef(fprocdefderef);
|
|
ppufile.putset(tppuset1(loadnodeflags));
|
|
end;
|
|
|
|
|
|
procedure tloadnode.buildderefimpl;
|
|
begin
|
|
inherited buildderefimpl;
|
|
symtableentryderef.build(symtableentry);
|
|
fprocdefderef.build(fprocdef);
|
|
end;
|
|
|
|
|
|
procedure tloadnode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
symtableentry:=tsym(symtableentryderef.resolve);
|
|
symtable:=symtableentry.owner;
|
|
fprocdef:=tprocdef(fprocdefderef.resolve);
|
|
end;
|
|
|
|
|
|
procedure tloadnode.set_mp(p:tnode);
|
|
begin
|
|
{ typen nodes should not be set }
|
|
if p.nodetype=typen then
|
|
internalerror(200301042);
|
|
left:=p;
|
|
end;
|
|
|
|
|
|
function tloadnode.dogetcopy : tnode;
|
|
var
|
|
n : tloadnode;
|
|
orglabel,
|
|
labelcopy : tlabelnode;
|
|
begin
|
|
n:=tloadnode(inherited dogetcopy);
|
|
n.symtable:=symtable;
|
|
n.symtableentry:=symtableentry;
|
|
n.fprocdef:=fprocdef;
|
|
n.loadnodeflags:=loadnodeflags;
|
|
if symtableentry.typ=labelsym then
|
|
begin
|
|
{ see the comments for the tgotonode.labelsym field }
|
|
orglabel:=tlabelnode(tlabelsym(symtableentry).code);
|
|
labelcopy:=tlabelnode(orglabel.dogetcopy);
|
|
if not assigned(labelcopy.labsym) then
|
|
begin
|
|
if not assigned(orglabel.labsym) then
|
|
internalerror(2019091301);
|
|
labelcopy.labsym:=clabelsym.create('$copiedlabelfrom$'+orglabel.labsym.RealName);
|
|
labelcopy.labsym.code:=labelcopy;
|
|
end;
|
|
n.symtableentry:=labelcopy.labsym;
|
|
end;
|
|
result:=n;
|
|
end;
|
|
|
|
|
|
function tloadnode.is_addr_param_load:boolean;
|
|
begin
|
|
result:=(symtable.symtabletype=parasymtable) and
|
|
(symtableentry.typ=paravarsym) and
|
|
not(vo_has_local_copy in tparavarsym(symtableentry).varoptions) and
|
|
not(loadnf_load_addr in loadnodeflags) and
|
|
paramanager.push_addr_param(tparavarsym(symtableentry).varspez,tparavarsym(symtableentry).vardef,tprocdef(symtable.defowner).proccalloption);
|
|
end;
|
|
|
|
|
|
function tloadnode.pass_typecheck:tnode;
|
|
begin
|
|
result:=nil;
|
|
case symtableentry.typ of
|
|
absolutevarsym :
|
|
resultdef:=tabsolutevarsym(symtableentry).vardef;
|
|
constsym:
|
|
begin
|
|
if tconstsym(symtableentry).consttyp=constresourcestring then
|
|
resultdef:=getansistringdef
|
|
else if tconstsym(symtableentry).consttyp=constwresourcestring then
|
|
resultdef:=cunicodestringtype
|
|
else
|
|
internalerror(22799);
|
|
end;
|
|
staticvarsym :
|
|
begin
|
|
tabstractvarsym(symtableentry).IncRefCountBy(1);
|
|
{ static variables referenced in procedures or from finalization,
|
|
variable needs to be in memory.
|
|
It is too hard and the benefit is too small to detect whether a
|
|
variable is only used in the finalization to add support for it (PFV) }
|
|
if assigned(current_procinfo) and
|
|
(symtable.symtabletype=staticsymtable) and
|
|
(
|
|
(symtable.symtablelevel<>current_procinfo.procdef.localst.symtablelevel) or
|
|
(current_procinfo.procdef.proctypeoption=potype_unitfinalize)
|
|
) then
|
|
make_not_regable(self,[ra_different_scope]);
|
|
resultdef:=tabstractvarsym(symtableentry).vardef;
|
|
if vo_is_thread_var in tstaticvarsym(symtableentry).varoptions then
|
|
result:=handle_threadvar_access;
|
|
end;
|
|
paravarsym,
|
|
localvarsym :
|
|
begin
|
|
tabstractvarsym(symtableentry).IncRefCountBy(1);
|
|
resultdef:=tabstractvarsym(symtableentry).vardef;
|
|
{ Nested variable? The we need to load the framepointer of
|
|
the parent procedure }
|
|
if assigned(current_procinfo) and
|
|
(symtable.symtabletype in [localsymtable,parasymtable]) and
|
|
(symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) then
|
|
begin
|
|
if assigned(left) then
|
|
internalerror(200309289);
|
|
left:=cloadparentfpnode.create(tprocdef(symtable.defowner),lpf_forload);
|
|
current_procinfo.set_needs_parentfp(tprocdef(symtable.defowner).parast.symtablelevel);
|
|
{ reference this as a captured symbol }
|
|
current_procinfo.add_captured_sym(symtableentry,resultdef,fileinfo);
|
|
{ reference in nested procedures, variable needs to be in memory }
|
|
{ and behaves as if its address escapes its parent block }
|
|
make_not_regable(self,[ra_different_scope]);
|
|
end
|
|
{ if this is a nested function and it uses the Self parameter then
|
|
consider this as captured as well (needed for anonymous functions) }
|
|
else if assigned(current_procinfo) and
|
|
(vo_is_self in tabstractvarsym(symtableentry).varoptions) and
|
|
(symtable.symtablelevel>normal_function_level) then
|
|
current_procinfo.add_captured_sym(symtableentry,resultdef,fileinfo);
|
|
|
|
{ e.g. self for objects is passed as var-parameter on the caller
|
|
side, but on the callee-side we use it as a pointer ->
|
|
adjust }
|
|
if (loadnf_load_addr in loadnodeflags) then
|
|
resultdef:=cpointerdef.getreusable(resultdef);
|
|
|
|
if (vo_is_self in tabstractvarsym(symtableentry).varoptions) and (resultdef=objc_idtype) and
|
|
(po_classmethod in tprocdef(symtableentry.owner.defowner).procoptions) then
|
|
resultdef:=cclassrefdef.create(tprocdef(symtableentry.owner.defowner).struct)
|
|
end;
|
|
procsym :
|
|
begin
|
|
{ Return the first procdef. In case of overloaded
|
|
procdefs the matching procdef will be choosen
|
|
when the expected procvardef is known, see get_information
|
|
in htypechk.pas (PFV) }
|
|
if not assigned(fprocdef) then
|
|
fprocdef:=tprocdef(tprocsym(symtableentry).ProcdefList[0])
|
|
else if po_kylixlocal in fprocdef.procoptions then
|
|
CGMessage(type_e_cant_take_address_of_local_subroutine);
|
|
|
|
{ the result is a fprocdef, addrn and proc_to_procvar
|
|
typeconvn need this as resultdef so they know
|
|
that the address needs to be returned }
|
|
resultdef:=fprocdef;
|
|
|
|
if is_nested_pd(fprocdef) and is_nested_pd(current_procinfo.procdef) then
|
|
current_procinfo.set_needs_parentfp(tprocdef(fprocdef.owner.defowner).parast.symtablelevel);
|
|
|
|
{ process methodpointer/framepointer }
|
|
if assigned(left) then
|
|
begin
|
|
typecheckpass(left);
|
|
if (po_classmethod in fprocdef.procoptions) and
|
|
is_class(left.resultdef) and
|
|
(left.nodetype<>niln) then
|
|
begin
|
|
left:=cloadvmtaddrnode.create(left);
|
|
typecheckpass(left);
|
|
end
|
|
end;
|
|
|
|
{ we can't know what will happen with this function pointer, so
|
|
we have to assume it will be used to create an instance of this
|
|
type }
|
|
if fprocdef.wpo_may_create_instance(left) then
|
|
begin
|
|
if wpoinfomanager.symbol_live_in_currentproc(tdef(symtable.defowner)) then
|
|
begin
|
|
if assigned(left) then
|
|
tobjectdef(left.resultdef).register_created_object_type
|
|
else
|
|
tobjectdef(fprocdef.owner.defowner).register_created_object_type;
|
|
end;
|
|
end;
|
|
end;
|
|
labelsym:
|
|
begin
|
|
tlabelsym(symtableentry).used:=true;
|
|
resultdef:=voidtype;
|
|
end;
|
|
else
|
|
internalerror(200104141);
|
|
end;
|
|
end;
|
|
|
|
procedure Tloadnode.mark_write;
|
|
|
|
begin
|
|
include(flags,nf_write);
|
|
end;
|
|
|
|
function tloadnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
expectloc:=LOC_REFERENCE;
|
|
|
|
case symtableentry.typ of
|
|
absolutevarsym :
|
|
;
|
|
constsym:
|
|
begin
|
|
if tconstsym(symtableentry).consttyp in [constresourcestring,constwresourcestring] then
|
|
expectloc:=LOC_CREFERENCE;
|
|
end;
|
|
staticvarsym,
|
|
localvarsym,
|
|
paravarsym :
|
|
begin
|
|
if assigned(left) then
|
|
firstpass(left);
|
|
if not is_addr_param_load and
|
|
tabstractvarsym(symtableentry).is_regvar(is_addr_param_load) then
|
|
expectloc:=tvarregable2tcgloc[tabstractvarsym(symtableentry).varregable]
|
|
else
|
|
if (tabstractvarsym(symtableentry).varspez=vs_const) then
|
|
expectloc:=LOC_CREFERENCE;
|
|
{ call to get address of threadvar }
|
|
if (vo_is_thread_var in tabstractvarsym(symtableentry).varoptions) then
|
|
begin
|
|
include(current_procinfo.flags,pi_do_call);
|
|
include(current_procinfo.flags,pi_uses_threadvar);
|
|
end;
|
|
end;
|
|
procsym :
|
|
begin
|
|
{ initialise left for nested procs if necessary (this won't need
|
|
to pass true for the forfuncref parameter, cause code that would
|
|
need that wouldn't have been reworked before it reaches pass_1) }
|
|
if (m_nested_procvars in current_settings.modeswitches) then
|
|
setprocdef(fprocdef,false);
|
|
{ method pointer or nested proc ? }
|
|
if assigned(left) then
|
|
begin
|
|
expectloc:=LOC_CREGISTER;
|
|
firstpass(left);
|
|
end;
|
|
end;
|
|
labelsym :
|
|
begin
|
|
if not assigned(tlabelsym(symtableentry).asmblocklabel) and
|
|
not assigned(tlabelsym(symtableentry).code) then
|
|
Message(parser_e_label_outside_proc);
|
|
end
|
|
else
|
|
internalerror(200104143);
|
|
end;
|
|
end;
|
|
|
|
|
|
function tloadnode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare :=
|
|
inherited docompare(p) and
|
|
(symtableentry = tloadnode(p).symtableentry) and
|
|
(fprocdef = tloadnode(p).fprocdef) and
|
|
(symtable = tloadnode(p).symtable);
|
|
end;
|
|
|
|
|
|
procedure tloadnode.printnodedata(var t:text);
|
|
begin
|
|
inherited printnodedata(t);
|
|
write(t,printnodeindention,'symbol = ',symtableentry.name);
|
|
if symtableentry.typ=procsym then
|
|
write(t,printnodeindention,'procdef = ',fprocdef.mangledname);
|
|
writeln(t,'');
|
|
end;
|
|
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure TLoadNode.XMLPrintNodeData(var T: Text);
|
|
begin
|
|
inherited XMLPrintNodeData(T);
|
|
WriteLn(T, printnodeindention, '<symbol>', symtableentry.name, '</symbol>');
|
|
|
|
if symtableentry.typ = procsym then
|
|
WriteLn(T, printnodeindention, '<procdef>', fprocdef.mangledname, '</procdef>');
|
|
end;
|
|
{$endif DEBUG_NODE_XML}
|
|
|
|
procedure tloadnode.setprocdef(p : tprocdef;forfuncref:boolean);
|
|
begin
|
|
fprocdef:=p;
|
|
resultdef:=p;
|
|
{ nested procedure? }
|
|
if assigned(p) and
|
|
is_nested_pd(p) and
|
|
not forfuncref and
|
|
(
|
|
not (po_anonymous in p.procoptions) or
|
|
(po_delphi_nested_cc in p.procoptions)
|
|
) then
|
|
begin
|
|
if not(m_nested_procvars in current_settings.modeswitches) then
|
|
CGMessage(type_e_cant_take_address_of_local_subroutine)
|
|
else
|
|
begin
|
|
{ parent frame pointer pointer as "self" }
|
|
left.free;
|
|
left:=cloadparentfpnode.create(tprocdef(p.owner.defowner),lpf_forpara);
|
|
typecheckpass(left);
|
|
end;
|
|
end
|
|
{ we should never go from nested to non-nested (except for an anonymous
|
|
function which might have been changed to a global function or a
|
|
method) }
|
|
else if assigned(left) and
|
|
(left.nodetype=loadparentfpn) then
|
|
begin
|
|
if po_anonymous in p.procoptions then
|
|
begin
|
|
left.free;
|
|
left:=nil;
|
|
end
|
|
else
|
|
internalerror(2010072201);
|
|
end;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
TASSIGNMENTNODE
|
|
*****************************************************************************}
|
|
|
|
function tassignmentnode.direct_shortstring_assignment: boolean;
|
|
begin
|
|
result:=
|
|
is_char(right.resultdef) or
|
|
(right.resultdef.typ=stringdef);
|
|
end;
|
|
|
|
|
|
constructor tassignmentnode.create(l,r : tnode);
|
|
|
|
begin
|
|
inherited create(assignn,l,r);
|
|
assignmentnodeflags:=[];
|
|
assigntype:=at_normal;
|
|
if r.nodetype = typeconvn then
|
|
ttypeconvnode(r).warn_pointer_to_signed:=false;
|
|
end;
|
|
|
|
|
|
constructor tassignmentnode.create_internal(l, r: tnode);
|
|
begin
|
|
create(l,r);
|
|
include(flags,nf_internal);
|
|
end;
|
|
|
|
|
|
constructor tassignmentnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.getset(tppuset1(assignmentnodeflags));
|
|
assigntype:=tassigntype(ppufile.getbyte);
|
|
end;
|
|
|
|
|
|
procedure tassignmentnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putset(tppuset1(assignmentnodeflags));
|
|
ppufile.putbyte(byte(assigntype));
|
|
end;
|
|
|
|
|
|
function tassignmentnode.dogetcopy : tnode;
|
|
|
|
var
|
|
n : tassignmentnode;
|
|
|
|
begin
|
|
n:=tassignmentnode(inherited dogetcopy);
|
|
n.assignmentnodeflags:=assignmentnodeflags;
|
|
n.assigntype:=assigntype;
|
|
result:=n;
|
|
end;
|
|
|
|
|
|
function tassignmentnode.simplify(forinline : boolean) : tnode;
|
|
begin
|
|
result:=nil;
|
|
{ assignment nodes can perform several floating point }
|
|
{ type conversions directly, so no typeconversions }
|
|
{ are inserted in those cases. When inlining, a }
|
|
{ variable may be replaced by a constant which can be }
|
|
{ converted at compile time, so check for this case }
|
|
if is_real(left.resultdef) and
|
|
is_real(right.resultdef) and
|
|
is_constrealnode(right) and
|
|
not equal_defs(right.resultdef,left.resultdef) then
|
|
inserttypeconv(right,left.resultdef);
|
|
{$if (cs_opt_use_load_modify_store in supported_optimizerswitches)}
|
|
{ Perform simple optimizations when -O2 and the dedicated
|
|
cs_opt_use_load_modify_store optimization pass is not enabled. }
|
|
if (cs_opt_level2 in current_settings.optimizerswitches) and
|
|
not (cs_opt_use_load_modify_store in current_settings.optimizerswitches) then
|
|
result:=try_opt_assignmentnode(self);
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
function tassignmentnode.pass_typecheck:tnode;
|
|
var
|
|
hp : tnode;
|
|
useshelper : boolean;
|
|
oldassignmentnode : tassignmentnode;
|
|
begin
|
|
result:=nil;
|
|
resultdef:=voidtype;
|
|
|
|
{ must be made unique }
|
|
set_unique(left);
|
|
|
|
typecheckpass(left);
|
|
|
|
left.mark_write;
|
|
|
|
{ PI. This is needed to return correct resultdef of add nodes for ansistrings
|
|
rawbytestring return needs to be replaced by left.resultdef }
|
|
oldassignmentnode:=aktassignmentnode;
|
|
aktassignmentnode:=self;
|
|
typecheckpass(right);
|
|
aktassignmentnode:=oldassignmentnode;
|
|
|
|
set_varstate(right,vs_read,[vsf_must_be_valid]);
|
|
set_varstate(left,vs_written,[]);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ just in case the typecheckpass of right optimized something here }
|
|
if anf_assign_done_in_right in assignmentnodeflags then
|
|
begin
|
|
result:=right;
|
|
right:=nil;
|
|
exit;
|
|
end;
|
|
|
|
{ tp procvar support, when we don't expect a procvar
|
|
then we need to call the procvar }
|
|
if (left.resultdef.typ<>procvardef) and
|
|
not is_invokable(left.resultdef) then
|
|
maybe_call_procvar(right,true);
|
|
|
|
{ assignments to formaldefs and open arrays aren't allowed }
|
|
if is_open_array(left.resultdef) then
|
|
begin
|
|
CGMessage(type_e_assignment_not_allowed);
|
|
result:=cerrornode.create;
|
|
exit;
|
|
end
|
|
else if (left.resultdef.typ=formaldef) then
|
|
if not(target_info.system in systems_managed_vm) then
|
|
CGMessage(type_e_assignment_not_allowed)
|
|
else
|
|
begin
|
|
{ on managed platforms, assigning to formaldefs is allowed (but
|
|
typecasting them on the left hand side isn't), but primitive
|
|
values need to be boxed first }
|
|
if (right.resultdef.typ in [orddef,floatdef]) then
|
|
begin
|
|
right:=cinlinenode.create(in_box_x,false,ccallparanode.create(right,nil));
|
|
typecheckpass(right);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ test if node can be assigned, properties are allowed }
|
|
if not(nf_internal in flags) then
|
|
if not valid_for_assignment(left,true) then
|
|
{ errors can in situations that cause the compiler to run out of
|
|
memory, such as assigning to an implicit pointer-to-array
|
|
converted node (that array is 2^31 or 2^63 bytes large) }
|
|
exit;
|
|
|
|
{ assigning nil or [] to a dynamic array clears the array }
|
|
if is_dynamic_array(left.resultdef) and
|
|
(
|
|
(right.nodetype=niln) or
|
|
(
|
|
(right.nodetype=arrayconstructorn) and
|
|
(right.resultdef.typ=arraydef) and
|
|
(tarraydef(right.resultdef).elementdef=voidtype) and
|
|
tarrayconstructornode(right).isempty
|
|
)
|
|
) then
|
|
begin
|
|
{ remove property flag to avoid errors, see comments for }
|
|
{ tf_winlikewidestring assignments below }
|
|
exclude(left.flags,nf_isproperty);
|
|
{ generate a setlength node so it can be intercepted by
|
|
target-specific code }
|
|
result:=cinlinenode.create(in_setlength_x,false,
|
|
ccallparanode.create(genintconstnode(0),
|
|
ccallparanode.create(left,nil)));
|
|
left:=nil;
|
|
exit;
|
|
end;
|
|
|
|
{ shortstring helpers can do the conversion directly,
|
|
so treat them separatly }
|
|
if (is_shortstring(left.resultdef)) then
|
|
begin
|
|
{ insert typeconv, except for chars that are handled in
|
|
secondpass and except for ansi/wide string that can
|
|
be converted immediatly }
|
|
if not direct_shortstring_assignment then
|
|
inserttypeconv(right,left.resultdef);
|
|
if right.resultdef.typ=stringdef then
|
|
begin
|
|
useshelper:=true;
|
|
{ convert constant strings to shortstrings. But
|
|
skip empty constant strings, that will be handled
|
|
in secondpass }
|
|
if (right.nodetype=stringconstn) then
|
|
begin
|
|
{ verify if range fits within shortstring }
|
|
{ just emit a warning, delphi gives an }
|
|
{ error, only if the type definition of }
|
|
{ of the string is less < 255 characters }
|
|
if not is_open_string(left.resultdef) and
|
|
(tstringconstnode(right).len > tstringdef(left.resultdef).len) then
|
|
cgmessage(type_w_string_too_long);
|
|
inserttypeconv(right,left.resultdef);
|
|
if (right.nodetype=stringconstn) and
|
|
(tstringconstnode(right).len=0) then
|
|
useshelper:=false;
|
|
end
|
|
else if (tstringdef(right.resultdef).stringtype in [st_unicodestring,st_widestring]) then
|
|
Message2(type_w_implicit_string_cast_loss,right.resultdef.typename,left.resultdef.typename);
|
|
{ rest is done in pass 1 (JM) }
|
|
if useshelper then
|
|
exit;
|
|
end
|
|
end
|
|
{ floating point assignments can also perform the conversion directly }
|
|
else if is_real(left.resultdef) and is_real(right.resultdef) and
|
|
not is_constrealnode(right)
|
|
{$ifdef cpufpemu}
|
|
{ the emulator can't do this obviously }
|
|
and not(current_settings.fputype in [fpu_libgcc,fpu_soft])
|
|
{$endif cpufpemu}
|
|
|
|
{$ifdef x86}
|
|
{ the assignment node code can't convert a double in an }
|
|
{ sse register to an extended value in memory more }
|
|
{ efficiently than a type conversion node, so don't }
|
|
{ bother implementing support for that }
|
|
and (use_vectorfpu(left.resultdef) or not(use_vectorfpu(right.resultdef)))
|
|
{$endif}
|
|
|
|
{$ifdef arm}
|
|
{ the assignment node code can't convert a single in
|
|
an interger register to a double in an mmregister or
|
|
vice versa }
|
|
and (use_vectorfpu(left.resultdef) and
|
|
use_vectorfpu(right.resultdef) and
|
|
(tfloatdef(left.resultdef).floattype=tfloatdef(right.resultdef).floattype))
|
|
{$endif arm}
|
|
{$ifdef xtensa}
|
|
and not((FPUXTENSA_SINGLE in fpu_capabilities[current_settings.fputype]) xor
|
|
(FPUXTENSA_DOUBLE in fpu_capabilities[current_settings.fputype]))
|
|
{$endif}
|
|
then
|
|
begin
|
|
if not(nf_internal in flags) then
|
|
check_ranges(fileinfo,right,left.resultdef);
|
|
end
|
|
else
|
|
begin
|
|
{ check if the assignment may cause a range check error }
|
|
if not(nf_internal in flags) then
|
|
check_ranges(fileinfo,right,left.resultdef);
|
|
|
|
{ beginners might be confused about an error message like
|
|
Incompatible types: got "untyped" expected "LongInt"
|
|
when trying to assign the result of a procedure, so give
|
|
a better error message, see also #19122 }
|
|
if (left.resultdef.typ<>procvardef) and
|
|
not is_invokable(left.resultdef) and
|
|
(right.nodetype=calln) and is_void(right.resultdef) then
|
|
CGMessage(type_e_procedures_return_no_value)
|
|
else if nf_internal in flags then
|
|
inserttypeconv_internal(right,left.resultdef)
|
|
else
|
|
inserttypeconv(right,left.resultdef);
|
|
end;
|
|
|
|
{ call helpers for interface }
|
|
if is_interfacecom_or_dispinterface(left.resultdef) then
|
|
begin
|
|
{ Normal interface assignments are handled by the generic refcount incr/decr }
|
|
if not def_is_related(right.resultdef,left.resultdef) then
|
|
begin
|
|
{ remove property flag to avoid errors, see comments for }
|
|
{ tf_winlikewidestring assignments below }
|
|
exclude(left.flags,nf_isproperty);
|
|
hp:=
|
|
ccallparanode.create(
|
|
cguidconstnode.create(tobjectdef(left.resultdef).iidguid^),
|
|
ccallparanode.create(
|
|
ctypeconvnode.create_internal(right,voidpointertype),
|
|
ccallparanode.create(
|
|
ctypeconvnode.create_internal(left,voidpointertype),
|
|
nil)));
|
|
result:=ccallnode.createintern('fpc_intf_assign_by_iid',hp);
|
|
left:=nil;
|
|
right:=nil;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
{ check if local proc/func is assigned to procvar }
|
|
if right.resultdef.typ=procvardef then
|
|
test_local_to_procvar(tprocvardef(right.resultdef),left.resultdef);
|
|
end;
|
|
|
|
|
|
function tassignmentnode.pass_1 : tnode;
|
|
|
|
function tempreturnfromcall:boolean;
|
|
var
|
|
node:tnode;
|
|
begin
|
|
result:=false;
|
|
if not is_managed_type(right.resultdef) then
|
|
exit;
|
|
node:=right;
|
|
while assigned(node) do
|
|
begin
|
|
case node.nodetype of
|
|
blockn:
|
|
node:=tblocknode(node).left;
|
|
statementn:
|
|
if assigned(tstatementnode(node).right) then
|
|
node:=tstatementnode(node).right
|
|
else
|
|
node:=tstatementnode(node).left;
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
if not assigned(node) then
|
|
internalerror(2024111101);
|
|
if (node.nodetype=calln) and assigned(tcallnode(node).funcretnode) then
|
|
node:=tcallnode(node).funcretnode;
|
|
result:=(node.nodetype=temprefn) and (nf_is_funcret in node.flags);
|
|
end;
|
|
|
|
var
|
|
hp: tnode;
|
|
oldassignmentnode : tassignmentnode;
|
|
hdef: tdef;
|
|
hs: string;
|
|
needrtti: boolean;
|
|
begin
|
|
result:=nil;
|
|
expectloc:=LOC_VOID;
|
|
|
|
firstpass(left);
|
|
|
|
{ Optimize the reuse of the destination of the assingment in left.
|
|
Allow the use of the left inside the tree generated on the right.
|
|
This is especially useful for string routines where the destination
|
|
is pushed as a parameter. Using the final destination of left directly
|
|
save a temp allocation and copy of data (PFV) }
|
|
oldassignmentnode:=aktassignmentnode;
|
|
aktassignmentnode:=self;
|
|
firstpass(right);
|
|
aktassignmentnode:=oldassignmentnode;
|
|
if anf_assign_done_in_right in assignmentnodeflags then
|
|
begin
|
|
result:=right;
|
|
right:=nil;
|
|
exit;
|
|
end;
|
|
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ assignment to refcounted variable -> inc/decref }
|
|
if is_managed_type(left.resultdef) then
|
|
include(current_procinfo.flags,pi_do_call);
|
|
|
|
needrtti:=false;
|
|
|
|
if (is_shortstring(left.resultdef)) then
|
|
begin
|
|
if right.resultdef.typ=stringdef then
|
|
begin
|
|
if (right.nodetype<>stringconstn) or
|
|
(tstringconstnode(right).len<>0) then
|
|
begin
|
|
{ remove property flag to avoid errors, see comments for }
|
|
{ tf_winlikewidestring assignments below }
|
|
exclude(left.flags, nf_isproperty);
|
|
hp:=ccallparanode.create
|
|
(right,
|
|
ccallparanode.create(left,nil));
|
|
result:=ccallnode.createintern('fpc_'+tstringdef(right.resultdef).stringtypname+'_to_shortstr',hp);
|
|
firstpass(result);
|
|
left:=nil;
|
|
right:=nil;
|
|
end;
|
|
end;
|
|
exit;
|
|
end
|
|
{ call helpers for composite types containing automated types }
|
|
else if is_managed_type(left.resultdef) and
|
|
(left.resultdef.typ in [arraydef,objectdef,recorddef]) and
|
|
not is_interfacecom_or_dispinterface(left.resultdef) and
|
|
not is_dynamic_array(left.resultdef) and
|
|
not is_const(left) and
|
|
not(target_info.system in systems_garbage_collected_managed_types) then
|
|
begin
|
|
hp:=ccallparanode.create(caddrnode.create_internal(
|
|
crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
|
|
ccallparanode.create(ctypeconvnode.create_internal(
|
|
caddrnode.create_internal(left),voidpointertype),
|
|
ccallparanode.create(ctypeconvnode.create_internal(
|
|
caddrnode.create_internal(right),voidpointertype),
|
|
nil)));
|
|
if tempreturnfromcall then
|
|
result:=ccallnode.createintern('fpc_copy_with_move_semantics_proc',hp)
|
|
else
|
|
result:=ccallnode.createintern('fpc_copy_proc',hp);
|
|
firstpass(result);
|
|
left:=nil;
|
|
right:=nil;
|
|
exit;
|
|
end
|
|
{ call helpers for variant, they can contain non ref. counted types like
|
|
vararrays which must be really copied }
|
|
else if (left.resultdef.typ=variantdef) and
|
|
not(is_const(left)) and
|
|
not(target_info.system in systems_garbage_collected_managed_types) then
|
|
begin
|
|
{ remove property flag to avoid errors, see comments for }
|
|
{ tf_winlikewidestring assignments below }
|
|
exclude(left.flags,nf_isproperty);
|
|
hdef:=search_system_type('TVARDATA').typedef;
|
|
hp:=ccallparanode.create(ctypeconvnode.create_internal(
|
|
right,hdef),
|
|
ccallparanode.create(ctypeconvnode.create_internal(
|
|
left,hdef),
|
|
nil));
|
|
result:=ccallnode.createintern('fpc_variant_copy',hp);
|
|
firstpass(result);
|
|
left:=nil;
|
|
right:=nil;
|
|
exit;
|
|
end
|
|
else if not(target_info.system in systems_garbage_collected_managed_types) and
|
|
not(is_const(left)) then
|
|
begin
|
|
{ call helpers for pointer-sized managed types }
|
|
if is_widestring(left.resultdef) then
|
|
hs:='fpc_widestr_assign'
|
|
else if is_ansistring(left.resultdef) then
|
|
hs:='fpc_ansistr_assign'
|
|
else if is_unicodestring(left.resultdef) then
|
|
hs:='fpc_unicodestr_assign'
|
|
else if is_interfacecom_or_dispinterface(left.resultdef) then
|
|
hs:='fpc_intf_assign'
|
|
else if is_dynamic_array(left.resultdef) then
|
|
begin
|
|
hs:='fpc_dynarray_assign';
|
|
needrtti:=true;
|
|
end
|
|
else
|
|
exit;
|
|
end
|
|
else
|
|
exit;
|
|
|
|
{ The first argument of these procedures is a var parameter. Properties cannot }
|
|
{ be passed to var or out parameters, because in that case setters/getters are not }
|
|
{ used. Further, if we would allow it in case there are no getters or setters, you }
|
|
{ would need source changes in case these are introduced later on, thus defeating }
|
|
{ part of the transparency advantages of properties. In this particular case, }
|
|
{ however: }
|
|
{ a) if there is a setter, this code will not be used since then the assignment }
|
|
{ will be converted to a procedure call }
|
|
{ b) the getter is irrelevant, because fpc_widestr_assign must always decrease }
|
|
{ the refcount of the field to which we are writing }
|
|
{ c) source code changes are not required if a setter is added/removed, because }
|
|
{ this transformation is handled at compile time }
|
|
{ -> we can remove the nf_isproperty flag (if any) from left, so that in case it }
|
|
{ is a property which refers to a field without a setter call, we will not get }
|
|
{ an error about trying to pass a property as a var parameter }
|
|
exclude(left.flags,nf_isproperty);
|
|
hp:=ccallparanode.create(ctypeconvnode.create_internal(right,voidpointertype),
|
|
ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),
|
|
nil));
|
|
if needrtti then
|
|
hp:=ccallparanode.create(
|
|
caddrnode.create_internal(
|
|
crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
|
|
hp);
|
|
result:=ccallnode.createintern(hs,hp);
|
|
firstpass(result);
|
|
left:=nil;
|
|
right:=nil;
|
|
end;
|
|
|
|
|
|
function tassignmentnode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare :=
|
|
inherited docompare(p) and
|
|
(assigntype = tassignmentnode(p).assigntype);
|
|
end;
|
|
|
|
{$ifdef state_tracking}
|
|
function Tassignmentnode.track_state_pass(exec_known:boolean):boolean;
|
|
|
|
var se:Tstate_entry;
|
|
|
|
begin
|
|
track_state_pass:=false;
|
|
if exec_known then
|
|
begin
|
|
track_state_pass:=right.track_state_pass(exec_known);
|
|
{Force a new resultdef pass.}
|
|
right.resultdef:=nil;
|
|
do_typecheckpass(right);
|
|
typecheckpass(right);
|
|
aktstate.store_fact(left.getcopy,right.getcopy);
|
|
end
|
|
else
|
|
aktstate.delete_fact(left);
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure TAssignmentNode.XMLPrintNodeInfo(var T: Text);
|
|
var
|
|
i: TAssignmentNodeFlag;
|
|
First: Boolean;
|
|
begin
|
|
inherited XMLPrintNodeInfo(T);
|
|
First := True;
|
|
for i in assignmentnodeflags do
|
|
begin
|
|
if First then
|
|
begin
|
|
Write(T, ' assignmentnodeflags="', i);
|
|
First := False;
|
|
end
|
|
else
|
|
Write(T, ',', i)
|
|
end;
|
|
if not First then
|
|
Write(T, '"');
|
|
end;
|
|
|
|
|
|
procedure TAssignmentNode.XMLPrintNodeData(var T: Text);
|
|
begin
|
|
{ For assignments, put the left and right branches on the same level for clarity }
|
|
XMLPrintNode(T, Left);
|
|
XMLPrintNode(T, Right);
|
|
PrintNodeUnindent;
|
|
WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
|
|
end;
|
|
{$endif DEBUG_NODE_XML}
|
|
|
|
|
|
{*****************************************************************************
|
|
TARRAYCONSTRUCTORRANGENODE
|
|
*****************************************************************************}
|
|
|
|
constructor tarrayconstructorrangenode.create(l,r : tnode);
|
|
|
|
begin
|
|
inherited create(arrayconstructorrangen,l,r);
|
|
end;
|
|
|
|
function tarrayconstructorrangenode.pass_typecheck:tnode;
|
|
begin
|
|
result:=nil;
|
|
typecheckpass(left);
|
|
typecheckpass(right);
|
|
set_varstate(left,vs_read,[vsf_must_be_valid]);
|
|
set_varstate(right,vs_read,[vsf_must_be_valid]);
|
|
if codegenerror then
|
|
exit;
|
|
resultdef:=left.resultdef;
|
|
end;
|
|
|
|
|
|
function tarrayconstructorrangenode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
CGMessage(parser_e_illegal_expression);
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
TARRAYCONSTRUCTORNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tarrayconstructornode.create(l,r : tnode);
|
|
begin
|
|
inherited create(arrayconstructorn,l,r);
|
|
arrayconstructornodeflags:=[];
|
|
end;
|
|
|
|
|
|
constructor tarrayconstructornode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.getset(tppuset1(arrayconstructornodeflags));
|
|
end;
|
|
|
|
|
|
procedure tarrayconstructornode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putset(tppuset1(arrayconstructornodeflags));
|
|
end;
|
|
|
|
|
|
function tarrayconstructornode.dogetcopy : tnode;
|
|
var
|
|
n : tarrayconstructornode;
|
|
begin
|
|
n:=tarrayconstructornode(inherited dogetcopy);
|
|
n.arrayconstructornodeflags:=arrayconstructornodeflags;
|
|
result:=n;
|
|
end;
|
|
|
|
|
|
function tarrayconstructornode.has_range_node:boolean;
|
|
var
|
|
n : tarrayconstructornode;
|
|
begin
|
|
result:=false;
|
|
n:=self;
|
|
while assigned(n) do
|
|
begin
|
|
if assigned(n.left) and (n.left.nodetype=arrayconstructorrangen) then
|
|
begin
|
|
result:=true;
|
|
break;
|
|
end;
|
|
n:=tarrayconstructornode(n.right);
|
|
end;
|
|
end;
|
|
|
|
|
|
function tarrayconstructornode.isempty:boolean;
|
|
begin
|
|
result:=not(assigned(left)) and not(assigned(right));
|
|
end;
|
|
|
|
|
|
function tarrayconstructornode.pass_typecheck:tnode;
|
|
var
|
|
hdef : tdef;
|
|
hp : tarrayconstructornode;
|
|
len : longint;
|
|
diff,
|
|
varia : boolean;
|
|
eq : tequaltype;
|
|
hnodetype : tnodetype;
|
|
begin
|
|
result:=nil;
|
|
|
|
{ are we allowing array constructor? Then convert it to a set.
|
|
Do this only if we didn't convert the arrayconstructor yet. This
|
|
is needed for the cases where the resultdef is forced for a second
|
|
run }
|
|
if not (acnf_allow_array_constructor in arrayconstructornodeflags) or has_range_node then
|
|
begin
|
|
hp:=tarrayconstructornode(getcopy);
|
|
arrayconstructor_to_set(tnode(hp));
|
|
result:=hp;
|
|
exit;
|
|
end;
|
|
|
|
{ only pass left tree, right tree contains next construct if any }
|
|
hdef:=nil;
|
|
hnodetype:=errorn;
|
|
len:=0;
|
|
varia:=false;
|
|
diff:=false;
|
|
if assigned(left) then
|
|
begin
|
|
hp:=self;
|
|
while assigned(hp) do
|
|
begin
|
|
typecheckpass(hp.left);
|
|
set_varstate(hp.left,vs_read,[vsf_must_be_valid]);
|
|
if (hdef=nil) then
|
|
begin
|
|
hdef:=hp.left.resultdef;
|
|
hnodetype:=hp.left.nodetype;
|
|
end
|
|
else
|
|
begin
|
|
{ If we got a niln we don't know the type yet and need to take the
|
|
type of the next array element.
|
|
This is to handle things like [nil,tclass,tclass], see also tw8371 (PFV) }
|
|
if hnodetype=niln then
|
|
begin
|
|
eq:=compare_defs(hp.left.resultdef,hdef,hnodetype);
|
|
if eq>te_incompatible then
|
|
begin
|
|
hdef:=hp.left.resultdef;
|
|
hnodetype:=hp.left.nodetype;
|
|
end;
|
|
end
|
|
else
|
|
eq:=compare_defs(hdef,hp.left.resultdef,hp.left.nodetype);
|
|
{ the element is not compatible with the previous element
|
|
which means the constructor is array of const }
|
|
if eq=te_incompatible then
|
|
diff:=true;
|
|
if (not varia) and (eq<te_equal) then
|
|
begin
|
|
{ If both are integers we need to take the type that can hold both
|
|
defs }
|
|
if is_integer(hdef) and is_integer(hp.left.resultdef) then
|
|
begin
|
|
if is_in_limit(hdef,hp.left.resultdef) then
|
|
hdef:=hp.left.resultdef;
|
|
end
|
|
else
|
|
if (acnf_novariaallowed in arrayconstructornodeflags) then
|
|
varia:=true;
|
|
end;
|
|
end;
|
|
inc(len);
|
|
hp:=tarrayconstructornode(hp.right);
|
|
end;
|
|
end;
|
|
{ Set the type of empty or varia arrays to void. Also
|
|
do this if the type is array of const/open array
|
|
because those can't be used with setelementdef }
|
|
if not assigned(hdef) or
|
|
varia or
|
|
is_array_of_const(hdef) or
|
|
is_open_array(hdef) then
|
|
hdef:=voidtype;
|
|
resultdef:=carraydef.create(0,len-1,s32inttype);
|
|
include(tarraydef(resultdef).arrayoptions,ado_IsConstructor);
|
|
if varia then
|
|
include(tarraydef(resultdef).arrayoptions,ado_IsVariant);
|
|
if diff then
|
|
include(tarraydef(resultdef).arrayoptions,ado_IsArrayOfConst);
|
|
tarraydef(resultdef).elementdef:=hdef;
|
|
end;
|
|
|
|
|
|
procedure tarrayconstructornode.force_type(def:tdef);
|
|
var
|
|
hp : tarrayconstructornode;
|
|
begin
|
|
tarraydef(resultdef).elementdef:=def;
|
|
include(tarraydef(resultdef).arrayoptions,ado_IsConstructor);
|
|
exclude(tarraydef(resultdef).arrayoptions,ado_IsVariant);
|
|
if assigned(left) then
|
|
begin
|
|
hp:=self;
|
|
while assigned(hp) do
|
|
begin
|
|
inserttypeconv(hp.left,def);
|
|
hp:=tarrayconstructornode(hp.right);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure tarrayconstructornode.insert_typeconvs;
|
|
var
|
|
hp : tarrayconstructornode;
|
|
dovariant : boolean;
|
|
begin
|
|
dovariant:=(acnf_forcevaria in arrayconstructornodeflags) or (ado_isvariant in tarraydef(resultdef).arrayoptions);
|
|
{ only pass left tree, right tree contains next construct if any }
|
|
if assigned(left) then
|
|
begin
|
|
hp:=self;
|
|
while assigned(hp) do
|
|
begin
|
|
typecheckpass(hp.left);
|
|
{ Insert typeconvs for array of const }
|
|
if dovariant then
|
|
{ at this time C varargs are no longer an arrayconstructornode }
|
|
insert_varargstypeconv(hp.left,false);
|
|
hp:=tarrayconstructornode(hp.right);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function tarrayconstructornode.pass_1 : tnode;
|
|
var
|
|
hp : tarrayconstructornode;
|
|
do_variant,
|
|
do_managed_variant:boolean;
|
|
begin
|
|
do_variant:=(acnf_forcevaria in arrayconstructornodeflags) or (ado_isvariant in tarraydef(resultdef).arrayoptions);
|
|
do_managed_variant:=
|
|
do_variant and
|
|
(target_info.system in systems_managed_vm);
|
|
result:=nil;
|
|
{ Insert required type convs, this must be
|
|
done in pass 1, because the call must be
|
|
typecheckpassed already }
|
|
if assigned(left) then
|
|
begin
|
|
insert_typeconvs;
|
|
{ call firstpass for all nodes }
|
|
hp:=self;
|
|
while assigned(hp) do
|
|
begin
|
|
if hp.left<>nil then
|
|
begin
|
|
{This check is pessimistic; a call will happen depending
|
|
on the location in which the elements will be found in
|
|
pass 2.}
|
|
if not do_variant then
|
|
include(current_procinfo.flags,pi_do_call);
|
|
firstpass(hp.left);
|
|
if do_managed_variant then
|
|
wrapmanagedvarrec(hp.left);
|
|
end;
|
|
hp:=tarrayconstructornode(hp.right);
|
|
end;
|
|
end;
|
|
{ set the elementdef to the correct type in case of a variant array }
|
|
if do_variant then
|
|
tarraydef(resultdef).elementdef:=search_system_type('TVARREC').typedef;
|
|
expectloc:=LOC_CREFERENCE;
|
|
|
|
inc(current_procinfo.estimatedtempsize,(tarraydef(resultdef).highrange+1)*tarraydef(resultdef).elementdef.size);
|
|
end;
|
|
|
|
|
|
function tarrayconstructornode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare:=inherited docompare(p);
|
|
end;
|
|
|
|
{$ifdef DEBUG_NODE_XML}
|
|
procedure TArrayConstructorNode.XMLPrintNodeInfo(var T: Text);
|
|
var
|
|
i: TArrayConstructorNodeFlag;
|
|
First: Boolean;
|
|
begin
|
|
inherited XMLPrintNodeInfo(T);
|
|
First := True;
|
|
for i in arrayconstructornodeflags do
|
|
begin
|
|
if First then
|
|
begin
|
|
Write(T, ' arrayconstructornodeflags="', i);
|
|
First := False;
|
|
end
|
|
else
|
|
Write(T, ',', i)
|
|
end;
|
|
if not First then
|
|
Write(T, '"');
|
|
end;
|
|
{$endif DEBUG_NODE_XML}
|
|
|
|
{*****************************************************************************
|
|
TTYPENODE
|
|
*****************************************************************************}
|
|
|
|
constructor ttypenode.create(def:tdef);
|
|
begin
|
|
inherited create(typen);
|
|
typedef:=def;
|
|
typesym:=def.typesym;
|
|
allowed:=false;
|
|
helperallowed:=false;
|
|
end;
|
|
|
|
|
|
constructor ttypenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.getderef(typedefderef);
|
|
ppufile.getderef(typesymderef);
|
|
allowed:=ppufile.getboolean;
|
|
helperallowed:=ppufile.getboolean;
|
|
end;
|
|
|
|
|
|
procedure ttypenode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(typedefderef);
|
|
ppufile.putderef(typesymderef);
|
|
ppufile.putboolean(allowed);
|
|
ppufile.putboolean(helperallowed);
|
|
end;
|
|
|
|
|
|
procedure ttypenode.buildderefimpl;
|
|
begin
|
|
inherited buildderefimpl;
|
|
typedefderef.build(typedef);
|
|
typesymderef.build(typesym);
|
|
end;
|
|
|
|
|
|
procedure ttypenode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
typedef:=tdef(typedefderef.resolve);
|
|
typesym:=tsym(typesymderef.resolve);
|
|
end;
|
|
|
|
|
|
function ttypenode.pass_typecheck:tnode;
|
|
begin
|
|
result:=nil;
|
|
resultdef:=typedef;
|
|
{ check if it's valid }
|
|
if typedef.typ = errordef then
|
|
CGMessage(parser_e_illegal_expression);
|
|
end;
|
|
|
|
|
|
function ttypenode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
expectloc:=LOC_VOID;
|
|
{ a typenode can't generate code, so we give here
|
|
an error. Else it'll be an abstract error in pass_generate_code.
|
|
Only when the allowed flag is set we don't generate
|
|
an error }
|
|
if not allowed then
|
|
CGMessage(parser_e_no_type_not_allowed_here);
|
|
if not helperallowed and is_objectpascal_helper(typedef) then
|
|
CGMessage(parser_e_no_category_as_types);
|
|
end;
|
|
|
|
|
|
function ttypenode.dogetcopy : tnode;
|
|
var
|
|
n : ttypenode;
|
|
begin
|
|
n:=ttypenode(inherited dogetcopy);
|
|
n.allowed:=allowed;
|
|
n.typedef:=typedef;
|
|
n.typesym:=typesym;
|
|
n.helperallowed:=helperallowed;
|
|
result:=n;
|
|
end;
|
|
|
|
|
|
function ttypenode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare :=
|
|
inherited docompare(p) and
|
|
(typedef=ttypenode(p).typedef) and
|
|
(typesym=ttypenode(p).typesym) and
|
|
(allowed=ttypenode(p).allowed) and
|
|
(helperallowed=ttypenode(p).helperallowed);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TRTTINODE
|
|
*****************************************************************************}
|
|
|
|
|
|
constructor trttinode.create(def:tstoreddef;rt:trttitype;dt:Trttidatatype);
|
|
begin
|
|
inherited create(rttin);
|
|
rttidef:=def;
|
|
rttitype:=rt;
|
|
rttidatatype:=dt;
|
|
end;
|
|
|
|
|
|
constructor trttinode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.getderef(rttidefderef);
|
|
rttitype:=trttitype(ppufile.getbyte);
|
|
rttidatatype:=trttidatatype(ppufile.getbyte);
|
|
end;
|
|
|
|
|
|
procedure trttinode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(rttidefderef);
|
|
ppufile.putbyte(byte(rttitype));
|
|
ppufile.putbyte(byte(rttidatatype));
|
|
end;
|
|
|
|
|
|
procedure trttinode.buildderefimpl;
|
|
begin
|
|
inherited buildderefimpl;
|
|
rttidefderef.build(rttidef);
|
|
end;
|
|
|
|
|
|
procedure trttinode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
rttidef:=tstoreddef(rttidefderef.resolve);
|
|
end;
|
|
|
|
|
|
function trttinode.dogetcopy : tnode;
|
|
var
|
|
n : trttinode;
|
|
begin
|
|
n:=trttinode(inherited dogetcopy);
|
|
n.rttidef:=rttidef;
|
|
n.rttitype:=rttitype;
|
|
n.rttidatatype:=rttidatatype;
|
|
result:=n;
|
|
end;
|
|
|
|
|
|
function trttinode.pass_typecheck:tnode;
|
|
begin
|
|
{ rtti information will be returned as a void pointer }
|
|
result:=nil;
|
|
resultdef:=voidpointertype;
|
|
end;
|
|
|
|
|
|
function trttinode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
expectloc:=LOC_CREFERENCE;
|
|
end;
|
|
|
|
|
|
function trttinode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare :=
|
|
inherited docompare(p) and
|
|
(rttidef = trttinode(p).rttidef) and
|
|
(rttitype = trttinode(p).rttitype) and
|
|
(rttidatatype = trttinode(p).rttidatatype);
|
|
end;
|
|
|
|
end.
|