mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-29 02:33:42 +02:00
a6c7ed5e61
Set the result of a vector add node to a vector type. Ensure that that these vector types are still asignment-compatible with regular array types (may want to change this when we expose vector types), and don't remove type conversions from vector types to array types (so the code generator pass can still rely on the resultdef being a vector type)
2955 lines
133 KiB
ObjectPascal
2955 lines
133 KiB
ObjectPascal
{
|
||
Copyright (c) 1998-2002 by Florian Klaempfl
|
||
|
||
Compare definitions and parameter lists
|
||
|
||
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 defcmp;
|
||
|
||
{$i fpcdefs.inc}
|
||
|
||
interface
|
||
|
||
uses
|
||
cclasses,
|
||
globtype,globals,
|
||
node,
|
||
symconst,symtype,symdef,symbase;
|
||
|
||
type
|
||
{ if acp is cp_all the var const or nothing are considered equal }
|
||
tcompare_paras_type = ( cp_none, cp_value_equal_const, cp_all,cp_procvar);
|
||
tcompare_paras_option = (
|
||
cpo_allowdefaults,
|
||
cpo_ignorehidden, // ignore hidden parameters
|
||
cpo_allowconvert,
|
||
cpo_comparedefaultvalue,
|
||
cpo_openequalisexact,
|
||
cpo_ignoreuniv,
|
||
cpo_warn_incompatible_univ,
|
||
cpo_ignorevarspez, // ignore parameter access type
|
||
cpo_ignoreframepointer, // ignore frame pointer parameter (for assignment-compatibility of global procedures to nested procvars)
|
||
cpo_compilerproc,
|
||
cpo_rtlproc,
|
||
cpo_generic, // two different undefined defs (or a constraint in the forward) alone or in open arrays are
|
||
// treated as exactly equal (also in open arrays) if they are owned by their respective procdefs
|
||
cpo_ignoreself // ignore Self parameter, but leave other hidden parameters
|
||
);
|
||
|
||
tcompare_paras_options = set of tcompare_paras_option;
|
||
|
||
tcompare_defs_option = (
|
||
cdo_internal,
|
||
cdo_explicit,
|
||
cdo_check_operator,
|
||
cdo_allow_variant,
|
||
cdo_parameter,
|
||
cdo_warn_incompatible_univ,
|
||
cdo_strict_undefined_check, // undefined defs are incompatible to everything except other undefined defs
|
||
cdo_equal_check, // this call is only to check equality -> shortcut some expensive checks
|
||
cdo_strict_genconstraint_check // check that generic constraints match (used for forward declarations)
|
||
);
|
||
tcompare_defs_options = set of tcompare_defs_option;
|
||
|
||
tconverttype = (tc_none,
|
||
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_cstring_2_int,
|
||
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_real_2_currency,
|
||
tc_proc_2_procvar,
|
||
tc_nil_2_methodprocvar,
|
||
tc_arrayconstructor_2_set,
|
||
tc_set_to_set,
|
||
tc_cord_2_pointer,
|
||
tc_intf_2_string,
|
||
tc_intf_2_guid,
|
||
tc_class_2_intf,
|
||
tc_char_2_char,
|
||
tc_dynarray_2_openarray,
|
||
tc_pwchar_2_string,
|
||
tc_variant_2_dynarray,
|
||
tc_dynarray_2_variant,
|
||
tc_variant_2_enum,
|
||
tc_enum_2_variant,
|
||
tc_interface_2_variant,
|
||
tc_variant_2_interface,
|
||
tc_array_2_dynarray,
|
||
tc_elem_2_openarray,
|
||
tc_arrayconstructor_2_dynarray,
|
||
tc_arrayconstructor_2_array,
|
||
tc_anonproc_2_funcref,
|
||
tc_procvar_2_funcref
|
||
);
|
||
|
||
function compare_defs_ext(def_from,def_to : tdef;
|
||
fromtreetype : tnodetype;
|
||
var doconv : tconverttype;
|
||
var operatorpd : tprocdef;
|
||
cdoptions:tcompare_defs_options):tequaltype;
|
||
|
||
{ Returns if the type def_from can be converted to def_to or if both types are equal }
|
||
function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype;
|
||
|
||
{ Returns true, if def1 and def2 are semantically the same }
|
||
function equal_defs(def_from,def_to: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;
|
||
|
||
{# true, if two parameter lists are equal
|
||
if acp is cp_all, all have to match exactly
|
||
if acp is cp_value_equal_const call by value
|
||
and call by const parameter are assumed as
|
||
equal
|
||
if acp is cp_procvar then the varspez have to match,
|
||
and all parameter types must be at least te_equal
|
||
if acp is cp_none, then we don't check the varspez at all
|
||
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)
|
||
|
||
para1 is expected to be parameter list of the first encountered
|
||
declaration (interface, forward), and para2 that of the second one
|
||
(important in case of cpo_comparedefaultvalue)
|
||
}
|
||
function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
|
||
|
||
{ 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;checkincompatibleuniv: boolean):tequaltype;
|
||
|
||
{ True if a function can be assigned to a function reference }
|
||
function proc_to_funcref_equal(def1:tabstractprocdef;def2:tobjectdef):tequaltype;
|
||
|
||
{ returns the equality between a function and a function reference }
|
||
function proc_to_funcref_conv(def1:tabstractprocdef;def2:tobjectdef):tequaltype;
|
||
|
||
{ Checks if an funcref interface can be assigned to the other }
|
||
function funcref_equal(def1,def2:tobjectdef):tequaltype;
|
||
|
||
{ Parentdef is the definition of a method defined in a parent class or interface }
|
||
{ Childdef is the definition of a method defined in a child class, interface or }
|
||
{ a class implementing an interface with parentdef. }
|
||
{ Returns true if the resultdef of childdef can be used to implement/override }
|
||
{ parentdef's resultdef }
|
||
function compatible_childmethod_resultdef(parentretdef, childretdef: tdef): boolean;
|
||
|
||
{ Checks whether the class impldef or one of its parent classes implements }
|
||
{ the interface intfdef and returns the corresponding "implementation link }
|
||
function find_implemented_interface(impldef,intfdef:tobjectdef):timplementedinterface;
|
||
|
||
{ Checks whether to defs are related to each other. Thereby the following }
|
||
{ cases of curdef are implemented: }
|
||
{ - stringdef: on JVM JLObject, JLString and AnsiString are compatible }
|
||
{ - recorddef: on JVM records are compatible to java_fpcbaserecordtype }
|
||
{ and JLObject }
|
||
{ - objectdef: if it inherits from otherdef or they are equal }
|
||
function def_is_related(curdef,otherdef:tdef):boolean;
|
||
|
||
{ Checks whether two defs for parameters or result types of a generic }
|
||
{ routine can be considered as equal. Requires the symtables of the }
|
||
{ procdefs the parameters defs shall belong to. }
|
||
function equal_genfunc_paradefs(fwdef,currdef:tdef;fwpdst,currpdst:tsymtable):boolean;
|
||
|
||
|
||
implementation
|
||
|
||
uses
|
||
verbose,systems,constexp,
|
||
symtable,symsym,symcpu,
|
||
defutil,symutil;
|
||
|
||
|
||
function same_genconstraint_interfaces(intffrom,intfto:tobject):boolean;
|
||
begin
|
||
result:=equal_defs(tdef(intffrom),tdef(intfto));
|
||
end;
|
||
|
||
|
||
function same_objectdef_implementedinterfaces(intffrom,intfto:tobject):boolean;
|
||
begin
|
||
result:=equal_defs(TImplementedInterface(intffrom).IntfDef,TImplementedInterface(intfto).IntfDef);
|
||
end;
|
||
|
||
|
||
function compare_defs_ext(def_from,def_to : tdef;
|
||
fromtreetype : tnodetype;
|
||
var doconv : tconverttype;
|
||
var operatorpd : tprocdef;
|
||
cdoptions:tcompare_defs_options):tequaltype;
|
||
|
||
{ tordtype:
|
||
uvoid,
|
||
u8bit,u16bit,u32bit,u64bit,
|
||
s8bit,s16bit,s32bit,s64bit,
|
||
pasbool, bool8bit,bool16bit,bool32bit,bool64bit,
|
||
uchar,uwidechar,scurrency,customint }
|
||
|
||
type
|
||
tbasedef=(bvoid,bchar,bint,bbool);
|
||
const
|
||
basedeftbl:array[tordtype] of tbasedef =
|
||
(bvoid,
|
||
bint,bint,bint,bint,bint,
|
||
bint,bint,bint,bint,bint,
|
||
bbool,bbool,bbool,bbool,bbool,
|
||
bbool,bbool,bbool,bbool,
|
||
bchar,bchar,bint,bint);
|
||
|
||
basedefconvertsimplicit : array[tbasedef,tbasedef] of tconverttype =
|
||
{ void, char, int, bool }
|
||
((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_not_possible),
|
||
(tc_not_possible,tc_not_possible,tc_not_possible,tc_bool_2_bool));
|
||
basedefconvertsexplicit : array[tbasedef,tbasedef] of tconverttype =
|
||
{ void, char, int, bool }
|
||
((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
|
||
(tc_not_possible,tc_char_2_char,tc_int_2_int,tc_int_2_bool),
|
||
(tc_not_possible,tc_int_2_int,tc_int_2_int,tc_int_2_bool),
|
||
(tc_not_possible,tc_bool_2_int,tc_bool_2_int,tc_bool_2_bool));
|
||
|
||
type
|
||
tsame_interface_func = function(intffrom,intfto:tobject):boolean;
|
||
|
||
function same_interface_lists(listfrom,listto:tfpobjectlist;checkfunc:tsame_interface_func):boolean;
|
||
var
|
||
i : longint;
|
||
begin
|
||
result:=false;
|
||
if assigned(listfrom) xor assigned(listto) then
|
||
exit;
|
||
if not assigned(listfrom) and not assigned(listto) then
|
||
exit(true);
|
||
if listfrom.count<>listto.count then
|
||
exit;
|
||
for i:=0 to listfrom.count-1 do
|
||
if not checkfunc(tdef(listfrom[i]),tdef(listto[i])) then
|
||
exit;
|
||
result:=true;
|
||
end;
|
||
|
||
|
||
var
|
||
subeq,eq : tequaltype;
|
||
hd1,hd2 : tdef;
|
||
def_generic : tstoreddef;
|
||
hct : tconverttype;
|
||
hobjdef : tobjectdef;
|
||
hpd : tprocdef;
|
||
i : longint;
|
||
diff : boolean;
|
||
symfrom,symto : tsym;
|
||
genconstrfrom,genconstrto : tgenericconstraintdata;
|
||
begin
|
||
eq:=te_incompatible;
|
||
doconv:=tc_not_possible;
|
||
|
||
{ safety check }
|
||
if not(assigned(def_from) and assigned(def_to)) then
|
||
begin
|
||
compare_defs_ext:=te_incompatible;
|
||
exit;
|
||
end;
|
||
|
||
{ resolve anonymous external definitions }
|
||
if def_from.typ=objectdef then
|
||
def_from:=find_real_class_definition(tobjectdef(def_from),false);
|
||
if def_to.typ=objectdef then
|
||
def_to:=find_real_class_definition(tobjectdef(def_to),false);
|
||
|
||
{ same def? then we've an exact match }
|
||
if def_from=def_to then
|
||
begin
|
||
doconv:=tc_equal;
|
||
compare_defs_ext:=te_exact;
|
||
exit;
|
||
end;
|
||
|
||
if cdo_strict_undefined_check in cdoptions then
|
||
begin
|
||
{ two different undefined defs are not considered equal }
|
||
if (def_from.typ=undefineddef) and
|
||
(def_to.typ=undefineddef) then
|
||
begin
|
||
doconv:=tc_not_possible;
|
||
compare_defs_ext:=te_incompatible;
|
||
exit;
|
||
end;
|
||
|
||
{ if only one def is a undefined def then they are not considered as
|
||
equal}
|
||
if (
|
||
(def_from.typ=undefineddef) or
|
||
assigned(tstoreddef(def_from).genconstraintdata)
|
||
) or (
|
||
(def_to.typ=undefineddef) or
|
||
assigned(tstoreddef(def_to).genconstraintdata)
|
||
) then
|
||
begin
|
||
doconv:=tc_not_possible;
|
||
compare_defs_ext:=te_incompatible;
|
||
exit;
|
||
end;
|
||
end
|
||
else
|
||
begin
|
||
{ undefined defs are considered equal to everything }
|
||
if (def_from.typ=undefineddef) or
|
||
(def_to.typ=undefineddef) then
|
||
begin
|
||
{ for strict checks with genconstraints pure undefineddefs are
|
||
not compatible with constrained defs }
|
||
if (cdo_strict_genconstraint_check in cdoptions) and
|
||
(
|
||
assigned(tstoreddef(def_from).genconstraintdata) or
|
||
assigned(tstoreddef(def_to).genconstraintdata)
|
||
) then
|
||
begin
|
||
doconv:=tc_not_possible;
|
||
compare_defs_ext:=te_incompatible;
|
||
exit;
|
||
end;
|
||
doconv:=tc_equal;
|
||
compare_defs_ext:=te_exact;
|
||
exit;
|
||
end;
|
||
|
||
{ either type has constraints }
|
||
if assigned(tstoreddef(def_from).genconstraintdata) or
|
||
assigned(tstoreddef(def_to).genconstraintdata) then
|
||
begin
|
||
{ this is bascially a poor man's type checking, if there is a chance
|
||
that the types are equal considering the constraints, this needs probably
|
||
to be improved and maybe factored out or even result in a recursive compare_defs_ext }
|
||
if (def_from.typ<>def_to.typ) and
|
||
{ formaldefs are compatible with everything }
|
||
not(def_from.typ in [formaldef]) and
|
||
not(def_to.typ in [formaldef]) and
|
||
{ constants could get another deftype (e.g. niln) }
|
||
not(fromtreetype in nodetype_const) then
|
||
begin
|
||
{ not compatible anyway }
|
||
doconv:=tc_not_possible;
|
||
compare_defs_ext:=te_incompatible;
|
||
exit;
|
||
end;
|
||
|
||
{ for a strict check of the generic constraints the constraints
|
||
of both parts need to match }
|
||
if cdo_strict_genconstraint_check in cdoptions then
|
||
begin
|
||
genconstrfrom:=tstoreddef(def_from).genconstraintdata;
|
||
genconstrto:=tstoreddef(def_to).genconstraintdata;
|
||
if (
|
||
{ both parts need to be constraints }
|
||
not assigned(genconstrfrom) or
|
||
not assigned(genconstrto)
|
||
) or (
|
||
{ same type of def required }
|
||
def_from.typ<>def_to.typ
|
||
) or (
|
||
{ for objectdefs same object type as well as parent required }
|
||
(def_from.typ=objectdef) and
|
||
(
|
||
(tobjectdef(def_from).objecttype<>tobjectdef(def_to).objecttype) or
|
||
not equal_defs(tobjectdef(def_from).childof,tobjectdef(def_to).childof)
|
||
)
|
||
) or (
|
||
{ the flags need to match }
|
||
genconstrfrom.flags<>genconstrto.flags
|
||
) or
|
||
{ the interfaces of the constraints need to match }
|
||
not same_interface_lists(genconstrfrom.interfaces,genconstrto.interfaces,@same_genconstraint_interfaces) or
|
||
(
|
||
{ for objectdefs the implemented interfaces need to match }
|
||
(def_from.typ=objectdef) and not
|
||
same_interface_lists(tobjectdef(def_from).implementedinterfaces,tobjectdef(def_to).implementedinterfaces,@same_objectdef_implementedinterfaces)
|
||
) then
|
||
begin
|
||
doconv:=tc_not_possible;
|
||
compare_defs_ext:=te_incompatible;
|
||
exit;
|
||
end;
|
||
end;
|
||
|
||
{ maybe we are in generic type declaration/implementation.
|
||
In this case constraint in comparison to not specialized generic
|
||
is not "exact" nor "incompatible" }
|
||
if not(((df_genconstraint in def_from.defoptions) and
|
||
([df_generic,df_specialization]*def_to.defoptions=[df_generic])
|
||
) or
|
||
(
|
||
(df_genconstraint in def_to.defoptions) and
|
||
([df_generic,df_specialization]*def_from.defoptions=[df_generic]))
|
||
) then
|
||
begin
|
||
{ one is definitely a constraint, for the other we don't
|
||
care right now }
|
||
doconv:=tc_equal;
|
||
compare_defs_ext:=te_exact;
|
||
exit;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{ two specializations are considered equal if they specialize the same
|
||
generic with the same types }
|
||
if (df_specialization in def_from.defoptions) and
|
||
(df_specialization in def_to.defoptions) and
|
||
(tstoreddef(def_from).genericdef=tstoreddef(def_to).genericdef) then
|
||
begin
|
||
if assigned(tstoreddef(def_from).genericparas) xor
|
||
assigned(tstoreddef(def_to).genericparas) then
|
||
internalerror(2013030901);
|
||
diff:=false;
|
||
if assigned(tstoreddef(def_from).genericparas) then
|
||
begin
|
||
if tstoreddef(def_from).genericparas.count<>tstoreddef(def_to).genericparas.count then
|
||
internalerror(2012091301);
|
||
for i:=0 to tstoreddef(def_from).genericparas.count-1 do
|
||
begin
|
||
if tstoreddef(def_from).genericparas.nameofindex(i)<>tstoreddef(def_to).genericparas.nameofindex(i) then
|
||
internalerror(2012091302);
|
||
symfrom:=ttypesym(tstoreddef(def_from).genericparas[i]);
|
||
symto:=ttypesym(tstoreddef(def_to).genericparas[i]);
|
||
if not (symfrom.typ in [typesym,constsym]) or not (symto.typ in [typesym,constsym]) then
|
||
internalerror(2012121401);
|
||
if symto.typ<>symfrom.typ then
|
||
diff:=true
|
||
else if (symfrom.typ=constsym) and (symto.typ=constsym) and not equal_constsym(tconstsym(symfrom),tconstsym(symto),true) then
|
||
diff:=true
|
||
else if not equal_defs(ttypesym(symfrom).typedef,ttypesym(symto).typedef) then
|
||
diff:=true;
|
||
if diff then
|
||
break;
|
||
end;
|
||
end;
|
||
if not diff then
|
||
begin
|
||
doconv:=tc_equal;
|
||
{ the definitions are not exactly the same, but only equal }
|
||
compare_defs_ext:=te_equal;
|
||
exit;
|
||
end;
|
||
end;
|
||
{ handling of partial specializations }
|
||
if (
|
||
(df_generic in def_to.defoptions) and
|
||
(df_specialization in def_from.defoptions) and
|
||
(tstoreddef(def_from).genericdef=def_to)
|
||
) or (
|
||
(df_generic in def_from.defoptions) and
|
||
(df_specialization in def_to.defoptions) and
|
||
(tstoreddef(def_to).genericdef=def_from)
|
||
) then
|
||
begin
|
||
if tstoreddef(def_from).genericdef=def_to then
|
||
def_generic:=tstoreddef(def_to)
|
||
else
|
||
def_generic:=tstoreddef(def_from);
|
||
if not assigned(def_generic.genericparas) then
|
||
internalerror(2014052306);
|
||
diff:=false;
|
||
for i:=0 to def_generic.genericparas.count-1 do
|
||
begin
|
||
symfrom:=tsym(def_generic.genericparas[i]);
|
||
if symfrom.typ<>typesym then
|
||
internalerror(2014052307);
|
||
if ttypesym(symfrom).typedef.typ<>undefineddef then
|
||
diff:=true;
|
||
if diff then
|
||
break;
|
||
end;
|
||
if not diff then
|
||
begin
|
||
doconv:=tc_equal;
|
||
{ the definitions are not exactly the same, but only equal }
|
||
compare_defs_ext:=te_equal;
|
||
exit;
|
||
end;
|
||
end;
|
||
|
||
{ we walk the wanted (def_to) types and check then the def_from
|
||
types if there is a conversion possible }
|
||
case def_to.typ of
|
||
orddef :
|
||
begin
|
||
case def_from.typ of
|
||
orddef :
|
||
begin
|
||
if (torddef(def_from).ordtype=torddef(def_to).ordtype) then
|
||
begin
|
||
case torddef(def_from).ordtype of
|
||
uchar,uwidechar,
|
||
u8bit,u16bit,u32bit,u64bit,
|
||
s8bit,s16bit,s32bit,s64bit:
|
||
begin
|
||
if (torddef(def_from).low>=torddef(def_to).low) and
|
||
(torddef(def_from).high<=torddef(def_to).high) then
|
||
eq:=te_equal
|
||
else
|
||
begin
|
||
doconv:=tc_int_2_int;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
uvoid,
|
||
pasbool1,pasbool8,pasbool16,pasbool32,pasbool64,
|
||
bool8bit,bool16bit,bool32bit,bool64bit,
|
||
scurrency:
|
||
eq:=te_equal;
|
||
else
|
||
internalerror(200210061);
|
||
end;
|
||
end
|
||
{ currency cannot be implicitly converted to an ordinal
|
||
type }
|
||
else if not is_currency(def_from) or
|
||
(cdo_explicit in cdoptions) then
|
||
begin
|
||
if cdo_explicit in cdoptions then
|
||
doconv:=basedefconvertsexplicit[basedeftbl[torddef(def_from).ordtype],basedeftbl[torddef(def_to).ordtype]]
|
||
else
|
||
doconv:=basedefconvertsimplicit[basedeftbl[torddef(def_from).ordtype],basedeftbl[torddef(def_to).ordtype]];
|
||
if (doconv=tc_not_possible) then
|
||
eq:=te_incompatible
|
||
else if (not is_in_limit(def_from,def_to)) then
|
||
{ "punish" bad type conversions :) (JM) }
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
enumdef :
|
||
begin
|
||
{ needed for char(enum) }
|
||
if cdo_explicit in cdoptions then
|
||
begin
|
||
doconv:=tc_int_2_int;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
floatdef :
|
||
begin
|
||
if is_currency(def_to) then
|
||
begin
|
||
doconv:=tc_real_2_currency;
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
objectdef:
|
||
begin
|
||
if (m_delphi in current_settings.modeswitches) and
|
||
is_implicit_pointer_object_type(def_from) and
|
||
(cdo_explicit in cdoptions) then
|
||
begin
|
||
eq:=te_convert_l1;
|
||
if (fromtreetype=niln) then
|
||
begin
|
||
{ will be handled by the constant folding }
|
||
doconv:=tc_equal;
|
||
end
|
||
else
|
||
doconv:=tc_int_2_int;
|
||
end;
|
||
end;
|
||
classrefdef,
|
||
procvardef,
|
||
pointerdef :
|
||
begin
|
||
if cdo_explicit in cdoptions then
|
||
begin
|
||
eq:=te_convert_l1;
|
||
if (fromtreetype=niln) then
|
||
begin
|
||
{ will be handled by the constant folding }
|
||
doconv:=tc_equal;
|
||
end
|
||
else
|
||
doconv:=tc_int_2_int;
|
||
end;
|
||
end;
|
||
arraydef :
|
||
begin
|
||
if (m_mac in current_settings.modeswitches) and
|
||
is_integer(def_to) and
|
||
(fromtreetype=stringconstn) then
|
||
begin
|
||
eq:=te_convert_l3;
|
||
doconv:=tc_cstring_2_int;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
|
||
stringdef :
|
||
begin
|
||
case def_from.typ of
|
||
stringdef :
|
||
begin
|
||
{ Constant string }
|
||
if (fromtreetype=stringconstn) and
|
||
is_shortstring(def_from) and
|
||
is_shortstring(def_to) then
|
||
eq:=te_equal
|
||
else if (tstringdef(def_to).stringtype=st_ansistring) and
|
||
(tstringdef(def_from).stringtype=st_ansistring) then
|
||
begin
|
||
{ don't convert ansistrings if any condition is true:
|
||
1) same encoding
|
||
2) from explicit codepage ansistring to ansistring and vice versa
|
||
3) from any ansistring to rawbytestring
|
||
4) from rawbytestring to any ansistring }
|
||
if (tstringdef(def_from).encoding=tstringdef(def_to).encoding) or
|
||
((tstringdef(def_to).encoding=0) and (tstringdef(def_from).encoding=getansistringcodepage)) or
|
||
((tstringdef(def_to).encoding=getansistringcodepage) and (tstringdef(def_from).encoding=0)) or
|
||
(tstringdef(def_to).encoding=globals.CP_NONE) or
|
||
(tstringdef(def_from).encoding=globals.CP_NONE) then
|
||
begin
|
||
eq:=te_equal;
|
||
end
|
||
else
|
||
begin
|
||
doconv := tc_string_2_string;
|
||
|
||
{ prefere conversion to utf8 codepage }
|
||
if tstringdef(def_to).encoding = globals.CP_UTF8 then
|
||
eq:=te_convert_l1
|
||
{ else to AnsiString type }
|
||
else if def_to=getansistringdef then
|
||
eq:=te_convert_l2
|
||
{ else to AnsiString with other codepage }
|
||
else
|
||
eq:=te_convert_l3;
|
||
end
|
||
end
|
||
else
|
||
{ same string type ? }
|
||
if (tstringdef(def_from).stringtype=tstringdef(def_to).stringtype) and
|
||
{ for shortstrings also the length must match }
|
||
((tstringdef(def_from).stringtype<>st_shortstring) or
|
||
(tstringdef(def_from).len=tstringdef(def_to).len)) and
|
||
{ for ansi- and unicodestrings also the encoding must match }
|
||
(not(tstringdef(def_from).stringtype in [st_ansistring,st_unicodestring]) or
|
||
(tstringdef(def_from).encoding=tstringdef(def_to).encoding)) then
|
||
eq:=te_equal
|
||
else
|
||
begin
|
||
doconv:=tc_string_2_string;
|
||
case tstringdef(def_from).stringtype of
|
||
st_widestring :
|
||
begin
|
||
case tstringdef(def_to).stringtype of
|
||
{ Prefer conversions to unicodestring }
|
||
st_unicodestring: eq:=te_convert_l1;
|
||
{ else prefer conversions to ansistring }
|
||
st_ansistring: eq:=te_convert_l2;
|
||
else
|
||
eq:=te_convert_l3;
|
||
end;
|
||
end;
|
||
st_unicodestring :
|
||
begin
|
||
case tstringdef(def_to).stringtype of
|
||
{ Prefer conversions to widestring }
|
||
st_widestring: eq:=te_convert_l1;
|
||
{ else prefer conversions to ansistring }
|
||
st_ansistring: eq:=te_convert_l2;
|
||
else
|
||
eq:=te_convert_l3;
|
||
end;
|
||
end;
|
||
st_shortstring :
|
||
begin
|
||
{ Prefer shortstrings of different length or conversions
|
||
from shortstring to ansistring }
|
||
case tstringdef(def_to).stringtype of
|
||
st_shortstring: eq:=te_convert_l1;
|
||
st_ansistring:
|
||
if tstringdef(def_to).encoding=globals.CP_UTF8 then
|
||
eq:=te_convert_l2
|
||
else if def_to=getansistringdef then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l4;
|
||
st_unicodestring: eq:=te_convert_l5;
|
||
else
|
||
eq:=te_convert_l6;
|
||
end;
|
||
end;
|
||
st_ansistring :
|
||
begin
|
||
{ Prefer conversion to widestrings }
|
||
case tstringdef(def_to).stringtype of
|
||
st_unicodestring: eq:=te_convert_l4;
|
||
st_widestring: eq:=te_convert_l5;
|
||
else
|
||
eq:=te_convert_l6;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
end;
|
||
orddef :
|
||
begin
|
||
{ char to string}
|
||
if is_char(def_from) then
|
||
begin
|
||
doconv:=tc_char_2_string;
|
||
case tstringdef(def_to).stringtype of
|
||
st_shortstring: eq:=te_convert_l1;
|
||
st_ansistring: eq:=te_convert_l2;
|
||
st_unicodestring: eq:=te_convert_l3;
|
||
st_widestring: eq:=te_convert_l4;
|
||
else
|
||
eq:=te_convert_l5;
|
||
end;
|
||
end
|
||
else
|
||
if is_widechar(def_from) then
|
||
begin
|
||
doconv:=tc_char_2_string;
|
||
case tstringdef(def_to).stringtype of
|
||
st_unicodestring: eq:=te_convert_l1;
|
||
st_widestring: eq:=te_convert_l2;
|
||
st_ansistring: eq:=te_convert_l3;
|
||
st_shortstring: eq:=te_convert_l4;
|
||
else
|
||
eq:=te_convert_l5;
|
||
end;
|
||
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_open_chararray(def_from)) and
|
||
{ bitpacked arrays of char whose element bitsize is not
|
||
8 cannot be auto-converted to strings }
|
||
(not is_packed_array(def_from) or
|
||
(tarraydef(def_from).elementdef.packedbitsize=8)) then
|
||
begin
|
||
{ "Untyped" stringconstn is an array of char }
|
||
if fromtreetype=stringconstn then
|
||
begin
|
||
doconv:=tc_string_2_string;
|
||
{ prefered string type depends on the $H switch }
|
||
if (m_default_unicodestring in current_settings.modeswitches) and
|
||
(cs_refcountedstrings in current_settings.localswitches) then
|
||
case tstringdef(def_to).stringtype of
|
||
st_unicodestring: eq:=te_equal;
|
||
st_widestring: eq:=te_convert_l1;
|
||
// widechar: eq:=te_convert_l2;
|
||
// ansichar: eq:=te_convert_l3;
|
||
st_ansistring: eq:=te_convert_l4;
|
||
st_shortstring: eq:=te_convert_l5;
|
||
else
|
||
eq:=te_convert_l6;
|
||
end
|
||
else if not(cs_refcountedstrings in current_settings.localswitches) and
|
||
(tstringdef(def_to).stringtype=st_shortstring) then
|
||
eq:=te_equal
|
||
else if not(m_default_unicodestring in current_settings.modeswitches) and
|
||
(cs_refcountedstrings in current_settings.localswitches) and
|
||
(tstringdef(def_to).stringtype=st_ansistring) then
|
||
eq:=te_equal
|
||
else if tstringdef(def_to).stringtype in [st_widestring,st_unicodestring] then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
begin
|
||
doconv:=tc_chararray_2_string;
|
||
if is_open_array(def_from) then
|
||
begin
|
||
if is_ansistring(def_to) then
|
||
eq:=te_convert_l1
|
||
else if is_wide_or_unicode_string(def_to) then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l2;
|
||
end
|
||
else
|
||
begin
|
||
if is_shortstring(def_to) then
|
||
begin
|
||
{ Only compatible with arrays that fit
|
||
smaller than 255 chars }
|
||
if (def_from.size <= 255) then
|
||
eq:=te_convert_l1;
|
||
end
|
||
else if is_ansistring(def_to) then
|
||
begin
|
||
if (def_from.size > 255) then
|
||
eq:=te_convert_l1
|
||
else
|
||
eq:=te_convert_l2;
|
||
end
|
||
else if is_wide_or_unicode_string(def_to) then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
end
|
||
else
|
||
{ array of widechar to string, the length check is done by the firstpass of this node }
|
||
if is_widechararray(def_from) or is_open_widechararray(def_from) then
|
||
begin
|
||
doconv:=tc_chararray_2_string;
|
||
if is_wide_or_unicode_string(def_to) then
|
||
eq:=te_convert_l1
|
||
else
|
||
{ size of widechar array is double due the sizeof a widechar }
|
||
if not(is_shortstring(def_to) and (is_open_widechararray(def_from) or (def_from.size>255*sizeof(widechar)))) then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
pointerdef :
|
||
begin
|
||
{ pchar can be assigned to short/ansistrings,
|
||
but not in tp7 compatible mode }
|
||
if not(m_tp7 in current_settings.modeswitches) then
|
||
begin
|
||
if is_pchar(def_from) then
|
||
begin
|
||
doconv:=tc_pchar_2_string;
|
||
{ prefer ansistrings/unicodestrings because pchars
|
||
can overflow shortstrings; don't use l1/l2/l3
|
||
because then pchar -> ansistring has the same
|
||
preference as conststring -> pchar, and this
|
||
breaks webtbs/tw3328.pp }
|
||
if is_ansistring(def_to) then
|
||
eq:=te_convert_l2
|
||
else if is_wide_or_unicode_string(def_to) then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l4
|
||
end
|
||
else if is_pwidechar(def_from) then
|
||
begin
|
||
doconv:=tc_pwchar_2_string;
|
||
if is_wide_or_unicode_string(def_to) then
|
||
eq:=te_convert_l1
|
||
else
|
||
{ shortstring and ansistring can both result in
|
||
data loss, so don't prefer one over the other }
|
||
eq:=te_convert_l3;
|
||
end;
|
||
end;
|
||
end;
|
||
objectdef :
|
||
begin
|
||
{ corba interface -> id string }
|
||
if is_interfacecorba(def_from) then
|
||
begin
|
||
doconv:=tc_intf_2_string;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else if (def_from=java_jlstring) then
|
||
begin
|
||
if is_wide_or_unicode_string(def_to) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_equal;
|
||
end
|
||
else if def_to.typ=stringdef then
|
||
begin
|
||
doconv:=tc_string_2_string;
|
||
if is_ansistring(def_to) then
|
||
eq:=te_convert_l2
|
||
else
|
||
eq:=te_convert_l3
|
||
end;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
|
||
floatdef :
|
||
begin
|
||
case def_from.typ of
|
||
orddef :
|
||
begin { ordinal to real }
|
||
{ only for implicit and internal typecasts in tp }
|
||
if (([cdo_explicit,cdo_internal] * cdoptions <> [cdo_explicit]) or
|
||
(not(m_tp7 in current_settings.modeswitches))) and
|
||
(is_integer(def_from) or
|
||
(is_currency(def_from) and
|
||
(s64currencytype.typ = floatdef))) then
|
||
begin
|
||
doconv:=tc_int_2_real;
|
||
|
||
{ prefer single over others }
|
||
if is_single(def_to) then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l4;
|
||
end
|
||
else if is_currency(def_from)
|
||
{ and (s64currencytype.typ = orddef)) } then
|
||
begin
|
||
{ prefer conversion to orddef in this case, unless }
|
||
{ the orddef < currency (then it will get convert l3, }
|
||
{ and conversion to float is favoured) }
|
||
doconv:=tc_int_2_real;
|
||
if is_extended(def_to) then
|
||
eq:=te_convert_l1
|
||
else if is_double(def_to) then
|
||
eq:=te_convert_l2
|
||
else if is_single(def_to) then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
floatdef :
|
||
begin
|
||
if tfloatdef(def_from).floattype=tfloatdef(def_to).floattype then
|
||
eq:=te_equal
|
||
else
|
||
begin
|
||
{ Delphi does not allow explicit type conversions for float types like:
|
||
single_var:=single(double_var);
|
||
But if such conversion is inserted by compiler (internal) for some purpose,
|
||
it should be allowed even in Delphi mode. }
|
||
if (fromtreetype=realconstn) or
|
||
not((cdoptions*[cdo_explicit,cdo_internal]=[cdo_explicit]) and
|
||
(m_delphi in current_settings.modeswitches)) then
|
||
begin
|
||
doconv:=tc_real_2_real;
|
||
{ do we lose precision? }
|
||
if (def_to.size<def_from.size) or
|
||
(is_currency(def_from) and (tfloatdef(def_to).floattype in [s32real,s64real])) then
|
||
begin
|
||
if is_currency(def_from) and (tfloatdef(def_to).floattype=s32real) then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l2
|
||
end
|
||
else
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
|
||
enumdef :
|
||
begin
|
||
case def_from.typ of
|
||
enumdef :
|
||
begin
|
||
if cdo_explicit in cdoptions then
|
||
begin
|
||
eq:=te_convert_l1;
|
||
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
|
||
eq:=te_convert_l1;
|
||
{ because of packenum they can have different sizes! (JM) }
|
||
doconv:=tc_int_2_int;
|
||
end
|
||
else
|
||
begin
|
||
{ assignment of an enum symbol to an unique type? }
|
||
if (fromtreetype=ordconstn) and
|
||
(tenumsym(tenumdef(hd1).getfirstsym)=tenumsym(tenumdef(hd2).getfirstsym)) then
|
||
begin
|
||
{ because of packenum they can have different sizes! (JM) }
|
||
eq:=te_convert_l1;
|
||
doconv:=tc_int_2_int;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
orddef :
|
||
begin
|
||
if cdo_explicit in cdoptions then
|
||
begin
|
||
eq:=te_convert_l1;
|
||
doconv:=tc_int_2_int;
|
||
end;
|
||
end;
|
||
variantdef :
|
||
begin
|
||
eq:=te_convert_l1;
|
||
doconv:=tc_variant_2_enum;
|
||
end;
|
||
pointerdef :
|
||
begin
|
||
{ ugly, but delphi allows it }
|
||
if cdo_explicit in cdoptions then
|
||
begin
|
||
if target_info.system in systems_jvm then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else if m_delphi in current_settings.modeswitches then
|
||
begin
|
||
doconv:=tc_int_2_int;
|
||
eq:=te_convert_l1;
|
||
end
|
||
end;
|
||
end;
|
||
objectdef:
|
||
begin
|
||
{ ugly, but delphi allows it }
|
||
if (cdo_explicit in cdoptions) and
|
||
is_class_or_interface_or_dispinterface_or_objc_or_java(def_from) then
|
||
begin
|
||
{ in Java enums /are/ class instances, and hence such
|
||
typecasts must not be treated as integer-like
|
||
conversions
|
||
}
|
||
if target_info.system in systems_jvm then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else if m_delphi in current_settings.modeswitches then
|
||
begin
|
||
doconv:=tc_int_2_int;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
|
||
arraydef :
|
||
begin
|
||
{ open array is also compatible with a single element of its base type.
|
||
the extra check for deftyp is needed because equal defs can also return
|
||
true if the def types are not the same, for example with dynarray to pointer. }
|
||
if is_open_array(def_to) and
|
||
(def_from.typ=tarraydef(def_to).elementdef.typ) and
|
||
equal_defs(def_from,tarraydef(def_to).elementdef) then
|
||
begin
|
||
doconv:=tc_elem_2_openarray;
|
||
{ also update in htypechk.pas/var_para_allowed if changed
|
||
here }
|
||
eq:=te_convert_l3;
|
||
end
|
||
else
|
||
begin
|
||
case def_from.typ of
|
||
arraydef :
|
||
begin
|
||
{ from/to packed array -- packed chararrays are }
|
||
{ strings in ISO Pascal (at least if the lower bound }
|
||
{ is 1, but GPC makes all equal-length chararrays }
|
||
{ compatible), so treat those the same as regular }
|
||
{ char arrays -- except if they use subrange types }
|
||
if (is_packed_array(def_from) and
|
||
(not is_chararray(def_from) or
|
||
(tarraydef(def_from).elementdef.packedbitsize<>8)) and
|
||
not is_widechararray(def_from)) xor
|
||
(is_packed_array(def_to) and
|
||
(not is_chararray(def_to) or
|
||
(tarraydef(def_to).elementdef.packedbitsize<>8)) and
|
||
not is_widechararray(def_to)) then
|
||
{ both must be packed }
|
||
begin
|
||
compare_defs_ext:=te_incompatible;
|
||
exit;
|
||
end
|
||
{ to dynamic array }
|
||
else if is_dynamic_array(def_to) then
|
||
begin
|
||
if is_array_constructor(def_from) then
|
||
begin
|
||
{ array constructor -> dynamic array }
|
||
if is_void(tarraydef(def_from).elementdef) then
|
||
begin
|
||
{ only needs to loose to [] -> open array }
|
||
eq:=te_convert_l2;
|
||
doconv:=tc_arrayconstructor_2_dynarray;
|
||
end
|
||
else
|
||
begin
|
||
{ this should loose to the array constructor -> open array conversions,
|
||
but it might happen that the end of the convert levels is reached :/ }
|
||
subeq:=compare_defs_ext(tarraydef(def_from).elementdef,
|
||
tarraydef(def_to).elementdef,
|
||
{ reason for cdo_allow_variant: see webtbs/tw7070a and webtbs/tw7070b }
|
||
arrayconstructorn,hct,hpd,[cdo_check_operator,cdo_allow_variant]);
|
||
if (subeq>=te_equal) then
|
||
begin
|
||
eq:=te_convert_l2;
|
||
end
|
||
else
|
||
{ an array constructor is not a dynamic array, so
|
||
use a lower level of compatibility than that one of
|
||
of the elements }
|
||
if subeq>te_convert_l5 then
|
||
begin
|
||
eq:=pred(pred(subeq));
|
||
end
|
||
else if subeq>te_convert_l6 then
|
||
eq:=pred(subeq)
|
||
else if subeq=te_convert_operator then
|
||
{ the operater needs to be applied by element, so we tell
|
||
the caller that it's some unpreffered conversion and let
|
||
it handle the per-element stuff }
|
||
eq:=te_convert_l6
|
||
else
|
||
eq:=subeq;
|
||
doconv:=tc_arrayconstructor_2_dynarray;
|
||
end;
|
||
end
|
||
else if equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
|
||
begin
|
||
{ dynamic array -> dynamic array }
|
||
if is_dynamic_array(def_from) then
|
||
eq:=te_equal
|
||
{ regular array -> dynamic array }
|
||
else if (m_array2dynarray in current_settings.modeswitches) and
|
||
not(is_special_array(def_from)) and
|
||
is_zero_based_array(def_from) then
|
||
begin
|
||
eq:=te_convert_l2;
|
||
doconv:=tc_array_2_dynarray;
|
||
end;
|
||
end
|
||
end
|
||
else
|
||
{ to open array }
|
||
if is_open_array(def_to) then
|
||
begin
|
||
{ array constructor -> open array }
|
||
if is_array_constructor(def_from) then
|
||
begin
|
||
if is_void(tarraydef(def_from).elementdef) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
begin
|
||
subeq:=compare_defs_ext(tarraydef(def_from).elementdef,
|
||
tarraydef(def_to).elementdef,
|
||
{ reason for cdo_allow_variant: see webtbs/tw7070a and webtbs/tw7070b }
|
||
arrayconstructorn,hct,hpd,[cdo_check_operator,cdo_allow_variant]);
|
||
if (subeq>=te_equal) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
{ an array constructor is not an open array, so
|
||
use a lower level of compatibility than that one of
|
||
of the elements }
|
||
if subeq>te_convert_l6 then
|
||
begin
|
||
doconv:=hct;
|
||
eq:=pred(subeq);
|
||
end
|
||
else
|
||
eq:=subeq;
|
||
end;
|
||
end
|
||
else
|
||
{ dynamic array -> open array }
|
||
if is_dynamic_array(def_from) and
|
||
equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
|
||
begin
|
||
doconv:=tc_dynarray_2_openarray;
|
||
eq:=te_convert_l2;
|
||
end
|
||
else
|
||
{ open array -> open array }
|
||
if is_open_array(def_from) and
|
||
equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
|
||
if tarraydef(def_from).elementdef=tarraydef(def_to).elementdef then
|
||
eq:=te_exact
|
||
else
|
||
eq:=te_equal
|
||
else
|
||
{ array -> open array }
|
||
if not(cdo_parameter in cdoptions) and
|
||
equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
|
||
begin
|
||
if fromtreetype=stringconstn then
|
||
eq:=te_convert_l1
|
||
else
|
||
eq:=te_equal;
|
||
end;
|
||
end
|
||
else
|
||
{ to array of const }
|
||
if is_array_of_const(def_to) then
|
||
begin
|
||
if is_array_of_const(def_from) or
|
||
is_array_constructor(def_from) then
|
||
begin
|
||
eq:=te_equal;
|
||
end
|
||
else
|
||
{ array of tvarrec -> array of const }
|
||
if equal_defs(tarraydef(def_to).elementdef,tarraydef(def_from).elementdef) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end
|
||
else
|
||
{ to array of char, from "Untyped" stringconstn (array of char) }
|
||
if (fromtreetype=stringconstn) and
|
||
((is_chararray(def_to) and
|
||
{ bitpacked arrays of char whose element bitsize is not
|
||
8 cannot be auto-converted from strings }
|
||
(not is_packed_array(def_to) or
|
||
(tarraydef(def_to).elementdef.packedbitsize=8))) or
|
||
is_widechararray(def_to)) then
|
||
begin
|
||
eq:=te_convert_l1;
|
||
doconv:=tc_string_2_chararray;
|
||
end
|
||
else
|
||
{ to normal array }
|
||
if is_normal_array(def_to) and is_array_constructor(def_from) then
|
||
begin
|
||
{ element count must match exactly }
|
||
if tarraydef(def_to).elecount=tarraydef(def_from).elecount then
|
||
begin
|
||
eq:=te_convert_l2;
|
||
doconv:=tc_arrayconstructor_2_array;
|
||
end;
|
||
end
|
||
else
|
||
{ other arrays }
|
||
begin
|
||
{ open array -> array }
|
||
if not(cdo_parameter in cdoptions) and
|
||
is_open_array(def_from) and
|
||
equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) then
|
||
begin
|
||
eq:=te_equal
|
||
end
|
||
else
|
||
{ array -> array }
|
||
if ((not(m_tp7 in current_settings.modeswitches) and
|
||
not(m_delphi in current_settings.modeswitches)) or
|
||
{ allow assigning vector results to regular
|
||
arrays. TODO: change once we expose vector types }
|
||
tarraydef(def_from).is_hwvector) and
|
||
(tarraydef(def_from).lowrange=tarraydef(def_to).lowrange) and
|
||
(tarraydef(def_from).highrange=tarraydef(def_to).highrange) and
|
||
equal_defs(tarraydef(def_from).elementdef,tarraydef(def_to).elementdef) and
|
||
(compare_defs_ext(tarraydef(def_from).rangedef,tarraydef(def_to).rangedef,nothingn,hct,hpd,[])>te_incompatible) then
|
||
begin
|
||
eq:=te_equal
|
||
end;
|
||
end;
|
||
end;
|
||
pointerdef :
|
||
begin
|
||
{ nil and voidpointers are compatible with dyn. arrays }
|
||
if is_dynamic_array(def_to) and
|
||
((fromtreetype=niln) or
|
||
is_voidpointer(def_from)) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
if is_zero_based_array(def_to) and
|
||
equal_defs(tpointerdef(def_from).pointeddef,tarraydef(def_to).elementdef) then
|
||
begin
|
||
doconv:=tc_pointer_2_array;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
stringdef :
|
||
begin
|
||
{ string to char array }
|
||
if not is_special_array(def_to) and
|
||
((is_char(tarraydef(def_to).elementdef) and
|
||
{ bitpacked arrays of char whose element bitsize is not
|
||
8 cannot be auto-converted from strings }
|
||
(not is_packed_array(def_to) or
|
||
(tarraydef(def_to).elementdef.packedbitsize=8))) or
|
||
is_widechar(tarraydef(def_to).elementdef)) then
|
||
begin
|
||
doconv:=tc_string_2_chararray;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
orddef:
|
||
begin
|
||
if is_chararray(def_to) and
|
||
is_char(def_from) then
|
||
begin
|
||
doconv:=tc_char_2_chararray;
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
recorddef :
|
||
begin
|
||
{ tvarrec -> array of const }
|
||
if is_array_of_const(def_to) and
|
||
equal_defs(def_from,tarraydef(def_to).elementdef) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
variantdef :
|
||
begin
|
||
if is_dynamic_array(def_to) then
|
||
begin
|
||
doconv:=tc_variant_2_dynarray;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
setdef :
|
||
begin
|
||
{ special case: an empty set constant is compatible as
|
||
well }
|
||
if not assigned(tsetdef(def_from).elementdef)
|
||
and (fromtreetype=setconstn) then
|
||
begin
|
||
doconv:=tc_arrayconstructor_2_dynarray;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
variantdef :
|
||
begin
|
||
if (cdo_allow_variant in cdoptions) then
|
||
begin
|
||
case def_from.typ of
|
||
enumdef :
|
||
begin
|
||
doconv:=tc_enum_2_variant;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
arraydef :
|
||
begin
|
||
if is_dynamic_array(def_from) then
|
||
begin
|
||
doconv:=tc_dynarray_2_variant;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
objectdef :
|
||
begin
|
||
{ corbainterfaces not accepted, until we have
|
||
runtime support for them in Variants (sergei) }
|
||
if is_interfacecom_or_dispinterface(def_from) then
|
||
begin
|
||
doconv:=tc_interface_2_variant;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
variantdef :
|
||
begin
|
||
{ doing this in the compiler avoids a lot of unncessary
|
||
copying }
|
||
if (tvariantdef(def_from).varianttype=vt_olevariant) and
|
||
(tvariantdef(def_to).varianttype=vt_normalvariant) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
pointerdef :
|
||
begin
|
||
case def_from.typ of
|
||
stringdef :
|
||
begin
|
||
{ string constant (which can be part of array constructor)
|
||
to zero terminated string constant }
|
||
if (fromtreetype = stringconstn) and
|
||
(is_pchar(def_to) or is_pwidechar(def_to)) then
|
||
begin
|
||
doconv:=tc_cstring_2_pchar;
|
||
if is_pwidechar(def_to)=(m_default_unicodestring in current_settings.modeswitches) then
|
||
eq:=te_convert_l2
|
||
else
|
||
eq:=te_convert_l3
|
||
end
|
||
else
|
||
if (cdo_explicit in cdoptions) or (fromtreetype = arrayconstructorn) then
|
||
begin
|
||
{ pchar(ansistring) }
|
||
if is_pchar(def_to) and
|
||
is_ansistring(def_from) then
|
||
begin
|
||
doconv:=tc_ansistring_2_pchar;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
{ pwidechar(widestring) }
|
||
if is_pwidechar(def_to) and
|
||
is_wide_or_unicode_string(def_from) then
|
||
begin
|
||
doconv:=tc_ansistring_2_pchar;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
end;
|
||
orddef :
|
||
begin
|
||
{ char constant to zero terminated string constant }
|
||
if (fromtreetype in [ordconstn,arrayconstructorn]) then
|
||
begin
|
||
if (is_char(def_from) or is_widechar(def_from)) and
|
||
(is_pchar(def_to) or is_pwidechar(def_to)) then
|
||
begin
|
||
doconv:=tc_cchar_2_pchar;
|
||
if is_pwidechar(def_to)=(m_default_unicodestring in current_settings.modeswitches) then
|
||
eq:=te_convert_l1
|
||
else
|
||
eq:=te_convert_l2
|
||
end
|
||
else
|
||
if (m_delphi in current_settings.modeswitches) and is_integer(def_from) then
|
||
begin
|
||
doconv:=tc_cord_2_pointer;
|
||
eq:=te_convert_l5;
|
||
end;
|
||
end;
|
||
{ allow explicit typecasts from ordinals to pointer.
|
||
Support for delphi compatibility
|
||
Support constructs like pointer(cardinal-cardinal) or pointer(longint+cardinal) where
|
||
the result of the ordinal operation is int64 also on 32 bit platforms.
|
||
It is also used by the compiler internally for inc(pointer,ordinal) }
|
||
if (eq=te_incompatible) and
|
||
not is_void(def_from) and
|
||
(
|
||
(
|
||
(cdo_explicit in cdoptions) and
|
||
(
|
||
(m_delphi in current_settings.modeswitches) or
|
||
{ Don't allow pchar(char) in fpc modes }
|
||
is_integer(def_from)
|
||
)
|
||
) or
|
||
(cdo_internal in cdoptions)
|
||
) then
|
||
begin
|
||
doconv:=tc_int_2_int;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
enumdef :
|
||
begin
|
||
{ allow explicit typecasts from enums to pointer.
|
||
Support for delphi compatibility
|
||
}
|
||
{ in Java enums /are/ class instances, and hence such
|
||
typecasts must not be treated as integer-like conversions
|
||
}
|
||
if (((cdo_explicit in cdoptions) and
|
||
((m_delphi in current_settings.modeswitches) or
|
||
(target_info.system in systems_jvm)
|
||
)
|
||
) or
|
||
(cdo_internal in cdoptions)
|
||
) then
|
||
begin
|
||
{ in Java enums /are/ class instances, and hence such
|
||
typecasts must not be treated as integer-like
|
||
conversions
|
||
}
|
||
if target_info.system in systems_jvm then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else if m_delphi in current_settings.modeswitches then
|
||
begin
|
||
doconv:=tc_int_2_int;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
end;
|
||
arraydef :
|
||
begin
|
||
{ string constant (which can be part of array constructor)
|
||
to zero terminated string constant }
|
||
if (((fromtreetype = arrayconstructorn) and
|
||
{ can't use is_chararray, because returns false for }
|
||
{ array constructors }
|
||
is_char(tarraydef(def_from).elementdef)) or
|
||
(fromtreetype = stringconstn)) and
|
||
(is_pchar(def_to) or is_pwidechar(def_to)) then
|
||
begin
|
||
doconv:=tc_cstring_2_pchar;
|
||
if ((m_default_unicodestring in current_settings.modeswitches) xor
|
||
is_pchar(def_to)) then
|
||
eq:=te_convert_l2
|
||
else
|
||
eq:=te_convert_l3;
|
||
end
|
||
else
|
||
{ chararray to pointer }
|
||
if (is_zero_based_array(def_from) or
|
||
is_open_array(def_from)) and
|
||
equal_defs(tarraydef(def_from).elementdef,tpointerdef(def_to).pointeddef) then
|
||
begin
|
||
doconv:=tc_array_2_pointer;
|
||
{ don't prefer the pchar overload when a constant
|
||
string was passed }
|
||
if fromtreetype=stringconstn then
|
||
eq:=te_convert_l2
|
||
else
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
{ dynamic array to pointer, delphi only }
|
||
if (m_delphi in current_settings.modeswitches) and
|
||
is_dynamic_array(def_from) and
|
||
is_voidpointer(def_to) then
|
||
begin
|
||
eq:=te_equal;
|
||
end;
|
||
end;
|
||
pointerdef :
|
||
begin
|
||
{ check for far pointers }
|
||
if not tpointerdef(def_from).compatible_with_pointerdef_size(tpointerdef(def_to)) then
|
||
begin
|
||
if fromtreetype=niln then
|
||
eq:=te_equal
|
||
else
|
||
eq:=te_incompatible;
|
||
end
|
||
{ the types can be forward type, handle before normal type check !! }
|
||
else
|
||
if assigned(def_to.typesym) and
|
||
((tpointerdef(def_to).pointeddef.typ=forwarddef) or
|
||
(tpointerdef(def_from).pointeddef.typ=forwarddef)) then
|
||
begin
|
||
if (def_from.typesym=def_to.typesym) or
|
||
(fromtreetype=niln) then
|
||
eq:=te_equal
|
||
end
|
||
else
|
||
begin
|
||
{ avoid crash/stack overflow on recursive pointer definitions, see tests/webtbf/tw39634.pp }
|
||
hd1:=tabstractpointerdef(def_from).pointeddef;
|
||
hd2:=tabstractpointerdef(def_to).pointeddef;
|
||
while assigned(hd1) and (hd1.typ=pointerdef) and
|
||
assigned(hd2) and (hd2.typ=pointerdef) do
|
||
begin
|
||
if hd1=hd2 then
|
||
break;
|
||
if (hd1=def_from) and (hd2=def_to) then
|
||
begin
|
||
eq:=te_incompatible;
|
||
break;
|
||
end;
|
||
hd1:=tabstractpointerdef(hd1).pointeddef;
|
||
hd2:=tabstractpointerdef(hd2).pointeddef;
|
||
end;
|
||
|
||
{ same types }
|
||
if not((hd1=def_from) and (hd2=def_to)) and equal_defs(tpointerdef(def_from).pointeddef,tpointerdef(def_to).pointeddef) then
|
||
begin
|
||
eq:=te_equal
|
||
end
|
||
else
|
||
{ child class pointer can be assigned to anchestor pointers }
|
||
if (
|
||
(tpointerdef(def_from).pointeddef.typ=objectdef) and
|
||
(tpointerdef(def_to).pointeddef.typ=objectdef) and
|
||
def_is_related(tobjectdef(tpointerdef(def_from).pointeddef),
|
||
tobjectdef(tpointerdef(def_to).pointeddef))
|
||
) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
{ all pointers can be assigned to void-pointer }
|
||
if is_void(tpointerdef(def_to).pointeddef) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
{ give pwidechar,pchar a penalty so it prefers
|
||
conversion to ansistring }
|
||
if is_pchar(def_from) or
|
||
is_pwidechar(def_from) then
|
||
eq:=te_convert_l2
|
||
else
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
{ all pointers can be assigned from void-pointer }
|
||
if is_void(tpointerdef(def_from).pointeddef) or
|
||
{ all pointers can be assigned from void-pointer or formaldef pointer, check
|
||
tw3777.pp if you change this }
|
||
(tpointerdef(def_from).pointeddef.typ=formaldef) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
{ give pwidechar a penalty so it prefers
|
||
conversion to pchar }
|
||
if is_pwidechar(def_to) then
|
||
eq:=te_convert_l2
|
||
else
|
||
eq:=te_convert_l1;
|
||
end
|
||
{ id = generic class instance. metaclasses are also
|
||
class instances themselves. }
|
||
else if ((def_from=objc_idtype) and
|
||
(def_to=objc_metaclasstype)) or
|
||
((def_to=objc_idtype) and
|
||
(def_from=objc_metaclasstype)) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
end;
|
||
procvardef :
|
||
begin
|
||
{ procedure variable can be assigned to an void pointer,
|
||
this is not allowed for complex procvars }
|
||
if (is_void(tpointerdef(def_to).pointeddef) or
|
||
(m_mac_procvar in current_settings.modeswitches)) and
|
||
tprocvardef(def_from).compatible_with_pointerdef_size(tpointerdef(def_to)) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
procdef :
|
||
begin
|
||
{ procedure variable can be assigned to an void pointer,
|
||
this not allowed for methodpointers }
|
||
if (m_mac_procvar in current_settings.modeswitches) and
|
||
tprocdef(def_from).compatible_with_pointerdef_size(tpointerdef(def_to)) then
|
||
begin
|
||
doconv:=tc_proc_2_procvar;
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
classrefdef,
|
||
objectdef :
|
||
begin
|
||
{ implicit pointer object and class reference types
|
||
can be assigned to void pointers, but it is less
|
||
preferred than assigning to a related objectdef }
|
||
if (
|
||
is_implicit_pointer_object_type(def_from) or
|
||
(def_from.typ=classrefdef)
|
||
) and
|
||
(tpointerdef(def_to).pointeddef.typ=orddef) and
|
||
(torddef(tpointerdef(def_to).pointeddef).ordtype=uvoid) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l2;
|
||
end
|
||
else if (is_objc_class_or_protocol(def_from) and
|
||
(def_to=objc_idtype)) or
|
||
{ classrefs are also instances in Objective-C,
|
||
hence they're also assignment-cpmpatible with
|
||
id }
|
||
(is_objcclassref(def_from) and
|
||
((def_to=objc_metaclasstype) or
|
||
(def_to=objc_idtype))) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
|
||
setdef :
|
||
begin
|
||
case def_from.typ of
|
||
setdef :
|
||
begin
|
||
if assigned(tsetdef(def_from).elementdef) and
|
||
assigned(tsetdef(def_to).elementdef) then
|
||
begin
|
||
{ sets with the same size (packset setting), element
|
||
base type and the same range are equal }
|
||
if equal_defs(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) and
|
||
(tsetdef(def_from).setbase=tsetdef(def_to).setbase) and
|
||
(tsetdef(def_from).setmax=tsetdef(def_to).setmax) and
|
||
(def_from.size=def_to.size) then
|
||
eq:=te_equal
|
||
else if is_subequal(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) then
|
||
begin
|
||
eq:=te_convert_l1;
|
||
doconv:=tc_set_to_set;
|
||
end;
|
||
end
|
||
else
|
||
begin
|
||
{ empty set is compatible with everything }
|
||
eq:=te_convert_l1;
|
||
doconv:=tc_set_to_set;
|
||
end;
|
||
end;
|
||
arraydef :
|
||
begin
|
||
{ automatic arrayconstructor -> set conversion }
|
||
if is_array_constructor(def_from) then
|
||
begin
|
||
doconv:=tc_arrayconstructor_2_set;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
|
||
procvardef :
|
||
begin
|
||
case def_from.typ of
|
||
procdef :
|
||
begin
|
||
{ proc -> procvar }
|
||
if (m_tp_procvar in current_settings.modeswitches) or
|
||
(m_mac_procvar in current_settings.modeswitches) or
|
||
(po_anonymous in tprocdef(def_from).procoptions) then
|
||
begin
|
||
subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),cdo_warn_incompatible_univ in cdoptions);
|
||
if subeq>te_incompatible then
|
||
begin
|
||
doconv:=tc_proc_2_procvar;
|
||
if subeq>te_convert_l5 then
|
||
eq:=pred(subeq)
|
||
else
|
||
eq:=subeq;
|
||
end;
|
||
end;
|
||
end;
|
||
procvardef :
|
||
begin
|
||
{ procvar -> procvar }
|
||
eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to),cdo_warn_incompatible_univ in cdoptions);
|
||
if eq<te_equal then
|
||
doconv:=tc_proc_2_procvar
|
||
else
|
||
doconv:=tc_equal;
|
||
end;
|
||
pointerdef :
|
||
begin
|
||
{ nil is compatible with procvars }
|
||
if (fromtreetype=niln) then
|
||
begin
|
||
if not Tprocvardef(def_to).is_addressonly then
|
||
{Nil to method pointers requires to convert a single
|
||
pointer nil value to a two pointer procvardef.}
|
||
doconv:=tc_nil_2_methodprocvar
|
||
else
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
{ for example delphi allows the assignement from pointers }
|
||
{ to procedure variables }
|
||
if (m_pointer_2_procedure in current_settings.modeswitches) and
|
||
is_void(tpointerdef(def_from).pointeddef) and
|
||
tprocvardef(def_to).is_addressonly and
|
||
tprocvardef(def_to).compatible_with_pointerdef_size(tpointerdef(def_from)) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
end;
|
||
|
||
objectdef :
|
||
begin
|
||
{ object pascal objects }
|
||
{ don't call def_is_related if we came here from equal_defs, because
|
||
1) this can never result in an "equal result", and
|
||
2) def_is_related itself calls equal_defs again for each class in
|
||
the hierarchy, which will call compare_defs_ext, which will again
|
||
call def_is_related -> quadratic complexity explosion }
|
||
if not(cdo_equal_check in cdoptions) and
|
||
(def_from.typ=objectdef) and
|
||
(def_is_related(tobjectdef(def_from),tobjectdef(def_to))) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
{ also update in htypechk.pas/var_para_allowed if changed
|
||
here }
|
||
eq:=te_convert_l3;
|
||
end
|
||
{ string -> java.lang.string }
|
||
else if (def_to=java_jlstring) and
|
||
((def_from.typ=stringdef) or
|
||
(fromtreetype=stringconstn)) then
|
||
begin
|
||
if is_wide_or_unicode_string(def_from) or
|
||
((fromtreetype=stringconstn) and
|
||
(cs_refcountedstrings in current_settings.localswitches) and
|
||
(m_default_unicodestring in current_settings.modeswitches)) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_equal
|
||
end
|
||
else
|
||
begin
|
||
doconv:=tc_string_2_string;
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end
|
||
else if (def_to=java_jlstring) and
|
||
is_anychar(def_from) then
|
||
begin
|
||
doconv:=tc_char_2_string;
|
||
eq:=te_convert_l2
|
||
end
|
||
else if is_funcref(def_to) and
|
||
(def_from.typ=procdef) and
|
||
(po_anonymous in tprocdef(def_from).procoptions) then
|
||
begin
|
||
subeq:=proc_to_funcref_conv(tprocdef(def_from),tobjectdef(def_to));
|
||
if subeq>te_incompatible then
|
||
begin
|
||
doconv:=tc_anonproc_2_funcref;
|
||
if subeq>te_convert_l5 then
|
||
eq:=pred(subeq)
|
||
else
|
||
eq:=subeq;
|
||
end;
|
||
end
|
||
else if is_funcref(def_to) and
|
||
is_funcref(def_from) and
|
||
not (cdo_equal_check in cdoptions) then
|
||
begin
|
||
eq:=funcref_equal(tobjectdef(def_from),tobjectdef(def_to));
|
||
if eq>=te_equal then
|
||
doconv:=tc_equal;
|
||
end
|
||
else
|
||
{ specific to implicit pointer object types }
|
||
if is_implicit_pointer_object_type(def_to) then
|
||
begin
|
||
{ void pointer also for delphi mode }
|
||
if (m_delphi in current_settings.modeswitches) and
|
||
is_voidpointer(def_from) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
{ prefer pointer-pointer assignments }
|
||
eq:=te_convert_l2;
|
||
end
|
||
else
|
||
{ nil is compatible with class instances and interfaces }
|
||
if (fromtreetype=niln) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
{ All Objective-C classes are compatible with ID }
|
||
else if is_objc_class_or_protocol(def_to) and
|
||
(def_from=objc_idtype) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l2;
|
||
end
|
||
{ classes can be assigned to interfaces
|
||
(same with objcclass and objcprotocol) }
|
||
else if ((is_interface(def_to) and
|
||
is_class(def_from)) or
|
||
(is_objcprotocol(def_to) and
|
||
is_objcclass(def_from)) or
|
||
(is_javainterface(def_to) and
|
||
is_javaclass(def_from))) and
|
||
assigned(tobjectdef(def_from).ImplementedInterfaces) then
|
||
begin
|
||
{ we've to search in parent classes as well }
|
||
hobjdef:=tobjectdef(def_from);
|
||
while assigned(hobjdef) do
|
||
begin
|
||
if find_implemented_interface(hobjdef,tobjectdef(def_to))<>nil then
|
||
begin
|
||
if is_interface(def_to) then
|
||
doconv:=tc_class_2_intf
|
||
else
|
||
{ for Objective-C, we don't have to do anything special }
|
||
doconv:=tc_equal;
|
||
{ don't prefer this over objectdef->objectdef }
|
||
eq:=te_convert_l2;
|
||
break;
|
||
end;
|
||
hobjdef:=hobjdef.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
|
||
eq:=te_convert_l1;
|
||
doconv:=tc_equal;
|
||
end
|
||
else if is_funcref(def_to) and
|
||
(def_from.typ in [procdef,procvardef]) then
|
||
begin
|
||
subeq:=proc_to_funcref_conv(tabstractprocdef(def_from),tobjectdef(def_to));
|
||
if subeq>te_incompatible then
|
||
begin
|
||
doconv:=tc_procvar_2_funcref;
|
||
if subeq>te_convert_l5 then
|
||
eq:=pred(subeq)
|
||
else
|
||
eq:=subeq;
|
||
end;
|
||
end
|
||
else if (def_from.typ=variantdef) and is_interfacecom_or_dispinterface(def_to) then
|
||
begin
|
||
{ corbainterfaces not accepted, until we have
|
||
runtime support for them in Variants (sergei) }
|
||
doconv:=tc_variant_2_interface;
|
||
eq:=te_convert_l2;
|
||
end
|
||
{ ugly, but delphi allows it (enables typecasting ordinals/
|
||
enums of any size to pointer-based object defs) }
|
||
{ in Java enums /are/ class instances, and hence such
|
||
typecasts must not be treated as integer-like conversions;
|
||
arbitrary constants cannot be converted into classes/
|
||
pointer-based values either on the JVM -> always return
|
||
false and let it be handled by the regular explicit type
|
||
casting code
|
||
}
|
||
else if (not(target_info.system in systems_jvm) and
|
||
((def_from.typ=enumdef) or
|
||
(
|
||
(def_from.typ=orddef) and
|
||
not is_void(def_from)
|
||
))) and
|
||
(m_delphi in current_settings.modeswitches) and
|
||
(cdo_explicit in cdoptions) then
|
||
begin
|
||
doconv:=tc_int_2_int;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
classrefdef :
|
||
begin
|
||
{ similar to pointerdef wrt forwards }
|
||
if assigned(def_to.typesym) and
|
||
(tclassrefdef(def_to).pointeddef.typ=forwarddef) or
|
||
((def_from.typ=classrefdef) and
|
||
(tclassrefdef(def_from).pointeddef.typ=forwarddef)) then
|
||
begin
|
||
if (def_from.typesym=def_to.typesym) or
|
||
(fromtreetype=niln) then
|
||
eq:=te_equal;
|
||
end
|
||
else
|
||
{ class reference types }
|
||
if (def_from.typ=classrefdef) then
|
||
begin
|
||
if equal_defs(tclassrefdef(def_from).pointeddef,tclassrefdef(def_to).pointeddef) then
|
||
begin
|
||
eq:=te_equal;
|
||
end
|
||
else
|
||
begin
|
||
doconv:=tc_equal;
|
||
if (cdo_explicit in cdoptions) or
|
||
def_is_related(tobjectdef(tclassrefdef(def_from).pointeddef),
|
||
tobjectdef(tclassrefdef(def_to).pointeddef)) then
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end
|
||
else
|
||
if (m_delphi in current_settings.modeswitches) and
|
||
is_voidpointer(def_from) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
{ prefer pointer-pointer assignments }
|
||
eq:=te_convert_l2;
|
||
end
|
||
else
|
||
{ nil is compatible with class references }
|
||
if (fromtreetype=niln) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
end
|
||
else
|
||
{ id is compatible with all classref types }
|
||
if (def_from=objc_idtype) then
|
||
begin
|
||
doconv:=tc_equal;
|
||
eq:=te_convert_l1;
|
||
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.typ=filedef) then
|
||
begin
|
||
if (tfiledef(def_from).filetyp=tfiledef(def_to).filetyp) then
|
||
begin
|
||
if
|
||
(
|
||
(tfiledef(def_from).typedfiledef=nil) and
|
||
(tfiledef(def_to).typedfiledef=nil)
|
||
) or
|
||
(
|
||
(tfiledef(def_from).typedfiledef<>nil) and
|
||
(tfiledef(def_to).typedfiledef<>nil) and
|
||
equal_defs(tfiledef(def_from).typedfiledef,tfiledef(def_to).typedfiledef)
|
||
) or
|
||
(
|
||
(tfiledef(def_from).filetyp = ft_typed) and
|
||
(tfiledef(def_to).filetyp = ft_typed) and
|
||
(
|
||
(tfiledef(def_from).typedfiledef = tdef(voidtype)) or
|
||
(tfiledef(def_to).typedfiledef = tdef(voidtype))
|
||
)
|
||
) then
|
||
begin
|
||
eq:=te_equal;
|
||
end;
|
||
end
|
||
else
|
||
if ((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;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
recorddef :
|
||
begin
|
||
{ interface -> guid }
|
||
if (def_to=rec_tguid) and
|
||
(is_interfacecom_or_dispinterface(def_from)) then
|
||
begin
|
||
doconv:=tc_intf_2_guid;
|
||
eq:=te_convert_l1;
|
||
end;
|
||
end;
|
||
|
||
formaldef :
|
||
begin
|
||
doconv:=tc_equal;
|
||
if (def_from.typ=formaldef) then
|
||
eq:=te_equal
|
||
else
|
||
{ Just about everything can be converted to a formaldef...}
|
||
if not (def_from.typ in [abstractdef,errordef]) then
|
||
eq:=te_convert_l6;
|
||
end;
|
||
else
|
||
;
|
||
end;
|
||
|
||
{ if we didn't find an appropriate type conversion yet
|
||
then we search also the := operator }
|
||
if (eq=te_incompatible) and
|
||
{ make sure there is not a single variant if variants }
|
||
{ are not allowed (otherwise if only cdo_check_operator }
|
||
{ and e.g. fromdef=stringdef and todef=variantdef, then }
|
||
{ the test will still succeed }
|
||
((cdo_allow_variant in cdoptions) or
|
||
((def_from.typ<>variantdef) and
|
||
(def_to.typ<>variantdef) and
|
||
{ internal typeconversions always have to be bitcasts (except for
|
||
variants) }
|
||
not(cdo_internal in cdoptions)
|
||
)
|
||
) and
|
||
(
|
||
{ Check for variants? }
|
||
(
|
||
(cdo_allow_variant in cdoptions) and
|
||
((def_from.typ=variantdef) or (def_to.typ=variantdef))
|
||
) or
|
||
{ Check for operators? }
|
||
(
|
||
(cdo_check_operator in cdoptions) and
|
||
((def_from.typ<>variantdef) or (def_to.typ<>variantdef))
|
||
)
|
||
) then
|
||
begin
|
||
operatorpd:=search_assignment_operator(def_from,def_to,cdo_explicit in cdoptions);
|
||
if assigned(operatorpd) then
|
||
eq:=te_convert_operator;
|
||
end;
|
||
|
||
{ update convtype for te_equal when it is not yet set }
|
||
if (eq=te_equal) and
|
||
(doconv=tc_not_possible) then
|
||
doconv:=tc_equal;
|
||
|
||
compare_defs_ext:=eq;
|
||
end;
|
||
|
||
|
||
function equal_defs(def_from,def_to:tdef):boolean;
|
||
var
|
||
convtyp : tconverttype;
|
||
pd : tprocdef;
|
||
begin
|
||
{ Compare defs with nothingn and no explicit typecasts and
|
||
searching for overloaded operators is not needed }
|
||
equal_defs:=(compare_defs_ext(def_from,def_to,nothingn,convtyp,pd,[cdo_equal_check])>=te_equal);
|
||
end;
|
||
|
||
|
||
function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype;
|
||
var
|
||
doconv : tconverttype;
|
||
pd : tprocdef;
|
||
begin
|
||
compare_defs:=compare_defs_ext(def_from,def_to,fromtreetype,doconv,pd,[cdo_check_operator,cdo_allow_variant]);
|
||
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.typ = orddef) and (def2.typ = 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 adaptrange }
|
||
case torddef(def1).ordtype of
|
||
u8bit,u16bit,u32bit,u64bit,
|
||
s8bit,s16bit,s32bit,s64bit :
|
||
is_subequal:=(torddef(def2).ordtype in [s64bit,u64bit,s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
|
||
pasbool1,pasbool8,pasbool16,pasbool32,pasbool64,
|
||
bool8bit,bool16bit,bool32bit,bool64bit :
|
||
is_subequal:=(torddef(def2).ordtype in [pasbool1,pasbool8,pasbool16,pasbool32,pasbool64,bool8bit,bool16bit,bool32bit,bool64bit]);
|
||
uchar :
|
||
is_subequal:=(torddef(def2).ordtype=uchar);
|
||
uwidechar :
|
||
is_subequal:=(torddef(def2).ordtype=uwidechar);
|
||
customint:
|
||
is_subequal:=(torddef(def2).low=torddef(def1).low) and (torddef(def2).high=torddef(def1).high);
|
||
u128bit, s128bit,
|
||
scurrency,
|
||
uvoid:
|
||
;
|
||
end;
|
||
end
|
||
else
|
||
Begin
|
||
{ Check if both basedefs are equal }
|
||
if (def1.typ=enumdef) and (def2.typ=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);
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
function potentially_incompatible_univ_paras(def1, def2: tdef): boolean;
|
||
begin
|
||
result :=
|
||
{ not entirely safe: different records can be passed differently
|
||
depending on the types of their fields, but they're hard to compare
|
||
(variant records, bitpacked vs non-bitpacked) }
|
||
((def1.typ in [floatdef,recorddef,arraydef,filedef,variantdef]) and
|
||
(def1.typ<>def2.typ)) or
|
||
{ pointers, ordinals and small sets are all passed the same}
|
||
(((def1.typ in [orddef,enumdef,pointerdef,procvardef,classrefdef]) or
|
||
(is_class_or_interface_or_objc(def1)) or
|
||
is_dynamic_array(def1) or
|
||
is_smallset(def1) or
|
||
is_ansistring(def1) or
|
||
is_unicodestring(def1)) <>
|
||
(def2.typ in [orddef,enumdef,pointerdef,procvardef,classrefdef]) or
|
||
(is_class_or_interface_or_objc(def2)) or
|
||
is_dynamic_array(def2) or
|
||
is_smallset(def2) or
|
||
is_ansistring(def2) or
|
||
is_unicodestring(def2)) or
|
||
{ shortstrings }
|
||
(is_shortstring(def1)<>
|
||
is_shortstring(def2)) or
|
||
{ winlike widestrings }
|
||
(is_widestring(def1)<>
|
||
is_widestring(def2)) or
|
||
{ TP-style objects }
|
||
(is_object(def1) <>
|
||
is_object(def2));
|
||
end;
|
||
|
||
|
||
function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
|
||
|
||
var
|
||
i1,i2 : byte;
|
||
|
||
procedure skip_args;
|
||
var
|
||
skipped : boolean;
|
||
begin
|
||
repeat
|
||
skipped:=false;
|
||
if cpo_ignorehidden in cpoptions then
|
||
begin
|
||
while (i1<para1.count) and
|
||
(vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do
|
||
begin
|
||
inc(i1);
|
||
skipped:=true;
|
||
end;
|
||
while (i2<para2.count) and
|
||
(vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do
|
||
begin
|
||
inc(i2);
|
||
skipped:=true;
|
||
end;
|
||
end;
|
||
if cpo_ignoreself in cpoptions then
|
||
begin
|
||
if (i1<para1.count) and
|
||
(vo_is_self in tparavarsym(para1[i1]).varoptions) then
|
||
begin
|
||
inc(i1);
|
||
skipped:=true;
|
||
end;
|
||
if (i2<para2.count) and
|
||
(vo_is_self in tparavarsym(para2[i2]).varoptions) then
|
||
begin
|
||
inc(i2);
|
||
skipped:=true;
|
||
end;
|
||
end;
|
||
if cpo_ignoreframepointer in cpoptions then
|
||
begin
|
||
if (i1<para1.count) and
|
||
(vo_is_parentfp in tparavarsym(para1[i1]).varoptions) then
|
||
begin
|
||
inc(i1);
|
||
skipped:=true;
|
||
end;
|
||
if (i2<para2.count) and
|
||
(vo_is_parentfp in tparavarsym(para2[i2]).varoptions) then
|
||
begin
|
||
inc(i2);
|
||
skipped:=true;
|
||
end;
|
||
end;
|
||
until not skipped;
|
||
end;
|
||
|
||
var
|
||
currpara1,
|
||
currpara2 : tparavarsym;
|
||
eq,lowesteq : tequaltype;
|
||
hpd : tprocdef;
|
||
convtype : tconverttype;
|
||
cdoptions : tcompare_defs_options;
|
||
begin
|
||
compare_paras:=te_incompatible;
|
||
cdoptions:=[cdo_parameter,cdo_check_operator,cdo_allow_variant,cdo_strict_undefined_check];
|
||
{ we need to parse the list from left-right so the
|
||
not-default parameters are checked first }
|
||
lowesteq:=high(tequaltype);
|
||
i1:=0;
|
||
i2:=0;
|
||
skip_args;
|
||
while (i1<para1.count) and (i2<para2.count) do
|
||
begin
|
||
eq:=te_incompatible;
|
||
|
||
currpara1:=tparavarsym(para1[i1]);
|
||
currpara2:=tparavarsym(para2[i2]);
|
||
|
||
{ Unique types must match exact }
|
||
if ((df_unique in currpara1.vardef.defoptions) or (df_unique in currpara2.vardef.defoptions)) and
|
||
(currpara1.vardef<>currpara2.vardef) then
|
||
exit;
|
||
|
||
{ Handle hidden parameters separately, because self is
|
||
defined as voidpointer for methodpointers }
|
||
if (vo_is_hidden_para in currpara1.varoptions) or
|
||
(vo_is_hidden_para in currpara2.varoptions) then
|
||
begin
|
||
{ both must be hidden }
|
||
if (vo_is_hidden_para in currpara1.varoptions)<>(vo_is_hidden_para in currpara2.varoptions) then
|
||
exit;
|
||
eq:=te_exact;
|
||
if (([vo_is_self,vo_is_vmt]*currpara1.varoptions)=[]) and
|
||
(([vo_is_self,vo_is_vmt]*currpara2.varoptions)=[]) then
|
||
begin
|
||
if not(cpo_ignorevarspez in cpoptions) and
|
||
(currpara1.varspez<>currpara2.varspez) then
|
||
exit;
|
||
eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
|
||
convtype,hpd,cdoptions);
|
||
end
|
||
else if ([vo_is_self,vo_is_vmt]*currpara1.varoptions)<>
|
||
([vo_is_self,vo_is_vmt]*currpara2.varoptions) then
|
||
eq:=te_incompatible;
|
||
end
|
||
else
|
||
begin
|
||
case acp of
|
||
cp_value_equal_const :
|
||
begin
|
||
{ this one is used for matching parameters from a call
|
||
statement to a procdef -> univ state can't be equal
|
||
in any case since the call statement does not contain
|
||
any information about that }
|
||
if (
|
||
not(cpo_ignorevarspez in cpoptions) and
|
||
(currpara1.varspez<>currpara2.varspez) and
|
||
((currpara1.varspez in [vs_var,vs_out,vs_constref]) or
|
||
(currpara2.varspez in [vs_var,vs_out,vs_constref]))
|
||
) then
|
||
exit;
|
||
eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
|
||
convtype,hpd,cdoptions);
|
||
end;
|
||
cp_all :
|
||
begin
|
||
{ used to resolve forward definitions -> headers must
|
||
match exactly, including the "univ" specifier }
|
||
if (not(cpo_ignorevarspez in cpoptions) and
|
||
(currpara1.varspez<>currpara2.varspez)) or
|
||
(currpara1.univpara<>currpara2.univpara) then
|
||
exit;
|
||
eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
|
||
convtype,hpd,cdoptions);
|
||
end;
|
||
cp_procvar :
|
||
begin
|
||
if not(cpo_ignorevarspez in cpoptions) and
|
||
(currpara1.varspez<>currpara2.varspez) then
|
||
exit;
|
||
{ "univ" state doesn't matter here: from univ to non-univ
|
||
matches if the types are compatible (i.e., as usual),
|
||
from from non-univ to univ also matches if the types
|
||
have the same size (checked below) }
|
||
eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
|
||
convtype,hpd,cdoptions);
|
||
{ Parameters must be at least equal otherwise the are incompatible }
|
||
if (eq<te_equal) then
|
||
eq:=te_incompatible;
|
||
end;
|
||
else
|
||
eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
|
||
convtype,hpd,cdoptions);
|
||
end;
|
||
end;
|
||
{ check type }
|
||
if eq=te_incompatible then
|
||
begin
|
||
{ special case: "univ" parameters match if their size is equal }
|
||
if not(cpo_ignoreuniv in cpoptions) and
|
||
currpara2.univpara and
|
||
is_valid_univ_para_type(currpara1.vardef) and
|
||
(currpara1.vardef.size=currpara2.vardef.size) then
|
||
begin
|
||
{ only pick as last choice }
|
||
eq:=te_convert_l5;
|
||
if (acp=cp_procvar) and
|
||
(cpo_warn_incompatible_univ in cpoptions) then
|
||
begin
|
||
{ if the types may be passed in different ways by the
|
||
calling convention then this can lead to crashes
|
||
(note: not an exhaustive check, and failing this
|
||
this check does not mean things will crash on all
|
||
platforms) }
|
||
if potentially_incompatible_univ_paras(currpara1.vardef,currpara2.vardef) then
|
||
Message2(type_w_procvar_univ_conflicting_para,currpara1.vardef.typename,currpara2.vardef.typename)
|
||
end;
|
||
end
|
||
else if (cpo_generic in cpoptions) then
|
||
begin
|
||
if equal_genfunc_paradefs(currpara1.vardef,currpara2.vardef,currpara1.owner,currpara2.owner) then
|
||
eq:=te_exact
|
||
else
|
||
exit;
|
||
end
|
||
else
|
||
exit;
|
||
end;
|
||
if (eq=te_equal) and
|
||
(cpo_generic in cpoptions) then
|
||
begin
|
||
if is_open_array(currpara1.vardef) and
|
||
is_open_array(currpara2.vardef) then
|
||
begin
|
||
if equal_genfunc_paradefs(tarraydef(currpara1.vardef).elementdef,tarraydef(currpara2.vardef).elementdef,currpara1.owner,currpara2.owner) then
|
||
eq:=te_exact;
|
||
end
|
||
else
|
||
{ for the purpose of forward declarations two equal specializations
|
||
are considered as exactly equal }
|
||
if (df_specialization in tstoreddef(currpara1.vardef).defoptions) and
|
||
(df_specialization in tstoreddef(currpara2.vardef).defoptions) then
|
||
eq:=te_exact;
|
||
end;
|
||
{ open strings can never match exactly, since you cannot define }
|
||
{ a separate "open string" type -> we have to be able to }
|
||
{ consider those as exact when resolving forward definitions. }
|
||
{ The same goes for array of const. Open arrays are handled }
|
||
{ already (if their element types match exactly, they are }
|
||
{ considered to be an exact match) }
|
||
{ And also for "inline defined" function parameter definitions }
|
||
{ (i.e., function types directly declared in a parameter list) }
|
||
if (is_array_of_const(currpara1.vardef) or
|
||
is_open_string(currpara1.vardef) or
|
||
((currpara1.vardef.typ = procvardef) and
|
||
not(assigned(currpara1.vardef.typesym)))) and
|
||
(eq=te_equal) and
|
||
(cpo_openequalisexact in cpoptions) then
|
||
eq:=te_exact;
|
||
if eq<lowesteq then
|
||
lowesteq:=eq;
|
||
{ also check default value if both have it declared }
|
||
if (cpo_comparedefaultvalue in cpoptions) then
|
||
begin
|
||
if assigned(currpara1.defaultconstsym) and
|
||
assigned(currpara2.defaultconstsym) then
|
||
begin
|
||
if not equal_constsym(tconstsym(currpara1.defaultconstsym),tconstsym(currpara2.defaultconstsym),true) then
|
||
exit;
|
||
end
|
||
{ cannot have that the second (= implementation) has a default value declared and the
|
||
other (interface) doesn't }
|
||
else if not assigned(currpara1.defaultconstsym) and assigned(currpara2.defaultconstsym) then
|
||
exit;
|
||
end;
|
||
if not(cpo_compilerproc in cpoptions) and
|
||
not(cpo_rtlproc in cpoptions) and
|
||
is_ansistring(currpara1.vardef) and
|
||
is_ansistring(currpara2.vardef) and
|
||
(tstringdef(currpara1.vardef).encoding<>tstringdef(currpara2.vardef).encoding) and
|
||
((tstringdef(currpara1.vardef).encoding=globals.CP_NONE) or
|
||
(tstringdef(currpara2.vardef).encoding=globals.CP_NONE)
|
||
) then
|
||
eq:=te_convert_l1;
|
||
if eq<lowesteq then
|
||
lowesteq:=eq;
|
||
inc(i1);
|
||
inc(i2);
|
||
skip_args;
|
||
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 ((i1>=para1.count) and (i2>=para2.count)) or
|
||
((cpo_allowdefaults in cpoptions) and
|
||
(((i1<para1.count) and assigned(tparavarsym(para1[i1]).defaultconstsym)) or
|
||
((i2<para2.count) and assigned(tparavarsym(para2[i2]).defaultconstsym)))) then
|
||
compare_paras:=lowesteq;
|
||
end;
|
||
|
||
|
||
function proc_to_procvar_equal_internal(def1:tabstractprocdef;def2:tabstractprocdef;checkincompatibleuniv,ignoreself: boolean):tequaltype;
|
||
var
|
||
eq: tequaltype;
|
||
po_comp: tprocoptions;
|
||
pa_comp: tcompare_paras_options;
|
||
captured : tfplist;
|
||
dstisfuncref : boolean;
|
||
begin
|
||
proc_to_procvar_equal_internal:=te_incompatible;
|
||
if not(assigned(def1)) or not(assigned(def2)) then
|
||
exit;
|
||
{ check for method pointer and local procedure pointer:
|
||
a) anything but procvars can be assigned to blocks
|
||
b) depending on their captured symbols anonymous functions can be
|
||
assigned to global, method or nested procvars
|
||
c) anything can be assigned to function references except for
|
||
nested procvars (this is checked in the type conversion)
|
||
d) if one is a procedure of object, the other also has to be one
|
||
("object static procedure" is equal to procedure as well)
|
||
(except for block)
|
||
e) if one is a pure address, the other also has to be one
|
||
except if def1 is a global proc and def2 is a nested procdef
|
||
(global procedures can be converted into nested procvars)
|
||
f) if def1 is a nested procedure, then def2 has to be a nested
|
||
procvar and def1 has to have the po_delphi_nested_cc option
|
||
or does not use parentfp
|
||
g) if def1 is a procvar, def1 and def2 both have to be nested or
|
||
non-nested (we don't allow assignments from non-nested to
|
||
nested procvars to make sure that we can still implement
|
||
nested procvars using trampolines -- e.g., this would be
|
||
necessary for LLVM or CIL as long as they do not have support
|
||
for Delphi-style frame pointer parameter passing) }
|
||
if is_block(def2) or { a) }
|
||
(po_anonymous in def1.procoptions) or { b) }
|
||
(po_is_function_ref in def2.procoptions) then { c) }
|
||
{ can't explicitly check against procvars here, because
|
||
def1 may already be a procvar due to a proc_to_procvar;
|
||
this is checked in the type conversion node itself -> ok }
|
||
else if
|
||
((def1.is_methodpointer and not (po_staticmethod in def1.procoptions))<> { d) }
|
||
(def2.is_methodpointer and not (po_staticmethod in def2.procoptions))) or
|
||
((def1.is_addressonly<>def2.is_addressonly) and { e) }
|
||
(is_nested_pd(def1) or
|
||
not is_nested_pd(def2))) or
|
||
((def1.typ=procdef) and { f) }
|
||
is_nested_pd(def1) and
|
||
(not(po_delphi_nested_cc in def1.procoptions) or
|
||
not is_nested_pd(def2))) or
|
||
((def1.typ=procvardef) and { g) }
|
||
(is_nested_pd(def1)<>is_nested_pd(def2))) then
|
||
exit;
|
||
pa_comp:=[cpo_ignoreframepointer];
|
||
if is_block(def2) then
|
||
include(pa_comp,cpo_ignorehidden);
|
||
if (po_anonymous in def1.procoptions) or ignoreself then
|
||
include(pa_comp,cpo_ignoreself);
|
||
if checkincompatibleuniv then
|
||
include(pa_comp,cpo_warn_incompatible_univ);
|
||
{ check return value and options, methodpointer is already checked }
|
||
po_comp:=[po_interrupt,po_iocheck,po_varargs,po_far];
|
||
{ check static only if we compare method pointers }
|
||
if def1.is_methodpointer and def2.is_methodpointer then
|
||
include(po_comp,po_staticmethod);
|
||
if (m_delphi in current_settings.modeswitches) then
|
||
exclude(po_comp,po_varargs);
|
||
{ for blocks, the calling convention doesn't matter because we have to
|
||
generate a wrapper anyway }
|
||
if ((po_is_block in def2.procoptions) or
|
||
(def1.proccalloption=def2.proccalloption)) and
|
||
((po_comp * def1.procoptions)= (po_comp * def2.procoptions)) and
|
||
equal_defs(def1.returndef,def2.returndef) then
|
||
begin
|
||
{ return equal type based on the parameters, but a proc->procvar
|
||
is never exact, so map an exact match of the parameters to
|
||
te_equal }
|
||
eq:=compare_paras(def1.paras,def2.paras,cp_procvar,pa_comp);
|
||
if eq=te_exact then
|
||
eq:=te_equal;
|
||
if (eq=te_equal) then
|
||
begin
|
||
{ prefer non-nested to non-nested over non-nested to nested }
|
||
if (is_nested_pd(def1)<>is_nested_pd(def2)) then
|
||
eq:=te_convert_l1;
|
||
{ in case of non-block to block, we need a type conversion }
|
||
if (po_is_block in def1.procoptions) <> (po_is_block in def2.procoptions) then
|
||
eq:=te_convert_l1;
|
||
{ for anonymous functions check whether their captured symbols are
|
||
compatible with the target }
|
||
if po_anonymous in def1.procoptions then
|
||
begin
|
||
if def1.typ<>procdef then
|
||
internalerror(2021052602);
|
||
captured:=tprocdef(def1).capturedsyms;
|
||
{ a function reference can capture anything, but they're
|
||
rather expensive, so cheaper overloads are preferred }
|
||
dstisfuncref:=assigned(def2.owner) and
|
||
assigned(def2.owner.defowner) and
|
||
is_funcref(tdef(def2.owner.defowner));
|
||
{ if no symbol was captured an anonymous function is
|
||
compatible to all four types of function pointers, but we
|
||
might need to generate its code differently (e.g. get rid
|
||
of parentfp parameter for global functions); the order for
|
||
this is:
|
||
- procedure variable
|
||
- method variable
|
||
- function reference
|
||
- nested procvar }
|
||
if not assigned(captured) or (captured.count=0) then
|
||
begin
|
||
if po_methodpointer in def2.procoptions then
|
||
eq:=te_convert_l2
|
||
else if po_delphi_nested_cc in def2.procoptions then
|
||
eq:=te_convert_l4
|
||
else if dstisfuncref then
|
||
eq:=te_convert_l3
|
||
else
|
||
eq:=te_convert_l1
|
||
end
|
||
{ if only a Self was captured then the function is not
|
||
compatible to normal function pointers; the order for this
|
||
is:
|
||
- method variable
|
||
- function reference
|
||
- nested function }
|
||
else if (captured.count=1) and (tsym(pcapturedsyminfo(captured[0])^.sym).typ in [localvarsym,paravarsym]) and
|
||
(vo_is_self in tabstractvarsym(pcapturedsyminfo(captured[0])^.sym).varoptions) then
|
||
begin
|
||
if po_methodpointer in def2.procoptions then
|
||
eq:=te_convert_l1
|
||
else if po_delphi_nested_cc in def2.procoptions then
|
||
eq:=te_convert_l3
|
||
else if dstisfuncref then
|
||
eq:=te_convert_l2
|
||
else
|
||
eq:=te_incompatible;
|
||
end
|
||
{ otherwise it's compatible to nested function pointers and
|
||
function references }
|
||
else
|
||
begin
|
||
if dstisfuncref then
|
||
eq:=te_convert_l1
|
||
else if po_delphi_nested_cc in def2.procoptions then
|
||
eq:=te_convert_l2
|
||
else
|
||
eq:=te_incompatible;
|
||
end;
|
||
end
|
||
else if assigned(def2.owner) and
|
||
assigned(def2.owner.defowner) and
|
||
is_funcref(tdef(def2.owner.defowner)) then
|
||
begin
|
||
{ consider assignment to a funcref a bit more expensive
|
||
then assigning it to a normal proc or method variable }
|
||
eq:=te_convert_l2;
|
||
end;
|
||
end;
|
||
proc_to_procvar_equal_internal:=eq;
|
||
end;
|
||
end;
|
||
|
||
|
||
function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef;checkincompatibleuniv: boolean):tequaltype;
|
||
begin
|
||
result:=proc_to_procvar_equal_internal(def1,def2,checkincompatibleuniv,false);
|
||
end;
|
||
|
||
|
||
function proc_to_funcref_conv(def1:tabstractprocdef;def2:tobjectdef):tequaltype;
|
||
var
|
||
invoke : tprocdef;
|
||
begin
|
||
result:=te_incompatible;
|
||
if not assigned(def1) or not assigned(def2) then
|
||
exit;
|
||
if not is_invokable(def2) then
|
||
internalerror(2022011601);
|
||
invoke:=get_invoke_procdef(def2);
|
||
result:=proc_to_procvar_equal_internal(def1,invoke,false,true);
|
||
end;
|
||
|
||
|
||
function proc_to_funcref_equal(def1:tabstractprocdef;def2:tobjectdef):tequaltype;
|
||
begin
|
||
result:=proc_to_funcref_conv(def1,def2);
|
||
{ as long as the two methods are considered convertible we consider the
|
||
procdef and the function reference as equal }
|
||
if result>te_convert_operator then
|
||
result:=te_equal;
|
||
end;
|
||
|
||
|
||
function funcref_equal(def1,def2:tobjectdef):tequaltype;
|
||
var
|
||
invoke1,
|
||
invoke2 : tprocdef;
|
||
begin
|
||
if not is_funcref(def1) then
|
||
internalerror(2022010714);
|
||
if not is_funcref(def2) then
|
||
internalerror(2022010715);
|
||
invoke1:=get_invoke_procdef(def1);
|
||
invoke2:=get_invoke_procdef(def2);
|
||
result:=proc_to_procvar_equal_internal(invoke1,invoke2,false,true);
|
||
{ as long as the two methods are considered convertible we consider the
|
||
two function references as equal }
|
||
if result>te_convert_operator then
|
||
result:=te_equal;
|
||
end;
|
||
|
||
|
||
function compatible_childmethod_resultdef(parentretdef, childretdef: tdef): boolean;
|
||
begin
|
||
compatible_childmethod_resultdef :=
|
||
(equal_defs(parentretdef,childretdef)) or
|
||
((parentretdef.typ=objectdef) and
|
||
(childretdef.typ=objectdef) and
|
||
is_class_or_interface_or_objc_or_java(parentretdef) and
|
||
is_class_or_interface_or_objc_or_java(childretdef) and
|
||
(def_is_related(tobjectdef(childretdef),tobjectdef(parentretdef))))
|
||
end;
|
||
|
||
|
||
function find_implemented_interface(impldef,intfdef:tobjectdef):timplementedinterface;
|
||
var
|
||
implintf : timplementedinterface;
|
||
i : longint;
|
||
begin
|
||
if not assigned(impldef) then
|
||
internalerror(2013102301);
|
||
if not assigned(intfdef) then
|
||
internalerror(2013102302);
|
||
result:=nil;
|
||
if not assigned(impldef.implementedinterfaces) then
|
||
exit;
|
||
for i:=0 to impldef.implementedinterfaces.count-1 do
|
||
begin
|
||
implintf:=timplementedinterface(impldef.implementedinterfaces[i]);
|
||
if equal_defs(implintf.intfdef,intfdef) then
|
||
begin
|
||
result:=implintf;
|
||
exit;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
function stringdef_is_related(curdef:tstringdef;otherdef:tdef):boolean;
|
||
begin
|
||
result:=
|
||
(target_info.system in systems_jvm) and
|
||
(((curdef.stringtype in [st_unicodestring,st_widestring]) and
|
||
((otherdef=java_jlobject) or
|
||
(otherdef=java_jlstring))) or
|
||
((curdef.stringtype=st_ansistring) and
|
||
((otherdef=java_jlobject) or
|
||
(otherdef=java_ansistring))));
|
||
end;
|
||
|
||
|
||
function recorddef_is_related(curdef:trecorddef;otherdef:tdef):boolean;
|
||
begin
|
||
{ records are implemented via classes in the JVM target, and are
|
||
all descendents of the java_fpcbaserecordtype class }
|
||
result:=false;
|
||
if (target_info.system in systems_jvm) then
|
||
begin
|
||
if otherdef.typ=objectdef then
|
||
begin
|
||
otherdef:=find_real_class_definition(tobjectdef(otherdef),false);
|
||
if (otherdef=java_jlobject) or
|
||
(otherdef=java_fpcbaserecordtype) then
|
||
result:=true
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
{ true if prot implements d (or if they are equal) }
|
||
function is_related_interface_multiple(prot:tobjectdef;d:tdef):boolean;
|
||
var
|
||
i : longint;
|
||
begin
|
||
{ objcprotocols have multiple inheritance, all protocols from which
|
||
the current protocol inherits are stored in implementedinterfaces }
|
||
result:=prot=d;
|
||
if result then
|
||
exit;
|
||
|
||
for i:=0 to prot.implementedinterfaces.count-1 do
|
||
begin
|
||
result:=is_related_interface_multiple(timplementedinterface(prot.implementedinterfaces[i]).intfdef,d);
|
||
if result then
|
||
exit;
|
||
end;
|
||
end;
|
||
|
||
|
||
function objectdef_is_related(curdef:tobjectdef;otherdef:tdef):boolean;
|
||
var
|
||
realself,
|
||
hp : tobjectdef;
|
||
begin
|
||
if (otherdef.typ=objectdef) then
|
||
otherdef:=find_real_class_definition(tobjectdef(otherdef),false);
|
||
realself:=find_real_class_definition(curdef,false);
|
||
if realself=otherdef then
|
||
begin
|
||
result:=true;
|
||
exit;
|
||
end;
|
||
|
||
if (realself.objecttype in [odt_objcclass,odt_objcprotocol]) and
|
||
(otherdef=objc_idtype) then
|
||
begin
|
||
result:=true;
|
||
exit;
|
||
end;
|
||
|
||
if (otherdef.typ<>objectdef) then
|
||
begin
|
||
result:=false;
|
||
exit;
|
||
end;
|
||
|
||
if is_funcref(realself) and is_funcref(otherdef) then
|
||
begin
|
||
result:=(funcref_equal(tobjectdef(realself),tobjectdef(otherdef))>=te_equal);
|
||
if result then
|
||
exit;
|
||
end;
|
||
|
||
{ Objective-C protocols and Java interfaces can use multiple
|
||
inheritance }
|
||
if (realself.objecttype in [odt_objcprotocol,odt_interfacejava]) then
|
||
begin
|
||
result:=is_related_interface_multiple(realself,otherdef);
|
||
exit;
|
||
end;
|
||
|
||
{ formally declared Objective-C and Java classes match Objective-C/Java
|
||
classes with the same name. In case of Java, the package must also
|
||
match (still required even though we looked up the real definitions
|
||
above, because these may be two different formal declarations that
|
||
cannot be resolved yet) }
|
||
if (realself.objecttype in [odt_objcclass,odt_javaclass]) and
|
||
(tobjectdef(otherdef).objecttype=curdef.objecttype) and
|
||
((oo_is_formal in curdef.objectoptions) or
|
||
(oo_is_formal in tobjectdef(otherdef).objectoptions)) and
|
||
(curdef.objrealname^=tobjectdef(otherdef).objrealname^) then
|
||
begin
|
||
{ check package name for Java }
|
||
if curdef.objecttype=odt_objcclass then
|
||
result:=true
|
||
else
|
||
begin
|
||
result:=
|
||
assigned(curdef.import_lib)=assigned(tobjectdef(otherdef).import_lib);
|
||
if result and
|
||
assigned(curdef.import_lib) then
|
||
result:=curdef.import_lib^=tobjectdef(otherdef).import_lib^;
|
||
end;
|
||
exit;
|
||
end;
|
||
|
||
hp:=realself.childof;
|
||
while assigned(hp) do
|
||
begin
|
||
if equal_defs(hp,otherdef) then
|
||
begin
|
||
result:=true;
|
||
exit;
|
||
end;
|
||
hp:=hp.childof;
|
||
end;
|
||
result:=false;
|
||
end;
|
||
|
||
|
||
function def_is_related(curdef,otherdef:tdef):boolean;
|
||
begin
|
||
if not assigned(curdef) then
|
||
internalerror(2013102303);
|
||
case curdef.typ of
|
||
stringdef:
|
||
result:=stringdef_is_related(tstringdef(curdef),otherdef);
|
||
recorddef:
|
||
result:=recorddef_is_related(trecorddef(curdef),otherdef);
|
||
objectdef:
|
||
result:=objectdef_is_related(tobjectdef(curdef),otherdef);
|
||
else
|
||
result:=false;
|
||
end;
|
||
end;
|
||
|
||
|
||
function equal_genfunc_paradefs(fwdef,currdef:tdef;fwpdst,currpdst:tsymtable): boolean;
|
||
begin
|
||
result:=false;
|
||
{ for open array parameters, typesym might not be assigned }
|
||
if assigned(fwdef.typesym) and (sp_generic_para in fwdef.typesym.symoptions) and
|
||
assigned(currdef.typesym) and (sp_generic_para in currdef.typesym.symoptions) and
|
||
(fwdef.owner=fwpdst) and
|
||
(currdef.owner=currpdst) then
|
||
begin
|
||
{ the forward declaration may have constraints }
|
||
if not (df_genconstraint in currdef.defoptions) and (currdef.typ=undefineddef) and
|
||
((fwdef.typ=undefineddef) or (df_genconstraint in fwdef.defoptions)) then
|
||
result:=true;
|
||
end
|
||
end;
|
||
|
||
end.
|