mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-01 20:13:43 +02:00
940 lines
34 KiB
ObjectPascal
940 lines
34 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 1998-2000 by Florian Klaempfl
|
|
|
|
This unit exports some help routines for the type checking
|
|
|
|
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 htypechk;
|
|
|
|
{$i defines.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
tokens,
|
|
node,
|
|
symtype,symdef;
|
|
|
|
type
|
|
Ttok2nodeRec=record
|
|
tok : ttoken;
|
|
nod : tnodetype;
|
|
op_overloading_supported : boolean;
|
|
end;
|
|
|
|
const
|
|
tok2nodes=25;
|
|
tok2node:array[1..tok2nodes] of ttok2noderec=(
|
|
(tok:_PLUS ;nod:addn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_MINUS ;nod:subn;op_overloading_supported:true), { binary and unary overloading supported }
|
|
(tok:_STAR ;nod:muln;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_SLASH ;nod:slashn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_EQUAL ;nod:equaln;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_GT ;nod:gtn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_LT ;nod:ltn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_GTE ;nod:gten;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_LTE ;nod:lten;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_SYMDIF ;nod:symdifn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_STARSTAR;nod:starstarn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_OP_AS ;nod:asn;op_overloading_supported:false), { binary overloading NOT supported }
|
|
(tok:_OP_IN ;nod:inn;op_overloading_supported:false), { binary overloading NOT supported }
|
|
(tok:_OP_IS ;nod:isn;op_overloading_supported:false), { binary overloading NOT supported }
|
|
(tok:_OP_OR ;nod:orn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_OP_AND ;nod:andn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_OP_DIV ;nod:divn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_OP_NOT ;nod:notn;op_overloading_supported:true), { unary overloading supported }
|
|
(tok:_OP_MOD ;nod:modn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_OP_SHL ;nod:shln;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_OP_SHR ;nod:shrn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_OP_XOR ;nod:xorn;op_overloading_supported:true), { binary overloading supported }
|
|
(tok:_ASSIGNMENT;nod:assignn;op_overloading_supported:true), { unary overloading supported }
|
|
(tok:_CARET ;nod:caretn;op_overloading_supported:false), { binary overloading NOT supported }
|
|
(tok:_UNEQUAL ;nod:unequaln;op_overloading_supported:false) { binary overloading NOT supported overload = instead }
|
|
);
|
|
const
|
|
{ firstcallparan without varspez we don't count the ref }
|
|
{$ifdef extdebug}
|
|
count_ref : boolean = true;
|
|
{$endif def extdebug}
|
|
get_para_resulttype : boolean = false;
|
|
allow_array_constructor : boolean = false;
|
|
|
|
{ is overloading of this operator allowed for this
|
|
binary operator }
|
|
function isbinaryoperatoroverloadable(ld, rd,dd : pdef;
|
|
treetyp : tnodetype) : boolean;
|
|
|
|
{ is overloading of this operator allowed for this
|
|
unary operator }
|
|
function isunaryoperatoroverloadable(rd,dd : pdef;
|
|
treetyp : tnodetype) : boolean;
|
|
|
|
{ check operator args and result type }
|
|
function isoperatoracceptable(pf : pprocdef; optoken : ttoken) : boolean;
|
|
function isbinaryoverloaded(var t : tnode) : boolean;
|
|
|
|
{ Register Allocation }
|
|
procedure make_not_regable(p : tnode);
|
|
procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word);
|
|
|
|
{ subroutine handling }
|
|
procedure test_protected_sym(sym : psym);
|
|
procedure test_protected(p : tnode);
|
|
function valid_for_formal_var(p : tnode) : boolean;
|
|
function valid_for_formal_const(p : tnode) : boolean;
|
|
function is_procsym_load(p:tnode):boolean;
|
|
function is_procsym_call(p:tnode):boolean;
|
|
procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef);
|
|
function valid_for_assign(p:tnode;allowprop:boolean):boolean;
|
|
{ sets the callunique flag, if the node is a vecn, }
|
|
{ takes care of type casts etc. }
|
|
procedure set_unique(p : tnode);
|
|
|
|
{ sets funcret_is_valid to true, if p contains a funcref node }
|
|
procedure set_funcret_is_valid(p : tnode);
|
|
|
|
{
|
|
type
|
|
tvarstaterequire = (vsr_can_be_undefined,vsr_must_be_valid,
|
|
vsr_is_used_after,vsr_must_be_valid_and_is_used_after); }
|
|
|
|
{ sets varsym varstate field correctly }
|
|
procedure unset_varstate(p : tnode);
|
|
procedure set_varstate(p : tnode;must_be_valid : boolean);
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
globtype,systems,
|
|
cutils,cobjects,verbose,globals,
|
|
symconst,symsym,symtable,
|
|
types,pass_1,cpubase,
|
|
ncnv,nld,
|
|
nmem,ncal,nmat,
|
|
{$ifdef newcg}
|
|
cgbase
|
|
{$else}
|
|
hcodegen
|
|
{$endif}
|
|
;
|
|
|
|
{ ld is the left type definition
|
|
rd the right type definition
|
|
dd the result type definition or voiddef if unkown }
|
|
function isbinaryoperatoroverloadable(ld, rd, dd : pdef;
|
|
treetyp : tnodetype) : boolean;
|
|
begin
|
|
isbinaryoperatoroverloadable:=
|
|
(treetyp=starstarn) or
|
|
(ld^.deftype=recorddef) or
|
|
(rd^.deftype=recorddef) or
|
|
((rd^.deftype=pointerdef) and
|
|
not(is_pchar(rd) and
|
|
(is_chararray(ld) or
|
|
(ld^.deftype=stringdef) or
|
|
(treetyp=addn))) and
|
|
(not(ld^.deftype in [pointerdef,objectdef,classrefdef,procvardef]) or
|
|
not (treetyp in [equaln,unequaln,gtn,gten,ltn,lten,subn])
|
|
) and
|
|
(not is_integer(ld) or not (treetyp in [addn,subn]))
|
|
) or
|
|
((ld^.deftype=pointerdef) and
|
|
not(is_pchar(ld) and
|
|
(is_chararray(rd) or
|
|
(rd^.deftype=stringdef) or
|
|
(treetyp=addn))) and
|
|
(not(rd^.deftype in [stringdef,pointerdef,objectdef,classrefdef,procvardef]) and
|
|
((not is_integer(rd) and (rd^.deftype<>objectdef)
|
|
and (rd^.deftype<>classrefdef)) or
|
|
not (treetyp in [equaln,unequaln,gtn,gten,ltn,lten,addn,subn])
|
|
)
|
|
)
|
|
) or
|
|
{ array def, but not mmx or chararray+[char,string,chararray] }
|
|
((ld^.deftype=arraydef) and
|
|
not((cs_mmx in aktlocalswitches) and
|
|
is_mmx_able_array(ld)) and
|
|
not(is_chararray(ld) and
|
|
(is_char(rd) or
|
|
is_pchar(rd) or
|
|
(rd^.deftype=stringdef) or
|
|
is_chararray(rd)))
|
|
) or
|
|
((rd^.deftype=arraydef) and
|
|
not((cs_mmx in aktlocalswitches) and
|
|
is_mmx_able_array(rd)) and
|
|
not(is_chararray(rd) and
|
|
(is_char(ld) or
|
|
is_pchar(ld) or
|
|
(ld^.deftype=stringdef) or
|
|
is_chararray(ld)))
|
|
) or
|
|
{ <> and = are defined for classes }
|
|
(
|
|
(ld^.deftype=objectdef) and
|
|
not((treetyp in [equaln,unequaln]) and is_class_or_interface(ld))
|
|
) or
|
|
(
|
|
(rd^.deftype=objectdef) and
|
|
not((treetyp in [equaln,unequaln]) and is_class_or_interface(rd))
|
|
)
|
|
or
|
|
{ allow other operators that + on strings }
|
|
(
|
|
(is_char(rd) or
|
|
is_pchar(rd) or
|
|
(rd^.deftype=stringdef) or
|
|
is_chararray(rd) or
|
|
is_char(ld) or
|
|
is_pchar(ld) or
|
|
(ld^.deftype=stringdef) or
|
|
is_chararray(ld)
|
|
) and
|
|
not(treetyp in [addn,equaln,unequaln,gtn,gten,ltn,lten]) and
|
|
not(is_pchar(ld) and
|
|
(is_integer(rd) or (rd^.deftype=pointerdef)) and
|
|
(treetyp=subn)
|
|
)
|
|
);
|
|
end;
|
|
|
|
|
|
function isunaryoperatoroverloadable(rd,dd : pdef;
|
|
treetyp : tnodetype) : boolean;
|
|
begin
|
|
isunaryoperatoroverloadable:=false;
|
|
{ what assignment overloading should be allowed ?? }
|
|
if (treetyp=assignn) then
|
|
begin
|
|
isunaryoperatoroverloadable:=true;
|
|
{ this already get tbs0261 to fail
|
|
isunaryoperatoroverloadable:=not is_equal(rd,dd); PM }
|
|
end
|
|
{ should we force that rd and dd are equal ?? }
|
|
else if (treetyp=subn { unaryminusn }) then
|
|
begin
|
|
isunaryoperatoroverloadable:=
|
|
not is_integer(rd) and not (rd^.deftype=floatdef)
|
|
{$ifdef SUPPORT_MMX}
|
|
and not ((cs_mmx in aktlocalswitches) and
|
|
is_mmx_able_array(rd))
|
|
{$endif SUPPORT_MMX}
|
|
;
|
|
end
|
|
else if (treetyp=notn) then
|
|
begin
|
|
isunaryoperatoroverloadable:=not is_integer(rd) and not is_boolean(rd)
|
|
{$ifdef SUPPORT_MMX}
|
|
and not ((cs_mmx in aktlocalswitches) and
|
|
is_mmx_able_array(rd))
|
|
{$endif SUPPORT_MMX}
|
|
;
|
|
end;
|
|
end;
|
|
|
|
function isoperatoracceptable(pf : pprocdef; optoken : ttoken) : boolean;
|
|
var
|
|
ld,rd,dd : pdef;
|
|
i : longint;
|
|
begin
|
|
case pf^.parast^.symindex^.count of
|
|
2 : begin
|
|
isoperatoracceptable:=false;
|
|
for i:=1 to tok2nodes do
|
|
if tok2node[i].tok=optoken then
|
|
begin
|
|
ld:=pvarsym(pf^.parast^.symindex^.first)^.vartype.def;
|
|
rd:=pvarsym(pf^.parast^.symindex^.first^.indexnext)^.vartype.def;
|
|
dd:=pf^.rettype.def;
|
|
isoperatoracceptable:=
|
|
tok2node[i].op_overloading_supported and
|
|
isbinaryoperatoroverloadable(ld,rd,dd,tok2node[i].nod);
|
|
break;
|
|
end;
|
|
end;
|
|
1 : begin
|
|
rd:=pvarsym(pf^.parast^.symindex^.first)^.vartype.def;
|
|
dd:=pf^.rettype.def;
|
|
for i:=1 to tok2nodes do
|
|
if tok2node[i].tok=optoken then
|
|
begin
|
|
isoperatoracceptable:=
|
|
tok2node[i].op_overloading_supported and
|
|
isunaryoperatoroverloadable(rd,dd,tok2node[i].nod);
|
|
break;
|
|
end;
|
|
end;
|
|
else
|
|
isoperatoracceptable:=false;
|
|
end;
|
|
end;
|
|
|
|
function isbinaryoverloaded(var t : tnode) : boolean;
|
|
|
|
var
|
|
rd,ld : pdef;
|
|
optoken : ttoken;
|
|
ht : tnode;
|
|
begin
|
|
isbinaryoverloaded:=false;
|
|
{ overloaded operator ? }
|
|
{ load easier access variables }
|
|
rd:=tbinarynode(t).right.resulttype;
|
|
ld:=tbinarynode(t).left.resulttype;
|
|
if isbinaryoperatoroverloadable(ld,rd,voiddef,t.nodetype) then
|
|
begin
|
|
isbinaryoverloaded:=true;
|
|
{!!!!!!!!! handle paras }
|
|
case t.nodetype of
|
|
addn:
|
|
optoken:=_PLUS;
|
|
subn:
|
|
optoken:=_MINUS;
|
|
muln:
|
|
optoken:=_STAR;
|
|
starstarn:
|
|
optoken:=_STARSTAR;
|
|
slashn:
|
|
optoken:=_SLASH;
|
|
ltn:
|
|
optoken:=tokens._lt;
|
|
gtn:
|
|
optoken:=tokens._gt;
|
|
lten:
|
|
optoken:=_lte;
|
|
gten:
|
|
optoken:=_gte;
|
|
equaln,unequaln :
|
|
optoken:=_EQUAL;
|
|
symdifn :
|
|
optoken:=_SYMDIF;
|
|
modn :
|
|
optoken:=_OP_MOD;
|
|
orn :
|
|
optoken:=_OP_OR;
|
|
xorn :
|
|
optoken:=_OP_XOR;
|
|
andn :
|
|
optoken:=_OP_AND;
|
|
divn :
|
|
optoken:=_OP_DIV;
|
|
shln :
|
|
optoken:=_OP_SHL;
|
|
shrn :
|
|
optoken:=_OP_SHR;
|
|
else
|
|
exit;
|
|
end;
|
|
{ the nil as symtable signs firstcalln that this is
|
|
an overloaded operator }
|
|
ht:=gencallnode(overloaded_operators[optoken],nil);
|
|
{ we have to convert p^.left and p^.right into
|
|
callparanodes }
|
|
if tcallnode(ht).symtableprocentry=nil then
|
|
begin
|
|
CGMessage(parser_e_operator_not_overloaded);
|
|
ht.free;
|
|
end
|
|
else
|
|
begin
|
|
inc(tcallnode(ht).symtableprocentry^.refs);
|
|
tcallnode(ht).left:=gencallparanode(tbinarynode(t).right,
|
|
gencallparanode(tbinarynode(t).left,nil));
|
|
if t.nodetype=unequaln then
|
|
ht:=cnotnode.create(ht);
|
|
firstpass(ht);
|
|
t:=ht;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{****************************************************************************
|
|
Register Calculation
|
|
****************************************************************************}
|
|
|
|
{ marks an lvalue as "unregable" }
|
|
procedure make_not_regable(p : tnode);
|
|
begin
|
|
case p.nodetype of
|
|
typeconvn :
|
|
make_not_regable(ttypeconvnode(p).left);
|
|
loadn :
|
|
if tloadnode(p).symtableentry^.typ=varsym then
|
|
pvarsym(tloadnode(p).symtableentry)^.varoptions:=pvarsym(tloadnode(p).symtableentry)^.varoptions-[vo_regable,vo_fpuregable];
|
|
end;
|
|
end;
|
|
|
|
|
|
{ calculates the needed registers for a binary operator }
|
|
procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word);
|
|
|
|
begin
|
|
p.left_right_max;
|
|
|
|
{ Only when the difference between the left and right registers < the
|
|
wanted registers allocate the amount of registers }
|
|
|
|
if assigned(p.left) then
|
|
begin
|
|
if assigned(p.right) then
|
|
begin
|
|
if (abs(p.left.registers32-p.right.registers32)<r32) then
|
|
inc(p.registers32,r32);
|
|
if (abs(p.left.registersfpu-p.right.registersfpu)<fpu) then
|
|
inc(p.registersfpu,fpu);
|
|
{$ifdef SUPPORT_MMX}
|
|
if (abs(p.left.registersmmx-p.right.registersmmx)<mmx) then
|
|
inc(p.registersmmx,mmx);
|
|
{$endif SUPPORT_MMX}
|
|
{ the following is a little bit guessing but I think }
|
|
{ it's the only way to solve same internalerrors: }
|
|
{ if the left and right node both uses registers }
|
|
{ and return a mem location, but the current node }
|
|
{ doesn't use an integer register we get probably }
|
|
{ trouble when restoring a node }
|
|
if (p.left.registers32=p.right.registers32) and
|
|
(p.registers32=p.left.registers32) and
|
|
(p.registers32>0) and
|
|
(p.left.location.loc in [LOC_REFERENCE,LOC_MEM]) and
|
|
(p.right.location.loc in [LOC_REFERENCE,LOC_MEM]) then
|
|
inc(p.registers32);
|
|
end
|
|
else
|
|
begin
|
|
if (p.left.registers32<r32) then
|
|
inc(p.registers32,r32);
|
|
if (p.left.registersfpu<fpu) then
|
|
inc(p.registersfpu,fpu);
|
|
{$ifdef SUPPORT_MMX}
|
|
if (p.left.registersmmx<mmx) then
|
|
inc(p.registersmmx,mmx);
|
|
{$endif SUPPORT_MMX}
|
|
end;
|
|
end;
|
|
|
|
{ error CGMessage, if more than 8 floating point }
|
|
{ registers are needed }
|
|
if p.registersfpu>8 then
|
|
CGMessage(cg_e_too_complex_expr);
|
|
end;
|
|
|
|
{****************************************************************************
|
|
Subroutine Handling
|
|
****************************************************************************}
|
|
|
|
{ protected field handling
|
|
protected field can not appear in
|
|
var parameters of function !!
|
|
this can only be done after we have determined the
|
|
overloaded function
|
|
this is the reason why it is not in the parser, PM }
|
|
|
|
procedure test_protected_sym(sym : psym);
|
|
begin
|
|
if (sp_protected in sym^.symoptions) and
|
|
((sym^.owner^.symtabletype=unitsymtable) or
|
|
((sym^.owner^.symtabletype=objectsymtable) and
|
|
(pobjectdef(sym^.owner^.defowner)^.owner^.symtabletype=unitsymtable))
|
|
) then
|
|
CGMessage(parser_e_cant_access_protected_member);
|
|
end;
|
|
|
|
|
|
procedure test_protected(p : tnode);
|
|
begin
|
|
case p.nodetype of
|
|
loadn : test_protected_sym(tloadnode(p).symtableentry);
|
|
typeconvn : test_protected(ttypeconvnode(p).left);
|
|
derefn : test_protected(tderefnode(p).left);
|
|
subscriptn : begin
|
|
{ test_protected(p.left);
|
|
Is a field of a protected var
|
|
also protected ??? PM }
|
|
test_protected_sym(tsubscriptnode(p).vs);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function valid_for_formal_var(p : tnode) : boolean;
|
|
var
|
|
v : boolean;
|
|
begin
|
|
case p.nodetype of
|
|
loadn :
|
|
v:=(tloadnode(p).symtableentry^.typ in [typedconstsym,varsym]);
|
|
typeconvn :
|
|
v:=valid_for_formal_var(ttypeconvnode(p).left);
|
|
derefn,
|
|
subscriptn,
|
|
vecn,
|
|
funcretn,
|
|
selfn :
|
|
v:=true;
|
|
calln : { procvars are callnodes first }
|
|
v:=assigned(tcallnode(p).right) and not assigned(tcallnode(p).left);
|
|
addrn :
|
|
begin
|
|
{ addrn is not allowed as this generate a constant value,
|
|
but a tp procvar are allowed (PFV) }
|
|
if nf_procvarload in p.flags then
|
|
v:=true
|
|
else
|
|
v:=false;
|
|
end;
|
|
else
|
|
v:=false;
|
|
end;
|
|
valid_for_formal_var:=v;
|
|
end;
|
|
|
|
function valid_for_formal_const(p : tnode) : boolean;
|
|
var
|
|
v : boolean;
|
|
begin
|
|
{ p must have been firstpass'd before }
|
|
{ accept about anything but not a statement ! }
|
|
case p.nodetype of
|
|
calln,
|
|
statementn,
|
|
addrn :
|
|
begin
|
|
{ addrn is not allowed as this generate a constant value,
|
|
but a tp procvar are allowed (PFV) }
|
|
if nf_procvarload in p.flags then
|
|
v:=true
|
|
else
|
|
v:=false;
|
|
end;
|
|
else
|
|
v:=true;
|
|
end;
|
|
valid_for_formal_const:=v;
|
|
end;
|
|
|
|
function is_procsym_load(p:tnode):boolean;
|
|
begin
|
|
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)) ;
|
|
end;
|
|
|
|
{ change a proc call to a procload for assignment to a procvar }
|
|
{ this can only happen for proc/function without arguments }
|
|
function is_procsym_call(p:tnode):boolean;
|
|
begin
|
|
is_procsym_call:=(p.nodetype=calln) and (tcallnode(p).left=nil) and
|
|
(((tcallnode(p).symtableprocentry^.typ=procsym) and (tcallnode(p).right=nil)) or
|
|
(assigned(tcallnode(p).right) and (tcallnode(tcallnode(p).right).symtableprocentry^.typ=varsym)));
|
|
end;
|
|
|
|
|
|
{ local routines can't be assigned to procvars }
|
|
procedure test_local_to_procvar(from_def:pprocvardef;to_def:pdef);
|
|
begin
|
|
if (from_def^.symtablelevel>1) and (to_def^.deftype=procvardef) then
|
|
CGMessage(type_e_cannot_local_proc_to_procvar);
|
|
end;
|
|
|
|
|
|
function valid_for_assign(p:tnode;allowprop:boolean):boolean;
|
|
var
|
|
hp : tnode;
|
|
gotwith,
|
|
gotsubscript,
|
|
gotpointer,
|
|
gotclass,
|
|
gotderef : boolean;
|
|
begin
|
|
valid_for_assign:=false;
|
|
gotsubscript:=false;
|
|
gotderef:=false;
|
|
gotclass:=false;
|
|
gotpointer:=false;
|
|
gotwith:=false;
|
|
hp:=p;
|
|
while assigned(hp) do
|
|
begin
|
|
{ property allowed? calln has a property check itself }
|
|
if (not allowprop) and
|
|
(nf_isproperty in hp.flags) and
|
|
(hp.nodetype<>calln) then
|
|
begin
|
|
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
|
|
exit;
|
|
end;
|
|
case hp.nodetype of
|
|
derefn :
|
|
begin
|
|
gotderef:=true;
|
|
hp:=tderefnode(hp).left;
|
|
end;
|
|
typeconvn :
|
|
begin
|
|
case hp.resulttype^.deftype of
|
|
pointerdef :
|
|
gotpointer:=true;
|
|
objectdef :
|
|
gotclass:=is_class_or_interface(hp.resulttype);
|
|
classrefdef :
|
|
gotclass:=true;
|
|
arraydef :
|
|
begin
|
|
{ pointer -> array conversion is done then we need to see it
|
|
as a deref, because a ^ is then not required anymore }
|
|
if (ttypeconvnode(hp).left.resulttype^.deftype=pointerdef) then
|
|
gotderef:=true;
|
|
end;
|
|
end;
|
|
hp:=ttypeconvnode(hp).left;
|
|
end;
|
|
vecn,
|
|
asn :
|
|
hp:=tunarynode(hp).left;
|
|
subscriptn :
|
|
begin
|
|
gotsubscript:=true;
|
|
hp:=tsubscriptnode(hp).left;
|
|
end;
|
|
subn,
|
|
addn :
|
|
begin
|
|
{ Allow add/sub operators on a pointer, or an integer
|
|
and a pointer typecast and deref has been found }
|
|
if (hp.resulttype^.deftype=pointerdef) or
|
|
(is_integer(hp.resulttype) and gotpointer and gotderef) then
|
|
valid_for_assign:=true
|
|
else
|
|
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
|
|
exit;
|
|
end;
|
|
addrn :
|
|
begin
|
|
if not(gotderef) and
|
|
not(nf_procvarload in hp.flags) then
|
|
CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
|
|
exit;
|
|
end;
|
|
selfn,
|
|
funcretn :
|
|
begin
|
|
valid_for_assign:=true;
|
|
exit;
|
|
end;
|
|
calln :
|
|
begin
|
|
{ check return type }
|
|
case hp.resulttype^.deftype of
|
|
pointerdef :
|
|
gotpointer:=true;
|
|
objectdef :
|
|
gotclass:=is_class_or_interface(hp.resulttype);
|
|
recorddef, { handle record like class it needs a subscription }
|
|
classrefdef :
|
|
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,
|
|
3. property is allowed }
|
|
if (gotpointer and gotderef) or
|
|
(gotclass and (gotsubscript or gotwith)) or
|
|
((nf_isproperty in hp.flags) and allowprop) then
|
|
valid_for_assign:=true
|
|
else
|
|
CGMessagePos(hp.fileinfo,type_e_argument_cant_be_assigned);
|
|
exit;
|
|
end;
|
|
loadn :
|
|
begin
|
|
case tloadnode(hp).symtableentry^.typ of
|
|
absolutesym,
|
|
varsym :
|
|
begin
|
|
if (pvarsym(tloadnode(hp).symtableentry)^.varspez=vs_const) then
|
|
begin
|
|
{ allow p^:= constructions with p is const parameter }
|
|
if gotderef then
|
|
valid_for_assign:=true
|
|
else
|
|
CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const);
|
|
exit;
|
|
end;
|
|
{ Are we at a with symtable, then we need to process the
|
|
withrefnode also to check for maybe a const load }
|
|
if (tloadnode(hp).symtable^.symtabletype=withsymtable) then
|
|
begin
|
|
{ continue with processing the withref node }
|
|
hp:=tnode(pwithsymtable(tloadnode(hp).symtable)^.withrefnode);
|
|
gotwith:=true;
|
|
end
|
|
else
|
|
begin
|
|
{ set the assigned flag for varsyms }
|
|
if (pvarsym(tloadnode(hp).symtableentry)^.varstate=vs_declared) then
|
|
pvarsym(tloadnode(hp).symtableentry)^.varstate:=vs_assigned;
|
|
valid_for_assign:=true;
|
|
exit;
|
|
end;
|
|
end;
|
|
funcretsym,
|
|
typedconstsym :
|
|
begin
|
|
valid_for_assign:=true;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
else
|
|
begin
|
|
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure set_varstate(p : tnode;must_be_valid : boolean);
|
|
var
|
|
hsym : pvarsym;
|
|
begin
|
|
while assigned(p) do
|
|
begin
|
|
if (nf_varstateset in p.flags) then
|
|
exit;
|
|
include(p.flags,nf_varstateset);
|
|
case p.nodetype of
|
|
typeconvn :
|
|
begin
|
|
case ttypeconvnode(p).convtype of
|
|
tc_cchar_2_pchar,
|
|
tc_cstring_2_pchar,
|
|
tc_array_2_pointer :
|
|
must_be_valid:=false;
|
|
tc_pchar_2_string,
|
|
tc_pointer_2_array :
|
|
must_be_valid:=true;
|
|
end;
|
|
p:=tunarynode(p).left;
|
|
end;
|
|
subscriptn :
|
|
p:=tunarynode(p).left;
|
|
vecn:
|
|
begin
|
|
set_varstate(tbinarynode(p).right,true);
|
|
if not(tunarynode(p).left.resulttype^.deftype in [stringdef,arraydef]) then
|
|
must_be_valid:=true;
|
|
p:=tunarynode(p).left;
|
|
end;
|
|
{ do not parse calln }
|
|
calln :
|
|
break;
|
|
callparan :
|
|
begin
|
|
set_varstate(tbinarynode(p).right,must_be_valid);
|
|
p:=tunarynode(p).left;
|
|
end;
|
|
loadn :
|
|
begin
|
|
if (tloadnode(p).symtableentry^.typ=varsym) then
|
|
begin
|
|
hsym:=pvarsym(tloadnode(p).symtableentry);
|
|
if must_be_valid and (nf_first in p.flags) then
|
|
begin
|
|
if (hsym^.varstate=vs_declared_and_first_found) or
|
|
(hsym^.varstate=vs_set_but_first_not_passed) then
|
|
begin
|
|
if (assigned(hsym^.owner) and
|
|
assigned(aktprocsym) and
|
|
(hsym^.owner = aktprocsym^.definition^.localst)) then
|
|
begin
|
|
if tloadnode(p).symtable^.symtabletype=localsymtable then
|
|
CGMessage1(sym_n_uninitialized_local_variable,hsym^.realname)
|
|
else
|
|
CGMessage1(sym_n_uninitialized_variable,hsym^.realname);
|
|
end;
|
|
end;
|
|
end;
|
|
if (nf_first in p.flags) then
|
|
begin
|
|
if hsym^.varstate=vs_declared_and_first_found then
|
|
begin
|
|
{ this can only happen at left of an assignment, no ? PM }
|
|
if (parsing_para_level=0) and not must_be_valid then
|
|
hsym^.varstate:=vs_assigned
|
|
else
|
|
hsym^.varstate:=vs_used;
|
|
end
|
|
else
|
|
if hsym^.varstate=vs_set_but_first_not_passed then
|
|
hsym^.varstate:=vs_used;
|
|
exclude(p.flags,nf_first);
|
|
end
|
|
else
|
|
begin
|
|
if (hsym^.varstate=vs_assigned) and
|
|
(must_be_valid or (parsing_para_level>0) or
|
|
(p.resulttype^.deftype=procvardef)) then
|
|
hsym^.varstate:=vs_used;
|
|
if (hsym^.varstate=vs_declared_and_first_found) and
|
|
(must_be_valid or (parsing_para_level>0) or
|
|
(p.resulttype^.deftype=procvardef)) then
|
|
hsym^.varstate:=vs_set_but_first_not_passed;
|
|
end;
|
|
end;
|
|
break;
|
|
end;
|
|
funcretn:
|
|
begin
|
|
{ no claim if setting higher return value_str }
|
|
if must_be_valid and
|
|
(procinfo=pprocinfo(tfuncretnode(p).funcretprocinfo)) and
|
|
((procinfo^.funcret_state=vs_declared) or
|
|
((nf_is_first_funcret in p.flags) and
|
|
(procinfo^.funcret_state=vs_declared_and_first_found))) then
|
|
begin
|
|
CGMessage(sym_w_function_result_not_set);
|
|
{ avoid multiple warnings }
|
|
procinfo^.funcret_state:=vs_assigned;
|
|
end;
|
|
if (nf_is_first_funcret in p.flags) and not must_be_valid then
|
|
pprocinfo(tfuncretnode(p).funcretprocinfo)^.funcret_state:=vs_assigned;
|
|
break;
|
|
end;
|
|
else
|
|
break;
|
|
end;{case }
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure unset_varstate(p : tnode);
|
|
begin
|
|
while assigned(p) do
|
|
begin
|
|
exclude(p.flags,nf_varstateset);
|
|
case p.nodetype of
|
|
typeconvn,
|
|
subscriptn,
|
|
vecn :
|
|
p:=tunarynode(p).left;
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure set_unique(p : tnode);
|
|
begin
|
|
while assigned(p) do
|
|
begin
|
|
case p.nodetype of
|
|
vecn:
|
|
begin
|
|
include(p.flags,nf_callunique);
|
|
break;
|
|
end;
|
|
typeconvn,
|
|
subscriptn,
|
|
derefn:
|
|
p:=tunarynode(p).left;
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure set_funcret_is_valid(p:tnode);
|
|
begin
|
|
while assigned(p) do
|
|
begin
|
|
case p.nodetype of
|
|
funcretn:
|
|
begin
|
|
if (nf_is_first_funcret in p.flags) then
|
|
pprocinfo(tfuncretnode(p).funcretprocinfo)^.funcret_state:=vs_assigned;
|
|
break;
|
|
end;
|
|
vecn,
|
|
{derefn,}
|
|
typeconvn,
|
|
subscriptn:
|
|
p:=tunarynode(p).left;
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.16 2000-11-13 11:30:54 florian
|
|
* some bugs with interfaces and NIL fixed
|
|
|
|
Revision 1.15 2000/11/12 22:20:37 peter
|
|
* create generic toutputsection for binary writers
|
|
|
|
Revision 1.14 2000/11/04 14:25:19 florian
|
|
+ merged Attila's changes for interfaces, not tested yet
|
|
|
|
Revision 1.13 2000/10/31 22:02:47 peter
|
|
* symtable splitted, no real code changes
|
|
|
|
Revision 1.12 2000/10/14 10:14:47 peter
|
|
* moehrendorf oct 2000 rewrite
|
|
|
|
Revision 1.11 2000/10/01 19:48:23 peter
|
|
* lot of compile updates for cg11
|
|
|
|
Revision 1.10 2000/09/29 15:45:23 florian
|
|
* make cycle fixed
|
|
|
|
Revision 1.9 2000/09/28 19:49:51 florian
|
|
*** empty log message ***
|
|
|
|
Revision 1.8 2000/09/27 18:14:31 florian
|
|
* fixed a lot of syntax errors in the n*.pas stuff
|
|
|
|
Revision 1.7 2000/09/26 20:06:13 florian
|
|
* hmm, still a lot of work to get things compilable
|
|
|
|
Revision 1.6 2000/09/24 15:06:17 peter
|
|
* use defines.inc
|
|
|
|
Revision 1.5 2000/08/27 16:11:51 peter
|
|
* moved some util functions from globals,cobjects to cutils
|
|
* splitted files into finput,fmodule
|
|
|
|
Revision 1.4 2000/08/16 18:33:53 peter
|
|
* splitted namedobjectitem.next into indexnext and listnext so it
|
|
can be used in both lists
|
|
* don't allow "word = word" type definitions (merged)
|
|
|
|
Revision 1.3 2000/08/07 11:31:04 jonas
|
|
* fixed bug in type conversions between enum subranges (it didn't take
|
|
the packenum directive into account)
|
|
+ define PACKENUMFIXED symbol in options.pas
|
|
(merged from fixes branch)
|
|
|
|
Revision 1.2 2000/07/13 11:32:41 michael
|
|
+ removed logs
|
|
} |