freepascal.compiler/compiler/types.pas

{
    $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;

{$i defines.inc}

interface

    uses
       cobjects,cclasses,
       cpuinfo,
       node,
       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 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 a dynamic array def }
    function is_dynamic_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;

    { true if p is a wide char array def }
    function is_widechararray(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 pwidechar def }
    function is_pwidechar(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;

     type
       tconverttype = (
          tc_equal,
          tc_not_possible,
          tc_string_2_string,
          tc_char_2_string,
          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
       );

    function assignment_overloaded(from_def,to_def : pdef) : pprocdef;

    { Returns:
       0 - Not convertable
       1 - Convertable
       2 - Convertable, but not first choice }
    function isconvertable(def_from,def_to : pdef;
             var doconv : tconverttype;
             fromtreetype : tnodetype;
             explicit : boolean) : byte;

    { 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 : tlinkedlist; acp : compare_type) : 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 }
    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 : tconstexprint);

    { 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
       globtype,globals,systems,tokens,verbose,
       symconst,symtable,nld;

    var
       b_needs_init_final : boolean;

    procedure _needs_init_final(p : pnamedindexobject);
      begin
         if (psym(p)^.typ=varsym) and
           assigned(pvarsym(p)^.vartype.def) and
           not is_class(pvarsym(p)^.vartype.def) and
           pstoreddef(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({$ifdef FPCPROCVAR}@{$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(tpointerord(sym1^.value));
                  p2:=pchar(tpointerord(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(tpointerord(sym1^.value))^=pbestreal(tpointerord(sym2^.value))^);
           constset :
             equal_constsym:=(pnormalset(tpointerord(sym1^.value))^=pnormalset(tpointerord(sym2^.value))^);
           constnil :
             equal_constsym:=true;
        end;
      end;


    {  compare_type = ( cp_none, cp_value_equal_const, cp_all); }

    function equal_paras(paralist1,paralist2 : TLinkedList; acp : compare_type) : boolean;
      var
        def1,def2 : TParaItem;
      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 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:=TParaItem(def1.next);
              def2:=TParaItem(def2.next);
           end;
         if (def1=nil) and (def2=nil) 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;
      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_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 }
    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);
      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,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 : 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:=penumdef(def)^.min < 0;
           arraydef :
             is_signed:=is_signed(parraydef(def)^.rangetype.def);
           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 a dynamic array def }
    function is_dynamic_array(p : pdef) : boolean;
      begin
         is_dynamic_array:=(p^.deftype=arraydef) and
           parraydef(p)^.IsDynamicArray;
      end;


    { true, if p points to an open array def }
    function is_open_array(p : pdef) : boolean;
      begin
         { check for s32bittype is needed, because for u32bit the high
           range is also -1 ! (PFV) }
         is_open_array:=(p^.deftype=arraydef) and
                        (parraydef(p)^.rangetype.def=s32bittype.def) 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) and
                        not(parraydef(p)^.IsDynamicArray);

      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,cchartype.def) and
                      not(is_special_array(p));
      end;

    { true if p is a widechar array def }
    function is_widechararray(p : pdef) : boolean;
      begin
        is_widechararray:=(p^.deftype=arraydef) and
                      is_equal(parraydef(p)^.elementtype.def,cwidechartype.def) 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,cchartype.def) or
                   (is_zero_based_array(ppointerdef(p)^.pointertype.def) and
                    is_chararray(ppointerdef(p)^.pointertype.def)));
      end;

    { true if p is a pchar def }
    function is_pwidechar(p : pdef) : boolean;
      begin
        is_pwidechar:=(p^.deftype=pointerdef) and
                  (is_equal(ppointerdef(p)^.pointertype.def,cwidechartype.def) or
                   (is_zero_based_array(ppointerdef(p)^.pointertype.def) and
                    is_widechararray(ppointerdef(p)^.pointertype.def)));
      end;


    { true if p is a voidpointer def }
    function is_voidpointer(p : pdef) : boolean;
      begin
        is_voidpointer:=(p^.deftype=pointerdef) and
                        (ppointerdef(p)^.pointertype.def^.deftype=orddef) and
                        (porddef(ppointerdef(p)^.pointertype.def)^.typ=uvoid);
      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 not is_object(def)) or
                     ((def^.deftype=setdef) and (psetdef(def)^.settype=smallset));
      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 is_object(def)) 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>target_os.size_of_pointer);
             arraydef :
               push_addr_param:=((Parraydef(def)^.highrange>=Parraydef(def)^.lowrange) and (def^.size>target_os.size_of_pointer)) or
                                is_open_array(def) or
                                is_array_of_const(def) or
                                is_array_constructor(def);
             objectdef :
               push_addr_param:=is_object(def);
             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 : tconstexprint);
      var
         lv,hv: longint;
         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 (porddef(def)^.typ=u64bit) then
                begin
                   { don't zero the result, because it may come from hex notation
                     like $ffffffffffffffff! (JM)
                   l:=0; }
                   if (cs_check_range in aktlocalswitches) then
                     Message(parser_e_range_check_error)
                   else
                     Message(parser_w_range_check_error);
                   error := true;
                end;
           end
         else
           begin
              getrange(def,lv,hv);
              if (def^.deftype=orddef) and
                 (porddef(def)^.typ=u32bit) then
                begin
                  if (l < cardinal(lv)) or
                     (l > cardinal(hv)) then
                    begin
                      if (cs_check_range in aktlocalswitches) then
                        Message(parser_e_range_check_error)
                      else
                        Message(parser_w_range_check_error);
                      error := true;
                    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);
                   error := true;
                end;
           end;
         if error then
         { 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;
      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;
                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=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=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
                { check if both are farpointer }
                if (ppointerdef(def1)^.is_far=ppointerdef(def2)^.is_far) 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
                 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 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,uwidechar,
                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(voidtype.def)) or
                   (pfiledef(def2)^.typedfiletype.def=pdef(voidtype.def))
                 )))
         { sets with the same element base 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:=is_subequal(psetdef(def1)^.elementtype.def,psetdef(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:=(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_dynamic_array(def1) and is_dynamic_array(def2) then
                 b:=is_equal(parraydef(def1)^.elementtype.def,parraydef(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_open_array(def1) or is_open_array(def2) then
                 begin
                   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 assignment_overloaded(from_def,to_def : pdef) : pprocdef;
       var
          passproc : pprocdef;
          convtyp : tconverttype;
       begin
          assignment_overloaded:=nil;
          if assigned(overloaded_operators[_ASSIGNMENT]) then
            passproc:=overloaded_operators[_ASSIGNMENT]^.definition
          else
            exit;
          while passproc<>nil do
            begin
              if is_equal(passproc^.rettype.def,to_def) and
                 (is_equal(TParaItem(passproc^.Para.first).paratype.def,from_def) or
                 (isconvertable(from_def,TParaItem(passproc^.Para.first).paratype.def,convtyp,ordconstn,false)=1)) then
                begin
                   assignment_overloaded:=passproc;
                   break;
                end;
              passproc:=passproc^.nextoverloaded;
            end;
       end;


    { Returns:
       0 - Not convertable
       1 - Convertable
       2 - Convertable, but not first choice }
    function isconvertable(def_from,def_to : pdef;
             var doconv : tconverttype;
             fromtreetype : tnodetype;
             explicit : boolean) : byte;

      { Tbasetype:  uauto,uvoid,uchar,
                    u8bit,u16bit,u32bit,
                    s8bit,s16bit,s32,
                    bool8bit,bool16bit,bool32bit,
                    u64bit,s64bitint }
      type
        tbasedef=(bvoid,bchar,bint,bbool);
      const
        basedeftbl:array[tbasetype] of tbasedef =
          (bvoid,bvoid,bchar,
           bint,bint,bint,
           bint,bint,bint,
           bbool,bbool,bbool,bint,bint,bchar);

        basedefconverts : array[tbasedef,tbasedef] of tconverttype =
         ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
          (tc_not_possible,tc_equal,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 : pdef;
         hct : tconverttype;
      begin
       { safety check }
         if not(assigned(def_from) and assigned(def_to)) then
          begin
            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) then
          begin
            def_from:=pprocvardef(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[porddef(def_from)^.typ],basedeftbl[porddef(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;
                   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) 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) then
                      begin
                        doconv:=tc_chararray_2_string;
                        if (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 is_pchar(def_from) and not(m_tp7 in aktmodeswitches) then
                      begin
                        doconv:=tc_pchar_2_string;
                        { prefer 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;
                   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 pfloatdef(def_from)^.typ=pfloatdef(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
                  hd1:=def_from;
                  while assigned(penumdef(hd1)^.basedef) do
                   hd1:=penumdef(hd1)^.basedef;
                  hd2:=def_to;
                  while assigned(penumdef(hd2)^.basedef) do
                    hd2:=penumdef(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;

           arraydef :
             begin
             { open array is also compatible with a single element of its base type }
               if is_open_array(def_to) and
                  is_equal(parraydef(def_to)^.elementtype.def,def_from) 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(parraydef(def_from)^.elementtype.def) or
                              is_equal(parraydef(def_to)^.elementtype.def,parraydef(def_from)^.elementtype.def) then
                            begin
                              doconv:=tc_equal;
                              b:=1;
                            end
                           else
                            if isconvertable(parraydef(def_from)^.elementtype.def,
                                             parraydef(def_to)^.elementtype.def,hct,arrayconstructorn,false)<>0 then
                             begin
                               doconv:=hct;
                               b:=2;
                             end;
                         end
                        else
                        { array of tvarrec -> array of const }
                         if is_array_of_const(def_to) and
                            is_equal(parraydef(def_to)^.elementtype.def,parraydef(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(ppointerdef(def_from)^.pointertype.def,parraydef(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(parraydef(def_to)^.elementtype.def) then
                         begin
                           doconv:=tc_string_2_chararray;
                           b:=1;
                         end;
                      end;
                    recorddef :
                      begin
                        { tvarrec -> array of constconst }
                         if is_array_of_const(def_to) and
                            is_equal(def_from,parraydef(def_to)^.elementtype.def) then
                          begin
                            doconv:=tc_equal;
                            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) 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(parraydef(def_from)^.elementtype.def,ppointerdef(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 (
                         (ppointerdef(def_from)^.pointertype.def^.deftype=objectdef) and
                         (ppointerdef(def_to)^.pointertype.def^.deftype=objectdef) and
                         pobjectdef(ppointerdef(def_from)^.pointertype.def)^.is_related(
                           pobjectdef(ppointerdef(def_to)^.pointertype.def))
                        ) or
                        { all pointers can be assigned to void-pointer }
                        is_equal(ppointerdef(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(ppointerdef(def_from)^.pointertype.def,voidtype.def) then
                       begin
                         { but don't allow conversion between farpointer-pointer }
                         if (ppointerdef(def_to)^.is_far=ppointerdef(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
                        (ppointerdef(def_to)^.pointertype.def^.deftype=orddef) and
                        (porddef(ppointerdef(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
                        (ppointerdef(def_to)^.pointertype.def^.deftype=orddef) and
                        (porddef(ppointerdef(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) then
                begin
                  doconv:=tc_proc_2_procvar;
                  if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then
                   b:=1;
                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
                  (ppointerdef(def_from)^.pointertype.def^.deftype=orddef) and
                  (porddef(ppointerdef(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
                 pobjectdef(def_from)^.is_related(pobjectdef(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(pobjectdef(def_from)^.implementedinterfaces) and
                     (pobjectdef(def_from)^.implementedinterfaces^.searchintf(def_to)<>-1) then
                     begin
                        doconv:=tc_class_2_intf;
                        b:=1;
                     end
                   { Interface 2 GUID handling }
                   else if (def_to=pdef(rec_tguid)) and
                           (fromtreetype=typen) and
                           is_interface(def_from) and
                           pobjectdef(def_from)^.isiidguidvalid 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 pobjectdef(pclassrefdef(def_from)^.pointertype.def)^.is_related(
                       pobjectdef(pclassrefdef(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
                  (
                   (
                    (pfiledef(def_from)^.filetyp = ft_typed) and
                    (pfiledef(def_to)^.filetyp = ft_typed) and
                    (
                     (pfiledef(def_from)^.typedfiletype.def = pdef(voidtype.def)) or
                     (pfiledef(def_to)^.typedfiletype.def = pdef(voidtype.def))
                    )
                   ) or
                   (
                    (
                     (pfiledef(def_from)^.filetyp = ft_untyped) and
                     (pfiledef(def_to)^.filetyp = ft_typed)
                    ) or
                    (
                     (pfiledef(def_from)^.filetyp = ft_typed) and
                     (pfiledef(def_to)^.filetyp = ft_untyped)
                    )
                   )
                  ) then
                 begin
                    doconv:=tc_equal;
                    b:=1;
                 end
             end;

           else
             begin
               { assignment overwritten ?? }
               if assignment_overloaded(def_from,def_to)<>nil then
                 b:=2;
             end;
         end;
        isconvertable:=b;
      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.38  2001-04-04 21:30:47  florian
    * applied several fixes to get the DD8 Delphi Unit compiled
     e.g. "forward"-interfaces are working now

  Revision 1.37  2001/04/02 21:20:35  peter
    * resulttype rewrite

  Revision 1.36  2001/03/23 00:16:07  florian
    + some stuff to compile FreeCLX added

  Revision 1.35  2001/03/03 12:38:33  jonas
    + support for arraydefs in is_signed (for their rangetype, used in rangechecks)

  Revision 1.34  2001/02/26 19:44:55  peter
    * merged generic m68k updates from fixes branch

  Revision 1.33  2001/02/26 12:47:46  jonas
    * fixed bug in type checking for compatibility of set elements (merged)
    * released fix in options.pas from Carl also for FPC (merged)

  Revision 1.32  2001/02/20 21:44:25  peter
    * tvarrec -> array of const fixed

  Revision 1.31  2001/01/22 11:20:15  jonas
    * fixed web bug 1363 (merged)

  Revision 1.30  2001/01/08 21:43:38  peter
    * string isn't compatible with array of char

  Revision 1.29  2000/12/25 00:07:30  peter
    + new tlinkedlist class (merge of old tstringqueue,tcontainer and
      tlinkedlist objects)

  Revision 1.28  2000/12/22 22:38:12  peter
    * fixed bug #1286

  Revision 1.27  2000/12/20 15:59:40  jonas
    - removed obsolete special case for range checking of cardinal constants
      at compile time

  Revision 1.26  2000/12/11 19:13:54  jonas
    * fixed range checking of cardinal constants
    * fixed range checking of "qword constants" (they don't really exist,
      but values > high(int64) were set to zero if assigned to qword)

  Revision 1.25  2000/12/08 14:06:11  jonas
    * fix for web bug 1245: arrays of char with size >255 are now passed to
      overloaded procedures which expect ansistrings instead of shortstrings
      if possible
    * pointer to array of chars (when using $t+) are now also considered
      pchars

  Revision 1.24  2000/11/20 15:52:47  jonas
    * testrange now always cuts a constant to the size of the destination
      if a rangeerror occurred
    * changed an "and $ffffffff" to "and (int64($fffffff) shl 4 + $f" to
      work around the constant evaluation problem we currently have

  Revision 1.23  2000/11/13 14:42:41  jonas
    * fix in testrange so that 64bit constants are properly truncated when
      assigned to 32bit vars

  Revision 1.22  2000/11/13 11:30:55  florian
    * some bugs with interfaces and NIL fixed

  Revision 1.21  2000/11/12 23:24:12  florian
    * interfaces are basically running

  Revision 1.20  2000/11/11 16:13:31  peter
    * farpointer and normal pointer aren't compatible

  Revision 1.19  2000/11/06 22:30:30  peter
    * more fixes

  Revision 1.18  2000/11/04 14:25:22  florian
    + merged Attila's changes for interfaces, not tested yet

  Revision 1.17  2000/10/31 22:30:13  peter
    * merged asm result patch part 2

  Revision 1.16  2000/10/31 22:02:55  peter
    * symtable splitted, no real code changes

  Revision 1.15  2000/10/21 18:16:12  florian
    * a lot of changes:
       - basic dyn. array support
       - basic C++ support
       - some work for interfaces done
       ....

  Revision 1.14  2000/10/14 10:14:56  peter
    * moehrendorf oct 2000 rewrite

  Revision 1.13  2000/10/01 19:48:26  peter
    * lot of compile updates for cg11

  Revision 1.12  2000/09/30 16:08:46  peter
    * more cg11 updates

  Revision 1.11  2000/09/24 15:06:32  peter
    * use defines.inc

  Revision 1.10  2000/09/18 12:31:15  jonas
    * fixed bug in push_addr_param for arrays (merged from fixes branch)

  Revision 1.9  2000/09/10 20:16:21  peter
    * array of const isn't equal with array of <type> (merged)

  Revision 1.8  2000/08/19 19:51:03  peter
    * fixed bug with comparing constsym strings

  Revision 1.7  2000/08/16 13:06:07  florian
    + support of 64 bit integer constants

  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

}