paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 15:59:28 +01:00
Code Issues Packages Projects Releases Wiki Activity
eab5d1f7c5
fpc/compiler/defbase.pas
florian 121ca40b39 * some variant <-> dyn. array stuff
2002-12-05 14:27:25 +00:00

2252 lines
82 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998-2002 by Florian Klaempfl
This unit provides some help routines for type handling
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 defbase;
{$i fpcdefs.inc}
interface
uses
cclasses,
cpuinfo,
globals,
node,
symconst,symbase,symtype,symdef,symsym;
type
tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
const
{# true if we must never copy this parameter }
never_copy_const_param : boolean = false;
{*****************************************************************************
Basic type functions
*****************************************************************************}
{# Returns true, if definition defines an ordinal type }
function is_ordinal(def : tdef) : boolean;
{# Returns the minimal integer value of the type }
function get_min_value(def : tdef) : TConstExprInt;
{# Returns basetype of the specified integer range }
function range_to_basetype(low,high:TConstExprInt):tbasetype;
{# Returns true, if definition defines an integer type }
function is_integer(def : tdef) : boolean;
{# Returns true if definition is a boolean }
function is_boolean(def : tdef) : boolean;
{# Returns true if definition is a char
This excludes the unicode char.
}
function is_char(def : tdef) : boolean;
{# Returns true if definition is a widechar }
function is_widechar(def : tdef) : boolean;
{# Returns true if definition is a void}
function is_void(def : tdef) : boolean;
{# Returns true if definition is a smallset}
function is_smallset(p : tdef) : boolean;
{# Returns true, if def defines a signed data type
(only for ordinal types)
}
function is_signed(def : tdef) : boolean;
{# Returns true whether def_from's range is comprised in def_to's if both are
orddefs, false otherwise }
function is_in_limit(def_from,def_to : tdef) : boolean;
function is_in_limit_value(val_from:TConstExprInt;def_from,def_to : tdef) : boolean;
{*****************************************************************************
Array helper functions
*****************************************************************************}
{# Returns true, if p points to a zero based (non special like open or
dynamic array def).
This is mainly used to see if the array
is convertable to a pointer
}
function is_zero_based_array(p : tdef) : boolean;
{# Returns true if p points to an open array definition }
function is_open_array(p : tdef) : boolean;
{# Returns true if p points to a dynamic array definition }
function is_dynamic_array(p : tdef) : boolean;
{# Returns true, if p points to an array of const definition }
function is_array_constructor(p : tdef) : boolean;
{# Returns true, if p points to a variant array }
function is_variant_array(p : tdef) : boolean;
{# Returns true, if p points to an array of const }
function is_array_of_const(p : tdef) : boolean;
{# Returns true, if p points any kind of special array
That is if the array is an open array, a variant
array, an array constants constructor, or an
array of const.
}
function is_special_array(p : tdef) : boolean;
{# Returns true if p is a char array def }
function is_chararray(p : tdef) : boolean;
{# Returns true if p is a wide char array def }
function is_widechararray(p : tdef) : boolean;
{*****************************************************************************
String helper functions
*****************************************************************************}
{# Returns true if p points to an open string type }
function is_open_string(p : tdef) : boolean;
{# Returns true if p is an ansi string type }
function is_ansistring(p : tdef) : boolean;
{# Returns true if p is a long string type }
function is_longstring(p : tdef) : boolean;
{# returns true if p is a wide string type }
function is_widestring(p : tdef) : boolean;
{# Returns true if p is a short string type }
function is_shortstring(p : tdef) : boolean;
{# Returns true if p is a pchar def }
function is_pchar(p : tdef) : boolean;
{# Returns true if p is a pwidechar def }
function is_pwidechar(p : tdef) : boolean;
{# Returns true if p is a voidpointer def }
function is_voidpointer(p : tdef) : boolean;
{# Returns true, if definition is a float }
function is_fpu(def : tdef) : boolean;
{# Returns true, if def is a currency type }
function is_currency(def : tdef) : boolean;
{# Returns true, if def is a 64 bit integer type }
function is_64bitint(def : tdef) : boolean;
{# Returns true, if def1 and def2 are semantically the same }
function is_equal(def1,def2 : tdef) : boolean;
{# Checks for type compatibility (subgroups of type)
used for case statements... probably missing stuff
to use on other types
}
function is_subequal(def1, def2: tdef): boolean;
type
tconverttype = (
tc_equal,
tc_not_possible,
tc_string_2_string,
tc_char_2_string,
tc_char_2_chararray,
tc_pchar_2_string,
tc_cchar_2_pchar,
tc_cstring_2_pchar,
tc_ansistring_2_pchar,
tc_string_2_chararray,
tc_chararray_2_string,
tc_array_2_pointer,
tc_pointer_2_array,
tc_int_2_int,
tc_int_2_bool,
tc_bool_2_bool,
tc_bool_2_int,
tc_real_2_real,
tc_int_2_real,
tc_proc_2_procvar,
tc_arrayconstructor_2_set,
tc_load_smallset,
tc_cord_2_pointer,
tc_intf_2_string,
tc_intf_2_guid,
tc_class_2_intf,
tc_char_2_char,
tc_normal_2_smallset,
tc_dynarray_2_openarray,
tc_pwchar_2_string,
tc_variant_2_dynarray,
tc_dynarray_2_variant
);
function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
{ Returns:
0 - Not convertable
1 - Convertable
2 - Convertable, but not first choice }
function isconvertable(def_from,def_to : tdef;
var doconv : tconverttype;
fromtreetype : tnodetype;
explicit : boolean) : byte;
{ this routine is recusrive safe, and is used by the
checking of overloaded assignment operators ONLY!
}
function overloaded_assignment_isconvertable(def_from,def_to : tdef;
var doconv : tconverttype;
fromtreetype : tnodetype;
explicit : boolean; var overload_procs : pprocdeflist) : byte;
{ Same as is_equal, but with error message if failed }
function CheckTypes(def1,def2 : tdef) : boolean;
function equal_constsym(sym1,sym2:tconstsym):boolean;
{ if acp is cp_all the var const or nothing are considered equal }
type
compare_type = ( cp_none, cp_value_equal_const, cp_all,cp_procvar);
{# true, if two parameter lists are equal
if acp is cp_none, all have to match exactly
if acp is cp_value_equal_const call by value
and call by const parameter are assumed as
equal
allowdefaults indicates if default value parameters
are allowed (in this case, the search order will first
search for a routine with default parameters, before
searching for the same definition with no parameters)
}
function equal_paras(paralist1,paralist2 : TLinkedList; acp : compare_type;allowdefaults:boolean) : boolean;
{ True if a type can be allowed for another one
in a func var }
function convertable_paras(paralist1,paralist2 : tlinkedlist; acp : compare_type) : boolean;
{ True if a function can be assigned to a procvar }
{ changed first argument type to pabstractprocdef so that it can also be }
{ used to test compatibility between two pprocvardefs (JM) }
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;exact:boolean) : boolean;
{ function get_proc_2_procvar_def(p:tprocsym;d:tprocvardef):tprocdef;}
{# If @var(l) isn't in the range of def a range check error (if not explicit) is generated and
the value is placed within the range
}
procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
{# Returns the range of def, where @var(l) is the low-range and @var(h) is
the high-range.
}
procedure getrange(def : tdef;var l : TConstExprInt;var h : TConstExprInt);
{ some type helper routines for MMX support }
function is_mmx_able_array(p : tdef) : boolean;
{# returns the mmx type }
function mmx_type(p : tdef) : tmmxtype;
{# returns true, if sym needs an entry in the proplist of a class rtti }
function needs_prop_entry(sym : tsym) : boolean;
implementation
uses
globtype,tokens,systems,verbose,
symtable;
function needs_prop_entry(sym : tsym) : boolean;
begin
needs_prop_entry:=(sp_published in tsym(sym).symoptions) and
(sym.typ in [propertysym,varsym]);
end;
function equal_constsym(sym1,sym2:tconstsym):boolean;
var
p1,p2,pend : pchar;
begin
equal_constsym:=false;
if sym1.consttyp<>sym2.consttyp then
exit;
case sym1.consttyp of
constint,
constbool,
constchar,
constord :
equal_constsym:=(sym1.value.valueord=sym2.value.valueord);
constpointer :
equal_constsym:=(sym1.value.valueordptr=sym2.value.valueordptr);
conststring,constresourcestring :
begin
if sym1.value.len=sym2.value.len then
begin
p1:=pchar(sym1.value.valueptr);
p2:=pchar(sym2.value.valueptr);
pend:=p1+sym1.value.len;
while (p1<pend) do
begin
if p1^<>p2^ then
break;
inc(p1);
inc(p2);
end;
if (p1=pend) then
equal_constsym:=true;
end;
end;
constreal :
equal_constsym:=(pbestreal(sym1.value.valueptr)^=pbestreal(sym2.value.valueptr)^);
constset :
equal_constsym:=(pnormalset(sym1.value.valueptr)^=pnormalset(sym2.value.valueptr)^);
constnil :
equal_constsym:=true;
end;
end;
function equal_paras(paralist1,paralist2 : TLinkedList; acp : compare_type;allowdefaults:boolean) : boolean;
var
def1,def2 : TParaItem;
begin
{ we need to parse the list from left-right so the
not-default parameters are checked first }
def1:=TParaItem(paralist1.last);
def2:=TParaItem(paralist2.last);
while (assigned(def1)) and (assigned(def2)) do
begin
case acp of
cp_value_equal_const :
begin
if not(is_equal(def1.paratype.def,def2.paratype.def)) or
((def1.paratyp<>def2.paratyp) and
((def1.paratyp in [vs_var,vs_out]) or
(def2.paratyp in [vs_var,vs_out])
)
) then
begin
equal_paras:=false;
exit;
end;
end;
cp_all,cp_procvar :
begin
if not(is_equal(def1.paratype.def,def2.paratype.def)) or
(def1.paratyp<>def2.paratyp) then
begin
equal_paras:=false;
exit;
end;
end;
cp_none :
begin
if not(is_equal(def1.paratype.def,def2.paratype.def)) then
begin
equal_paras:=false;
exit;
end;
{ also check default value if both have it declared }
if assigned(def1.defaultvalue) and
assigned(def2.defaultvalue) then
begin
if not equal_constsym(tconstsym(def1.defaultvalue),tconstsym(def2.defaultvalue)) then
begin
equal_paras:=false;
exit;
end;
end;
end;
end;
def1:=TParaItem(def1.previous);
def2:=TParaItem(def2.previous);
end;
{ when both lists are empty then the parameters are equal. Also
when one list is empty and the other has a parameter with default
value assigned then the parameters are also equal }
if ((def1=nil) and (def2=nil)) or
(allowdefaults and
((assigned(def1) and assigned(def1.defaultvalue)) or
(assigned(def2) and assigned(def2.defaultvalue)))) then
equal_paras:=true
else
equal_paras:=false;
end;
function convertable_paras(paralist1,paralist2 : TLinkedList;acp : compare_type) : boolean;
var
def1,def2 : TParaItem;
doconv : tconverttype;
p : pointer;
b : byte;
begin
def1:=TParaItem(paralist1.first);
def2:=TParaItem(paralist2.first);
while (assigned(def1)) and (assigned(def2)) do
begin
case acp of
cp_value_equal_const :
begin
if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) or
((def1.paratyp<>def2.paratyp) and
((def1.paratyp in [vs_out,vs_var]) or
(def2.paratyp in [vs_out,vs_var])
)
) then
begin
convertable_paras:=false;
exit;
end;
end;
cp_all :
begin
if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) or
(def1.paratyp<>def2.paratyp) then
begin
convertable_paras:=false;
exit;
end;
end;
cp_procvar :
begin
b:=isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false);
if (b=0) or
not(doconv in [tc_equal,tc_int_2_int]) or
(def1.paratyp<>def2.paratyp) or
(not is_special_array(def1.paratype.def) and
not is_special_array(def2.paratype.def) and
(def1.paratype.def.size<>def2.paratype.def.size)) then
begin
convertable_paras:=false;
exit;
end;
end;
cp_none :
begin
if (isconvertable(def1.paratype.def,def2.paratype.def,doconv,callparan,false)=0) then
begin
convertable_paras:=false;
exit;
end;
end;
end;
def1:=TParaItem(def1.next);
def2:=TParaItem(def2.next);
end;
if (def1=nil) and (def2=nil) then
convertable_paras:=true
else
convertable_paras:=false;
end;
{ true if a function can be assigned to a procvar }
{ changed first argument type to pabstractprocdef so that it can also be }
{ used to test compatibility between two pprocvardefs (JM) }
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;exact:boolean) : boolean;
const
po_comp = po_compatibility_options-[po_methodpointer,po_classmethod];
var
ismethod : boolean;
begin
proc_to_procvar_equal:=false;
if not(assigned(def1)) or not(assigned(def2)) then
exit;
{ check for method pointer }
if def1.deftype=procvardef then
begin
ismethod:=(po_methodpointer in def1.procoptions);
end
else
begin
ismethod:=assigned(def1.owner) and
(def1.owner.symtabletype=objectsymtable);
end;
if (ismethod and not (po_methodpointer in def2.procoptions)) or
(not(ismethod) and (po_methodpointer in def2.procoptions)) then
begin
Message(type_e_no_method_and_procedure_not_compatible);
exit;
end;
{ check return value and para's and options, methodpointer is already checked
parameters may also be convertable }
if is_equal(def1.rettype.def,def2.rettype.def) and
(def1.para_size(target_info.alignment.paraalign)=def2.para_size(target_info.alignment.paraalign)) and
(equal_paras(def1.para,def2.para,cp_procvar,false) or
((not exact) and convertable_paras(def1.para,def2.para,cp_procvar))) and
((po_comp * def1.procoptions)= (po_comp * def2.procoptions)) then
proc_to_procvar_equal:=true
else
proc_to_procvar_equal:=false;
end;
{ returns true, if def uses FPU }
function is_fpu(def : tdef) : boolean;
begin
is_fpu:=(def.deftype=floatdef);
end;
{ returns true, if def is a currency type }
function is_currency(def : tdef) : boolean;
begin
is_currency:=(def.deftype=floatdef) and (tfloatdef(def).typ=s64currency);
end;
function range_to_basetype(low,high:TConstExprInt):tbasetype;
begin
{ generate a unsigned range if high<0 and low>=0 }
if (low>=0) and (high<0) then
range_to_basetype:=u32bit
else if (low>=0) and (high<=255) then
range_to_basetype:=u8bit
else if (low>=-128) and (high<=127) then
range_to_basetype:=s8bit
else if (low>=0) and (high<=65536) then
range_to_basetype:=u16bit
else if (low>=-32768) and (high<=32767) then
range_to_basetype:=s16bit
else
range_to_basetype:=s32bit;
end;
{ true if p is an ordinal }
function is_ordinal(def : tdef) : boolean;
var
dt : tbasetype;
begin
case def.deftype of
orddef :
begin
dt:=torddef(def).typ;
is_ordinal:=dt in [uchar,uwidechar,
u8bit,u16bit,u32bit,u64bit,
s8bit,s16bit,s32bit,s64bit,
bool8bit,bool16bit,bool32bit];
end;
enumdef :
is_ordinal:=true;
else
is_ordinal:=false;
end;
end;
{ returns the min. value of the type }
function get_min_value(def : tdef) : TConstExprInt;
begin
case def.deftype of
orddef:
get_min_value:=torddef(def).low;
enumdef:
get_min_value:=tenumdef(def).min;
else
get_min_value:=0;
end;
end;
{ true if p is an integer }
function is_integer(def : tdef) : boolean;
begin
is_integer:=(def.deftype=orddef) and
(torddef(def).typ in [u8bit,u16bit,u32bit,u64bit,
s8bit,s16bit,s32bit,s64bit]);
end;
{ true if p is a boolean }
function is_boolean(def : tdef) : boolean;
begin
is_boolean:=(def.deftype=orddef) and
(torddef(def).typ in [bool8bit,bool16bit,bool32bit]);
end;
{ true if p is a void }
function is_void(def : tdef) : boolean;
begin
is_void:=(def.deftype=orddef) and
(torddef(def).typ=uvoid);
end;
{ true if p is a char }
function is_char(def : tdef) : boolean;
begin
is_char:=(def.deftype=orddef) and
(torddef(def).typ=uchar);
end;
{ true if p is a wchar }
function is_widechar(def : tdef) : boolean;
begin
is_widechar:=(def.deftype=orddef) and
(torddef(def).typ=uwidechar);
end;
{ true if p is signed (integer) }
function is_signed(def : tdef) : boolean;
var
dt : tbasetype;
begin
case def.deftype of
orddef :
begin
dt:=torddef(def).typ;
is_signed:=(dt in [s8bit,s16bit,s32bit,s64bit]);
end;
enumdef :
is_signed:=tenumdef(def).min < 0;
arraydef :
is_signed:=is_signed(tarraydef(def).rangetype.def);
else
is_signed:=false;
end;
end;
function is_in_limit(def_from,def_to : tdef) : boolean;
var
fromqword, toqword: boolean;
begin
if (def_from.deftype <> orddef) or
(def_to.deftype <> orddef) then
begin
is_in_limit := false;
exit;
end;
fromqword := torddef(def_from).typ = u64bit;
toqword := torddef(def_to).typ = u64bit;
is_in_limit:=(toqword and is_signed(def_from)) or
((not fromqword) and
(torddef(def_from).low>=torddef(def_to).low) and
(torddef(def_from).high<=torddef(def_to).high));
end;
function is_in_limit_value(val_from:TConstExprInt;def_from,def_to : tdef) : boolean;
begin
if (def_from.deftype <> orddef) and
(def_to.deftype <> orddef) then
internalerror(200210062);
if (torddef(def_to).typ = u64bit) then
begin
is_in_limit_value:=((TConstExprUInt(val_from)>=TConstExprUInt(torddef(def_to).low)) and
(TConstExprUInt(val_from)<=TConstExprUInt(torddef(def_to).high)));
end
else
begin;
is_in_limit_value:=((val_from>=torddef(def_to).low) and
(val_from<=torddef(def_to).high));
end;
end;
{ true, if p points to an open array def }
function is_open_string(p : tdef) : boolean;
begin
is_open_string:=(p.deftype=stringdef) and
(tstringdef(p).string_typ=st_shortstring) and
(tstringdef(p).len=0);
end;
{ true, if p points to a zero based array def }
function is_zero_based_array(p : tdef) : boolean;
begin
is_zero_based_array:=(p.deftype=arraydef) and
(tarraydef(p).lowrange=0) and
not(is_special_array(p));
end;
{ true if p points to a dynamic array def }
function is_dynamic_array(p : tdef) : boolean;
begin
is_dynamic_array:=(p.deftype=arraydef) and
tarraydef(p).IsDynamicArray;
end;
{ true, if p points to an open array def }
function is_open_array(p : tdef) : boolean;
begin
{ check for s32bittype is needed, because for u32bit the high
range is also -1 ! (PFV) }
is_open_array:=(p.deftype=arraydef) and
(tarraydef(p).rangetype.def=s32bittype.def) and
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=-1) and
not(tarraydef(p).IsConstructor) and
not(tarraydef(p).IsVariant) and
not(tarraydef(p).IsArrayOfConst) and
not(tarraydef(p).IsDynamicArray);
end;
{ true, if p points to an array of const def }
function is_array_constructor(p : tdef) : boolean;
begin
is_array_constructor:=(p.deftype=arraydef) and
(tarraydef(p).IsConstructor);
end;
{ true, if p points to a variant array }
function is_variant_array(p : tdef) : boolean;
begin
is_variant_array:=(p.deftype=arraydef) and
(tarraydef(p).IsVariant);
end;
{ true, if p points to an array of const }
function is_array_of_const(p : tdef) : boolean;
begin
is_array_of_const:=(p.deftype=arraydef) and
(tarraydef(p).IsArrayOfConst);
end;
{ true, if p points to a special array }
function is_special_array(p : tdef) : boolean;
begin
is_special_array:=(p.deftype=arraydef) and
((tarraydef(p).IsVariant) or
(tarraydef(p).IsArrayOfConst) or
(tarraydef(p).IsConstructor) or
is_open_array(p)
);
end;
{ true if p is an ansi string def }
function is_ansistring(p : tdef) : boolean;
begin
is_ansistring:=(p.deftype=stringdef) and
(tstringdef(p).string_typ=st_ansistring);
end;
{ true if p is an long string def }
function is_longstring(p : tdef) : boolean;
begin
is_longstring:=(p.deftype=stringdef) and
(tstringdef(p).string_typ=st_longstring);
end;
{ true if p is an wide string def }
function is_widestring(p : tdef) : boolean;
begin
is_widestring:=(p.deftype=stringdef) and
(tstringdef(p).string_typ=st_widestring);
end;
{ true if p is an short string def }
function is_shortstring(p : tdef) : boolean;
begin
is_shortstring:=(p.deftype=stringdef) and
(tstringdef(p).string_typ=st_shortstring);
end;
{ true if p is a char array def }
function is_chararray(p : tdef) : boolean;
begin
is_chararray:=(p.deftype=arraydef) and
is_equal(tarraydef(p).elementtype.def,cchartype.def) and
not(is_special_array(p));
end;
{ true if p is a widechar array def }
function is_widechararray(p : tdef) : boolean;
begin
is_widechararray:=(p.deftype=arraydef) and
is_equal(tarraydef(p).elementtype.def,cwidechartype.def) and
not(is_special_array(p));
end;
{ true if p is a pchar def }
function is_pchar(p : tdef) : boolean;
begin
is_pchar:=(p.deftype=pointerdef) and
(is_equal(tpointerdef(p).pointertype.def,cchartype.def) or
(is_zero_based_array(tpointerdef(p).pointertype.def) and
is_chararray(tpointerdef(p).pointertype.def)));
end;
{ true if p is a pchar def }
function is_pwidechar(p : tdef) : boolean;
begin
is_pwidechar:=(p.deftype=pointerdef) and
(is_equal(tpointerdef(p).pointertype.def,cwidechartype.def) or
(is_zero_based_array(tpointerdef(p).pointertype.def) and
is_widechararray(tpointerdef(p).pointertype.def)));
end;
{ true if p is a voidpointer def }
function is_voidpointer(p : tdef) : boolean;
begin
is_voidpointer:=(p.deftype=pointerdef) and
(tpointerdef(p).pointertype.def.deftype=orddef) and
(torddef(tpointerdef(p).pointertype.def).typ=uvoid);
end;
{ true if p is a smallset def }
function is_smallset(p : tdef) : boolean;
begin
is_smallset:=(p.deftype=setdef) and
(tsetdef(p).settype=smallset);
end;
{ true, if def is a 64 bit int type }
function is_64bitint(def : tdef) : boolean;
begin
is_64bitint:=(def.deftype=orddef) and (torddef(def).typ in [u64bit,s64bit])
end;
{ if l isn't in the range of def a range check error (if not explicit) is generated and
the value is placed within the range }
procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
var
lv,hv: TConstExprInt;
error: boolean;
begin
error := false;
{ for 64 bit types we need only to check if it is less than }
{ zero, if def is a qword node }
if is_64bitint(def) then
begin
if (l<0) and (torddef(def).typ=u64bit) then
begin
{ don't zero the result, because it may come from hex notation
like $ffffffffffffffff! (JM)
l:=0; }
if not explicit then
begin
if (cs_check_range in aktlocalswitches) then
Message(parser_e_range_check_error)
else
Message(parser_w_range_check_error);
end;
error := true;
end;
end
else
begin
getrange(def,lv,hv);
if (def.deftype=orddef) and
(torddef(def).typ=u32bit) then
begin
if (l < cardinal(lv)) or
(l > cardinal(hv)) then
begin
if not explicit then
begin
if (cs_check_range in aktlocalswitches) then
Message(parser_e_range_check_error)
else
Message(parser_w_range_check_error);
end;
error := true;
end;
end
else if (l<lv) or (l>hv) then
begin
if not explicit then
begin
if ((def.deftype=enumdef) and
{ delphi allows range check errors in
enumeration type casts FK }
not(m_delphi in aktmodeswitches)) or
(cs_check_range in aktlocalswitches) then
Message(parser_e_range_check_error)
else
Message(parser_w_range_check_error);
end;
error := true;
end;
end;
if error then
begin
{ Fix the value to fit in the allocated space for this type of variable }
case def.size of
1: l := l and $ff;
2: l := l and $ffff;
{ work around sign extension bug (to be fixed) (JM) }
4: l := l and (int64($fffffff) shl 4 + $f);
end;
{ do sign extension if necessary (JM) }
if is_signed(def) then
begin
case def.size of
1: l := shortint(l);
2: l := smallint(l);
4: l := longint(l);
end;
end;
end;
end;
{ return the range from def in l and h }
procedure getrange(def : tdef;var l : TConstExprInt;var h : TConstExprInt);
begin
case def.deftype of
orddef :
begin
l:=torddef(def).low;
h:=torddef(def).high;
end;
enumdef :
begin
l:=tenumdef(def).min;
h:=tenumdef(def).max;
end;
arraydef :
begin
l:=tarraydef(def).lowrange;
h:=tarraydef(def).highrange;
end;
else
internalerror(987);
end;
end;
function mmx_type(p : tdef) : tmmxtype;
begin
mmx_type:=mmxno;
if is_mmx_able_array(p) then
begin
if tarraydef(p).elementtype.def.deftype=floatdef then
case tfloatdef(tarraydef(p).elementtype.def).typ of
s32real:
mmx_type:=mmxsingle;
end
else
case torddef(tarraydef(p).elementtype.def).typ of
u8bit:
mmx_type:=mmxu8bit;
s8bit:
mmx_type:=mmxs8bit;
u16bit:
mmx_type:=mmxu16bit;
s16bit:
mmx_type:=mmxs16bit;
u32bit:
mmx_type:=mmxu32bit;
s32bit:
mmx_type:=mmxs32bit;
end;
end;
end;
function is_mmx_able_array(p : tdef) : boolean;
begin
{$ifdef SUPPORT_MMX}
if (cs_mmx_saturation in aktlocalswitches) then
begin
is_mmx_able_array:=(p.deftype=arraydef) and
not(is_special_array(p)) and
(
(
(tarraydef(p).elementtype.def.deftype=orddef) and
(
(
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=1) and
(torddef(tarraydef(p).elementtype.def).typ in [u32bit,s32bit])
)
or
(
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=3) and
(torddef(tarraydef(p).elementtype.def).typ in [u16bit,s16bit])
)
)
)
or
(
(
(tarraydef(p).elementtype.def.deftype=floatdef) and
(
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=1) and
(tfloatdef(tarraydef(p).elementtype.def).typ=s32real)
)
)
)
);
end
else
begin
is_mmx_able_array:=(p.deftype=arraydef) and
(
(
(tarraydef(p).elementtype.def.deftype=orddef) and
(
(
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=1) and
(torddef(tarraydef(p).elementtype.def).typ in [u32bit,s32bit])
)
or
(
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=3) and
(torddef(tarraydef(p).elementtype.def).typ in [u16bit,s16bit])
)
or
(
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=7) and
(torddef(tarraydef(p).elementtype.def).typ in [u8bit,s8bit])
)
)
)
or
(
(tarraydef(p).elementtype.def.deftype=floatdef) and
(
(tarraydef(p).lowrange=0) and
(tarraydef(p).highrange=1) and
(tfloatdef(tarraydef(p).elementtype.def).typ=s32real)
)
)
);
end;
{$else SUPPORT_MMX}
is_mmx_able_array:=false;
{$endif SUPPORT_MMX}
end;
function is_equal(def1,def2 : tdef) : boolean;
var
b : boolean;
hd : tdef;
begin
{ both types must exists }
if not (assigned(def1) and assigned(def2)) then
begin
is_equal:=false;
exit;
end;
{ be sure, that if there is a stringdef, that this is def1 }
if def2.deftype=stringdef then
begin
hd:=def1;
def1:=def2;
def2:=hd;
end;
b:=false;
{ both point to the same definition ? }
if def1=def2 then
b:=true
else
{ pointer with an equal definition are equal }
if (def1.deftype=pointerdef) and (def2.deftype=pointerdef) then
begin
{ check if both are farpointer }
if (tpointerdef(def1).is_far=tpointerdef(def2).is_far) then
begin
{ here a problem detected in tabsolutesym }
{ the types can be forward type !! }
if assigned(def1.typesym) and (tpointerdef(def1).pointertype.def.deftype=forwarddef) then
b:=(def1.typesym=def2.typesym)
else
b:=tpointerdef(def1).pointertype.def=tpointerdef(def2).pointertype.def;
end
else
b:=false;
end
else
{ ordinals are equal only when the ordinal type is equal }
if (def1.deftype=orddef) and (def2.deftype=orddef) then
begin
case torddef(def1).typ of
u8bit,u16bit,u32bit,u64bit,
s8bit,s16bit,s32bit,s64bit:
b:=((torddef(def1).typ=torddef(def2).typ) and
(torddef(def1).low=torddef(def2).low) and
(torddef(def1).high=torddef(def2).high));
uvoid,uchar,uwidechar,
bool8bit,bool16bit,bool32bit:
b:=(torddef(def1).typ=torddef(def2).typ);
else
internalerror(200210061);
end;
end
else
if (def1.deftype=floatdef) and (def2.deftype=floatdef) then
b:=tfloatdef(def1).typ=tfloatdef(def2).typ
else
{ strings with the same length are equal }
if (def1.deftype=stringdef) and (def2.deftype=stringdef) and
(tstringdef(def1).string_typ=tstringdef(def2).string_typ) then
begin
b:=not(is_shortstring(def1)) or
(tstringdef(def1).len=tstringdef(def2).len);
end
else
if (def1.deftype=formaldef) and (def2.deftype=formaldef) then
b:=true
{ file types with the same file element type are equal }
{ this is a problem for assign !! }
{ changed to allow if one is untyped }
{ all typed files are equal to the special }
{ typed file that has voiddef as elemnt type }
{ but must NOT match for text file !!! }
else
if (def1.deftype=filedef) and (def2.deftype=filedef) then
b:=(tfiledef(def1).filetyp=tfiledef(def2).filetyp) and
((
((tfiledef(def1).typedfiletype.def=nil) and
(tfiledef(def2).typedfiletype.def=nil)) or
(
(tfiledef(def1).typedfiletype.def<>nil) and
(tfiledef(def2).typedfiletype.def<>nil) and
is_equal(tfiledef(def1).typedfiletype.def,tfiledef(def2).typedfiletype.def)
) or
( (tfiledef(def1).typedfiletype.def=tdef(voidtype.def)) or
(tfiledef(def2).typedfiletype.def=tdef(voidtype.def))
)))
{ sets with the same element base type are equal }
else
if (def1.deftype=setdef) and (def2.deftype=setdef) then
begin
if assigned(tsetdef(def1).elementtype.def) and
assigned(tsetdef(def2).elementtype.def) then
b:=is_subequal(tsetdef(def1).elementtype.def,tsetdef(def2).elementtype.def)
else
{ empty set is compatible with everything }
b:=true;
end
else
if (def1.deftype=procvardef) and (def2.deftype=procvardef) then
begin
{ poassembler isn't important for compatibility }
{ if a method is assigned to a methodpointer }
{ is checked before }
b:=(tprocvardef(def1).proctypeoption=tprocvardef(def2).proctypeoption) and
(tprocvardef(def1).proccalloption=tprocvardef(def2).proccalloption) and
((tprocvardef(def1).procoptions * po_compatibility_options)=
(tprocvardef(def2).procoptions * po_compatibility_options)) and
is_equal(tprocvardef(def1).rettype.def,tprocvardef(def2).rettype.def) and
equal_paras(tprocvardef(def1).para,tprocvardef(def2).para,cp_all,false);
end
else
if (def1.deftype=arraydef) and (def2.deftype=arraydef) then
begin
if is_dynamic_array(def1) and is_dynamic_array(def2) then
b:=is_equal(tarraydef(def1).elementtype.def,tarraydef(def2).elementtype.def)
else
if is_array_of_const(def1) or is_array_of_const(def2) then
begin
b:=(is_array_of_const(def1) and is_array_of_const(def2)) or
(is_array_of_const(def1) and is_array_constructor(def2)) or
(is_array_of_const(def2) and is_array_constructor(def1));
end
else
if (is_dynamic_array(def1) or is_dynamic_array(def2)) then
begin
b := is_dynamic_array(def1) and is_dynamic_array(def2) and
is_equal(tarraydef(def1).elementtype.def,tarraydef(def2).elementtype.def);
end
else
if is_open_array(def1) or is_open_array(def2) then
begin
b:=is_equal(tarraydef(def1).elementtype.def,tarraydef(def2).elementtype.def);
end
else
begin
b:=not(m_tp7 in aktmodeswitches) and
not(m_delphi in aktmodeswitches) and
(tarraydef(def1).lowrange=tarraydef(def2).lowrange) and
(tarraydef(def1).highrange=tarraydef(def2).highrange) and
is_equal(tarraydef(def1).elementtype.def,tarraydef(def2).elementtype.def) and
is_equal(tarraydef(def1).rangetype.def,tarraydef(def2).rangetype.def);
end;
end
else
if (def1.deftype=classrefdef) and (def2.deftype=classrefdef) then
begin
{ similar to pointerdef: }
if assigned(def1.typesym) and (tclassrefdef(def1).pointertype.def.deftype=forwarddef) then
b:=(def1.typesym=def2.typesym)
else
b:=is_equal(tclassrefdef(def1).pointertype.def,tclassrefdef(def2).pointertype.def);
end;
is_equal:=b;
end;
function is_subequal(def1, def2: tdef): boolean;
var
basedef1,basedef2 : tenumdef;
Begin
is_subequal := false;
if assigned(def1) and assigned(def2) then
Begin
if (def1.deftype = orddef) and (def2.deftype = orddef) then
Begin
{ see p.47 of Turbo Pascal 7.01 manual for the separation of types }
{ range checking for case statements is done with testrange }
case torddef(def1).typ of
u8bit,u16bit,u32bit,
s8bit,s16bit,s32bit,s64bit,u64bit :
is_subequal:=(torddef(def2).typ in [s64bit,u64bit,s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
bool8bit,bool16bit,bool32bit :
is_subequal:=(torddef(def2).typ in [bool8bit,bool16bit,bool32bit]);
uchar :
is_subequal:=(torddef(def2).typ=uchar);
uwidechar :
is_subequal:=(torddef(def2).typ=uwidechar);
end;
end
else
Begin
{ I assume that both enumerations are equal when the first }
{ pointers are equal. }
{ I changed this to assume that the enums are equal }
{ if the basedefs are equal (FK) }
if (def1.deftype=enumdef) and (def2.deftype=enumdef) then
Begin
{ get both basedefs }
basedef1:=tenumdef(def1);
while assigned(basedef1.basedef) do
basedef1:=basedef1.basedef;
basedef2:=tenumdef(def2);
while assigned(basedef2.basedef) do
basedef2:=basedef2.basedef;
is_subequal:=basedef1=basedef2;
{
if tenumdef(def1).firstenum = tenumdef(def2).firstenum then
is_subequal := TRUE;
}
end;
end;
end; { endif assigned ... }
end;
(* function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
var
passprocs : pprocdeflist;
convtyp : tconverttype;
begin
assignment_overloaded:=nil;
if not assigned(overloaded_operators[_ASSIGNMENT]) then
exit;
{ look for an exact match first }
passprocs:=overloaded_operators[_ASSIGNMENT].defs;
while assigned(passprocs) do
begin
if is_equal(passprocs^.def.rettype.def,to_def) and
(TParaItem(passprocs^.def.Para.first).paratype.def=from_def) then
begin
assignment_overloaded:=passprocs^.def;
exit;
end;
passprocs:=passprocs^.next;
end;
{ .... then look for an equal match }
passprocs:=overloaded_operators[_ASSIGNMENT].defs;
while assigned(passprocs) do
begin
if is_equal(passprocs^.def.rettype.def,to_def) and
is_equal(TParaItem(passprocs^.def.Para.first).paratype.def,from_def) then
begin
assignment_overloaded:=passprocs^.def;
exit;
end;
passprocs:=passprocs^.next;
end;
{ .... then for convert level 1 }
passprocs:=overloaded_operators[_ASSIGNMENT].defs;
while assigned(passprocs) do
begin
if is_equal(passprocs^.def.rettype.def,to_def) and
(isconvertable(from_def,TParaItem(passprocs^.def.Para.first).paratype.def,convtyp,ordconstn,false)=1) then
begin
assignment_overloaded:=passprocs^.def;
exit;
end;
passprocs:=passprocs^.next;
end;
end;
*)
{ this is an internal routine to take care of recursivity }
function internal_assignment_overloaded(from_def,to_def : tdef;
var overload_procs : pprocdeflist) : tprocdef;
var
p :pprocdeflist;
_result : tprocdef;
begin
internal_assignment_overloaded:=nil;
p := nil;
if not assigned(overloaded_operators[_ASSIGNMENT]) then
exit;
{ look for an exact match first, from start of list }
_result:=overloaded_operators[_ASSIGNMENT].
search_procdef_byretdef_by1paradef(to_def,from_def,dm_exact,
p);
if assigned(_result) then
begin
internal_assignment_overloaded := _result;
exit;
end;
{ .... then look for an equal match, from start of list }
_result:=overloaded_operators[_ASSIGNMENT].
search_procdef_byretdef_by1paradef(to_def,from_def,dm_equal,
p);
if assigned(_result) then
begin
internal_assignment_overloaded := _result;
exit;
end;
{ .... then for convert level 1, continue from where we were at }
internal_assignment_overloaded:=overloaded_operators[_ASSIGNMENT].
search_procdef_byretdef_by1paradef(to_def,from_def,dm_convertl1,
overload_procs);
end;
function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
var
p : pprocdeflist;
begin
p:=nil;
assignment_overloaded:=nil;
assignment_overloaded:=internal_assignment_overloaded(
from_def, to_def, p);
end;
{ Returns:
0 - Not convertable
1 - Convertable
2 - Convertable, but not first choice
}
function isconvertable(def_from,def_to : tdef;
var doconv : tconverttype;
fromtreetype : tnodetype;
explicit : boolean) : byte;
var
p: pprocdeflist;
begin
p:=nil;
isconvertable:=overloaded_assignment_isconvertable(def_from,def_to,
doconv, fromtreetype, explicit,p);
end;
function overloaded_assignment_isconvertable(def_from,def_to : tdef;
var doconv : tconverttype;
fromtreetype : tnodetype;
explicit : boolean; var overload_procs : pprocdeflist) : byte;
{ Tbasetype:
uvoid,
u8bit,u16bit,u32bit,u64bit,
s8bit,s16bit,s32bit,s64bit,
bool8bit,bool16bit,bool32bit,
uchar,uwidechar }
type
tbasedef=(bvoid,bchar,bint,bbool);
const
basedeftbl:array[tbasetype] of tbasedef =
(bvoid,
bint,bint,bint,bint,
bint,bint,bint,bint,
bbool,bbool,bbool,
bchar,bchar);
basedefconverts : array[tbasedef,tbasedef] of tconverttype =
((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
(tc_not_possible,tc_char_2_char,tc_not_possible,tc_not_possible),
(tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool),
(tc_not_possible,tc_not_possible,tc_bool_2_int,tc_bool_2_bool));
var
b : byte;
hd1,hd2 : tdef;
hct : tconverttype;
hd3 : tobjectdef;
begin
{ safety check }
if not(assigned(def_from) and assigned(def_to)) then
begin
overloaded_assignment_isconvertable :=0;
exit;
end;
{ tp7 procvar def support, in tp7 a procvar is always called, if the
procvar is passed explicit a addrn would be there }
if (m_tp_procvar in aktmodeswitches) and
(def_from.deftype=procvardef) and
(fromtreetype=loadn) and
{ only if the procvar doesn't require any paramters }
(tprocvardef(def_from).minparacount = 0) then
begin
def_from:=tprocvardef(def_from).rettype.def;
end;
{ we walk the wanted (def_to) types and check then the def_from
types if there is a conversion possible }
b:=0;
case def_to.deftype of
orddef :
begin
case def_from.deftype of
orddef :
begin
doconv:=basedefconverts[basedeftbl[torddef(def_from).typ],basedeftbl[torddef(def_to).typ]];
b:=1;
if (doconv=tc_not_possible) or
((doconv=tc_int_2_bool) and
(not explicit) and
(not is_boolean(def_from))) or
((doconv=tc_bool_2_int) and
(not explicit) and
(not is_boolean(def_to))) then
b:=0
else
{ "punish" bad type conversions :) (JM) }
if not is_in_limit(def_from,def_to) and
(def_from.size > def_to.size) then
b := 2;
end;
enumdef :
begin
{ needed for char(enum) }
if explicit then
begin
doconv:=tc_int_2_int;
b:=1;
end;
end;
end;
end;
stringdef :
begin
case def_from.deftype of
stringdef :
begin
doconv:=tc_string_2_string;
b:=1;
end;
orddef :
begin
{ char to string}
if is_char(def_from) or
is_widechar(def_from) then
begin
doconv:=tc_char_2_string;
b:=1;
end;
end;
arraydef :
begin
{ array of char to string, the length check is done by the firstpass of this node }
if is_chararray(def_from) or
(is_equal(tarraydef(def_from).elementtype.def,cchartype.def) and
is_open_array(def_from)) then
begin
doconv:=tc_chararray_2_string;
if is_open_array(def_from) or
(is_shortstring(def_to) and
(def_from.size <= 255)) or
(is_ansistring(def_to) and
(def_from.size > 255)) then
b:=1
else
b:=2;
end;
end;
pointerdef :
begin
{ pchar can be assigned to short/ansistrings,
but not in tp7 compatible mode }
if not(m_tp7 in aktmodeswitches) then
begin
if is_pchar(def_from) then
begin
doconv:=tc_pchar_2_string;
{ trefer ansistrings because pchars can overflow shortstrings, }
{ but only if ansistrings are the default (JM) }
if (is_shortstring(def_to) and
not(cs_ansistrings in aktlocalswitches)) or
(is_ansistring(def_to) and
(cs_ansistrings in aktlocalswitches)) then
b:=1
else
b:=2;
end
else if is_pwidechar(def_from) then
begin
doconv:=tc_pwchar_2_string;
{ trefer ansistrings because pchars can overflow shortstrings, }
{ but only if ansistrings are the default (JM) }
if is_widestring(def_to) then
b:=1
else
b:=2;
end;
end;
end;
end;
end;
floatdef :
begin
case def_from.deftype of
orddef :
begin { ordinal to real }
if is_integer(def_from) then
begin
doconv:=tc_int_2_real;
b:=1;
end;
end;
floatdef :
begin { 2 float types ? }
if tfloatdef(def_from).typ=tfloatdef(def_to).typ then
doconv:=tc_equal
else
doconv:=tc_real_2_real;
b:=1;
end;
end;
end;
enumdef :
begin
if (def_from.deftype=enumdef) then
begin
if explicit then
begin
b:=1;
doconv:=tc_int_2_int;
end
else
begin
hd1:=def_from;
while assigned(tenumdef(hd1).basedef) do
hd1:=tenumdef(hd1).basedef;
hd2:=def_to;
while assigned(tenumdef(hd2).basedef) do
hd2:=tenumdef(hd2).basedef;
if (hd1=hd2) then
begin
b:=1;
{ because of packenum they can have different sizes! (JM) }
doconv:=tc_int_2_int;
end;
end;
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(tarraydef(def_to).elementtype.def,def_from) then
begin
doconv:=tc_equal;
b:=1;
end
else if is_dynamic_array(def_to) and
{ nil is compatible with dyn. arrays }
(fromtreetype=niln) then
begin
doconv:=tc_equal;
b:=1;
end
else
begin
case def_from.deftype of
arraydef :
begin
{ array constructor -> open array }
if is_open_array(def_to) and
is_array_constructor(def_from) then
begin
if is_void(tarraydef(def_from).elementtype.def) or
is_equal(tarraydef(def_to).elementtype.def,tarraydef(def_from).elementtype.def) then
begin
doconv:=tc_equal;
b:=1;
end
else
if isconvertable(tarraydef(def_from).elementtype.def,
tarraydef(def_to).elementtype.def,hct,arrayconstructorn,false)<>0 then
begin
doconv:=hct;
b:=2;
end;
end
else
{ dynamic array -> open array }
if is_dynamic_array(def_from) and
is_open_array(def_to) and
is_equal(tarraydef(def_to).elementtype.def,tarraydef(def_from).elementtype.def) then
begin
doconv := tc_dynarray_2_openarray;
b := 2;
end
else
{ array of tvarrec -> array of const }
if is_array_of_const(def_to) and
is_equal(tarraydef(def_to).elementtype.def,tarraydef(def_from).elementtype.def) then
begin
doconv:=tc_equal;
b:=1;
end;
end;
pointerdef :
begin
if is_zero_based_array(def_to) and
is_equal(tpointerdef(def_from).pointertype.def,tarraydef(def_to).elementtype.def) then
begin
doconv:=tc_pointer_2_array;
b:=1;
end;
end;
stringdef :
begin
{ string to char array }
if (not is_special_array(def_to)) and
is_char(tarraydef(def_to).elementtype.def) then
begin
doconv:=tc_string_2_chararray;
b:=1;
end;
end;
orddef:
begin
if is_chararray(def_to) and
is_char(def_from) then
begin
doconv:=tc_char_2_chararray;
b:=2;
end;
end;
recorddef :
begin
{ tvarrec -> array of const }
if is_array_of_const(def_to) and
is_equal(def_from,tarraydef(def_to).elementtype.def) then
begin
doconv:=tc_equal;
b:=1;
end;
end;
variantdef :
begin
if is_dynamic_array(def_to) then
begin
doconv:=tc_variant_2_dynarray;
b:=1;
end;
end;
end;
end;
end;
pointerdef :
begin
case def_from.deftype of
stringdef :
begin
{ string constant (which can be part of array constructor)
to zero terminated string constant }
if (fromtreetype in [arrayconstructorn,stringconstn]) and
is_pchar(def_to) or is_pwidechar(def_to) then
begin
doconv:=tc_cstring_2_pchar;
b:=1;
end;
end;
orddef :
begin
{ char constant to zero terminated string constant }
if (fromtreetype=ordconstn) then
begin
if is_equal(def_from,cchartype.def) and
is_pchar(def_to) then
begin
doconv:=tc_cchar_2_pchar;
b:=1;
end
else
if is_integer(def_from) then
begin
doconv:=tc_cord_2_pointer;
b:=1;
end;
end;
end;
arraydef :
begin
{ chararray to pointer }
if is_zero_based_array(def_from) and
is_equal(tarraydef(def_from).elementtype.def,tpointerdef(def_to).pointertype.def) then
begin
doconv:=tc_array_2_pointer;
b:=1;
end;
end;
pointerdef :
begin
{ child class pointer can be assigned to anchestor pointers }
if (
(tpointerdef(def_from).pointertype.def.deftype=objectdef) and
(tpointerdef(def_to).pointertype.def.deftype=objectdef) and
tobjectdef(tpointerdef(def_from).pointertype.def).is_related(
tobjectdef(tpointerdef(def_to).pointertype.def))
) or
{ all pointers can be assigned to void-pointer }
is_equal(tpointerdef(def_to).pointertype.def,voidtype.def) or
{ in my opnion, is this not clean pascal }
{ well, but it's handy to use, it isn't ? (FK) }
is_equal(tpointerdef(def_from).pointertype.def,voidtype.def) then
begin
{ but don't allow conversion between farpointer-pointer }
if (tpointerdef(def_to).is_far=tpointerdef(def_from).is_far) then
begin
doconv:=tc_equal;
b:=1;
end;
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
(tpointerdef(def_to).pointertype.def.deftype=orddef) and
(torddef(tpointerdef(def_to).pointertype.def).typ=uvoid) then
begin
doconv:=tc_equal;
b:=1;
end;
end;
classrefdef,
objectdef :
begin
{ class types and class reference type
can be assigned to void pointers }
if (
is_class_or_interface(def_from) or
(def_from.deftype=classrefdef)
) and
(tpointerdef(def_to).pointertype.def.deftype=orddef) and
(torddef(tpointerdef(def_to).pointertype.def).typ=uvoid) then
begin
doconv:=tc_equal;
b:=1;
end;
end;
end;
end;
setdef :
begin
{ automatic arrayconstructor -> set conversion }
if is_array_constructor(def_from) then
begin
doconv:=tc_arrayconstructor_2_set;
b:=1;
end;
end;
procvardef :
begin
{ proc -> procvar }
if (def_from.deftype=procdef) and
(m_tp_procvar in aktmodeswitches) then
begin
doconv:=tc_proc_2_procvar;
if proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),false) then
b:=1;
end
{ procvar -> procvar }
else
if (def_from.deftype=procvardef) and
(proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to),false)) then
begin
doconv:=tc_equal;
b := 2;
end
else
{ for example delphi allows the assignement from pointers }
{ to procedure variables }
if (m_pointer_2_procedure in aktmodeswitches) and
(def_from.deftype=pointerdef) and
(tpointerdef(def_from).pointertype.def.deftype=orddef) and
(torddef(tpointerdef(def_from).pointertype.def).typ=uvoid) then
begin
doconv:=tc_equal;
b:=1;
end
else
{ nil is compatible with procvars }
if (fromtreetype=niln) then
begin
doconv:=tc_equal;
b:=1;
end;
end;
objectdef :
begin
{ object pascal objects }
if (def_from.deftype=objectdef) and
tobjectdef(def_from).is_related(tobjectdef(def_to)) then
begin
doconv:=tc_equal;
b:=1;
end
else
{ Class/interface specific }
if is_class_or_interface(def_to) then
begin
{ void pointer also for delphi mode }
if (m_delphi in aktmodeswitches) and
is_voidpointer(def_from) then
begin
doconv:=tc_equal;
b:=1;
end
else
{ nil is compatible with class instances and interfaces }
if (fromtreetype=niln) then
begin
doconv:=tc_equal;
b:=1;
end
{ classes can be assigned to interfaces }
else if is_interface(def_to) and
is_class(def_from) and
assigned(tobjectdef(def_from).implementedinterfaces) then
begin
{ we've to search in parent classes as well }
hd3:=tobjectdef(def_from);
while assigned(hd3) do
begin
if hd3.implementedinterfaces.searchintf(def_to)<>-1 then
begin
doconv:=tc_class_2_intf;
b:=1;
break;
end;
hd3:=hd3.childof;
end;
end
{ Interface 2 GUID handling }
else if (def_to=tdef(rec_tguid)) and
(fromtreetype=typen) and
is_interface(def_from) and
assigned(tobjectdef(def_from).iidguid) then
begin
b:=1;
doconv:=tc_equal;
end;
end;
end;
classrefdef :
begin
{ class reference types }
if (def_from.deftype=classrefdef) then
begin
doconv:=tc_equal;
if tobjectdef(tclassrefdef(def_from).pointertype.def).is_related(
tobjectdef(tclassrefdef(def_to).pointertype.def)) then
b:=1;
end
else
{ nil is compatible with class references }
if (fromtreetype=niln) then
begin
doconv:=tc_equal;
b:=1;
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
(
(
(tfiledef(def_from).filetyp = ft_typed) and
(tfiledef(def_to).filetyp = ft_typed) and
(
(tfiledef(def_from).typedfiletype.def = tdef(voidtype.def)) or
(tfiledef(def_to).typedfiletype.def = tdef(voidtype.def))
)
) or
(
(
(tfiledef(def_from).filetyp = ft_untyped) and
(tfiledef(def_to).filetyp = ft_typed)
) or
(
(tfiledef(def_from).filetyp = ft_typed) and
(tfiledef(def_to).filetyp = ft_untyped)
)
)
) then
begin
doconv:=tc_equal;
b:=1;
end
end;
recorddef :
begin
{ interface -> guid }
if is_interface(def_from) and
(def_to=rec_tguid) then
begin
doconv:=tc_intf_2_guid;
b:=1;
end
else
begin
{ assignment overwritten ?? }
if internal_assignment_overloaded(def_from,def_to,overload_procs)<>nil then
b:=2;
end;
end;
{ a variant isn't compatible to nil (FK)
variantdef :
begin
if (fromtreetype=niln) then
begin
doconv:=tc_equal;
b:=1;
end;
end;
}
formaldef :
begin
{ Just about everything can be converted to a formaldef...}
if not (def_from.deftype in [abstractdef,errordef]) then
b:=1
else
begin
{ assignment overwritten ?? }
if internal_assignment_overloaded(def_from,def_to,overload_procs)<>nil then
b:=2;
end;
end;
end;
{ if we didn't find an appropriate type conversion yet, we try the overloaded := operator }
{ This is done for variants only yet, maybe we should do this for other types as well (FK) }
if (b=0) and ((def_from.deftype in [variantdef]) or (def_to.deftype in [variantdef])) then
begin
if internal_assignment_overloaded(def_from,def_to,overload_procs)<>nil then
begin
{
if ((def_from.deftype=orddef) and (torddef(def_from).typ=s32bit)) or
((def_to.deftype=orddef) and (torddef(def_to).typ=s32bit)) then
b:=1
else
}
b:=2;
end;
end;
overloaded_assignment_isconvertable :=b;
end;
function CheckTypes(def1,def2 : tdef) : boolean;
var
s1,s2 : string;
begin
CheckTypes:=False;
if not is_equal(def1,def2) then
begin
{ Crash prevention }
if (not assigned(def1)) or (not assigned(def2)) then
Message(type_e_mismatch)
else
begin
if not is_subequal(def1,def2) then
begin
s1:=def1.typename;
s2:=def2.typename;
Message2(type_e_not_equal_types,def1.typename,def2.typename);
end
else
CheckTypes := true;
end;
end
else
CheckTypes := True;
end;
end.
{
$Log$
Revision 1.29 2002-12-05 14:27:25 florian
* some variant <-> dyn. array stuff
Revision 1.28 2002/11/25 17:43:16 peter
* splitted defbase in defutil,symutil,defcmp
* merged isconvertable and is_equal into compare_defs(_ext)
* made operator search faster by walking the list only once
Revision 1.27 2002/11/22 22:48:10 carl
* memory optimization with tconstsym (1.5%)
Revision 1.26 2002/11/17 16:31:55 carl
* memory optimization (3-4%) : cleanup of tai fields,
cleanup of tdef and tsym fields.
* make it work for m68k
Revision 1.25 2002/11/16 18:00:53 peter
* fix merged proc-procvar check
Revision 1.24 2002/11/15 01:58:46 peter
* merged changes from 1.0.7 up to 04-11
- -V option for generating bug report tracing
- more tracing for option parsing
- errors for cdecl and high()
- win32 import stabs
- win32 records<=8 are returned in eax:edx (turned off by default)
- heaptrc update
- more info for temp management in .s file with EXTDEBUG
Revision 1.23 2002/10/20 15:34:16 peter
* removed df_unique flag. It breaks code. For a good type=type <id>
a def copy is required
Revision 1.22 2002/10/10 16:07:57 florian
+ several widestring/pwidechar related stuff added
Revision 1.21 2002/10/09 21:01:41 florian
* variants aren't compatible with nil
Revision 1.20 2002/10/07 09:49:42 florian
* overloaded :=-operator is now searched when looking for possible
variant type conversions
Revision 1.19 2002/10/06 21:02:17 peter
* fixed limit checking for qword
Revision 1.18 2002/10/06 15:08:59 peter
* only check for forwarddefs the definitions that really belong to
the current procsym
Revision 1.17 2002/10/06 12:25:04 florian
+ proper support of type <id> = type <another id>;
Revision 1.16 2002/10/05 12:43:24 carl
* fixes for Delphi 6 compilation
(warning : Some features do not work under Delphi)
Revision 1.15 2002/10/05 00:50:01 peter
* check parameters from left to right in equal_paras, so default
parameters are checked at the end
Revision 1.14 2002/09/30 07:00:44 florian
* fixes to common code to get the alpha compiler compiled applied
Revision 1.13 2002/09/22 14:02:34 carl
* stack checking cannot be called before system unit is initialized
* MC68020 define
Revision 1.12 2002/09/16 14:11:12 peter
* add argument to equal_paras() to support default values or not
Revision 1.11 2002/09/15 17:54:46 peter
* allow default parameters in equal_paras
Revision 1.10 2002/09/08 11:10:17 carl
* bugfix 2109 (bad imho, but only way)
Revision 1.9 2002/09/07 15:25:02 peter
* old logs removed and tabs fixed
Revision 1.8 2002/09/07 09:16:55 carl
* fix my stupid copy and paste bug
Revision 1.7 2002/09/06 19:58:31 carl
* start bugfix 1996
* 64-bit typed constant now work correctly and fully (bugfix 2001)
Revision 1.6 2002/08/20 10:31:26 daniel
* Tcallnode.det_resulttype rewritten
Revision 1.5 2002/08/12 20:39:17 florian
* casting of classes to interface fixed when the interface was
implemented by a parent class
Revision 1.4 2002/08/12 14:17:56 florian
* nil is now recognized as being compatible with a dynamic array
Revision 1.3 2002/08/05 18:27:48 carl
+ more more more documentation
+ first version include/exclude (can't test though, not enough scratch for i386 :()...
Revision 1.2 2002/07/23 09:51:22 daniel
* Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
are worth comitting.
Revision 1.1 2002/07/20 11:57:53 florian
* types.pas renamed to defbase.pas because D6 contains a types
unit so this would conflicts if D6 programms are compiled
+ Willamette/SSE2 instructions to assembler added
Revision 1.75 2002/07/11 14:41:32 florian
* start of the new generic parameter handling
Revision 1.74 2002/07/01 16:23:54 peter
* cg64 patch
* basics for currency
* asnode updates for class and interface (not finished)
Revision 1.73 2002/05/18 13:34:21 peter
* readded missing revisions
Revision 1.72 2002/05/16 19:46:47 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.70 2002/05/12 16:53:16 peter
* moved entry and exitcode to ncgutil and cgobj
* foreach gets extra argument for passing local data to the
iterator function
* -CR checks also class typecasts at runtime by changing them
into as
* fixed compiler to cycle with the -CR option
* fixed stabs with elf writer, finally the global variables can
be watched
* removed a lot of routines from cga unit and replaced them by
calls to cgobj
* u32bit-s32bit updates for and,or,xor nodes. When one element is
u32bit then the other is typecasted also to u32bit without giving
a rangecheck warning/error.
* fixed pascal calling method with reversing also the high tree in
the parast, detected by tcalcst3 test
Revision 1.69 2002/04/25 20:16:39 peter
* moved more routines from cga/n386util
Revision 1.68 2002/04/15 19:08:22 carl
+ target_info.size_of_pointer -> pointer_size
+ some cleanup of unused types/variables
Revision 1.67 2002/04/07 13:40:29 carl
+ update documentation
Revision 1.66 2002/04/02 17:11:32 peter
* tlocation,treference update
* LOC_CONSTANT added for better constant handling
* secondadd splitted in multiple routines
* location_force_reg added for loading a location to a register
of a specified size
* secondassignment parses now first the right and then the left node
(this is compatible with Kylix). This saves a lot of push/pop especially
with string operations
* adapted some routines to use the new cg methods
Revision 1.65 2002/04/01 20:57:14 jonas
* fixed web bug 1907
* fixed some other procvar related bugs (all related to accepting procvar
constructs with either too many or too little parameters)
(both merged, includes second typo fix of pexpr.pas)
Revision 1.64 2002/01/24 18:25:53 peter
* implicit result variable generation for assembler routines
* removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
Revision 1.63 2002/01/24 12:33:53 jonas
* adapted ranges of native types to int64 (e.g. high cardinal is no
longer longint($ffffffff), but just $fffffff in psystem)
* small additional fix in 64bit rangecheck code generation for 32 bit
processors
* adaption of ranges required the matching talgorithm used for selecting
which overloaded procedure to call to be adapted. It should now always
select the closest match for ordinal parameters.
+ inttostr(qword) in sysstr.inc/sysstrh.inc
+ abs(int64), sqr(int64), sqr(qword) in systemh.inc/generic.inc (previous
fixes were required to be able to add them)
* is_in_limit() moved from ncal to types unit, should always be used
instead of direct comparisons of low/high values of orddefs because
qword is a special case
}
Reference in New Issue View Git Blame Copy Permalink