mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-11 18:48:41 +02:00
37aa2d8443
o sets of enums are handled as JUEnumSet instances, others as JUBitSet
derivatives (both smallsets and varsets, to make interoperability with
Java easier)
o special handling of set constants: these have to be constructed at run
time. In case of constants in the code, create an internal constsym to
represent them. These and regular constsyms are then aliased by an
another internal staticvarsym that is used to initialise them in the
unit initialisation code.
o until they are constructed at run time, set constants are encoded as
constant Java strings (with the characters containing the set bits)
o hlcgobj conversion of tcginnode.pass_generate_code() for the genjumps
part (that's the only part of the generic code that's used by the JVM
target)
o as far as explicit typecasting support is concerned, currently the
following ones are supported (both from/to setdefs): ordinal types,
enums, any other set types (whose size is the same on native targets)
o enum setdefs also emit signatures
o overloading routines for different ordinal set types, or for different
enum set types, is not supported on the JVM target
git-svn-id: branches/jvmbackend@18662 -
1087 lines
37 KiB
ObjectPascal
1087 lines
37 KiB
ObjectPascal
{
|
|
Copyright (c) 2000-2002 by Florian Klaempfl
|
|
|
|
Type checking and register allocation for memory related 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 nmem;
|
|
|
|
{$i fpcdefs.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
node,
|
|
symdef,symsym,symtable,symtype;
|
|
|
|
type
|
|
tloadvmtaddrnode = class(tunarynode)
|
|
{ unless this is for a call, we have to send the "class" message to
|
|
the objctype because the type information only gets initialized
|
|
after the first message has been sent -> crash if you pass an
|
|
uninitialized type to e.g. class_getInstanceSize() or so. No need
|
|
to save to/restore from ppu. }
|
|
forcall: boolean;
|
|
constructor create(l : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
function dogetcopy: tnode; override;
|
|
end;
|
|
tloadvmtaddrnodeclass = class of tloadvmtaddrnode;
|
|
|
|
tloadparentfpnode = class(tunarynode)
|
|
parentpd : tprocdef;
|
|
parentpdderef : tderef;
|
|
constructor create(pd:tprocdef);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 docompare(p: tnode): boolean; override;
|
|
function dogetcopy : tnode;override;
|
|
end;
|
|
tloadparentfpnodeclass = class of tloadparentfpnode;
|
|
|
|
taddrnode = class(tunarynode)
|
|
getprocvardef : tprocvardef;
|
|
getprocvardefderef : tderef;
|
|
constructor create(l : tnode);virtual;
|
|
constructor create_internal(l : tnode); virtual;
|
|
constructor create_internal_nomark(l : tnode); virtual;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
procedure mark_write;override;
|
|
procedure buildderefimpl;override;
|
|
procedure derefimpl;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
function dogetcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
protected
|
|
mark_read_written: boolean;
|
|
end;
|
|
taddrnodeclass = class of taddrnode;
|
|
|
|
tderefnode = class(tunarynode)
|
|
constructor create(l : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
procedure mark_write;override;
|
|
end;
|
|
tderefnodeclass = class of tderefnode;
|
|
|
|
tsubscriptnode = class(tunarynode)
|
|
vs : tfieldvarsym;
|
|
vsderef : tderef;
|
|
constructor create(varsym : tsym;l : tnode);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 docompare(p: tnode): boolean; override;
|
|
function pass_typecheck:tnode;override;
|
|
procedure mark_write;override;
|
|
end;
|
|
tsubscriptnodeclass = class of tsubscriptnode;
|
|
|
|
tvecnode = class(tbinarynode)
|
|
constructor create(l,r : tnode);virtual;
|
|
function pass_1 : tnode;override;
|
|
function pass_typecheck:tnode;override;
|
|
procedure mark_write;override;
|
|
end;
|
|
tvecnodeclass = class of tvecnode;
|
|
|
|
twithnode = class(tunarynode)
|
|
constructor create(l:tnode);
|
|
destructor destroy;override;
|
|
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
|
|
procedure ppuwrite(ppufile:tcompilerppufile);override;
|
|
function dogetcopy : tnode;override;
|
|
function pass_1 : tnode;override;
|
|
function docompare(p: tnode): boolean; override;
|
|
function pass_typecheck:tnode;override;
|
|
end;
|
|
twithnodeclass = class of twithnode;
|
|
|
|
var
|
|
cloadvmtaddrnode : tloadvmtaddrnodeclass= tloadvmtaddrnode;
|
|
caddrnode : taddrnodeclass= taddrnode;
|
|
cderefnode : tderefnodeclass= tderefnode;
|
|
csubscriptnode : tsubscriptnodeclass= tsubscriptnode;
|
|
cvecnode : tvecnodeclass= tvecnode;
|
|
cwithnode : twithnodeclass= twithnode;
|
|
cloadparentfpnode : tloadparentfpnodeclass = tloadparentfpnode;
|
|
|
|
function is_big_untyped_addrnode(p: tnode): boolean;
|
|
|
|
implementation
|
|
|
|
uses
|
|
globtype,systems,constexp,
|
|
cutils,verbose,globals,
|
|
symconst,symbase,defutil,defcmp,
|
|
nbas,nutils,
|
|
wpobase,
|
|
htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase,procinfo
|
|
;
|
|
|
|
{*****************************************************************************
|
|
TLOADVMTADDRNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tloadvmtaddrnode.create(l : tnode);
|
|
begin
|
|
inherited create(loadvmtaddrn,l);
|
|
end;
|
|
|
|
|
|
function tloadvmtaddrnode.pass_typecheck:tnode;
|
|
var
|
|
defaultresultdef : boolean;
|
|
begin
|
|
result:=nil;
|
|
typecheckpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
case left.resultdef.typ of
|
|
classrefdef :
|
|
resultdef:=left.resultdef;
|
|
objectdef,
|
|
recorddef:
|
|
{ access to the classtype while specializing? }
|
|
if (df_generic in left.resultdef.defoptions) then
|
|
begin
|
|
defaultresultdef:=true;
|
|
if assigned(current_structdef) then
|
|
begin
|
|
if assigned(current_structdef.genericdef) then
|
|
if current_structdef.genericdef=left.resultdef then
|
|
begin
|
|
resultdef:=tclassrefdef.create(current_structdef);
|
|
defaultresultdef:=false;
|
|
end
|
|
else
|
|
CGMessage(parser_e_cant_create_generics_of_this_type);
|
|
end
|
|
else
|
|
message(parser_e_cant_create_generics_of_this_type);
|
|
if defaultresultdef then
|
|
resultdef:=tclassrefdef.create(left.resultdef);
|
|
end
|
|
else
|
|
resultdef:=tclassrefdef.create(left.resultdef);
|
|
else
|
|
CGMessage(parser_e_pointer_to_class_expected);
|
|
end;
|
|
end;
|
|
|
|
|
|
function tloadvmtaddrnode.docompare(p: tnode): boolean;
|
|
begin
|
|
result:=inherited docompare(p);
|
|
if result then
|
|
result:=forcall=tloadvmtaddrnode(p).forcall;
|
|
end;
|
|
|
|
|
|
function tloadvmtaddrnode.dogetcopy: tnode;
|
|
begin
|
|
result:=inherited dogetcopy;
|
|
tloadvmtaddrnode(result).forcall:=forcall;
|
|
end;
|
|
|
|
|
|
function tloadvmtaddrnode.pass_1 : tnode;
|
|
var
|
|
vs: tsym;
|
|
begin
|
|
result:=nil;
|
|
expectloc:=LOC_REGISTER;
|
|
if left.nodetype<>typen then
|
|
begin
|
|
{ make sure that the isa field is loaded correctly in case
|
|
of the non-fragile ABI }
|
|
if is_objcclass(left.resultdef) and
|
|
(left.nodetype<>typen) then
|
|
begin
|
|
vs:=search_struct_member(tobjectdef(left.resultdef),'ISA');
|
|
if not assigned(vs) or
|
|
(tsym(vs).typ<>fieldvarsym) then
|
|
internalerror(2009092502);
|
|
result:=csubscriptnode.create(tfieldvarsym(vs),left);
|
|
inserttypeconv_internal(result,resultdef);
|
|
{ reused }
|
|
left:=nil;
|
|
end
|
|
else if is_javaclass(left.resultdef) and
|
|
(left.nodetype<>typen) and
|
|
(left.resultdef.typ<>classrefdef) then
|
|
begin
|
|
{ call java.lang.Object.getClass() }
|
|
vs:=search_struct_member(tobjectdef(left.resultdef),'GETCLASS');
|
|
if not assigned(vs) or
|
|
(tsym(vs).typ<>procsym) then
|
|
internalerror(2011041901);
|
|
result:=ccallnode.create(nil,tprocsym(vs),vs.owner,left,[]);
|
|
inserttypeconv_explicit(result,resultdef);
|
|
{ reused }
|
|
left:=nil;
|
|
end
|
|
else
|
|
firstpass(left)
|
|
end
|
|
else if not is_objcclass(left.resultdef) and
|
|
not is_objcclassref(left.resultdef) and
|
|
not is_javaclass(left.resultdef) and
|
|
not is_javaclassref(left.resultdef) then
|
|
begin
|
|
if not(nf_ignore_for_wpo in flags) and
|
|
(not assigned(current_procinfo) or
|
|
(po_inline in current_procinfo.procdef.procoptions) or
|
|
wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then
|
|
begin
|
|
{ keep track of which classes might be instantiated via a classrefdef }
|
|
if (left.resultdef.typ=classrefdef) then
|
|
tobjectdef(tclassrefdef(left.resultdef).pointeddef).register_maybe_created_object_type
|
|
else if (left.resultdef.typ=objectdef) then
|
|
tobjectdef(left.resultdef).register_maybe_created_object_type
|
|
end
|
|
end
|
|
else if is_objcclass(left.resultdef) and
|
|
not(forcall) then
|
|
begin
|
|
{ call "class" method (= "classclass" in FPC), because otherwise
|
|
we may use the class information before it has been
|
|
initialized }
|
|
vs:=search_struct_member(tobjectdef(left.resultdef),'CLASSCLASS');
|
|
if not assigned(vs) or
|
|
(vs.typ<>procsym) then
|
|
internalerror(2011080601);
|
|
{ can't reuse "self", because it will be freed when we return }
|
|
result:=ccallnode.create(nil,tprocsym(vs),vs.owner,self.getcopy,[]);
|
|
end;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TLOADPARENTFPNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tloadparentfpnode.create(pd:tprocdef);
|
|
begin
|
|
inherited create(loadparentfpn,nil);
|
|
if not assigned(pd) then
|
|
internalerror(200309288);
|
|
if (pd.parast.symtablelevel>current_procinfo.procdef.parast.symtablelevel) then
|
|
internalerror(200309284);
|
|
parentpd:=pd;
|
|
end;
|
|
|
|
|
|
constructor tloadparentfpnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.getderef(parentpdderef);
|
|
end;
|
|
|
|
|
|
procedure tloadparentfpnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(parentpdderef);
|
|
end;
|
|
|
|
|
|
procedure tloadparentfpnode.buildderefimpl;
|
|
begin
|
|
inherited buildderefimpl;
|
|
parentpdderef.build(parentpd);
|
|
end;
|
|
|
|
|
|
procedure tloadparentfpnode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
parentpd:=tprocdef(parentpdderef.resolve);
|
|
end;
|
|
|
|
|
|
function tloadparentfpnode.docompare(p: tnode): boolean;
|
|
begin
|
|
result:=
|
|
inherited docompare(p) and
|
|
(tloadparentfpnode(p).parentpd=parentpd);
|
|
end;
|
|
|
|
|
|
function tloadparentfpnode.dogetcopy : tnode;
|
|
var
|
|
p : tloadparentfpnode;
|
|
begin
|
|
p:=tloadparentfpnode(inherited dogetcopy);
|
|
p.parentpd:=parentpd;
|
|
dogetcopy:=p;
|
|
end;
|
|
|
|
|
|
function tloadparentfpnode.pass_typecheck:tnode;
|
|
{$ifdef dummy}
|
|
var
|
|
currpi : tprocinfo;
|
|
hsym : tparavarsym;
|
|
{$endif dummy}
|
|
begin
|
|
result:=nil;
|
|
resultdef:=voidpointertype;
|
|
{$ifdef dummy}
|
|
{ currently parentfps are never loaded in registers (FK) }
|
|
if (current_procinfo.procdef.parast.symtablelevel<>parentpd.parast.symtablelevel) then
|
|
begin
|
|
currpi:=current_procinfo;
|
|
{ walk parents }
|
|
while (currpi.procdef.owner.symtablelevel>parentpd.parast.symtablelevel) do
|
|
begin
|
|
currpi:=currpi.parent;
|
|
if not assigned(currpi) then
|
|
internalerror(2005040602);
|
|
hsym:=tparavarsym(currpi.procdef.parast.Find('parentfp'));
|
|
if not assigned(hsym) then
|
|
internalerror(2005040601);
|
|
hsym.varregable:=vr_none;
|
|
end;
|
|
end;
|
|
{$endif dummy}
|
|
end;
|
|
|
|
|
|
function tloadparentfpnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
expectloc:=LOC_REGISTER;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TADDRNODE
|
|
*****************************************************************************}
|
|
|
|
constructor taddrnode.create(l : tnode);
|
|
|
|
begin
|
|
inherited create(addrn,l);
|
|
getprocvardef:=nil;
|
|
mark_read_written := true;
|
|
end;
|
|
|
|
|
|
constructor taddrnode.create_internal(l : tnode);
|
|
begin
|
|
self.create(l);
|
|
include(flags,nf_internal);
|
|
end;
|
|
|
|
|
|
constructor taddrnode.create_internal_nomark(l : tnode);
|
|
begin
|
|
self.create_internal(l);
|
|
mark_read_written := false;
|
|
end;
|
|
|
|
|
|
constructor taddrnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.getderef(getprocvardefderef);
|
|
end;
|
|
|
|
|
|
procedure taddrnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(getprocvardefderef);
|
|
end;
|
|
|
|
procedure Taddrnode.mark_write;
|
|
|
|
begin
|
|
{@procvar:=nil is legal in Delphi mode.}
|
|
left.mark_write;
|
|
end;
|
|
|
|
procedure taddrnode.buildderefimpl;
|
|
begin
|
|
inherited buildderefimpl;
|
|
getprocvardefderef.build(getprocvardef);
|
|
end;
|
|
|
|
|
|
procedure taddrnode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
getprocvardef:=tprocvardef(getprocvardefderef.resolve);
|
|
end;
|
|
|
|
|
|
function taddrnode.docompare(p: tnode): boolean;
|
|
begin
|
|
result:=
|
|
inherited docompare(p) and
|
|
(taddrnode(p).getprocvardef=getprocvardef);
|
|
end;
|
|
|
|
|
|
function taddrnode.dogetcopy : tnode;
|
|
var
|
|
p : taddrnode;
|
|
begin
|
|
p:=taddrnode(inherited dogetcopy);
|
|
p.getprocvardef:=getprocvardef;
|
|
dogetcopy:=p;
|
|
end;
|
|
|
|
|
|
function taddrnode.pass_typecheck:tnode;
|
|
var
|
|
hp : tnode;
|
|
hsym : tfieldvarsym;
|
|
isprocvar : boolean;
|
|
begin
|
|
result:=nil;
|
|
typecheckpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
make_not_regable(left,[ra_addr_regable,ra_addr_taken]);
|
|
|
|
{ don't allow constants, for internal use we also
|
|
allow taking the address of strings and sets }
|
|
if is_constnode(left) and
|
|
not(
|
|
(nf_internal in flags) and
|
|
(left.nodetype in [stringconstn,setconstn])
|
|
) then
|
|
begin
|
|
CGMessagePos(left.fileinfo,type_e_no_addr_of_constant);
|
|
exit;
|
|
end;
|
|
|
|
{ Handle @proc special, also @procvar in tp-mode needs
|
|
special handling }
|
|
if (left.resultdef.typ=procdef) or
|
|
(
|
|
(left.resultdef.typ=procvardef) and
|
|
((m_tp_procvar in current_settings.modeswitches) or
|
|
(m_mac_procvar in current_settings.modeswitches))
|
|
) then
|
|
begin
|
|
isprocvar:=(left.resultdef.typ=procvardef);
|
|
|
|
if not isprocvar then
|
|
begin
|
|
left:=ctypeconvnode.create_proc_to_procvar(left);
|
|
left.fileinfo:=fileinfo;
|
|
typecheckpass(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 current_settings.modeswitches) or
|
|
(m_mac_procvar in current_settings.modeswitches) then
|
|
begin
|
|
if tabstractprocdef(left.resultdef).is_addressonly then
|
|
begin
|
|
result:=ctypeconvnode.create_internal(left,voidpointertype);
|
|
include(result.flags,nf_load_procvar);
|
|
left:=nil;
|
|
end
|
|
else
|
|
begin
|
|
{ For procvars and for nested routines we need to return
|
|
the proc field of the methodpointer }
|
|
if isprocvar or
|
|
is_nested_pd(tabstractprocdef(left.resultdef)) then
|
|
begin
|
|
{ find proc field in methodpointer record }
|
|
hsym:=tfieldvarsym(trecorddef(methodpointertype).symtable.Find('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
|
|
{ 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 [typeconvn,vecn,derefn,subscriptn]) do
|
|
hp:=tunarynode(hp).left;
|
|
if not assigned(hp) then
|
|
internalerror(200412042);
|
|
{$ifdef i386}
|
|
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
|
|
resultdef:=voidfarpointertype
|
|
else
|
|
resultdef:=tpointerdef.createfar(left.resultdef);
|
|
end
|
|
else
|
|
{$endif i386}
|
|
if (hp.nodetype=loadn) and
|
|
(tloadnode(hp).symtableentry.typ=absolutevarsym) and
|
|
{$ifdef i386}
|
|
not(tabsolutevarsym(tloadnode(hp).symtableentry).absseg) and
|
|
{$endif i386}
|
|
(tabsolutevarsym(tloadnode(hp).symtableentry).abstyp=toaddr) then
|
|
begin
|
|
if nf_typedaddr in flags then
|
|
result:=cpointerconstnode.create(tabsolutevarsym(tloadnode(hp).symtableentry).addroffset,getpointerdef(left.resultdef))
|
|
else
|
|
result:=cpointerconstnode.create(tabsolutevarsym(tloadnode(hp).symtableentry).addroffset,voidpointertype);
|
|
exit;
|
|
end
|
|
else if (nf_internal in flags) or
|
|
valid_for_addr(left,true) then
|
|
begin
|
|
if not(nf_typedaddr in flags) then
|
|
resultdef:=voidpointertype
|
|
else
|
|
resultdef:=getpointerdef(left.resultdef);
|
|
end
|
|
else
|
|
CGMessage(type_e_variable_id_expected);
|
|
end;
|
|
|
|
if mark_read_written then
|
|
begin
|
|
{ This is actually only "read", but treat it nevertheless as }
|
|
{ modified due to the possible use of pointers }
|
|
{ To avoid false positives regarding "uninitialised" }
|
|
{ warnings when using arrays, perform it in two steps }
|
|
set_varstate(left,vs_written,[]);
|
|
{ vsf_must_be_valid so it doesn't get changed into }
|
|
{ vsf_referred_not_inited }
|
|
set_varstate(left,vs_read,[vsf_must_be_valid]);
|
|
end;
|
|
end;
|
|
|
|
|
|
function taddrnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ is this right for object of methods ?? }
|
|
expectloc:=LOC_REGISTER;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TDEREFNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tderefnode.create(l : tnode);
|
|
|
|
begin
|
|
inherited create(derefn,l);
|
|
|
|
end;
|
|
|
|
function tderefnode.pass_typecheck:tnode;
|
|
begin
|
|
result:=nil;
|
|
typecheckpass(left);
|
|
set_varstate(left,vs_read,[vsf_must_be_valid]);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ tp procvar support }
|
|
maybe_call_procvar(left,true);
|
|
|
|
if left.resultdef.typ=pointerdef then
|
|
resultdef:=tpointerdef(left.resultdef).pointeddef
|
|
else
|
|
CGMessage(parser_e_invalid_qualifier);
|
|
end;
|
|
|
|
procedure Tderefnode.mark_write;
|
|
|
|
begin
|
|
include(flags,nf_write);
|
|
end;
|
|
|
|
function tderefnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
expectloc:=LOC_REFERENCE;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TSUBSCRIPTNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tsubscriptnode.create(varsym : tsym;l : tnode);
|
|
|
|
begin
|
|
inherited create(subscriptn,l);
|
|
{ vs should be changed to tsym! }
|
|
vs:=tfieldvarsym(varsym);
|
|
end;
|
|
|
|
constructor tsubscriptnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
ppufile.getderef(vsderef);
|
|
end;
|
|
|
|
|
|
procedure tsubscriptnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
ppufile.putderef(vsderef);
|
|
end;
|
|
|
|
|
|
procedure tsubscriptnode.buildderefimpl;
|
|
begin
|
|
inherited buildderefimpl;
|
|
vsderef.build(vs);
|
|
end;
|
|
|
|
|
|
procedure tsubscriptnode.derefimpl;
|
|
begin
|
|
inherited derefimpl;
|
|
vs:=tfieldvarsym(vsderef.resolve);
|
|
end;
|
|
|
|
|
|
function tsubscriptnode.dogetcopy : tnode;
|
|
var
|
|
p : tsubscriptnode;
|
|
begin
|
|
p:=tsubscriptnode(inherited dogetcopy);
|
|
p.vs:=vs;
|
|
dogetcopy:=p;
|
|
end;
|
|
|
|
|
|
function tsubscriptnode.pass_typecheck:tnode;
|
|
begin
|
|
result:=nil;
|
|
typecheckpass(left);
|
|
{ tp procvar support }
|
|
maybe_call_procvar(left,true);
|
|
resultdef:=vs.vardef;
|
|
|
|
// don't put records from which we load float fields
|
|
// in integer registers
|
|
if (left.resultdef.typ=recorddef) and
|
|
(resultdef.typ=floatdef) then
|
|
make_not_regable(left,[ra_addr_regable]);
|
|
end;
|
|
|
|
procedure Tsubscriptnode.mark_write;
|
|
begin
|
|
include(flags,nf_write);
|
|
end;
|
|
|
|
|
|
function tsubscriptnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ several object types must be dereferenced implicitly }
|
|
if is_implicit_pointer_object_type(left.resultdef) then
|
|
expectloc:=LOC_REFERENCE
|
|
else
|
|
begin
|
|
case left.expectloc of
|
|
LOC_REGISTER,
|
|
LOC_SUBSETREG:
|
|
// can happen for function results on win32 and darwin/x86
|
|
if (left.resultdef.size > sizeof(pint)) then
|
|
expectloc:=LOC_REFERENCE
|
|
else
|
|
expectloc:=LOC_SUBSETREG;
|
|
LOC_CREGISTER,
|
|
LOC_CSUBSETREG:
|
|
expectloc:=LOC_CSUBSETREG;
|
|
LOC_REFERENCE,
|
|
LOC_CREFERENCE:
|
|
expectloc:=left.expectloc;
|
|
else internalerror(20060521);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function tsubscriptnode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare :=
|
|
inherited docompare(p) and
|
|
(vs = tsubscriptnode(p).vs);
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TVECNODE
|
|
*****************************************************************************}
|
|
|
|
constructor tvecnode.create(l,r : tnode);
|
|
|
|
begin
|
|
inherited create(vecn,l,r);
|
|
end;
|
|
|
|
|
|
function tvecnode.pass_typecheck:tnode;
|
|
var
|
|
hightree: tnode;
|
|
htype,elementdef : tdef;
|
|
valid : boolean;
|
|
begin
|
|
result:=nil;
|
|
typecheckpass(left);
|
|
typecheckpass(right);
|
|
|
|
{ implicitly convert stringconstant to stringdef,
|
|
see tbs/tb0476.pp for a test }
|
|
if (left.nodetype=stringconstn) and
|
|
(tstringconstnode(left).cst_type=cst_conststring) then
|
|
begin
|
|
if tstringconstnode(left).len>255 then
|
|
inserttypeconv(left,cansistringtype)
|
|
else
|
|
inserttypeconv(left,cshortstringtype);
|
|
end;
|
|
|
|
{ In p[1] p is always valid, it is not possible to
|
|
declared a shortstring or normal array that has
|
|
undefined number of elements. Dynamic array and
|
|
ansi/widestring needs to be valid }
|
|
valid:=is_dynamic_array(left.resultdef) or
|
|
is_ansistring(left.resultdef) or
|
|
is_wide_or_unicode_string(left.resultdef) or
|
|
{ implicit pointer dereference -> pointer is read }
|
|
(left.resultdef.typ = pointerdef);
|
|
if valid then
|
|
set_varstate(left,vs_read,[vsf_must_be_valid]);
|
|
{
|
|
A vecn is, just like a loadn, always part of an expression with its
|
|
own read/write and must_be_valid semantics. Therefore we don't have
|
|
to do anything else here, just like for loadn's
|
|
}
|
|
set_varstate(right,vs_read,[vsf_must_be_valid]);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
{ maybe type conversion for the index value, but
|
|
do not convert enums, char (why not? (JM))
|
|
and do not convert range nodes }
|
|
if (right.nodetype<>rangen) and (is_integer(right.resultdef) or is_boolean(right.resultdef) or (left.resultdef.typ<>arraydef)) then
|
|
case left.resultdef.typ of
|
|
arraydef:
|
|
if ado_isvariant in Tarraydef(left.resultdef).arrayoptions then
|
|
{Variant arrays are a special array, can have negative indexes and would therefore
|
|
need s32bit. However, they should not appear in a vecn, as they are handled in
|
|
handle_variantarray in pexpr.pas. Therefore, encountering a variant array is an
|
|
internal error... }
|
|
internalerror(200707031)
|
|
else if is_special_array(left.resultdef) then
|
|
{Arrays without a high bound (dynamic arrays, open arrays) are zero based,
|
|
convert indexes into these arrays to aword.}
|
|
inserttypeconv(right,uinttype)
|
|
{ convert between pasbool and cbool if necessary }
|
|
else if is_boolean(right.resultdef) then
|
|
inserttypeconv(right,tarraydef(left.resultdef).rangedef)
|
|
else
|
|
{Convert array indexes to low_bound..high_bound.}
|
|
inserttypeconv(right,Torddef.create(Torddef(sinttype).ordtype,
|
|
int64(Tarraydef(left.resultdef).lowrange),
|
|
int64(Tarraydef(left.resultdef).highrange)
|
|
));
|
|
stringdef:
|
|
if is_open_string(left.resultdef) then
|
|
inserttypeconv(right,u8inttype)
|
|
else if is_shortstring(left.resultdef) then
|
|
{Convert shortstring indexes to 0..length.}
|
|
inserttypeconv(right,Torddef.create(u8bit,0,int64(Tstringdef(left.resultdef).len)))
|
|
else
|
|
{Convert indexes into dynamically allocated strings to aword.}
|
|
inserttypeconv(right,uinttype);
|
|
else
|
|
{Others, i.e. pointer indexes to aint.}
|
|
inserttypeconv(right,sinttype);
|
|
end;
|
|
|
|
{ although we never put regular arrays or shortstrings in registers,
|
|
it's possible that another type was typecasted to a small record
|
|
that has a field of one of these types -> in that case the record
|
|
can't be a regvar either }
|
|
if ((left.resultdef.typ=arraydef) and
|
|
not is_special_array(left.resultdef)) or
|
|
((left.resultdef.typ=stringdef) and
|
|
(tstringdef(left.resultdef).stringtype in [st_shortstring,st_longstring])) then
|
|
make_not_regable(left,[ra_addr_regable]);
|
|
|
|
case left.resultdef.typ of
|
|
arraydef :
|
|
begin
|
|
{ check type of the index value }
|
|
if (compare_defs(right.resultdef,tarraydef(left.resultdef).rangedef,right.nodetype)=te_incompatible) then
|
|
IncompatibleTypes(right.resultdef,tarraydef(left.resultdef).rangedef);
|
|
if right.nodetype=rangen then
|
|
resultdef:=left.resultdef
|
|
else
|
|
resultdef:=Tarraydef(left.resultdef).elementdef;
|
|
|
|
{ if we are range checking an open array or array of const, we }
|
|
{ need to load the high parameter. If the current procedure is }
|
|
{ nested inside the procedure to which the open array/of const }
|
|
{ was passed, then the high parameter must not be a regvar. }
|
|
{ So create a loadnode for the high parameter here and }
|
|
{ typecheck it, then the loadnode will make the high parameter }
|
|
{ not regable. Otherwise this would only happen inside pass_2, }
|
|
{ which is too late since by then the regvars are already }
|
|
{ assigned (pass_1 is also already too late, because then the }
|
|
{ regvars of the parent are also already assigned). }
|
|
{ webtbs/tw8975 }
|
|
if (cs_check_range in current_settings.localswitches) and
|
|
(is_open_array(left.resultdef) or
|
|
is_array_of_const(left.resultdef)) and
|
|
{ cdecl functions don't have high() so we can not check the range }
|
|
{ (can't use current_procdef, since it may be a nested procedure) }
|
|
not(tprocdef(tparasymtable(tparavarsym(tloadnode(left).symtableentry).owner).defowner).proccalloption in cdecl_pocalls) then
|
|
begin
|
|
{ load_high_value_node already typechecks }
|
|
hightree:=load_high_value_node(tparavarsym(tloadnode(left).symtableentry));
|
|
hightree.free;
|
|
end;
|
|
|
|
|
|
end;
|
|
pointerdef :
|
|
begin
|
|
{ are we accessing a pointer[], then convert the pointer to
|
|
an array first, in FPC this is allowed for all pointers
|
|
(except voidpointer) in delphi/tp7 it's only allowed for pchars. }
|
|
if not is_voidpointer(left.resultdef) and
|
|
(
|
|
(cs_pointermath in current_settings.localswitches) or
|
|
tpointerdef(left.resultdef).has_pointer_math or
|
|
is_pchar(left.resultdef) or
|
|
is_pwidechar(left.resultdef)
|
|
) then
|
|
begin
|
|
{ convert pointer to array }
|
|
htype:=tarraydef.create_from_pointer(tpointerdef(left.resultdef).pointeddef);
|
|
inserttypeconv(left,htype);
|
|
if right.nodetype=rangen then
|
|
resultdef:=htype
|
|
else
|
|
resultdef:=tarraydef(htype).elementdef;
|
|
end
|
|
else
|
|
CGMessage(type_e_array_required);
|
|
end;
|
|
stringdef :
|
|
begin
|
|
case tstringdef(left.resultdef).stringtype of
|
|
st_unicodestring,
|
|
st_widestring :
|
|
elementdef:=cwidechartype;
|
|
st_ansistring :
|
|
elementdef:=cchartype;
|
|
st_longstring :
|
|
elementdef:=cchartype;
|
|
st_shortstring :
|
|
elementdef:=cchartype;
|
|
end;
|
|
if right.nodetype=rangen then
|
|
begin
|
|
htype:=Tarraydef.create_from_pointer(elementdef);
|
|
resultdef:=htype;
|
|
end
|
|
else
|
|
begin
|
|
{ indexed access to 0 element is only allowed for shortstrings }
|
|
if (right.nodetype=ordconstn) and
|
|
(Tordconstnode(right).value.svalue=0) and
|
|
not is_shortstring(left.resultdef) then
|
|
CGMessage(cg_e_can_access_element_zero);
|
|
resultdef:=elementdef;
|
|
end;
|
|
end;
|
|
variantdef :
|
|
resultdef:=cvarianttype;
|
|
else
|
|
CGMessage(type_e_array_required);
|
|
end;
|
|
end;
|
|
|
|
procedure Tvecnode.mark_write;
|
|
|
|
begin
|
|
include(flags,nf_write);
|
|
end;
|
|
|
|
function tvecnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
firstpass(left);
|
|
firstpass(right);
|
|
if codegenerror then
|
|
exit;
|
|
|
|
if (nf_callunique in flags) and
|
|
(is_ansistring(left.resultdef) or
|
|
is_unicodestring(left.resultdef) or
|
|
(is_widestring(left.resultdef) and not(tf_winlikewidestring in target_info.flags))) then
|
|
begin
|
|
left := ctypeconvnode.create_internal(ccallnode.createintern('fpc_'+tstringdef(left.resultdef).stringtypname+'_unique',
|
|
ccallparanode.create(
|
|
ctypeconvnode.create_internal(left,voidpointertype),nil)),
|
|
left.resultdef);
|
|
firstpass(left);
|
|
{ double resultdef passes somwhere else may cause this to be }
|
|
{ reset though :/ }
|
|
exclude(flags,nf_callunique);
|
|
end
|
|
else if is_widestring(left.resultdef) and (tf_winlikewidestring in target_info.flags) then
|
|
exclude(flags,nf_callunique);
|
|
|
|
{ a range node as array index can only appear in function calls, and
|
|
those convert the range node into something else in
|
|
tcallnode.gen_high_tree }
|
|
if (right.nodetype=rangen) then
|
|
CGMessagePos(right.fileinfo,parser_e_illegal_expression)
|
|
else if (not is_packed_array(left.resultdef)) or
|
|
((tarraydef(left.resultdef).elepackedbitsize mod 8) = 0) then
|
|
if left.expectloc=LOC_CREFERENCE then
|
|
expectloc:=LOC_CREFERENCE
|
|
else
|
|
expectloc:=LOC_REFERENCE
|
|
else
|
|
if left.expectloc=LOC_CREFERENCE then
|
|
expectloc:=LOC_CSUBSETREF
|
|
else
|
|
expectloc:=LOC_SUBSETREF;
|
|
end;
|
|
|
|
|
|
{*****************************************************************************
|
|
TWITHNODE
|
|
*****************************************************************************}
|
|
|
|
constructor twithnode.create(l:tnode);
|
|
begin
|
|
inherited create(withn,l);
|
|
fileinfo:=l.fileinfo;
|
|
end;
|
|
|
|
|
|
destructor twithnode.destroy;
|
|
begin
|
|
inherited destroy;
|
|
end;
|
|
|
|
|
|
constructor twithnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuload(t,ppufile);
|
|
end;
|
|
|
|
|
|
procedure twithnode.ppuwrite(ppufile:tcompilerppufile);
|
|
begin
|
|
inherited ppuwrite(ppufile);
|
|
end;
|
|
|
|
|
|
function twithnode.dogetcopy : tnode;
|
|
var
|
|
p : twithnode;
|
|
begin
|
|
p:=twithnode(inherited dogetcopy);
|
|
result:=p;
|
|
end;
|
|
|
|
|
|
function twithnode.pass_typecheck:tnode;
|
|
begin
|
|
result:=nil;
|
|
resultdef:=voidtype;
|
|
if assigned(left) then
|
|
typecheckpass(left);
|
|
end;
|
|
|
|
|
|
function twithnode.pass_1 : tnode;
|
|
begin
|
|
result:=nil;
|
|
expectloc:=LOC_VOID;
|
|
end;
|
|
|
|
|
|
function twithnode.docompare(p: tnode): boolean;
|
|
begin
|
|
docompare :=
|
|
inherited docompare(p);
|
|
end;
|
|
|
|
function is_big_untyped_addrnode(p: tnode): boolean;
|
|
begin
|
|
is_big_untyped_addrnode:=(p.nodetype=addrn) and
|
|
not (nf_typedaddr in p.flags) and (taddrnode(p).left.resultdef.size > 1);
|
|
end;
|
|
|
|
end.
|