mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-08 10:32:36 +02:00
1158 lines
40 KiB
ObjectPascal
1158 lines
40 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (C) 1998-2000 by Florian Klaempfl
|
|
|
|
This unit provides some help routines for type handling
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit types;
|
|
interface
|
|
|
|
uses
|
|
cobjects,symtable
|
|
{$IFDEF NEWST}
|
|
,defs
|
|
{$ENDIF NEWST};
|
|
|
|
type
|
|
tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
|
|
mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
|
|
|
|
const
|
|
{ true if we must never copy this parameter }
|
|
never_copy_const_param : boolean = false;
|
|
|
|
{*****************************************************************************
|
|
Basic type functions
|
|
*****************************************************************************}
|
|
|
|
{ returns true, if def defines an ordinal type }
|
|
function is_ordinal(def : pdef) : boolean;
|
|
|
|
{ returns the min. value of the type }
|
|
function get_min_value(def : pdef) : longint;
|
|
|
|
{ returns true, if def defines an ordinal type }
|
|
function is_integer(def : pdef) : boolean;
|
|
|
|
{ true if p is a boolean }
|
|
function is_boolean(def : pdef) : boolean;
|
|
|
|
{ true if p is a char }
|
|
function is_char(def : pdef) : boolean;
|
|
|
|
{ true if p is a void}
|
|
function is_void(def : pdef) : boolean;
|
|
|
|
{ true if p is a smallset def }
|
|
function is_smallset(p : pdef) : boolean;
|
|
|
|
{ returns true, if def defines a signed data type (only for ordinal types) }
|
|
function is_signed(def : pdef) : boolean;
|
|
|
|
{*****************************************************************************
|
|
Array helper functions
|
|
*****************************************************************************}
|
|
|
|
{ true, if p points to a zero based (non special like open or
|
|
dynamic array def, mainly this is used to see if the array
|
|
is convertable to a pointer }
|
|
function is_zero_based_array(p : pdef) : boolean;
|
|
|
|
{ true if p points to an open array def }
|
|
function is_open_array(p : pdef) : boolean;
|
|
|
|
{ true, if p points to an array of const def }
|
|
function is_array_constructor(p : pdef) : boolean;
|
|
|
|
{ true, if p points to a variant array }
|
|
function is_variant_array(p : pdef) : boolean;
|
|
|
|
{ true, if p points to an array of const }
|
|
function is_array_of_const(p : pdef) : boolean;
|
|
|
|
{ true, if p points any kind of special array }
|
|
function is_special_array(p : pdef) : boolean;
|
|
|
|
{ true if p is a char array def }
|
|
function is_chararray(p : pdef) : boolean;
|
|
|
|
{*****************************************************************************
|
|
String helper functions
|
|
*****************************************************************************}
|
|
|
|
{ true if p points to an open string def }
|
|
function is_open_string(p : pdef) : boolean;
|
|
|
|
{ true if p is an ansi string def }
|
|
function is_ansistring(p : pdef) : boolean;
|
|
|
|
{ true if p is a long string def }
|
|
function is_longstring(p : pdef) : boolean;
|
|
|
|
{ true if p is a wide string def }
|
|
function is_widestring(p : pdef) : boolean;
|
|
|
|
{ true if p is a short string def }
|
|
function is_shortstring(p : pdef) : boolean;
|
|
|
|
{ true if p is a pchar def }
|
|
function is_pchar(p : pdef) : boolean;
|
|
|
|
{ true if p is a voidpointer def }
|
|
function is_voidpointer(p : pdef) : boolean;
|
|
|
|
{ returns true, if def uses FPU }
|
|
function is_fpu(def : pdef) : boolean;
|
|
|
|
{ true if the return value is in EAX }
|
|
function ret_in_acc(def : pdef) : boolean;
|
|
|
|
{ true if uses a parameter as return value }
|
|
function ret_in_param(def : pdef) : boolean;
|
|
|
|
{ true, if def is a 64 bit int type }
|
|
function is_64bitint(def : pdef) : boolean;
|
|
|
|
function push_high_param(def : pdef) : boolean;
|
|
|
|
{ true if a parameter is too large to copy and only the address is pushed }
|
|
function push_addr_param(def : pdef) : boolean;
|
|
|
|
{ true, if def1 and def2 are semantical the same }
|
|
function is_equal(def1,def2 : pdef) : 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: pdef): boolean;
|
|
|
|
{ same as is_equal, but with error message if failed }
|
|
function CheckTypes(def1,def2 : pdef) : boolean;
|
|
|
|
function equal_constsym(sym1,sym2:pconstsym):boolean;
|
|
|
|
{ true, if two parameter lists are equal }
|
|
{ if acp is cp_none, all have to match exactly }
|
|
{ if acp is cp_value_equal_const call by value }
|
|
{ and call by const parameter are assumed as }
|
|
{ equal }
|
|
{ if acp is cp_all the var const or nothing are considered equal }
|
|
type
|
|
compare_type = ( cp_none, cp_value_equal_const, cp_all);
|
|
|
|
function equal_paras(paralist1,paralist2 : plinkedlist; acp : compare_type) : boolean;
|
|
|
|
|
|
{ true if a type can be allowed for another one
|
|
in a func var }
|
|
function convertable_paras(paralist1,paralist2 : plinkedlist; acp : compare_type) : boolean;
|
|
|
|
{ true if a function can be assigned to a procvar }
|
|
function proc_to_procvar_equal(def1:pprocdef;def2:pprocvardef) : boolean;
|
|
|
|
{ if l isn't in the range of def a range check error is generated and
|
|
the value is placed within the range }
|
|
procedure testrange(def : pdef;var l : longint);
|
|
|
|
{ returns the range of def }
|
|
procedure getrange(def : pdef;var l : longint;var h : longint);
|
|
|
|
{ some type helper routines for MMX support }
|
|
function is_mmx_able_array(p : pdef) : boolean;
|
|
|
|
{ returns the mmx type }
|
|
function mmx_type(p : pdef) : tmmxtype;
|
|
|
|
{ returns true, if sym needs an entry in the proplist of a class rtti }
|
|
function needs_prop_entry(sym : psym) : boolean;
|
|
|
|
{ returns true, if p contains data which needs init/final code }
|
|
function needs_init_final(p : psymtable) : boolean;
|
|
|
|
implementation
|
|
|
|
uses
|
|
strings,globtype,globals,htypechk,
|
|
tree,verbose,symconst;
|
|
|
|
var
|
|
b_needs_init_final : boolean;
|
|
|
|
procedure _needs_init_final(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
|
|
|
|
|
|
begin
|
|
if (psym(p)^.typ=varsym) and
|
|
assigned(pvarsym(p)^.vartype.def) and
|
|
not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
|
|
pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
|
|
pvarsym(p)^.vartype.def^.needs_inittable then
|
|
b_needs_init_final:=true;
|
|
end;
|
|
|
|
{ returns true, if p contains data which needs init/final code }
|
|
function needs_init_final(p : psymtable) : boolean;
|
|
|
|
begin
|
|
b_needs_init_final:=false;
|
|
p^.foreach({$ifndef TP}@{$endif}_needs_init_final);
|
|
needs_init_final:=b_needs_init_final;
|
|
end;
|
|
|
|
function needs_prop_entry(sym : psym) : boolean;
|
|
|
|
begin
|
|
needs_prop_entry:=(sp_published in psym(sym)^.symoptions) and
|
|
(sym^.typ in [propertysym,varsym]);
|
|
end;
|
|
|
|
|
|
function equal_constsym(sym1,sym2:pconstsym):boolean;
|
|
var
|
|
p1,p2,pend : pchar;
|
|
begin
|
|
equal_constsym:=false;
|
|
if sym1^.consttyp<>sym2^.consttyp then
|
|
exit;
|
|
case sym1^.consttyp of
|
|
constint,
|
|
constbool,
|
|
constchar,
|
|
constpointer,
|
|
constord :
|
|
equal_constsym:=(sym1^.value=sym2^.value);
|
|
conststring,constresourcestring :
|
|
begin
|
|
if sym1^.len=sym2^.len then
|
|
begin
|
|
p1:=pchar(sym1^.value);
|
|
p2:=pchar(sym2^.value);
|
|
pend:=p1+sym1^.len;
|
|
while (p1<pend) do
|
|
begin
|
|
if p1<>p2 then
|
|
break;
|
|
inc(p1);
|
|
inc(p2);
|
|
end;
|
|
if (p1=pend) then
|
|
equal_constsym:=true;
|
|
end;
|
|
end;
|
|
constreal :
|
|
equal_constsym:=(pbestreal(sym1^.value)^=pbestreal(sym2^.value)^);
|
|
constset :
|
|
equal_constsym:=(pnormalset(sym1^.value)^=pnormalset(sym2^.value)^);
|
|
constnil :
|
|
equal_constsym:=true;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ compare_type = ( cp_none, cp_value_equal_const, cp_all); }
|
|
|
|
function equal_paras(paralist1,paralist2 : plinkedlist; acp : compare_type) : boolean;
|
|
var
|
|
def1,def2 : pparaitem;
|
|
begin
|
|
def1:=pparaitem(paralist1^.first);
|
|
def2:=pparaitem(paralist2^.first);
|
|
while (assigned(def1)) and (assigned(def2)) do
|
|
begin
|
|
case acp of
|
|
cp_value_equal_const :
|
|
begin
|
|
if not(is_equal(def1^.paratype.def,def2^.paratype.def)) or
|
|
((def1^.paratyp<>def2^.paratyp) and
|
|
((def1^.paratyp in [vs_var,vs_out]) or
|
|
(def2^.paratyp in [vs_var,vs_out])
|
|
)
|
|
) then
|
|
begin
|
|
equal_paras:=false;
|
|
exit;
|
|
end;
|
|
end;
|
|
cp_all :
|
|
begin
|
|
if not(is_equal(def1^.paratype.def,def2^.paratype.def)) or
|
|
(def1^.paratyp<>def2^.paratyp) then
|
|
begin
|
|
equal_paras:=false;
|
|
exit;
|
|
end;
|
|
end;
|
|
cp_none :
|
|
begin
|
|
if not(is_equal(def1^.paratype.def,def2^.paratype.def)) then
|
|
begin
|
|
equal_paras:=false;
|
|
exit;
|
|
end;
|
|
{ also check default value if both have it declared }
|
|
if assigned(def1^.defaultvalue) and
|
|
assigned(def2^.defaultvalue) then
|
|
begin
|
|
if not equal_constsym(pconstsym(def1^.defaultvalue),pconstsym(def2^.defaultvalue)) then
|
|
begin
|
|
equal_paras:=false;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
def1:=pparaitem(def1^.next);
|
|
def2:=pparaitem(def2^.next);
|
|
end;
|
|
if (def1=nil) and (def2=nil) then
|
|
equal_paras:=true
|
|
else
|
|
equal_paras:=false;
|
|
end;
|
|
|
|
function convertable_paras(paralist1,paralist2 : plinkedlist;acp : compare_type) : boolean;
|
|
var
|
|
def1,def2 : pparaitem;
|
|
doconv : tconverttype;
|
|
begin
|
|
def1:=pparaitem(paralist1^.first);
|
|
def2:=pparaitem(paralist2^.first);
|
|
while (assigned(def1)) and (assigned(def2)) do
|
|
begin
|
|
case acp of
|
|
cp_value_equal_const :
|
|
begin
|
|
if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) or
|
|
((def1^.paratyp<>def2^.paratyp) and
|
|
((def1^.paratyp in [vs_out,vs_var]) or
|
|
(def2^.paratyp in [vs_out,vs_var])
|
|
)
|
|
) then
|
|
begin
|
|
convertable_paras:=false;
|
|
exit;
|
|
end;
|
|
end;
|
|
cp_all :
|
|
begin
|
|
if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) or
|
|
(def1^.paratyp<>def2^.paratyp) then
|
|
begin
|
|
convertable_paras:=false;
|
|
exit;
|
|
end;
|
|
end;
|
|
cp_none :
|
|
begin
|
|
if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) then
|
|
begin
|
|
convertable_paras:=false;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
def1:=pparaitem(def1^.next);
|
|
def2:=pparaitem(def2^.next);
|
|
end;
|
|
if (def1=nil) and (def2=nil) then
|
|
convertable_paras:=true
|
|
else
|
|
convertable_paras:=false;
|
|
end;
|
|
|
|
|
|
{ true if a function can be assigned to a procvar }
|
|
function proc_to_procvar_equal(def1:pprocdef;def2:pprocvardef) : boolean;
|
|
const
|
|
po_comp = po_compatibility_options-[po_methodpointer,po_classmethod];
|
|
var
|
|
ismethod : boolean;
|
|
begin
|
|
proc_to_procvar_equal:=false;
|
|
if not(assigned(def1)) or not(assigned(def2)) then
|
|
exit;
|
|
{ check for method pointer }
|
|
ismethod:=assigned(def1^.owner) and
|
|
(def1^.owner^.symtabletype=objectsymtable);
|
|
{ I think methods of objects are also not compatible }
|
|
{ with procedure variables! (FK)
|
|
and
|
|
assigned(def1^.owner^.defowner) and
|
|
(pobjectdef(def1^.owner^.defowner)^.is_class); }
|
|
if (ismethod and not (po_methodpointer in def2^.procoptions)) or
|
|
(not(ismethod) and (po_methodpointer in def2^.procoptions)) then
|
|
begin
|
|
Message(type_e_no_method_and_procedure_not_compatible);
|
|
exit;
|
|
end;
|
|
{ check return value and para's and options, methodpointer is already checked
|
|
parameters may also be convertable }
|
|
if is_equal(def1^.rettype.def,def2^.rettype.def) and
|
|
(equal_paras(def1^.para,def2^.para,cp_all) or
|
|
convertable_paras(def1^.para,def2^.para,cp_all)) and
|
|
((po_comp * def1^.procoptions)= (po_comp * def2^.procoptions)) then
|
|
proc_to_procvar_equal:=true
|
|
else
|
|
proc_to_procvar_equal:=false;
|
|
end;
|
|
|
|
|
|
{ returns true, if def uses FPU }
|
|
function is_fpu(def : pdef) : boolean;
|
|
begin
|
|
is_fpu:=(def^.deftype=floatdef) and (pfloatdef(def)^.typ<>f32bit);
|
|
end;
|
|
|
|
|
|
{ true if p is an ordinal }
|
|
function is_ordinal(def : pdef) : boolean;
|
|
var
|
|
dt : tbasetype;
|
|
begin
|
|
case def^.deftype of
|
|
orddef :
|
|
begin
|
|
dt:=porddef(def)^.typ;
|
|
is_ordinal:=dt in [uchar,
|
|
u8bit,u16bit,u32bit,u64bit,
|
|
s8bit,s16bit,s32bit,s64bit,
|
|
bool8bit,bool16bit,bool32bit];
|
|
end;
|
|
enumdef :
|
|
is_ordinal:=true;
|
|
else
|
|
is_ordinal:=false;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ returns the min. value of the type }
|
|
function get_min_value(def : pdef) : longint;
|
|
begin
|
|
case def^.deftype of
|
|
orddef:
|
|
get_min_value:=porddef(def)^.low;
|
|
enumdef:
|
|
get_min_value:=penumdef(def)^.min;
|
|
else
|
|
get_min_value:=0;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ true if p is an integer }
|
|
function is_integer(def : pdef) : boolean;
|
|
begin
|
|
is_integer:=(def^.deftype=orddef) and
|
|
(porddef(def)^.typ in [uauto,u8bit,u16bit,u32bit,u64bit,
|
|
s8bit,s16bit,s32bit,s64bit]);
|
|
end;
|
|
|
|
|
|
{ true if p is a boolean }
|
|
function is_boolean(def : pdef) : boolean;
|
|
begin
|
|
is_boolean:=(def^.deftype=orddef) and
|
|
(porddef(def)^.typ in [bool8bit,bool16bit,bool32bit]);
|
|
end;
|
|
|
|
|
|
{ true if p is a void }
|
|
function is_void(def : pdef) : boolean;
|
|
begin
|
|
is_void:=(def^.deftype=orddef) and
|
|
(porddef(def)^.typ=uvoid);
|
|
end;
|
|
|
|
|
|
{ true if p is a char }
|
|
function is_char(def : pdef) : boolean;
|
|
begin
|
|
is_char:=(def^.deftype=orddef) and
|
|
(porddef(def)^.typ=uchar);
|
|
end;
|
|
|
|
|
|
{ true if p is signed (integer) }
|
|
function is_signed(def : pdef) : boolean;
|
|
var
|
|
dt : tbasetype;
|
|
begin
|
|
case def^.deftype of
|
|
orddef :
|
|
begin
|
|
dt:=porddef(def)^.typ;
|
|
is_signed:=(dt in [s8bit,s16bit,s32bit,s64bit]);
|
|
end;
|
|
enumdef :
|
|
is_signed:=false;
|
|
else
|
|
is_signed:=false;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ true, if p points to an open array def }
|
|
function is_open_string(p : pdef) : boolean;
|
|
begin
|
|
is_open_string:=(p^.deftype=stringdef) and
|
|
(pstringdef(p)^.string_typ=st_shortstring) and
|
|
(pstringdef(p)^.len=0);
|
|
end;
|
|
|
|
|
|
{ true, if p points to a zero based array def }
|
|
function is_zero_based_array(p : pdef) : boolean;
|
|
begin
|
|
is_zero_based_array:=(p^.deftype=arraydef) and
|
|
(parraydef(p)^.lowrange=0) and
|
|
not(is_special_array(p));
|
|
end;
|
|
|
|
{ true, if p points to an open array def }
|
|
function is_open_array(p : pdef) : boolean;
|
|
begin
|
|
{ check for s32bitdef is needed, because for u32bit the high
|
|
range is also -1 ! (PFV) }
|
|
is_open_array:=(p^.deftype=arraydef) and
|
|
(parraydef(p)^.rangetype.def=pdef(s32bitdef)) and
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=-1) and
|
|
not(parraydef(p)^.IsConstructor) and
|
|
not(parraydef(p)^.IsVariant) and
|
|
not(parraydef(p)^.IsArrayOfConst);
|
|
|
|
end;
|
|
|
|
{ true, if p points to an array of const def }
|
|
function is_array_constructor(p : pdef) : boolean;
|
|
begin
|
|
is_array_constructor:=(p^.deftype=arraydef) and
|
|
(parraydef(p)^.IsConstructor);
|
|
end;
|
|
|
|
{ true, if p points to a variant array }
|
|
function is_variant_array(p : pdef) : boolean;
|
|
begin
|
|
is_variant_array:=(p^.deftype=arraydef) and
|
|
(parraydef(p)^.IsVariant);
|
|
end;
|
|
|
|
{ true, if p points to an array of const }
|
|
function is_array_of_const(p : pdef) : boolean;
|
|
begin
|
|
is_array_of_const:=(p^.deftype=arraydef) and
|
|
(parraydef(p)^.IsArrayOfConst);
|
|
end;
|
|
|
|
{ true, if p points to a special array }
|
|
function is_special_array(p : pdef) : boolean;
|
|
begin
|
|
is_special_array:=(p^.deftype=arraydef) and
|
|
((parraydef(p)^.IsVariant) or
|
|
(parraydef(p)^.IsArrayOfConst) or
|
|
(parraydef(p)^.IsConstructor) or
|
|
is_open_array(p)
|
|
);
|
|
end;
|
|
|
|
{ true if p is an ansi string def }
|
|
function is_ansistring(p : pdef) : boolean;
|
|
begin
|
|
is_ansistring:=(p^.deftype=stringdef) and
|
|
(pstringdef(p)^.string_typ=st_ansistring);
|
|
end;
|
|
|
|
|
|
{ true if p is an long string def }
|
|
function is_longstring(p : pdef) : boolean;
|
|
begin
|
|
is_longstring:=(p^.deftype=stringdef) and
|
|
(pstringdef(p)^.string_typ=st_longstring);
|
|
end;
|
|
|
|
|
|
{ true if p is an wide string def }
|
|
function is_widestring(p : pdef) : boolean;
|
|
begin
|
|
is_widestring:=(p^.deftype=stringdef) and
|
|
(pstringdef(p)^.string_typ=st_widestring);
|
|
end;
|
|
|
|
|
|
{ true if p is an short string def }
|
|
function is_shortstring(p : pdef) : boolean;
|
|
begin
|
|
is_shortstring:=(p^.deftype=stringdef) and
|
|
(pstringdef(p)^.string_typ=st_shortstring);
|
|
end;
|
|
|
|
{ true if p is a char array def }
|
|
function is_chararray(p : pdef) : boolean;
|
|
begin
|
|
is_chararray:=(p^.deftype=arraydef) and
|
|
is_equal(parraydef(p)^.elementtype.def,cchardef) and
|
|
not(is_special_array(p));
|
|
end;
|
|
|
|
|
|
{ true if p is a pchar def }
|
|
function is_pchar(p : pdef) : boolean;
|
|
begin
|
|
is_pchar:=(p^.deftype=pointerdef) and
|
|
is_equal(Ppointerdef(p)^.pointertype.def,cchardef);
|
|
end;
|
|
|
|
|
|
{ true if p is a voidpointer def }
|
|
function is_voidpointer(p : pdef) : boolean;
|
|
begin
|
|
is_voidpointer:=(p^.deftype=pointerdef) and
|
|
is_equal(Ppointerdef(p)^.pointertype.def,voiddef);
|
|
end;
|
|
|
|
|
|
{ true if p is a smallset def }
|
|
function is_smallset(p : pdef) : boolean;
|
|
begin
|
|
is_smallset:=(p^.deftype=setdef) and
|
|
(psetdef(p)^.settype=smallset);
|
|
end;
|
|
|
|
|
|
{ true if the return value is in accumulator (EAX for i386), D0 for 68k }
|
|
function ret_in_acc(def : pdef) : boolean;
|
|
begin
|
|
ret_in_acc:=(def^.deftype in [orddef,pointerdef,enumdef,classrefdef]) or
|
|
((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_ansistring,st_widestring])) or
|
|
((def^.deftype=procvardef) and not(po_methodpointer in pprocvardef(def)^.procoptions)) or
|
|
((def^.deftype=objectdef) and pobjectdef(def)^.is_class) or
|
|
((def^.deftype=setdef) and (psetdef(def)^.settype=smallset)) or
|
|
((def^.deftype=floatdef) and (pfloatdef(def)^.typ=f32bit));
|
|
end;
|
|
|
|
|
|
{ true, if def is a 64 bit int type }
|
|
function is_64bitint(def : pdef) : boolean;
|
|
begin
|
|
is_64bitint:=(def^.deftype=orddef) and (porddef(def)^.typ in [u64bit,s64bit])
|
|
end;
|
|
|
|
|
|
{ true if uses a parameter as return value }
|
|
function ret_in_param(def : pdef) : boolean;
|
|
begin
|
|
ret_in_param:=(def^.deftype in [arraydef,recorddef]) or
|
|
((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_shortstring,st_longstring])) or
|
|
((def^.deftype=procvardef) and (po_methodpointer in pprocvardef(def)^.procoptions)) or
|
|
((def^.deftype=objectdef) and not(pobjectdef(def)^.is_class)) or
|
|
((def^.deftype=setdef) and (psetdef(def)^.settype<>smallset));
|
|
end;
|
|
|
|
|
|
function push_high_param(def : pdef) : boolean;
|
|
begin
|
|
push_high_param:=is_open_array(def) or
|
|
is_open_string(def) or
|
|
is_array_of_const(def);
|
|
end;
|
|
|
|
|
|
{ true if a parameter is too large to copy and only the address is pushed }
|
|
function push_addr_param(def : pdef) : boolean;
|
|
begin
|
|
push_addr_param:=false;
|
|
if never_copy_const_param then
|
|
push_addr_param:=true
|
|
else
|
|
begin
|
|
case def^.deftype of
|
|
formaldef :
|
|
push_addr_param:=true;
|
|
recorddef :
|
|
push_addr_param:=(def^.size>4);
|
|
arraydef :
|
|
push_addr_param:=((Parraydef(def)^.highrange>Parraydef(def)^.lowrange) and (def^.size>4)) or
|
|
is_open_array(def) or
|
|
is_array_of_const(def) or
|
|
is_array_constructor(def);
|
|
objectdef :
|
|
push_addr_param:=not(pobjectdef(def)^.is_class);
|
|
stringdef :
|
|
push_addr_param:=pstringdef(def)^.string_typ in [st_shortstring,st_longstring];
|
|
procvardef :
|
|
push_addr_param:=(po_methodpointer in pprocvardef(def)^.procoptions);
|
|
setdef :
|
|
push_addr_param:=(psetdef(def)^.settype<>smallset);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ test if l is in the range of def, outputs error if out of range }
|
|
procedure testrange(def : pdef;var l : longint);
|
|
var
|
|
lv,hv: longint;
|
|
|
|
begin
|
|
{ for 64 bit types we need only to check if it is less than }
|
|
{ zero, if def is a qword node }
|
|
if is_64bitint(def) then
|
|
begin
|
|
if (l<0) and (porddef(def)^.typ=u64bit) then
|
|
begin
|
|
l:=0;
|
|
if (cs_check_range in aktlocalswitches) then
|
|
Message(parser_e_range_check_error)
|
|
else
|
|
Message(parser_w_range_check_error);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
getrange(def,lv,hv);
|
|
if (def^.deftype=orddef) and
|
|
(porddef(def)^.typ=u32bit) then
|
|
begin
|
|
if lv<=hv then
|
|
begin
|
|
if (l<lv) or (l>hv) then
|
|
begin
|
|
if (cs_check_range in aktlocalswitches) then
|
|
Message(parser_e_range_check_error)
|
|
else
|
|
Message(parser_w_range_check_error);
|
|
end;
|
|
end
|
|
else
|
|
{ this happens with the wrap around problem }
|
|
{ if lv is positive and hv is over $7ffffff }
|
|
{ so it seems negative }
|
|
begin
|
|
if ((l>=0) and (l<lv)) or
|
|
((l<0) and (l>hv)) then
|
|
begin
|
|
if (cs_check_range in aktlocalswitches) then
|
|
Message(parser_e_range_check_error)
|
|
else
|
|
Message(parser_w_range_check_error);
|
|
end;
|
|
end;
|
|
end
|
|
else if (l<lv) or (l>hv) then
|
|
begin
|
|
if (def^.deftype=enumdef) or
|
|
(cs_check_range in aktlocalswitches) then
|
|
Message(parser_e_range_check_error)
|
|
else
|
|
Message(parser_w_range_check_error);
|
|
{ Fix the value to fit in the allocated space for this type of variable }
|
|
case def^.size of
|
|
1: l := l and $ff;
|
|
2: l := l and $ffff;
|
|
end
|
|
{ l:=lv+(l mod (hv-lv+1));}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ return the range from def in l and h }
|
|
procedure getrange(def : pdef;var l : longint;var h : longint);
|
|
begin
|
|
case def^.deftype of
|
|
orddef :
|
|
begin
|
|
l:=porddef(def)^.low;
|
|
h:=porddef(def)^.high;
|
|
end;
|
|
enumdef :
|
|
begin
|
|
l:=penumdef(def)^.min;
|
|
h:=penumdef(def)^.max;
|
|
end;
|
|
arraydef :
|
|
begin
|
|
l:=parraydef(def)^.lowrange;
|
|
h:=parraydef(def)^.highrange;
|
|
end;
|
|
else
|
|
internalerror(987);
|
|
end;
|
|
end;
|
|
|
|
|
|
function mmx_type(p : pdef) : tmmxtype;
|
|
begin
|
|
mmx_type:=mmxno;
|
|
if is_mmx_able_array(p) then
|
|
begin
|
|
if parraydef(p)^.elementtype.def^.deftype=floatdef then
|
|
case pfloatdef(parraydef(p)^.elementtype.def)^.typ of
|
|
s32real:
|
|
mmx_type:=mmxsingle;
|
|
f16bit:
|
|
mmx_type:=mmxfixed16
|
|
end
|
|
else
|
|
case porddef(parraydef(p)^.elementtype.def)^.typ of
|
|
u8bit:
|
|
mmx_type:=mmxu8bit;
|
|
s8bit:
|
|
mmx_type:=mmxs8bit;
|
|
u16bit:
|
|
mmx_type:=mmxu16bit;
|
|
s16bit:
|
|
mmx_type:=mmxs16bit;
|
|
u32bit:
|
|
mmx_type:=mmxu32bit;
|
|
s32bit:
|
|
mmx_type:=mmxs32bit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
function is_mmx_able_array(p : pdef) : boolean;
|
|
begin
|
|
{$ifdef SUPPORT_MMX}
|
|
if (cs_mmx_saturation in aktlocalswitches) then
|
|
begin
|
|
is_mmx_able_array:=(p^.deftype=arraydef) and
|
|
not(is_special_array(p)) and
|
|
(
|
|
(
|
|
(parraydef(p)^.elementtype.def^.deftype=orddef) and
|
|
(
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=1) and
|
|
(porddef(parraydef(p)^.elementtype.def)^.typ in [u32bit,s32bit])
|
|
)
|
|
or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=3) and
|
|
(porddef(parraydef(p)^.elementtype.def)^.typ in [u16bit,s16bit])
|
|
)
|
|
)
|
|
)
|
|
or
|
|
(
|
|
(
|
|
(parraydef(p)^.elementtype.def^.deftype=floatdef) and
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=3) and
|
|
(pfloatdef(parraydef(p)^.elementtype.def)^.typ=f16bit)
|
|
) or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=1) and
|
|
(pfloatdef(parraydef(p)^.elementtype.def)^.typ=s32real)
|
|
)
|
|
)
|
|
)
|
|
);
|
|
end
|
|
else
|
|
begin
|
|
is_mmx_able_array:=(p^.deftype=arraydef) and
|
|
(
|
|
(
|
|
(parraydef(p)^.elementtype.def^.deftype=orddef) and
|
|
(
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=1) and
|
|
(porddef(parraydef(p)^.elementtype.def)^.typ in [u32bit,s32bit])
|
|
)
|
|
or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=3) and
|
|
(porddef(parraydef(p)^.elementtype.def)^.typ in [u16bit,s16bit])
|
|
)
|
|
or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=7) and
|
|
(porddef(parraydef(p)^.elementtype.def)^.typ in [u8bit,s8bit])
|
|
)
|
|
)
|
|
)
|
|
or
|
|
(
|
|
(parraydef(p)^.elementtype.def^.deftype=floatdef) and
|
|
(
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=3) and
|
|
(pfloatdef(parraydef(p)^.elementtype.def)^.typ=f32bit)
|
|
)
|
|
or
|
|
(
|
|
(parraydef(p)^.lowrange=0) and
|
|
(parraydef(p)^.highrange=1) and
|
|
(pfloatdef(parraydef(p)^.elementtype.def)^.typ=s32real)
|
|
)
|
|
)
|
|
)
|
|
);
|
|
end;
|
|
{$else SUPPORT_MMX}
|
|
is_mmx_able_array:=false;
|
|
{$endif SUPPORT_MMX}
|
|
end;
|
|
|
|
|
|
function is_equal(def1,def2 : pdef) : boolean;
|
|
var
|
|
b : boolean;
|
|
hd : pdef;
|
|
begin
|
|
{ both types must exists }
|
|
if not (assigned(def1) and assigned(def2)) then
|
|
begin
|
|
is_equal:=false;
|
|
exit;
|
|
end;
|
|
|
|
{ be sure, that if there is a stringdef, that this is def1 }
|
|
if def2^.deftype=stringdef then
|
|
begin
|
|
hd:=def1;
|
|
def1:=def2;
|
|
def2:=hd;
|
|
end;
|
|
b:=false;
|
|
|
|
{ both point to the same definition ? }
|
|
if def1=def2 then
|
|
b:=true
|
|
else
|
|
{ pointer with an equal definition are equal }
|
|
if (def1^.deftype=pointerdef) and (def2^.deftype=pointerdef) then
|
|
begin
|
|
{ here a problem detected in tabsolutesym }
|
|
{ the types can be forward type !! }
|
|
if assigned(def1^.typesym) and (ppointerdef(def1)^.pointertype.def^.deftype=forwarddef) then
|
|
b:=(def1^.typesym=def2^.typesym)
|
|
else
|
|
b:=ppointerdef(def1)^.pointertype.def=ppointerdef(def2)^.pointertype.def;
|
|
end
|
|
else
|
|
{ ordinals are equal only when the ordinal type is equal }
|
|
if (def1^.deftype=orddef) and (def2^.deftype=orddef) then
|
|
begin
|
|
case porddef(def1)^.typ of
|
|
u8bit,u16bit,u32bit,
|
|
s8bit,s16bit,s32bit:
|
|
b:=((porddef(def1)^.typ=porddef(def2)^.typ) and
|
|
(porddef(def1)^.low=porddef(def2)^.low) and
|
|
(porddef(def1)^.high=porddef(def2)^.high));
|
|
uvoid,uchar,
|
|
bool8bit,bool16bit,bool32bit:
|
|
b:=(porddef(def1)^.typ=porddef(def2)^.typ);
|
|
end;
|
|
end
|
|
else
|
|
if (def1^.deftype=floatdef) and (def2^.deftype=floatdef) then
|
|
b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ
|
|
else
|
|
{ strings with the same length are equal }
|
|
if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
|
|
(pstringdef(def1)^.string_typ=pstringdef(def2)^.string_typ) then
|
|
begin
|
|
b:=not(is_shortstring(def1)) or
|
|
(pstringdef(def1)^.len=pstringdef(def2)^.len);
|
|
end
|
|
else
|
|
if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then
|
|
b:=true
|
|
{ file types with the same file element type are equal }
|
|
{ this is a problem for assign !! }
|
|
{ changed to allow if one is untyped }
|
|
{ all typed files are equal to the special }
|
|
{ typed file that has voiddef as elemnt type }
|
|
{ but must NOT match for text file !!! }
|
|
else
|
|
if (def1^.deftype=filedef) and (def2^.deftype=filedef) then
|
|
b:=(pfiledef(def1)^.filetyp=pfiledef(def2)^.filetyp) and
|
|
((
|
|
((pfiledef(def1)^.typedfiletype.def=nil) and
|
|
(pfiledef(def2)^.typedfiletype.def=nil)) or
|
|
(
|
|
(pfiledef(def1)^.typedfiletype.def<>nil) and
|
|
(pfiledef(def2)^.typedfiletype.def<>nil) and
|
|
is_equal(pfiledef(def1)^.typedfiletype.def,pfiledef(def2)^.typedfiletype.def)
|
|
) or
|
|
( (pfiledef(def1)^.typedfiletype.def=pdef(voiddef)) or
|
|
(pfiledef(def2)^.typedfiletype.def=pdef(voiddef))
|
|
)))
|
|
{ sets with the same element type are equal }
|
|
else
|
|
if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
|
|
begin
|
|
if assigned(psetdef(def1)^.elementtype.def) and
|
|
assigned(psetdef(def2)^.elementtype.def) then
|
|
b:=(psetdef(def1)^.elementtype.def^.deftype=psetdef(def2)^.elementtype.def^.deftype)
|
|
else
|
|
b:=true;
|
|
end
|
|
else
|
|
if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
|
|
begin
|
|
{ poassembler isn't important for compatibility }
|
|
{ if a method is assigned to a methodpointer }
|
|
{ is checked before }
|
|
b:=(pprocvardef(def1)^.proctypeoption=pprocvardef(def2)^.proctypeoption) and
|
|
(pprocvardef(def1)^.proccalloptions=pprocvardef(def2)^.proccalloptions) and
|
|
((pprocvardef(def1)^.procoptions * po_compatibility_options)=
|
|
(pprocvardef(def2)^.procoptions * po_compatibility_options)) and
|
|
is_equal(pprocvardef(def1)^.rettype.def,pprocvardef(def2)^.rettype.def) and
|
|
equal_paras(pprocvardef(def1)^.para,pprocvardef(def2)^.para,cp_all);
|
|
end
|
|
else
|
|
if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) then
|
|
begin
|
|
if is_open_array(def1) or is_open_array(def2) or
|
|
is_array_of_const(def1) or is_array_of_const(def2) then
|
|
begin
|
|
if parraydef(def1)^.IsArrayOfConst or parraydef(def2)^.IsArrayOfConst then
|
|
b:=true
|
|
else
|
|
b:=is_equal(parraydef(def1)^.elementtype.def,parraydef(def2)^.elementtype.def);
|
|
end
|
|
else
|
|
begin
|
|
b:=not(m_tp in aktmodeswitches) and
|
|
not(m_delphi in aktmodeswitches) and
|
|
(parraydef(def1)^.lowrange=parraydef(def2)^.lowrange) and
|
|
(parraydef(def1)^.highrange=parraydef(def2)^.highrange) and
|
|
is_equal(parraydef(def1)^.elementtype.def,parraydef(def2)^.elementtype.def) and
|
|
is_equal(parraydef(def1)^.rangetype.def,parraydef(def2)^.rangetype.def);
|
|
end;
|
|
end
|
|
else
|
|
if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
|
|
begin
|
|
{ similar to pointerdef: }
|
|
if assigned(def1^.typesym) and (pclassrefdef(def1)^.pointertype.def^.deftype=forwarddef) then
|
|
b:=(def1^.typesym=def2^.typesym)
|
|
else
|
|
b:=is_equal(pclassrefdef(def1)^.pointertype.def,pclassrefdef(def2)^.pointertype.def);
|
|
end;
|
|
is_equal:=b;
|
|
end;
|
|
|
|
|
|
function is_subequal(def1, def2: pdef): boolean;
|
|
|
|
var
|
|
basedef1,basedef2 : penumdef;
|
|
|
|
Begin
|
|
is_subequal := false;
|
|
if assigned(def1) and assigned(def2) then
|
|
Begin
|
|
if (def1^.deftype = orddef) and (def2^.deftype = orddef) then
|
|
Begin
|
|
{ see p.47 of Turbo Pascal 7.01 manual for the separation of types }
|
|
{ range checking for case statements is done with testrange }
|
|
case porddef(def1)^.typ of
|
|
u8bit,u16bit,u32bit,
|
|
s8bit,s16bit,s32bit,s64bit,u64bit :
|
|
is_subequal:=(porddef(def2)^.typ in [s64bit,u64bit,s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
|
|
bool8bit,bool16bit,bool32bit :
|
|
is_subequal:=(porddef(def2)^.typ in [bool8bit,bool16bit,bool32bit]);
|
|
uchar :
|
|
is_subequal:=(porddef(def2)^.typ=uchar);
|
|
end;
|
|
end
|
|
else
|
|
Begin
|
|
{ I assume that both enumerations are equal when the first }
|
|
{ pointers are equal. }
|
|
|
|
{ I changed this to assume that the enums are equal }
|
|
{ if the basedefs are equal (FK) }
|
|
if (def1^.deftype=enumdef) and (def2^.deftype=enumdef) then
|
|
Begin
|
|
{ get both basedefs }
|
|
basedef1:=penumdef(def1);
|
|
while assigned(basedef1^.basedef) do
|
|
basedef1:=basedef1^.basedef;
|
|
basedef2:=penumdef(def2);
|
|
while assigned(basedef2^.basedef) do
|
|
basedef2:=basedef2^.basedef;
|
|
is_subequal:=basedef1=basedef2;
|
|
{
|
|
if penumdef(def1)^.firstenum = penumdef(def2)^.firstenum then
|
|
is_subequal := TRUE;
|
|
}
|
|
end;
|
|
end;
|
|
end; { endif assigned ... }
|
|
end;
|
|
|
|
function CheckTypes(def1,def2 : pdef) : boolean;
|
|
|
|
var
|
|
s1,s2 : string;
|
|
|
|
begin
|
|
if not is_equal(def1,def2) then
|
|
begin
|
|
{ Crash prevention }
|
|
if (not assigned(def1)) or (not assigned(def2)) then
|
|
Message(type_e_mismatch)
|
|
else
|
|
begin
|
|
s1:=def1^.typename;
|
|
s2:=def2^.typename;
|
|
if (s1<>'<unknown type>') and (s2<>'<unknown type>') then
|
|
Message2(type_e_not_equal_types,def1^.typename,def2^.typename)
|
|
else
|
|
Message(type_e_mismatch);
|
|
end;
|
|
CheckTypes:=false;
|
|
end
|
|
else
|
|
CheckTypes:=true;
|
|
end;
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.6 2000-08-13 13:07:18 peter
|
|
* equal_paras now also checks default parameter value
|
|
|
|
Revision 1.5 2000/08/12 06:49:22 florian
|
|
+ case statement for int64/qword implemented
|
|
|
|
Revision 1.4 2000/08/08 19:26:41 peter
|
|
* equal_constsym() needed for default para
|
|
|
|
Revision 1.3 2000/07/13 12:08:28 michael
|
|
+ patched to 1.1.0 with former 1.09patch from peter
|
|
|
|
Revision 1.2 2000/07/13 11:32:53 michael
|
|
+ removed logs
|
|
|
|
} |