mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-31 16:11:33 +01:00
656 lines
28 KiB
ObjectPascal
656 lines
28 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 1996-98 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;
|
|
interface
|
|
|
|
uses
|
|
tree,symtable;
|
|
|
|
const
|
|
{ firstcallparan without varspez we don't count the ref }
|
|
count_ref : boolean = true;
|
|
allow_array_constructor : boolean = false;
|
|
|
|
|
|
{ Conversion }
|
|
function isconvertable(def_from,def_to : pdef;
|
|
var doconv : tconverttype;fromtreetype : ttreetyp;
|
|
explicit : boolean) : boolean;
|
|
|
|
{ Register Allocation }
|
|
procedure make_not_regable(p : ptree);
|
|
procedure left_right_max(p : ptree);
|
|
procedure calcregisters(p : ptree;r32,fpu,mmx : word);
|
|
|
|
{ subroutine handling }
|
|
procedure test_protected_sym(sym : psym);
|
|
procedure test_protected(p : ptree);
|
|
function is_procsym_load(p:Ptree):boolean;
|
|
function is_procsym_call(p:Ptree):boolean;
|
|
function is_assignment_overloaded(from_def,to_def : pdef) : boolean;
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
cobjects,verbose,systems,globals,
|
|
aasm,types,
|
|
hcodegen;
|
|
|
|
{****************************************************************************
|
|
Convert
|
|
****************************************************************************}
|
|
|
|
function isconvertable(def_from,def_to : pdef;
|
|
var doconv : tconverttype;fromtreetype : ttreetyp;
|
|
explicit : boolean) : boolean;
|
|
const
|
|
{ Tbasetype: uauto,uvoid,uchar,
|
|
u8bit,u16bit,u32bit,
|
|
s8bit,s16bit,s32,
|
|
bool8bit,bool16bit,boot32bit }
|
|
basedefconverts : array[tbasetype,tbasetype] of tconverttype =
|
|
{uauto}
|
|
((tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_not_possible,tc_not_possible,tc_not_possible),
|
|
{uvoid}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_not_possible,tc_not_possible,tc_not_possible),
|
|
{uchar}
|
|
(tc_not_possible,tc_not_possible,tc_only_rangechecks32bit,
|
|
tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_not_possible,tc_not_possible,tc_not_possible),
|
|
{u8bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_only_rangechecks32bit,tc_u8bit_2_u16bit,tc_u8bit_2_u32bit,
|
|
tc_only_rangechecks32bit,tc_u8bit_2_s16bit,tc_u8bit_2_s32bit,
|
|
tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
|
|
{u16bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_u16bit_2_u8bit,tc_only_rangechecks32bit,tc_u16bit_2_u32bit,
|
|
tc_u16bit_2_s8bit,tc_only_rangechecks32bit,tc_u16bit_2_s32bit,
|
|
tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
|
|
{u32bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_u32bit_2_u8bit,tc_u32bit_2_u16bit,tc_only_rangechecks32bit,
|
|
tc_u32bit_2_s8bit,tc_u32bit_2_s16bit,tc_only_rangechecks32bit,
|
|
tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
|
|
{s8bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_only_rangechecks32bit,tc_s8bit_2_u16bit,tc_s8bit_2_u32bit,
|
|
tc_only_rangechecks32bit,tc_s8bit_2_s16bit,tc_s8bit_2_s32bit,
|
|
tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
|
|
{s16bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_s16bit_2_u8bit,tc_only_rangechecks32bit,tc_s16bit_2_u32bit,
|
|
tc_s16bit_2_s8bit,tc_only_rangechecks32bit,tc_s16bit_2_s32bit,
|
|
tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
|
|
{s32bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_s32bit_2_u8bit,tc_s32bit_2_u16bit,tc_only_rangechecks32bit,
|
|
tc_s32bit_2_s8bit,tc_s32bit_2_s16bit,tc_only_rangechecks32bit,
|
|
tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
|
|
{bool8bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
|
|
tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
|
|
tc_only_rangechecks32bit,tc_int_2_bool,tc_int_2_bool),
|
|
{bool16bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
|
|
tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
|
|
tc_int_2_bool,tc_only_rangechecks32bit,tc_int_2_bool),
|
|
{bool32bit}
|
|
(tc_not_possible,tc_not_possible,tc_not_possible,
|
|
tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
|
|
tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
|
|
tc_int_2_bool,tc_int_2_bool,tc_only_rangechecks32bit));
|
|
|
|
var
|
|
b : boolean;
|
|
hd1,hd2 : pdef;
|
|
begin
|
|
{ safety check }
|
|
if not(assigned(def_from) and assigned(def_to)) then
|
|
begin
|
|
isconvertable:=false;
|
|
exit;
|
|
end;
|
|
|
|
b:=false;
|
|
{ we walk the wanted (def_to) types and check then the def_from
|
|
types if there is a conversion possible }
|
|
case def_to^.deftype of
|
|
orddef : begin
|
|
if (def_from^.deftype=orddef) then
|
|
begin
|
|
doconv:=basedefconverts[porddef(def_from)^.typ,porddef(def_to)^.typ];
|
|
if (doconv<>tc_not_possible) and
|
|
(explicit or not(doconv in [tc_int_2_bool])) then
|
|
b:=true;
|
|
end;
|
|
end;
|
|
stringdef : begin
|
|
case def_from^.deftype of
|
|
stringdef : begin
|
|
doconv:=tc_string_to_string;
|
|
b:=true;
|
|
end;
|
|
orddef : begin
|
|
{ char to string}
|
|
if is_equal(def_from,cchardef) then
|
|
begin
|
|
doconv:=tc_char_to_string;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
arraydef : begin
|
|
{ string to array of char, the length check is done by the firstpass of this node }
|
|
if is_equal(parraydef(def_from)^.definition,cchardef) then
|
|
begin
|
|
doconv:=tc_chararray_2_string;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
pointerdef : begin
|
|
{ pchar can be assigned to short/ansistrings }
|
|
if is_pchar(def_from) then
|
|
begin
|
|
doconv:=tc_pchar_2_string;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
floatdef : begin
|
|
case def_from^.deftype of
|
|
orddef : begin { ordinal to real }
|
|
if pfloatdef(def_to)^.typ=f32bit then
|
|
doconv:=tc_int_2_fix
|
|
else
|
|
doconv:=tc_int_2_real;
|
|
b:=true;
|
|
end;
|
|
floatdef : begin { 2 float types ? }
|
|
if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
|
|
doconv:=tc_equal
|
|
else
|
|
begin
|
|
if pfloatdef(def_from)^.typ=f32bit then
|
|
doconv:=tc_fix_2_real
|
|
else
|
|
if pfloatdef(def_to)^.typ=f32bit then
|
|
doconv:=tc_real_2_fix
|
|
else
|
|
doconv:=tc_real_2_real;
|
|
{ comp isn't a floating type }
|
|
{$ifdef i386}
|
|
if (pfloatdef(def_to)^.typ=s64bit) and
|
|
(pfloatdef(def_from)^.typ<>s64bit) and
|
|
not (explicit) then
|
|
CGMessage(type_w_convert_real_2_comp);
|
|
{$endif}
|
|
end;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
end;
|
|
enumdef : begin
|
|
if (def_from^.deftype=enumdef) then
|
|
begin
|
|
if assigned(penumdef(def_from)^.basedef) then
|
|
hd1:=penumdef(def_from)^.basedef
|
|
else
|
|
hd1:=def_from;
|
|
if assigned(penumdef(def_to)^.basedef) then
|
|
hd2:=penumdef(def_to)^.basedef
|
|
else
|
|
hd2:=def_to;
|
|
b:=(hd1=hd2);
|
|
end;
|
|
end;
|
|
arraydef : begin
|
|
{ open array is also compatible with a single element of its base type }
|
|
if is_open_array(def_to) and
|
|
is_equal(parraydef(def_to)^.definition,def_from) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end
|
|
else
|
|
begin
|
|
case def_from^.deftype of
|
|
pointerdef : begin
|
|
if (parraydef(def_to)^.lowrange=0) and
|
|
is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then
|
|
begin
|
|
doconv:=tc_pointer_to_array;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
stringdef : begin
|
|
{ array of char to string }
|
|
if is_equal(parraydef(def_to)^.definition,cchardef) then
|
|
begin
|
|
doconv:=tc_string_chararray;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
pointerdef : begin
|
|
case def_from^.deftype of
|
|
stringdef : begin
|
|
{ string constant to zero terminated string constant }
|
|
if (fromtreetype=stringconstn) and
|
|
is_pchar(def_to) then
|
|
begin
|
|
doconv:=tc_cstring_charpointer;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
orddef : begin
|
|
{ char constant to zero terminated string constant }
|
|
if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) and
|
|
is_pchar(def_to) then
|
|
begin
|
|
doconv:=tc_cchar_charpointer;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
arraydef : begin
|
|
{ chararray to pointer }
|
|
if (parraydef(def_from)^.lowrange=0) and
|
|
is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then
|
|
begin
|
|
doconv:=tc_array_to_pointer;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
pointerdef : begin
|
|
{ child class pointer can be assigned to anchestor pointers }
|
|
if (
|
|
(ppointerdef(def_from)^.definition^.deftype=objectdef) and
|
|
(ppointerdef(def_to)^.definition^.deftype=objectdef) and
|
|
pobjectdef(ppointerdef(def_from)^.definition)^.isrelated(
|
|
pobjectdef(ppointerdef(def_to)^.definition))
|
|
) or
|
|
{ all pointers can be assigned to void-pointer }
|
|
is_equal(ppointerdef(def_to)^.definition,voiddef) or
|
|
{ in my opnion, is this not clean pascal }
|
|
{ well, but it's handy to use, it isn't ? (FK) }
|
|
is_equal(ppointerdef(def_from)^.definition,voiddef) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
procvardef : begin
|
|
{ procedure variable can be assigned to an void pointer }
|
|
{ Not anymore. Use the @ operator now.}
|
|
if not(m_tp_procvar in aktmodeswitches) and
|
|
(ppointerdef(def_to)^.definition^.deftype=orddef) and
|
|
(porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
classrefdef,
|
|
objectdef : begin
|
|
{ class types and class reference type
|
|
can be assigned to void pointers }
|
|
if (
|
|
((def_from^.deftype=objectdef) and pobjectdef(def_from)^.isclass) or
|
|
(def_from^.deftype=classrefdef)
|
|
) and
|
|
(ppointerdef(def_to)^.definition^.deftype=orddef) and
|
|
(porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
setdef : begin
|
|
{ automatic arrayconstructor -> set conversion }
|
|
if (def_from^.deftype=arraydef) and (parraydef(def_from)^.IsConstructor) then
|
|
begin
|
|
doconv:=tc_arrayconstructor_2_set;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
procvardef : begin
|
|
{ proc -> procvar }
|
|
if (def_from^.deftype=procdef) then
|
|
begin
|
|
def_from^.deftype:=procvardef;
|
|
doconv:=tc_proc2procvar;
|
|
b:=is_equal(def_from,def_to);
|
|
def_from^.deftype:=procdef;
|
|
end
|
|
else
|
|
{ nil is compatible with procvars }
|
|
if (fromtreetype=niln) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
objectdef : begin
|
|
{ object pascal objects }
|
|
if (def_from^.deftype=objectdef) {and
|
|
pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=pobjectdef(def_from)^.isrelated(pobjectdef(def_to));
|
|
end
|
|
else
|
|
{ nil is compatible with class instances }
|
|
if (fromtreetype=niln) and (pobjectdef(def_to)^.isclass) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
classrefdef : begin
|
|
{ class reference types }
|
|
if (def_from^.deftype=classrefdef) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=pobjectdef(pclassrefdef(def_from)^.definition)^.isrelated(
|
|
pobjectdef(pclassrefdef(def_to)^.definition));
|
|
end
|
|
else
|
|
{ nil is compatible with class references }
|
|
if (fromtreetype=niln) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end;
|
|
end;
|
|
filedef : begin
|
|
{ typed files are all equal to the abstract file type
|
|
name TYPEDFILE in system.pp in is_equal in types.pas
|
|
the problem is that it sholud be also compatible to FILE
|
|
but this would leed to a problem for ASSIGN RESET and REWRITE
|
|
when trying to find the good overloaded function !!
|
|
so all file function are doubled in system.pp
|
|
this is not very beautiful !!}
|
|
if (def_from^.deftype=filedef) and
|
|
(
|
|
(
|
|
(pfiledef(def_from)^.filetype = ft_typed) and
|
|
(pfiledef(def_to)^.filetype = ft_typed) and
|
|
(
|
|
(pfiledef(def_from)^.typed_as = pdef(voiddef)) or
|
|
(pfiledef(def_to)^.typed_as = pdef(voiddef))
|
|
)
|
|
) or
|
|
(
|
|
(
|
|
(pfiledef(def_from)^.filetype = ft_untyped) and
|
|
(pfiledef(def_to)^.filetype = ft_typed)
|
|
) or
|
|
(
|
|
(pfiledef(def_from)^.filetype = ft_typed) and
|
|
(pfiledef(def_to)^.filetype = ft_untyped)
|
|
)
|
|
)
|
|
) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end
|
|
end;
|
|
else
|
|
begin
|
|
{ assignment overwritten ?? }
|
|
if is_assignment_overloaded(def_from,def_to) then
|
|
b:=true;
|
|
end;
|
|
end;
|
|
|
|
{ nil is compatible with ansi- and wide strings }
|
|
{ no, that isn't true, (FK)
|
|
if (fromtreetype=niln) and (def_to^.deftype=stringdef)
|
|
and (pstringdef(def_to)^.string_typ in [st_ansistring,st_widestring]) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end
|
|
else
|
|
}
|
|
{ ansi- and wide strings can be assigned to void pointers }
|
|
{ no, (FK)
|
|
if (def_from^.deftype=stringdef) and
|
|
(pstringdef(def_from)^.string_typ in [st_ansistring,st_widestring]) and
|
|
(def_to^.deftype=pointerdef) and
|
|
(ppointerdef(def_to)^.definition^.deftype=orddef) and
|
|
(porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
|
|
begin
|
|
doconv:=tc_equal;
|
|
b:=true;
|
|
end
|
|
else
|
|
}
|
|
{ ansistrings can be assigned to pchar
|
|
this needs an explicit type cast (FK)
|
|
if is_ansistring(def_from) and
|
|
(def_to^.deftype=pointerdef) and
|
|
(ppointerdef(def_to)^.definition^.deftype=orddef) and
|
|
(porddef(ppointerdef(def_to)^.definition)^.typ=uchar) then
|
|
begin
|
|
doconv:=tc_ansistring_2_pchar;
|
|
b:=true;
|
|
end
|
|
else
|
|
}
|
|
isconvertable:=b;
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
Register Calculation
|
|
****************************************************************************}
|
|
|
|
{ marks an lvalue as "unregable" }
|
|
procedure make_not_regable(p : ptree);
|
|
begin
|
|
case p^.treetype of
|
|
typeconvn :
|
|
make_not_regable(p^.left);
|
|
loadn :
|
|
if p^.symtableentry^.typ=varsym then
|
|
pvarsym(p^.symtableentry)^.var_options :=
|
|
pvarsym(p^.symtableentry)^.var_options and not vo_regable;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure left_right_max(p : ptree);
|
|
begin
|
|
if assigned(p^.left) then
|
|
begin
|
|
if assigned(p^.right) then
|
|
begin
|
|
p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
|
|
p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
|
|
{$ifdef SUPPORT_MMX}
|
|
p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
|
|
{$endif SUPPORT_MMX}
|
|
end
|
|
else
|
|
begin
|
|
p^.registers32:=p^.left^.registers32;
|
|
p^.registersfpu:=p^.left^.registersfpu;
|
|
{$ifdef SUPPORT_MMX}
|
|
p^.registersmmx:=p^.left^.registersmmx;
|
|
{$endif SUPPORT_MMX}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ calculates the needed registers for a binary operator }
|
|
procedure calcregisters(p : ptree;r32,fpu,mmx : word);
|
|
|
|
begin
|
|
left_right_max(p);
|
|
|
|
{ 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}
|
|
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 ((sym^.properties and sp_protected)<>0) 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 : ptree);
|
|
begin
|
|
case p^.treetype of
|
|
loadn : test_protected_sym(p^.symtableentry);
|
|
typeconvn : test_protected(p^.left);
|
|
derefn : test_protected(p^.left);
|
|
subscriptn : begin
|
|
{ test_protected(p^.left);
|
|
Is a field of a protected var
|
|
also protected ??? PM }
|
|
test_protected_sym(p^.vs);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function is_procsym_load(p:Ptree):boolean;
|
|
begin
|
|
is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
|
|
((p^.treetype=addrn) and (p^.left^.treetype=loadn)
|
|
and (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:Ptree):boolean;
|
|
begin
|
|
is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and
|
|
(((p^.symtableprocentry^.typ=procsym) and (p^.right=nil)) or
|
|
((p^.right<>nil) and (p^.right^.symtableprocentry^.typ=varsym)));
|
|
end;
|
|
|
|
|
|
function is_assignment_overloaded(from_def,to_def : pdef) : boolean;
|
|
var
|
|
passproc : pprocdef;
|
|
convtyp : tconverttype;
|
|
begin
|
|
is_assignment_overloaded:=false;
|
|
if assigned(overloaded_operators[assignment]) then
|
|
passproc:=overloaded_operators[assignment]^.definition
|
|
else
|
|
exit;
|
|
while passproc<>nil do
|
|
begin
|
|
if is_equal(passproc^.retdef,to_def) and
|
|
isconvertable(from_def,passproc^.para1^.data,convtyp,
|
|
ordconstn { nur Dummy},false ) then
|
|
begin
|
|
is_assignment_overloaded:=true;
|
|
break;
|
|
end;
|
|
passproc:=passproc^.nextoverloaded;
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.4 1998-09-30 16:42:52 peter
|
|
* fixed bool-bool cnv
|
|
|
|
Revision 1.3 1998/09/24 23:49:05 peter
|
|
+ aktmodeswitches
|
|
|
|
Revision 1.2 1998/09/24 09:02:14 peter
|
|
* rewritten isconvertable to use case
|
|
* array of .. and single variable are compatible
|
|
|
|
Revision 1.1 1998/09/23 20:42:22 peter
|
|
* splitted pass_1
|
|
|
|
}
|