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