freepascal.compiler/compiler/types.pas

{
    $Id$
    Copyright (C) 1993-98 by Florian Klaempfl

    This unit provides some help routines for type handling

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************
}
unit types;

  interface

    uses
       cobjects,globals,symtable,aasm;

    type
       tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
                   mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);

    { 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 points to an open string def }
    function is_open_string(p : pdef) : boolean;

    { true if p points to an open array def }
    function is_open_array(p : pdef) : boolean;

    { true, if p points to an array of const def }
    function is_array_constructor(p : pdef) : boolean;

    { true if p 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 char array def }
    function is_chararray(p : pdef) : boolean;

    { true if p is a pchar def }
    function is_pchar(p : 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;

    { 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 we must never copy this parameter }
    const
       never_copy_const_param : boolean = false;

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

    { true, if two parameter lists are equal        }
    { if value_equal_const is true, call by value   }
    { and call by const parameter are assumed as    }
    { equal                                         }
    function equal_paras(def1,def2 : pdefcoll;value_equal_const : boolean) : boolean;

    { true if a function can be assigned to a procvar }
    function proc_to_procvar_equal(def1,def2 : pabstractprocdef) : boolean;

    { if l isn't in the range of def a range check error is generated }
    procedure testrange(def : pdef;l : longint);

    { returns the range of def }
    procedure getrange(def : pdef;var l : longint;var h : longint);

    { generates a VMT for _class }
    procedure genvmt(_class : pobjectdef);

    { generates the message tables for a class }
    function genstrmsgtab(_class : pobjectdef) : plabel;
    function genintmsgtab(_class : pobjectdef) : plabel;

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

  implementation

    uses
       strings,globtype,verbose;


    function equal_paras(def1,def2 : pdefcoll;value_equal_const : boolean) : boolean;
      begin
         while (assigned(def1)) and (assigned(def2)) do
           begin
              if value_equal_const then
                begin
                   if not(is_equal(def1^.data,def2^.data)) or
                     ((def1^.paratyp<>def2^.paratyp) and
                      ((def1^.paratyp=vs_var) or
                       (def1^.paratyp=vs_var)
                      )
                     ) then
                     begin
                        equal_paras:=false;
                        exit;
                     end;
                end
              else
                begin
                   if not(is_equal(def1^.data,def2^.data)) or
                     (def1^.paratyp<>def2^.paratyp) then
                     begin
                        equal_paras:=false;
                        exit;
                     end;
                end;
              def1:=def1^.next;
              def2:=def2^.next;
           end;
         if (def1=nil) and (def2=nil) then
           equal_paras:=true
         else
           equal_paras:=false;
      end;


    { true if a function can be assigned to a procvar }
    function proc_to_procvar_equal(def1,def2 : pabstractprocdef) : boolean;
      begin
         if is_equal(def1^.retdef,def2^.retdef) and
            equal_paras(def1^.para1,def2^.para1,false) and
            ((def1^.options and po_compatibility_options)=
             (def2^.options and po_compatibility_options)) then
           proc_to_procvar_equal:=true
         else
           proc_to_procvar_equal:=false;
      end;


    { returns true, if def uses FPU }
    function is_fpu(def : pdef) : boolean;
      begin
         is_fpu:=(def^.deftype=floatdef) and (pfloatdef(def)^.typ<>f32bit);
      end;


    { true if p is an ordinal }
    function is_ordinal(def : pdef) : boolean;
      var
         dt : tbasetype;
      begin
         case def^.deftype of
          orddef : begin
                     dt:=porddef(def)^.typ;
                     is_ordinal:=dt in [uchar,u8bit,u16bit,u32bit,u64bit,s8bit,s16bit,s32bit,
                       s64bitint,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,s8bit,s16bit,s32bit]);
      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 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]);
                     end;
           enumdef : is_signed:=false;
         else
           is_signed:=false;
         end;
      end;


    { true, if p points to an open array def }
    function is_open_string(p : pdef) : boolean;
      begin
         is_open_string:=(p^.deftype=stringdef) and
                        (pstringdef(p)^.string_typ=st_shortstring) and
                        (pstringdef(p)^.len=0);
      end;


    { true, if p points to an open array def }
    function is_open_array(p : pdef) : boolean;
      begin
         is_open_array:=(p^.deftype=arraydef) and
                        (parraydef(p)^.lowrange=0) and
                        (parraydef(p)^.highrange=-1);
      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 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)^.definition,cchardef);
      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)^.definition,cchardef);
      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 ((pprocvardef(def)^.options and pomethodpointer)=0)) or
                     ((def^.deftype=objectdef) and pobjectdef(def)^.isclass) or
                     ((def^.deftype=setdef) and (psetdef(def)^.settype=smallset)) or
                     ((def^.deftype=floatdef) and (pfloatdef(def)^.typ=f32bit));
      end;

    { true, if def is a 64 bit int type }
    function is_64bitint(def : pdef) : boolean;

      begin
         is_64bitint:=(def^.deftype=orddef) and (porddef(def)^.typ in [u64bit,s64bitint])
      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 ((pprocvardef(def)^.options and pomethodpointer)<>0)) or
           ((def^.deftype=objectdef) and not(pobjectdef(def)^.isclass)) 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);
      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:=never_copy_const_param or
           (def^.deftype in [arraydef,formaldef,recorddef]) or
           ((def^.deftype=objectdef) and not(pobjectdef(def)^.isclass)) or
           ((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_shortstring,st_longstring])) or
           ((def^.deftype=procvardef) and ((pprocvardef(def)^.options and pomethodpointer)<>0)) or
           ((def^.deftype=setdef) and (psetdef(def)^.settype<>smallset));
      end;

    { test if l is in the range of def, outputs error if out of range }
    procedure testrange(def : pdef;l : longint);
      var
         lv,hv: longint;
      begin
         getrange(def,lv,hv);
         if (def^.deftype=orddef) and
            (porddef(def)^.typ=u32bit) then
           begin
              if lv<=hv then
                begin
                   if (l<lv) or (l>hv) then
                     begin
                        if (cs_check_range in aktlocalswitches) then
                          Message(parser_e_range_check_error)
                        else
                          Message(parser_w_range_check_error);
                     end;
                end
              else
                { this happens with the wrap around problem  }
                { if lv is positive and hv is over $7ffffff  }
                { so it seems negative                       }
                begin
                   if ((l>=0) and (l<lv)) or
                      ((l<0) and (l>hv)) then
                     begin
                        if (cs_check_range in aktlocalswitches) then
                          Message(parser_e_range_check_error)
                        else
                          Message(parser_w_range_check_error);
                     end;
                end;
           end
         else if (l<lv) or (l>hv) then
           begin
              if (cs_check_range in aktlocalswitches) then
                Message(parser_e_range_check_error)
              else
                Message(parser_w_range_check_error);
           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;
        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)^.definition^.deftype=floatdef then
                case pfloatdef(parraydef(p)^.definition)^.typ of
                  s32real:
                    mmx_type:=mmxsingle;
                  f16bit:
                    mmx_type:=mmxfixed16
                end
              else
                case porddef(parraydef(p)^.definition)^.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
                (
                 (
                  (parraydef(p)^.definition^.deftype=orddef) and
                  (
                   (
                    (parraydef(p)^.lowrange=0) and
                    (parraydef(p)^.highrange=1) and
                    (porddef(parraydef(p)^.definition)^.typ in [u32bit,s32bit])
                   )
                   or
                   (
                    (parraydef(p)^.lowrange=0) and
                    (parraydef(p)^.highrange=3) and
                    (porddef(parraydef(p)^.definition)^.typ in [u16bit,s16bit])
                   )
                  )
                 )
                 or
                (
                 (
                  (parraydef(p)^.definition^.deftype=floatdef) and
                  (
                   (parraydef(p)^.lowrange=0) and
                   (parraydef(p)^.highrange=3) and
                   (pfloatdef(parraydef(p)^.definition)^.typ=f16bit)
                  ) or
                  (
                   (parraydef(p)^.lowrange=0) and
                   (parraydef(p)^.highrange=1) and
                   (pfloatdef(parraydef(p)^.definition)^.typ=s32real)
                  )
                 )
                )
              );
           end
         else
           begin
              is_mmx_able_array:=(p^.deftype=arraydef) and
                (
                 (
                  (parraydef(p)^.definition^.deftype=orddef) and
                  (
                   (
                    (parraydef(p)^.lowrange=0) and
                    (parraydef(p)^.highrange=1) and
                    (porddef(parraydef(p)^.definition)^.typ in [u32bit,s32bit])
                   )
                   or
                   (
                    (parraydef(p)^.lowrange=0) and
                    (parraydef(p)^.highrange=3) and
                    (porddef(parraydef(p)^.definition)^.typ in [u16bit,s16bit])
                   )
                   or
                   (
                    (parraydef(p)^.lowrange=0) and
                    (parraydef(p)^.highrange=7) and
                    (porddef(parraydef(p)^.definition)^.typ in [u8bit,s8bit])
                   )
                  )
                 )
                 or
                 (
                  (parraydef(p)^.definition^.deftype=floatdef) and
                  (
                   (
                    (parraydef(p)^.lowrange=0) and
                    (parraydef(p)^.highrange=3) and
                    (pfloatdef(parraydef(p)^.definition)^.typ=f32bit)
                   )
                   or
                   (
                    (parraydef(p)^.lowrange=0) and
                    (parraydef(p)^.highrange=1) and
                    (pfloatdef(parraydef(p)^.definition)^.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;
         hp1,hp2 : pdefcoll;

      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
         { here a problem detected in tabsolutesym }
         { the types can be forward type !!        }
             begin
                if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
                  b:=(def1^.sym=def2^.sym)
                else
                  b:=ppointerdef(def1)^.definition=ppointerdef(def2)^.definition;
             end
         else
         { ordinals are equal only when the ordinal type is equal }
           if (def1^.deftype=orddef) and (def2^.deftype=orddef) then
             begin
                case porddef(def1)^.typ of
                u8bit,u16bit,u32bit,
                s8bit,s16bit,s32bit:
                  b:=((porddef(def1)^.typ=porddef(def2)^.typ) and
                   (porddef(def1)^.low=porddef(def2)^.low) and
                   (porddef(def1)^.high=porddef(def2)^.high));
                uvoid,uchar,
                bool8bit,bool16bit,bool32bit:
                  b:=(porddef(def1)^.typ=porddef(def2)^.typ);
                end;
             end
         else
           if (def1^.deftype=floatdef) and (def2^.deftype=floatdef) then
             b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ
         else
            { strings with the same length are equal }
            if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
               (pstringdef(def1)^.string_typ=pstringdef(def2)^.string_typ) then
               begin
                  b:=not(is_shortstring(def1)) or
                    (pstringdef(def1)^.len=pstringdef(def2)^.len);
               end
    { STRING[N] ist equivalent zu ARRAY[0..N] OF CHAR (N<256) }
{
         else if ((def1^.deftype=stringdef) and (def2^.deftype=arraydef)) and
              (parraydef(def2)^.definition^.deftype=orddef) and
              (porddef(parraydef(def1)^.definition)^.typ=uchar) and
              (parraydef(def2)^.lowrange=0) and
              (parraydef(def2)^.highrange=pstringdef(def1)^.len) then
              b:=true }
          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)^.filetype=pfiledef(def2)^.filetype) and
                 ((
                 ((pfiledef(def1)^.typed_as=nil) and
                  (pfiledef(def2)^.typed_as=nil)) or
                 (
                  (pfiledef(def1)^.typed_as<>nil) and
                  (pfiledef(def2)^.typed_as<>nil) and
                  is_equal(pfiledef(def1)^.typed_as,pfiledef(def2)^.typed_as)
                 ) or
                 ( (pfiledef(def1)^.typed_as=pdef(voiddef)) or
                   (pfiledef(def2)^.typed_as=pdef(voiddef))
                 )))
          { sets with the same element type are equal }
          else
            if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
              begin
                 if assigned(psetdef(def1)^.setof) and
                    assigned(psetdef(def2)^.setof) then
                   b:=(psetdef(def1)^.setof^.deftype=psetdef(def2)^.setof^.deftype)
                 else
                   b:=true;
              end
          else
            if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
              begin
                 { poassembler isn't important for compatibility }
                 { if a method is assigned to a methodpointer    }
                 { is checked before                             }
                 b:=((pprocvardef(def1)^.options and not(poassembler or pomethodpointer or
                       povirtualmethod or pooverridingmethod))=
                     (pprocvardef(def2)^.options and not(poassembler or pomethodpointer or
                       povirtualmethod or pooverridingmethod))
                    ) and
                   is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
                 { now evalute the parameters }
                 if b then
                   begin
                      hp1:=pprocvardef(def1)^.para1;
                      hp2:=pprocvardef(def1)^.para1;
                      while assigned(hp1) and assigned(hp2) do
                        begin
                           if not(is_equal(hp1^.data,hp2^.data)) or
                             not(hp1^.paratyp=hp2^.paratyp) then
                             begin
                                b:=false;
                                break;
                             end;
                           hp1:=hp1^.next;
                           hp2:=hp2^.next;
                        end;
                      b:=(hp1=nil) and (hp2=nil);
                   end;
              end
          else
            if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) and
              (is_open_array(def1) or is_open_array(def2)) then
              begin
                if parraydef(def1)^.IsArrayOfConst or parraydef(def2)^.IsArrayOfConst then
                 b:=true
                else
                 b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
              end
          else
            if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
              begin
                 { similar to pointerdef: }
                 if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
                   b:=(def1^.sym=def2^.sym)
                 else
                   b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
              end;
         is_equal:=b;
      end;


    function is_subequal(def1, def2: pdef): boolean;
    Begin
      if assigned(def1) and assigned(def2) then
      Begin
        is_subequal := FALSE;
        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 : is_subequal:=(porddef(def2)^.typ in [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.                                      }
            if (def1^.deftype = enumdef) and (def2^.deftype =enumdef) then
              Begin
                if penumdef(def1)^.first = penumdef(def2)^.first then
                   is_subequal := TRUE;
              end;
          end;
      end; { endif assigned ... }
    end;

    type
       pprocdeftree = ^tprocdeftree;

       tprocdeftree = record
          p : pprocdef;
          nl : plabel;
          l,r : pprocdeftree;
       end;

    var
       root : pprocdeftree;
       count : longint;

    procedure insertstr(p : pprocdeftree;var at : pprocdeftree);

      var
         i : longint;

      begin
         if at=nil then
           begin
              at:=p;
              inc(count);
           end
         else
           begin
              i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
              if i<0 then
                insertstr(p,at^.l)
              else if i>0 then
                insertstr(p,at^.r)
              else
                Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str));
           end;
      end;

    procedure disposeprocdeftree(p : pprocdeftree);

      begin
         if assigned(p^.l) then
           disposeprocdeftree(p^.l);
         if assigned(p^.r) then
           disposeprocdeftree(p^.r);
         dispose(p);
      end;

    procedure insertmsgstr(p : psym);{$ifndef FPC}far;{$endif FPC}

      var
         hp : pprocdef;
         pt : pprocdeftree;

      begin
         if p^.typ=procsym then
           begin
              hp:=pprocsym(p)^.definition;
              while assigned(hp) do
                begin
                   if (hp^.options and pomsgstr)<>0 then
                     begin
                        new(pt);
                        pt^.p:=hp;
                        pt^.l:=nil;
                        pt^.r:=nil;
                        insertstr(pt,root);
                     end;
                   hp:=hp^.nextoverloaded;
                end;
           end;
      end;

    procedure writenames(p : pprocdeftree);

      begin
         getlabel(p^.nl);
         if assigned(p^.l) then
           writenames(p^.l);
         datasegment^.concat(new(pai_label,init(p^.nl)));
         datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str))));
         datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str)));
         if assigned(p^.r) then
           writenames(p^.r);
      end;

    procedure writestrentry(p : pprocdeftree);

      begin
         if assigned(p^.l) then
           writestrentry(p^.l);

         { write name label }
         datasegment^.concat(new(pai_const_symbol,init(lab2str(p^.nl))));
         datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
         maybe_concat_external(p^.p^.owner,p^.p^.mangledname);

         if assigned(p^.r) then
           writestrentry(p^.r);
      end;

    function genstrmsgtab(_class : pobjectdef) : plabel;


      var
         r : plabel;

      begin
         root:=nil;
         count:=0;
         { insert all message handlers into a tree, sorted by name }
         _class^.publicsyms^.foreach(insertmsgstr);

         { write all names }
         if assigned(root) then
           writenames(root);

         { now start writing of the message string table }
         getlabel(r);
         datasegment^.concat(new(pai_label,init(r)));
         genstrmsgtab:=r;
         datasegment^.concat(new(pai_const,init_32bit(count)));
         if assigned(root) then
           begin
              writestrentry(root);
              disposeprocdeftree(root);
           end;
      end;

    procedure insertint(p : pprocdeftree;var at : pprocdeftree);

      var
         i : longint;

      begin
         if at=nil then
           begin
              at:=p;
              inc(count);
           end
         else
           begin
              i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
              if p^.p^.messageinf.i<at^.p^.messageinf.i then
                insertstr(p,at^.l)
              else if p^.p^.messageinf.i>at^.p^.messageinf.i then
                insertstr(p,at^.r)
              else
                Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i));
           end;
      end;

    procedure writeintentry(p : pprocdeftree);

      begin
         if assigned(p^.l) then
           writeintentry(p^.l);

         { write name label }
         datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
         datasegment^.concat(new(pai_const_symbol,init(p^.p^.mangledname)));
         maybe_concat_external(p^.p^.owner,p^.p^.mangledname);

         if assigned(p^.r) then
           writeintentry(p^.r);
      end;

    procedure insertmsgint(p : psym);{$ifndef FPC}far;{$endif FPC}

      var
         hp : pprocdef;
         pt : pprocdeftree;

      begin
         if p^.typ=procsym then
           begin
              hp:=pprocsym(p)^.definition;
              while assigned(hp) do
                begin
                   if (hp^.options and pomsgint)<>0 then
                     begin
                        new(pt);
                        pt^.p:=hp;
                        pt^.l:=nil;
                        pt^.r:=nil;
                        insertint(pt,root);
                     end;
                   hp:=hp^.nextoverloaded;
                end;
           end;
      end;

    function genintmsgtab(_class : pobjectdef) : plabel;


      var
         r : plabel;

      begin
         root:=nil;
         count:=0;
         { insert all message handlers into a tree, sorted by name }
         _class^.publicsyms^.foreach(insertmsgint);

         { now start writing of the message string table }
         getlabel(r);
         datasegment^.concat(new(pai_label,init(r)));
         genintmsgtab:=r;
         datasegment^.concat(new(pai_const,init_32bit(count)));
         if assigned(root) then
           begin
              writeintentry(root);
              disposeprocdeftree(root);
           end;
      end;

    type
       pprocdefcoll = ^tprocdefcoll;

       tprocdefcoll = record
          next : pprocdefcoll;
          data : pprocdef;
       end;

       psymcoll = ^tsymcoll;

       tsymcoll = record
          next : psymcoll;
          name : pstring;
          data : pprocdefcoll;
       end;

    var
       wurzel : psymcoll;
       nextvirtnumber : longint;
       _c : pobjectdef;
       has_constructor,has_virtual_method : boolean;

    procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif FPC}

      var
         procdefcoll : pprocdefcoll;
         hp : pprocdef;
         symcoll : psymcoll;
         _name : string;
         stored : boolean;

      { creates a new entry in the procsym list }
      procedure newentry;

        begin
           { if not, generate a new symbol item }
           new(symcoll);
           symcoll^.name:=stringdup(sym^.name);
           symcoll^.next:=wurzel;
           symcoll^.data:=nil;
           wurzel:=symcoll;
           hp:=pprocsym(sym)^.definition;

           { inserts all definitions }
           while assigned(hp) do
             begin
                new(procdefcoll);
                procdefcoll^.data:=hp;
                procdefcoll^.next:=symcoll^.data;
                symcoll^.data:=procdefcoll;

                { if it's a virtual method }
                if (hp^.options and povirtualmethod)<>0 then
                  begin
                     { then it gets a number ... }
                     hp^.extnumber:=nextvirtnumber;
                     { and we inc the number }
                     inc(nextvirtnumber);
                     has_virtual_method:=true;
                  end;

                if (hp^.options and poconstructor)<>0 then
                  has_constructor:=true;

                { check, if a method should be overridden }
                if (hp^.options and pooverridingmethod)<>0 then
                  Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
                { next overloaded method }
                hp:=hp^.nextoverloaded;
             end;
        end;

      begin
         { put only sub routines into the VMT }
         if sym^.typ=procsym then
           begin
              _name:=sym^.name;
              symcoll:=wurzel;
              while assigned(symcoll) do
                begin
                   { does the symbol already exist in the list ? }
                   if _name=symcoll^.name^ then
                     begin
                        { walk through all defs of the symbol }
                        hp:=pprocsym(sym)^.definition;
                        while assigned(hp) do
                          begin
                             { compare with all stored definitions }
                             procdefcoll:=symcoll^.data;
                             stored:=false;
                             while assigned(procdefcoll) do
                               begin
                                  { compare parameters }
                                  if equal_paras(procdefcoll^.data^.para1,hp^.para1,false) and
                                     (
                                       ((procdefcoll^.data^.options and povirtualmethod)<>0) or
                                       ((hp^.options and povirtualmethod)<>0)
                                     ) then
                                    begin
                                       { wenn sie gleich sind }
                                       { und eine davon virtual deklariert ist }
                                       { Fehler falls nur eine VIRTUAL }
                                       if (procdefcoll^.data^.options and povirtualmethod)<>
                                          (hp^.options and povirtualmethod) then
                                         begin
                                            { in classes, we hide the old method }
                                            if _c^.isclass then
                                              begin
                                                 { warn only if it is the first time,
                                                   we hide the method }
                                                 if _c=hp^._class then
                                                   Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
                                                 newentry;
                                                 exit;
                                              end
                                            else
                                              if _c=hp^._class then
                                                begin
                                                   if (procdefcoll^.data^.options and povirtualmethod)<>0 then
                                                     Message1(parser_w_overloaded_are_not_both_virtual,_c^.name^+'.'+_name)
                                                   else
                                                     Message1(parser_w_overloaded_are_not_both_non_virtual,
                                                       _c^.name^+'.'+_name);
                                                   newentry;
                                                   exit;
                                                end;
                                         end;

                                       { check, if the overridden directive is set }
                                       { (povirtualmethod is set! }

                                       { class ? }
                                       if _c^.isclass and
                                         ((hp^.options and pooverridingmethod)=0) then
                                         begin
                                            { warn only if it is the first time,
                                              we hide the method }
                                            if _c=hp^._class then
                                              Message1(parser_w_should_use_override,_c^.name^+'.'+_name);
                                            newentry;
                                            exit;
                                         end;

                                       { error, if the return types aren't equal }
                                       if not(is_equal(procdefcoll^.data^.retdef,hp^.retdef)) and
                                         not((procdefcoll^.data^.retdef^.deftype=objectdef) and
                                           (hp^.retdef^.deftype=objectdef) and
                                           (pobjectdef(procdefcoll^.data^.retdef)^.isclass) and
                                           (pobjectdef(hp^.retdef)^.isclass) and
                                           (pobjectdef(hp^.retdef)^.isrelated(pobjectdef(procdefcoll^.data^.retdef)))) then
                                         Message1(parser_e_overloaded_methodes_not_same_ret,_c^.name^+'.'+_name);


                                       { the flags have to match      }
                                       { except abstract and override }
                                       if (procdefcoll^.data^.options and not(poabstractmethod or pooverridingmethod))<>
                                         (hp^.options and not(poabstractmethod or pooverridingmethod)) then
                                            Message1(parser_e_header_dont_match_forward,_c^.name^+'.'+_name);

                                       { now set the number }
                                       hp^.extnumber:=procdefcoll^.data^.extnumber;
                                       { and exchange }
                                       procdefcoll^.data:=hp;
                                       stored:=true;
                                    end;
                                  procdefcoll:=procdefcoll^.next;
                               end;
                             { if it isn't saved in the list }
                             { we create a new entry         }
                             if not(stored) then
                               begin
                                  new(procdefcoll);
                                  procdefcoll^.data:=hp;
                                  procdefcoll^.next:=symcoll^.data;
                                  symcoll^.data:=procdefcoll;
                                  { if the method is virtual ... }
                                  if (hp^.options and povirtualmethod)<>0 then
                                    begin
                                       { ... it will get a number }
                                       hp^.extnumber:=nextvirtnumber;
                                       inc(nextvirtnumber);
                                    end;
                                  { check, if a method should be overridden }
                                  if (hp^.options and pooverridingmethod)<>0 then
                                   Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
                               end;
                             hp:=hp^.nextoverloaded;
                          end;
                        exit;
                     end;
                   symcoll:=symcoll^.next;
                end;
             newentry;
           end;
      end;

    procedure genvmt(_class : pobjectdef);

      procedure do_genvmt(p : pobjectdef);

        begin
           { start with the base class }
           if assigned(p^.childof) then
             do_genvmt(p^.childof);

           { walk through all public syms }
           _c:=_class;
{$ifdef tp}
           p^.publicsyms^.foreach(eachsym);
{$else}
           p^.publicsyms^.foreach(@eachsym);
{$endif}
        end;

      var
         symcoll : psymcoll;
         procdefcoll : pprocdefcoll;
         i : longint;

      begin
         wurzel:=nil;
         nextvirtnumber:=0;

         has_constructor:=false;
         has_virtual_method:=false;

         { generates a tree of all used methods }
         do_genvmt(_class);

         if has_virtual_method and not(has_constructor) then
            Message1(parser_w_virtual_without_constructor,_class^.name^);


         { generates the VMT }

         { walk trough all numbers for virtual methods and search }
         { the method                                             }
         for i:=0 to nextvirtnumber-1 do
           begin
              symcoll:=wurzel;

              { walk trough all symbols }
              while assigned(symcoll) do
                begin

                   { walk trough all methods }
                   procdefcoll:=symcoll^.data;
                   while assigned(procdefcoll) do
                     begin
                        { writes the addresses to the VMT }
                        { but only this which are declared as virtual }
                        if procdefcoll^.data^.extnumber=i then
                          begin
                             if (procdefcoll^.data^.options and povirtualmethod)<>0 then
                               begin
                                  { if a method is abstract, then is also the }
                                  { class abstract and it's not allow to      }
                                  { generates an instance                     }
                                  if (procdefcoll^.data^.options and poabstractmethod)<>0 then
                                    begin
                                       _class^.options:=_class^.options or oo_is_abstract;
                                       datasegment^.concat(new(pai_const_symbol,
                                         init('FPC_ABSTRACTERROR')));
                                    end
                                  else
                                    begin
                                      datasegment^.concat(new(pai_const_symbol,
                                        init(procdefcoll^.data^.mangledname)));
                                      maybe_concat_external(procdefcoll^.data^.owner,
                                        procdefcoll^.data^.mangledname);
                                    end;
                               end;
                          end;
                        procdefcoll:=procdefcoll^.next;
                     end;
                   symcoll:=symcoll^.next;
                end;
           end;
         { disposes the above generated tree }
         symcoll:=wurzel;
         while assigned(symcoll) do
           begin
              wurzel:=symcoll^.next;
              stringdispose(symcoll^.name);
              procdefcoll:=symcoll^.data;
              while assigned(procdefcoll) do
                begin
                   symcoll^.data:=procdefcoll^.next;
                   dispose(procdefcoll);
                   procdefcoll:=symcoll^.data;
                end;
              dispose(symcoll);
              symcoll:=wurzel;
           end;
      end;

end.
{
  $Log$
  Revision 1.54  1999-03-02 22:52:20  peter
    * fixed char array, which can start with all possible values

  Revision 1.53  1999/02/25 21:02:57  peter
    * ag386bin updates
    + coff writer

  Revision 1.52  1999/02/24 09:51:44  florian
    * wrong warning fixed, if a non-virtual method was hidden by a virtual
      method (repoerted by Matthias Koeppe)

  Revision 1.51  1999/02/22 23:33:31  florian
    + message directive for integers added

  Revision 1.50  1999/02/22 20:13:42  florian
    + first implementation of message keyword

  Revision 1.49  1999/02/16 00:45:30  peter
    * fixed crashes by forgotten strpnew() for init_symbol

  Revision 1.48  1999/02/09 23:03:08  florian
    * check for duplicate field names in inherited classes/objects
    * bug with self from the mailing list solved (the problem
      was that classes were sometimes pushed wrong)

  Revision 1.47  1999/01/27 00:14:01  florian
    * "procedure of object"-stuff fixed

  Revision 1.46  1999/01/21 22:10:54  peter
    * fixed array of const
    * generic platform independent high() support

  Revision 1.45  1999/01/20 12:34:22  peter
    * fixed typed file read/write

  Revision 1.44  1999/01/15 11:33:03  pierre
   * bug in mmx code removed

  Revision 1.43  1998/12/30 13:41:20  peter
    * released valuepara

  Revision 1.42  1998/12/11 00:04:03  peter
    + globtype,tokens,version unit splitted from globals

  Revision 1.41  1998/12/10 09:47:33  florian
    + basic operations with int64/qord (compiler with -dint64)
    + rtti of enumerations extended: names are now written

  Revision 1.40  1998/12/04 10:18:14  florian
    * some stuff for procedures of object added
    * bug with overridden virtual constructors fixed (reported by Italo Gomes)

  Revision 1.39  1998/11/27 14:50:55  peter
    + open strings, $P switch support

  Revision 1.38  1998/11/18 15:44:24  peter
    * VALUEPARA for tp7 compatible value parameters

  Revision 1.37  1998/11/13 10:15:50  peter
    * fixed ptr() with constants

  Revision 1.36  1998/11/10 10:09:21  peter
    * va_list -> array of const

  Revision 1.35  1998/10/19 08:55:13  pierre
    * wrong stabs info corrected once again !!
    + variable vmt offset with vmt field only if required
      implemented now !!!

  Revision 1.34  1998/10/12 09:50:06  florian
    + support of <procedure var type>:=<pointer> in delphi mode added

  Revision 1.33  1998/10/06 20:43:30  peter
    * fixed set of bugs. like set of false..true set of #1..#255 and
      set of #1..true which was allowed

  Revision 1.32  1998/10/05 21:33:35  peter
    * fixed 161,165,166,167,168

  Revision 1.31  1998/09/23 09:58:56  peter
    * first working array of const things

  Revision 1.30  1998/09/22 15:40:58  peter
    * some extra ifdef GDB

  Revision 1.29  1998/09/16 12:37:31  michael
  Added FPC_ prefix to abstracterror

  Revision 1.28  1998/09/09 16:44:23  florian
    * I hope, the case bug is fixed now

  Revision 1.27  1998/09/07 17:37:07  florian
    * first fixes for published properties

  Revision 1.26  1998/09/04 12:24:31  florian
    * bug0159 fixed

  Revision 1.25  1998/09/04 09:06:36  florian
   * bug0132 fixed

  Revision 1.24  1998/09/04 08:36:49  peter
    * fixed boolean:=integer which is not explicit

  Revision 1.23  1998/09/01 17:39:55  peter
    + internal constant functions

  Revision 1.22  1998/09/01 12:53:28  peter
    + aktpackenum

  Revision 1.21  1998/08/19 00:42:45  peter
    + subrange types for enums
    + checking for bounds type with ranges

  Revision 1.20  1998/08/18 14:17:14  pierre
    * bug about assigning the return value of a function to
      a procvar fixed : warning
      assigning a proc to a procvar need @ in FPC mode !!
    * missing file/line info restored

  Revision 1.19  1998/08/18 09:24:48  pierre
    * small warning position bug fixed
    * support_mmx switches splitting was missing
    * rhide error and warning output corrected

  Revision 1.18  1998/08/14 18:18:49  peter
    + dynamic set contruction
    * smallsets are now working (always longint size)

  Revision 1.17  1998/08/05 16:00:17  florian
    * some fixes for ansi strings

  Revision 1.16  1998/07/20 23:35:50  michael
  Const ansistrings are not copied.

  Revision 1.15  1998/07/18 22:54:32  florian
    * some ansi/wide/longstring support fixed:
       o parameter passing
       o returning as result from functions

  Revision 1.14  1998/06/12 14:50:50  peter
    * removed the tree dependency to types.pas
    * long_fil.pas support (not fully tested yet)

  Revision 1.13  1998/06/03 22:49:07  peter
    + wordbool,longbool
    * rename bis,von -> high,low
    * moved some systemunit loading/creating to psystem.pas

  Revision 1.12  1998/05/12 10:47:00  peter
    * moved printstatus to verb_def
    + V_Normal which is between V_Error and V_Warning and doesn't have a
      prefix like error: warning: and is included in V_Default
    * fixed some messages
    * first time parameter scan is only for -v and -T
    - removed old style messages

  Revision 1.11  1998/05/01 16:38:46  florian
    * handling of private and protected fixed
    + change_keywords_to_tp implemented to remove
      keywords which aren't supported by tp
    * break and continue are now symbols of the system unit
    + widestring, longstring and ansistring type released

  Revision 1.10  1998/04/29 10:34:08  pierre
    + added some code for ansistring (not complete nor working yet)
    * corrected operator overloading
    * corrected nasm output
    + started inline procedures
    + added starstarn : use ** for exponentiation (^ gave problems)
    + started UseTokenInfo cond to get accurate positions

  Revision 1.9  1998/04/21 10:16:49  peter
    * patches from strasbourg
    * objects is not used anymore in the fpc compiled version

  Revision 1.8  1998/04/12 22:39:44  florian
    * problem with read access to properties solved
    * correct handling of hidding methods via virtual (COM)
    * correct result type of constructor calls (COM), the resulttype
      depends now on the type of the class reference

  Revision 1.7  1998/04/10 21:36:56  florian
    + some stuff to support method pointers (procedure of object) added
      (declaration, parameter handling)

  Revision 1.6  1998/04/10 15:39:49  florian
    * more fixes to get classes.pas compiled

  Revision 1.5  1998/04/09 23:02:16  florian
    * small problems solved to get remake3 work

  Revision 1.4  1998/04/08 16:58:09  pierre
    * several bugfixes
      ADD ADC and AND are also sign extended
      nasm output OK (program still crashes at end
      and creates wrong assembler files !!)
      procsym types sym in tdef removed !!

  Revision 1.3  1998/04/08 11:34:22  peter
    * nasm works (linux only tested)
}