+ merged Attila's changes for interfaces, not tested yet

compiler/cobjects.pas

@@ -281,7 +281,7 @@ interface
         procedure clear;
         procedure foreach(proc2call : Tnamedindexcallback);
         procedure deleteindex(p:Pnamedindexobject);
-        procedure delete(p:Pnamedindexobject);
+        procedure delete(var p:Pnamedindexobject);
         procedure insert(p:Pnamedindexobject);
         function  search(nr:longint):Pnamedindexobject;
       private
@@ -1790,7 +1790,7 @@ end;
       end;
 
 
-    procedure tindexarray.delete(p:Pnamedindexobject);
+    procedure tindexarray.delete(var p:Pnamedindexobject);
       begin
         deleteindex(p);
         dispose(p,done);
@@ -1811,6 +1811,9 @@ end;
          count:=p^.indexnr;
         if count>size then
          grow(((count div growsize)+1)*growsize);
+        {$ifdef Delphi}
+        Assert(not assigned(data^[p^.indexnr]) or (p=data^[p^.indexnr]));
+        {$endif}
         data^[p^.indexnr]:=p;
         { update linked list backward }
         i:=p^.indexnr;
@@ -1843,7 +1846,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.17  2000-11-03 19:41:06  jonas
+  Revision 1.18  2000-11-04 14:25:19  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.17  2000/11/03 19:41:06  jonas
     * fixed bug in tdynamicarray.align (merged)
 
   Revision 1.16  2000/10/31 22:02:46  peter

compiler/errore.msg

@@ -295,6 +295,7 @@ scan_w_macro_support_turned_off=02057_W_Macro support has been turned off
 % A macro declaration has been found, but macro support is currently off,
 % so the declaration will be ignored. To turn macro support on compile with
 % -Sm on the commandline or add {$MACRO ON} in the source
+scan_e_invalid_interface_type=02058_E_Illegal interface type specified. Valids are COM, CORBA or DEFAULT.
 % \end{description}
 #
 # Parser
@@ -624,8 +625,8 @@ parser_e_only_virtual_methods_abstract=03091_E_Only virtual methods can be abstr
 % virtual.
 parser_f_unsupported_feature=03092_F_Use of unsupported feature!
 % You're trying to force the compiler into doing something it cannot do yet.
-parser_e_mix_of_classes_and_objects=03093_E_The mix of CLASSES and OBJECTS isn't allowed
-% You cannot derive \var{objects} and \var{classes} intertwined . That is,
+parser_e_mix_of_classes_and_objects=03093_E_The mix of different kind of objects (class, object, interface, raw interface etc) isn't allowed
+% You cannot derive \var{objects}, \var{classes}, \var{cppclasses} and \var{interfaces} intertwined . E.g.
 % a class cannot have an object as parent and vice versa.
 parser_w_unknown_proc_directive_ignored=03094_W_Unknown procedure directive had to be ignored: "$1"
 % The procedure direcive you secified is unknown. Recognised procedure
@@ -875,6 +876,20 @@ parser_e_no_export_with_index_for_target=03163_E_Can't export with index under $
 parser_e_no_export_of_variables_for_target=03164_E_Exporting of variables is not supported under $1
 % Exporting of variables is not support on all targets. The only platform
 % currently supporting export of variables is Win32.
+parser_e_improper_guid_syntax=03165_E_Improper GUID syntax
+parser_f_interface_cant_have_variables=03166_F_An interface can't have variables
+parser_f_interface_cant_have_constr_or_destr=03167_F_An interface can't have constructor or destructor
+parser_w_interface_mapping_notfound=03168_W_Procedure named $1 not found that is suitable for implementing the $2.$3
+parser_e_interface_id_expected=03169_E_interface identifier expected
+% This happens when the compiler scans a \var{class} declaration that contains
+% \var{interface} function name mapping code like this:
+% \begin{verbatim}
+% type
+%   TMyObject = class(TObject, IDispatch)
+%     function IUnknown.QueryInterface=MyQueryInterface;
+%     ....
+% \end{verbatim}
+% and the \var{interface} before the dot not listed in the inheritance list.
 % \end{description}
 #
 # Type Checking
@@ -1016,6 +1031,7 @@ type_e_no_assign_to_const=04032_E_Can't assign values to const variable
 type_e_array_required=04033_E_Array type required
 % If you are accessing a variable using an index '[<x>]' then
 % the type must be an array. In FPC mode also a pointer is allowed.
+type_e_interface_type_expected=04034_E_interface type expected, but got "$1"
 % \end{description}
 #
 # Symtable
@@ -1914,4 +1930,4 @@ option_help_pages=11025_[
 
 #
 # The End...
-#
+#

compiler/globals.pas

@@ -148,6 +148,7 @@ interface
        initoptprocessor,
        initspecificoptprocessor : tprocessors;
        initasmmode        : tasmmode;
+       initinterfacetype  : tinterfacetypes;
      { current state values }
        aktglobalswitches : tglobalswitches;
        aktmoduleswitches : tmoduleswitches;
@@ -165,6 +166,7 @@ interface
        aktoptprocessor,
        aktspecificoptprocessor : tprocessors;
        aktasmmode        : tasmmode;
+       aktinterfacetype  : tinterfacetypes;
 
      { Memory sizes }
        heapsize,
@@ -250,6 +252,9 @@ interface
     procedure InitGlobals;
     procedure DoneGlobals;
 
+    function  string2guid(const s: string; var GUID: TGUID): boolean;
+    function  guid2string(const GUID: TGUID): string;
+
 
 implementation
 
@@ -1043,6 +1048,84 @@ implementation
         SetCompileMode:=b;
       end;
 
+    { '('D1:'00000000-'D2:'0000-'D3:'0000-'D4:'0000-000000000000)' }
+    function string2guid(const s: string; var GUID: TGUID): boolean;
+        function ishexstr(const hs: string): boolean;
+          var
+            i: integer;
+          begin
+            ishexstr:=false;
+            for i:=1 to Length(hs) do begin
+              if not (hs[i] in ['0'..'9','A'..'F','a'..'f']) then
+                exit;
+            end;
+            ishexstr:=true;
+          end;
+        function hexstr2longint(const hexs: string): longint;
+          var
+            i: integer;
+            rl: longint;
+          begin
+            rl:=0;
+            for i:=1 to length(hexs) do begin
+              rl:=rl shl 4;
+              case hexs[i] of
+                '0'..'9' : inc(rl,ord(hexs[i])-ord('0'));
+                'A'..'F' : inc(rl,ord(hexs[i])-ord('A')+10);
+                'a'..'f' : inc(rl,ord(hexs[i])-ord('a')+10);
+              end
+            end;
+            hexstr2longint:=rl;
+          end;
+      var
+        i: integer;
+      begin
+        if (Length(s)=38) and (s[1]='{') and (s[38]='}') and
+           (s[10]='-') and (s[15]='-') and (s[20]='-') and (s[25]='-') and
+           ishexstr(copy(s,2,8)) and ishexstr(copy(s,11,4)) and
+           ishexstr(copy(s,16,4)) and ishexstr(copy(s,21,4)) and
+           ishexstr(copy(s,26,12)) then begin
+          GUID.D1:=hexstr2longint(copy(s,2,8));
+          GUID.D2:=hexstr2longint(copy(s,11,4));
+          GUID.D3:=hexstr2longint(copy(s,16,4));
+          for i:=0 to 1 do
+            GUID.D4[i]:=hexstr2longint(copy(s,21+i*2,2));
+          for i:=2 to 7 do
+            GUID.D4[i]:=hexstr2longint(copy(s,22+i*2,2));
+          string2guid:=true;
+        end
+        else
+          string2guid:=false;
+      end;
+
+    function guid2string(const GUID: TGUID): string;
+        function long2hex(l, len: longint): string;
+          const
+            hextbl: array[0..15] of char = '0123456789ABCDEF';
+          var
+            rs: string;
+            i: integer;
+          begin
+            rs[0]:=chr(len);
+            for i:=len downto 1 do begin
+              rs[i]:=hextbl[l and $F];
+              l:=l shr 4;
+            end;
+            long2hex:=rs;
+          end;
+      begin
+        guid2string:=
+          '{'+long2hex(GUID.D1,8)+
+          '-'+long2hex(GUID.D2,4)+
+          '-'+long2hex(GUID.D3,4)+
+          '-'+long2hex(GUID.D4[0],2)+long2hex(GUID.D4[1],2)+
+          '-'+long2hex(GUID.D4[2],2)+long2hex(GUID.D4[3],2)+
+              long2hex(GUID.D4[4],2)+long2hex(GUID.D4[5],2)+
+              long2hex(GUID.D4[6],2)+long2hex(GUID.D4[7],2)+
+          '}';
+      end;
+
+
 
 {****************************************************************************
                                     Init
@@ -1160,6 +1243,7 @@ implementation
         initasmmode:=asmmode_m68k_mot;
   {$endif m68k}
 {$endif i386}
+        initinterfacetype:=it_interfacecom;
         initdefines.init;
 
       { memory sizes, will be overriden by parameter or default for target
@@ -1186,7 +1270,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.17  2000-10-31 22:02:46  peter
+  Revision 1.18  2000-11-04 14:25:19  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.17  2000/10/31 22:02:46  peter
     * symtable splitted, no real code changes
 
   Revision 1.16  2000/10/04 14:51:08  pierre

compiler/globtype.pas

@@ -143,6 +143,12 @@ interface
          at_gui,at_cui
        );
 
+       { interface types }
+       tinterfacetypes = (
+         it_interfacecom,
+         it_interfacecorba
+       );
+
        { currently parsed block type }
        tblock_type = (bt_none,
          bt_general,bt_type,bt_const,bt_except
@@ -179,6 +185,18 @@ interface
                     (values:longint);
        end;
 
+{$ifndef Delphi}
+  {$ifndef xFPC}
+    type
+      tguid = packed record
+        D1: LongWord;
+        D2: Word;
+        D3: Word;
+        D4: array[0..7] of Byte;
+      end;
+  {$endif}
+{$endif}
+
     const
        { link options }
        link_none    = $0;
@@ -192,7 +210,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.7  2000-09-24 15:06:16  peter
+  Revision 1.8  2000-11-04 14:25:19  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.7  2000/09/24 15:06:16  peter
     * use defines.inc
 
   Revision 1.6  2000/09/21 11:30:49  jonas
@@ -211,4 +232,4 @@ end.
   Revision 1.2  2000/07/13 11:32:41  michael
   + removed logs
 
-}
+}

compiler/hcgdata.pas

@@ -44,11 +44,8 @@ interface
     function gendmt(_class : pobjectdef) : pasmlabel;
 {$endif WITHDMT}
 
-{ define INTERFACE_SUPPORT}
-
-{$ifdef INTERFACE_SUPPORT}
     function genintftable(_class: pobjectdef): pasmlabel;
-{$endif INTERFACE_SUPPORT}
+    procedure writeinterfaceids(c : pobjectdef);
 
 implementation
 
@@ -60,13 +57,11 @@ implementation
 {$endif}
        cutils,cobjects,
        globtype,globals,verbose,
-       symconst,symtype,symsym,types,
+       symtable,symconst,symtype,symsym,types,
        hcodegen, systems,fmodule
-{$ifdef INTERFACE_SUPPORT}
 {$ifdef i386}
-       ,cg386ic
+       ,n386ic
 {$endif}
-{$endif INTERFACE_SUPPORT}
        ;
 
 
@@ -550,7 +545,7 @@ implementation
                                           (po_virtualmethod in hp^.procoptions) then
                                          begin
                                             { in classes, we hide the old method }
-                                            if _c^.is_class then
+                                            if is_class(_c) then
                                               begin
                                                  { warn only if it is the first time,
                                                    we hide the method }
@@ -586,7 +581,7 @@ implementation
                                        { (povirtualmethod is set! }
 
                                        { class ? }
-                                       if _c^.is_class and
+                                       if is_class(_c) and
                                           not(po_overridingmethod in hp^.procoptions) then
                                          begin
                                             { warn only if it is the first time,
@@ -602,8 +597,8 @@ implementation
                                        if not(is_equal(procdefcoll^.data^.rettype.def,hp^.rettype.def)) and
                                          not((procdefcoll^.data^.rettype.def^.deftype=objectdef) and
                                            (hp^.rettype.def^.deftype=objectdef) and
-                                           (pobjectdef(procdefcoll^.data^.rettype.def)^.is_class) and
-                                           (pobjectdef(hp^.rettype.def)^.is_class) and
+                                           is_class(procdefcoll^.data^.rettype.def) and
+                                           is_class(hp^.rettype.def) and
                                            (pobjectdef(hp^.rettype.def)^.is_related(
                                                pobjectdef(procdefcoll^.data^.rettype.def)))) then
                                          Message1(parser_e_overloaded_methodes_not_same_ret,hp^.fullprocname);
@@ -758,15 +753,13 @@ implementation
          disposevmttree;
       end;
 
-{$ifdef SUPPORT_INTERFACES}
-
     function  gintfgetvtbllabelname(_class: pobjectdef; intfindex: integer): string;
       begin
         gintfgetvtbllabelname:='_$$_'+_class^.objname^+'_$$_'+
           _class^.implementedinterfaces^.interfaces(intfindex)^.objname^+'_$$_VTBL';
       end;
 
-    procedure gintfcreatevtbl(_class: pobjectdef; intfindex: integer; rawdata: paasmoutput);
+    procedure gintfcreatevtbl(_class: pobjectdef; intfindex: integer; rawdata,rawcode: paasmoutput);
       var
         implintf: pimplementedinterfaces;
         curintf: pobjectdef;
@@ -782,7 +775,7 @@ implementation
           begin
             tmps:=implintf^.implprocs(intfindex,i)^.mangledname+'_$$_'+curintf^.objname^;
             { create wrapper code }
-            cgintfwrapper(implintf^.implprocs(intfindex,i),tmps,implintf^.ioffsets(intfindex)^);
+            cgintfwrapper(rawcode,implintf^.implprocs(intfindex,i),tmps,implintf^.ioffsets(intfindex)^);
             { create reference }
             rawdata^.concat(new(pai_const_symbol,initname(tmps)));
           end;
@@ -830,6 +823,10 @@ implementation
         datasegment^.concat(new(pai_const_symbol,init(tmplabel)));
       end;
 
+    type
+       tlongintarr = array[0..0] of longint;
+       plongintarr = ^tlongintarr;
+
     procedure gintfoptimizevtbls(_class: pobjectdef; var implvtbl: tlongintarr);
       type
         tcompintfentry = record
@@ -911,7 +908,7 @@ implementation
 
     procedure gintfwritedata(_class: pobjectdef);
       var
-        rawdata: taasmoutput;
+        rawdata,rawcode: taasmoutput;
         impintfindexes: plongintarr;
         max: longint;
         i: longint;
@@ -922,6 +919,7 @@ implementation
         gintfoptimizevtbls(_class,impintfindexes^);
 
         rawdata.init;
+        rawcode.init;
         datasegment^.concat(new(pai_const,init_16bit(max)));
         { Two pass, one for allocation and vtbl creation }
         for i:=1 to max do
@@ -929,17 +927,17 @@ implementation
             if impintfindexes^[i]=i then { if implement itself }
               begin
                 { allocate a pointer in the object memory }
-                with _class^.symtable^ do
+                with pstoredsymtable(_class^.symtable)^ do
                   begin
-                    if (alignment>=target_os.size_of_pointer) then
-                      datasize:=align(datasize,alignment)
+                    if (dataalignment>=target_os.size_of_pointer) then
+                      datasize:=align(datasize,dataalignment)
                     else
                       datasize:=align(datasize,target_os.size_of_pointer);
                     _class^.implementedinterfaces^.ioffsets(i)^:=datasize;
                     datasize:=datasize+target_os.size_of_pointer;
                   end;
                 { write vtbl }
-                gintfcreatevtbl(_class,i,@rawdata);
+                gintfcreatevtbl(_class,i,@rawdata,@rawcode);
               end;
           end;
         { second pass: for fill interfacetable and remained ioffsets }
@@ -951,6 +949,10 @@ implementation
           end;
         datasegment^.insertlist(@rawdata);
         rawdata.done;
+        if (cs_create_smart in aktmoduleswitches) then
+          rawcode.insert(new(pai_cut,init));
+        codesegment^.insertlist(@rawcode);
+        rawcode.done;
         freemem(impintfindexes,(max+1)*sizeof(longint));
       end;
 
@@ -964,7 +966,7 @@ implementation
         if assigned(sym) and (sym^.typ=procsym) and not (sp_private in sym^.symoptions) then
           begin
             implprocdef:=sym^.definition;
-            while assigned(implprocdef) and not equal_paras(proc^.para,implprocdef^.para,false) and
+            while assigned(implprocdef) and not equal_paras(proc^.para,implprocdef^.para,cp_none) and
                   (proc^.proccalloptions<>implprocdef^.proccalloptions) do
               implprocdef:=implprocdef^.nextoverloaded;
           end;
@@ -1035,12 +1037,36 @@ implementation
         genintftable:=intftable;
       end;
 
-{$endif SUPPORT_INTERFACES}
+  { Write interface identifiers to the data section }
+  procedure writeinterfaceids(c : pobjectdef);
+    var
+      i: longint;
+    begin
+      if c^.isiidguidvalid then
+        begin
+          if (cs_create_smart in aktmoduleswitches) then
+            datasegment^.concat(new(pai_cut,init));
+          datasegment^.concat(new(pai_symbol,initname_global(c^.vmt_mangledname+'$_IID',0)));
+          datasegment^.concat(new(pai_const,init_32bit(c^.iidguid.D1)));
+          datasegment^.concat(new(pai_const,init_16bit(c^.iidguid.D2)));
+          datasegment^.concat(new(pai_const,init_16bit(c^.iidguid.D3)));
+          for i:=Low(c^.iidguid.D4) to High(c^.iidguid.D4) do
+            datasegment^.concat(new(pai_const,init_8bit(c^.iidguid.D4[i])));
+        end;
+      if (cs_create_smart in aktmoduleswitches) then
+        datasegment^.concat(new(pai_cut,init));
+      datasegment^.concat(new(pai_symbol,initname_global(c^.vmt_mangledname+'$_IIDSTR',0)));
+      datasegment^.concat(new(pai_const,init_8bit(length(c^.iidstr^))));
+      datasegment^.concat(new(pai_string,init(c^.iidstr^)));
+    end;
 
 end.
 {
   $Log$
-  Revision 1.9  2000-11-01 23:04:37  peter
+  Revision 1.10  2000-11-04 14:25:19  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.9  2000/11/01 23:04:37  peter
     * tprocdef.fullprocname added for better casesensitve writing of
       procedures
 

compiler/htypechk.pas

@@ -187,16 +187,15 @@ implementation
                  is_chararray(ld)))
            ) or
            { <> and = are defined for classes }
-           ((ld^.deftype=objectdef) and
-            (not(pobjectdef(ld)^.is_class) or
-             not(treetyp in [equaln,unequaln])
-            )
+           (
+            (ld^.deftype=objectdef) and
+            not((treetyp in [equaln,unequaln]) and (is_class(ld) or is_interface(ld)))
            ) or
-           ((rd^.deftype=objectdef) and
-            (not(pobjectdef(rd)^.is_class) or
-             not(treetyp in [equaln,unequaln])
-            )
-             or
+           (
+            (rd^.deftype=objectdef) and
+            not((treetyp in [equaln,unequaln]) and (is_class(rd) or is_interface(rd)))
+           )
+           or
            { allow other operators that + on strings }
            (
             (is_char(rd) or
@@ -213,8 +212,7 @@ implementation
                  (is_integer(rd) or (rd^.deftype=pointerdef)) and
                  (treetyp=subn)
                 )
-            )
-           );
+            );
       end;
 
 
@@ -593,7 +591,7 @@ implementation
                    pointerdef :
                      gotpointer:=true;
                    objectdef :
-                     gotclass:=pobjectdef(hp.resulttype)^.is_class;
+                     gotclass:=is_class_or_interface(hp.resulttype);
                    classrefdef :
                      gotclass:=true;
                    arraydef :
@@ -646,7 +644,7 @@ implementation
                    pointerdef :
                      gotpointer:=true;
                    objectdef :
-                     gotclass:=pobjectdef(hp.resulttype)^.is_class;
+                     gotclass:=is_class_or_interface(hp.resulttype);
                    recorddef, { handle record like class it needs a subscription }
                    classrefdef :
                      gotclass:=true;
@@ -889,7 +887,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  2000-10-31 22:02:47  peter
+  Revision 1.14  2000-11-04 14:25:19  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.13  2000/10/31 22:02:47  peter
     * symtable splitted, no real code changes
 
   Revision 1.12  2000/10/14 10:14:47  peter

compiler/i386/cgai386.pas

@@ -111,6 +111,9 @@ interface
     procedure emit_push_mem(const ref : treference);
     procedure emitpushreferenceaddr(const ref : treference);
 
+    procedure incrcomintfref(t: pdef; const ref: treference);
+    procedure decrcomintfref(t: pdef; const ref: treference);
+
     procedure floatload(t : tfloattype;const ref : treference);
     procedure floatstore(t : tfloattype;const ref : treference);
     procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize);
@@ -970,6 +973,41 @@ implementation
                            Emit String Functions
 *****************************************************************************}
 
+    procedure incrcomintfref(t: pdef; const ref: treference);
+
+      var
+         pushedregs : tpushed;
+
+      begin
+         pushusedregisters(pushedregs,$ff);
+         emitpushreferenceaddr(ref);
+         if is_interfacecom(t) then
+           begin
+              emitcall('FPC_INTF_INCR_REF');
+           end
+         else internalerror(1859);
+         popusedregisters(pushedregs);
+      end;
+
+
+    procedure decrcomintfref(t: pdef; const ref: treference);
+
+      var
+         pushedregs : tpushed;
+
+      begin
+         pushusedregisters(pushedregs,$ff);
+         emitpushreferenceaddr(ref);
+         if is_interfacecom(t) then
+           begin
+              emitcall('FPC_INTF_DECR_REF');
+           end
+         else internalerror(1859);
+         popusedregisters(pushedregs);
+      end;
+
+
+
     procedure copyshortstring(const dref,sref : treference;len : byte;
                 loadref, del_sref: boolean);
       begin
@@ -1041,7 +1079,6 @@ implementation
          popusedregisters(pushedregs);
       end;
 
-
 {*****************************************************************************
                            Emit Push Functions
 *****************************************************************************}
@@ -1585,7 +1622,8 @@ implementation
 
       begin
          if is_ansistring(t) or
-           is_widestring(t) then
+           is_widestring(t) or
+           is_interfacecom(t) then
            begin
               emit_const_ref(A_MOV,S_L,0,
                 newreference(ref));
@@ -1618,6 +1656,10 @@ implementation
            begin
               decrstringref(t,ref);
            end
+         else if is_interfacecom(t) then
+           begin
+              decrcomintfref(t,ref);
+           end
          else
            begin
               reset_reference(r);
@@ -1642,8 +1684,7 @@ implementation
     begin
        if (psym(p)^.typ=varsym) and
           assigned(pvarsym(p)^.vartype.def) and
-          not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
-            pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
+          not(is_class(pvarsym(p)^.vartype.def)) and
           pvarsym(p)^.vartype.def^.needs_inittable then
          begin
             if assigned(procinfo) then
@@ -1662,37 +1703,103 @@ implementation
          end;
     end;
 
-  { generates the code for incrementing the reference count of parameters }
-  procedure incr_data(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
+  { generates the code for incrementing the reference count of parameters and
+    initialize out parameters }
+  procedure init_paras(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
 
     var
-       hr : treference;
+       hrv : treference;
+       hr: treference;
 
     begin
        if (psym(p)^.typ=varsym) and
-          not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
-            pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
-          pvarsym(p)^.vartype.def^.needs_inittable and
-          (not assigned(pvarsym(p)^.localvarsym)) and
-          ((pvarsym(p)^.varspez=vs_value) {or
-           (pvarsym(p)^.varspez=vs_const) and
-           not(dont_copy_const_param(pvarsym(p)^.definition))}) then
+          not is_class(pvarsym(p)^.vartype.def) and
+          pvarsym(p)^.vartype.def^.needs_inittable then
          begin
-            procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-            reset_reference(hr);
-            hr.symbol:=pstoreddef(pvarsym(p)^.vartype.def)^.get_inittable_label;
-            emitpushreferenceaddr(hr);
-            reset_reference(hr);
-            hr.base:=procinfo^.framepointer;
-            hr.offset:=pvarsym(p)^.address+procinfo^.para_offset;
+           if (pvarsym(p)^.varspez=vs_value) then
+             begin
+               procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
 
-            emitpushreferenceaddr(hr);
-            reset_reference(hr);
+               reset_reference(hrv);
+               hrv.base:=procinfo^.framepointer;
+               hrv.offset:=pvarsym(p)^.address+procinfo^.para_offset;
 
-            emitcall('FPC_ADDREF');
+               if is_ansistring(pvarsym(p)^.vartype.def) or
+                  is_widestring(pvarsym(p)^.vartype.def) then
+                 begin
+                   incrstringref(pvarsym(p)^.vartype.def,hrv)
+                 end
+               else if is_interfacecom(pvarsym(p)^.vartype.def) then
+                 begin
+                   incrcomintfref(pvarsym(p)^.vartype.def,hrv)
+                 end
+               else
+                 begin
+                   reset_reference(hr);
+                   hr.symbol:=pstoreddef(pvarsym(p)^.vartype.def)^.get_inittable_label;
+                   emitpushreferenceaddr(hr);
+                   emitpushreferenceaddr(hrv);
+                   emitcall('FPC_ADDREF');
+                 end;
+             end
+           else if (pvarsym(p)^.varspez=vs_out) then
+             begin
+               reset_reference(hrv);
+               hrv.base:=procinfo^.framepointer;
+               hrv.offset:=pvarsym(p)^.address+procinfo^.para_offset;
+               {$ifndef noAllocEdi}
+               getexplicitregister32(R_EDI);
+               {$endif noAllocEdi}
+               exprasmlist^.concat(new(paicpu,op_ref_reg(A_MOV,S_L,newreference(hrv),R_EDI)));
+               reset_reference(hr);
+               hr.base:=R_EDI;
+               initialize(pvarsym(p)^.vartype.def,hr,false);
+             end;
          end;
     end;
 
+  { generates the code for decrementing the reference count of parameters }
+  procedure final_paras(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
+
+    var
+       hrv : treference;
+       hr: treference;
+
+    begin
+       if (psym(p)^.typ=varsym) and
+          not is_class(pvarsym(p)^.vartype.def) and
+          pvarsym(p)^.vartype.def^.needs_inittable then
+         begin
+           if (pvarsym(p)^.varspez=vs_value) then
+             begin
+               procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+
+               reset_reference(hrv);
+               hrv.base:=procinfo^.framepointer;
+               hrv.offset:=pvarsym(p)^.address+procinfo^.para_offset;
+
+               if is_ansistring(pvarsym(p)^.vartype.def) or
+                  is_widestring(pvarsym(p)^.vartype.def) then
+                 begin
+                   decrstringref(pvarsym(p)^.vartype.def,hrv)
+                 end
+               else if is_interfacecom(pvarsym(p)^.vartype.def) then
+                 begin
+                   decrcomintfref(pvarsym(p)^.vartype.def,hrv)
+                 end
+               else
+                 begin
+                   reset_reference(hr);
+                   hr.symbol:=pstoreddef(pvarsym(p)^.vartype.def)^.get_inittable_label;
+                   emitpushreferenceaddr(hr);
+                   emitpushreferenceaddr(hrv);
+                   emitcall('FPC_DECREF');
+                 end;
+             end;
+         end;
+    end;
+
+
   { generates the code for finalisation of local data }
   procedure finalize_data(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
 
@@ -1702,15 +1809,9 @@ implementation
     begin
        if (psym(p)^.typ=varsym) and
           assigned(pvarsym(p)^.vartype.def) and
-          not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
-          pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
-          (not assigned(pvarsym(p)^.localvarsym)) and
+          not(is_class(pvarsym(p)^.vartype.def)) and
           pvarsym(p)^.vartype.def^.needs_inittable then
          begin
-            { not all kind of parameters need to be finalized  }
-            if (psym(p)^.owner^.symtabletype=parasymtable) and
-              (pvarsym(p)^.varspez in [vs_out,vs_var,vs_const]) then
-              exit;
             if assigned(procinfo) then
               procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
             reset_reference(hr);
@@ -1720,11 +1821,6 @@ implementation
                     hr.base:=procinfo^.framepointer;
                     hr.offset:=-pvarsym(p)^.address+pvarsym(p)^.owner^.address_fixup;
                  end;
-               parasymtable,inlineparasymtable:
-                 begin
-                    hr.base:=procinfo^.framepointer;
-                    hr.offset:=pvarsym(p)^.address+procinfo^.para_offset;
-                 end;
                else
                  hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname);
             end;
@@ -1920,7 +2016,7 @@ implementation
         end;
     end;
 
-  procedure inittempansistrings;
+  procedure inittempvariables;
 
     var
        hp : ptemprecord;
@@ -1930,20 +2026,20 @@ implementation
        hp:=templist;
        while assigned(hp) do
          begin
-           if hp^.temptype in [tt_ansistring,tt_freeansistring] then
-            begin
-              procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-              new(r);
-              reset_reference(r^);
-              r^.base:=procinfo^.framepointer;
-              r^.offset:=hp^.pos;
-              emit_const_ref(A_MOV,S_L,0,r);
-            end;
-            hp:=hp^.next;
+           if hp^.temptype in [tt_ansistring,tt_freeansistring,tt_interfacecom] then
+             begin
+               procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+               new(r);
+               reset_reference(r^);
+               r^.base:=procinfo^.framepointer;
+               r^.offset:=hp^.pos;
+               emit_const_ref(A_MOV,S_L,0,r);
+             end;
+           hp:=hp^.next;
          end;
    end;
 
-  procedure finalizetempansistrings;
+  procedure finalizetempvariables;
 
     var
        hp : ptemprecord;
@@ -1954,12 +2050,21 @@ implementation
          begin
             if hp^.temptype in [tt_ansistring,tt_freeansistring] then
               begin
-                 procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
-                 reset_reference(hr);
-                 hr.base:=procinfo^.framepointer;
-                 hr.offset:=hp^.pos;
-                 emitpushreferenceaddr(hr);
-                 emitcall('FPC_ANSISTR_DECR_REF');
+                procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+                reset_reference(hr);
+                hr.base:=procinfo^.framepointer;
+                hr.offset:=hp^.pos;
+                emitpushreferenceaddr(hr);
+                emitcall('FPC_ANSISTR_DECR_REF');
+              end
+            else if hp^.temptype=tt_interfacecom then
+              begin
+                procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
+                reset_reference(hr);
+                hr.base:=procinfo^.framepointer;
+                hr.offset:=hp^.pos;
+                emitpushreferenceaddr(hr);
+                emitcall('FPC_INTF_DECR_REF');
               end;
             hp:=hp^.next;
          end;
@@ -2038,19 +2143,21 @@ implementation
       { a constructor needs a help procedure }
       if (aktprocsym^.definition^.proctypeoption=potype_constructor) then
         begin
-          if procinfo^._class^.is_class then
+          if is_class(procinfo^._class) then
             begin
               procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
               exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel)));
               emitinsertcall('FPC_NEW_CLASS');
             end
-          else
+          else if is_object(procinfo^._class) then
             begin
               exprasmlist^.insert(new(paicpu,op_cond_sym(A_Jcc,C_Z,S_NO,faillabel)));
               emitinsertcall('FPC_HELP_CONSTRUCTOR');
               getexplicitregister32(R_EDI);
               exprasmlist^.insert(new(paicpu,op_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI)));
-            end;
+            end
+          else
+            Internalerror(200006161);
         end;
 
       { don't load ESI, does the caller }
@@ -2058,7 +2165,7 @@ implementation
       { that can be called from a foreach }
       { of another object than self !! PM }
 
-         if assigned(procinfo^._class) and
+         if assigned(procinfo^._class) and  { !!!!! shouldn't we load ESI always? }
             (lexlevel>normal_function_level) then
            maybe_loadesi;
 
@@ -2090,8 +2197,7 @@ implementation
         end;
 
       { omit stack frame ? }
-      if not inlined then
-      if procinfo^.framepointer=stack_pointer then
+      if (not inlined) and (procinfo^.framepointer=stack_pointer) then
           begin
               CGMessage(cg_d_stackframe_omited);
               nostackframe:=true;
@@ -2204,8 +2310,7 @@ implementation
       { initialize return value }
       if (procinfo^.returntype.def<>pdef(voiddef)) and
         (procinfo^.returntype.def^.needs_inittable) and
-        ((procinfo^.returntype.def^.deftype<>objectdef) or
-        not(pobjectdef(procinfo^.returntype.def)^.is_class)) then
+        not(is_class(procinfo^.returntype.def)) then
         begin
            procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
            reset_reference(r);
@@ -2228,7 +2333,7 @@ implementation
          else
            aktprocsym^.definition^.localst^.foreach({$ifndef TP}@{$endif}initialize_data);
       end;
-
+      {
       { generate copies of call by value parameters }
       if not(po_assembler in aktprocsym^.definition^.procoptions) and
          (([pocall_cdecl,pocall_cppdecl]*aktprocsym^.definition^.proccalloptions)=[]) then
@@ -2236,11 +2341,11 @@ implementation
 
       { add a reference to all call by value/const parameters }
       aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}incr_data);
-
+      }
       { initialisizes temp. ansi/wide string data }
-      inittempansistrings;
+      inittempvariables;
 
-      { do we need an exception frame because of ansi/widestrings ? }
+      { do we need an exception frame because of ansi/widestrings/interfaces ? }
       if not inlined and
          ((procinfo^.flags and pi_needs_implicit_finally)<>0) and
       { but it's useless in init/final code of units }
@@ -2406,11 +2511,11 @@ implementation
       if (aktprocsym^.definition^.proctypeoption=potype_destructor) and
          assigned(procinfo^._class) then
         begin
-          if procinfo^._class^.is_class then
+          if is_class(procinfo^._class) then
             begin
               emitinsertcall('FPC_DISPOSE_CLASS');
             end
-          else
+          else if is_object(procinfo^._class) then
             begin
               emitinsertcall('FPC_HELP_DESTRUCTOR');
               getexplicitregister32(R_EDI);
@@ -2432,11 +2537,15 @@ implementation
                    hr.offset:=8;
                    exprasmlist^.insert(new(paicpu,op_const_ref(A_CMP,S_L,0,newreference(hr))));
                 end;
+            end
+          else
+            begin
+              Internalerror(200006161);
             end;
         end;
 
       { finalize temporary data }
-      finalizetempansistrings;
+      finalizetempvariables;
 
       { finalize local data like ansistrings}
       case aktprocsym^.definition^.proctypeoption of
@@ -2455,7 +2564,7 @@ implementation
 
       { finalize paras data }
       if assigned(aktprocsym^.definition^.parast) then
-        aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}finalize_data);
+        aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}final_paras);
 
       { do we need to handle exceptions because of ansi/widestrings ? }
       if not inlined and
@@ -2486,15 +2595,19 @@ implementation
                           emit_const_ref(A_CMP,S_L,0,new_reference(procinfo^.framepointer,
                             procinfo^.selfpointer_offset));
                           emitjmp(C_E,nodestroycall);
-                          if procinfo^._class^.is_class then
+                          if is_class(procinfo^._class) then
                             begin
                                emit_const(A_PUSH,S_L,1);
                                emit_reg(A_PUSH,S_L,R_ESI);
                             end
-                          else
+                          else if is_object(procinfo^._class) then
                             begin
                                emit_reg(A_PUSH,S_L,R_ESI);
                                emit_sym(A_PUSH,S_L,newasmsymbol(procinfo^._class^.vmt_mangledname));
+                            end
+                          else
+                            begin
+                              Internalerror(200006161);
                             end;
                           if (po_virtualmethod in pd^.procoptions) then
                             begin
@@ -2517,7 +2630,7 @@ implementation
            if (procinfo^.returntype.def<>pdef(voiddef)) and
              (procinfo^.returntype.def^.needs_inittable) and
              ((procinfo^.returntype.def^.deftype<>objectdef) or
-             not(pobjectdef(procinfo^.returntype.def)^.is_class)) then
+              not is_class(procinfo^.returntype.def)) then
              begin
                 reset_reference(hr);
                 hr.offset:=procinfo^.return_offset;
@@ -2550,19 +2663,22 @@ implementation
                   getlabel(okexitlabel);
                   emitjmp(C_NONE,okexitlabel);
                   emitlab(faillabel);
-                  if procinfo^._class^.is_class then
+                  if is_class(procinfo^._class) then
                     begin
                       emit_ref_reg(A_MOV,S_L,new_reference(procinfo^.framepointer,8),R_ESI);
                       emitcall('FPC_HELP_FAIL_CLASS');
                     end
-                  else
+                  else if is_object(procinfo^._class) then
                     begin
                       emit_ref_reg(A_MOV,S_L,new_reference(procinfo^.framepointer,12),R_ESI);
                        getexplicitregister32(R_EDI);
                       emit_const_reg(A_MOV,S_L,procinfo^._class^.vmt_offset,R_EDI);
                       emitcall('FPC_HELP_FAIL');
                       ungetregister32(R_EDI);
-                    end;
+                    end
+                  else
+                    Internalerror(200006161);
+
                   emitlab(okexitlabel);
 
                   exprasmlist^.concat(new(pairegalloc,alloc(R_EAX)));
@@ -2675,7 +2791,7 @@ implementation
                 if (not assigned(procinfo^.parent) or
                    not assigned(procinfo^.parent^._class)) then
                   begin
-                    if not  procinfo^._class^.is_class then
+                    if not(is_class(procinfo^._class)) then
                       st:='v'
                     else
                       st:='p';
@@ -2685,7 +2801,7 @@ implementation
                   end
                 else
                   begin
-                    if not  procinfo^._class^.is_class then
+                    if not is_class(procinfo^._class) then
                       st:='*'
                     else
                       st:='';
@@ -2816,7 +2932,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.6  2000-10-31 22:02:55  peter
+  Revision 1.7  2000-11-04 14:25:23  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.6  2000/10/31 22:02:55  peter
     * symtable splitted, no real code changes
 
   Revision 1.5  2000/10/24 22:23:04  peter

compiler/i386/n386add.pas

@@ -923,11 +923,7 @@ interface
 
                  (right.resulttype^.deftype=pointerdef) or
 
-                 ((right.resulttype^.deftype=objectdef) and
-                  pobjectdef(right.resulttype)^.is_class and
-                 (left.resulttype^.deftype=objectdef) and
-                  pobjectdef(left.resulttype)^.is_class
-                 ) or
+                 (is_class(right.resulttype) and is_class(left.resulttype)) or
 
                  (left.resulttype^.deftype=classrefdef) or
 
@@ -2292,7 +2288,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.2  2000-10-31 22:02:56  peter
+  Revision 1.3  2000-11-04 14:25:23  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.2  2000/10/31 22:02:56  peter
     * symtable splitted, no real code changes
 
   Revision 1.1  2000/10/15 09:33:31  peter

compiler/i386/n386bas.pas

@@ -143,7 +143,7 @@ unit n386bas;
          else
            begin
              { if the routine is an inline routine, then we must hold a copy
-               becuase it can be necessary for inlining later }
+               because it can be necessary for inlining later }
              if (pocall_inline in aktprocsym^.definition^.proccalloptions) then
                exprasmlist^.concatlistcopy(p_asm)
              else
@@ -204,7 +204,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.2  2000-10-31 22:02:56  peter
+  Revision 1.3  2000-11-04 14:25:23  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.2  2000/10/31 22:02:56  peter
     * symtable splitted, no real code changes
 
   Revision 1.1  2000/10/15 09:33:31  peter

compiler/i386/n386cal.pas

@@ -90,44 +90,6 @@ implementation
              end;
         end;
 
-      procedure prepareout(const r : treference);
-
-        var
-           hr : treference;
-           pushed : tpushed;
-
-        begin
-           { out parameters needs to be finalized }
-           if (defcoll^.paratype.def^.needs_inittable) then
-             begin
-                reset_reference(hr);
-                hr.symbol:=pstoreddef(defcoll^.paratype.def)^.get_inittable_label;
-                emitpushreferenceaddr(hr);
-                emitpushreferenceaddr(r);
-                emitcall('FPC_FINALIZE');
-             end
-           else
-           { or at least it zeroed out }
-             begin
-                case defcoll^.paratype.def^.size of
-                   1:
-                     emit_const_ref(A_MOV,S_B,0,newreference(r));
-                   2:
-                     emit_const_ref(A_MOV,S_W,0,newreference(r));
-                   4:
-                     emit_const_ref(A_MOV,S_L,0,newreference(r));
-                   else
-                     begin
-                        pushusedregisters(pushed,$ff);
-                        emit_const(A_PUSH,S_W,0);
-                        push_int(defcoll^.paratype.def^.size);
-                        emitpushreferenceaddr(r);
-                        emitcall('FPC_FILLCHAR');
-                        popusedregisters(pushed);
-                     end
-                end;
-             end;
-        end;
       var
          otlabel,oflabel : pasmlabel;
          { temporary variables: }
@@ -200,6 +162,11 @@ implementation
               if (left.location.loc<>LOC_REFERENCE) then
                 CGMessage(cg_e_var_must_be_reference);
               maybe_push_high;
+              if (defcoll^.paratyp=vs_out) and
+                 assigned(defcoll^.paratype.def) and
+                 not is_class(defcoll^.paratype.def) and
+                 defcoll^.paratype.def^.needs_inittable then
+                finalize(defcoll^.paratype.def,left.location.reference,false);
               inc(pushedparasize,4);
               if inlined then
                 begin
@@ -212,8 +179,6 @@ implementation
                 end
               else
                 emitpushreferenceaddr(left.location.reference);
-              if defcoll^.paratyp=vs_out then
-                prepareout(left.location.reference);
               del_reference(left.location.reference);
            end
          else
@@ -562,7 +527,7 @@ implementation
                    r^:=twithnode(pwithsymtable(symtableproc)^.withnode).withreference^;
                    if ((not(nf_islocal in twithnode(pwithsymtable(symtableproc)^.withnode).flags)) and
                        (not pwithsymtable(symtableproc)^.direct_with)) or
-                      pobjectdef(methodpointer.resulttype)^.is_class then
+                      is_class_or_interface(methodpointer.resulttype) then
                      emit_ref_reg(A_MOV,S_L,r,R_ESI)
                    else
                      emit_ref_reg(A_LEA,S_L,r,R_ESI);
@@ -623,7 +588,7 @@ implementation
                                       loadesi:=false;
 
                                     { a class destructor needs a flag }
-                                    if pobjectdef(methodpointer.resulttype)^.is_class and
+                                    if is_class(pobjectdef(methodpointer.resulttype)) and
                                        {assigned(aktprocsym) and
                                        (aktprocsym^.definition^.proctypeoption=potype_destructor)}
                                        (procdefinition^.proctypeoption=potype_destructor) then
@@ -633,7 +598,7 @@ implementation
                                       end;
 
                                     if not(is_con_or_destructor and
-                                           pobjectdef(methodpointer.resulttype)^.is_class and
+                                           is_class(methodpointer.resulttype) and
                                            {assigned(aktprocsym) and
                                           (aktprocsym^.definition^.proctypeoption in [potype_constructor,potype_destructor])}
                                            (procdefinition^.proctypeoption in [potype_constructor,potype_destructor])
@@ -644,8 +609,8 @@ implementation
                                     { will be made                                  }
                                     { con- and destructors need a pointer to the vmt }
                                     if is_con_or_destructor and
-                                    not(pobjectdef(methodpointer.resulttype)^.is_class) and
-                                    assigned(aktprocsym) then
+                                      is_object(methodpointer.resulttype) and
+                                      assigned(aktprocsym) then
                                       begin
                                          if not(aktprocsym^.definition^.proctypeoption in
                                                 [potype_constructor,potype_destructor]) then
@@ -654,12 +619,13 @@ implementation
                                     { class destructors get there flag above }
                                     { constructor flags ?                    }
                                     if is_con_or_destructor and
-                                        not(pobjectdef(methodpointer.resulttype)^.is_class and
+                                      not(
+                                        is_class(methodpointer.resulttype) and
                                         assigned(aktprocsym) and
                                         (aktprocsym^.definition^.proctypeoption=potype_destructor)) then
                                       begin
                                          { a constructor needs also a flag }
-                                         if pobjectdef(methodpointer.resulttype)^.is_class then
+                                         if is_class(methodpointer.resulttype) then
                                            push_int(0);
                                          push_int(0);
                                       end;
@@ -713,8 +679,7 @@ implementation
                                             else
                                               begin
                                                  if (methodpointer.resulttype^.deftype=classrefdef) or
-                                                    ((methodpointer.resulttype^.deftype=objectdef) and
-                                                   pobjectdef(methodpointer.resulttype)^.is_class) then
+                                                    is_class_or_interface(methodpointer.resulttype) then
                                                    emit_ref_reg(A_MOV,S_L,
                                                      newreference(methodpointer.location.reference),R_ESI)
                                                  else
@@ -742,14 +707,12 @@ implementation
 
                                         { direct call to destructor: remove data }
                                         if (procdefinition^.proctypeoption=potype_destructor) and
-                                           (methodpointer.resulttype^.deftype=objectdef) and
-                                           (pobjectdef(methodpointer.resulttype)^.is_class) then
+                                           is_class(methodpointer.resulttype) then
                                           emit_const(A_PUSH,S_L,1);
 
                                         { direct call to class constructor, don't allocate memory }
                                         if (procdefinition^.proctypeoption=potype_constructor) and
-                                           (methodpointer.resulttype^.deftype=objectdef) and
-                                           (pobjectdef(methodpointer.resulttype)^.is_class) then
+                                           is_class(methodpointer.resulttype) then
                                           begin
                                              emit_const(A_PUSH,S_L,0);
                                              emit_const(A_PUSH,S_L,0);
@@ -759,8 +722,7 @@ implementation
                                              { constructor call via classreference => allocate memory }
                                              if (procdefinition^.proctypeoption=potype_constructor) and
                                                 (methodpointer.resulttype^.deftype=classrefdef) and
-                                                (pobjectdef(pclassrefdef(methodpointer.resulttype)^.
-                                                   pointertype.def)^.is_class) then
+                                                is_class(pclassrefdef(methodpointer.resulttype)^.pointertype.def) then
                                                 emit_const(A_PUSH,S_L,1);
                                              emit_reg(A_PUSH,S_L,R_ESI);
                                           end;
@@ -769,8 +731,7 @@ implementation
                                     if is_con_or_destructor then
                                       begin
                                          { classes don't get a VMT pointer pushed }
-                                         if (methodpointer.resulttype^.deftype=objectdef) and
-                                           not(pobjectdef(methodpointer.resulttype)^.is_class) then
+                                         if is_object(methodpointer.resulttype) then
                                            begin
                                               if (procdefinition^.proctypeoption=potype_constructor) then
                                                 begin
@@ -810,7 +771,7 @@ implementation
                              loadesi:=false;
                           end;
                         { direct call to destructor: don't remove data! }
-                        if procinfo^._class^.is_class then
+                        if is_class(procinfo^._class) then
                           begin
                              if (procdefinition^.proctypeoption=potype_destructor) then
                                begin
@@ -825,7 +786,7 @@ implementation
                              else
                                emit_reg(A_PUSH,S_L,R_ESI);
                           end
-                        else
+                        else if is_object(procinfo^._class) then
                           begin
                              emit_reg(A_PUSH,S_L,R_ESI);
                              if is_con_or_destructor then
@@ -841,7 +802,9 @@ implementation
                                   else
                                     push_int(0);
                                end;
-                          end;
+                          end
+                        else
+                          Internalerror(200006165);
                      end;
                 end;
 
@@ -1356,8 +1319,7 @@ implementation
                 begin
                    { data which must be finalized ? }
                    if (resulttype^.needs_inittable) and
-                     ( (resulttype^.deftype<>objectdef) or
-                       not(pobjectdef(resulttype)^.is_class)) then
+                     not(is_class(resulttype)) then
                       finalize(resulttype,location.reference,false);
                    { release unused temp }
                    ungetiftemp(location.reference)
@@ -1595,7 +1557,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.3  2000-11-04 13:12:14  jonas
+  Revision 1.4  2000-11-04 14:25:23  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.3  2000/11/04 13:12:14  jonas
     * check for nil pointers before calling getcopy
 
   Revision 1.2  2000/10/31 22:02:56  peter

compiler/i386/n386cnv.pas

@@ -1234,7 +1234,9 @@ implementation
            @ti386typeconvnode.second_proc_to_procvar,
            @ti386typeconvnode.second_nothing, {arrayconstructor_to_set}
            @ti386typeconvnode.second_load_smallset,
-           @ti386typeconvnode.second_cord_to_pointer
+           @ti386typeconvnode.second_cord_to_pointer,
+           @ti386typeconvnode.second_nothing, { interface 2 string }
+           @ti386typeconvnode.second_nothing  { interface 2 guid   }
          );
       type
          tprocedureofobject = procedure of object;
@@ -1434,7 +1436,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.2  2000-10-31 22:02:56  peter
+  Revision 1.3  2000-11-04 14:25:23  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.2  2000/10/31 22:02:56  peter
     * symtable splitted, no real code changes
 
   Revision 1.1  2000/10/15 09:33:31  peter

compiler/i386/n386ic.pas

@@ -0,0 +1,213 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Kovacs Attila Zoltan
+
+    Generate i386 assembly wrapper code interface implementor objects
+
+    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 n386ic;
+
+interface
+
+uses
+  aasm,
+  symbase,symtype,symtable,symdef,symsym;
+
+procedure cgintfwrapper(asmlist: paasmoutput; procdef: pprocdef; const labelname: string; ioffset: longint);
+
+implementation
+
+uses
+  globtype, systems,
+  cobjects, verbose, globals,
+  symconst, types,
+{$ifdef GDB}
+  strings, gdb,
+{$endif GDB}
+  hcodegen, temp_gen,
+  cpubase, cpuasm,
+  cgai386, tgeni386;
+
+{
+possible calling conventions:
+              default stdcall cdecl pascal popstack register saveregisters
+default(0):      OK     OK    OK(1)  OK     OK(1)      OK          OK
+virtual(2):      OK     OK    OK(3)  OK     OK(3)      OK          OK(4)
+
+(0):
+    set self parameter to correct value
+    jmp mangledname
+
+(1): The code is the following
+     set self parameter to correct value
+     call mangledname
+     set self parameter to interface value
+
+(2): The wrapper code use %eax to reach the virtual method address
+     set self to correct value
+     move self,%eax
+     mov  0(%eax),%eax ; load vmt
+     jmp  vmtoffs(%eax) ; method offs
+
+(3): The wrapper code use %eax to reach the virtual method address
+     set self to correct value
+     move self,%eax
+     mov  0(%eax),%eax ; load vmt
+     jmp  vmtoffs(%eax) ; method offs
+     set self parameter to interface value
+
+
+(4): Virtual use eax to reach the method address so the following code be generated:
+     set self to correct value
+     push %ebx ; allocate space for function address
+     push %eax
+     mov  self,%eax
+     mov  0(%eax),%eax ; load vmt
+     mov  vmtoffs(%eax),eax ; method offs
+     mov  %eax,4(%esp)
+     pop  %eax
+     ret  0; jmp the address
+
+}
+
+function getselfoffsetfromsp(procdef: pprocdef): longint;
+begin
+  if not assigned(procdef^.parast^.symindex^.first) then
+    getselfoffsetfromsp:=4
+  else
+    if psym(procdef^.parast^.symindex^.first)^.typ=varsym then
+      getselfoffsetfromsp:=pvarsym(procdef^.parast^.symindex^.first)^.address+4
+    else
+      Internalerror(2000061310);
+end;
+
+
+procedure cgintfwrapper(asmlist: paasmoutput; procdef: pprocdef; const labelname: string; ioffset: longint);
+  procedure checkvirtual;
+  begin
+    if (procdef^.extnumber=-1) then
+      Internalerror(200006139);
+  end;
+
+  procedure adjustselfvalue(ioffset: longint);
+  begin
+    { sub $ioffset,offset(%esp) }
+    emit_const_ref(A_SUB,S_L,ioffset,new_reference(R_ESP,getselfoffsetfromsp(procdef)));
+  end;
+
+  procedure getselftoeax(offs: longint);
+  begin
+    { mov offset(%esp),%eax }
+    emit_ref_reg(A_MOV,S_L,new_reference(R_ESP,getselfoffsetfromsp(procdef)),R_EAX);
+  end;
+
+  procedure loadvmttoeax;
+  begin
+    checkvirtual;
+    { mov  0(%eax),%eax ; load vmt}
+    emit_ref_reg(A_MOV,S_L,new_reference(R_EAX,0),R_EAX);
+  end;
+
+  procedure op_oneaxmethodaddr(op: TAsmOp);
+  begin
+    { call/jmp  vmtoffs(%eax) ; method offs }
+    emit_ref(op,S_L,new_reference(R_EAX,procdef^._class^.vmtmethodoffset(procdef^.extnumber)));
+  end;
+
+  procedure loadmethodoffstoeax;
+  begin
+    { mov  vmtoffs(%eax),%eax ; method offs }
+    emit_ref_reg(A_MOV,S_L,new_reference(R_EAX,procdef^._class^.vmtmethodoffset(procdef^.extnumber)),R_EAX);
+  end;
+
+var
+  oldexprasmlist: paasmoutput;
+begin
+  if procdef^.proctypeoption<>potype_none then
+    Internalerror(200006137);
+  if not assigned(procdef^._class) or
+     (procdef^.procoptions*[po_containsself, po_classmethod, po_staticmethod,
+       po_methodpointer, po_interrupt, po_iocheck]<>[]) then
+    Internalerror(200006138);
+
+  oldexprasmlist:=exprasmlist;
+  exprasmlist:=asmlist;
+
+  exprasmlist^.concat(new(pai_symbol,initname(labelname,0)));
+
+  { set param1 interface to self  }
+  adjustselfvalue(ioffset);
+
+  { case 1  or 2 }
+  if (pocall_clearstack in procdef^.proccalloptions) then
+    begin
+      if po_virtualmethod in procdef^.procoptions then
+        begin { case 2 }
+          getselftoeax(0);
+          loadvmttoeax;
+          op_oneaxmethodaddr(A_CALL);
+        end
+      else { case 1 }
+        begin
+          emitcall(procdef^.mangledname);
+        end;
+      { restore param1 value self to interface }
+      adjustselfvalue(-ioffset);
+    end
+  { case 3 }
+  else if [po_virtualmethod,po_saveregisters]*procdef^.procoptions=[po_virtualmethod,po_saveregisters] then
+    begin
+      emit_reg(A_PUSH,S_L,R_EBX); { allocate space for address}
+      emit_reg(A_PUSH,S_L,R_EAX);
+      getselftoeax(8);
+      loadvmttoeax;
+      loadmethodoffstoeax;
+      { mov %eax,4(%esp) }
+      emit_reg_ref(A_MOV,S_L,R_EAX,new_reference(R_ESP,4));
+      { pop  %eax }
+      emit_reg(A_POP,S_L,R_EAX);
+      { ret  ; jump to the address }
+      emit_none(A_RET,S_L);
+    end
+  { case 4 }
+  else if po_virtualmethod in procdef^.procoptions then
+    begin
+      getselftoeax(0);
+      loadvmttoeax;
+      op_oneaxmethodaddr(A_JMP);
+    end
+  { case 0 }
+  else
+    begin
+      emitcall(procdef^.mangledname);
+    end;
+  exprasmlist:=oldexprasmlist;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-11-04 14:25:23  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.1.2.2  2000/06/15 15:05:30  kaz
+    * An minor bug fix
+
+  Revision 1.1.2.1  2000/06/15 06:26:34  kaz
+    * Initial version
+}

compiler/i386/n386ld.pas

@@ -315,9 +315,7 @@ implementation
                               begin
                                  hregister:=left.location.register;
                                  ungetregister32(left.location.register);
-                                 if (left.resulttype^.deftype<>classrefdef) and
-                                    (left.resulttype^.deftype<>objectdef) and
-                                    not(pobjectdef(left.resulttype)^.is_class) then
+                                 if is_object(left.resulttype) then
                                    CGMessage(cg_e_illegal_expression);
                               end;
 
@@ -328,7 +326,7 @@ implementation
                                  getexplicitregister32(R_EDI);
 {$endif noAllocEdi}
                                  hregister:=R_EDI;
-                                 if pobjectdef(left.resulttype)^.is_class then
+                                 if is_class_or_interface(left.resulttype) then
                                    emit_ref_reg(A_MOV,S_L,
                                      newreference(left.location.reference),R_EDI)
                                  else
@@ -555,6 +553,10 @@ implementation
                   del_reference(right.location.reference);
                 end
            end
+        else if is_interfacecom(left.resulttype) then
+          begin
+             loadinterfacecom(self);
+          end
         else case right.location.loc of
             LOC_REFERENCE,
             LOC_MEM : begin
@@ -624,8 +626,7 @@ implementation
                          else
                            begin
                               if (right.resulttype^.needs_inittable) and
-                                ( (right.resulttype^.deftype<>objectdef) or
-                                  not(pobjectdef(right.resulttype)^.is_class)) then
+                                  not(is_class(right.resulttype)) then
                                 begin
                                    { this would be a problem }
                                    if not(left.resulttype^.needs_inittable) then
@@ -1064,7 +1065,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.2  2000-10-31 22:02:56  peter
+  Revision 1.3  2000-11-04 14:25:23  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.2  2000/10/31 22:02:56  peter
     * symtable splitted, no real code changes
 
   Revision 1.1  2000/10/15 09:33:31  peter

compiler/i386/n386mem.pas

@@ -370,9 +370,8 @@ implementation
          secondpass(left);
          if codegenerror then
            exit;
-         { classes must be dereferenced implicit }
-         if (left.resulttype^.deftype=objectdef) and
-           pobjectdef(left.resulttype)^.is_class then
+         { classes and interfaces must be dereferenced implicit }
+         if is_class_or_interface(left.resulttype) then
            begin
              reset_reference(location.reference);
              case left.location.loc of
@@ -399,6 +398,11 @@ implementation
                   end;
              end;
            end
+         else if is_interfacecom(left.resulttype) then
+           begin
+              gettempintfcomreference(location.reference);
+              emit_mov_loc_ref(left.location,location.reference,S_L,false);
+           end
          else
            set_location(location,left.location);
 
@@ -895,9 +899,7 @@ implementation
          reset_reference(location.reference);
          getexplicitregister32(R_ESI);
          if (resulttype^.deftype=classrefdef) or
-           ((resulttype^.deftype=objectdef)
-             and pobjectdef(resulttype)^.is_class
-           ) then
+           is_class(resulttype) then
            location.register:=R_ESI
          else
            location.reference.base:=R_ESI;
@@ -938,8 +940,7 @@ implementation
                  end
                else
                 { call can have happend with a property }
-                if (left.resulttype^.deftype=objectdef) and
-                   pobjectdef(left.resulttype)^.is_class then
+                if is_class_or_interface(left.resulttype) then
                  begin
 {$ifndef noAllocEdi}
                     getexplicitregister32(R_EDI);
@@ -1052,7 +1053,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.4  2000-10-31 22:02:57  peter
+  Revision 1.5  2000-11-04 14:25:24  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.4  2000/10/31 22:02:57  peter
     * symtable splitted, no real code changes
 
   Revision 1.3  2000/10/31 14:18:53  jonas

compiler/i386/n386util.pas

@@ -43,6 +43,7 @@ interface
     procedure loadshortstring(source,dest : tnode);
     procedure loadlongstring(p:tbinarynode);
     procedure loadansi2short(source,dest : tnode);
+    procedure loadinterfacecom(p: tbinarynode);
 
     procedure maketojumpbool(p : tnode);
     procedure emitoverflowcheck(p:tnode);
@@ -696,8 +697,8 @@ implementation
                            ) and
                            (p.resulttype^.size<=4)
                           ) or
-                          ((p.resulttype^.deftype=objectdef) and
-                           pobjectdef(p.resulttype)^.is_class) then
+                          is_class(p.resulttype) or
+                          is_interface(p.resulttype) then
                          begin
                             if (p.resulttype^.size>2) or
                                ((alignment=4) and (p.resulttype^.size>0)) then
@@ -1311,11 +1312,61 @@ implementation
          maybe_loadesi;
       end;
 
+    procedure loadinterfacecom(p: tbinarynode);
+    {
+      copies an com interface from n.right to n.left, we
+      assume, that both sides are com interface, firstassignement have
+      to take care of that, an com interface can't be a register variable
+    }
+      var
+         pushed : tpushed;
+         ungettemp : boolean;
+      begin
+         { before pushing any parameter, we have to save all used      }
+         { registers, but before that we have to release the       }
+         { registers of that node to save uneccessary pushed       }
+         { so be careful, if you think you can optimize that code (FK) }
+
+         { nevertheless, this has to be changed, because otherwise the }
+         { register is released before it's contents are pushed ->     }
+         { problems with the optimizer (JM)                         }
+         del_reference(p.left.location.reference);
+         ungettemp:=false;
+         case p.right.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 pushusedregisters(pushed, $ff xor ($80 shr byte(p.right.location.register)));
+                 exprasmlist^.concat(new(paicpu,op_reg(A_PUSH,S_L,p.right.location.register)));
+                 ungetregister32(p.right.location.register);
+              end;
+            LOC_REFERENCE,LOC_MEM:
+              begin
+                 pushusedregisters(pushed,$ff
+                   xor ($80 shr byte(p.right.location.reference.base))
+                   xor ($80 shr byte(p.right.location.reference.index)));
+                 emit_push_mem(p.right.location.reference);
+                 del_reference(p.right.location.reference);
+                 ungettemp:=true;
+              end;
+         end;
+         emitpushreferenceaddr(p.left.location.reference);
+         del_reference(p.left.location.reference);
+         emitcall('FPC_INTF_ASSIGN');
+         maybe_loadesi;
+         popusedregisters(pushed);
+         if ungettemp then
+           ungetiftemp(p.right.location.reference);
+      end;
+
+
 
 end.
 {
   $Log$
-  Revision 1.2  2000-10-31 22:02:57  peter
+  Revision 1.3  2000-11-04 14:25:25  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.2  2000/10/31 22:02:57  peter
     * symtable splitted, no real code changes
 
   Revision 1.1  2000/10/15 09:33:32  peter

compiler/msgidx.inc

@@ -74,6 +74,7 @@ const
   scan_e_invalid_maxfpureg_value=02055;
   scan_w_only_one_resourcefile_supported=02056;
   scan_w_macro_support_turned_off=02057;
+  scan_e_invalid_interface_type=02058;
   parser_e_syntax_error=03000;
   parser_w_proc_far_ignored=03001;
   parser_w_proc_near_ignored=03002;
@@ -239,6 +240,11 @@ const
   parser_f_need_objfpc_or_delphi_mode=03162;
   parser_e_no_export_with_index_for_target=03163;
   parser_e_no_export_of_variables_for_target=03164;
+  parser_e_improper_guid_syntax=03165;
+  parser_f_interface_cant_have_variables=03166;
+  parser_f_interface_cant_have_constr_or_destr=03167;
+  parser_w_interface_mapping_notfound=03168;
+  parser_e_interface_id_expected=03169;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -273,6 +279,7 @@ const
   type_e_no_assign_to_addr=04031;
   type_e_no_assign_to_const=04032;
   type_e_array_required=04033;
+  type_e_interface_type_expected=04034;
   sym_e_id_not_found=05000;
   sym_f_internal_error_in_symtablestack=05001;
   sym_e_duplicate_id=05002;
@@ -557,9 +564,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 31225;
+  MsgTxtSize = 31647;
 
   MsgIdxMax : array[1..20] of longint=(
-    17,58,165,34,41,41,86,14,35,40,
+    17,59,170,35,41,41,86,14,35,40,
     26,1,1,1,1,1,1,1,1,1
   );

compiler/msgtxt.inc

@@ -1,7 +1,7 @@
 {$ifdef Delphi}
-const msgtxt : array[0..000130] of string[240]=(
+const msgtxt : array[0..000131] of string[240]=(
 {$else Delphi}
-const msgtxt : array[0..000130,1..240] of char=(
+const msgtxt : array[0..000131,1..240] of char=(
 {$endif Delphi}
   '01000_T_Compiler: $1'#000+
   '01001_D_Compiler OS: $1'#000+
@@ -81,526 +81,538 @@ const msgtxt : array[0..000130,1..240] of char=(
   '02055_E_Illegal value for FPU register limit'#000+
   '02056_W_Only one resource file is supported for this target'#000+
   '02057_W_Macro support has been turned off'#000+
+  '02058_E_Illegal interface type specified.',' Valids are COM, CORBA or D'+
+  'EFAULT.'#000+
   '03000_E_Parser - Syntax Error'#000+
-  '03001_W_Pro','cedure type FAR ignored'#000+
+  '03001_W_Procedure type FAR ignored'#000+
   '03002_W_Procedure type NEAR ignored'#000+
   '03003_W_Procedure type INTERRUPT ignored for not i386'#000+
   '03004_E_INTERRUPT procedure can'#039't be nested'#000+
-  '03005_W_Procedure type "$1" ignored'#000+
-  '03006_E_Not all declarations of "$1" are decla','red with OVERLOAD'#000+
+  '03005_','W_Procedure type "$1" ignored'#000+
+  '03006_E_Not all declarations of "$1" are declared with OVERLOAD'#000+
   '03007_E_No DLL File specified'#000+
   '03008_E_Duplicate exported function name "$1"'#000+
   '03009_E_Duplicate exported function index $1'#000+
-  '03010_E_Invalid index for exported function'#000+
-  '03011_W_Relocatable DLL or executable $1 debug info does ','not work, d'+
-  'isabled.'#000+
+  '03010_E_Invalid index for',' exported function'#000+
+  '03011_W_Relocatable DLL or executable $1 debug info does not work, dis'+
+  'abled.'#000+
   '03012_W_To allow debugging for win32 code you need to disable relocati'+
   'on with -WN option'#000+
   '03013_E_Constructor name must be INIT'#000+
-  '03014_E_Destructor name must be DONE'#000+
+  '03014_E_Destructo','r name must be DONE'#000+
   '03015_E_Illegal open parameter'#000+
-  '03016_E_Procedure type IN','LINE not supported'#000+
+  '03016_E_Procedure type INLINE not supported'#000+
   '03017_W_Private methods shouldn'#039't be VIRTUAL'#000+
   '03018_W_Constructor should be public'#000+
   '03019_W_Destructor should be public'#000+
-  '03020_N_Class should have one destructor only'#000+
+  '03020_N_Class should have o','ne destructor only'#000+
   '03021_E_Local class definitions are not allowed'#000+
-  '03022_F_A','nonym class definitions are not allowed'#000+
+  '03022_F_Anonym class definitions are not allowed'#000+
   '03023_E_The object "$1" has no VMT'#000+
   '03024_E_Illegal parameter list'#000+
   '03025_E_Wrong parameter type specified for arg no. "$1"'#000+
-  '03026_E_Wrong amount of parameters specified'#000+
-  '03027_E_overloaded identifier "$1','" isn'#039't a function'#000+
+  '03','026_E_Wrong amount of parameters specified'#000+
+  '03027_E_overloaded identifier "$1" isn'#039't a function'#000+
   '03028_E_overloaded functions have the same parameter list'#000+
   '03029_E_function header doesn'#039't match the forward declaration "$1"'+
   #000+
-  '03030_E_function header "$1" doesn'#039't match forward : var name chan'+
-  'ges $2 => $3'#000+
-  '03031_N_Values in',' enumeration types have to be ascending'#000+
+  '03030_E_function hea','der "$1" doesn'#039't match forward : var name ch'+
+  'anges $2 => $3'#000+
+  '03031_N_Values in enumeration types have to be ascending'#000+
   '03032_N_Interface and implementation names are different "$1" => "$2"'#000+
-  '03033_E_With can not be used for variables in a different segment'#000+
+  '03033_E_With can not be used for variables in a differ','ent segment'#000+
   '03034_E_function nesting > 31'#000+
-  '03035_E_range check error while ev','aluating constants'#000+
+  '03035_E_range check error while evaluating constants'#000+
   '03036_W_range check error while evaluating constants'#000+
   '03037_E_duplicate case label'#000+
   '03038_E_Upper bound of case range is less than lower bound'#000+
-  '03039_E_typed constants of classes are not allowed'#000+
-  '03040_E_functions variables o','f overloaded functions are not allowed'#000+
+  '0303','9_E_typed constants of classes are not allowed'#000+
+  '03040_E_functions variables of overloaded functions are not allowed'#000+
   '03041_E_string length must be a value from 1 to 255'#000+
   '03042_W_use extended syntax of NEW and DISPOSE for instances of object'+
   's'#000+
-  '03043_W_use of NEW or DISPOSE for untyped pointers is meaningless'#000+
-  '03044_E_use',' of NEW or DISPOSE is not possible for untyped pointers'#000+
+  '0','3043_W_use of NEW or DISPOSE for untyped pointers is meaningless'#000+
+  '03044_E_use of NEW or DISPOSE is not possible for untyped pointers'#000+
   '03045_E_class identifier expected'#000+
   '03046_E_type identifier not allowed here'#000+
-  '03047_E_method identifier expected'#000+
+  '03047_E_method identifier expecte','d'#000+
   '03048_E_function header doesn'#039't match any method of this class "$1'+
   '"'#000+
-  '03049_','P_procedure/function $1'#000+
+  '03049_P_procedure/function $1'#000+
   '03050_E_Illegal floating point constant'#000+
   '03051_E_FAIL can be used in constructors only'#000+
   '03052_E_Destructors can'#039't have parameters'#000+
-  '03053_E_Only class methods can be referred with class references'#000+
-  '03054_E_Only class meth','ods can be accessed in class methods'#000+
+  '03053_E_Only',' class methods can be referred with class references'#000+
+  '03054_E_Only class methods can be accessed in class methods'#000+
   '03055_E_Constant and CASE types do not match'#000+
   '03056_E_The symbol can'#039't be exported from a library'#000+
-  '03057_W_An inherited method is hidden by "$1"'#000+
-  '03058_E_There is no method in an ancestor class to be overri','dden: "$'+
-  '1"'#000+
+  '03057_W_An inherited method is',' hidden by "$1"'#000+
+  '03058_E_There is no method in an ancestor class to be overridden: "$1"'+
+  #000+
   '03059_E_No member is provided to access property'#000+
   '03060_W_Stored prorperty directive is not yet implemented'#000+
   '03061_E_Illegal symbol for property access'#000+
-  '03062_E_Cannot access a protected field of an object here'#000+
-  '03063_E_Cannot access',' a private field of an object here'#000+
+  '030','62_E_Cannot access a protected field of an object here'#000+
+  '03063_E_Cannot access a private field of an object here'#000+
   '03064_W_overloaded method of virtual method should be virtual: "$1"'#000+
-  '03065_W_overloaded method of non-virtual method should be non-virtual:'+
-  ' "$1"'#000+
-  '03066_E_overloaded methods which are virtual must have the sa','me retu'+
-  'rn type: "$1"'#000+
+  '03065_W_overloaded method of non-virtual method should be non','-virtua'+
+  'l: "$1"'#000+
+  '03066_E_overloaded methods which are virtual must have the same return'+
+  ' type: "$1"'#000+
   '03067_E_EXPORT declared functions can'#039't be nested'#000+
   '03068_E_methods can'#039't be EXPORTed'#000+
-  '03069_E_call by var parameters have to match exactly: Got "$1" expecte'+
-  'd "$2"'#000+
+  '03069_E_call by var parameters have to match exactly: Got "','$1" expec'+
+  'ted "$2"'#000+
   '03070_E_Class isn'#039't a parent class of the current class'#000+
-  '03','071_E_SELF is only allowed in methods'#000+
+  '03071_E_SELF is only allowed in methods'#000+
   '03072_E_methods can be only in other methods called direct with type i'+
   'dentifier of the class'#000+
   '03073_E_Illegal use of '#039':'#039#000+
-  '03074_E_range check error in set constructor or duplicate set element'#000+
-  '03075_E_Poin','ter to object expected'#000+
+  '03074_','E_range check error in set constructor or duplicate set elemen'+
+  't'#000+
+  '03075_E_Pointer to object expected'#000+
   '03076_E_Expression must be constructor call'#000+
   '03077_E_Expression must be destructor call'#000+
   '03078_E_Illegal order of record elements'#000+
-  '03079_E_Expression type must be class or record type'#000+
-  '03080_E_Procedures can'#039't return a va','lue'#000+
+  '03079_E_Expre','ssion type must be class or record type'#000+
+  '03080_E_Procedures can'#039't return a value'#000+
   '03081_E_constructors and destructors must be methods'#000+
   '03082_E_Operator is not overloaded'#000+
   '03083_E_Impossible to overload assignment for equal types'#000+
-  '03084_E_Impossible operator overload'#000+
+  '03084_E_Imposs','ible operator overload'#000+
   '03085_E_Re-raise isn'#039't possible there'#000+
-  '03086_E_The ext','ended syntax of new or dispose isn'#039't allowed for '+
-  'a class'#000+
+  '03086_E_The extended syntax of new or dispose isn'#039't allowed for a '+
+  'class'#000+
   '03087_E_Assembler incompatible with function return type'#000+
   '03088_E_Procedure overloading is switched off'#000+
-  '03089_E_It is not possible to overload this operator (overload = inste'+
-  'ad)'#000+
-  '03090_','E_Comparative operator must return a boolean value'#000+
+  '0308','9_E_It is not possible to overload this operator (overload = ins'+
+  'tead)'#000+
+  '03090_E_Comparative operator must return a boolean value'#000+
   '03091_E_Only virtual methods can be abstract'#000+
   '03092_F_Use of unsupported feature!'#000+
-  '03093_E_The mix of CLASSES and OBJECTS isn'#039't allowed'#000+
-  '03094_W_Unknown procedure directive had to be ignored: ','"$1"'#000+
+  '03093_E_The mix of different kin','d of objects (class, object, interfa'+
+  'ce, raw interface etc) isn'#039't allowed'#000+
+  '03094_W_Unknown procedure directive had to be ignored: "$1"'#000+
   '03095_E_absolute can only be associated to ONE variable'#000+
-  '03096_E_absolute can only be associated a var or const'#000+
+  '03096_E_absolute can only be associated a var or co','nst'#000+
   '03097_E_Only ONE variable can be initialized'#000+
   '03098_E_Abstract methods shouldn'#039't have any definition (with funct'+
   'ion body)'#000+
-  '030','99_E_This overloaded function can'#039't be local (must be exporte'+
-  'd)'#000+
-  '03100_W_Virtual methods are used without a constructor in "$1"'#000+
+  '03099_E_This overloaded function can'#039't be local (must be exported)'+
+  #000+
+  '03100_W_Virtual methods are used without a const','ructor in "$1"'#000+
   '03101_M_Macro defined: $1'#000+
   '03102_M_Macro undefined: $1'#000+
   '03103_M_Macro $1 set to $2'#000+
   '03104_I_Compiling $1'#000+
-  '03105_U_Par','sing interface of unit $1'#000+
+  '03105_U_Parsing interface of unit $1'#000+
   '03106_U_Parsing implementation of $1'#000+
   '03107_D_Compiling $1 for the second time'#000+
-  '03108_E_Array properties aren'#039't allowed here'#000+
+  '03108_E_','Array properties aren'#039't allowed here'#000+
   '03109_E_No property found to override'#000+
-  '03110_E_Only one default property is allowed, found i','nherited defaul'+
-  't property in class "$1"'#000+
+  '03110_E_Only one default property is allowed, found inherited default '+
+  'property in class "$1"'#000+
   '03111_E_The default property must be an array property'#000+
-  '03112_E_Virtual constructors are only supported in class object model'#000+
+  '03112_E_Virtual c','onstructors are only supported in class object mode'+
+  'l'#000+
   '03113_E_No default property available'#000+
-  '03114_E_The class can'#039't have a publis','hed section, use the {$M+} '+
-  'switch'#000+
+  '03114_E_The class can'#039't have a published section, use the {$M+} sw'+
+  'itch'#000+
   '03115_E_Forward declaration of class "$1" must be resolved here to use'+
-  ' the class as ancestor'#000+
+  ' the cla','ss as ancestor'#000+
   '03116_E_Local operators not supported'#000+
   '03117_E_Procedure directive "$1" not allowed in interface section'#000+
-  '03118_E_P','rocedure directive "$1" not allowed in implementation secti'+
-  'on'#000+
-  '03119_E_Procedure directive "$1" not allowed in procvar declaration'#000+
+  '03118_E_Procedure directive "$1" not allowed in implementation section'+
+  #000+
+  '03119_E_Procedure directive "$1" not allowed in pr','ocvar declaration'#000+
   '03120_E_Function is already declared Public/Forward "$1"'#000+
   '03121_E_Can'#039't use both EXPORT and EXTERNAL'#000+
-  '03122_E_NA','ME keyword expected'#000+
+  '03122_E_NAME keyword expected'#000+
   '03123_W_"$1" not yet supported inside inline procedure/function'#000+
   '03124_W_Inlining disabled'#000+
-  '03125_I_Writing Browser log $1'#000+
+  '03','125_I_Writing Browser log $1'#000+
   '03126_H_may be pointer dereference is missing'#000+
   '03127_F_Selected assembler reader not supported'#000+
-  '03128','_E_Procedure directive "$1" has conflicts with other directives'+
-  #000+
-  '03129_E_Calling convention doesn'#039't match forward'#000+
+  '03128_E_Procedure directive "$1" has conflicts with other directives'#000+
+  '03129_E_Calling convention doesn'#039't match forward',#000+
   '03130_E_Register calling (fastcall) not supported'#000+
   '03131_E_Property can'#039't have a default value'#000+
-  '03132_E_The default value of a pr','operty must be constant'#000+
+  '03132_E_The default value of a property must be constant'#000+
   '03133_E_Symbol can'#039't be published, can be only a class'#000+
-  '03134_E_That kind of property can'#039't be published'#000+
+  '03134_E_That kind of property can',#039't be published'#000+
   '03135_W_Empty import name specified'#000+
   '03136_W_An import name is required'#000+
-  '03137_E_Function internal name changed af','ter use of function'#000+
+  '03137_E_Function internal name changed after use of function'#000+
   '03138_E_Division by zero'#000+
   '03139_E_Invalid floating point operation'#000+
-  '03140_E_Upper bound of range is less than lower bound'#000+
+  '03140_E_Upper bound of ran','ge is less than lower bound'#000+
   '03141_W_string "$1" is longer than "$2"'#000+
   '03142_E_string length is larger than array of char length'#000+
-  '03','143_E_Illegal expression after message directive'#000+
-  '03144_E_Message handlers can take only one call by ref. parameter'#000+
+  '03143_E_Illegal expression after message directive'#000+
+  '03144_E_Message handlers can take only one call by ref. paramet','er'#000+
   '03145_E_Duplicate message label: "$1"'#000+
   '03146_E_Self can be only an explicit parameter in message handlers'#000+
-  '03147_E_Threadvars c','an be only static or global'#000+
+  '03147_E_Threadvars can be only static or global'#000+
   '03148_F_Direct assembler not supported for binary output format'#000+
-  '03149_W_Don'#039't load OBJPAS unit manual, use {$mode objfpc} or {$mod'+
-  'e delphi} instead'#000+
+  '03149_W_Don'#039't load O','BJPAS unit manual, use {$mode objfpc} or {$m'+
+  'ode delphi} instead'#000+
   '03150_E_OVERRIDE can'#039't be used in objects'#000+
-  '03151_E_Data types whi','ch requires initialization/finalization can'#039+
-  't be used in variant records'#000+
-  '03152_E_Resourcestrings can be only static or global'#000+
+  '03151_E_Data types which requires initialization/finalization can'#039't'+
+  ' be used in variant records'#000+
+  '03152_E_Resourcestrings can be only sta','tic or global'#000+
   '03153_E_Exit with argument can'#039't be used here'#000+
   '03154_E_The type of the storage symbol must be boolean'#000+
-  '03155_E_This ','symbol isn'#039't allowed as storage symbol'#000+
+  '03155_E_This symbol isn'#039't allowed as storage symbol'#000+
   '03156_E_Only class which are compiled in $M+ mode can be published'#000+
-  '03157_E_Procedure directive expected'#000+
+  '03157_','E_Procedure directive expected'#000+
   '03158_E_The value for a property index must be of an ordinal type'#000+
-  '03159_E_Procedure name to short',' to be exported'#000+
+  '03159_E_Procedure name to short to be exported'#000+
   '03160_E_No DEFFILE entry can be generated for unit global vars'#000+
-  '03161_E_Compile without -WD option'#000+
+  '03161_E_Compile without -WD optio','n'#000+
   '03162_F_You need ObjFpc (-S2) or Delphi (-Sd) mode to compile this mod'+
   'ule'#000+
   '03163_E_Can'#039't export with index under $1'#000+
-  '03164_E_Exp','orting of variables is not supported under $1'#000+
+  '03164_E_Exporting of variables is not supported under $1'#000+
+  '03165_E_Improper GUID syntax'#000+
+  '03166_F_An interface can'#039't have varia','bles'#000+
+  '03167_F_An interface can'#039't have constructor or destructor'#000+
+  '03168_W_Procedure named $1 not found that is suitable for implementing'+
+  ' the $2.$3'#000+
+  '03169_E_interface identifier expected'#000+
   '04000_E_Type mismatch'#000+
-  '04001_E_Incompatible types: got "$1" expected "$2"'#000+
+  '04001_E_Incompatible types: got "$1"',' expected "$2"'#000+
   '04002_E_Type mismatch between "$1" and "$2"'#000+
   '04003_E_Type identifier expected'#000+
   '04004_E_Variable identifier expected'#000+
-  '04005_E','_Integer expression expected, but got "$1"'#000+
+  '04005_E_Integer expression expected, but got "$1"'#000+
   '04006_E_Boolean expression expected, but got "$1"'#000+
-  '04007_E_Ordinal expression expected'#000+
+  '04007_E_Ord','inal expression expected'#000+
   '04008_E_pointer type expected, but got "$1"'#000+
   '04009_E_class type expected, but got "$1"'#000+
-  '04010_E_Variable or type ','indentifier expected'#000+
+  '04010_E_Variable or type indentifier expected'#000+
   '04011_E_Can'#039't evaluate constant expression'#000+
-  '04012_E_Set elements are not compatible'#000+
+  '04012_E_Set elements are not compatible'#000,
   '04013_E_Operation not implemented for sets'#000+
   '04014_W_Automatic type conversion from floating type to COMP which is '+
   'an integer type'#000+
-  '04015_H','_use DIV instead to get an integer result'#000+
+  '04015_H_use DIV instead to get an integer result'#000+
   '04016_E_string types doesn'#039't match, because of $V+ mode'#000+
-  '04017_E_succ or pred on enums with assignments not possible'#000+
+  '04017_','E_succ or pred on enums with assignments not possible'#000+
   '04018_E_Can'#039't read or write variables of this type'#000+
-  '04019_E_Can'#039't use readln or wri','teln on typed file'#000+
+  '04019_E_Can'#039't use readln or writeln on typed file'#000+
   '04020_E_Can'#039't use read or write on untyped file.'#000+
-  '04021_E_Type conflict between set elements'#000+
+  '04021_E_Type conflict between set el','ements'#000+
   '04022_W_lo/hi(dword/qword) returns the upper/lower word/dword'#000+
   '04023_E_Integer or real expression expected'#000+
-  '04024_E_Wrong type "$1"',' in array constructor'#000+
+  '04024_E_Wrong type "$1" in array constructor'#000+
   '04025_E_Incompatible type for arg no. $1: Got "$2", expected "$3"'#000+
-  '04026_E_Method (variable) and Procedure (variable) are not compatible'#000+
+  '04026_E_Method (','variable) and Procedure (variable) are not compatibl'+
+  'e'#000+
   '04027_E_Illegal constant passed to internal math function'#000+
-  '04028_E_Can'#039't get the ad','dress of constants'#000+
+  '04028_E_Can'#039't get the address of constants'#000+
   '04029_E_Argument can'#039't be assigned to'#000+
-  '04030_E_Can'#039't assign local procedure/function to procedure variabl'+
-  'e'#000+
+  '04030_E_Can'#039't assign local procedure/function t','o procedure varia'+
+  'ble'#000+
   '04031_E_Can'#039't assign values to an address'#000+
   '04032_E_Can'#039't assign values to const variable'#000+
-  '04033_E_Array type required',#000+
+  '04033_E_Array type required'#000+
+  '04034_E_interface type expected, but got "$1"'#000+
   '05000_E_Identifier not found "$1"'#000+
-  '05001_F_Internal Error in SymTableStack()'#000+
+  '05001_F_Internal Error ','in SymTableStack()'#000+
   '05002_E_Duplicate identifier "$1"'#000+
   '05003_H_Identifier already defined in $1 at line $2'#000+
   '05004_E_Unknown identifier "$1"'#000+
   '05005_E_Forward declaration not solved "$1"'#000+
-  '0','5006_F_Identifier type already defined as type'#000+
-  '05007_E_Error in type definition'#000+
+  '05006_F_Identifier type already defined as type'#000+
+  '05007_E_Err','or in type definition'#000+
   '05008_E_Type identifier not defined'#000+
   '05009_E_Forward type not resolved "$1"'#000+
   '05010_E_Only static variables can be used in static methods or outside'+
   ' methods'#000+
-  '05011_','E_Invalid call to tvarsym.mangledname()'#000+
-  '05012_F_record or class type expected'#000+
+  '05011_E_Invalid call to tvarsym.mangledname()'#000+
+  '05012_F_record or ','class type expected'#000+
   '05013_E_Instances of classes or objects with an abstract method are no'+
   't allowed'#000+
   '05014_W_Label not defined "$1"'#000+
   '05015_E_Label used but not defined "$1"'#000+
-  '05016_E_Ill','egal label declaration'#000+
-  '05017_E_GOTO and LABEL are not supported (use switch -Sg)'#000+
+  '05016_E_Illegal label declaration'#000+
+  '05017_E_GOTO and LABEL are not supp','orted (use switch -Sg)'#000+
   '05018_E_Label not found'#000+
   '05019_E_identifier isn'#039't a label'#000+
   '05020_E_label already defined'#000+
   '05021_E_illegal type declaration of set elements'#000+
-  '05022_E_Forward class d','efinition not resolved "$1"'#000+
-  '05023_H_Unit "$1" not used in $2'#000+
+  '05022_E_Forward class definition not resolved "$1"'#000+
+  '05023_H_Unit "$1" not used in ','$2'#000+
   '05024_H_Parameter "$1" not used'#000+
   '05025_N_Local variable "$1" not used'#000+
   '05026_H_Value parameter "$1" is assigned but never used'#000+
-  '05027_N_Local variable "$1" is assigned but never used',#000+
+  '05027_N_Local variable "$1" is assigned but never used'#000+
   '05028_H_Local $1 "$2" is not used'#000+
-  '05029_N_Private field "$1.$2" is never used'#000+
+  '05029_N_Private field "','$1.$2" is never used'#000+
   '05030_N_Private field "$1.$2" is assigned but never used'#000+
   '05031_N_Private method "$1.$2" never used'#000+
   '05032_E_Set type expected'#000+
-  '05033_W_Function result does not see','m to be set'#000+
-  '05034_W_Type "$1" is not aligned correctly in current record for C'#000+
+  '05033_W_Function result does not seem to be set'#000+
+  '05034_W_Type "$1" is not aligned correctly in ','current record for C'#000+
   '05035_E_Unknown record field identifier "$1"'#000+
   '05036_W_Local variable "$1" does not seem to be initialized'#000+
   '05037_W_Variable "$1" does not seem to be initialized'#000+
-  '05','038_E_identifier idents no member "$1"'#000+
-  '05039_B_Found declaration: $1'#000+
+  '05038_E_identifier idents no member "$1"'#000+
+  '05039_B_Found decla','ration: $1'#000+
   '05040_E_Data segment too large (max. 2GB)'#000+
   '06000_E_BREAK not allowed'#000+
   '06001_E_CONTINUE not allowed'#000+
   '06002_E_Expression too complicated - FPU stack overflow'#000+
-  '06003_E_Illegal ex','pression'#000+
+  '06003_E_Illegal expression'#000+
   '06004_E_Invalid integer expression'#000+
-  '06005_E_Illegal qualifier'#000+
+  '06005_E_Illega','l qualifier'#000+
   '06006_E_High range limit < low range limit'#000+
   '06007_E_Illegal counter variable'#000+
   '06008_E_Can'#039't determine which overloaded function to call'#000+
-  '06009_E_Parameter list size exceeds ','65535 bytes'#000+
+  '06009_E_Parameter list size exceeds 65535 bytes'#000+
   '06010_E_Illegal type conversion'#000+
-  '06011_D_Conversion between ordinals and pointers is not portable acros'+
-  's platforms'#000+
+  '06011_D_Conver','sion between ordinals and pointers is not portable acr'+
+  'oss platforms'#000+
   '06012_E_File types must be var parameters'#000+
   '06013_E_The use of a far pointer isn'#039't allowed there'#000+
-  '06014_E_illegal cal','l by reference parameters'#000+
-  '06015_E_EXPORT declared functions can'#039't be called'#000+
+  '06014_E_illegal call by reference parameters'#000+
+  '06015_E_EXPORT declared function','s can'#039't be called'#000+
   '06016_W_Possible illegal call of constructor or destructor (doesn'#039't'+
   ' match to this context)'#000+
   '06017_N_Inefficient code'#000+
   '06018_W_unreachable code'#000+
-  '06019_E_procedure call ','with stackframe ESP/SP'#000+
-  '06020_E_Abstract methods can'#039't be called directly'#000+
+  '06019_E_procedure call with stackframe ESP/SP'#000+
+  '06020_E_Abstract methods can'#039't be c','alled directly'#000+
   '06021_F_Internal Error in getfloatreg(), allocation failure'#000+
   '06022_F_Unknown float type'#000+
   '06023_F_SecondVecn() base defined twice'#000+
   '06024_F_Extended cg68k not supported'#000+
-  '060','25_F_32-bit unsigned not supported in MC68000 mode'#000+
-  '06026_F_Internal Error in secondinline()'#000+
+  '06025_F_32-bit unsigned not supported in MC68000 mode'#000+
+  '06026_F','_Internal Error in secondinline()'#000+
   '06027_D_Register $1 weight $2 $3'#000+
   '06028_E_Stack limit excedeed in local routine'#000+
   '06029_D_Stack frame is omitted'#000+
-  '06030_W_Range check for 64 bit integer','s is not supported on this tar'+
-  'get'#000+
-  '06031_E_Object or class methods can'#039't be inline.'#000+
+  '06030_W_Range check for 64 bit integers is not supported on this targe'+
+  't'#000+
+  '06031_E_Object or class ','methods can'#039't be inline.'#000+
   '06032_E_Procvar calls can'#039't be inline.'#000+
   '06033_E_No code for inline procedure stored'#000+
   '06034_E_Direct call of interrupt procedure "$1" is not possible'#000+
-  '06035_E_El','ement zero of an ansi/wide- or longstring can'#039't be acc'+
-  'essed, use (set)length instead'#000+
+  '06035_E_Element zero of an ansi/wide- or longstring can'#039't be acces'+
+  'se','d, use (set)length instead'#000+
   '06036_E_Include and exclude not implemented in this case'#000+
   '06037_E_Constructors or destructors can not be called inside a '#039'wi'+
   'th'#039' clause'#000+
-  '06038_E_Cannot call m','essage handler method directly'#000+
-  '06039_E_Jump in or outside of an exception block'#000+
+  '06038_E_Cannot call message handler method directly'#000+
+  '06039_E_Jump in or outside ','of an exception block'#000+
   '06040_E_Control flow statements aren'#039't allowed in a finally block'#000+
   '07000_D_Starting $1 styled assembler parsing'#000+
   '07001_D_Finished $1 styled assembler parsing'#000+
-  '0700','2_E_Non-label pattern contains @'#000+
-  '07003_W_Override operator not supported'#000+
+  '07002_E_Non-label pattern contains @'#000+
+  '07003_W_Override operator',' not supported'#000+
   '07004_E_Error building record offset'#000+
   '07005_E_OFFSET used without identifier'#000+
   '07006_E_TYPE used without identifier'#000+
   '07007_E_Cannot use local variable or parameters here'#000+
-  '0','7008_E_need to use OFFSET here'#000+
-  '07009_E_need to use $ here'#000+
+  '07008_E_need to use OFFSET here'#000+
+  '07009_E_need to use $ here'#000,
   '07010_E_Cannot use multiple relocatable symbols'#000+
   '07011_E_Relocatable symbol can only be added'#000+
   '07012_E_Invalid constant expression'#000+
   '07013_E_Relocatable symbol is not allowed'#000+
-  '07014_E_Inv','alid reference syntax'#000+
-  '07015_E_You can not reach $1 from that code'#000+
+  '07014_E_Invalid reference syntax'#000+
+  '07015_E_You can not reach $1 from th','at code'#000+
   '07016_E_Local symbols/labels aren'#039't allowed as references'#000+
   '07017_E_Invalid base and index register usage'#000+
   '07018_W_Possible error in object field handling'#000+
-  '07019_E_Wrong scale fa','ctor specified'#000+
+  '07019_E_Wrong scale factor specified'#000+
   '07020_E_Multiple index register usage'#000+
-  '07021_E_Invalid operand type'#000+
+  '07021','_E_Invalid operand type'#000+
   '07022_E_Invalid string as opcode operand: $1'#000+
   '07023_W_@CODE and @DATA not supported'#000+
   '07024_E_Null label references are not allowed'#000+
-  '07025_E_Divide by zero in asm',' evaluator'#000+
+  '07025_E_Divide by zero in asm evaluator'#000+
   '07026_E_Illegal expression'#000+
-  '07027_E_escape sequence ignored: $1'#000+
+  '07027_E_escape seque','nce ignored: $1'#000+
   '07028_E_Invalid symbol reference'#000+
   '07029_W_Fwait can cause emulation problems with emu387'#000+
   '07030_W_FADD without operand translated into FADDP'#000+
-  '07031_W_ENTER instruction i','s not supported by Linux kernel'#000+
-  '07032_W_Calling an overload function in assembler'#000+
+  '07031_W_ENTER instruction is not supported by Linux kernel'#000+
+  '07032_W_Calling an overloa','d function in assembler'#000+
   '07033_E_Unsupported symbol type for operand'#000+
   '07034_E_Constant value out of bounds'#000+
   '07035_E_Error converting decimal $1'#000+
   '07036_E_Error converting octal $1'#000+
-  '07037_E','_Error converting binary $1'#000+
-  '07038_E_Error converting hexadecimal $1'#000+
+  '07037_E_Error converting binary $1'#000+
+  '07038_E_Error converting hexad','ecimal $1'#000+
   '07039_H_$1 translated to $2'#000+
   '07040_W_$1 is associated to an overloaded function'#000+
   '07041_E_Cannot use SELF outside a method'#000+
-  '07042_E_Cannot use OLDEBP outside a nested procedure',#000+
+  '07042_E_Cannot use OLDEBP outside a nested procedure'#000+
   '07084_E_Cannot use RESULT in this function'#000+
-  '07085_H_RESULT is register $1'#000+
+  '07085_H_RESULT',' is register $1'#000+
   '07043_W_Procedures can'#039't return any value in asm code'#000+
   '07044_E_SEG not supported'#000+
   '07045_E_Size suffix and destination or source size do not match'#000+
-  '07046_W_Size suffix an','d destination or source size do not match'#000+
-  '07047_E_Assembler syntax error'#000+
+  '07046_W_Size suffix and destination or source size do not match'#000+
+  '07047_E_Assemble','r syntax error'#000+
   '07048_E_Invalid combination of opcode and operands'#000+
   '07049_E_Assemler syntax error in operand'#000+
   '07050_E_Assemler syntax error in constant'#000+
-  '07051_E_Invalid String expression',#000+
+  '07051_E_Invalid String expression'#000+
   '07052_bit constant created for address'#000+
-  '07053_E_Unrecognized opcode $1'#000+
+  '07053_E_Unrecogniz','ed opcode $1'#000+
   '07054_E_Invalid or missing opcode'#000+
   '07055_E_Invalid combination of prefix and opcode: $1'#000+
   '07056_E_Invalid combination of override and opcode: $1'#000+
-  '07057_E_Too many operands o','n line'#000+
+  '07057_E_Too many operands on line'#000+
   '07058_W_NEAR ignored'#000+
   '07059_W_FAR ignored'#000+
-  '07060_E_Duplicate local symbol $1'#000+
+  '07060_E_Du','plicate local symbol $1'#000+
   '07061_E_Undefined local symbol $1'#000+
   '07062_E_Unknown label identifier $1'#000+
   '07063_E_Invalid register name'#000+
   '07064_E_Invalid floating point register name'#000+
-  '07065_E_NOR n','ot supported'#000+
+  '07065_E_NOR not supported'#000+
   '07066_W_Modulo not supported'#000+
-  '07067_E_Invalid floating point constant $1'#000+
+  '07067_E_Invalid ','floating point constant $1'#000+
   '07068_E_Invalid floating point expression'#000+
   '07069_E_Wrong symbol type'#000+
   '07070_E_Cannot index a local var or parameter with a register'#000+
-  '07071_E_Invalid segment o','verride expression'#000+
-  '07072_W_Identifier $1 supposed external'#000+
+  '07071_E_Invalid segment override expression'#000+
+  '07072_W_Identifier $1 supposed external',#000+
   '07073_E_Strings not allowed as constants'#000+
   '07074_No type of variable specified'#000+
   '07075_E_assembler code not returned to text section'#000+
   '07076_E_Not a directive or local symbol $1'#000+
-  '07077_E_U','sing a defined name as a local label'#000+
-  '07078_E_Dollar token is used without an identifier'#000+
+  '07077_E_Using a defined name as a local label'#000+
+  '07078_E_Dollar token ','is used without an identifier'#000+
   '07079_W_32bit constant created for address'#000+
   '07080_N_.align is target specific, use .balign or .p2align'#000+
-  '07081_E_Can'#039't access fields directly for parameter','s'#000+
-  '07082_E_Can'#039't access fields of objects/classes directly'#000+
+  '07081_E_Can'#039't access fields directly for parameters'#000+
+  '07082_E_Can'#039't access fields of objects/classes directly'#000,
   '07083_E_No size specified and unable to determine the size of the oper'+
   'ands'#000+
   '08000_F_Too many assembler files'#000+
   '08001_F_Selected assembler output not supported'#000+
-  '08002_F_Comp not supported',#000+
+  '08002_F_Comp not supported'#000+
   '08003_F_Direct not support for binary writers'#000+
-  '08004_E_Allocating of data is only allowed in bss section'#000+
+  '08004_E_All','ocating of data is only allowed in bss section'#000+
   '08005_F_No binary writer selected'#000+
   '08006_E_Asm: Opcode $1 not in table'#000+
   '08007_E_Asm: $1 invalid combination of opcode and operands'#000+
-  '08008_','E_Asm: 16 Bit references not supported'#000+
-  '08009_E_Asm: Invalid effective address'#000+
+  '08008_E_Asm: 16 Bit references not supported'#000+
+  '08009_E_Asm: Invali','d effective address'#000+
   '08010_E_Asm: Immediate or reference expected'#000+
   '08011_E_Asm: $1 value exceeds bounds $2'#000+
   '08012_E_Asm: Short jump is out of range $1'#000+
   '08013_E_Asm: Undefined label $1'#000+
-  '09','000_W_Source operating system redefined'#000+
-  '09001_I_Assembling (pipe) $1'#000+
+  '09000_W_Source operating system redefined'#000+
+  '09001_I_Assembling',' (pipe) $1'#000+
   '09002_E_Can'#039't create assember file: $1'#000+
   '09003_E_Can'#039't create object file: $1'#000+
   '09004_E_Can'#039't create archive file: $1'#000+
-  '09005_W_Assembler $1 not found, switching to external ass','embling'#000+
+  '09005_W_Assembler $1 not found, switching to external assembling'#000+
   '09006_T_Using assembler: $1'#000+
-  '09007_W_Error while assembling exitcode $1'#000+
+  '09007_W_Error while as','sembling exitcode $1'#000+
   '09008_W_Can'#039't call the assembler, error $1 switching to external a'+
   'ssembling'#000+
   '09009_I_Assembling $1'#000+
   '09010_I_Assembling smartlink $1'#000+
-  '09011_W_Object $1 not found, Li','nking may fail !'#000+
-  '09012_W_Library $1 not found, Linking may fail !'#000+
+  '09011_W_Object $1 not found, Linking may fail !'#000+
+  '09012_W_Library $1 not found, Linking may',' fail !'#000+
   '09013_W_Error while linking'#000+
   '09014_W_Can'#039't call the linker, switching to external linking'#000+
   '09015_I_Linking $1'#000+
   '09016_W_Util $1 not found, switching to external linking'#000+
-  '09017_T_U','sing util $1'#000+
-  '09018_E_Creation of Executables not supported'#000+
+  '09017_T_Using util $1'#000+
+  '09018_E_Creation of Executables not supported',#000+
   '09019_E_Creation of Dynamic/Shared Libraries not supported'#000+
   '09020_I_Closing script $1'#000+
   '09021_W_resource compiler not found, switching to external mode'#000+
   '09022_I_Compiling resource $1'#000+
-  '09','023_T_unit $1 can'#039't be static linked, switching to smart linki'+
+  '09023_T_unit $1 can'#039't be static linked, switching to smart l','inki'+
   'ng'#000+
   '09024_T_unit $1 can'#039't be smart linked, switching to static linking'+
   #000+
   '09025_T_unit $1 can'#039't be shared linked, switching to static linkin'+
   'g'#000+
-  '09026_E_unit $1 can'#039't be smart or static',' linked'#000+
+  '09026_E_unit $1 can'#039't be smart or static linked'#000+
   '09027_E_unit $1 can'#039't be shared or static linked'#000+
-  '09028_F_Can'#039't post process executable $1'#000+
+  '0','9028_F_Can'#039't post process executable $1'#000+
   '09029_F_Can'#039't open executable $1'#000+
   '09030_X_Size of Code: $1 bytes'#000+
   '09031_X_Size of initialized data: $1 bytes'#000+
-  '09032_X_Size of uninitialized data:',' $1 bytes'#000+
+  '09032_X_Size of uninitialized data: $1 bytes'#000+
   '09033_X_Stack space reserved: $1 bytes'#000+
-  '09034_X_Stack space commited: $1 bytes'#000+
+  '09034_X_S','tack space commited: $1 bytes'#000+
   '10000_T_Unitsearch: $1'#000+
   '10001_T_PPU Loading $1'#000+
   '10002_U_PPU Name: $1'#000+
   '10003_U_PPU Flags: $1'#000+
   '10004_U_PPU Crc: $1'#000+
   '10005_U_PPU Time: $1'#000+
-  '10006_U_PPU File too s','hort'#000+
+  '10006_U_PPU File too short'#000+
   '10007_U_PPU Invalid Header (no PPU at the begin)'#000+
-  '10008_U_PPU Invalid Version $1'#000+
+  '1000','8_U_PPU Invalid Version $1'#000+
   '10009_U_PPU is compiled for an other processor'#000+
   '10010_U_PPU is compiled for an other target'#000+
   '10011_U_PPU Source: $1'#000+
   '10012_U_Writing $1'#000+
-  '10013_F_Can'#039't Write PP','U-File'#000+
+  '10013_F_Can'#039't Write PPU-File'#000+
   '10014_F_Error reading PPU-File'#000+
-  '10015_F_unexpected end of PPU-File'#000+
+  '10015_F_unexpected e','nd of PPU-File'#000+
   '10016_F_Invalid PPU-File entry: $1'#000+
   '10017_F_PPU Dbx count problem'#000+
   '10018_E_Illegal unit name: $1'#000+
   '10019_F_Too much units'#000+
-  '10020_F_Circular unit reference between $1 and $2',#000+
+  '10020_F_Circular unit reference between $1 and $2'#000+
   '10021_F_Can'#039't compile unit $1, no sources available'#000+
-  '10022_F_Can'#039't find unit $1'#000+
+  '10022','_F_Can'#039't find unit $1'#000+
   '10023_W_Unit $1 was not found but $2 exists'#000+
   '10024_F_Unit $1 searched but $2 found'#000+
   '10025_W_Compiling the system unit requires the -Us switch'#000+
-  '10026_F_There were $','1 errors compiling module, stopping'#000+
-  '10027_U_Load from $1 ($2) unit $3'#000+
+  '10026_F_There were $1 errors compiling module, stopping'#000+
+  '10027_U_Load from $1 (','$2) unit $3'#000+
   '10028_U_Recompiling $1, checksum changed for $2'#000+
   '10029_U_Recompiling $1, source found only'#000+
   '10030_U_Recompiling unit, static lib is older than ppufile'#000+
-  '10031_U_Recompiling u','nit, shared lib is older than ppufile'#000+
-  '10032_U_Recompiling unit, obj and asm are older than ppufile'#000+
+  '10031_U_Recompiling unit, shared lib is older than ppufile'#000+
+  '10032_U_Recompiling ','unit, obj and asm are older than ppufile'#000+
   '10033_U_Recompiling unit, obj is older than asm'#000+
   '10034_U_Parsing interface of $1'#000+
   '10035_U_Parsing implementation of $1'#000+
-  '10036_U_Second load for ','unit $1'#000+
+  '10036_U_Second load for unit $1'#000+
   '10037_U_PPU Check file $1 time $2'#000+
-  '10038_H_Conditional $1 was not set at startup in last compilation of $'+
-  '2'#000+
+  '10038_H_Conditio','nal $1 was not set at startup in last compilation of'+
+  ' $2'#000+
   '10039_H_Conditional $1 was set at startup in last compilation of $2'#000+
   '11000_$1 [options] <inputfile> [options]'#000+
-  '11001_W_Only one ','source file supported'#000+
-  '11002_W_DEF file can be created only for OS/2'#000+
+  '11001_W_Only one source file supported'#000+
+  '11002_W_DEF file can be created only',' for OS/2'#000+
   '11003_E_nested response files are not supported'#000+
   '11004_F_No source file name in command line'#000+
   '11005_N_No option inside $1 config file'#000+
   '11006_E_Illegal parameter: $1'#000+
-  '11007_H_-?',' writes help pages'#000+
+  '11007_H_-? writes help pages'#000+
   '11008_F_Too many config files nested'#000+
-  '11009_F_Unable to open file $1'#000+
+  '11','009_F_Unable to open file $1'#000+
   '11010_N_Reading further options from $1'#000+
   '11011_W_Target is already set to: $1'#000+
   '11012_W_Shared libs not supported on DOS platform, reverting to static'+
   #000+
-  '11013','_F_too many IF(N)DEFs'#000+
+  '11013_F_too many IF(N)DEFs'#000+
   '11014_F_too many ENDIFs'#000+
-  '11015_F_open conditional at the end of the file'#000+
+  '11015_F_open',' conditional at the end of the file'#000+
   '11016_W_Debug information generation is not supported by this executab'+
   'le'#000+
   '11017_H_Try recompiling with -dGDB'#000+
-  '11018_E_You are using the obsolete swi','tch $1'#000+
-  '11019_E_You are using the obsolete switch $1, please use $2'#000+
+  '11018_E_You are using the obsolete switch $1'#000+
+  '11019_E_You are using the obsolete switch $1, pleas','e use $2'#000+
   '11020_N_Switching assembler to default source writing assembler'#000+
   '11021_W_Assembler output selected "$1" is not compatible with "$2"'#000+
   '11022_W_"$1" assembler use forced'#000+
-  '11023_Fr','ee Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARGET'+
+  '11023_Free Pascal Compiler version $FPCVER [$FPCDATE] for $FPCTARG','ET'+
   #010+
   'Copyright (c) 1993-2000 by Florian Klaempfl'#000+
   '11024_Free Pascal Compiler version $FPCVER'#010+
@@ -608,158 +620,158 @@ const msgtxt : array[0..000130,1..240] of char=(
   'Compiler Date  : $FPCDATE'#010+
   'Compiler Target: $FPCTARGET'#010+
   #010+
-  'This program comes under the GNU Gen','eral Public Licence'#010+
-  'For more information read COPYING.FPC'#010+
+  'This program comes under the GNU General Public Licence'#010+
+  'For more information read COPYING.FPC'#010,
   #010+
   'Report bugs,suggestions etc to:'#010+
   '                 [email protected]'#000+
   '11025_**0*_put + after a boolean switch option to enable it, - to disa'+
   'ble it'#010+
-  '**1a_the compiler doesn'#039't delete ','the generated assembler file'#010+
-  '**2al_list sourcecode lines in assembler file'#010+
+  '**1a_the compiler doesn'#039't delete the generated assembler file'#010+
+  '**2al_list sourcecode lines i','n assembler file'#010+
   '**2ar_list register allocation/release info in assembler file'#010+
   '**2at_list temp allocation/release info in assembler file'#010+
   '**1b_generate browser info'#010+
-  '**2bl_generate loc','al symbol info'#010+
+  '**2bl_generate local symbol info'#010+
   '**1B_build all modules'#010+
-  '**1C<x>_code generation options:'#010+
+  '**1C<x>_code generat','ion options:'#010+
   '**2CD_create also dynamic library (not supported)'#010+
   '**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#010+
   '**2Ci_IO-checking'#010+
   '**2Cn_omit linking stage'#010+
-  '**2Co_check overflow of ','integer operations'#010+
+  '**2Co_check overflow of integer operations'#010+
   '**2Cr_range checking'#010+
-  '**2Cs<n>_set stack size to <n>'#010+
+  '**2Cs<n>_set stack',' size to <n>'#010+
   '**2Ct_stack checking'#010+
   '**2CX_create also smartlinked library'#010+
   '**1d<x>_defines the symbol <x>'#010+
   '*O1D_generate a DEF file'#010+
   '*O2Dd<x>_set description to <x>'#010+
   '*O2Dw_PM application'#010+
-  '*','*1e<x>_set path to executable'#010+
+  '**1e<x>_set path to executable'#010+
   '**1E_same as -Cn'#010+
-  '**1F<x>_set file names and paths:'#010+
+  '**1F<x>_set',' file names and paths:'#010+
   '**2FD<x>_sets the directory where to search for compiler utilities'#010+
   '**2Fe<x>_redirect error output to <x>'#010+
   '**2FE<x>_set exe/unit output path to <x>'#010+
-  '**2Fi<x>_adds',' <x> to include path'#010+
+  '**2Fi<x>_adds <x> to include path'#010+
   '**2Fl<x>_adds <x> to library path'#010+
-  '*L2FL<x>_uses <x> as dynamic linker'#010+
+  '*L2','FL<x>_uses <x> as dynamic linker'#010+
   '**2Fo<x>_adds <x> to object path'#010+
   '**2Fr<x>_load error message file <x>'#010+
   '**2Fu<x>_adds <x> to unit path'#010+
-  '**2FU<x>_set unit output path to <x>, overrides ','-FE'#010+
+  '**2FU<x>_set unit output path to <x>, overrides -FE'#010+
   '*g1g_generate debugger information:'#010+
   '*g2gg_use gsym'#010+
-  '*g2gd_use dbx'#010+
+  '*g2','gd_use dbx'#010+
   '*g2gh_use heap trace unit (for memory leak debugging)'#010+
   '*g2gl_use line info unit to show more info for backtraces'#010+
   '*g2gc_generate checks for pointers'#010+
   '**1i_information'#010+
-  '**2iD_r','eturn compiler date'#010+
+  '**2iD_return compiler date'#010+
   '**2iV_return compiler version'#010+
-  '**2iSO_return compiler OS'#010+
+  '**2iSO_r','eturn compiler OS'#010+
   '**2iSP_return compiler processor'#010+
   '**2iTO_return target OS'#010+
   '**2iTP_return target processor'#010+
   '**1I<x>_adds <x> to include path'#010+
   '**1k<x>_Pass <x> to the linker'#010+
-  '**1l_write l','ogo'#010+
+  '**1l_write logo'#010+
   '**1n_don'#039't read the default config file'#010+
-  '**1o<x>_change the name of the executable produced to <x>'#010+
+  '**1o<x>_change',' the name of the executable produced to <x>'#010+
   '**1pg_generate profile code for gprof (defines FPC_PROFILE)'#010+
   '*L1P_use pipes instead of creating temporary assembler files'#010+
-  '**1S<x>_syntax op','tions:'#010+
+  '**1S<x>_syntax options:'#010+
   '**2S2_switch some Delphi 2 extensions on'#010+
-  '**2Sc_supports operators like C (*=,+=,/= and -=)'#010+
+  '**2Sc_supp','orts operators like C (*=,+=,/= and -=)'#010+
   '**2Sa_include assertion code.'#010+
   '**2Sd_tries to be Delphi compatible'#010+
   '**2Se<x>_compiler stops after the <x> errors (default is 1)'#010+
-  '**2Sg_allow LABE','L and GOTO'#010+
+  '**2Sg_allow LABEL and GOTO'#010+
   '**2Sh_Use ansistrings'#010+
-  '**2Si_support C++ styled INLINE'#010+
+  '**2Si_support C++ styled ','INLINE'#010+
   '**2Sm_support macros like C (global)'#010+
   '**2So_tries to be TP/BP 7.0 compatible'#010+
   '**2Sp_tries to be gpc compatible'#010+
   '**2Ss_constructor name must be init (destructor must be done)'#010+
-  '**2S','t_allow static keyword in objects'#010+
-  '**1s_don'#039't call assembler and linker (only with -a)'#010+
+  '**2St_allow static keyword in objects'#010+
+  '**1s_don'#039't call assemble','r and linker (only with -a)'#010+
   '**1u<x>_undefines the symbol <x>'#010+
   '**1U_unit options:'#010+
   '**2Un_don'#039't check the unit name'#010+
   '**2Us_compile a system unit'#010+
-  '**1v<x>_Be verbose. <x> is a combination o','f the following letters:'#010+
-  '**2*_e : Show errors (default)       d : Show debug info'#010+
+  '**1v<x>_Be verbose. <x> is a combination of the following letters:'#010+
+  '**2*_e : Show errors (default)   ','    d : Show debug info'#010+
   '**2*_w : Show warnings               u : Show unit info'#010+
   '**2*_n : Show notes                  t : Show tried/used files'#010+
-  '**2*_h : Show hints                  m ',': Show defined macros'#010+
-  '**2*_i : Show general info           p : Show compiled procedures'#010+
+  '**2*_h : Show hints                  m : Show defined macros'#010+
+  '**2*_i : Show general info          ',' p : Show compiled procedures'#010+
   '**2*_l : Show linenumbers            c : Show conditionals'#010+
   '**2*_a : Show everything             0 : Show nothing (except errors)'#010+
-  '**2*_b : Show all proce','dure          r : Rhide/GCC compatibility mod'+
-  'e'#010+
-  '**2*_    declarations if an error    x : Executable info (Win32 only)'#010+
+  '**2*_b : Show all procedure          r : Rhide/GCC compatibility mode'#010+
+  '**2*_    de','clarations if an error    x : Executable info (Win32 only'+
+  ')'#010+
   '**2*_    occurs'#010+
   '**1X_executable options:'#010+
   '*L2Xc_link with the c library'#010+
   '**2Xs_strip all symbols from executable'#010+
-  '**2XD_try to',' link dynamic          (defines FPC_LINK_DYNAMIC)'#010+
-  '**2XS_try to link static (default) (defines FPC_LINK_STATIC)'#010+
+  '**2XD_try to link dynamic          (defines FPC_LINK_DYNAMIC)'#010+
+  '**2XS_tr','y to link static (default) (defines FPC_LINK_STATIC)'#010+
   '**2XX_try to link smart            (defines FPC_LINK_SMART)'#010+
   '**0*_Processor specific options:'#010+
   '3*1A<x>_output format:'#010+
-  '3*2Aas_assemb','le using GNU AS'#010+
-  '3*2Aasaout_assemble using GNU AS for aout (Go32v1)'#010+
+  '3*2Aas_assemble using GNU AS'#010+
+  '3*2Aasaout_assemble using GNU AS for aout ','(Go32v1)'#010+
   '3*2Anasmcoff_coff (Go32v2) file using Nasm'#010+
   '3*2Anasmelf_elf32 (Linux) file using Nasm'#010+
   '3*2Anasmobj_obj file using Nasm'#010+
   '3*2Amasm_obj file using Masm (Microsoft)'#010+
-  '3*2Atasm_obj fi','le using Tasm (Borland)'#010+
-  '3*2Acoff_coff (Go32v2) using internal writer'#010+
+  '3*2Atasm_obj file using Tasm (Borland)'#010+
+  '3*2Acoff_coff (Go32v2) using inter','nal writer'#010+
   '3*2Apecoff_pecoff (Win32) using internal writer'#010+
   '3*1R<x>_assembler reading style:'#010+
   '3*2Ratt_read AT&T style assembler'#010+
   '3*2Rintel_read Intel style assembler'#010+
-  '3*2Rdirect_copy ass','embler text directly to assembler file'#010+
-  '3*1O<x>_optimizations:'#010+
+  '3*2Rdirect_copy assembler text directly to assembler file'#010+
+  '3*1O<x>_optimizatio','ns:'#010+
   '3*2Og_generate smaller code'#010+
   '3*2OG_generate faster code (default)'#010+
   '3*2Or_keep certain variables in registers'#010+
   '3*2Ou_enable uncertain optimizations (see docs)'#010+
-  '3*2O1_level 1 optimizat','ions (quick optimizations)'#010+
-  '3*2O2_level 2 optimizations (-O1 + slower optimizations)'#010+
+  '3*2O1_level 1 optimizations (quick optimizations)'#010+
+  '3*2O2_level 2 optimizations (-O','1 + slower optimizations)'#010+
   '3*2O3_level 3 optimizations (-O2 repeatedly, max 5 times)'#010+
   '3*2Op<x>_target processor:'#010+
   '3*3Op1_set target processor to 386/486'#010+
-  '3*3Op2_set target processor to P','entium/PentiumMMX (tm)'#010+
-  '3*3Op3_set target processor to PPro/PII/c6x86/K6 (tm)'#010+
+  '3*3Op2_set target processor to Pentium/PentiumMMX (tm)'#010+
+  '3*3Op3_set target processor to PPro','/PII/c6x86/K6 (tm)'#010+
   '3*1T<x>_Target operating system:'#010+
   '3*2TGO32V1_version 1 of DJ Delorie DOS extender'#010+
   '3*2TGO32V2_version 2 of DJ Delorie DOS extender'#010+
   '3*2TLINUX_Linux'#010+
-  '3*2Tnetware_Novell',' Netware Module (experimental)'#010+
+  '3*2Tnetware_Novell Netware Module (experimental)'#010+
   '3*2TOS2_OS/2 2.x'#010+
-  '3*2TWin32_Windows 32 Bit'#010+
+  '3*2TWin32_','Windows 32 Bit'#010+
   '3*1W<x>_Win32 target options'#010+
   '3*2WB<x>_Set Image base to Hexadecimal <x> value'#010+
   '3*2WC_Specify console type application'#010+
-  '3*2WD_Use DEFFILE to export functions of DLL or EX','E'#010+
+  '3*2WD_Use DEFFILE to export functions of DLL or EXE'#010+
   '3*2WG_Specify graphic type application'#010+
-  '3*2WN_Do not generate relocation code (necessary for debugging)'#010+
+  '3*2WN_Do not gene','rate relocation code (necessary for debugging)'#010+
   '3*2WR_Generate relocation code'#010+
   '6*1A<x>_output format'#010+
   '6*2Aas_Unix o-file using GNU AS'#010+
   '6*2Agas_GNU Motorola assembler'#010+
-  '6*2Amit_MIT Syntax ','(old GAS)'#010+
+  '6*2Amit_MIT Syntax (old GAS)'#010+
   '6*2Amot_Standard Motorola assembler'#010+
-  '6*1O_optimizations:'#010+
+  '6*1O_optimiz','ations:'#010+
   '6*2Oa_turn on the optimizer'#010+
   '6*2Og_generate smaller code'#010+
   '6*2OG_generate faster code (default)'#010+
   '6*2Ox_optimize maximum (still BUGGY!!!)'#010+
-  '6*2O2_set target processor to a MC68020+'#010,
+  '6*2O2_set target processor to a MC68020+'#010+
   '6*1R<x>_assembler reading style:'#010+
-  '6*2RMOT_read motorola style assembler'#010+
+  '6*2RMOT_read motorola sty','le assembler'#010+
   '6*1T<x>_Target operating system:'#010+
   '6*2TAMIGA_Commodore Amiga'#010+
   '6*2TATARI_Atari ST/STe/TT'#010+
@@ -767,5 +779,5 @@ const msgtxt : array[0..000130,1..240] of char=(
   '6*2TLINUX_Linux-68k'#010+
   '**1*_'#010+
   '**1?_shows this help'#010+
-  '**1h_shows t','his help without waiting'#000
+  '**1h_shows this help without waiting'#000
 );

compiler/nadd.pas

@@ -891,8 +891,7 @@ implementation
            end
          else
 
-           if (rd^.deftype=objectdef) and (ld^.deftype=objectdef) and
-              pobjectdef(rd)^.is_class and pobjectdef(ld)^.is_class then
+           if is_class_or_interface(rd) and is_class_or_interface(ld) then
             begin
               location.loc:=LOC_REGISTER;
               if pobjectdef(rd)^.is_related(pobjectdef(ld)) then
@@ -930,8 +929,7 @@ implementation
          else
 
          { allows comperasion with nil pointer }
-           if (rd^.deftype=objectdef) and
-              pobjectdef(rd)^.is_class then
+           if is_class_or_interface(rd) then
             begin
               location.loc:=LOC_REGISTER;
               left:=gentypeconvnode(left,rd);
@@ -945,8 +943,7 @@ implementation
             end
          else
 
-           if (ld^.deftype=objectdef) and
-              pobjectdef(ld)^.is_class then
+           if is_class_or_interface(ld) then
             begin
               location.loc:=LOC_REGISTER;
               right:=gentypeconvnode(right,ld);
@@ -1232,7 +1229,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.14  2000-10-31 22:02:47  peter
+  Revision 1.15  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.14  2000/10/31 22:02:47  peter
     * symtable splitted, no real code changes
 
   Revision 1.13  2000/10/14 10:14:50  peter

compiler/ncal.pas

@@ -261,11 +261,11 @@ interface
               if do_count then
                begin
                  { not completly proper, but avoids some warnings }
-                 if (defcoll^.paratyp=vs_var) then
+                 if (defcoll^.paratyp in [vs_var,vs_out]) then
                    set_funcret_is_valid(left);
 
                  { protected has nothing to do with read/write
-                 if (defcoll^.paratyp=vs_var) then
+                 if (defcoll^.paratyp in [vs_var,vs_out]) then
                    test_protected(left);
                  }
                  { set_varstate(left,defcoll^.paratyp<>vs_var);
@@ -367,13 +367,13 @@ interface
                     CGMessage(type_e_strict_var_string_violation);
                  end;
 
-              { Variablen for call by reference may not be copied }
+              { variabls for call by reference may not be copied }
               { into a register }
               { is this usefull here ? }
               { this was missing in formal parameter list   }
               if (defcoll^.paratype.def=pdef(cformaldef)) then
                 begin
-                  if defcoll^.paratyp=vs_var then
+                  if defcoll^.paratyp in [vs_var,vs_out] then
                     begin
                       if not valid_for_formal_var(left) then
                         begin
@@ -406,7 +406,7 @@ interface
                 make_not_regable(left);
 
               if do_count then
-                set_varstate(left,defcoll^.paratyp <> vs_var);
+                set_varstate(left,defcoll^.paratyp in [vs_var,vs_out]);
                 { must only be done after typeconv PM }
               resulttype:=defcoll^.paratype.def;
            end;
@@ -802,7 +802,7 @@ interface
                          (m_tp_procvar in aktmodeswitches) then
                         begin
                           if (symtableprocentry^.owner^.symtabletype=objectsymtable) and
-                             (pobjectdef(symtableprocentry^.owner^.defowner)^.is_class) then
+                             is_class(pdef(symtableprocentry^.owner^.defowner)) then
                            hpt:=genloadmethodcallnode(pprocsym(symtableprocentry),symtableproc,
                                  methodpointer.getcopy)
                           else
@@ -856,7 +856,7 @@ interface
                                begin
                                  hp^.nextpara^.argconvtyp:=act_convertable;
                                  hp^.nextpara^.convertlevel:=isconvertable(pt.resulttype,hp^.nextpara^.paratype.def,
-                                     hcvt,pt.left.nodetype,false);
+                                     hcvt,pt.left,pt.left.nodetype,false);
                                  case hp^.nextpara^.convertlevel of
                                   1 : include(pt.callparaflags,cpf_convlevel1found);
                                   2 : include(pt.callparaflags,cpf_convlevel2found);
@@ -1545,7 +1545,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.13  2000-10-31 22:02:47  peter
+  Revision 1.14  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.13  2000/10/31 22:02:47  peter
     * symtable splitted, no real code changes
 
   Revision 1.12  2000/10/21 18:16:11  florian

compiler/ncnv.pas

@@ -726,7 +726,9 @@ implementation
            @ttypeconvnode.first_proc_to_procvar,
            @ttypeconvnode.first_arrayconstructor_to_set,
            @ttypeconvnode.first_load_smallset,
-           @ttypeconvnode.first_cord_to_pointer
+           @ttypeconvnode.first_cord_to_pointer,
+           @ttypeconvnode.first_nothing,
+           @ttypeconvnode.first_nothing
          );
       type
          tprocedureofobject = function : tnode of object;
@@ -823,7 +825,7 @@ implementation
             exit;
          end;
 
-       if isconvertable(left.resulttype,resulttype,convtype,left.nodetype,nf_explizit in flags)=0 then
+       if isconvertable(left.resulttype,resulttype,convtype,left,left.nodetype,nf_explizit in flags)=0 then
          begin
            {Procedures have a resulttype of voiddef and functions of their
            own resulttype. They will therefore always be incompatible with
@@ -935,7 +937,7 @@ implementation
                   end
                  else
                   begin
-                    if isconvertable(s32bitdef,resulttype,convtype,ordconstn,false)=0 then
+                    if isconvertable(s32bitdef,resulttype,convtype,nil,ordconstn,false)=0 then
                       CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
                   end;
                end
@@ -954,7 +956,7 @@ implementation
                    end
                   else
                    begin
-                     if IsConvertable(left.resulttype,s32bitdef,convtype,ordconstn,false)=0 then
+                     if IsConvertable(left.resulttype,s32bitdef,convtype,nil,ordconstn,false)=0 then
                        CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
                    end;
                 end
@@ -983,7 +985,7 @@ implementation
                     end
                    else
                     begin
-                      if IsConvertable(left.resulttype,u8bitdef,convtype,ordconstn,false)=0 then
+                      if IsConvertable(left.resulttype,u8bitdef,convtype,nil,ordconstn,false)=0 then
                         CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
                     end;
                  end
@@ -1002,7 +1004,7 @@ implementation
                     end
                    else
                     begin
-                      if IsConvertable(u8bitdef,resulttype,convtype,ordconstn,false)=0 then
+                      if IsConvertable(u8bitdef,resulttype,convtype,nil,ordconstn,false)=0 then
                         CGMessage2(type_e_incompatible_types,left.resulttype^.typename,resulttype^.typename);
                     end;
                  end
@@ -1029,7 +1031,7 @@ implementation
                { the conversion into a strutured type is only }
                { possible, if the source is no register    }
                if ((resulttype^.deftype in [recorddef,stringdef,arraydef]) or
-                   ((resulttype^.deftype=objectdef) and not(pobjectdef(resulttype)^.is_class))
+                   ((resulttype^.deftype=objectdef) and not(is_class(resulttype)))
                   ) and (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) { and
                    it also works if the assignment is overloaded
                    YES but this code is not executed if assignment is overloaded (PM)
@@ -1099,7 +1101,7 @@ implementation
 
          { left must be a class }
          if (left.resulttype^.deftype<>objectdef) or
-            not(pobjectdef(left.resulttype)^.is_class) then
+            not(is_class(left.resulttype)) then
            CGMessage(type_e_mismatch);
 
          { the operands must be related }
@@ -1141,7 +1143,7 @@ implementation
 
          { left must be a class }
          if (left.resulttype^.deftype<>objectdef) or
-           not(pobjectdef(left.resulttype)^.is_class) then
+           not(is_class(left.resulttype)) then
            CGMessage(type_e_mismatch);
 
          { the operands must be related }
@@ -1163,7 +1165,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.9  2000-10-31 22:02:48  peter
+  Revision 1.10  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.9  2000/10/31 22:02:48  peter
     * symtable splitted, no real code changes
 
   Revision 1.8  2000/10/14 21:52:55  peter

compiler/nflw.pas

@@ -746,8 +746,7 @@ implementation
               { first para must be a _class_ }
               firstpass(left);
               if assigned(left.resulttype) and
-                 ((left.resulttype^.deftype<>objectdef) or
-                  not(pobjectdef(left.resulttype)^.is_class)) then
+                 not(is_class(left.resulttype)) then
                 CGMessage(type_e_mismatch);
               set_varstate(left,true);
               if codegenerror then
@@ -919,8 +918,7 @@ implementation
       begin
          pass_1:=nil;
          { that's really an example procedure for a firstpass :) }
-         if (excepttype^.deftype<>objectdef) or
-           not(pobjectdef(excepttype)^.is_class) then
+         if not(is_class(excepttype)) then
            CGMessage(type_e_mismatch);
 {$ifdef newcg}
          tg.cleartempgen;
@@ -994,7 +992,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.9  2000-10-31 22:02:48  peter
+  Revision 1.10  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.9  2000/10/31 22:02:48  peter
     * symtable splitted, no real code changes
 
   Revision 1.8  2000/10/21 18:16:11  florian

compiler/nld.pas

@@ -287,15 +287,6 @@ implementation
 
                    if ([vo_is_thread_var,vo_is_dll_var]*pvarsym(symtableentry)^.varoptions)<>[] then
                      registers32:=1;
-                   { a class variable is a pointer !!!
-                     yes, but we have to resolve the reference in an
-                     appropriate tree node (FK)
-
-                   if (pvarsym(symtableentry)^.definition^.deftype=objectdef) and
-                      ((pobjectdef(pvarsym(symtableentry)^.definition)^.options and oo_is_class)<>0) then
-                     registers32:=1;
-                   }
-
                    { count variable references }
 
                      { this will create problem with local var set by
@@ -752,7 +743,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.7  2000-10-31 22:02:49  peter
+  Revision 1.8  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.7  2000/10/31 22:02:49  peter
     * symtable splitted, no real code changes
 
   Revision 1.6  2000/10/14 10:14:50  peter

compiler/nmem.pas

@@ -403,7 +403,7 @@ implementation
 
                      { method ? then set the methodpointer flag }
                        if (hp3^.owner^.symtabletype=objectsymtable) and
-                          (pobjectdef(hp3^.owner^.defowner)^.is_class) then
+                          is_class(pdef(hp3^.owner^.defowner)) then
                          include(pprocvardef(resulttype)^.procoptions,po_methodpointer);
                        { we need to process the parameters reverse so they are inserted
                          in the correct right2left order (PFV) }
@@ -596,8 +596,7 @@ implementation
          registersmmx:=left.registersmmx;
 {$endif SUPPORT_MMX}
          { classes must be dereferenced implicit }
-         if (left.resulttype^.deftype=objectdef) and
-           pobjectdef(left.resulttype)^.is_class then
+         if is_class_or_interface(left.resulttype) then
            begin
               if registers32=0 then
                 registers32:=1;
@@ -641,7 +640,7 @@ implementation
          if (left.resulttype^.deftype=arraydef) then
            begin
               if (isconvertable(right.resulttype,parraydef(left.resulttype)^.rangetype.def,
-                    ct,ordconstn,false)=0) and
+                    ct,nil,ordconstn,false)=0) and
                  not(is_equal(right.resulttype,parraydef(left.resulttype)^.rangetype.def)) then
                 CGMessage(type_e_mismatch);
            end;
@@ -778,9 +777,7 @@ implementation
       begin
          pass_1:=nil;
          if (resulttype^.deftype=classrefdef) or
-           ((resulttype^.deftype=objectdef)
-             and pobjectdef(resulttype)^.is_class
-           ) then
+           is_class(resulttype) then
            location.loc:=LOC_CREGISTER
          else
            location.loc:=LOC_REFERENCE;
@@ -872,7 +869,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.9  2000-10-31 22:02:49  peter
+  Revision 1.10  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.9  2000/10/31 22:02:49  peter
     * symtable splitted, no real code changes
 
   Revision 1.8  2000/10/21 18:16:11  florian

compiler/nset.pas

@@ -305,7 +305,7 @@ implementation
            exit;
          { both types must be compatible }
          if not(is_equal(left.resulttype,right.resulttype)) and
-            (isconvertable(left.resulttype,right.resulttype,ct,ordconstn,false)=0) then
+            (isconvertable(left.resulttype,right.resulttype,ct,nil,ordconstn,false)=0) then
            CGMessage(type_e_mismatch);
          { Check if only when its a constant set }
          if (left.nodetype=ordconstn) and (right.nodetype=ordconstn) then
@@ -525,7 +525,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.7  2000-10-31 22:02:49  peter
+  Revision 1.8  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.7  2000/10/31 22:02:49  peter
     * symtable splitted, no real code changes
 
   Revision 1.6  2000/10/21 18:16:11  florian

compiler/options.pas

@@ -703,28 +703,38 @@ begin
 {$endif}
               's' : initglobalswitches:=initglobalswitches+[cs_asm_extern,cs_link_extern];
               'S' : begin
-                      for j:=1 to length(more) do
-                       case more[j] of
-                        '2' : SetCompileMode('OBJFPC',true);
-                        'a' : initlocalswitches:=InitLocalswitches+[cs_do_assertion];
-                        'c' : initmoduleswitches:=initmoduleswitches+[cs_support_c_operators];
-                        'd' : SetCompileMode('DELPHI',true);
-                        'e' : begin
-                                SetErrorFlags(more);
-                                break;
-                              end;
-                        'g' : initmoduleswitches:=initmoduleswitches+[cs_support_goto];
-                        'h' : initlocalswitches:=initlocalswitches+[cs_ansistrings];
-                        'i' : initmoduleswitches:=initmoduleswitches+[cs_support_inline];
-                        'm' : initmoduleswitches:=initmoduleswitches+[cs_support_macro];
-                        'o' : SetCompileMode('TP',true);
-                        'p' : SetCompileMode('GPC',true);
-                        's' : initglobalswitches:=initglobalswitches+[cs_constructor_name];
-                        't' : initmoduleswitches:=initmoduleswitches+[cs_static_keyword];
-                        'v' : Message1(option_obsolete_switch,'-Sv');
-                       else
-                        IllegalPara(opt);
-                       end;
+                      if more[1]='I' then
+                        begin
+                          if upper(more)='ICOM' then
+                            initinterfacetype:=it_interfacecom
+                          else if upper(more)='ICORBA' then
+                            initinterfacetype:=it_interfacecorba
+                          else
+                            IllegalPara(opt);
+                        end
+                      else
+                        for j:=1 to length(more) do
+                         case more[j] of
+                          '2' : SetCompileMode('OBJFPC',true);
+                          'a' : initlocalswitches:=InitLocalswitches+[cs_do_assertion];
+                          'c' : initmoduleswitches:=initmoduleswitches+[cs_support_c_operators];
+                          'd' : SetCompileMode('DELPHI',true);
+                          'e' : begin
+                                  SetErrorFlags(more);
+                                  break;
+                                end;
+                          'g' : initmoduleswitches:=initmoduleswitches+[cs_support_goto];
+                          'h' : initlocalswitches:=initlocalswitches+[cs_ansistrings];
+                          'i' : initmoduleswitches:=initmoduleswitches+[cs_support_inline];
+                          'm' : initmoduleswitches:=initmoduleswitches+[cs_support_macro];
+                          'o' : SetCompileMode('TP',true);
+                          'p' : SetCompileMode('GPC',true);
+                          's' : initglobalswitches:=initglobalswitches+[cs_constructor_name];
+                          't' : initmoduleswitches:=initmoduleswitches+[cs_static_keyword];
+                          'v' : Message1(option_obsolete_switch,'-Sv');
+                         else
+                          IllegalPara(opt);
+                         end;
                     end;
               'T' : begin
                       more:=Upper(More);
@@ -1181,9 +1191,6 @@ procedure read_arguments(cmd:string);
 var
   configpath : pathstr;
 begin
-{$ifdef Delphi}
-  option:=new(poption386,Init);
-{$endif Delphi}
 {$ifdef i386}
   option:=new(poption386,Init);
 {$endif}
@@ -1490,7 +1497,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.11  2000-09-26 10:50:41  jonas
+  Revision 1.12  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.11  2000/09/26 10:50:41  jonas
     * initmodeswitches is changed is you change the compiler mode from the
       command line (the -S<x> switches didn't work anymore for changing the
       compiler mode) (merged from fixes branch)
@@ -1527,4 +1537,4 @@ end.
   Revision 1.2  2000/07/13 11:32:44  michael
   + removed logs
 
-}
+}

compiler/parser.pas

@@ -258,12 +258,15 @@ implementation
          oldaktspecificoptprocessor,
          oldaktoptprocessor : tprocessors;
          oldaktasmmode      : tasmmode;
+         oldaktinterfacetype: tinterfacetypes;
          oldaktmodeswitches : tmodeswitches;
          old_compiled_module : pmodule;
          prev_name          : pstring;
 {$ifdef USEEXCEPT}
+{$ifndef Delphi}
          recoverpos    : jmp_buf;
          oldrecoverpos : pjmp_buf;
+{$endif Delphi}         
 {$endif useexcept}
 {$ifdef newcg}
          oldcg         : pcg;
@@ -327,6 +330,7 @@ implementation
          oldaktoptprocessor:=aktoptprocessor;
          oldaktspecificoptprocessor:=aktspecificoptprocessor;
          oldaktasmmode:=aktasmmode;
+         oldaktinterfacetype:=aktinterfacetype;
          oldaktfilepos:=aktfilepos;
          oldaktmodeswitches:=aktmodeswitches;
 {$ifdef newcg}
@@ -381,6 +385,7 @@ implementation
          aktoptprocessor:=initoptprocessor;
          aktspecificoptprocessor:=initspecificoptprocessor;
          aktasmmode:=initasmmode;
+         aktinterfacetype:=initinterfacetype;
          { we need this to make the system unit }
          if compile_system then
           aktmoduleswitches:=aktmoduleswitches+[cs_compilesystem];
@@ -516,6 +521,7 @@ implementation
               aktoptprocessor:=oldaktoptprocessor;
               aktspecificoptprocessor:=oldaktspecificoptprocessor;
               aktasmmode:=oldaktasmmode;
+              aktinterfacetype:=oldaktinterfacetype;
               aktfilepos:=oldaktfilepos;
               aktmodeswitches:=oldaktmodeswitches;
            end;
@@ -587,7 +593,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2000-10-31 22:02:49  peter
+  Revision 1.9  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.8  2000/10/31 22:02:49  peter
     * symtable splitted, no real code changes
 
   Revision 1.7  2000/10/14 10:14:51  peter

compiler/pdecl.pas

@@ -312,6 +312,7 @@ implementation
                     akttokenpos:=stpos;
                     { we don't need the forwarddef anymore, dispose it }
                     dispose(hpd,done);
+                    ppointerdef(pd)^.pointertype.def:=nil; { if error occurs }
                     { was a type sym found ? }
                     if assigned(srsym) and
                        (srsym^.typ=typesym) then
@@ -329,8 +330,7 @@ implementation
 {$endif GDB}
                        { we need a class type for classrefdef }
                        if (pd^.deftype=classrefdef) and
-                          not((ptypesym(srsym)^.restype.def^.deftype=objectdef) and
-                              pobjectdef(ptypesym(srsym)^.restype.def)^.is_class) then
+                          not(is_class(ptypesym(srsym)^.restype.def)) then
                          Message1(type_e_class_type_expected,ptypesym(srsym)^.restype.def^.typename);
                      end
                     else
@@ -400,8 +400,7 @@ implementation
                begin
                  if (token=_CLASS) and
                     (assigned(ptypesym(sym)^.restype.def)) and
-                    (ptypesym(sym)^.restype.def^.deftype=objectdef) and
-                    pobjectdef(ptypesym(sym)^.restype.def)^.is_class and
+                    is_class(ptypesym(sym)^.restype.def) and
                     (oo_is_forward in pobjectdef(ptypesym(sym)^.restype.def)^.objectoptions) then
                   begin
                     { we can ignore the result   }
@@ -431,6 +430,11 @@ implementation
                 tt.sym:=newtype;
               if assigned(tt.def) and not assigned(tt.def^.typesym) then
                 tt.def^.typesym:=newtype;
+              { KAZ: handle TGUID declaration in system unit }
+              if (cs_compilesystem in aktmoduleswitches) and not assigned(rec_tguid) and
+                 (typename='TGUID') and { name: TGUID and size=16 bytes that is 128 bits }
+                 assigned(tt.def) and (tt.def^.deftype=recorddef) and (tt.def^.size=16) then
+                rec_tguid:=precorddef(tt.def);
             end;
            if assigned(newtype^.restype.def) and
               (newtype^.restype.def^.deftype=procvardef) then
@@ -528,7 +532,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.18  2000-10-31 22:02:49  peter
+  Revision 1.19  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.18  2000/10/31 22:02:49  peter
     * symtable splitted, no real code changes
 
   Revision 1.17  2000/10/14 10:14:51  peter

compiler/pdecobj.pas

@@ -51,7 +51,7 @@ implementation
       var
          actmembertype : tsymoptions;
          there_is_a_destructor : boolean;
-         classtype : (ct_object,ct_class,ct_interfacecom,ct_interfaceraw,ct_cppclass);
+         classtype : tobjectdeftype;
          childof : pobjectdef;
          aktclass : pobjectdef;
 
@@ -70,7 +70,7 @@ implementation
            include(aktclass^.objectoptions,oo_has_constructor);
            consume(_SEMICOLON);
              begin
-                if (aktclass^.is_class) then
+                if is_class(aktclass) then
                   begin
                      { CLASS constructors return the created instance }
                      aktprocsym^.definition^.rettype.def:=aktclass;
@@ -124,7 +124,7 @@ implementation
 
         begin
            { check for a class }
-           if not(aktclass^.is_class) then
+           if not(is_class(aktclass)) then
             Message(parser_e_syntax_error);
            consume(_PROPERTY);
            new(propertyparas,init);
@@ -544,9 +544,9 @@ implementation
       procedure setclassattributes;
 
         begin
-           if classtype=ct_class then
+           if classtype=odt_class then
              begin
-                include(aktclass^.objectoptions,oo_is_class);
+                aktclass^.objecttype:=odt_class;
                 if (cs_generate_rtti in aktlocalswitches) or
                     (assigned(aktclass^.childof) and
                      (oo_can_have_published in aktclass^.childof^.objectoptions)) then
@@ -563,35 +563,27 @@ implementation
      procedure setclassparent;
 
         begin
+           if assigned(fd) then
+             aktclass:=fd
+           else
+             aktclass:=new(pobjectdef,init(classtype,n,nil));
            { is the current class tobject?   }
            { so you could define your own tobject }
-           if (cs_compilesystem in aktmoduleswitches) and
-              (upper(n)='TOBJECT') then
-             begin
-                if assigned(fd) then
-                  aktclass:=fd
-                else
-                  aktclass:=new(pobjectdef,init(n,nil));
-                class_tobject:=aktclass;
-             end
+           if (cs_compilesystem in aktmoduleswitches) and (classtype=odt_class) and (n='TOBJECT') then
+             class_tobject:=aktclass
+           else if (cs_compilesystem in aktmoduleswitches) and (classtype=odt_interfacecom) and (n='IUNKNOWN') then
+             interface_iunknown:=aktclass
            else
              begin
-                childof:=class_tobject;
-                if assigned(fd) then
-                  begin
-                     { the forward of the child must be resolved to get
-                       correct field addresses
-                     }
-                     if (oo_is_forward in childof^.objectoptions) then
-                       Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^);
-                     aktclass:=fd;
-                     aktclass^.set_parent(childof);
-                  end
-                else
-                  begin
-                     aktclass:=new(pobjectdef,init(n,childof));
-                     aktclass^.set_parent(childof);
-                  end;
+                case classtype of
+                  odt_class:
+                    childof:=class_tobject;
+                  odt_interfacecom:
+                    childof:=interface_iunknown;
+                end;
+                if (oo_is_forward in childof^.objectoptions) then
+                  Message1(parser_e_forward_declaration_must_be_resolved,childof^.objname^);
+                aktclass^.set_parent(childof);
              end;
          end;
 
@@ -603,6 +595,7 @@ implementation
 {$ifdef WITHDMT}
            dmtlabel : pasmlabel;
 {$endif WITHDMT}
+           interfacetable : pasmlabel;
 
         begin
 {$ifdef WITHDMT}
@@ -614,7 +607,7 @@ implementation
 
            { write tables for classes, this must be done before the actual
              class is written, because we need the labels defined }
-           if classtype=ct_class then
+           if classtype=odt_class then
             begin
               methodnametable:=genpublishedmethodstable(aktclass);
               fieldtablelabel:=aktclass^.generate_field_table;
@@ -633,6 +626,8 @@ implementation
                 intmessagetable:=genintmsgtab(aktclass)
               else
                 datasegment^.concat(new(pai_const,init_32bit(0)));
+              if aktclass^.implementedinterfaces^.count>0 then
+                interfacetable:=genintftable(aktclass);
             end;
 
           { write debug info }
@@ -671,7 +666,7 @@ implementation
              datasegment^.concat(new(pai_const,init_32bit(0)));
 
            { write extended info for classes, for the order see rtl/inc/objpash.inc }
-           if classtype=ct_class then
+           if classtype=odt_class then
             begin
               { pointer to class name string }
               datasegment^.concat(new(pai_const_symbol,init(classnamelabel)));
@@ -706,7 +701,10 @@ implementation
               { auto table }
               datasegment^.concat(new(pai_const,init_32bit(0)));
               { interface table }
-              datasegment^.concat(new(pai_const,init_32bit(0)));
+              if aktclass^.implementedinterfaces^.count>0 then
+                datasegment^.concat(new(pai_const_symbol,init(interfacetable)))
+              else
+                datasegment^.concat(new(pai_const,init_32bit(0)));
               { table for string messages }
               if (oo_has_msgstr in aktclass^.objectoptions) then
                 datasegment^.concat(new(pai_const_symbol,init(strmessagetable)))
@@ -719,6 +717,28 @@ implementation
            datasegment^.concat(new(pai_symbol_end,initname(aktclass^.vmt_mangledname)));
         end;
 
+      procedure setinterfacemethodoptions;
+
+        var
+          i: longint;
+          defs: pindexarray;
+          pd: pprocdef;
+        begin
+          include(aktclass^.objectoptions,oo_has_virtual);
+          defs:=aktclass^.symtable^.defindex;
+          for i:=1 to defs^.count do
+            begin
+              pd:=pprocdef(defs^.search(i));
+              if pd^.deftype=procdef then
+                begin
+                  pd^.extnumber:=aktclass^.lastvtableindex;
+                  aktclass^.lastvtableindex:=aktclass^.lastvtableindex+1;
+                  include(pd^.procoptions,po_virtualmethod);
+                  pd^.forwarddef:=false;
+                end;
+            end;
+        end;
+
       function readobjecttype : boolean;
 
         begin
@@ -727,21 +747,21 @@ implementation
            case token of
               _OBJECT:
                 begin
-                   classtype:=ct_object;
+                   classtype:=odt_object;
                    consume(_OBJECT)
                 end;
               _CPPCLASS:
                 begin
-                   classtype:=ct_cppclass;
+                   classtype:=odt_cppclass;
                    consume(_CPPCLASS);
                 end;
 {$ifdef SUPPORT_INTERFACE}
               _INTERFACE:
                 begin
                    if aktinterfacetype=it_interfacecom then
-                     objecttype:=ct_interfacecom
-                   else {it_interfaceraw}
-                     objecttype:=ct_interfaceraw;
+                     objecttype:=odt_interfacecom
+                   else {it_interfacecorba}
+                     objecttype:=odt_interfacecorba;
                    consume(_INTERFACE);
                    { forward declaration }
                    if not(assigned(fd)) and (token=_SEMICOLON) then
@@ -753,13 +773,13 @@ implementation
                        if (cs_compilesystem in aktmoduleswitches) and
                           (objecttype=odt_interfacecom) and (n='IUNKNOWN') then
                          interface_iunknown:=aktclass;
-                       include(aktclass^.objectoptions,[oo_is_forward]);
+                       aktclass^.objectoptions:=aktclass^.objectoptions+[oo_is_forward];
                      end;
                 end;
 {$endif SUPPORT_INTERFACE}
               _CLASS:
                 begin
-                   classtype:=ct_class;
+                   classtype:=odt_class;
                    consume(_CLASS);
                    if not(assigned(fd)) and (token=_OF) then
                      begin
@@ -770,7 +790,7 @@ implementation
 
                         { accept hp1, if is a forward def or a class }
                         if (tt.def^.deftype=forwarddef) or
-                           ((tt.def^.deftype=objectdef) and pobjectdef(tt.def)^.is_class) then
+                           is_class(tt.def) then
                           begin
                              pcrd:=new(pclassrefdef,init(tt.def));
                              object_dec:=pcrd;
@@ -790,10 +810,11 @@ implementation
                         { also anonym objects aren't allow (o : object a : longint; end;) }
                         if n='' then
                           Message(parser_f_no_anonym_objects);
-                        aktclass:=new(pobjectdef,init(n,nil));
+                        aktclass:=new(pobjectdef,init(odt_class,n,nil));
                         if (cs_compilesystem in aktmoduleswitches) and (n='TOBJECT') then
                           class_tobject:=aktclass;
-                        aktclass^.objectoptions:=aktclass^.objectoptions+[oo_is_class,oo_is_forward];
+                        aktclass^.objecttype:=odt_class;
+                        include(aktclass^.objectoptions,oo_is_forward);
                         { all classes must have a vmt !!  at offset zero }
                         if not(oo_has_vmt in aktclass^.objectoptions) then
                           aktclass^.insertvmt;
@@ -806,12 +827,35 @@ implementation
                 end;
               else
                 begin
-                   classtype:=ct_class; { this is error but try to recover }
+                   classtype:=odt_class; { this is error but try to recover }
                    consume(_OBJECT);
                 end;
            end;
         end;
 
+      procedure readimplementedinterfaces;
+        var
+          implintf: pobjectdef;
+          tt      : ttype;
+        begin
+          while try_to_consume(_COMMA) do begin
+            id_type(tt,pattern,false);
+            implintf:=pobjectdef(tt.def);
+            if (tt.def^.deftype<>objectdef) then begin
+              Message1(type_e_interface_type_expected,tt.def^.typename);
+              Continue; { omit }
+            end;
+            if not is_interface(implintf) then begin
+              Message1(type_e_interface_type_expected,implintf^.typename);
+              Continue; { omit }
+            end;
+            if aktclass^.implementedinterfaces^.searchintf(tt.def)<>-1 then
+              Message1(sym_e_duplicate_id,tt.def^.name)
+            else
+              aktclass^.implementedinterfaces^.addintf(tt.def);
+          end;
+        end;
+
       procedure readparentclasses;
 
         begin
@@ -828,26 +872,26 @@ implementation
                    if assigned(childof) then
                     Message1(type_e_class_type_expected,childof^.typename);
                    childof:=nil;
-                   aktclass:=new(pobjectdef,init(n,nil));
+                   aktclass:=new(pobjectdef,init(classtype,n,nil));
                  end
                 else
                  begin
                    { a mix of class, interfaces, objects and cppclasses
                      isn't allowed }
                    case classtype of
-                      ct_class:
-                        if not(childof^.is_class) and
-                          not(childof^.is_interface) then
+                      odt_class:
+                        if not(is_class(childof)) and
+                          not(is_interface(childof)) then
                           Message(parser_e_mix_of_classes_and_objects);
-                      ct_interfaceraw,
-                      ct_interfacecom:
-                        if not(childof^.is_interface) then
+                      odt_interfacecorba,
+                      odt_interfacecom:
+                        if not(is_interface(childof)) then
                           Message(parser_e_mix_of_classes_and_objects);
-                      ct_cppclass:
-                        if not(childof^.is_cppclass) then
+                      odt_cppclass:
+                        if not(is_cppclass(childof)) then
                           Message(parser_e_mix_of_classes_and_objects);
-                      ct_object:
-                        if not(childof^.is_object) then
+                      odt_object:
+                        if not(is_object(childof)) then
                           Message(parser_e_mix_of_classes_and_objects);
                    end;
                    { the forward of the child must be resolved to get
@@ -864,21 +908,23 @@ implementation
                       fd^.set_parent(childof);
                     end
                    else
-                    aktclass:=new(pobjectdef,init(n,childof));
+                    aktclass:=new(pobjectdef,init(classtype,n,childof));
+                   if aktclass^.objecttype=odt_class then
+                    readimplementedinterfaces;
                  end;
                 consume(_RKLAMMER);
              end
            { if no parent class, then a class get tobject as parent }
-           else if classtype=ct_class then
+           else if classtype=odt_class then
              setclassparent
            else
-             aktclass:=new(pobjectdef,init(n,nil));
+             aktclass:=new(pobjectdef,init(classtype,n,nil));
         end;
 
       procedure chkcpp;
 
         begin
-           if aktclass^.is_cppclass then
+           if is_cppclass(aktclass) then
              begin
                 include(aktprocsym^.definition^.proccalloptions,pocall_cppdecl);
                 aktprocsym^.definition^.setmangledname(
@@ -886,6 +932,30 @@ implementation
              end;
         end;
 
+      procedure readinterfaceiid;
+        var
+          tt: ttype;
+          p : tnode;
+          isiidguidvalid: boolean;
+
+        begin
+          p:=comp_expr(true);
+          do_firstpass(p);
+          if p.nodetype=stringconstn then
+            begin
+              aktclass^.iidstr:=stringdup(strpas(tstringconstnode(p).value_str)); { or upper? }
+              p.free;
+              aktclass^.isiidguidvalid:=string2guid(aktclass^.iidstr^,aktclass^.iidguid);
+              if (classtype=odt_interfacecom) and not aktclass^.isiidguidvalid then
+                Message(parser_e_improper_guid_syntax);
+            end
+          else
+            begin
+              p.free;
+              Message(cg_e_illegal_expression);
+            end;
+        end;
+
       var
         temppd : pprocdef;
       begin
@@ -938,7 +1008,7 @@ implementation
 
 
        { short class declaration ? }
-         if (classtype<>ct_class) or (token<>_SEMICOLON) then
+         if (classtype<>odt_class) or (token<>_SEMICOLON) then
           begin
           { Parse componenten }
             repeat
@@ -1051,14 +1121,22 @@ implementation
 
          { generate vmt space if needed }
          if not(oo_has_vmt in aktclass^.objectoptions) and
-            ([oo_has_virtual,oo_has_constructor,oo_has_destructor,oo_is_class]*aktclass^.objectoptions<>[]) then
+            (([oo_has_virtual,oo_has_constructor,oo_has_destructor]*aktclass^.objectoptions<>[]) or
+             (classtype=odt_class)
+            ) then
            aktclass^.insertvmt;
          if (cs_create_smart in aktmoduleswitches) then
            datasegment^.concat(new(pai_cut,init));
 
+         if is_interface(aktclass) then
+           writeinterfaceids(aktclass);
+
          if (oo_has_vmt in aktclass^.objectoptions) then
            writevmt;
 
+         if is_interface(aktclass) then
+           setinterfacemethodoptions;
+
          { restore old state }
          symtablestack:=symtablestack^.next;
          aktobjectdef:=nil;
@@ -1074,7 +1152,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.4  2000-10-31 22:02:49  peter
+  Revision 1.5  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.4  2000/10/31 22:02:49  peter
     * symtable splitted, no real code changes
 
   Revision 1.3  2000/10/26 21:54:03  peter

compiler/pdecsub.pas

@@ -37,6 +37,7 @@ interface
       pd_object    = $10;   { directive can be used object declaration }
       pd_procvar   = $20;   { directive can be used procvar declaration }
       pd_notobject = $40;   { directive can not be used object declaration }
+      pd_notobjintf= $80;   { directive can not be used interface declaration }
 
     function  is_proc_directive(tok:ttoken):boolean;
     function  check_identical_proc(var p : pprocdef) : boolean;
@@ -130,7 +131,7 @@ implementation
           { self is only allowed in procvars and class methods }
           if (idtoken=_SELF) and
              (is_procvar or
-              (assigned(procinfo^._class) and procinfo^._class^.is_class)) then
+              (assigned(procinfo^._class) and is_class(procinfo^._class))) then
             begin
               if not is_procvar then
                begin
@@ -318,6 +319,7 @@ var orgsp,sp:stringid;
     st : psymtable;
     overloaded_level:word;
     storepos,procstartfilepos : tfileposinfo;
+    i: longint;
 begin
 { Save the position where this procedure really starts and set col to 1 which
   looks nicer }
@@ -337,7 +339,44 @@ begin
       consume(_ID);
     end;
 
-{ method ? }
+    { examine interface map: function/procedure iname.functionname=locfuncname }
+    if parse_only and assigned(procinfo^._class) and
+       assigned(procinfo^._class^.implementedinterfaces) and
+       (procinfo^._class^.implementedinterfaces^.count>0) and
+       try_to_consume(_POINT) then
+      begin
+         storepos:=akttokenpos;
+         akttokenpos:=procstartfilepos;
+         { get interface syms}
+         getsym(sp,true);
+         sym:=srsym;
+         akttokenpos:=storepos;
+         { load proc name }
+         sp:=pattern;
+         if sym^.typ=typesym then
+           i:=procinfo^._class^.implementedinterfaces^.searchintf(ptypesym(sym)^.restype.def);
+         { qualifier is interface name? }
+         if (sym^.typ<>typesym) or (ptypesym(sym)^.restype.def^.deftype<>objectdef) or
+            (i=-1) then
+           begin
+              Message(parser_e_interface_id_expected);
+              aktprocsym:=nil;
+           end
+         else
+           begin
+              aktprocsym:=pprocsym(procinfo^._class^.implementedinterfaces^.interfaces(i)^.symtable^.search(sp));
+              if not(assigned(aktprocsym)) then
+                Message(parser_e_methode_id_expected);
+           end;
+         consume(_ID);
+         consume(_EQUAL);
+         if (token=_ID) and assigned(aktprocsym) then
+           procinfo^._class^.implementedinterfaces^.addmappings(i,sp,pattern);
+         consume(_ID);
+         exit;
+    end;
+
+  { method  ? }
   if not(parse_only) and
      (lexlevel=normal_function_level) and
      try_to_consume(_POINT) then
@@ -508,7 +547,7 @@ begin
     end;
 
   if assigned (procinfo^._Class)  and
-     not(procinfo^._Class^.is_class) and
+     is_object(procinfo^._Class) and
      (pd^.proctypeoption in [potype_constructor,potype_destructor]) then
     inc(paramoffset,target_os.size_of_pointer);
 
@@ -524,7 +563,7 @@ begin
 
   { con/-destructor flag ? }
   if assigned (procinfo^._Class) and
-     procinfo^._class^.is_class and
+     is_class(procinfo^._class) and
      (pd^.proctypeoption in [potype_destructor,potype_constructor]) then
     inc(paramoffset,target_os.size_of_pointer);
 
@@ -592,7 +631,8 @@ begin
                    parse_proc_head(potype_none);
                    if token<>_COLON then
                     begin
-                       if not(aktprocsym^.definition^.forwarddef) or
+                       if not(is_interface(aktprocsym^.definition^._class)) and
+                          not(aktprocsym^.definition^.forwarddef) or
                          (m_repeat_forward in aktmodeswitches) then
                        begin
                          consume(_COLON);
@@ -617,7 +657,7 @@ begin
                    consume(_CONSTRUCTOR);
                    parse_proc_head(potype_constructor);
                    if assigned(procinfo^._class) and
-                      procinfo^._class^.is_class then
+                      is_class(procinfo^._class) then
                     begin
                       { CLASS constructors return the created instance }
                       aktprocsym^.definition^.rettype.def:=procinfo^._class;
@@ -804,10 +844,10 @@ var
 {$endif WITHDMT}
 begin
   if (aktprocsym^.definition^.proctypeoption=potype_constructor) and
-     not(aktprocsym^.definition^._class^.is_class) then
+     is_object(aktprocsym^.definition^._class) then
     Message(parser_e_constructor_cannot_be_not_virtual);
 {$ifdef WITHDMT}
-  if not(aktprocsym^.definition^._class^.is_class) and
+  if is_object(aktprocsym^.definition^._class) and
     (token<>_SEMICOLON) then
     begin
        { any type of parameter is allowed here! }
@@ -837,7 +877,7 @@ end;
 
 procedure pd_override(const procnames:Tstringcontainer);
 begin
-  if not(aktprocsym^.definition^._class^.is_class) then
+  if not(is_class_or_interface(aktprocsym^.definition^._class)) then
     Message(parser_e_no_object_override);
 end;
 
@@ -1043,7 +1083,7 @@ const
    (
     (
       idtok:_ABSTRACT;
-      pd_flags : pd_interface+pd_object;
+      pd_flags : pd_interface+pd_object+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_abstract;
       pocall   : [];
       pooption : [po_abstractmethod];
@@ -1052,7 +1092,7 @@ const
       mutexclpo     : [po_exports,po_interrupt,po_external]
     ),(
       idtok:_ALIAS;
-      pd_flags : pd_implemen+pd_body;
+      pd_flags : pd_implemen+pd_body+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_alias;
       pocall   : [];
       pooption : [];
@@ -1061,7 +1101,7 @@ const
       mutexclpo     : [po_external]
     ),(
       idtok:_ASMNAME;
-      pd_flags : pd_interface+pd_implemen;
+      pd_flags : pd_interface+pd_implemen+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_asmname;
       pocall   : [pocall_cdecl,pocall_clearstack];
       pooption : [po_external];
@@ -1070,7 +1110,7 @@ const
       mutexclpo     : [po_external]
     ),(
       idtok:_ASSEMBLER;
-      pd_flags : pd_implemen+pd_body;
+      pd_flags : pd_implemen+pd_body+pd_notobjintf;
       handler  : nil;
       pocall   : [];
       pooption : [po_assembler];
@@ -1088,7 +1128,7 @@ const
       mutexclpo     : [po_assembler,po_external]
     ),(
       idtok:_DYNAMIC;
-      pd_flags : pd_interface+pd_object;
+      pd_flags : pd_interface+pd_object+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
       pocall   : [];
       pooption : [po_virtualmethod];
@@ -1097,7 +1137,7 @@ const
       mutexclpo     : [po_exports,po_interrupt,po_external]
     ),(
       idtok:_EXPORT;
-      pd_flags : pd_body+pd_global+pd_interface+pd_implemen{??};
+      pd_flags : pd_body+pd_global+pd_interface+pd_implemen{??}+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_export;
       pocall   : [];
       pooption : [po_exports];
@@ -1106,7 +1146,7 @@ const
       mutexclpo     : [po_external,po_interrupt]
     ),(
       idtok:_EXTERNAL;
-      pd_flags : pd_implemen+pd_interface;
+      pd_flags : pd_implemen+pd_interface+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_external;
       pocall   : [];
       pooption : [po_external];
@@ -1115,7 +1155,7 @@ const
       mutexclpo     : [po_exports,po_interrupt,po_assembler]
     ),(
       idtok:_FAR;
-      pd_flags : pd_implemen+pd_body+pd_interface+pd_procvar;
+      pd_flags : pd_implemen+pd_body+pd_interface+pd_procvar+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_far;
       pocall   : [];
       pooption : [];
@@ -1124,7 +1164,7 @@ const
       mutexclpo     : []
     ),(
       idtok:_FORWARD;
-      pd_flags : pd_implemen;
+      pd_flags : pd_implemen+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_forward;
       pocall   : [];
       pooption : [];
@@ -1133,7 +1173,7 @@ const
       mutexclpo     : [po_external]
     ),(
       idtok:_INLINE;
-      pd_flags : pd_implemen+pd_body;
+      pd_flags : pd_implemen+pd_body+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_inline;
       pocall   : [pocall_inline];
       pooption : [];
@@ -1142,7 +1182,7 @@ const
       mutexclpo     : [po_exports,po_external,po_interrupt]
     ),(
       idtok:_INTERNCONST;
-      pd_flags : pd_implemen+pd_body;
+      pd_flags : pd_implemen+pd_body+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
       pocall   : [pocall_internconst];
       pooption : [];
@@ -1151,7 +1191,7 @@ const
       mutexclpo     : []
     ),(
       idtok:_INTERNPROC;
-      pd_flags : pd_implemen;
+      pd_flags : pd_implemen+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_intern;
       pocall   : [pocall_internproc];
       pooption : [];
@@ -1160,7 +1200,7 @@ const
       mutexclpo     : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck]
     ),(
       idtok:_INTERRUPT;
-      pd_flags : pd_implemen+pd_body;
+      pd_flags : pd_implemen+pd_body+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_interrupt;
       pocall   : [];
       pooption : [po_interrupt];
@@ -1169,7 +1209,7 @@ const
       mutexclpo     : [po_external]
     ),(
       idtok:_IOCHECK;
-      pd_flags : pd_implemen+pd_body;
+      pd_flags : pd_implemen+pd_body+pd_notobjintf;
       handler  : nil;
       pocall   : [];
       pooption : [po_iocheck];
@@ -1178,7 +1218,7 @@ const
       mutexclpo     : [po_external]
     ),(
       idtok:_MESSAGE;
-      pd_flags : pd_interface+pd_object;
+      pd_flags : pd_interface+pd_object+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_message;
       pocall   : [];
       pooption : []; { can be po_msgstr or po_msgint }
@@ -1187,7 +1227,7 @@ const
       mutexclpo     : [po_interrupt,po_external]
     ),(
       idtok:_NEAR;
-      pd_flags : pd_implemen+pd_body+pd_procvar;
+      pd_flags : pd_implemen+pd_body+pd_procvar+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_near;
       pocall   : [];
       pooption : [];
@@ -1205,7 +1245,7 @@ const
       mutexclpo     : []
     ),(
       idtok:_OVERRIDE;
-      pd_flags : pd_interface+pd_object;
+      pd_flags : pd_interface+pd_object+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_override;
       pocall   : [];
       pooption : [po_overridingmethod,po_virtualmethod];
@@ -1232,7 +1272,7 @@ const
       mutexclpo     : [po_assembler,po_external]
     ),(
       idtok:_PUBLIC;
-      pd_flags : pd_implemen+pd_body+pd_global+pd_notobject;
+      pd_flags : pd_implemen+pd_body+pd_global+pd_notobject+pd_notobjintf;
       handler  : nil;
       pocall   : [];
       pooption : [];
@@ -1268,7 +1308,7 @@ const
       mutexclpo     : [po_external]
     ),(
       idtok:_SAVEREGISTERS;
-      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar;
+      pd_flags : pd_interface+pd_implemen+pd_body+pd_procvar+pd_notobjintf;
       handler  : nil;
       pocall   : [];
       pooption : [po_saveregisters];
@@ -1277,7 +1317,7 @@ const
       mutexclpo     : [po_external]
     ),(
       idtok:_STATIC;
-      pd_flags : pd_interface+pd_object;
+      pd_flags : pd_interface+pd_object+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_static;
       pocall   : [];
       pooption : [po_staticmethod];
@@ -1295,7 +1335,7 @@ const
       mutexclpo     : [po_external]
     ),(
       idtok:_SYSCALL;
-      pd_flags : pd_interface;
+      pd_flags : pd_interface+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_syscall;
       pocall   : [pocall_palmossyscall];
       pooption : [];
@@ -1304,7 +1344,7 @@ const
       mutexclpo     : [po_external,po_assembler,po_interrupt,po_exports]
     ),(
       idtok:_SYSTEM;
-      pd_flags : pd_implemen;
+      pd_flags : pd_implemen+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_system;
       pocall   : [pocall_clearstack];
       pooption : [];
@@ -1313,7 +1353,7 @@ const
       mutexclpo     : [po_external,po_assembler,po_interrupt]
     ),(
       idtok:_VIRTUAL;
-      pd_flags : pd_interface+pd_object;
+      pd_flags : pd_interface+pd_object+pd_notobjintf;
       handler  : {$ifdef FPCPROCVAR}@{$endif}pd_virtual;
       pocall   : [];
       pooption : [po_virtualmethod];
@@ -1402,6 +1442,13 @@ begin
       exit;
     end;
 
+{ check if method and directive not for interface }
+  if ((proc_direcdata[p].pd_flags and pd_notobjintf)<>0) and
+     is_interface(aktprocsym^.definition^._class) then
+    begin
+      exit;
+    end;
+
 { consume directive, and turn flag on }
   consume(token);
   parse_proc_direc:=true;
@@ -1815,7 +1862,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.5  2000-11-01 23:04:37  peter
+  Revision 1.6  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.5  2000/11/01 23:04:37  peter
     * tprocdef.fullprocname added for better casesensitve writing of
       procedures
 
@@ -1834,5 +1884,4 @@ end.
 
   Revision 1.1  2000/10/14 10:14:51  peter
     * moehrendorf oct 2000 rewrite
-
 }

compiler/pdecvar.pas

@@ -422,7 +422,7 @@ implementation
                begin
                   { save object option, because we can turn of the sp_published }
                   if (sp_published in current_object_option) and
-                    (not((tt.def^.deftype=objectdef) and (pobjectdef(tt.def)^.is_class))) then
+                    not(is_class(tt.def)) then
                    begin
                      Message(parser_e_cant_publish_that);
                      exclude(current_object_option,sp_published);
@@ -527,7 +527,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.2  2000-10-31 22:02:49  peter
+  Revision 1.3  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.2  2000/10/31 22:02:49  peter
     * symtable splitted, no real code changes
 
   Revision 1.1  2000/10/14 10:14:51  peter

compiler/pexpr.pas

@@ -368,7 +368,7 @@ implementation
                    procvardef,
                    classrefdef : ;
                    objectdef :
-                     if not(pobjectdef(p1.resulttype)^.is_class) then
+                     if not is_class_or_interface(p1.resulttype) then
                        Message(parser_e_illegal_parameter_list);
                    else
                      Message(parser_e_illegal_parameter_list);
@@ -1191,10 +1191,9 @@ implementation
                                        p1:=gentypeconvnode(p1,pd);
                                        include(p1.flags,nf_explizit);
                                      end
-                                    else { not LKLAMMER}
+                                    else { not LKLAMMER }
                                      if (token=_POINT) and
-                                        (pd^.deftype=objectdef) and
-                                        not(pobjectdef(pd)^.is_class) then
+                                        is_object(pd) then
                                        begin
                                          consume(_POINT);
                                          if assigned(procinfo) and
@@ -1246,8 +1245,7 @@ implementation
                                      else
                                        begin
                                           { class reference ? }
-                                          if (pd^.deftype=objectdef)
-                                            and pobjectdef(pd)^.is_class then
+                                          if is_object(pd) then
                                             begin
                                                if getaddr and (token=_POINT) then
                                                  begin
@@ -1540,7 +1538,7 @@ implementation
 
                _LECKKLAMMER:
                   begin
-                    if (pd^.deftype=objectdef) and pobjectdef(pd)^.is_class then
+                    if is_class_or_interface(pd) then
                       begin
                         { default property }
                         propsym:=search_default_property(pobjectdef(pd));
@@ -2374,7 +2372,10 @@ _LECKKLAMMER : begin
 end.
 {
   $Log$
-  Revision 1.14  2000-10-31 22:02:49  peter
+  Revision 1.15  2000-11-04 14:25:20  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.14  2000/10/31 22:02:49  peter
     * symtable splitted, no real code changes
 
   Revision 1.13  2000/10/26 23:40:54  peter

compiler/pstatmnt.pas

@@ -596,8 +596,7 @@ implementation
                                     consume(_ID);
                                  end;
                                if (srsym^.typ=typesym) and
-                                 (ptypesym(srsym)^.restype.def^.deftype=objectdef) and
-                                 pobjectdef(ptypesym(srsym)^.restype.def)^.is_class then
+                                  is_class(ptypesym(srsym)^.restype.def) then
                                  begin
                                     ot:=pobjectdef(ptypesym(srsym)^.restype.def);
                                     sym:=new(pvarsym,initdef(objname,ot));
@@ -633,8 +632,7 @@ implementation
                                     consume(_ID);
                                  end;
                                if (srsym^.typ=typesym) and
-                                 (ptypesym(srsym)^.restype.def^.deftype=objectdef) and
-                                 pobjectdef(ptypesym(srsym)^.restype.def)^.is_class then
+                                  is_class(ptypesym(srsym)^.restype.def) then
                                  ot:=pobjectdef(ptypesym(srsym)^.restype.def)
                                else
                                  begin
@@ -893,7 +891,7 @@ implementation
               end;
             { check, if the first parameter is a pointer to a _class_ }
             classh:=pobjectdef(ppointerdef(pd)^.pointertype.def);
-            if classh^.is_class then
+            if is_class(classh) then
               begin
                  Message(parser_e_no_new_or_dispose_for_classes);
                  new_dispose_statement:=factor(false);
@@ -1258,7 +1256,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.12  2000-10-31 22:02:50  peter
+  Revision 1.13  2000-11-04 14:25:21  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.12  2000/10/31 22:02:50  peter
     * symtable splitted, no real code changes
 
   Revision 1.11  2000/10/14 21:52:56  peter

compiler/ptconst.pas

@@ -76,6 +76,7 @@ implementation
          ll        : pasmlabel;
          s         : string;
          ca        : pchar;
+         tmpguid   : tguid;
          aktpos    : longint;
          obj       : pobjectdef;
          symt      : psymtable;
@@ -600,7 +601,7 @@ implementation
               if p.nodetype=calln then
                begin
                  if (tcallnode(p).symtableprocentry^.owner^.symtabletype=objectsymtable) and
-                    (pobjectdef(tcallnode(p).symtableprocentry^.owner^.defowner)^.is_class) then
+                    is_class(pdef(tcallnode(p).symtableprocentry^.owner^.defowner)) then
                   hp:=genloadmethodcallnode(pprocsym(tcallnode(p).symtableprocentry),tcallnode(p).symtableproc,
                         tcallnode(p).methodpointer.getcopy)
                  else
@@ -618,9 +619,9 @@ implementation
                 (taddrnode(p).left.nodetype=calln) then
                 begin
                    if (tcallnode(taddrnode(p).left).symtableprocentry^.owner^.symtabletype=objectsymtable) and
-                      (pobjectdef(tcallnode(taddrnode(p).left).symtableprocentry^.owner^.defowner)^.is_class) then
+                      is_class(pdef(tcallnode(taddrnode(p).left).symtableprocentry^.owner^.defowner)) then
                     hp:=genloadmethodcallnode(pprocsym(tcallnode(taddrnode(p).left).symtableprocentry),
-                    tcallnode(taddrnode(p).left).symtableproc,tcallnode(taddrnode(p).left).methodpointer.getcopy)
+                      tcallnode(taddrnode(p).left).symtableproc,tcallnode(taddrnode(p).left).methodpointer.getcopy)
                    else
                     hp:=genloadcallnode(pprocsym(tcallnode(taddrnode(p).left).symtableprocentry),
                       tcallnode(taddrnode(p).left).symtableproc);
@@ -672,62 +673,95 @@ implementation
          { reads a typed constant record }
          recorddef:
            begin
-              consume(_LKLAMMER);
-              aktpos:=0;
-              while token<>_RKLAMMER do
+              { KAZ }
+              if (precorddef(def)=rec_tguid) and
+                 ((token=_CSTRING) or (token=_CCHAR) or (token=_ID)) then
                 begin
-                   s:=pattern;
-                   consume(_ID);
-                   consume(_COLON);
-                   srsym:=psym(precorddef(def)^.symtable^.search(s));
-                   if srsym=nil then
-                     begin
-                        Message1(sym_e_id_not_found,s);
-                        consume_all_until(_SEMICOLON);
-                     end
-                   else
+                  p:=comp_expr(true);
+                  p:=gentypeconvnode(p,cshortstringdef);
+                  do_firstpass(p);
+                  if p.nodetype=stringconstn then
+                    begin
+                      s:=strpas(tstringconstnode(p).value_str);
+                      p.free;
+                      if string2guid(s,tmpguid) then
+                        begin
+                          curconstsegment^.concat(new(pai_const,init_32bit(tmpguid.D1)));
+                          curconstsegment^.concat(new(pai_const,init_16bit(tmpguid.D2)));
+                          curconstsegment^.concat(new(pai_const,init_16bit(tmpguid.D3)));
+                          for i:=Low(tmpguid.D4) to High(tmpguid.D4) do
+                            curconstsegment^.concat(new(pai_const,init_8bit(tmpguid.D4[i])));
+                        end
+                      else
+                        Message(parser_e_improper_guid_syntax);
+                    end
+                  else
+                    begin
+                      p.free;
+                      Message(cg_e_illegal_expression);
+                      exit;
+                    end;
+                end
+              else
+                begin
+                   consume(_LKLAMMER);
+                   aktpos:=0;
+                   while token<>_RKLAMMER do
                      begin
-                        { check position }
-                        if pvarsym(srsym)^.address<aktpos then
-                          Message(parser_e_invalid_record_const);
+                        s:=pattern;
+                        consume(_ID);
+                        consume(_COLON);
+                        srsym:=psym(precorddef(def)^.symtable^.search(s));
+                        if srsym=nil then
+                          begin
+                             Message1(sym_e_id_not_found,s);
+                             consume_all_until(_SEMICOLON);
+                          end
+                        else
+                          begin
+                             { check position }
+                             if pvarsym(srsym)^.address<aktpos then
+                               Message(parser_e_invalid_record_const);
 
-                        { if needed fill }
-                        if pvarsym(srsym)^.address>aktpos then
-                          for i:=1 to pvarsym(srsym)^.address-aktpos do
-                            curconstsegment^.concat(new(pai_const,init_8bit(0)));
+                             { if needed fill }
+                             if pvarsym(srsym)^.address>aktpos then
+                               for i:=1 to pvarsym(srsym)^.address-aktpos do
+                                 curconstsegment^.concat(new(pai_const,init_8bit(0)));
 
-                        { new position }
-                        aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size;
+                             { new position }
+                             aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.vartype.def^.size;
 
-                        { read the data }
-                        readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed);
+                             { read the data }
+                             readtypedconst(pvarsym(srsym)^.vartype.def,nil,no_change_allowed);
 
-                        if token=_SEMICOLON then
-                          consume(_SEMICOLON)
-                        else break;
-                     end;
+                             if token=_SEMICOLON then
+                               consume(_SEMICOLON)
+                             else break;
+                          end;
+                   end;
                 end;
-              for i:=1 to def^.size-aktpos do
-                curconstsegment^.concat(new(pai_const,init_8bit(0)));
-              consume(_RKLAMMER);
            end;
          { reads a typed object }
          objectdef:
            begin
-              if ([oo_has_vmt,oo_is_class]*pobjectdef(def)^.objectoptions)<>[] then
+              if is_class_or_interface(def) then
                 begin
-                   { support nil assignment for classes }
-                   if pobjectdef(def)^.is_class and
-                      try_to_consume(_NIL) then
-                    begin
-                      curconstsegment^.concat(new(pai_const,init_32bit(0)));
-                    end
-                   else
+                  p:=comp_expr(true);
+                  do_firstpass(p);
+                  if p.nodetype<>niln then
                     begin
                       Message(parser_e_type_const_not_possible);
                       consume_all_until(_RKLAMMER);
+                    end
+                  else
+                    begin
+                      curconstsegment^.concat(new(pai_const,init_32bit(0)));
                     end;
+                  p.free;
                 end
+              { for objects we allow it only if it doesn't contain a vmt }
+              else if (oo_has_vmt in pobjectdef(def)^.objectoptions) then
+                 Message(parser_e_type_const_not_possible)
               else
                 begin
                    consume(_LKLAMMER);
@@ -801,7 +835,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.10  2000-10-31 22:02:51  peter
+  Revision 1.11  2000-11-04 14:25:21  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.10  2000/10/31 22:02:51  peter
     * symtable splitted, no real code changes
 
   Revision 1.9  2000/10/14 10:14:52  peter

compiler/ptype.pas

@@ -93,7 +93,7 @@ implementation
          s:=pattern;
          pos:=akttokenpos;
          { classes can be used also in classes }
-         if (curobjectname=pattern) and aktobjectdef^.is_class then
+         if (curobjectname=pattern) and is_class_or_interface(aktobjectdef) then
            begin
               tt.setdef(aktobjectdef);
               consume(_ID);
@@ -254,7 +254,7 @@ implementation
                 exit;
              end;
            { classes can be used also in classes }
-           if (curobjectname=pattern) and aktobjectdef^.is_class then
+           if (curobjectname=pattern) and is_class_or_interface(aktobjectdef) then
              begin
                 tt.setdef(aktobjectdef);
                 consume(_ID);
@@ -538,9 +538,7 @@ implementation
               end;
             _CLASS,
             _CPPCLASS,
-{$ifdef SUPPORTINTERFACES}
             _INTERFACE,
-{$endif SUPPORTINTERFACES}
             _OBJECT:
               begin
                 tt.setdef(object_dec(name,nil));
@@ -583,7 +581,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  2000-10-31 22:02:51  peter
+  Revision 1.14  2000-11-04 14:25:21  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.13  2000/10/31 22:02:51  peter
     * symtable splitted, no real code changes
 
   Revision 1.12  2000/10/26 21:54:03  peter

compiler/rautils.pas

@@ -906,6 +906,10 @@ Begin
                       opr.ref.options:=ref_none;
                     end;
                 end;
+              if (pvarsym(sym)^.varspez in [vs_var,vs_out]) or
+                 ((pvarsym(sym)^.varspez=vs_const) and
+                  push_addr_param(pvarsym(sym)^.vartype.def)) then
+                SetSize(target_os.size_of_pointer,false);
             end;
         end;
         case pvarsym(sym)^.vartype.def^.deftype of
@@ -1548,7 +1552,10 @@ end;
 end.
 {
   $Log$
-  Revision 1.9  2000-10-31 22:30:13  peter
+  Revision 1.10  2000-11-04 14:25:21  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.9  2000/10/31 22:30:13  peter
     * merged asm result patch part 2
 
   Revision 1.8  2000/10/31 22:02:51  peter

compiler/regvars.pas

@@ -192,7 +192,7 @@ implementation
 
                       { possibly no 32 bit register are needed }
                       { call by reference/const ? }
-                      if (regvarinfo^.regvars[i]^.varspez=vs_var) or
+                      if (regvarinfo^.regvars[i]^.varspez in [vs_var,vs_out]) or
                          ((regvarinfo^.regvars[i]^.varspez=vs_const) and
                            push_addr_param(regvarinfo^.regvars[i]^.vartype.def)) then
                         begin
@@ -464,7 +464,10 @@ end.
 
 {
   $Log$
-  Revision 1.11  2000-10-31 22:02:51  peter
+  Revision 1.12  2000-11-04 14:25:21  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.11  2000/10/31 22:02:51  peter
     * symtable splitted, no real code changes
 
   Revision 1.10  2000/10/14 10:14:52  peter

compiler/scandir.inc

@@ -36,6 +36,7 @@ type
      _DIR_I,_DIR_I386_ATT,_DIR_I386_DIRECT,_DIR_I386_INTEL,_DIR_IOCHECKS,
        _DIR_IF,_DIR_IFDEF,_DIR_IFNDEF,_DIR_IFOPT,_DIR_INCLUDE,_DIR_INCLUDEPATH,
        _DIR_INFO,_DIR_INLINE,
+       _DIR_INTERFACES,
      _DIR_L,_DIR_LIBRARYPATH,_DIR_LINK,_DIR_LINKLIB,_DIR_LOCALSYMBOLS,
        _DIR_LONGSTRINGS,
      _DIR_M,_DIR_MACRO,_DIR_MAXFPUREGISTERS,_DIR_MEMORY,_DIR_MESSAGE,_DIR_MINENUMSIZE,_DIR_MMX,_DIR_MODE,
@@ -90,6 +91,7 @@ const
      'INCLUDEPATH',
      'INFO',
      'INLINE',
+     'INTERFACES',
      'L',
      'LIBRARYPATH',
      'LINK',
@@ -575,6 +577,22 @@ const
          end;
       end;
 
+    procedure dir_interfacesswitch(t:tdirectivetoken);
+      var
+        hs : string;
+      begin
+        {corba/com/default}
+        current_scanner^.skipspace;
+        hs:=current_scanner^.readid;
+        if (hs='CORBA') then
+          aktinterfacetype:=it_interfacecorba
+        else if (hs='COM') then
+          aktinterfacetype:=it_interfacecom
+        else if (hs='DEFAULT') then
+          aktinterfacetype:=initinterfacetype
+        else
+          Message(scan_e_invalid_interface_type);
+      end;
 
     procedure dir_localswitch(t:tdirectivetoken);
       var
@@ -1302,6 +1320,7 @@ const
          {_DIR_INCLUDEPATH} dir_includepath,
          {_DIR_INFO} dir_message,
          {_DIR_INLINE} dir_moduleswitch,
+         {_DIR_INTERFACES} dir_interfacesswitch,
          {_DIR_L} dir_linkobject,
          {_DIR_LIBRARYPATH} dir_librarypath,
          {_DIR_LINK} dir_linkobject,
@@ -1436,7 +1455,10 @@ const
 
 {
   $Log$
-  Revision 1.10  2000-10-31 22:02:51  peter
+  Revision 1.11  2000-11-04 14:25:21  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.10  2000/10/31 22:02:51  peter
     * symtable splitted, no real code changes
 
   Revision 1.9  2000/09/26 10:50:41  jonas

compiler/symconst.pas

@@ -54,6 +54,7 @@ const
   tkInt64    = 19;
   tkQWord    = 20;
   tkDynArray = 21;
+  tkInterfaceCorba = 22;
 
   otSByte    = 0;
   otUByte    = 1;
@@ -196,9 +197,17 @@ type
   );
   tprocoptions=set of tprocoption;
 
+  { options for objects and classes }
+  tobjectdeftype = (
+    odt_class,
+    odt_object,
+    odt_interfacecom,
+    odt_interfacecorba,
+    odt_cppclass
+  );
+
   { options for objects and classes }
   tobjectoption=(oo_none,
-    oo_is_class,
     oo_is_forward,         { the class is only a forward declared yet }
     oo_has_virtual,        { the object/class has virtual methods }
     oo_has_private,
@@ -209,10 +218,7 @@ type
     oo_has_msgstr,
     oo_has_msgint,
     oo_has_abstract,       { the object/class has an abstract method => no instances can be created }
-    oo_can_have_published, { the class has rtti, i.e. you can publish properties }
-    oo_is_cppclass,        { the object/class uses an C++ compatible }
-                           { class layout }
-    oo_is_interface        { delphi styled interface }
+    oo_can_have_published { the class has rtti, i.e. you can publish properties }
   );
 
   tobjectoptions=set of tobjectoption;
@@ -322,7 +328,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.11  2000-10-31 22:02:51  peter
+  Revision 1.12  2000-11-04 14:25:21  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.11  2000/10/31 22:02:51  peter
     * symtable splitted, no real code changes
 
   Revision 1.9  2000/10/15 07:47:52  peter

compiler/symdef.inc

@@ -0,0 +1,4805 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
+
+    Symbol table implementation for the definitions
+
+    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.
+ ****************************************************************************
+}
+
+{****************************************************************************
+                     TDEF (base class for definitions)
+****************************************************************************}
+
+    function tparalinkedlist.count:longint;
+      begin
+        { You must use tabstractprocdef.minparacount and .maxparacount instead }
+        internalerror(432432978);
+        count:=0;
+      end;
+
+
+{****************************************************************************
+                     TDEF (base class for definitions)
+****************************************************************************}
+
+
+    constructor tdef.init;
+      begin
+         inherited init;
+         deftype:=abstractdef;
+         owner := nil;
+         typesym := nil;
+         savesize := 0;
+         if registerdef then
+           symtablestack^.registerdef(@self);
+         has_rtti:=false;
+         has_inittable:=false;
+{$ifdef GDB}
+         is_def_stab_written := not_written;
+         globalnb := 0;
+{$endif GDB}
+         if assigned(lastglobaldef) then
+           begin
+              lastglobaldef^.nextglobal := @self;
+              previousglobal:=lastglobaldef;
+           end
+         else
+           begin
+              firstglobaldef := @self;
+              previousglobal := nil;
+           end;
+         lastglobaldef := @self;
+         nextglobal := nil;
+      end;
+
+{$ifdef MEMDEBUG}
+   var
+       manglenamesize : longint;
+{$endif}
+
+    constructor tdef.load;
+      begin
+         inherited init;
+         deftype:=abstractdef;
+         owner := nil;
+         has_rtti:=false;
+         has_inittable:=false;
+{$ifdef GDB}
+         is_def_stab_written := not_written;
+         globalnb := 0;
+{$endif GDB}
+         if assigned(lastglobaldef) then
+           begin
+              lastglobaldef^.nextglobal := @self;
+              previousglobal:=lastglobaldef;
+           end
+         else
+           begin
+              firstglobaldef := @self;
+              previousglobal:=nil;
+           end;
+         lastglobaldef := @self;
+         nextglobal := nil;
+      { load }
+         indexnr:=readword;
+         typesym:=ptypesym(readsymref);
+      end;
+
+
+    destructor tdef.done;
+      begin
+         { first element  ? }
+         if not(assigned(previousglobal)) then
+           begin
+              firstglobaldef := nextglobal;
+              if assigned(firstglobaldef) then
+                firstglobaldef^.previousglobal:=nil;
+           end
+         else
+           begin
+              { remove reference in the element before }
+              previousglobal^.nextglobal:=nextglobal;
+           end;
+         { last element ? }
+         if not(assigned(nextglobal)) then
+           begin
+              lastglobaldef := previousglobal;
+              if assigned(lastglobaldef) then
+                lastglobaldef^.nextglobal:=nil;
+           end
+         else
+           nextglobal^.previousglobal:=previousglobal;
+         previousglobal:=nil;
+         nextglobal:=nil;
+{$ifdef SYNONYM}
+         while assigned(typesym) do
+           begin
+              typesym^.restype.setdef(nil);
+              typesym:=typesym^.synonym;
+           end;
+{$endif}
+      end;
+
+    { used for enumdef because the symbols are
+      inserted in the owner symtable }
+    procedure tdef.correct_owner_symtable;
+      var
+         st : psymtable;
+      begin
+         if assigned(owner) and
+            (owner^.symtabletype in [recordsymtable,objectsymtable]) then
+           begin
+              owner^.defindex^.deleteindex(@self);
+              st:=owner;
+              while (st^.symtabletype in [recordsymtable,objectsymtable]) do
+                st:=st^.next;
+              st^.registerdef(@self);
+           end;
+      end;
+
+
+    function tdef.typename:string;
+      begin
+        if assigned(typesym) and not(deftype=procvardef) and
+          assigned(typesym^._realname) and
+          (typesym^._realname^[1]<>'$') then
+         typename:=typesym^._realname^
+        else
+         typename:=gettypename;
+      end;
+
+    function tdef.gettypename : string;
+
+      begin
+         gettypename:='<unknown type>'
+      end;
+
+    function tdef.is_in_current : boolean;
+      var
+        p : psymtable;
+      begin
+         p:=owner;
+         is_in_current:=false;
+         while assigned(p) do
+           begin
+              if (p=current_module^.globalsymtable) or (p=current_module^.localsymtable)
+                 or (p^.symtabletype in [globalsymtable,staticsymtable]) then
+                begin
+                   is_in_current:=true;
+                   exit;
+                end
+              else if p^.symtabletype in [localsymtable,parasymtable,objectsymtable] then
+                begin
+                  if assigned(p^.defowner) then
+                    p:=pobjectdef(p^.defowner)^.owner
+                  else
+                    exit;
+                end
+              else
+                exit;
+           end;
+
+      end;
+
+    procedure tdef.write;
+      begin
+        writeword(indexnr);
+        writesymref(typesym);
+{$ifdef GDB}
+        if globalnb = 0 then
+          begin
+            if assigned(owner) then
+              globalnb := owner^.getnewtypecount
+            else
+              begin
+                globalnb := PGlobalTypeCount^;
+                Inc(PGlobalTypeCount^);
+              end;
+           end;
+{$endif GDB}
+      end;
+
+
+    function tdef.size : longint;
+      begin
+         size:=savesize;
+      end;
+
+
+    function tdef.alignment : longint;
+      begin
+         { normal alignment by default }
+         alignment:=0;
+      end;
+
+
+{$ifdef GDB}
+   procedure tdef.set_globalnb;
+     begin
+         globalnb :=PGlobalTypeCount^;
+         inc(PglobalTypeCount^);
+     end;
+
+    function tdef.stabstring : pchar;
+      begin
+      stabstring := strpnew('t'+numberstring+';');
+      end;
+
+
+    function tdef.numberstring : string;
+      var table : psymtable;
+      begin
+      {formal def have no type !}
+      if deftype = formaldef then
+        begin
+        numberstring := voiddef^.numberstring;
+        exit;
+        end;
+      if (not assigned(typesym)) or (not typesym^.isusedinstab) then
+        begin
+           {set even if debuglist is not defined}
+           if assigned(typesym) then
+             typesym^.isusedinstab := true;
+           if assigned(debuglist) and (is_def_stab_written = not_written) then
+             concatstabto(debuglist);
+        end;
+      if not (cs_gdb_dbx in aktglobalswitches) then
+        begin
+           if globalnb = 0 then
+             set_globalnb;
+           numberstring := tostr(globalnb);
+        end
+      else
+        begin
+           if globalnb = 0 then
+             begin
+                if assigned(owner) then
+                  globalnb := owner^.getnewtypecount
+                else
+                  begin
+                     globalnb := PGlobalTypeCount^;
+                     Inc(PGlobalTypeCount^);
+                  end;
+             end;
+           if assigned(typesym) then
+             begin
+                table := typesym^.owner;
+                if table^.unitid > 0 then
+                  numberstring := '('+tostr(table^.unitid)+','+tostr(typesym^.restype.def^.globalnb)+')'
+                else
+                  numberstring := tostr(globalnb);
+                exit;
+             end;
+           numberstring := tostr(globalnb);
+        end;
+      end;
+
+
+    function tdef.allstabstring : pchar;
+    var stabchar : string[2];
+        ss,st : pchar;
+        sname : string;
+        sym_line_no : longint;
+      begin
+      ss := stabstring;
+      getmem(st,strlen(ss)+512);
+      stabchar := 't';
+      if deftype in tagtypes then
+        stabchar := 'Tt';
+      if assigned(typesym) then
+        begin
+           sname := typesym^.name;
+           sym_line_no:=typesym^.fileinfo.line;
+        end
+      else
+        begin
+           sname := ' ';
+           sym_line_no:=0;
+        end;
+      strpcopy(st,'"'+sname+':'+stabchar+numberstring+'=');
+      strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
+      allstabstring := strnew(st);
+      freemem(st,strlen(ss)+512);
+      strdispose(ss);
+      end;
+
+
+    procedure tdef.concatstabto(asmlist : paasmoutput);
+     var stab_str : pchar;
+    begin
+    if ((typesym = nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
+      and (is_def_stab_written = not_written) then
+      begin
+      If cs_gdb_dbx in aktglobalswitches then
+        begin
+           { otherwise you get two of each def }
+           If assigned(typesym) then
+             begin
+                if typesym^.typ=symconst.typesym then
+                  typesym^.isusedinstab:=true;
+                if (typesym^.owner = nil) or
+                  ((typesym^.owner^.symtabletype = unitsymtable) and
+                 punitsymtable(typesym^.owner)^.dbx_count_ok)  then
+                begin
+                   {with DBX we get the definition from the other objects }
+                   is_def_stab_written := written;
+                   exit;
+                end;
+             end;
+        end;
+      { to avoid infinite loops }
+      is_def_stab_written := being_written;
+      stab_str := allstabstring;
+      asmlist^.concat(new(pai_stabs,init(stab_str)));
+      is_def_stab_written := written;
+      end;
+    end;
+{$endif GDB}
+
+
+    procedure tdef.deref;
+      begin
+        resolvesym(psym(typesym));
+      end;
+
+
+    { rtti generation }
+    procedure tdef.generate_rtti;
+      begin
+         if not has_rtti then
+          begin
+            has_rtti:=true;
+            getdatalabel(rtti_label);
+            write_child_rtti_data;
+            rttilist^.concat(new(pai_symbol,init(rtti_label,0)));
+            write_rtti_data;
+            rttilist^.concat(new(pai_symbol_end,init(rtti_label)));
+          end;
+      end;
+
+
+    function tdef.get_rtti_label : string;
+      begin
+         generate_rtti;
+         get_rtti_label:=rtti_label^.name;
+      end;
+
+
+    { init table handling }
+    function tdef.needs_inittable : boolean;
+      begin
+         needs_inittable:=false;
+      end;
+
+
+    procedure tdef.generate_inittable;
+      begin
+         has_inittable:=true;
+         getdatalabel(inittable_label);
+         write_child_init_data;
+         rttilist^.concat(new(pai_label,init(inittable_label)));
+         write_init_data;
+      end;
+
+
+    procedure tdef.write_init_data;
+      begin
+         write_rtti_data;
+      end;
+
+
+    procedure tdef.write_child_init_data;
+      begin
+         write_child_rtti_data;
+      end;
+
+
+    function tdef.get_inittable_label : pasmlabel;
+      begin
+         if not(has_inittable) then
+           generate_inittable;
+         get_inittable_label:=inittable_label;
+      end;
+
+
+    procedure tdef.write_rtti_name;
+      var
+         str : string;
+      begin
+         { name }
+         if assigned(typesym) then
+           begin
+              str:=typesym^.realname;
+              rttilist^.concat(new(pai_string,init(chr(length(str))+str)));
+           end
+         else
+           rttilist^.concat(new(pai_string,init(#0)))
+      end;
+
+
+    { returns true, if the definition can be published }
+    function tdef.is_publishable : boolean;
+      begin
+         is_publishable:=false;
+      end;
+
+
+    procedure tdef.write_rtti_data;
+      begin
+      end;
+
+
+    procedure tdef.write_child_rtti_data;
+      begin
+      end;
+
+
+   function tdef.is_intregable : boolean;
+
+     begin
+        is_intregable:=false;
+        case deftype of
+          pointerdef,
+          enumdef,
+          procvardef :
+            is_intregable:=true;
+          orddef :
+            case porddef(@self)^.typ of
+              bool8bit,bool16bit,bool32bit,
+              u8bit,u16bit,u32bit,
+              s8bit,s16bit,s32bit:
+                is_intregable:=true;
+            end;
+          setdef:
+            is_intregable:=is_smallset(@self);
+        end;
+     end;
+
+   function tdef.is_fpuregable : boolean;
+
+     begin
+        is_fpuregable:=(deftype=floatdef) and not(pfloatdef(@self)^.typ in [f32bit,f16bit]);
+     end;
+
+{****************************************************************************
+                               TSTRINGDEF
+****************************************************************************}
+
+    constructor tstringdef.shortinit(l : byte);
+      begin
+         tdef.init;
+         string_typ:=st_shortstring;
+         deftype:=stringdef;
+         len:=l;
+         savesize:=len+1;
+      end;
+
+
+    constructor tstringdef.shortload;
+      begin
+         tdef.load;
+         string_typ:=st_shortstring;
+         deftype:=stringdef;
+         len:=readbyte;
+         savesize:=len+1;
+      end;
+
+
+    constructor tstringdef.longinit(l : longint);
+      begin
+         tdef.init;
+         string_typ:=st_longstring;
+         deftype:=stringdef;
+         len:=l;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    constructor tstringdef.longload;
+      begin
+         tdef.load;
+         deftype:=stringdef;
+         string_typ:=st_longstring;
+         len:=readlong;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    constructor tstringdef.ansiinit(l : longint);
+      begin
+         tdef.init;
+         string_typ:=st_ansistring;
+         deftype:=stringdef;
+         len:=l;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    constructor tstringdef.ansiload;
+      begin
+         tdef.load;
+         deftype:=stringdef;
+         string_typ:=st_ansistring;
+         len:=readlong;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    constructor tstringdef.wideinit(l : longint);
+      begin
+         tdef.init;
+         string_typ:=st_widestring;
+         deftype:=stringdef;
+         len:=l;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    constructor tstringdef.wideload;
+      begin
+         tdef.load;
+         deftype:=stringdef;
+         string_typ:=st_widestring;
+         len:=readlong;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    function tstringdef.stringtypname:string;
+      const
+        typname:array[tstringtype] of string[8]=('',
+          'SHORTSTR','LONGSTR','ANSISTR','WIDESTR'
+        );
+      begin
+        stringtypname:=typname[string_typ];
+      end;
+
+
+    function tstringdef.size : longint;
+      begin
+        size:=savesize;
+      end;
+
+
+    procedure tstringdef.write;
+      begin
+         tdef.write;
+         if string_typ=st_shortstring then
+           writebyte(len)
+         else
+           writelong(len);
+         case string_typ of
+           st_shortstring : current_ppu^.writeentry(ibshortstringdef);
+            st_longstring : current_ppu^.writeentry(iblongstringdef);
+            st_ansistring : current_ppu^.writeentry(ibansistringdef);
+            st_widestring : current_ppu^.writeentry(ibwidestringdef);
+         end;
+      end;
+
+
+{$ifdef GDB}
+    function tstringdef.stabstring : pchar;
+      var
+        bytest,charst,longst : string;
+      begin
+        case string_typ of
+           st_shortstring:
+             begin
+               charst := typeglobalnumber('char');
+               { this is what I found in stabs.texinfo but
+                 gdb 4.12 for go32 doesn't understand that !! }
+             {$IfDef GDBknowsstrings}
+               stabstring := strpnew('n'+charst+';'+tostr(len));
+             {$else}
+               bytest := typeglobalnumber('byte');
+               stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest
+                  +',0,8;st:ar'+bytest
+                  +';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;');
+             {$EndIf}
+             end;
+           st_longstring:
+             begin
+               charst := typeglobalnumber('char');
+               { this is what I found in stabs.texinfo but
+                 gdb 4.12 for go32 doesn't understand that !! }
+             {$IfDef GDBknowsstrings}
+               stabstring := strpnew('n'+charst+';'+tostr(len));
+             {$else}
+               bytest := typeglobalnumber('byte');
+               longst := typeglobalnumber('longint');
+               stabstring := strpnew('s'+tostr(len+5)+'length:'+longst
+                  +',0,32;dummy:'+bytest+',32,8;st:ar'+bytest
+                  +';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;');
+             {$EndIf}
+             end;
+           st_ansistring:
+             begin
+               { an ansi string looks like a pchar easy !! }
+               stabstring:=strpnew('*'+typeglobalnumber('char'));
+             end;
+           st_widestring:
+             begin
+               { an ansi string looks like a pchar easy !! }
+               stabstring:=strpnew('*'+typeglobalnumber('char'));
+             end;
+      end;
+    end;
+
+
+    procedure tstringdef.concatstabto(asmlist : paasmoutput);
+      begin
+        inherited concatstabto(asmlist);
+      end;
+{$endif GDB}
+
+
+    function tstringdef.needs_inittable : boolean;
+      begin
+         needs_inittable:=string_typ in [st_ansistring,st_widestring];
+      end;
+
+    function tstringdef.gettypename : string;
+
+      const
+         names : array[tstringtype] of string[20] = ('',
+           'ShortString','LongString','AnsiString','WideString');
+
+      begin
+         gettypename:=names[string_typ];
+      end;
+
+    procedure tstringdef.write_rtti_data;
+      begin
+         case string_typ of
+            st_ansistring:
+              begin
+                 rttilist^.concat(new(pai_const,init_8bit(tkAString)));
+                 write_rtti_name;
+              end;
+            st_widestring:
+              begin
+                 rttilist^.concat(new(pai_const,init_8bit(tkWString)));
+                 write_rtti_name;
+              end;
+            st_longstring:
+              begin
+                 rttilist^.concat(new(pai_const,init_8bit(tkLString)));
+                 write_rtti_name;
+              end;
+            st_shortstring:
+              begin
+                 rttilist^.concat(new(pai_const,init_8bit(tkSString)));
+                 write_rtti_name;
+                 rttilist^.concat(new(pai_const,init_8bit(len)));
+              end;
+         end;
+      end;
+
+
+    function tstringdef.is_publishable : boolean;
+      begin
+         is_publishable:=true;
+      end;
+
+
+{****************************************************************************
+                                 TENUMDEF
+****************************************************************************}
+
+    constructor tenumdef.init;
+      begin
+         tdef.init;
+         deftype:=enumdef;
+         minval:=0;
+         maxval:=0;
+         calcsavesize;
+         has_jumps:=false;
+         basedef:=nil;
+         rangenr:=0;
+         firstenum:=nil;
+         correct_owner_symtable;
+      end;
+
+    constructor tenumdef.init_subrange(_basedef:penumdef;_min,_max:longint);
+      begin
+         tdef.init;
+         deftype:=enumdef;
+         minval:=_min;
+         maxval:=_max;
+         basedef:=_basedef;
+         calcsavesize;
+         has_jumps:=false;
+         rangenr:=0;
+         firstenum:=basedef^.firstenum;
+         while assigned(firstenum) and (penumsym(firstenum)^.value<>minval) do
+          firstenum:=firstenum^.nextenum;
+         correct_owner_symtable;
+      end;
+
+
+    constructor tenumdef.load;
+      begin
+         tdef.load;
+         deftype:=enumdef;
+         basedef:=penumdef(readdefref);
+         minval:=readlong;
+         maxval:=readlong;
+         savesize:=readlong;
+         has_jumps:=false;
+         firstenum:=Nil;
+      end;
+
+
+    procedure tenumdef.calcsavesize;
+      begin
+        if (aktpackenum=4) or (min<0) or (max>65535) then
+         savesize:=4
+        else
+         if (aktpackenum=2) or (min<0) or (max>255) then
+          savesize:=2
+        else
+         savesize:=1;
+      end;
+
+
+    procedure tenumdef.setmax(_max:longint);
+      begin
+        maxval:=_max;
+        calcsavesize;
+      end;
+
+
+    procedure tenumdef.setmin(_min:longint);
+      begin
+        minval:=_min;
+        calcsavesize;
+      end;
+
+
+    function tenumdef.min:longint;
+      begin
+        min:=minval;
+      end;
+
+
+    function tenumdef.max:longint;
+      begin
+        max:=maxval;
+      end;
+
+
+    procedure tenumdef.deref;
+      begin
+        inherited deref;
+        resolvedef(pdef(basedef));
+      end;
+
+
+    destructor tenumdef.done;
+      begin
+        inherited done;
+      end;
+
+
+    procedure tenumdef.write;
+      begin
+         tdef.write;
+         writedefref(basedef);
+         writelong(min);
+         writelong(max);
+         writelong(savesize);
+         current_ppu^.writeentry(ibenumdef);
+      end;
+
+
+    function tenumdef.getrangecheckstring : string;
+      begin
+         if (cs_create_smart in aktmoduleswitches) then
+           getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
+         else
+           getrangecheckstring:='R_'+tostr(rangenr);
+      end;
+
+
+    procedure tenumdef.genrangecheck;
+      begin
+         if rangenr=0 then
+           begin
+              { generate two constant for bounds }
+              getlabelnr(rangenr);
+              if (cs_create_smart in aktmoduleswitches) then
+                datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,8)))
+              else
+                datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,8)));
+              datasegment^.concat(new(pai_const,init_32bit(min)));
+              datasegment^.concat(new(pai_const,init_32bit(max)));
+           end;
+      end;
+
+
+{$ifdef GDB}
+    function tenumdef.stabstring : pchar;
+      var st,st2 : pchar;
+          p : penumsym;
+          s : string;
+          memsize : word;
+      begin
+        memsize := memsizeinc;
+        getmem(st,memsize);
+        strpcopy(st,'e');
+        p := firstenum;
+        while assigned(p) do
+          begin
+            s :=p^.name+':'+tostr(p^.value)+',';
+            { place for the ending ';' also }
+            if (strlen(st)+length(s)+1<memsize) then
+              strpcopy(strend(st),s)
+            else
+              begin
+                getmem(st2,memsize+memsizeinc);
+                strcopy(st2,st);
+                freemem(st,memsize);
+                st := st2;
+                memsize := memsize+memsizeinc;
+                strpcopy(strend(st),s);
+              end;
+            p := p^.nextenum;
+          end;
+        strpcopy(strend(st),';');
+        stabstring := strnew(st);
+        freemem(st,memsize);
+      end;
+{$endif GDB}
+
+
+    procedure tenumdef.write_child_rtti_data;
+      begin
+         if assigned(basedef) then
+           basedef^.get_rtti_label;
+      end;
+
+
+    procedure tenumdef.write_rtti_data;
+
+      var
+         hp : penumsym;
+
+      begin
+         rttilist^.concat(new(pai_const,init_8bit(tkEnumeration)));
+         write_rtti_name;
+         case savesize of
+            1:
+              rttilist^.concat(new(pai_const,init_8bit(otUByte)));
+            2:
+              rttilist^.concat(new(pai_const,init_8bit(otUWord)));
+            4:
+              rttilist^.concat(new(pai_const,init_8bit(otULong)));
+         end;
+         rttilist^.concat(new(pai_const,init_32bit(min)));
+         rttilist^.concat(new(pai_const,init_32bit(max)));
+         if assigned(basedef) then
+           rttilist^.concat(new(pai_const_symbol,initname(basedef^.get_rtti_label)))
+         else
+           rttilist^.concat(new(pai_const,init_32bit(0)));
+         hp:=firstenum;
+         while assigned(hp) do
+           begin
+              rttilist^.concat(new(pai_const,init_8bit(length(hp^.name))));
+              rttilist^.concat(new(pai_string,init(lower(hp^.name))));
+              hp:=hp^.nextenum;
+           end;
+         rttilist^.concat(new(pai_const,init_8bit(0)));
+      end;
+
+
+    function tenumdef.is_publishable : boolean;
+      begin
+         is_publishable:=true;
+      end;
+
+    function tenumdef.gettypename : string;
+
+      begin
+         gettypename:='<enumeration type>';
+      end;
+
+{****************************************************************************
+                                 TORDDEF
+****************************************************************************}
+
+    constructor torddef.init(t : tbasetype;v,b : longint);
+      begin
+         inherited init;
+         deftype:=orddef;
+         low:=v;
+         high:=b;
+         typ:=t;
+         rangenr:=0;
+         setsize;
+      end;
+
+
+    constructor torddef.load;
+      begin
+         inherited load;
+         deftype:=orddef;
+         typ:=tbasetype(readbyte);
+         low:=readlong;
+         high:=readlong;
+         rangenr:=0;
+         setsize;
+      end;
+
+
+    procedure torddef.setsize;
+      begin
+         if typ=uauto then
+           begin
+              { generate a unsigned range if high<0 and low>=0 }
+              if (low>=0) and (high<0) then
+                begin
+                   savesize:=4;
+                   typ:=u32bit;
+                end
+              else if (low>=0) and (high<=255) then
+                begin
+                   savesize:=1;
+                   typ:=u8bit;
+                end
+              else if (low>=-128) and (high<=127) then
+                begin
+                   savesize:=1;
+                   typ:=s8bit;
+                end
+              else if (low>=0) and (high<=65536) then
+                begin
+                   savesize:=2;
+                   typ:=u16bit;
+                end
+              else if (low>=-32768) and (high<=32767) then
+                begin
+                   savesize:=2;
+                   typ:=s16bit;
+                end
+              else
+                begin
+                   savesize:=4;
+                   typ:=s32bit;
+                end;
+           end
+         else
+           begin
+             case typ of
+                u8bit,s8bit,
+                uchar,bool8bit:
+                  savesize:=1;
+
+                u16bit,s16bit,
+                bool16bit,uwidechar:
+                  savesize:=2;
+
+                s32bit,u32bit,
+                bool32bit:
+                  savesize:=4;
+
+                u64bit,s64bit:
+                  savesize:=8;
+             else
+               savesize:=0;
+             end;
+           end;
+       { there are no entrys for range checking }
+         rangenr:=0;
+      end;
+
+    function torddef.getrangecheckstring : string;
+
+      begin
+         if (cs_create_smart in aktmoduleswitches) then
+           getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
+         else
+           getrangecheckstring:='R_'+tostr(rangenr);
+      end;
+
+    procedure torddef.genrangecheck;
+      var
+        rangechecksize : longint;
+      begin
+         if rangenr=0 then
+           begin
+              if low<=high then
+               rangechecksize:=8
+              else
+               rangechecksize:=16;
+              { generate two constant for bounds }
+              getlabelnr(rangenr);
+              if (cs_create_smart in aktmoduleswitches) then
+                datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,rangechecksize)))
+              else
+                datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,rangechecksize)));
+              if low<=high then
+                begin
+                   datasegment^.concat(new(pai_const,init_32bit(low)));
+                   datasegment^.concat(new(pai_const,init_32bit(high)));
+                end
+              { for u32bit we need two bounds }
+              else
+                begin
+                   datasegment^.concat(new(pai_const,init_32bit(low)));
+                   datasegment^.concat(new(pai_const,init_32bit($7fffffff)));
+                   datasegment^.concat(new(pai_const,init_32bit($80000000)));
+                   datasegment^.concat(new(pai_const,init_32bit(high)));
+                end;
+           end;
+      end;
+
+
+    procedure torddef.write;
+      begin
+         tdef.write;
+         writebyte(byte(typ));
+         writelong(low);
+         writelong(high);
+         current_ppu^.writeentry(iborddef);
+      end;
+
+
+{$ifdef GDB}
+    function torddef.stabstring : pchar;
+      begin
+        case typ of
+            uvoid : stabstring := strpnew(numberstring+';');
+         {GDB 4.12 for go32 doesn't like boolean as range for 0 to 1 !!!}
+{$ifdef Use_integer_types_for_boolean}
+         bool8bit,
+        bool16bit,
+        bool32bit : stabstring := strpnew('r'+numberstring+';0;255;');
+{$else : not Use_integer_types_for_boolean}
+         bool8bit : stabstring := strpnew('-21;');
+        bool16bit : stabstring := strpnew('-22;');
+        bool32bit : stabstring := strpnew('-23;');
+        u64bit    : stabstring := strpnew('-32;');
+        s64bit    : stabstring := strpnew('-31;');
+{$endif not Use_integer_types_for_boolean}
+         { u32bit : stabstring := strpnew('r'+
+              s32bitdef^.numberstring+';0;-1;'); }
+        else
+          stabstring := strpnew('r'+s32bitdef^.numberstring+';'+tostr(low)+';'+tostr(high)+';');
+        end;
+      end;
+{$endif GDB}
+
+
+    procedure torddef.write_rtti_data;
+
+        procedure dointeger;
+        const
+          trans : array[uchar..bool8bit] of byte =
+            (otUByte,otUByte,otUWord,otULong,otSByte,otSWord,otSLong,otUByte);
+        begin
+          write_rtti_name;
+          rttilist^.concat(new(pai_const,init_8bit(byte(trans[typ]))));
+          rttilist^.concat(new(pai_const,init_32bit(low)));
+          rttilist^.concat(new(pai_const,init_32bit(high)));
+        end;
+
+      begin
+        case typ of
+          s64bit :
+            begin
+              rttilist^.concat(new(pai_const,init_8bit(tkInt64)));
+              write_rtti_name;
+              { low }
+              rttilist^.concat(new(pai_const,init_32bit($0)));
+              rttilist^.concat(new(pai_const,init_32bit($8000)));
+              { high }
+              rttilist^.concat(new(pai_const,init_32bit($ffff)));
+              rttilist^.concat(new(pai_const,init_32bit($7fff)));
+            end;
+          u64bit :
+            begin
+              rttilist^.concat(new(pai_const,init_8bit(tkQWord)));
+              write_rtti_name;
+              { low }
+              rttilist^.concat(new(pai_const,init_32bit($0)));
+              rttilist^.concat(new(pai_const,init_32bit($0)));
+              { high }
+              rttilist^.concat(new(pai_const,init_32bit($0)));
+              rttilist^.concat(new(pai_const,init_32bit($8000)));
+            end;
+          bool8bit:
+            begin
+              rttilist^.concat(new(pai_const,init_8bit(tkBool)));
+              dointeger;
+            end;
+          uchar:
+            begin
+              rttilist^.concat(new(pai_const,init_8bit(tkWChar)));
+              dointeger;
+            end;
+          uwidechar:
+            begin
+              rttilist^.concat(new(pai_const,init_8bit(tkChar)));
+              dointeger;
+            end;
+          else
+            begin
+              rttilist^.concat(new(pai_const,init_8bit(tkInteger)));
+              dointeger;
+            end;
+        end;
+      end;
+
+
+    function torddef.is_publishable : boolean;
+      begin
+         is_publishable:=typ in [uchar..bool8bit];
+      end;
+
+    function torddef.gettypename : string;
+
+      const
+        names : array[tbasetype] of string[20] = ('<unknown type>',
+          'untyped','Char','Byte','Word','DWord','ShortInt',
+          'SmallInt','LongInt','Boolean','WordBool',
+          'LongBool','QWord','Int64','WideChar');
+
+      begin
+         gettypename:=names[typ];
+      end;
+
+{****************************************************************************
+                                TFLOATDEF
+****************************************************************************}
+
+    constructor tfloatdef.init(t : tfloattype);
+      begin
+         inherited init;
+         deftype:=floatdef;
+         typ:=t;
+         setsize;
+      end;
+
+
+    constructor tfloatdef.load;
+      begin
+         inherited load;
+         deftype:=floatdef;
+         typ:=tfloattype(readbyte);
+         setsize;
+      end;
+
+
+    procedure tfloatdef.setsize;
+      begin
+         case typ of
+            f16bit : savesize:=2;
+            f32bit,
+           s32real : savesize:=4;
+           s64real : savesize:=8;
+           s80real : savesize:=extended_size;
+           s64comp : savesize:=8;
+         else
+           savesize:=0;
+         end;
+      end;
+
+
+    procedure tfloatdef.write;
+      begin
+         inherited write;
+         writebyte(byte(typ));
+         current_ppu^.writeentry(ibfloatdef);
+      end;
+
+
+{$ifdef GDB}
+    function tfloatdef.stabstring : pchar;
+      begin
+         case typ of
+            s32real,
+            s64real : stabstring := strpnew('r'+
+               s32bitdef^.numberstring+';'+tostr(savesize)+';0;');
+            { for fixed real use longint instead to be able to }
+            { debug something at least                         }
+            f32bit:
+              stabstring := s32bitdef^.stabstring;
+            f16bit:
+              stabstring := strpnew('r'+s32bitdef^.numberstring+';0;'+
+                tostr($ffff)+';');
+            { found this solution in stabsread.c from GDB v4.16 }
+            s64comp : stabstring := strpnew('r'+
+               s32bitdef^.numberstring+';-'+tostr(savesize)+';0;');
+{$ifdef i386}
+            { under dos at least you must give a size of twelve instead of 10 !! }
+            { this is probably do to the fact that in gcc all is pushed in 4 bytes size }
+            s80real : stabstring := strpnew('r'+s32bitdef^.numberstring+';12;0;');
+{$endif i386}
+            else
+              internalerror(10005);
+         end;
+      end;
+{$endif GDB}
+
+
+    procedure tfloatdef.write_rtti_data;
+      const
+         {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);}
+         translate : array[tfloattype] of byte =
+           (ftSingle,ftDouble,ftExtended,ftComp,ftFixed16,ftFixed32);
+      begin
+         rttilist^.concat(new(pai_const,init_8bit(tkFloat)));
+         write_rtti_name;
+         rttilist^.concat(new(pai_const,init_8bit(translate[typ])));
+      end;
+
+
+    function tfloatdef.is_publishable : boolean;
+      begin
+         is_publishable:=true;
+      end;
+
+    function tfloatdef.gettypename : string;
+
+      const
+        names : array[tfloattype] of string[20] = (
+          'Single','Double','Extended','Comp','Fixed','Fixed16');
+
+      begin
+         gettypename:=names[typ];
+      end;
+
+{****************************************************************************
+                                TFILEDEF
+****************************************************************************}
+
+    constructor tfiledef.inittext;
+      begin
+         inherited init;
+         deftype:=filedef;
+         filetyp:=ft_text;
+         typedfiletype.reset;
+         setsize;
+      end;
+
+
+    constructor tfiledef.inituntyped;
+      begin
+         inherited init;
+         deftype:=filedef;
+         filetyp:=ft_untyped;
+         typedfiletype.reset;
+         setsize;
+      end;
+
+
+    constructor tfiledef.inittyped(const tt : ttype);
+      begin
+         inherited init;
+         deftype:=filedef;
+         filetyp:=ft_typed;
+         typedfiletype:=tt;
+         setsize;
+      end;
+
+
+    constructor tfiledef.inittypeddef(p : pdef);
+      begin
+         inherited init;
+         deftype:=filedef;
+         filetyp:=ft_typed;
+         typedfiletype.setdef(p);
+         setsize;
+      end;
+
+
+    constructor tfiledef.load;
+      begin
+         inherited load;
+         deftype:=filedef;
+         filetyp:=tfiletyp(readbyte);
+         if filetyp=ft_typed then
+           typedfiletype.load
+         else
+           typedfiletype.reset;
+         setsize;
+      end;
+
+
+    procedure tfiledef.deref;
+      begin
+        inherited deref;
+        if filetyp=ft_typed then
+          typedfiletype.resolve;
+      end;
+
+
+    procedure tfiledef.setsize;
+      begin
+        case filetyp of
+          ft_text :
+            savesize:=572;
+          ft_typed,
+          ft_untyped :
+            savesize:=316;
+        end;
+      end;
+
+
+    procedure tfiledef.write;
+      begin
+         inherited write;
+         writebyte(byte(filetyp));
+         if filetyp=ft_typed then
+           typedfiletype.write;
+         current_ppu^.writeentry(ibfiledef);
+      end;
+
+
+{$ifdef GDB}
+    function tfiledef.stabstring : pchar;
+      begin
+   {$IfDef GDBknowsfiles}
+      case filetyp of
+        ft_typed :
+          stabstring := strpnew('d'+typedfiletype.def^.numberstring{+';'});
+        ft_untyped :
+          stabstring := strpnew('d'+voiddef^.numberstring{+';'});
+        ft_text :
+          stabstring := strpnew('d'+cchardef^.numberstring{+';'});
+      end;
+   {$Else}
+      {based on
+        FileRec = Packed Record
+          Handle,
+          Mode,
+          RecSize   : longint;
+          _private  : array[1..32] of byte;
+          UserData  : array[1..16] of byte;
+          name      : array[0..255] of char;
+        End; }
+      { the buffer part is still missing !! (PM) }
+      { but the string could become too long !! }
+      stabstring := strpnew('s'+tostr(savesize)+
+                     'HANDLE:'+typeglobalnumber('longint')+',0,32;'+
+                     'MODE:'+typeglobalnumber('longint')+',32,32;'+
+                     'RECSIZE:'+typeglobalnumber('longint')+',64,32;'+
+                     '_PRIVATE:ar'+typeglobalnumber('word')+';1;32;'+typeglobalnumber('byte')
+                        +',96,256;'+
+                     'USERDATA:ar'+typeglobalnumber('word')+';1;16;'+typeglobalnumber('byte')
+                        +',352,128;'+
+                     'NAME:ar'+typeglobalnumber('word')+';0;255;'+typeglobalnumber('char')
+                        +',480,2048;;');
+   {$EndIf}
+      end;
+
+
+    procedure tfiledef.concatstabto(asmlist : paasmoutput);
+      begin
+      { most file defs are unnamed !!! }
+      if ((typesym = nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
+         (is_def_stab_written  = not_written) then
+        begin
+        if assigned(typedfiletype.def) then forcestabto(asmlist,typedfiletype.def);
+        inherited concatstabto(asmlist);
+        end;
+      end;
+{$endif GDB}
+
+    function tfiledef.gettypename : string;
+
+      begin
+         case filetyp of
+           ft_untyped:
+             gettypename:='File';
+           ft_typed:
+             gettypename:='File Of '+typedfiletype.def^.typename;
+           ft_text:
+             gettypename:='Text'
+         end;
+      end;
+
+
+
+{****************************************************************************
+                               TPOINTERDEF
+****************************************************************************}
+
+    constructor tpointerdef.init(const tt : ttype);
+      begin
+        tdef.init;
+        deftype:=pointerdef;
+        pointertype:=tt;
+        is_far:=false;
+        savesize:=target_os.size_of_pointer;
+        pointertypeis_forwarddef:=assigned(pointertype.def) and (pointertype.def^.deftype=forwarddef);
+      end;
+
+
+    constructor tpointerdef.initfar(const tt : ttype);
+      begin
+        tdef.init;
+        deftype:=pointerdef;
+        pointertype:=tt;
+        is_far:=true;
+        savesize:=target_os.size_of_pointer;
+        pointertypeis_forwarddef:=assigned(pointertype.def) and (pointertype.def^.deftype=forwarddef);
+      end;
+
+
+    constructor tpointerdef.initdef(p : pdef);
+      var
+        t : ttype;
+      begin
+        t.setdef(p);
+        tpointerdef.init(t);
+      end;
+
+
+    constructor tpointerdef.initfardef(p : pdef);
+      var
+        t : ttype;
+      begin
+        t.setdef(p);
+        tpointerdef.initfar(t);
+      end;
+
+
+
+    constructor tpointerdef.load;
+      begin
+         tdef.load;
+         deftype:=pointerdef;
+         pointertype.load;
+         is_far:=(readbyte<>0);
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    destructor tpointerdef.done;
+      begin
+        if {assigned(pointertype.def) and
+           (pointertype.def^.deftype=forwarddef)} pointertypeis_forwarddef then
+         begin
+           dispose(pointertype.def,done);
+           pointertype.reset;
+         end;
+        inherited done;
+      end;
+
+
+    procedure tpointerdef.deref;
+      begin
+        inherited deref;
+        pointertype.resolve;
+      end;
+
+
+    procedure tpointerdef.write;
+      begin
+         inherited write;
+         pointertype.write;
+         writebyte(byte(is_far));
+         current_ppu^.writeentry(ibpointerdef);
+      end;
+
+
+{$ifdef GDB}
+    function tpointerdef.stabstring : pchar;
+      begin
+        stabstring := strpnew('*'+pointertype.def^.numberstring);
+      end;
+
+
+    procedure tpointerdef.concatstabto(asmlist : paasmoutput);
+      var st,nb : string;
+          sym_line_no : longint;
+      begin
+      if assigned(pointertype.def) and
+         (pointertype.def^.deftype=forwarddef) then
+        exit;
+
+      if ( (typesym=nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
+         (is_def_stab_written = not_written) then
+        begin
+          is_def_stab_written := being_written;
+        if assigned(pointertype.def) and
+           (pointertype.def^.deftype in [recorddef,objectdef]) then
+          begin
+            nb:=pointertype.def^.numberstring;
+            {to avoid infinite recursion in record with next-like fields }
+            if pointertype.def^.is_def_stab_written = being_written then
+              begin
+                if assigned(pointertype.def^.typesym) then
+                  begin
+                    if assigned(typesym) then
+                      begin
+                         st := typesym^.name;
+                         sym_line_no:=typesym^.fileinfo.line;
+                      end
+                    else
+                      begin
+                         st := ' ';
+                         sym_line_no:=0;
+                      end;
+                    st := '"'+st+':t'+numberstring+'=*'+nb
+                          +'=xs'+pointertype.def^.typesym^.name+':",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0';
+                    asmlist^.concat(new(pai_stabs,init(strpnew(st))));
+                    end;
+              end
+            else
+              begin
+                is_def_stab_written := not_written;
+                inherited concatstabto(asmlist);
+              end;
+            is_def_stab_written := written;
+          end
+        else
+          begin
+            if assigned(pointertype.def) then
+              forcestabto(asmlist,pointertype.def);
+            is_def_stab_written := not_written;
+            inherited concatstabto(asmlist);
+          end;
+        end;
+      end;
+{$endif GDB}
+
+    function tpointerdef.gettypename : string;
+
+      begin
+         gettypename:='^'+pointertype.def^.typename;
+      end;
+
+{****************************************************************************
+                              TCLASSREFDEF
+****************************************************************************}
+
+    constructor tclassrefdef.init(def : pdef);
+      begin
+         inherited initdef(def);
+         deftype:=classrefdef;
+      end;
+
+
+    constructor tclassrefdef.load;
+      begin
+         { be careful, tclassdefref inherits from tpointerdef }
+         tdef.load;
+         deftype:=classrefdef;
+         pointertype.load;
+         is_far:=false;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    procedure tclassrefdef.write;
+      begin
+         { be careful, tclassdefref inherits from tpointerdef }
+         tdef.write;
+         pointertype.write;
+         current_ppu^.writeentry(ibclassrefdef);
+      end;
+
+
+{$ifdef GDB}
+    function tclassrefdef.stabstring : pchar;
+      begin
+         stabstring:=strpnew(pvmtdef^.numberstring+';');
+      end;
+
+
+    procedure tclassrefdef.concatstabto(asmlist : paasmoutput);
+      begin
+        inherited concatstabto(asmlist);
+      end;
+{$endif GDB}
+
+    function tclassrefdef.gettypename : string;
+
+      begin
+         gettypename:='Class Of '+pointertype.def^.typename;
+      end;
+
+
+{***************************************************************************
+                                   TSETDEF
+***************************************************************************}
+
+{ For i386 smallsets work,
+  for m68k there are problems
+  can be test by compiling with -dusesmallset PM }
+{$ifdef i386}
+{$define usesmallset}
+{$endif i386}
+
+    constructor tsetdef.init(s : pdef;high : longint);
+      begin
+         inherited init;
+         deftype:=setdef;
+         elementtype.setdef(s);
+{$ifdef usesmallset}
+         { small sets only working for i386 PM }
+         if high<32 then
+           begin
+            settype:=smallset;
+           {$ifdef testvarsets}
+            if aktsetalloc=0 THEN      { $PACKSET Fixed?}
+           {$endif}
+            savesize:=Sizeof(longint)
+           {$ifdef testvarsets}
+           else                       {No, use $PACKSET VALUE for rounding}
+            savesize:=aktsetalloc*((high+aktsetalloc*8-1) DIV (aktsetalloc*8))
+           {$endif}
+              ;
+          end
+         else
+{$endif usesmallset}
+         if high<256 then
+           begin
+              settype:=normset;
+              savesize:=32;
+           end
+         else
+{$ifdef testvarsets}
+         if high<$10000 then
+           begin
+              settype:=varset;
+              savesize:=4*((high+31) div 32);
+           end
+         else
+{$endif testvarsets}
+          Message(sym_e_ill_type_decl_set);
+      end;
+
+
+    constructor tsetdef.load;
+      begin
+         inherited load;
+         deftype:=setdef;
+         elementtype.load;
+         settype:=tsettype(readbyte);
+         case settype of
+            normset : savesize:=32;
+            varset : savesize:=readlong;
+            smallset : savesize:=Sizeof(longint);
+         end;
+      end;
+
+
+    destructor tsetdef.done;
+      begin
+        inherited done;
+      end;
+
+
+    procedure tsetdef.write;
+      begin
+         inherited write;
+         elementtype.write;
+         writebyte(byte(settype));
+         if settype=varset then
+           writelong(savesize);
+         current_ppu^.writeentry(ibsetdef);
+      end;
+
+
+{$ifdef GDB}
+    function tsetdef.stabstring : pchar;
+      begin
+         { For small sets write a longint, which can at least be seen
+           in the current GDB's (PFV)
+           this is obsolete with GDBPAS !!
+           and anyhow creates problems with version 4.18!! PM
+         if settype=smallset then
+           stabstring := strpnew('r'+s32bitdef^.numberstring+';0;0xffffffff;')
+         else }
+           stabstring := strpnew('S'+elementtype.def^.numberstring);
+      end;
+
+
+    procedure tsetdef.concatstabto(asmlist : paasmoutput);
+      begin
+      if ( not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
+          (is_def_stab_written = not_written) then
+        begin
+          if assigned(elementtype.def) then
+            forcestabto(asmlist,elementtype.def);
+          inherited concatstabto(asmlist);
+        end;
+      end;
+{$endif GDB}
+
+
+    procedure tsetdef.deref;
+      begin
+        inherited deref;
+        elementtype.resolve;
+      end;
+
+
+    procedure tsetdef.write_rtti_data;
+      begin
+         rttilist^.concat(new(pai_const,init_8bit(tkSet)));
+         write_rtti_name;
+         rttilist^.concat(new(pai_const,init_8bit(otULong)));
+         rttilist^.concat(new(pai_const_symbol,initname(elementtype.def^.get_rtti_label)));
+      end;
+
+
+    procedure tsetdef.write_child_rtti_data;
+      begin
+         elementtype.def^.get_rtti_label;
+      end;
+
+
+    function tsetdef.is_publishable : boolean;
+      begin
+         is_publishable:=settype=smallset;
+      end;
+
+    function tsetdef.gettypename : string;
+
+      begin
+         if assigned(elementtype.def) then
+          gettypename:='Set Of '+elementtype.def^.typename
+         else
+          gettypename:='Empty Set';
+      end;
+
+
+{***************************************************************************
+                                 TFORMALDEF
+***************************************************************************}
+
+    constructor tformaldef.init;
+      var
+         stregdef : boolean;
+      begin
+         stregdef:=registerdef;
+         registerdef:=false;
+         inherited init;
+         deftype:=formaldef;
+         registerdef:=stregdef;
+         { formaldef must be registered at unit level !! }
+         if registerdef and assigned(current_module) then
+            if assigned(current_module^.localsymtable) then
+              psymtable(current_module^.localsymtable)^.registerdef(@self)
+            else if assigned(current_module^.globalsymtable) then
+              psymtable(current_module^.globalsymtable)^.registerdef(@self);
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    constructor tformaldef.load;
+      begin
+         inherited load;
+         deftype:=formaldef;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    procedure tformaldef.write;
+      begin
+         inherited write;
+         current_ppu^.writeentry(ibformaldef);
+      end;
+
+
+{$ifdef GDB}
+    function tformaldef.stabstring : pchar;
+      begin
+      stabstring := strpnew('formal'+numberstring+';');
+      end;
+
+
+    procedure tformaldef.concatstabto(asmlist : paasmoutput);
+      begin
+      { formaldef can't be stab'ed !}
+      end;
+{$endif GDB}
+
+    function tformaldef.gettypename : string;
+
+      begin
+         gettypename:='Var';
+      end;
+
+{***************************************************************************
+                           TARRAYDEF
+***************************************************************************}
+
+    constructor tarraydef.init(l,h : longint;rd : pdef);
+      begin
+         inherited init;
+         deftype:=arraydef;
+         lowrange:=l;
+         highrange:=h;
+         rangetype.setdef(rd);
+         elementtype.reset;
+         IsVariant:=false;
+         IsConstructor:=false;
+         IsArrayOfConst:=false;
+         IsDynamicArray:=false;
+         rangenr:=0;
+      end;
+
+
+    constructor tarraydef.load;
+      begin
+         inherited load;
+         deftype:=arraydef;
+         { the addresses are calculated later }
+         elementtype.load;
+         rangetype.load;
+         lowrange:=readlong;
+         highrange:=readlong;
+         IsArrayOfConst:=boolean(readbyte);
+         IsVariant:=false;
+         IsConstructor:=false;
+{$warning FIXME!!!!!}
+         IsDynamicArray:=false;
+         rangenr:=0;
+      end;
+
+
+    function tarraydef.getrangecheckstring : string;
+      begin
+         if (cs_create_smart in aktmoduleswitches) then
+           getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
+         else
+           getrangecheckstring:='R_'+tostr(rangenr);
+      end;
+
+
+    procedure tarraydef.genrangecheck;
+      begin
+         if rangenr=0 then
+           begin
+              { generates the data for range checking }
+              getlabelnr(rangenr);
+              if (cs_create_smart in aktmoduleswitches) then
+                datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring,8)))
+              else
+                datasegment^.concat(new(pai_symbol,initname(getrangecheckstring,8)));
+              if lowrange<=highrange then
+                begin
+                  datasegment^.concat(new(pai_const,init_32bit(lowrange)));
+                  datasegment^.concat(new(pai_const,init_32bit(highrange)));
+                end
+              { for big arrays we need two bounds }
+              else
+                begin
+                  datasegment^.concat(new(pai_const,init_32bit(lowrange)));
+                  datasegment^.concat(new(pai_const,init_32bit($7fffffff)));
+                  datasegment^.concat(new(pai_const,init_32bit($80000000)));
+                  datasegment^.concat(new(pai_const,init_32bit(highrange)));
+                end;
+           end;
+      end;
+
+
+    procedure tarraydef.deref;
+      begin
+        inherited deref;
+        elementtype.resolve;
+        rangetype.resolve;
+      end;
+
+
+    procedure tarraydef.write;
+      begin
+         inherited write;
+         elementtype.write;
+         rangetype.write;
+         writelong(lowrange);
+         writelong(highrange);
+         writebyte(byte(IsArrayOfConst));
+         current_ppu^.writeentry(ibarraydef);
+      end;
+
+
+{$ifdef GDB}
+    function tarraydef.stabstring : pchar;
+      begin
+      stabstring := strpnew('ar'+rangetype.def^.numberstring+';'
+                    +tostr(lowrange)+';'+tostr(highrange)+';'+elementtype.def^.numberstring);
+      end;
+
+
+    procedure tarraydef.concatstabto(asmlist : paasmoutput);
+      begin
+      if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
+        and (is_def_stab_written = not_written) then
+        begin
+        {when array are inserted they have no definition yet !!}
+        if assigned(elementtype.def) then
+          inherited concatstabto(asmlist);
+        end;
+      end;
+{$endif GDB}
+
+
+    function tarraydef.elesize : longint;
+      begin
+        if isconstructor or is_open_array(@self) then
+         begin
+           { strings are stored by address only }
+           case elementtype.def^.deftype of
+             stringdef :
+               elesize:=4;
+             else
+               elesize:=elementtype.def^.size;
+           end;
+         end
+        else
+         elesize:=elementtype.def^.size;
+      end;
+
+
+    function tarraydef.size : longint;
+      begin
+        {Tarraydef.size may never be called for an open array!}
+        if IsDynamicArray then
+          begin
+             size:=4;
+             exit;
+          end;
+        if highrange<lowrange then
+            internalerror(99080501);
+        If (elesize>0) and
+           (
+            (highrange-lowrange = $7fffffff) or
+            { () are needed around elesize-1 to avoid a possible
+              integer overflow for elesize=1 !! PM }
+            (($7fffffff div elesize + (elesize -1)) < (highrange - lowrange))
+           ) Then
+          Begin
+            Message(sym_e_segment_too_large);
+            size := 4
+          End
+        Else size:=(highrange-lowrange+1)*elesize;
+      end;
+
+
+    function tarraydef.alignment : longint;
+      begin
+         { alignment is the size of the elements }
+         if elementtype.def^.deftype=recorddef then
+          alignment:=elementtype.def^.alignment
+         else
+          alignment:=elesize;
+      end;
+
+
+    function tarraydef.needs_inittable : boolean;
+      begin
+         needs_inittable:=IsDynamicArray or elementtype.def^.needs_inittable;
+      end;
+
+
+    procedure tarraydef.write_child_rtti_data;
+      begin
+         elementtype.def^.get_rtti_label;
+      end;
+
+
+    procedure tarraydef.write_rtti_data;
+      begin
+         if IsDynamicArray then
+           rttilist^.concat(new(pai_const,init_8bit(tkdynarray)))
+         else
+           rttilist^.concat(new(pai_const,init_8bit(tkarray)));
+         write_rtti_name;
+         { size of elements }
+         rttilist^.concat(new(pai_const,init_32bit(elesize)));
+         { count of elements }
+         if not(IsDynamicArray) then
+           rttilist^.concat(new(pai_const,init_32bit(highrange-lowrange+1)));
+         { element type }
+         rttilist^.concat(new(pai_const_symbol,initname(elementtype.def^.get_rtti_label)));
+         { variant type }
+         // !!!!!!!!!!!!!!!!
+      end;
+
+    function tarraydef.gettypename : string;
+
+      begin
+         if isarrayofconst or isConstructor then
+           begin
+             if isvariant or ((highrange=-1) and (lowrange=0)) then
+               gettypename:='Array Of Const'
+             else
+               gettypename:='Array Of '+elementtype.def^.typename;
+           end
+         else if is_open_array(@self) or IsDynamicArray then
+           gettypename:='Array Of '+elementtype.def^.typename
+         else
+           begin
+              if rangetype.def^.deftype=enumdef then
+                gettypename:='Array['+rangetype.def^.typename+'] Of '+elementtype.def^.typename
+              else
+                gettypename:='Array['+tostr(lowrange)+'..'+
+                  tostr(highrange)+'] Of '+elementtype.def^.typename
+           end;
+      end;
+
+{***************************************************************************
+                                  trecorddef
+***************************************************************************}
+
+    constructor trecorddef.init(p : psymtable);
+      begin
+         inherited init;
+         deftype:=recorddef;
+         symtable:=p;
+         symtable^.defowner := @self;
+         symtable^.dataalignment:=packrecordalignment[aktpackrecords];
+      end;
+
+
+    constructor trecorddef.load;
+      var
+         oldread_member : boolean;
+      begin
+         inherited load;
+         deftype:=recorddef;
+         savesize:=readlong;
+         oldread_member:=read_member;
+         read_member:=true;
+         symtable:=new(psymtable,loadas(recordsymtable));
+         read_member:=oldread_member;
+         symtable^.defowner := @self;
+      end;
+
+
+    destructor trecorddef.done;
+      begin
+         if assigned(symtable) then
+           dispose(symtable,done);
+         inherited done;
+      end;
+
+
+    var
+       binittable : boolean;
+
+    procedure check_rec_inittable(s : pnamedindexobject);
+
+      begin
+         if (not binittable) and
+            (psym(s)^.typ=varsym) and
+            assigned(pvarsym(s)^.vartype.def) then
+          begin
+            if (pvarsym(s)^.vartype.def^.deftype<>objectdef) or
+               not is_class(pvarsym(s)^.vartype.def) then
+             binittable:=pvarsym(s)^.vartype.def^.needs_inittable;
+          end;
+      end;
+
+
+    function trecorddef.needs_inittable : boolean;
+      var
+         oldb : boolean;
+      begin
+         { there are recursive calls to needs_rtti possible, }
+         { so we have to change to old value how else should }
+         { we do that ? check_rec_rtti can't be a nested     }
+         { procedure of needs_rtti !                         }
+         oldb:=binittable;
+         binittable:=false;
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}check_rec_inittable);
+         needs_inittable:=binittable;
+         binittable:=oldb;
+      end;
+
+
+    procedure trecorddef.deref;
+      var
+         oldrecsyms : psymtable;
+      begin
+         inherited deref;
+         oldrecsyms:=aktrecordsymtable;
+         aktrecordsymtable:=symtable;
+         { now dereference the definitions }
+         symtable^.deref;
+         aktrecordsymtable:=oldrecsyms;
+      end;
+
+
+    procedure trecorddef.write;
+      var
+         oldread_member : boolean;
+      begin
+         oldread_member:=read_member;
+         read_member:=true;
+         inherited write;
+         writelong(savesize);
+         current_ppu^.writeentry(ibrecorddef);
+         self.symtable^.writeas;
+         read_member:=oldread_member;
+      end;
+
+    function trecorddef.size:longint;
+      begin
+        size:=symtable^.datasize;
+      end;
+
+
+    function trecorddef.alignment:longint;
+      var
+        l  : longint;
+        hp : pvarsym;
+      begin
+        { also check the first symbol for it's size, because a
+          packed record has dataalignment of 1, but the first
+          sym could be a longint which should be aligned on 4 bytes,
+          this is compatible with C record packing (PFV) }
+        hp:=pvarsym(symtable^.symindex^.first);
+        if assigned(hp) then
+         begin
+           l:=hp^.vartype.def^.size;
+           if l>symtable^.dataalignment then
+            begin
+              if l>=4 then
+               alignment:=4
+              else
+               if l>=2 then
+                alignment:=2
+              else
+               alignment:=1;
+            end
+           else
+            alignment:=symtable^.dataalignment;
+         end
+        else
+         alignment:=symtable^.dataalignment;
+      end;
+
+{$ifdef GDB}
+    Const StabRecString : pchar = Nil;
+          StabRecSize : longint = 0;
+          RecOffset : Longint = 0;
+
+    procedure addname(p : pnamedindexobject);
+    var
+      news, newrec : pchar;
+      spec : string[3];
+      size : longint;
+    begin
+    { static variables from objects are like global objects }
+    if (sp_static in psym(p)^.symoptions) then
+      exit;
+    If psym(p)^.typ = varsym then
+       begin
+         if (sp_protected in psym(p)^.symoptions) then
+           spec:='/1'
+         else if (sp_private in psym(p)^.symoptions) then
+           spec:='/0'
+         else
+           spec:='';
+         if not assigned(pvarsym(p)^.vartype.def) then
+          writeln(pvarsym(p)^.name);
+         { class fields are pointers PM, obsolete now PM }
+         {if (pvarsym(p)^.vartype.def^.deftype=objectdef) and
+            pobjectdef(pvarsym(p)^.vartype.def)^.is_class then
+            spec:=spec+'*'; }
+         size:=pvarsym(p)^.vartype.def^.size;
+         { open arrays made overflows !! }
+         if size>$fffffff then
+           size:=$fffffff;
+         newrec := strpnew(p^.name+':'+spec+pvarsym(p)^.vartype.def^.numberstring
+                       +','+tostr(pvarsym(p)^.address*8)+','
+                       +tostr(size*8)+';');
+         if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
+           begin
+              getmem(news,stabrecsize+memsizeinc);
+              strcopy(news,stabrecstring);
+              freemem(stabrecstring,stabrecsize);
+              stabrecsize:=stabrecsize+memsizeinc;
+              stabrecstring:=news;
+           end;
+         strcat(StabRecstring,newrec);
+         strdispose(newrec);
+         {This should be used for case !!}
+         RecOffset := RecOffset + pvarsym(p)^.vartype.def^.size;
+       end;
+    end;
+
+
+    function trecorddef.stabstring : pchar;
+      Var oldrec : pchar;
+          oldsize : longint;
+      begin
+        oldrec := stabrecstring;
+        oldsize:=stabrecsize;
+        GetMem(stabrecstring,memsizeinc);
+        stabrecsize:=memsizeinc;
+        strpcopy(stabRecString,'s'+tostr(size));
+        RecOffset := 0;
+        symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}addname);
+        { FPC doesn't want to convert a char to a pchar}
+        { is this a bug ? }
+        strpcopy(strend(StabRecString),';');
+        stabstring := strnew(StabRecString);
+        Freemem(stabrecstring,stabrecsize);
+        stabrecstring := oldrec;
+        stabrecsize:=oldsize;
+      end;
+
+
+    procedure trecorddef.concatstabto(asmlist : paasmoutput);
+      begin
+        if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
+           (is_def_stab_written = not_written)  then
+          inherited concatstabto(asmlist);
+      end;
+
+{$endif GDB}
+
+    var
+       count : longint;
+
+    procedure count_inittable_fields(sym : pnamedindexobject);
+      begin
+         if ((psym(sym)^.typ=varsym) and
+            pvarsym(sym)^.vartype.def^.needs_inittable)
+            and ((pvarsym(sym)^.vartype.def^.deftype<>objectdef) or
+                  not(is_class(pvarsym(sym)^.vartype.def))) then
+           inc(count);
+      end;
+
+
+    procedure count_fields(sym : pnamedindexobject);
+      begin
+            inc(count);
+      end;
+
+
+    procedure write_field_inittable(sym : pnamedindexobject);
+      begin
+         if ((psym(sym)^.typ=varsym) and
+            pvarsym(sym)^.vartype.def^.needs_inittable) and
+            ((pvarsym(sym)^.vartype.def^.deftype<>objectdef) or
+             not(is_class(pvarsym(sym)^.vartype.def))) then
+           begin
+              rttilist^.concat(new(pai_const_symbol,init(pvarsym(sym)^.vartype.def^.get_inittable_label)));
+              rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
+           end;
+      end;
+
+
+    procedure write_field_rtti(sym : pnamedindexobject);
+      begin
+         rttilist^.concat(new(pai_const_symbol,initname(pvarsym(sym)^.vartype.def^.get_rtti_label)));
+         rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
+      end;
+
+
+    procedure generate_child_inittable(sym:pnamedindexobject);
+      begin
+         if (psym(sym)^.typ=varsym) and
+            pvarsym(sym)^.vartype.def^.needs_inittable then
+         { force inittable generation }
+           pvarsym(sym)^.vartype.def^.get_inittable_label;
+      end;
+
+
+    procedure generate_child_rtti(sym : pnamedindexobject);
+      begin
+         pvarsym(sym)^.vartype.def^.get_rtti_label;
+      end;
+
+
+    procedure trecorddef.write_child_rtti_data;
+      begin
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}generate_child_rtti);
+      end;
+
+
+    procedure trecorddef.write_child_init_data;
+      begin
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}generate_child_inittable);
+      end;
+
+
+    procedure trecorddef.write_rtti_data;
+      begin
+         rttilist^.concat(new(pai_const,init_8bit(tkrecord)));
+         write_rtti_name;
+         rttilist^.concat(new(pai_const,init_32bit(size)));
+         count:=0;
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}count_fields);
+         rttilist^.concat(new(pai_const,init_32bit(count)));
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_rtti);
+      end;
+
+
+    procedure trecorddef.write_init_data;
+      begin
+         rttilist^.concat(new(pai_const,init_8bit(tkrecord)));
+         write_rtti_name;
+         rttilist^.concat(new(pai_const,init_32bit(size)));
+         count:=0;
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}count_inittable_fields);
+         rttilist^.concat(new(pai_const,init_32bit(count)));
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_inittable);
+      end;
+
+    function trecorddef.gettypename : string;
+
+      begin
+         gettypename:='<record type>'
+      end;
+
+
+{***************************************************************************
+                       TABSTRACTPROCDEF
+***************************************************************************}
+
+    constructor tabstractprocdef.init;
+      begin
+         inherited init;
+         new(para,init);
+         minparacount:=0;
+         maxparacount:=0;
+         fpu_used:=0;
+         proctypeoption:=potype_none;
+         proccalloptions:=[];
+         procoptions:=[];
+         rettype.setdef(voiddef);
+         symtablelevel:=0;
+         savesize:=target_os.size_of_pointer;
+      end;
+
+
+    destructor tabstractprocdef.done;
+      begin
+         dispose(para,done);
+         inherited done;
+      end;
+
+
+    procedure tabstractprocdef.concatpara(tt:ttype;vsp : tvarspez;defval:psym);
+      var
+        hp : pparaitem;
+      begin
+        new(hp,init);
+        hp^.paratyp:=vsp;
+        hp^.paratype:=tt;
+        hp^.register:=R_NO;
+        hp^.defaultvalue:=defval;
+        para^.insert(hp);
+        if not assigned(defval) then
+         inc(minparacount);
+        inc(maxparacount);
+      end;
+
+
+    { all functions returning in FPU are
+      assume to use 2 FPU registers
+      until the function implementation
+      is processed   PM }
+    procedure tabstractprocdef.test_if_fpu_result;
+      begin
+         if assigned(rettype.def) and is_fpu(rettype.def) then
+           fpu_used:=2;
+      end;
+
+
+    procedure tabstractprocdef.deref;
+      var
+         hp : pparaitem;
+      begin
+         inherited deref;
+         rettype.resolve;
+         hp:=pparaitem(para^.first);
+         while assigned(hp) do
+          begin
+            hp^.paratype.resolve;
+            resolvesym(psym(hp^.defaultvalue));
+            hp:=pparaitem(hp^.next);
+          end;
+      end;
+
+
+    constructor tabstractprocdef.load;
+      var
+         hp : pparaitem;
+         count,i : word;
+      begin
+         inherited load;
+         new(para,init);
+         minparacount:=0;
+         maxparacount:=0;
+         rettype.load;
+         fpu_used:=readbyte;
+         proctypeoption:=tproctypeoption(readlong);
+         readsmallset(proccalloptions,sizeof(proccalloptions));
+         readsmallset(procoptions,sizeof(procoptions));
+         count:=readword;
+         savesize:=target_os.size_of_pointer;
+         for i:=1 to count do
+          begin
+            new(hp,init);
+            hp^.paratyp:=tvarspez(readbyte);
+            { hp^.register:=tregister(readbyte); }
+            hp^.register:=R_NO;
+            hp^.paratype.load;
+            hp^.defaultvalue:=readsymref;
+            if not assigned(hp^.defaultvalue) then
+             inc(minparacount);
+            inc(maxparacount);
+            para^.concat(hp);
+          end;
+      end;
+
+
+    procedure tabstractprocdef.write;
+      var
+        hp : pparaitem;
+        oldintfcrc : boolean;
+      begin
+         inherited write;
+         rettype.write;
+         oldintfcrc:=current_ppu^.do_interface_crc;
+         current_ppu^.do_interface_crc:=false;
+         writebyte(fpu_used);
+         writelong(ord(proctypeoption));
+         writesmallset(proccalloptions,sizeof(proccalloptions));
+         writesmallset(procoptions,sizeof(procoptions));
+         current_ppu^.do_interface_crc:=oldintfcrc;
+         writeword(maxparacount);
+         hp:=pparaitem(para^.first);
+         while assigned(hp) do
+          begin
+            writebyte(byte(hp^.paratyp));
+            { writebyte(byte(hp^.register)); }
+            hp^.paratype.write;
+            writesymref(hp^.defaultvalue);
+            hp:=pparaitem(hp^.next);
+          end;
+      end;
+
+
+    function tabstractprocdef.para_size(alignsize:longint) : longint;
+      var
+         pdc : pparaitem;
+         l : longint;
+      begin
+         l:=0;
+         pdc:=pparaitem(para^.first);
+         while assigned(pdc) do
+          begin
+            case pdc^.paratyp of
+              vs_out,
+              vs_var   : inc(l,target_os.size_of_pointer);
+              vs_value,
+              vs_const : if push_addr_param(pdc^.paratype.def) then
+                          inc(l,target_os.size_of_pointer)
+                         else
+                          inc(l,pdc^.paratype.def^.size);
+            end;
+            l:=align(l,alignsize);
+            pdc:=pparaitem(pdc^.next);
+          end;
+         para_size:=l;
+      end;
+
+
+    function tabstractprocdef.demangled_paras : string;
+      var
+        hs,s : string;
+        hp : pparaitem;
+        hpc : pconstsym;
+      begin
+        s:='(';
+        hp:=pparaitem(para^.last);
+        while assigned(hp) do
+         begin
+           if assigned(hp^.paratype.def^.typesym) then
+             s:=s+hp^.paratype.def^.typesym^.name
+           else if hp^.paratyp=vs_out then
+             s:=s+'out'
+           else if hp^.paratyp=vs_var then
+             s:=s+'var'
+           else if hp^.paratyp=vs_const then
+             s:=s+'const'
+           else if hp^.paratyp=vs_out then
+             s:=s+'out';
+           { default value }
+           if assigned(hp^.defaultvalue) then
+            begin
+              hpc:=pconstsym(hp^.defaultvalue);
+              hs:='';
+              case hpc^.consttyp of
+                conststring,
+                constresourcestring :
+                  hs:=strpas(pchar(tpointerord(hpc^.value)));
+                constreal :
+                  str(pbestreal(tpointerord(hpc^.value))^,hs);
+                constord,
+                constpointer :
+                  hs:=tostr(hpc^.value);
+                constbool :
+                  begin
+                    if hpc^.value<>0 then
+                     hs:='TRUE'
+                    else
+                     hs:='FALSE';
+                  end;
+                constnil :
+                  hs:='nil';
+                constchar :
+                  hs:=chr(hpc^.value);
+                constset :
+                  hs:='<set>';
+              end;
+              if hs<>'' then
+               s:=s+'="'+hs+'"';
+            end;
+           hp:=pparaitem(hp^.previous);
+           if assigned(hp) then
+            s:=s+',';
+         end;
+        s:=s+')';
+        demangled_paras:=s;
+      end;
+
+
+    function tabstractprocdef.proccalloption2str : string;
+      type
+        tproccallopt=record
+          mask : tproccalloption;
+          str  : string[30];
+        end;
+      const
+        proccallopts=13;
+        proccallopt : array[1..proccallopts] of tproccallopt=(
+           (mask:pocall_none;         str:''),
+           (mask:pocall_clearstack;   str:'ClearStack'),
+           (mask:pocall_leftright;    str:'LeftRight'),
+           (mask:pocall_cdecl;        str:'CDecl'),
+           (mask:pocall_register;     str:'Register'),
+           (mask:pocall_stdcall;      str:'StdCall'),
+           (mask:pocall_safecall;     str:'SafeCall'),
+           (mask:pocall_palmossyscall;str:'PalmOSSysCall'),
+           (mask:pocall_system;       str:'System'),
+           (mask:pocall_inline;       str:'Inline'),
+           (mask:pocall_internproc;   str:'InternProc'),
+           (mask:pocall_internconst;  str:'InternConst'),
+           (mask:pocall_cdecl;        str:'CPPDecl')
+        );
+      var
+        s : string;
+        i : longint;
+        first : boolean;
+      begin
+        s:='';
+        first:=true;
+        for i:=1to proccallopts do
+         if (proccallopt[i].mask in proccalloptions) then
+          begin
+            if first then
+              first:=false
+            else
+              s:=s+';';
+            s:=s+proccallopt[i].str;
+          end;
+        proccalloption2str:=s;
+      end;
+
+
+{$ifdef GDB}
+    function tabstractprocdef.stabstring : pchar;
+      begin
+        stabstring := strpnew('abstractproc'+numberstring+';');
+      end;
+
+
+    procedure tabstractprocdef.concatstabto(asmlist : paasmoutput);
+      begin
+         if (not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
+            and (is_def_stab_written = not_written)  then
+           begin
+              if assigned(rettype.def) then forcestabto(asmlist,rettype.def);
+              inherited concatstabto(asmlist);
+           end;
+      end;
+{$endif GDB}
+
+
+{***************************************************************************
+                                  TPROCDEF
+***************************************************************************}
+
+    constructor tprocdef.init;
+      begin
+         inherited init;
+         deftype:=procdef;
+         _mangledname:=nil;
+         nextoverloaded:=nil;
+         fileinfo:=aktfilepos;
+         extnumber:=-1;
+         localst:=new(psymtable,init(localsymtable));
+         parast:=new(psymtable,init(parasymtable));
+         localst^.defowner:=@self;
+         parast^.defowner:=@self;
+         { this is used by insert
+          to check same names in parast and localst }
+         localst^.next:=parast;
+         defref:=nil;
+         crossref:=nil;
+         lastwritten:=nil;
+         refcount:=0;
+         if (cs_browser in aktmoduleswitches) and make_ref then
+          begin
+            defref:=new(pref,init(defref,@tokenpos));
+            inc(refcount);
+          end;
+         lastref:=defref;
+       { first, we assume that all registers are used }
+{$ifdef newcg}
+         usedregisters:=[firstreg..lastreg];
+{$else newcg}
+{$ifdef i386}
+         usedregisters:=$ff;
+{$endif i386}
+{$ifdef m68k}
+         usedregisters:=$FFFF;
+{$endif}
+{$endif newcg}
+         forwarddef:=true;
+         interfacedef:=false;
+         hasforward:=false;
+         _class := nil;
+         code:=nil;
+         regvarinfo := nil;
+         count:=false;
+         is_used:=false;
+      end;
+
+
+    constructor tprocdef.load;
+      begin
+         inherited load;
+         deftype:=procdef;
+
+{$ifdef newcg}
+         readnormalset(usedregisters);
+{$else newcg}
+{$ifdef i386}
+         usedregisters:=readbyte;
+{$endif i386}
+{$ifdef m68k}
+         usedregisters:=readword;
+{$endif}
+{$endif newcg}
+         _mangledname:=stringdup(readstring);
+
+         extnumber:=readlong;
+         nextoverloaded:=pprocdef(readdefref);
+         _class := pobjectdef(readdefref);
+         readposinfo(fileinfo);
+
+         procsym:=pprocsym(readsymref);
+
+         if (cs_link_deffile in aktglobalswitches) and
+            (tf_need_export in target_info.flags) and
+            (po_exports in procoptions) then
+           deffile.AddExport(mangledname);
+
+         new(parast,loadas(parasymtable));
+         parast^.defowner:=@self;
+         {new(localst,loadas(localsymtable));
+         localst^.defowner:=@self;
+         parast^.next:=localst;
+         localst^.next:=owner;}
+
+         forwarddef:=false;
+         interfacedef:=false;
+         hasforward:=false;
+         code := nil;
+         regvarinfo := nil;
+         lastref:=nil;
+         lastwritten:=nil;
+         defref:=nil;
+         refcount:=0;
+         count:=true;
+         is_used:=false;
+      end;
+
+
+Const local_symtable_index : longint = $8001;
+
+    procedure tprocdef.load_references;
+      var
+        pos : tfileposinfo;
+{$ifndef NOLOCALBROWSER}
+        oldsymtablestack,
+        st : psymtable;
+{$endif ndef NOLOCALBROWSER}
+        move_last : boolean;
+      begin
+        move_last:=lastwritten=lastref;
+        while (not current_ppu^.endofentry) do
+         begin
+           readposinfo(pos);
+           inc(refcount);
+           lastref:=new(pref,init(lastref,@pos));
+           lastref^.is_written:=true;
+           if refcount=1 then
+            defref:=lastref;
+         end;
+        if move_last then
+          lastwritten:=lastref;
+        if ((current_module^.flags and uf_local_browser)<>0)
+           and is_in_current then
+          begin
+{$ifndef NOLOCALBROWSER}
+             oldsymtablestack:=symtablestack;
+             st:=aktlocalsymtable;
+             new(parast,loadas(parasymtable));
+             parast^.defowner:=@self;
+             aktlocalsymtable:=parast;
+             parast^.deref;
+             parast^.next:=owner;
+             parast^.load_browser;
+             aktlocalsymtable:=st;
+             new(localst,loadas(localsymtable));
+             localst^.defowner:=@self;
+             aktlocalsymtable:=localst;
+             symtablestack:=parast;
+             localst^.deref;
+             localst^.next:=parast;
+             localst^.load_browser;
+             aktlocalsymtable:=st;
+             symtablestack:=oldsymtablestack;
+{$endif ndef NOLOCALBROWSER}
+          end;
+      end;
+
+
+    function tprocdef.write_references : boolean;
+      var
+        ref : pref;
+{$ifndef NOLOCALBROWSER}
+        st : psymtable;
+        pdo : pobjectdef;
+{$endif ndef NOLOCALBROWSER}
+        move_last : boolean;
+      begin
+        move_last:=lastwritten=lastref;
+        if move_last and (((current_module^.flags and uf_local_browser)=0)
+           or not is_in_current) then
+          exit;
+      { write address of this symbol }
+        writedefref(@self);
+      { write refs }
+        if assigned(lastwritten) then
+          ref:=lastwritten
+        else
+          ref:=defref;
+        while assigned(ref) do
+         begin
+           if ref^.moduleindex=current_module^.unit_index then
+             begin
+                writeposinfo(ref^.posinfo);
+                ref^.is_written:=true;
+                if move_last then
+                  lastwritten:=ref;
+             end
+           else if not ref^.is_written then
+             move_last:=false
+           else if move_last then
+             lastwritten:=ref;
+           ref:=ref^.nextref;
+         end;
+        current_ppu^.writeentry(ibdefref);
+        write_references:=true;
+        if ((current_module^.flags and uf_local_browser)<>0)
+           and is_in_current then
+          begin
+{$ifndef NOLOCALBROWSER}
+             pdo:=_class;
+             if (owner^.symtabletype<>localsymtable) then
+               while assigned(pdo) do
+                 begin
+                    if pdo^.symtable<>aktrecordsymtable then
+                      begin
+                         pdo^.symtable^.unitid:=local_symtable_index;
+                         inc(local_symtable_index);
+                      end;
+                    pdo:=pdo^.childof;
+                 end;
+
+             { we need TESTLOCALBROWSER para and local symtables
+               PPU files are then easier to read PM }
+             if not assigned(parast) then
+               parast:=new(psymtable,init(parasymtable));
+             parast^.defowner:=@self;
+             st:=aktlocalsymtable;
+             aktlocalsymtable:=parast;
+             parast^.writeas;
+             parast^.unitid:=local_symtable_index;
+             inc(local_symtable_index);
+             parast^.write_browser;
+             if not assigned(localst) then
+               localst:=new(psymtable,init(localsymtable));
+             localst^.defowner:=@self;
+             aktlocalsymtable:=localst;
+             localst^.writeas;
+             localst^.unitid:=local_symtable_index;
+             inc(local_symtable_index);
+             localst^.write_browser;
+             aktlocalsymtable:=st;
+             { decrement for }
+             local_symtable_index:=local_symtable_index-2;
+             pdo:=_class;
+             if (owner^.symtabletype<>localsymtable) then
+               while assigned(pdo) do
+                 begin
+                    if pdo^.symtable<>aktrecordsymtable then
+                      dec(local_symtable_index);
+                    pdo:=pdo^.childof;
+                 end;
+{$endif ndef NOLOCALBROWSER}
+          end;
+      end;
+
+
+{$ifdef BrowserLog}
+    procedure tprocdef.add_to_browserlog;
+      begin
+         if assigned(defref) then
+          begin
+            browserlog.AddLog('***'+mangledname);
+            browserlog.AddLogRefs(defref);
+            if (current_module^.flags and uf_local_browser)<>0 then
+              begin
+                 if assigned(parast) then
+                   parast^.writebrowserlog;
+                 if assigned(localst) then
+                   localst^.writebrowserlog;
+              end;
+          end;
+      end;
+{$endif BrowserLog}
+
+
+    destructor tprocdef.done;
+      begin
+         if assigned(defref) then
+           begin
+             defref^.freechain;
+             dispose(defref,done);
+           end;
+         if assigned(parast) then
+           dispose(parast,done);
+         if assigned(localst) and (localst^.symtabletype<>staticsymtable) then
+           dispose(localst,done);
+         if (pocall_inline in proccalloptions) and assigned(code) then
+           tnode(code).free;
+         if assigned(regvarinfo) then
+           dispose(pregvarinfo(regvarinfo));
+         if (po_msgstr in procoptions) then
+           strdispose(messageinf.str);
+         if assigned(_mangledname) then
+           stringdispose(_mangledname);
+         inherited done;
+      end;
+
+
+    procedure tprocdef.write;
+      var
+        oldintfcrc : boolean;
+      begin
+         inherited write;
+         oldintfcrc:=current_ppu^.do_interface_crc;
+         current_ppu^.do_interface_crc:=false;
+   { set all registers to used for simplified compilation PM }
+         if simplify_ppu then
+           begin
+{$ifdef newcg}
+             usedregisters:=[firstreg..lastreg];
+{$else newcg}
+{$ifdef i386}
+             usedregisters:=$ff;
+{$endif i386}
+{$ifdef m68k}
+             usedregisters:=$ffff;
+{$endif}
+{$endif newcg}
+           end;
+
+{$ifdef newcg}
+         writenormalset(usedregisters);
+{$else newcg}
+{$ifdef i386}
+         writebyte(usedregisters);
+{$endif i386}
+{$ifdef m68k}
+         writeword(usedregisters);
+{$endif}
+{$endif newcg}
+         current_ppu^.do_interface_crc:=oldintfcrc;
+         writestring(mangledname);
+         writelong(extnumber);
+         if (proctypeoption<>potype_operator) then
+           writedefref(nextoverloaded)
+         else
+           begin
+              { only write the overloads from the same unit }
+              if assigned(nextoverloaded) and
+                 (nextoverloaded^.owner=owner) then
+                writedefref(nextoverloaded)
+              else
+                writedefref(nil);
+           end;
+         writedefref(_class);
+         writeposinfo(fileinfo);
+         writesymref(procsym);
+         if (pocall_inline in proccalloptions) then
+           begin
+              { we need to save
+                - the para and the local symtable
+                - the code ptree !! PM
+               writesymtable(parast);
+               writesymtable(localst);
+               writeptree(ptree(code));
+               }
+           end;
+         current_ppu^.writeentry(ibprocdef);
+
+         { Save the para and local symtable, for easier reading
+           save both always, they don't influence the interface crc }
+         oldintfcrc:=current_ppu^.do_interface_crc;
+         current_ppu^.do_interface_crc:=false;
+         if not assigned(parast) then
+          begin
+            parast:=new(psymtable,init(parasymtable));
+            parast^.defowner:=@self;
+          end;
+         parast^.writeas;
+         {if not assigned(localst) then
+          begin
+            localst:=new(psymtable,init(localsymtable));
+            localst^.defowner:=@self;
+          end;
+         localst^.writeas;}
+         current_ppu^.do_interface_crc:=oldintfcrc;
+      end;
+
+
+    function tprocdef.haspara:boolean;
+      begin
+        haspara:=assigned(aktprocsym^.definition^.parast^.symindex^.first);
+      end;
+
+
+{$ifdef GDB}
+    procedure addparaname(p : psym);
+      var vs : char;
+      begin
+      if pvarsym(p)^.varspez = vs_value then vs := '1'
+        else vs := '0';
+      strpcopy(strend(StabRecString),p^.name+':'+pvarsym(p)^.vartype.def^.numberstring+','+vs+';');
+      end;
+
+
+    function tprocdef.stabstring : pchar;
+      var
+          i : longint;
+          oldrec : pchar;
+      begin
+      oldrec := stabrecstring;
+      getmem(StabRecString,1024);
+      strpcopy(StabRecString,'f'+rettype.def^.numberstring);
+      i:=maxparacount;
+      if i>0 then
+        begin
+        strpcopy(strend(StabRecString),','+tostr(i)+';');
+        (* confuse gdb !! PM
+        if assigned(parast) then
+          parast^.foreach({$ifdef FPCPROCVAR}@{$endif}addparaname)
+          else
+          begin
+          param := para1;
+          i := 0;
+          while assigned(param) do
+            begin
+            inc(i);
+            if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
+            {Here we have lost the parameter names !!}
+            {using lower case parameters }
+            strpcopy(strend(stabrecstring),'p'+tostr(i)
+               +':'+param^.paratype.def^.numberstring+','+vartyp+';');
+            param := param^.next;
+            end;
+          end;   *)
+        {strpcopy(strend(StabRecString),';');}
+        end;
+      stabstring := strnew(stabrecstring);
+      freemem(stabrecstring,1024);
+      stabrecstring := oldrec;
+      end;
+
+
+    procedure tprocdef.concatstabto(asmlist : paasmoutput);
+      begin
+      end;
+{$endif GDB}
+
+
+    procedure tprocdef.deref;
+      var
+        oldsymtablestack,
+        oldlocalsymtable : psymtable;
+      begin
+         inherited deref;
+         resolvedef(pdef(nextoverloaded));
+         resolvedef(pdef(_class));
+         { parast }
+         oldsymtablestack:=symtablestack;
+         oldlocalsymtable:=aktlocalsymtable;
+         aktlocalsymtable:=parast;
+         parast^.deref;
+         {symtablestack:=parast;
+         aktlocalsymtable:=localst;
+         localst^.deref;}
+         aktlocalsymtable:=oldlocalsymtable;
+         symtablestack:=oldsymtablestack;
+      end;
+
+
+    function tprocdef.mangledname : string;
+      begin
+         if assigned(_mangledname) then
+           mangledname:=_mangledname^
+         else
+           mangledname:='';
+         if count then
+           is_used:=true;
+      end;
+
+
+{$ifdef dummy}
+    function tprocdef.procname: string;
+      var
+        s : string;
+        l : longint;
+      begin
+         if assigned(procsym) then
+           begin
+             procname:=procsym^.name;
+             exit;
+           end;
+         s:=mangledname;
+         { delete leading $$'s }
+         l:=pos('$$',s);
+         while l<>0 do
+           begin
+              delete(s,1,l+1);
+              l:=pos('$$',s);
+           end;
+         { delete leading _$'s }
+         l:=pos('_$',s);
+         while l<>0 do
+           begin
+              delete(s,1,l+1);
+              l:=pos('_$',s);
+           end;
+         l:=pos('$',s);
+         if l=0 then
+          procname:=s
+         else
+          procname:=Copy(s,1,l-1);
+      end;
+{$endif}
+
+    function tprocdef.cplusplusmangledname : string;
+
+      function getcppparaname(p : pdef) : string;
+
+        const
+           ordtype2str : array[tbasetype] of string[2] = (
+             '','','c',
+             'Uc','Us','Ui',
+             'Sc','s','i',
+             'b','b','b',
+             'Us','x','w');
+
+        var
+           s : string;
+
+        begin
+           case p^.deftype of
+              orddef:
+                s:=ordtype2str[porddef(p)^.typ];
+              pointerdef:
+                s:='P'+getcppparaname(ppointerdef(p)^.pointertype.def);
+              else
+                internalerror(2103001);
+           end;
+           getcppparaname:=s;
+        end;
+
+      var
+         s,s2 : string;
+         param : pparaitem;
+
+      begin
+         s := procsym^.realname;
+         if procsym^.owner^.symtabletype=objectsymtable then
+           begin
+              s2:=upper(pobjectdef(procsym^.owner^.defowner)^.typesym^.realname);
+              case proctypeoption of
+                 potype_destructor:
+                   s:='_$_'+tostr(length(s2))+s2;
+                 potype_constructor:
+                   s:='___'+tostr(length(s2))+s2;
+                 else
+                   s:='_'+s+'__'+tostr(length(s2))+s2;
+              end;
+
+           end
+         else s:=s+'__';
+
+         s:=s+'F';
+
+         { concat modifiers }
+         { !!!!! }
+
+         { now we handle the parameters }
+         param := pparaitem(para^.first);
+         if assigned(param) then
+           while assigned(param) do
+             begin
+                s2:=getcppparaname(param^.paratype.def);
+                if param^.paratyp in [vs_var,vs_out] then
+                  s2:='R'+s2;
+                s:=s+s2;
+                param:=pparaitem(param^.next);
+             end
+         else
+           s:=s+'v';
+         cplusplusmangledname:=s;
+      end;
+
+    procedure tprocdef.setmangledname(const s : string);
+      begin
+         if assigned(_mangledname) then
+           begin
+{$ifdef MEMDEBUG}
+              dec(manglenamesize,length(_mangledname^));
+{$endif}
+              stringdispose(_mangledname);
+           end;
+         _mangledname:=stringdup(s);
+{$ifdef MEMDEBUG}
+         inc(manglenamesize,length(s));
+{$endif}
+{$ifdef EXTDEBUG}
+         if assigned(parast) then
+           begin
+              stringdispose(parast^.name);
+              parast^.name:=stringdup('args of '+s);
+           end;
+         if assigned(localst) then
+           begin
+              stringdispose(localst^.name);
+              localst^.name:=stringdup('locals of '+s);
+           end;
+{$endif}
+      end;
+
+
+{***************************************************************************
+                                 TPROCVARDEF
+***************************************************************************}
+
+    constructor tprocvardef.init;
+      begin
+         inherited init;
+         deftype:=procvardef;
+      end;
+
+
+    constructor tprocvardef.load;
+      begin
+         inherited load;
+         deftype:=procvardef;
+      end;
+
+
+    procedure tprocvardef.write;
+      begin
+         { here we cannot get a real good value so just give something }
+         { plausible (PM) }
+         { a more secure way would be
+           to allways store in a temp }
+         if is_fpu(rettype.def) then
+           fpu_used:=2
+         else
+           fpu_used:=0;
+         inherited write;
+         current_ppu^.writeentry(ibprocvardef);
+      end;
+
+
+    function tprocvardef.size : longint;
+      begin
+         if (po_methodpointer in procoptions) then
+           size:=2*target_os.size_of_pointer
+         else
+           size:=target_os.size_of_pointer;
+      end;
+
+
+{$ifdef GDB}
+    function tprocvardef.stabstring : pchar;
+      var
+         nss : pchar;
+        { i   : longint; }
+      begin
+        { i := maxparacount; }
+        getmem(nss,1024);
+        { it is not a function but a function pointer !! (PM) }
+
+        strpcopy(nss,'*f'+rettype.def^.numberstring{+','+tostr(i)}+';');
+        { this confuses gdb !!
+          we should use 'F' instead of 'f' but
+          as we use c++ language mode
+          it does not like that either
+          Please do not remove this part
+          might be used once
+          gdb for pascal is ready PM }
+        (*
+        param := para1;
+        i := 0;
+        while assigned(param) do
+          begin
+          inc(i);
+                   vs_out  : paraspec := pfOut;
+          if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
+          {Here we have lost the parameter names !!}
+          pst := strpnew('p'+tostr(i)+':'+param^.paratype.def^.numberstring+','+vartyp+';');
+          strcat(nss,pst);
+          strdispose(pst);
+          param := param^.next;
+          end; *)
+        {strpcopy(strend(nss),';');}
+        stabstring := strnew(nss);
+        freemem(nss,1024);
+      end;
+
+
+    procedure tprocvardef.concatstabto(asmlist : paasmoutput);
+      begin
+         if ( not assigned(typesym) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
+           and (is_def_stab_written = not_written)  then
+           inherited concatstabto(asmlist);
+         is_def_stab_written:=written;
+      end;
+{$endif GDB}
+
+
+    procedure tprocvardef.write_rtti_data;
+      var
+         pdc : pparaitem;
+         methodkind, paraspec : byte;
+      begin
+        if po_methodpointer in procoptions then
+          begin
+             { write method id and name }
+             rttilist^.concat(new(pai_const,init_8bit(tkmethod)));
+             write_rtti_name;
+
+             { write kind of method (can only be function or procedure)}
+             if rettype.def = pdef(voiddef) then    { ### typecast shoudln't be necessary! (sg) }
+               methodkind := mkProcedure
+             else
+               methodkind := mkFunction;
+             rttilist^.concat(new(pai_const,init_8bit(methodkind)));
+
+             { get # of parameters }
+             rttilist^.concat(new(pai_const,init_8bit(maxparacount)));
+
+             { write parameter info. The parameters must be written in reverse order
+               if this method uses right to left parameter pushing! }
+             if (pocall_leftright in proccalloptions) then
+              pdc:=pparaitem(para^.last)
+             else
+              pdc:=pparaitem(para^.first);
+             while assigned(pdc) do
+               begin
+                 case pdc^.paratyp of
+                   vs_value: paraspec := 0;
+                   vs_const: paraspec := pfConst;
+                   vs_var  : paraspec := pfVar;
+                   vs_out  : paraspec := pfOut;
+                 end;
+                 { write flags for current parameter }
+                 rttilist^.concat(new(pai_const,init_8bit(paraspec)));
+                 { write name of current parameter ### how can I get this??? (sg)}
+                 rttilist^.concat(new(pai_const,init_8bit(0)));
+
+                 { write name of type of current parameter }
+                 pdc^.paratype.def^.write_rtti_name;
+
+                 if (pocall_leftright in proccalloptions) then
+                  pdc:=pparaitem(pdc^.previous)
+                 else
+                  pdc:=pparaitem(pdc^.next);
+               end;
+
+             { write name of result type }
+             rettype.def^.write_rtti_name;
+          end;
+      end;
+
+
+    procedure tprocvardef.write_child_rtti_data;
+      begin
+         {!!!!!!!!}
+      end;
+
+
+    function tprocvardef.is_publishable : boolean;
+      begin
+         is_publishable:=(po_methodpointer in procoptions);
+      end;
+
+    function tprocvardef.gettypename : string;
+      begin
+         if assigned(rettype.def) and
+            (rettype.def<>pdef(voiddef)) then
+           gettypename:='<procedure variable type of function'+demangled_paras+
+             ':'+rettype.def^.gettypename+';'+proccalloption2str+'>'
+         else
+           gettypename:='<procedure variable type of procedure'+demangled_paras+
+             ';'+proccalloption2str+'>';
+      end;
+
+
+{***************************************************************************
+                              TOBJECTDEF
+***************************************************************************}
+
+{$ifdef GDB}
+    const
+       vtabletype : word = 0;
+       vtableassigned : boolean = false;
+{$endif GDB}
+
+   constructor tobjectdef.init(odt : tobjectdeftype; const n : string;c : pobjectdef);
+     begin
+        tdef.init;
+        deftype:=objectdef;
+        objecttype:=odt;
+        objectoptions:=[];
+        childof:=nil;
+        symtable:=new(psymtable,init(objectsymtable));
+        symtable^.name := stringdup(n);
+        { create space for vmt !! }
+        vmt_offset:=0;
+        symtable^.datasize:=0;
+        symtable^.defowner:=@self;
+        symtable^.dataalignment:=packrecordalignment[aktpackrecords];
+
+        set_parent(c);
+        objname:=stringdup(n);
+        lastvtableindex:=0;
+
+        { set up guid }
+        isiidguidvalid:=true; { default null guid }
+        fillchar(iidguid,sizeof(iidguid),0); { default null guid }
+        iidstr:=stringdup(''); { default is empty string }
+
+        { set£p implemented interfaces }
+        if objecttype in [odt_class,odt_interfacecorba] then
+          new(implementedinterfaces,init)
+        else
+          implementedinterfaces:=nil;
+
+{$ifdef GDB}
+        writing_stabs:=false;
+        classglobalnb:=0;
+        classptrglobalnb:=0;
+{$endif GDB}
+     end;
+
+
+    constructor tobjectdef.load;
+      var
+         oldread_member : boolean;
+         implintfcount: longint;
+         i: longint;
+      begin
+         tdef.load;
+         deftype:=objectdef;
+         objecttype:=tobjectdeftype(readbyte);
+         savesize:=readlong;
+         vmt_offset:=readlong;
+         objname:=stringdup(readstring);
+         childof:=pobjectdef(readdefref);
+         readsmallset(objectoptions,sizeof(objectoptions));
+         has_rtti:=boolean(readbyte);
+
+         { load guid }
+         iidstr:=nil;
+         if objecttype in [odt_interfacecom,odt_interfacecorba] then
+           begin
+              isiidguidvalid:=boolean(readbyte);
+              readguid(iidguid);
+              iidstr:=stringdup(readstring);
+              lastvtableindex:=readlong;
+           end;
+
+         { load implemented interfaces }
+         if objecttype in [odt_class,odt_interfacecorba] then
+           begin
+             new(implementedinterfaces,init);
+             implintfcount:=readlong;
+             for i:=1 to implintfcount do
+               begin
+                  implementedinterfaces^.addintfref(readdefref);
+                  implementedinterfaces^.ioffsets(i)^:=readlong;
+               end;
+           end
+         else
+           implementedinterfaces:=nil;
+
+         oldread_member:=read_member;
+         read_member:=true;
+         symtable:=new(psymtable,loadas(objectsymtable));
+         read_member:=oldread_member;
+
+         symtable^.defowner:=@self;
+         symtable^.name := stringdup(objname^);
+
+         { handles the predefined class tobject  }
+         { the last TOBJECT which is loaded gets }
+         { it !                                  }
+         if (childof=nil) and
+            (objecttype=odt_class) and
+            (upper(objname^)='TOBJECT') then
+           class_tobject:=@self;
+         if (childof=nil) and (objecttype=odt_interfacecom) and
+           (objname^='IUNKNOWN') then
+           interface_iunknown:=@self;
+{$ifdef GDB}
+         writing_stabs:=false;
+         classglobalnb:=0;
+         classptrglobalnb:=0;
+{$endif GDB}
+       end;
+
+
+   destructor tobjectdef.done;
+     begin
+        if assigned(symtable) then
+          dispose(symtable,done);
+        if (oo_is_forward in objectoptions) then
+          Message1(sym_e_class_forward_not_resolved,objname^);
+        stringdispose(objname);
+        stringdispose(iidstr);
+        if assigned(implementedinterfaces) then
+          dispose(implementedinterfaces,done);
+        tdef.done;
+     end;
+
+
+    procedure tobjectdef.write;
+      var
+         oldread_member : boolean;
+         implintfcount : longint;
+         i : longint;
+      begin
+         tdef.write;
+         writebyte(ord(objecttype));
+         writelong(size);
+         writelong(vmt_offset);
+         writestring(objname^);
+         writedefref(childof);
+         writesmallset(objectoptions,sizeof(objectoptions));
+         writebyte(byte(has_rtti));
+         if objecttype in [odt_interfacecom,odt_interfacecorba] then
+           begin
+              writebyte(byte(isiidguidvalid));
+              writeguid(iidguid);
+              writestring(iidstr^);
+              writelong(lastvtableindex);
+           end;
+
+         if objecttype in [odt_class,odt_interfacecorba] then
+           begin
+              implintfcount:=implementedinterfaces^.count;
+              writelong(implintfcount);
+              for i:=1 to implintfcount do
+                begin
+                   writedefref(implementedinterfaces^.interfaces(i));
+                   writelong(implementedinterfaces^.ioffsets(i)^);
+                end;
+           end;
+
+         current_ppu^.writeentry(ibobjectdef);
+
+         oldread_member:=read_member;
+         read_member:=true;
+         symtable^.writeas;
+         read_member:=oldread_member;
+      end;
+
+
+    procedure tobjectdef.deref;
+      var
+         oldrecsyms : psymtable;
+      begin
+         inherited deref;
+         resolvedef(pdef(childof));
+         oldrecsyms:=aktrecordsymtable;
+         aktrecordsymtable:=symtable;
+         symtable^.deref;
+         aktrecordsymtable:=oldrecsyms;
+         if objecttype in [odt_class,odt_interfacecorba] then
+           implementedinterfaces^.deref;
+      end;
+
+
+    procedure tobjectdef.set_parent( c : pobjectdef);
+      begin
+        { nothing to do if the parent was not forward !}
+        if assigned(childof) then
+          exit;
+        childof:=c;
+        { some options are inherited !! }
+        if assigned(c) then
+          begin
+             { only important for classes }
+             lastvtableindex:=c^.lastvtableindex;
+             objectoptions:=objectoptions+(c^.objectoptions*
+               [oo_has_virtual,oo_has_private,oo_has_protected,oo_has_constructor,oo_has_destructor]);
+             if not (objecttype in [odt_interfacecom,odt_interfacecorba]) then
+               begin
+                  { add the data of the anchestor class }
+                  inc(symtable^.datasize,c^.symtable^.datasize);
+                  if (oo_has_vmt in objectoptions) and
+                     (oo_has_vmt in c^.objectoptions) then
+                    dec(symtable^.datasize,target_os.size_of_pointer);
+                  { if parent has a vmt field then
+                    the offset is the same for the child PM }
+                  if (oo_has_vmt in c^.objectoptions) or is_class(@self) then
+                    begin
+                       vmt_offset:=c^.vmt_offset;
+                       include(objectoptions,oo_has_vmt);
+                    end;
+               end;
+          end;
+        savesize := symtable^.datasize;
+      end;
+
+
+   procedure tobjectdef.insertvmt;
+     begin
+        if objecttype in [odt_interfacecom,odt_interfacecorba] then exit;
+        if (oo_has_vmt in objectoptions) then
+          internalerror(12345)
+        else
+          begin
+             { first round up to multiple of 4 }
+             if (symtable^.dataalignment=2) then
+               begin
+                 if (symtable^.datasize and 1)<>0 then
+                   inc(symtable^.datasize);
+               end
+             else
+              if (symtable^.dataalignment>=4) then
+               begin
+                 if (symtable^.datasize mod 4) <> 0 then
+                   inc(symtable^.datasize,4-(symtable^.datasize mod 4));
+               end;
+             vmt_offset:=symtable^.datasize;
+             inc(symtable^.datasize,target_os.size_of_pointer);
+             include(objectoptions,oo_has_vmt);
+          end;
+     end;
+
+
+   procedure tobjectdef.check_forwards;
+     begin
+        if objecttype in [odt_interfacecom,odt_interfacecorba] then exit; { Kaz: ??? }
+        symtable^.check_forwards;
+        if (oo_is_forward in objectoptions) then
+          begin
+             { ok, in future, the forward can be resolved }
+             Message1(sym_e_class_forward_not_resolved,objname^);
+             exclude(objectoptions,oo_is_forward);
+          end;
+     end;
+
+
+   { true, if self inherits from d (or if they are equal) }
+   function tobjectdef.is_related(d : pobjectdef) : boolean;
+     var
+        hp : pobjectdef;
+     begin
+        hp:=@self;
+        while assigned(hp) do
+          begin
+             if hp=d then
+               begin
+                  is_related:=true;
+                  exit;
+               end;
+             hp:=hp^.childof;
+          end;
+        is_related:=false;
+     end;
+
+   var
+      sd : pprocdef;
+
+   procedure _searchdestructor(sym : pnamedindexobject);
+
+     var
+        p : pprocdef;
+
+     begin
+        { if we found already a destructor, then we exit }
+        if assigned(sd) then
+          exit;
+        if psym(sym)^.typ=procsym then
+          begin
+             p:=pprocsym(sym)^.definition;
+             while assigned(p) do
+               begin
+                  if p^.proctypeoption=potype_destructor then
+                    begin
+                       sd:=p;
+                       exit;
+                    end;
+                  p:=p^.nextoverloaded;
+               end;
+          end;
+     end;
+
+   function tobjectdef.searchdestructor : pprocdef;
+
+     var
+        o : pobjectdef;
+
+     begin
+        searchdestructor:=nil;
+        o:=@self;
+        sd:=nil;
+        while assigned(o) do
+          begin
+             symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}_searchdestructor);
+             if assigned(sd) then
+               begin
+                  searchdestructor:=sd;
+                  exit;
+               end;
+             o:=o^.childof;
+          end;
+     end;
+
+    function tobjectdef.size : longint;
+      begin
+        if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
+          size:=target_os.size_of_pointer
+        else
+          size:=symtable^.datasize;
+      end;
+
+
+    function tobjectdef.alignment:longint;
+      begin
+        alignment:=symtable^.dataalignment;
+      end;
+
+
+    function tobjectdef.vmtmethodoffset(index:longint):longint;
+      begin
+        { for offset of methods for classes, see rtl/inc/objpash.inc }
+        if objecttype in [odt_interfacecom,odt_interfacecorba] then
+          vmtmethodoffset:=index*target_os.size_of_pointer
+        else if (objecttype=odt_class) then
+           vmtmethodoffset:=(index+12)*target_os.size_of_pointer
+        else
+{$ifdef WITHDMT}
+         vmtmethodoffset:=(index+4)*target_os.size_of_pointer;
+{$else WITHDMT}
+         vmtmethodoffset:=(index+3)*target_os.size_of_pointer;
+{$endif WITHDMT}
+      end;
+
+
+    function tobjectdef.vmt_mangledname : string;
+    {DM: I get a nil pointer on the owner name. I don't know if this
+     may happen, and I have therefore fixed the problem by doing nil pointer
+     checks.}
+    var
+      s1,s2:string;
+    begin
+        if not(oo_has_vmt in objectoptions) then
+          Message1(parser_object_has_no_vmt,objname^);
+        if owner^.name=nil then
+          s1:=''
+        else
+          s1:=owner^.name^;
+        if objname=nil then
+          s2:=''
+        else
+          s2:=Upper(objname^);
+        vmt_mangledname:='VMT_'+s1+'$_'+s2;
+    end;
+
+
+    function tobjectdef.rtti_name : string;
+    var
+      s1,s2:string;
+    begin
+       if owner^.name=nil then
+         s1:=''
+       else
+         s1:=owner^.name^;
+       if objname=nil then
+         s2:=''
+       else
+         s2:=Upper(objname^);
+       rtti_name:='RTTI_'+s1+'$_'+s2;
+    end;
+
+
+{$ifdef GDB}
+    procedure addprocname(p :pnamedindexobject);
+    var virtualind,argnames : string;
+        news, newrec : pchar;
+        pd,ipd : pprocdef;
+        lindex : longint;
+        para : pparaitem;
+        arglength : byte;
+        sp : char;
+
+    begin
+      If psym(p)^.typ = procsym then
+       begin
+                pd := pprocsym(p)^.definition;
+                { this will be used for full implementation of object stabs
+                not yet done }
+                ipd := pd;
+                while assigned(ipd^.nextoverloaded) do ipd := ipd^.nextoverloaded;
+                if (po_virtualmethod in pd^.procoptions) then
+                  begin
+                    lindex := pd^.extnumber;
+                    {doesnt seem to be necessary
+                    lindex := lindex or $80000000;}
+                    virtualind := '*'+tostr(lindex)+';'+ipd^._class^.classnumberstring+';'
+                  end
+                 else
+                  virtualind := '.';
+
+                 { used by gdbpas to recognize constructor and destructors }
+                 if (pd^.proctypeoption=potype_constructor) then
+                   argnames:='__ct__'
+                 else if (pd^.proctypeoption=potype_destructor) then
+                   argnames:='__dt__'
+                 else
+                   argnames := '';
+
+                { arguments are not listed here }
+                {we don't need another definition}
+                 para := pparaitem(pd^.para^.first);
+                 while assigned(para) do
+                   begin
+                   if para^.paratype.def^.deftype = formaldef then
+                     begin
+                        if para^.paratyp=vs_out then
+                          argnames := argnames+'3out'
+                        else if para^.paratyp=vs_var then
+                          argnames := argnames+'3var'
+                        else if para^.paratyp=vs_const then
+                          argnames:=argnames+'5const'
+                        else if para^.paratyp=vs_out then
+                          argnames:=argnames+'3out';
+                     end
+                   else
+                     begin
+                     { if the arg definition is like (v: ^byte;..
+                     there is no sym attached to data !!! }
+                     if assigned(para^.paratype.def^.typesym) then
+                       begin
+                          arglength := length(para^.paratype.def^.typesym^.name);
+                          argnames := argnames + tostr(arglength)+para^.paratype.def^.typesym^.name;
+                       end
+                     else
+                       begin
+                          argnames:=argnames+'11unnamedtype';
+                       end;
+                     end;
+                   para := pparaitem(para^.next);
+                   end;
+                ipd^.is_def_stab_written := written;
+                { here 2A must be changed for private and protected }
+                { 0 is private 1 protected and 2 public }
+                if (sp_private in psym(p)^.symoptions) then sp:='0'
+                else if (sp_protected in psym(p)^.symoptions) then sp:='1'
+                else sp:='2';
+                newrec := strpnew(p^.name+'::'+ipd^.numberstring
+                     +'=##'+pd^.rettype.def^.numberstring+';:'+argnames+';'+sp+'A'
+                     +virtualind+';');
+               { get spare place for a string at the end }
+               if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
+                 begin
+                    getmem(news,stabrecsize+memsizeinc);
+                    strcopy(news,stabrecstring);
+                    freemem(stabrecstring,stabrecsize);
+                    stabrecsize:=stabrecsize+memsizeinc;
+                    stabrecstring:=news;
+                 end;
+               strcat(StabRecstring,newrec);
+               {freemem(newrec,memsizeinc);    }
+               strdispose(newrec);
+               {This should be used for case !!}
+               RecOffset := RecOffset + pd^.size;
+       end;
+    end;
+
+
+    function tobjectdef.stabstring : pchar;
+      var anc : pobjectdef;
+          oldrec : pchar;
+          storenb, oldrecsize : longint;
+          str_end : string;
+      begin
+        if not (is_class(@self)) or writing_stabs then
+          begin
+            storenb:=globalnb;
+            globalnb:=classptrglobalnb;
+            oldrec := stabrecstring;
+            oldrecsize:=stabrecsize;
+            stabrecsize:=memsizeinc;
+            GetMem(stabrecstring,stabrecsize);
+            strpcopy(stabRecString,'s'+tostr(symtable^.datasize));
+            if assigned(childof) then
+              begin
+                {only one ancestor not virtual, public, at base offset 0 }
+                {       !1           ,    0       2         0    ,       }
+                strpcopy(strend(stabrecstring),'!1,020,'+childof^.classnumberstring+';');
+              end;
+            {virtual table to implement yet}
+            RecOffset := 0;
+            symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}addname);
+            if (oo_has_vmt in objectoptions) then
+              if not assigned(childof) or not(oo_has_vmt in childof^.objectoptions) then
+                 begin
+                    strpcopy(strend(stabrecstring),'$vf'+classnumberstring+':'+typeglobalnumber('vtblarray')
+                      +','+tostr(vmt_offset*8)+';');
+                 end;
+            symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}addprocname);
+            if (oo_has_vmt in objectoptions) then
+              begin
+                 anc := @self;
+                 while assigned(anc^.childof) and (oo_has_vmt in anc^.childof^.objectoptions) do
+                   anc := anc^.childof;
+                 { just in case anc = self }
+                 str_end:=';~%'+anc^.classnumberstring+';';
+              end
+            else
+              str_end:=';';
+            strpcopy(strend(stabrecstring),str_end);
+            stabstring := strnew(StabRecString);
+            freemem(stabrecstring,stabrecsize);
+            stabrecstring := oldrec;
+            stabrecsize:=oldrecsize;
+            globalnb:=storenb;
+          end
+        else
+          begin
+            stabstring:=strpnew('*'+classnumberstring);
+          end;
+      end;
+
+   procedure tobjectdef.set_globalnb;
+     begin
+         classglobalnb:=PGlobalTypeCount^;
+         globalnb:=classglobalnb;
+         inc(PglobalTypeCount^);
+         { classes need two type numbers, the globalnb is set to the ptr }
+         if objecttype=odt_class then
+           begin
+             classptrglobalnb:=PGlobalTypeCount^;
+             globalnb:=classptrglobalnb;
+             inc(PglobalTypeCount^);
+           end;
+     end;
+
+   function tobjectdef.classnumberstring : string;
+     var
+       onb : word;
+     begin
+       if globalnb=0 then
+         numberstring;
+       if objecttype=odt_class then
+         begin
+           onb:=globalnb;
+           globalnb:=classglobalnb;
+           classnumberstring:=numberstring;
+           globalnb:=onb;
+         end
+       else
+         classnumberstring:=numberstring;
+     end;
+
+   function tobjectdef.classptrnumberstring : string;
+     var
+       onb : word;
+     begin
+       if globalnb=0 then
+         numberstring;
+       if objecttype=odt_class then
+         begin
+           onb:=globalnb;
+           globalnb:=classptrglobalnb;
+           classptrnumberstring:=numberstring;
+           globalnb:=onb;
+         end
+       else
+         classptrnumberstring:=numberstring;
+     end;
+
+    procedure tobjectdef.concatstabto(asmlist : paasmoutput);
+      var st : pstring;
+      begin
+        if not(objecttype=odt_class) then
+          begin
+            inherited concatstabto(asmlist);
+            exit;
+          end;
+
+      if ((typesym=nil) or typesym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches)) and
+         (is_def_stab_written = not_written) then
+        begin
+          if globalnb=0 then
+            set_globalnb;
+          { Write the record class itself }
+          writing_stabs:=true;
+          if assigned(typesym) then
+            begin
+              st:=typesym^._name;
+              typesym^._name:=stringdup(' ');
+            end;
+          globalnb:=classglobalnb;
+          inherited concatstabto(asmlist);
+          if assigned(typesym) then
+            begin
+              stringdispose(typesym^._name);
+              typesym^._name:=st;
+            end;
+          globalnb:=classptrglobalnb;
+          writing_stabs:=false;
+          { Write the invisible pointer class }
+          is_def_stab_written:=not_written;
+          inherited concatstabto(asmlist);
+        end;
+      end;
+{$endif GDB}
+
+
+    procedure tobjectdef.write_child_init_data;
+      begin
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}generate_child_inittable);
+      end;
+
+
+    procedure tobjectdef.write_init_data;
+      begin
+         case objecttype of
+            odt_class:
+              rttilist^.concat(new(pai_const,init_8bit(tkclass)));
+            odt_object:
+              rttilist^.concat(new(pai_const,init_8bit(tkobject)));
+            odt_interfacecom:
+              rttilist^.concat(new(pai_const,init_8bit(tkinterface)));
+            odt_interfacecorba:
+              rttilist^.concat(new(pai_const,init_8bit(tkinterfaceCorba)));
+          else
+            exit;
+          end;
+
+         { generate the name }
+         rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
+         rttilist^.concat(new(pai_string,init(objname^)));
+
+         rttilist^.concat(new(pai_const,init_32bit(size)));
+         count:=0;
+         if objecttype in [odt_interfacecom,odt_interfacecorba] then
+           begin
+           end
+         else
+           begin
+              symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}count_inittable_fields);
+              rttilist^.concat(new(pai_const,init_32bit(count)));
+              symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_inittable);
+           end;
+      end;
+
+
+    function tobjectdef.needs_inittable : boolean;
+      var
+         oldb : boolean;
+      begin
+         case objecttype of
+            odt_interfacecom: needs_inittable:=true;
+            odt_object:
+              begin
+                 { there are recursive calls to needs_inittable possible, }
+                 { so we have to change to old value how else should      }
+                 { we do that ? check_rec_rtti can't be a nested          }
+                 { procedure of needs_rtti !                              }
+                 oldb:=binittable;
+                 binittable:=false;
+                 symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}check_rec_inittable);
+                 needs_inittable:=binittable;
+                 binittable:=oldb;
+              end;
+            else needs_inittable:=false;
+         end;
+      end;
+
+
+    procedure count_published_properties(sym:pnamedindexobject);
+      begin
+         if needs_prop_entry(psym(sym)) and
+          (psym(sym)^.typ<>varsym) then
+           inc(count);
+      end;
+
+
+    procedure write_property_info(sym : pnamedindexobject);
+      var
+         proctypesinfo : byte;
+
+      procedure writeproc(proc : psymlist; shiftvalue : byte);
+
+        var
+           typvalue : byte;
+           hp : psymlistitem;
+           address : longint;
+
+        begin
+           if not(assigned(proc) and assigned(proc^.firstsym))  then
+             begin
+                rttilist^.concat(new(pai_const,init_32bit(1)));
+                typvalue:=3;
+             end
+           else if proc^.firstsym^.sym^.typ=varsym then
+             begin
+                address:=0;
+                hp:=proc^.firstsym;
+                while assigned(hp) do
+                  begin
+                     inc(address,pvarsym(hp^.sym)^.address);
+                     hp:=hp^.next;
+                  end;
+                rttilist^.concat(new(pai_const,init_32bit(address)));
+                typvalue:=0;
+             end
+           else
+             begin
+                if not(po_virtualmethod in pprocdef(proc^.def)^.procoptions) then
+                  begin
+                     rttilist^.concat(new(pai_const_symbol,initname(pprocdef(proc^.def)^.mangledname)));
+                     typvalue:=1;
+                  end
+                else
+                  begin
+                     { virtual method, write vmt offset }
+                     rttilist^.concat(new(pai_const,init_32bit(
+                       pprocdef(proc^.def)^._class^.vmtmethodoffset(pprocdef(proc^.def)^.extnumber))));
+                     typvalue:=2;
+                  end;
+             end;
+           proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
+        end;
+
+      begin
+         if needs_prop_entry(psym(sym)) then
+           case psym(sym)^.typ of
+              varsym:
+                begin
+{$ifdef dummy}
+                   if not(pvarsym(sym)^.vartype.def^.deftype=objectdef) or
+                     not(pobjectdef(pvarsym(sym)^.vartype.def)^.is_class) then
+                     internalerror(1509992);
+                   { access to implicit class property as field }
+                   proctypesinfo:=(0 shl 0) or (0 shl 2) or (0 shl 4);
+                   rttilist^.concat(new(pai_const_symbol,initname(pvarsym(sym)^.vartype.def^.get_rtti_label)));
+                   rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
+                   rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
+                   { per default stored }
+                   rttilist^.concat(new(pai_const,init_32bit(1)));
+                   { index as well as ... }
+                   rttilist^.concat(new(pai_const,init_32bit(0)));
+                   { default value are zero }
+                   rttilist^.concat(new(pai_const,init_32bit(0)));
+                   rttilist^.concat(new(pai_const,init_16bit(count)));
+                   inc(count);
+                   rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
+                   rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.realname))));
+                   rttilist^.concat(new(pai_string,init(pvarsym(sym)^.realname)));
+{$endif dummy}
+                end;
+              propertysym:
+                begin
+                   if ppo_indexed in ppropertysym(sym)^.propoptions then
+                     proctypesinfo:=$40
+                   else
+                     proctypesinfo:=0;
+                   rttilist^.concat(new(pai_const_symbol,initname(ppropertysym(sym)^.proptype.def^.get_rtti_label)));
+                   writeproc(ppropertysym(sym)^.readaccess,0);
+                   writeproc(ppropertysym(sym)^.writeaccess,2);
+                   { isn't it stored ? }
+                   if not(ppo_stored in ppropertysym(sym)^.propoptions) then
+                     begin
+                        rttilist^.concat(new(pai_const,init_32bit(0)));
+                        proctypesinfo:=proctypesinfo or (3 shl 4);
+                     end
+                   else
+                     writeproc(ppropertysym(sym)^.storedaccess,4);
+                   rttilist^.concat(new(pai_const,init_32bit(ppropertysym(sym)^.index)));
+                   rttilist^.concat(new(pai_const,init_32bit(ppropertysym(sym)^.default)));
+                   rttilist^.concat(new(pai_const,init_16bit(count)));
+                   inc(count);
+                   rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
+                   rttilist^.concat(new(pai_const,init_8bit(length(ppropertysym(sym)^.realname))));
+                   rttilist^.concat(new(pai_string,init(ppropertysym(sym)^.realname)));
+                end;
+              else internalerror(1509992);
+           end;
+      end;
+
+
+    procedure generate_published_child_rtti(sym : pnamedindexobject);
+      begin
+         if needs_prop_entry(psym(sym)) then
+           case psym(sym)^.typ of
+              varsym:
+                ;
+                { now ignored:
+                ;
+                { now ignored
+                pvarsym(sym)^.vartype.def^.get_rtti_label;
+                }
+                }
+              propertysym:
+                ppropertysym(sym)^.proptype.def^.get_rtti_label;
+              else
+                internalerror(1509991);
+           end;
+      end;
+
+
+    procedure tobjectdef.write_child_rtti_data;
+      begin
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}generate_published_child_rtti);
+      end;
+
+
+    procedure tobjectdef.generate_rtti;
+      begin
+         if not has_rtti then
+          begin
+            has_rtti:=true;
+            getdatalabel(rtti_label);
+            write_child_rtti_data;
+            rttilist^.concat(new(pai_symbol,initname_global(rtti_name,0)));
+            rttilist^.concat(new(pai_label,init(rtti_label)));
+            write_rtti_data;
+            rttilist^.concat(new(pai_symbol_end,initname(rtti_name)));
+          end;
+      end;
+
+    type
+       tclasslistitem = object(tlinkedlist_item)
+          index : longint;
+          p : pobjectdef;
+       end;
+       pclasslistitem = ^tclasslistitem;
+
+    var
+       classtablelist : tlinkedlist;
+       tablecount : longint;
+
+    function searchclasstablelist(p : pobjectdef) : pclasslistitem;
+
+      var
+         hp : pclasslistitem;
+
+      begin
+         hp:=pclasslistitem(classtablelist.first);
+         while assigned(hp) do
+           if hp^.p=p then
+             begin
+                searchclasstablelist:=hp;
+                exit;
+             end
+           else
+             hp:=pclasslistitem(hp^.next);
+         searchclasstablelist:=nil;
+      end;
+
+    procedure count_published_fields(sym:pnamedindexobject);
+      var
+         hp : pclasslistitem;
+      begin
+         if needs_prop_entry(psym(sym)) and
+          (psym(sym)^.typ=varsym) then
+          begin
+             if pvarsym(sym)^.vartype.def^.deftype<>objectdef then
+               internalerror(0206001);
+             hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def));
+             if not(assigned(hp)) then
+               begin
+                  hp:=new(pclasslistitem,init);
+                  hp^.p:=pobjectdef(pvarsym(sym)^.vartype.def);
+                  hp^.index:=tablecount;
+                  classtablelist.concat(hp);
+                  inc(tablecount);
+               end;
+             inc(count);
+          end;
+      end;
+
+    procedure writefields(sym:pnamedindexobject);
+      var
+         hp : pclasslistitem;
+      begin
+         if needs_prop_entry(psym(sym)) and
+          (psym(sym)^.typ=varsym) then
+          begin
+             rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
+             hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def));
+             if not(assigned(hp)) then
+               internalerror(0206002);
+             rttilist^.concat(new(pai_const,init_16bit(hp^.index)));
+             rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.realname))));
+             rttilist^.concat(new(pai_string,init(pvarsym(sym)^.realname)));
+          end;
+      end;
+
+    function tobjectdef.generate_field_table : pasmlabel;
+
+      var
+         fieldtable,
+         classtable : pasmlabel;
+         hp : pclasslistitem;
+
+      begin
+         classtablelist.init;
+         getdatalabel(fieldtable);
+         getdatalabel(classtable);
+         count:=0;
+         tablecount:=0;
+         symtable^.foreach({$ifdef FPC}@{$endif}count_published_fields);
+         rttilist^.concat(new(pai_label,init(fieldtable)));
+         rttilist^.concat(new(pai_const,init_16bit(count)));
+         rttilist^.concat(new(pai_const_symbol,init(classtable)));
+         symtable^.foreach({$ifdef FPC}@{$endif}writefields);
+
+         { generate the class table }
+         rttilist^.concat(new(pai_label,init(classtable)));
+         rttilist^.concat(new(pai_const,init_16bit(tablecount)));
+         hp:=pclasslistitem(classtablelist.first);
+         while assigned(hp) do
+           begin
+              rttilist^.concat(new(pai_const_symbol,initname(pobjectdef(hp^.p)^.vmt_mangledname)));
+              hp:=pclasslistitem(hp^.next);
+           end;
+
+         generate_field_table:=fieldtable;
+         classtablelist.done;
+      end;
+
+    function tobjectdef.next_free_name_index : longint;
+      var
+         i : longint;
+      begin
+         if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
+           i:=childof^.next_free_name_index
+         else
+           i:=0;
+         count:=0;
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties);
+         next_free_name_index:=i+count;
+      end;
+
+
+    procedure tobjectdef.write_rtti_data;
+      begin
+         case objecttype of
+           odt_class: rttilist^.concat(new(pai_const,init_8bit(tkclass)));
+           odt_object: rttilist^.concat(new(pai_const,init_8bit(tkobject)));
+           odt_interfacecom: rttilist^.concat(new(pai_const,init_8bit(tkinterface)));
+           odt_interfacecorba: rttilist^.concat(new(pai_const,init_8bit(tkinterfaceCorba)));
+         else
+           exit;
+         end;
+
+         { generate the name }
+         rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
+         rttilist^.concat(new(pai_string,init(objname^)));
+
+         { write class type }
+         if objecttype in [odt_interfacecom,odt_interfacecorba] then
+           rttilist^.concat(new(pai_const,init_32bit(0)))
+         else
+           rttilist^.concat(new(pai_const_symbol,initname(vmt_mangledname)));
+
+         { write owner typeinfo }
+         if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
+           rttilist^.concat(new(pai_const_symbol,initname(childof^.get_rtti_label)))
+         else
+           rttilist^.concat(new(pai_const,init_32bit(0)));
+
+         { count total number of properties }
+         if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
+           count:=childof^.next_free_name_index
+         else
+           count:=0;
+
+         { write it }
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties);
+         rttilist^.concat(new(pai_const,init_16bit(count)));
+
+         { write unit name }
+         rttilist^.concat(new(pai_const,init_8bit(length(current_module^.realmodulename^))));
+         rttilist^.concat(new(pai_string,init(current_module^.realmodulename^)));
+
+         { write published properties count }
+         count:=0;
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}count_published_properties);
+         rttilist^.concat(new(pai_const,init_16bit(count)));
+
+         { count is used to write nameindex   }
+
+         { but we need an offset of the owner }
+         { to give each property an own slot  }
+         if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
+           count:=childof^.next_free_name_index
+         else
+           count:=0;
+
+         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}write_property_info);
+      end;
+
+
+    function tobjectdef.is_publishable : boolean;
+      begin
+         is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
+      end;
+
+    function  tobjectdef.get_rtti_label : string;
+
+      begin
+         generate_rtti;
+         get_rtti_label:=rtti_name;
+      end;
+
+{****************************************************************************
+                                TFORWARDDEF
+****************************************************************************}
+
+   constructor tforwarddef.init(const s:string;const pos : tfileposinfo);
+     var
+       oldregisterdef : boolean;
+     begin
+        { never register the forwarddefs, they are disposed at the
+          end of the type declaration block }
+        oldregisterdef:=registerdef;
+        registerdef:=false;
+        inherited init;
+        registerdef:=oldregisterdef;
+        deftype:=forwarddef;
+        tosymname:=s;
+        forwardpos:=pos;
+     end;
+
+
+    function tforwarddef.gettypename:string;
+      begin
+        gettypename:='unresolved forward to '+tosymname;
+      end;
+
+
+{****************************************************************************
+                             TIMPLEMENTEDINTERFACES
+****************************************************************************}
+    type
+      pnamemap = ^tnamemap;
+      tnamemap = object(tnamedindexobject)
+        newname: pstring;
+        constructor init(const aname, anewname: string);
+        destructor  done; virtual;
+      end;
+
+    constructor tnamemap.init(const aname, anewname: string);
+      begin
+        inherited initname(name);
+        newname:=stringdup(anewname);
+      end;
+
+    destructor  tnamemap.done;
+      begin
+        stringdispose(newname);
+        inherited done;
+      end;
+
+
+    type
+      pprocdefstore = ^tprocdefstore;
+      tprocdefstore = object(tnamedindexobject)
+        procdef: pprocdef;
+        constructor init(aprocdef: pprocdef);
+      end;
+
+    constructor tprocdefstore.init(aprocdef: pprocdef);
+      begin
+        inherited init;
+        procdef:=aprocdef;
+      end;
+
+
+    type
+      pimplintfentry = ^timplintfentry;
+      timplintfentry = object(tnamedindexobject)
+        intf: pobjectdef;
+        ioffs: longint;
+        namemappings: pdictionary;
+        procdefs: pindexarray;
+        constructor init(aintf: pobjectdef);
+        destructor  done; virtual;
+      end;
+
+    constructor timplintfentry.init(aintf: pobjectdef);
+      begin
+        inherited init;
+        intf:=aintf;
+        ioffs:=-1;
+        namemappings:=nil;
+        procdefs:=nil;
+      end;
+
+    destructor  timplintfentry.done;
+      begin
+        if assigned(namemappings) then
+          dispose(namemappings,done);
+        if assigned(procdefs) then
+          dispose(procdefs,done);
+        inherited done;
+      end;
+
+
+    constructor timplementedinterfaces.init;
+      begin
+        finterfaces.init(1);
+      end;
+
+    destructor  timplementedinterfaces.done;
+      begin
+        finterfaces.done;
+      end;
+
+    function  timplementedinterfaces.count: longint;
+      begin
+        count:=finterfaces.count;
+      end;
+
+    procedure timplementedinterfaces.checkindex(intfindex: longint);
+      begin
+        if (intfindex<1) or (intfindex>count) then
+          InternalError(200006123);
+      end;
+
+    function  timplementedinterfaces.interfaces(intfindex: longint): pobjectdef;
+      begin
+        checkindex(intfindex);
+        interfaces:=pimplintfentry(finterfaces.search(intfindex))^.intf;
+      end;
+
+    function  timplementedinterfaces.ioffsets(intfindex: longint): plongint;
+      begin
+        checkindex(intfindex);
+        ioffsets:=@pimplintfentry(finterfaces.search(intfindex))^.ioffs;
+      end;
+
+    function  timplementedinterfaces.searchintf(def: pdef): longint;
+      var
+        i: longint;
+      begin
+        i:=1;
+        while (i<=count) and (pdef(interfaces(i))<>def) do inc(i);
+        if i<=count then
+          searchintf:=i
+        else
+          searchintf:=-1;
+      end;
+
+    procedure timplementedinterfaces.deref;
+      var
+        i: longint;
+      begin
+        for i:=1 to count do
+          with pimplintfentry(finterfaces.search(i))^ do
+            resolvedef(pdef(intf));
+      end;
+
+    procedure timplementedinterfaces.addintfref(def: pdef);
+      begin
+        finterfaces.insert(new(pimplintfentry,init(pobjectdef(def))));
+      end;
+
+    procedure timplementedinterfaces.addintf(def: pdef);
+      begin
+        if not assigned(def) or (searchintf(def)<>-1) or (def^.deftype<>objectdef) or
+           not (pobjectdef(def)^.objecttype in [odt_interfacecom,odt_interfacecorba]) then
+          internalerror(200006124);
+        finterfaces.insert(new(pimplintfentry,init(pobjectdef(def))));
+      end;
+
+    procedure timplementedinterfaces.clearmappings;
+      var
+        i: longint;
+      begin
+        for i:=1 to count do
+          with pimplintfentry(finterfaces.search(i))^ do
+            begin
+             if assigned(namemappings) then
+               dispose(namemappings,done);
+             namemappings:=nil;
+            end;
+      end;
+
+    procedure timplementedinterfaces.addmappings(intfindex: longint; const name, newname: string);
+      begin
+        checkindex(intfindex);
+        with pimplintfentry(finterfaces.search(intfindex))^ do
+          begin
+            if not assigned(namemappings) then
+              new(namemappings,init);
+            namemappings^.insert(new(pnamemap,init(name,newname)));
+          end;
+      end;
+
+    function  timplementedinterfaces.getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
+      begin
+        checkindex(intfindex);
+        if not assigned(nextexist) then
+          with pimplintfentry(finterfaces.search(intfindex))^ do
+            begin
+              if assigned(namemappings) then
+                nextexist:=namemappings^.search(name)
+              else
+                nextexist:=nil;
+            end;
+        if assigned(nextexist) then
+          begin
+            getmappings:=pnamemap(nextexist)^.newname^;
+            nextexist:=pnamemap(nextexist)^.listnext;
+          end
+        else
+          getmappings:='';
+      end;
+
+    procedure timplementedinterfaces.clearimplprocs;
+      var
+        i: longint;
+      begin
+        for i:=1 to count do
+          with pimplintfentry(finterfaces.search(i))^ do
+            begin
+              if assigned(procdefs) then
+                dispose(procdefs,done);
+              procdefs:=nil;
+            end;
+      end;
+
+    procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: pprocdef);
+      begin
+        checkindex(intfindex);
+        with pimplintfentry(finterfaces.search(intfindex))^ do
+          begin
+            if not assigned(procdefs) then
+              new(procdefs,init(4));
+            procdefs^.insert(new(pprocdefstore,init(procdef)));
+          end;
+      end;
+
+    function  timplementedinterfaces.implproccount(intfindex: longint): longint;
+      begin
+        checkindex(intfindex);
+        with pimplintfentry(finterfaces.search(intfindex))^ do
+          if assigned(procdefs) then
+            implproccount:=procdefs^.count
+          else
+            implproccount:=0;
+      end;
+
+    function  timplementedinterfaces.implprocs(intfindex: longint; procindex: longint): pprocdef;
+      begin
+        checkindex(intfindex);
+        with pimplintfentry(finterfaces.search(intfindex))^ do
+          if assigned(procdefs) then
+            implprocs:=pprocdefstore(procdefs^.search(procindex))^.procdef
+          else
+            internalerror(200006131);
+      end;
+
+    function  timplementedinterfaces.isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
+      var
+        possible: boolean;
+        i: longint;
+        iiep1: pindexarray;
+        iiep2: pindexarray;
+      begin
+        checkindex(intfindex);
+        checkindex(remainindex);
+        iiep1:=pimplintfentry(finterfaces.search(intfindex))^.procdefs;
+        iiep2:=pimplintfentry(finterfaces.search(remainindex))^.procdefs;
+        if not assigned(iiep1) then { empty interface is mergeable :-) }
+          begin
+            possible:=true;
+            weight:=0;
+          end
+        else
+          begin
+            possible:=assigned(iiep2) and (iiep1^.count<=iiep2^.count);
+            i:=1;
+            while (possible) and (i<=iiep1^.count) do
+              begin
+                possible:=
+                  pprocdefstore(iiep1^.search(i))^.procdef=
+                  pprocdefstore(iiep2^.search(i))^.procdef;
+                inc(i);
+              end;
+            if possible then
+              weight:=iiep1^.count;
+          end;
+        isimplmergepossible:=possible;
+      end;
+
+{****************************************************************************
+                                  TERRORDEF
+****************************************************************************}
+
+   constructor terrordef.init;
+     begin
+        inherited init;
+        deftype:=errordef;
+     end;
+
+
+{$ifdef GDB}
+    function terrordef.stabstring : pchar;
+      begin
+         stabstring:=strpnew('error'+numberstring);
+      end;
+{$endif GDB}
+
+    function terrordef.gettypename:string;
+
+      begin
+         gettypename:='<erroneous type>';
+      end;
+
+{
+  $Log$
+  Revision 1.26  2000-11-04 14:25:22  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.25  2000/10/31 22:02:52  peter
+    * symtable splitted, no real code changes
+
+  Revision 1.24  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.23  2000/10/15 07:47:52  peter
+    * unit names and procedure names are stored mixed case
+
+  Revision 1.22  2000/10/14 10:14:52  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.21  2000/10/04 23:16:48  pierre
+   * object stabs fix (merged)
+
+  Revision 1.20  2000/10/01 19:48:25  peter
+    * lot of compile updates for cg11
+
+  Revision 1.19  2000/09/24 21:19:52  peter
+    * delphi compile fixes
+
+  Revision 1.18  2000/09/24 15:06:28  peter
+    * use defines.inc
+
+  Revision 1.17  2000/09/19 23:08:02  pierre
+   * fixes for local class debuggging problem (merged)
+
+  Revision 1.16  2000/09/10 20:13:37  peter
+    * fixed array of const writing instead of array of tvarrec (merged)
+
+  Revision 1.15  2000/09/09 18:36:40  peter
+    * fixed C alignment of array of record (merged)
+
+  Revision 1.14  2000/08/27 20:19:39  peter
+    * store strings with case in ppu, when an internal symbol is created
+      a '$' is prefixed so it's not automatic uppercased
+
+  Revision 1.13  2000/08/27 16:11:53  peter
+    * moved some util functions from globals,cobjects to cutils
+    * splitted files into finput,fmodule
+
+  Revision 1.12  2000/08/21 11:27:44  pierre
+   * fix the stabs problems
+
+  Revision 1.11  2000/08/16 18:33:54  peter
+    * splitted namedobjectitem.next into indexnext and listnext so it
+      can be used in both lists
+    * don't allow "word = word" type definitions (merged)
+
+  Revision 1.10  2000/08/16 13:06:06  florian
+    + support of 64 bit integer constants
+
+  Revision 1.9  2000/08/13 13:06:37  peter
+    * store parast always for procdef (browser needs still update)
+    * add default parameter value to demangledpara
+
+  Revision 1.8  2000/08/08 19:28:57  peter
+    * memdebug/memory patches (merged)
+    * only once illegal directive (merged)
+
+  Revision 1.7  2000/08/06 19:39:28  peter
+    * default parameters working !
+
+  Revision 1.6  2000/08/06 14:17:15  peter
+    * overload fixes (merged)
+
+  Revision 1.5  2000/08/03 13:17:26  jonas
+    + allow regvars to be used inside inlined procs, which required  the
+      following changes:
+        + load regvars in genentrycode/free them in genexitcode (cgai386)
+        * moved all regvar related code to new regvars unit
+        + added pregvarinfo type to hcodegen
+        + added regvarinfo field to tprocinfo (symdef/symdefh)
+        * deallocate the regvars of the caller in secondprocinline before
+          inlining the called procedure and reallocate them afterwards
+
+  Revision 1.4  2000/08/02 19:49:59  peter
+    * first things for default parameters
+
+  Revision 1.3  2000/07/13 12:08:27  michael
+  + patched to 1.1.0 with former 1.09patch from peter
+
+  Revision 1.2  2000/07/13 11:32:49  michael
+  + removed logs
+
+}

compiler/symdef.pas

@@ -197,6 +197,8 @@ interface
 
        pprocdef = ^tprocdef;
 
+       pimplementedinterfaces = ^timplementedinterfaces;
+
        pobjectdef = ^tobjectdef;
        tobjectdef = object(tstoreddef)
           childof  : pobjectdef;
@@ -211,7 +213,14 @@ interface
           classptrglobalnb : word;
           writing_stabs : boolean;
 {$endif GDB}
-          constructor init(const n : string;c : pobjectdef);
+          objecttype : tobjectdeftype;
+          isiidguidvalid: boolean;
+          iidguid: TGUID;
+          iidstr: pstring;
+          lastvtableindex: longint;
+          { store implemented interfaces defs and name mappings }
+          implementedinterfaces: pimplementedinterfaces;
+          constructor init(ot : tobjectdeftype;const n : string;c : pobjectdef);
           constructor load;
           destructor  done;virtual;
           procedure write;virtual;
@@ -225,10 +234,6 @@ interface
           function  rtti_name : string;
           procedure check_forwards;
           function  is_related(d : pobjectdef) : boolean;
-          function  is_class : boolean;
-          function  is_interface : boolean;
-          function  is_cppclass : boolean;
-          function  is_object : boolean;
           function  next_free_name_index : longint;
           procedure insertvmt;
           procedure set_parent(c : pobjectdef);
@@ -253,6 +258,35 @@ interface
           function generate_field_table : pasmlabel;
        end;
 
+       timplementedinterfaces = object
+         constructor init;
+         destructor  done; virtual;
+
+         function  count: longint;
+         function  interfaces(intfindex: longint): pobjectdef;
+         function  ioffsets(intfindex: longint): plongint;
+         function  searchintf(def: pdef): longint;
+         procedure addintf(def: pdef);
+
+         procedure deref;
+         procedure addintfref(def: pdef);
+
+         procedure clearmappings;
+         procedure addmappings(intfindex: longint; const name, newname: string);
+         function  getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
+
+         procedure clearimplprocs;
+         procedure addimplproc(intfindex: longint; procdef: pprocdef);
+         function  implproccount(intfindex: longint): longint;
+         function  implprocs(intfindex: longint; procindex: longint): pprocdef;
+         function  isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
+
+       private
+         finterfaces: tindexarray;
+         procedure checkindex(intfindex: longint);
+       end;
+
+
        pclassrefdef = ^tclassrefdef;
        tclassrefdef = object(tpointerdef)
           constructor init(def : pdef);
@@ -617,6 +651,9 @@ interface
                                   { used for stabs }
 
        class_tobject : pobjectdef;   { pointer to the anchestor of all classes }
+       interface_iunknown : pobjectdef; { KAZ: pointer to the ancestor }
+       rec_tguid : precorddef;          { KAZ: pointer to the TGUID type }
+                                        { of all interfaces            }
        pvmtdef       : ppointerdef;  { type of classrefs }
 
     const
@@ -638,6 +675,15 @@ interface
     function typeglobalnumber(const s : string) : string;
 {$endif GDB}
 
+    { should be in the types unit, but the types unit uses the node stuff :( }
+    function is_interfacecom(def: pdef): boolean;
+    function is_interfacecorba(def: pdef): boolean;
+    function is_interface(def: pdef): boolean;
+    function is_class(def: pdef): boolean;
+    function is_object(def: pdef): boolean;
+    function is_cppclass(def: pdef): boolean;
+    function is_class_or_interface(def: pdef): boolean;
+
     procedure reset_global_defs;
 
 
@@ -2739,8 +2785,8 @@ implementation
             (psym(s)^.typ=varsym) and
             assigned(pvarsym(s)^.vartype.def) then
           begin
-            if ((pvarsym(s)^.vartype.def^.deftype<>objectdef) or
-               not(pobjectdef(pvarsym(s)^.vartype.def)^.is_class)) then
+            if (pvarsym(s)^.vartype.def^.deftype<>objectdef) or
+               not(is_class(pdef(pvarsym(s)^.vartype.def))) then
              binittable:=pvarsym(s)^.vartype.def^.needs_inittable;
           end;
       end;
@@ -2912,8 +2958,8 @@ implementation
       begin
          if ((psym(sym)^.typ=varsym) and
             pvarsym(sym)^.vartype.def^.needs_inittable)
-            and ((pvarsym(sym)^.vartype.def^.deftype<>objectdef) or
-                  (not pobjectdef(pvarsym(sym)^.vartype.def)^.is_class)) then
+            and (pvarsym(sym)^.vartype.def^.deftype<>objectdef) or
+                  not(is_class(pdef(pvarsym(sym)^.vartype.def))) then
            inc(count);
       end;
 
@@ -2929,7 +2975,7 @@ implementation
          if ((psym(sym)^.typ=varsym) and
             pvarsym(sym)^.vartype.def^.needs_inittable) and
             ((pvarsym(sym)^.vartype.def^.deftype<>objectdef) or
-             (not pobjectdef(pvarsym(sym)^.vartype.def)^.is_class)) then
+             not(is_class(pvarsym(sym)^.vartype.def))) then
            begin
               rttilist^.concat(new(pai_const_symbol,init(pstoreddef(pvarsym(sym)^.vartype.def)^.get_inittable_label)));
               rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
@@ -4006,7 +4052,7 @@ Const local_symtable_index : longint = $8001;
        vtableassigned : boolean = false;
 {$endif GDB}
 
-   constructor tobjectdef.init(const n : string;c : pobjectdef);
+   constructor tobjectdef.init(ot : tobjectdeftype;const n : string;c : pobjectdef);
      begin
         inherited init;
         deftype:=objectdef;
@@ -4021,6 +4067,20 @@ Const local_symtable_index : longint = $8001;
         symtable^.dataalignment:=packrecordalignment[aktpackrecords];
         set_parent(c);
         objname:=stringdup(n);
+        lastvtableindex:=0;
+        objecttype:=ot;
+
+        { set up guid }
+        isiidguidvalid:=true; { default null guid }
+        fillchar(iidguid,sizeof(iidguid),0); { default null guid }
+        iidstr:=stringdup(''); { default is empty string }
+
+        { set£p implemented interfaces }
+        if objecttype in [odt_class,odt_interfacecorba] then
+          new(implementedinterfaces,init)
+        else
+          implementedinterfaces:=nil;
+
 {$ifdef GDB}
         writing_stabs:=false;
         classglobalnb:=0;
@@ -4032,9 +4092,11 @@ Const local_symtable_index : longint = $8001;
     constructor tobjectdef.load;
       var
          oldread_member : boolean;
+         i,implintfcount: longint;
       begin
          inherited load;
          deftype:=objectdef;
+         objecttype:=tobjectdeftype(readbyte);
          savesize:=readlong;
          vmt_offset:=readlong;
          objname:=stringdup(readstring);
@@ -4042,6 +4104,31 @@ Const local_symtable_index : longint = $8001;
          readsmallset(objectoptions);
          has_rtti:=boolean(readbyte);
 
+         { load guid }
+         iidstr:=nil;
+         if objecttype in [odt_interfacecom,odt_interfacecorba] then
+           begin
+              isiidguidvalid:=boolean(readbyte);
+              readguid(iidguid);
+              iidstr:=stringdup(readstring);
+              lastvtableindex:=readlong;
+           end;
+
+         { load implemented interfaces }
+         if objecttype in [odt_class,odt_interfacecorba] then
+           begin
+             new(implementedinterfaces,init);
+             implintfcount:=readlong;
+             for i:=1 to implintfcount do
+               begin
+                  implementedinterfaces^.addintfref(pdef(readderef));
+                  implementedinterfaces^.ioffsets(i)^:=readlong;
+               end;
+           end
+         else
+           implementedinterfaces:=nil;
+
+
          oldread_member:=read_member;
          read_member:=true;
          symtable:=new(pstoredsymtable,loadas(objectsymtable));
@@ -4054,9 +4141,12 @@ Const local_symtable_index : longint = $8001;
          { the last TOBJECT which is loaded gets }
          { it !                                  }
          if (childof=nil) and
-            is_class and
+            (objecttype=odt_class) and
             (upper(objname^)='TOBJECT') then
            class_tobject:=@self;
+         if (childof=nil) and (objecttype=odt_interfacecom) and
+           (objname^='IUNKNOWN') then
+           interface_iunknown:=@self;
 {$ifdef GDB}
          writing_stabs:=false;
          classglobalnb:=0;
@@ -4072,6 +4162,9 @@ Const local_symtable_index : longint = $8001;
         if (oo_is_forward in objectoptions) then
           Message1(sym_e_class_forward_not_resolved,objname^);
         stringdispose(objname);
+        stringdispose(iidstr);
+        if assigned(implementedinterfaces) then
+          dispose(implementedinterfaces,done);
         inherited done;
      end;
 
@@ -4079,14 +4172,36 @@ Const local_symtable_index : longint = $8001;
     procedure tobjectdef.write;
       var
          oldread_member : boolean;
+         implintfcount : longint;
+         i : longint;
       begin
          inherited write;
+         writebyte(byte(objecttype));
          writelong(size);
          writelong(vmt_offset);
          writestring(objname^);
          writederef(childof);
          writesmallset(objectoptions);
          writebyte(byte(has_rtti));
+         if objecttype in [odt_interfacecom,odt_interfacecorba] then
+           begin
+              writebyte(byte(isiidguidvalid));
+              writeguid(iidguid);
+              writestring(iidstr^);
+              writelong(lastvtableindex);
+           end;
+
+         if objecttype in [odt_class,odt_interfacecorba] then
+           begin
+              implintfcount:=implementedinterfaces^.count;
+              writelong(implintfcount);
+              for i:=1 to implintfcount do
+                begin
+                   writederef(implementedinterfaces^.interfaces(i));
+                   writelong(implementedinterfaces^.ioffsets(i)^);
+                end;
+           end;
+
          current_ppu^.writeentry(ibobjectdef);
 
          oldread_member:=read_member;
@@ -4114,6 +4229,8 @@ Const local_symtable_index : longint = $8001;
          aktrecordsymtable:=symtable;
          pstoredsymtable(symtable)^.deref;
          aktrecordsymtable:=oldrecsyms;
+         if objecttype in [odt_class,odt_interfacecorba] then
+           implementedinterfaces^.deref;
       end;
 
 
@@ -4126,19 +4243,24 @@ Const local_symtable_index : longint = $8001;
         { some options are inherited !! }
         if assigned(c) then
           begin
+             { only important for classes }
+             lastvtableindex:=c^.lastvtableindex;
              objectoptions:=objectoptions+(c^.objectoptions*
                [oo_has_virtual,oo_has_private,oo_has_protected,oo_has_constructor,oo_has_destructor]);
-             { add the data of the anchestor class }
-             inc(symtable^.datasize,c^.symtable^.datasize);
-             if (oo_has_vmt in objectoptions) and
-                (oo_has_vmt in c^.objectoptions) then
-               dec(symtable^.datasize,target_os.size_of_pointer);
-             { if parent has a vmt field then
-               the offset is the same for the child PM }
-             if (oo_has_vmt in c^.objectoptions) or is_class then
+             if not (objecttype in [odt_interfacecom,odt_interfacecorba]) then
                begin
-                  vmt_offset:=c^.vmt_offset;
-                  include(objectoptions,oo_has_vmt);
+                  { add the data of the anchestor class }
+                  inc(symtable^.datasize,c^.symtable^.datasize);
+                  if (oo_has_vmt in objectoptions) and
+                     (oo_has_vmt in c^.objectoptions) then
+                    dec(symtable^.datasize,target_os.size_of_pointer);
+                  { if parent has a vmt field then
+                    the offset is the same for the child PM }
+                  if (oo_has_vmt in c^.objectoptions) or is_class(@self) then
+                    begin
+                       vmt_offset:=c^.vmt_offset;
+                       include(objectoptions,oo_has_vmt);
+                    end;
                end;
           end;
         savesize := symtable^.datasize;
@@ -4147,6 +4269,7 @@ Const local_symtable_index : longint = $8001;
 
    procedure tobjectdef.insertvmt;
      begin
+        if objecttype in [odt_interfacecom,odt_interfacecorba] then exit;
         if (oo_has_vmt in objectoptions) then
           internalerror(12345)
         else
@@ -4172,6 +4295,7 @@ Const local_symtable_index : longint = $8001;
 
    procedure tobjectdef.check_forwards;
      begin
+        if objecttype in [odt_interfacecom,odt_interfacecorba] then exit; { Kaz: ??? }
         pstoredsymtable(symtable)^.check_forwards;
         if (oo_is_forward in objectoptions) then
           begin
@@ -4250,7 +4374,7 @@ Const local_symtable_index : longint = $8001;
 
     function tobjectdef.size : longint;
       begin
-        if (oo_is_class in objectoptions) then
+        if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba] then
           size:=target_os.size_of_pointer
         else
           size:=symtable^.datasize;
@@ -4266,8 +4390,8 @@ Const local_symtable_index : longint = $8001;
     function tobjectdef.vmtmethodoffset(index:longint):longint;
       begin
         { for offset of methods for classes, see rtl/inc/objpash.inc }
-        if is_class then
-         vmtmethodoffset:=(index+12)*target_os.size_of_pointer
+        if objecttype in [odt_interfacecom,odt_interfacecorba] then
+          vmtmethodoffset:=(index+12)*target_os.size_of_pointer
         else
 {$ifdef WITHDMT}
          vmtmethodoffset:=(index+4)*target_os.size_of_pointer;
@@ -4314,27 +4438,6 @@ Const local_symtable_index : longint = $8001;
     end;
 
 
-    function tobjectdef.is_class : boolean;
-      begin
-         is_class:=(oo_is_class in objectoptions);
-      end;
-
-    function tobjectdef.is_object : boolean;
-      begin
-         is_object:=([oo_is_class,oo_is_interface,oo_is_cppclass]*
-           objectoptions)=[];
-      end;
-
-    function tobjectdef.is_interface : boolean;
-      begin
-         is_interface:=(oo_is_interface in objectoptions);
-      end;
-
-    function tobjectdef.is_cppclass : boolean;
-      begin
-         is_cppclass:=(oo_is_cppclass in objectoptions);
-      end;
-
 {$ifdef GDB}
     procedure addprocname(p :pnamedindexobject);
     var virtualind,argnames : string;
@@ -4434,7 +4537,7 @@ Const local_symtable_index : longint = $8001;
           storenb, oldrecsize : longint;
           str_end : string;
       begin
-        if not (is_class) or writing_stabs then
+        if not (objecttype=odt_class) or writing_stabs then
           begin
             storenb:=globalnb;
             globalnb:=classptrglobalnb;
@@ -4488,7 +4591,7 @@ Const local_symtable_index : longint = $8001;
          globalnb:=classglobalnb;
          inc(PglobalTypeCount^);
          { classes need two type numbers, the globalnb is set to the ptr }
-         if is_class then
+         if objecttype=odt_class then
            begin
              classptrglobalnb:=PGlobalTypeCount^;
              globalnb:=classptrglobalnb;
@@ -4502,7 +4605,7 @@ Const local_symtable_index : longint = $8001;
      begin
        if globalnb=0 then
          numberstring;
-       if is_class then
+       if objecttype=odt_class then
          begin
            onb:=globalnb;
            globalnb:=classglobalnb;
@@ -4519,7 +4622,7 @@ Const local_symtable_index : longint = $8001;
      begin
        if globalnb=0 then
          numberstring;
-       if is_class then
+       if objecttype=odt_class then
          begin
            onb:=globalnb;
            globalnb:=classptrglobalnb;
@@ -4533,7 +4636,7 @@ Const local_symtable_index : longint = $8001;
     procedure tobjectdef.concatstabto(asmlist : paasmoutput);
       var st : pstring;
       begin
-        if not(is_class) then
+        if objecttype<>odt_class then
           begin
             inherited concatstabto(asmlist);
             exit;
@@ -4576,10 +4679,18 @@ Const local_symtable_index : longint = $8001;
 
     procedure tobjectdef.write_init_data;
       begin
-         if is_class then
-           rttilist^.concat(new(pai_const,init_8bit(tkclass)))
-         else
-           rttilist^.concat(new(pai_const,init_8bit(tkobject)));
+         case objecttype of
+            odt_class:
+              rttilist^.concat(new(pai_const,init_8bit(tkclass)));
+            odt_object:
+              rttilist^.concat(new(pai_const,init_8bit(tkobject)));
+            odt_interfacecom:
+              rttilist^.concat(new(pai_const,init_8bit(tkinterface)));
+            odt_interfacecorba:
+              rttilist^.concat(new(pai_const,init_8bit(tkinterfaceCorba)));
+          else
+            exit;
+          end;
 
          { generate the name }
          rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
@@ -4587,9 +4698,15 @@ Const local_symtable_index : longint = $8001;
 
          rttilist^.concat(new(pai_const,init_32bit(size)));
          count:=0;
-         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}count_inittable_fields);
-         rttilist^.concat(new(pai_const,init_32bit(count)));
-         symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_inittable);
+         if objecttype in [odt_interfacecom,odt_interfacecorba] then
+           begin
+           end
+         else
+           begin
+              symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}count_inittable_fields);
+              rttilist^.concat(new(pai_const,init_32bit(count)));
+              symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}write_field_inittable);
+           end;
       end;
 
 
@@ -4597,20 +4714,22 @@ Const local_symtable_index : longint = $8001;
       var
          oldb : boolean;
       begin
-         if is_class then
-           needs_inittable:=false
-         else
-           begin
-              { there are recursive calls to needs_inittable possible, }
-              { so we have to change to old value how else should      }
-              { we do that ? check_rec_rtti can't be a nested          }
-              { procedure of needs_rtti !                              }
-              oldb:=binittable;
-              binittable:=false;
-              symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}check_rec_inittable);
-              needs_inittable:=binittable;
-              binittable:=oldb;
-           end;
+         case objecttype of
+            odt_interfacecom: needs_inittable:=true;
+            odt_object:
+              begin
+                 { there are recursive calls to needs_inittable possible, }
+                 { so we have to change to old value how else should      }
+                 { we do that ? check_rec_rtti can't be a nested          }
+                 { procedure of needs_rtti !                              }
+                 oldb:=binittable;
+                 binittable:=false;
+                 symtable^.foreach({$ifdef FPCPROCVAR}@{$endif}check_rec_inittable);
+                 needs_inittable:=binittable;
+                 binittable:=oldb;
+              end;
+            else needs_inittable:=false;
+         end;
       end;
 
 
@@ -4880,17 +4999,24 @@ Const local_symtable_index : longint = $8001;
 
     procedure tobjectdef.write_rtti_data;
       begin
-         if is_class then
-           rttilist^.concat(new(pai_const,init_8bit(tkclass)))
+         case objecttype of
+           odt_class: rttilist^.concat(new(pai_const,init_8bit(tkclass)));
+           odt_object: rttilist^.concat(new(pai_const,init_8bit(tkobject)));
+           odt_interfacecom: rttilist^.concat(new(pai_const,init_8bit(tkinterface)));
+           odt_interfacecorba: rttilist^.concat(new(pai_const,init_8bit(tkinterfaceCorba)));
          else
-           rttilist^.concat(new(pai_const,init_8bit(tkobject)));
+           exit;
+         end;
+
 
          { generate the name }
          rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
          rttilist^.concat(new(pai_string,init(objname^)));
 
-         { write class type }
-         rttilist^.concat(new(pai_const_symbol,initname(vmt_mangledname)));
+         if objecttype in [odt_interfacecom,odt_interfacecorba] then
+           rttilist^.concat(new(pai_const,init_32bit(0)))
+         else
+           rttilist^.concat(new(pai_const_symbol,initname(vmt_mangledname)));
 
          { write owner typeinfo }
          if assigned(childof) and (oo_can_have_published in childof^.objectoptions) then
@@ -4932,7 +5058,7 @@ Const local_symtable_index : longint = $8001;
 
     function tobjectdef.is_publishable : boolean;
       begin
-         is_publishable:=is_class;
+         is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
       end;
 
     function  tobjectdef.get_rtti_label : string;
@@ -4942,6 +5068,262 @@ Const local_symtable_index : longint = $8001;
          get_rtti_label:=rtti_name;
       end;
 
+{****************************************************************************
+                             TIMPLEMENTEDINTERFACES
+****************************************************************************}
+    type
+      pnamemap = ^tnamemap;
+      tnamemap = object(tnamedindexobject)
+        newname: pstring;
+        constructor init(const aname, anewname: string);
+        destructor  done; virtual;
+      end;
+
+    constructor tnamemap.init(const aname, anewname: string);
+      begin
+        inherited initname(name);
+        newname:=stringdup(anewname);
+      end;
+
+    destructor  tnamemap.done;
+      begin
+        stringdispose(newname);
+        inherited done;
+      end;
+
+
+    type
+      pprocdefstore = ^tprocdefstore;
+      tprocdefstore = object(tnamedindexobject)
+        procdef: pprocdef;
+        constructor init(aprocdef: pprocdef);
+      end;
+
+    constructor tprocdefstore.init(aprocdef: pprocdef);
+      begin
+        inherited init;
+        procdef:=aprocdef;
+      end;
+
+
+    type
+      pimplintfentry = ^timplintfentry;
+      timplintfentry = object(tnamedindexobject)
+        intf: pobjectdef;
+        ioffs: longint;
+        namemappings: pdictionary;
+        procdefs: pindexarray;
+        constructor init(aintf: pobjectdef);
+        destructor  done; virtual;
+      end;
+
+    constructor timplintfentry.init(aintf: pobjectdef);
+      begin
+        inherited init;
+        intf:=aintf;
+        ioffs:=-1;
+        namemappings:=nil;
+        procdefs:=nil;
+      end;
+
+    destructor  timplintfentry.done;
+      begin
+        if assigned(namemappings) then
+          dispose(namemappings,done);
+        if assigned(procdefs) then
+          dispose(procdefs,done);
+        inherited done;
+      end;
+
+
+    constructor timplementedinterfaces.init;
+      begin
+        finterfaces.init(1);
+      end;
+
+    destructor  timplementedinterfaces.done;
+      begin
+        finterfaces.done;
+      end;
+
+    function  timplementedinterfaces.count: longint;
+      begin
+        count:=finterfaces.count;
+      end;
+
+    procedure timplementedinterfaces.checkindex(intfindex: longint);
+      begin
+        if (intfindex<1) or (intfindex>count) then
+          InternalError(200006123);
+      end;
+
+    function  timplementedinterfaces.interfaces(intfindex: longint): pobjectdef;
+      begin
+        checkindex(intfindex);
+        interfaces:=pimplintfentry(finterfaces.search(intfindex))^.intf;
+      end;
+
+    function  timplementedinterfaces.ioffsets(intfindex: longint): plongint;
+      begin
+        checkindex(intfindex);
+        ioffsets:=@pimplintfentry(finterfaces.search(intfindex))^.ioffs;
+      end;
+
+    function  timplementedinterfaces.searchintf(def: pdef): longint;
+      var
+        i: longint;
+      begin
+        i:=1;
+        while (i<=count) and (pdef(interfaces(i))<>def) do inc(i);
+        if i<=count then
+          searchintf:=i
+        else
+          searchintf:=-1;
+      end;
+
+    procedure timplementedinterfaces.deref;
+      var
+        i: longint;
+      begin
+        for i:=1 to count do
+          with pimplintfentry(finterfaces.search(i))^ do
+            resolvedef(pdef(intf));
+      end;
+
+    procedure timplementedinterfaces.addintfref(def: pdef);
+      begin
+        finterfaces.insert(new(pimplintfentry,init(pobjectdef(def))));
+      end;
+
+    procedure timplementedinterfaces.addintf(def: pdef);
+      begin
+        if not assigned(def) or (searchintf(def)<>-1) or (def^.deftype<>objectdef) or
+           not (pobjectdef(def)^.objecttype in [odt_interfacecom,odt_interfacecorba]) then
+          internalerror(200006124);
+        finterfaces.insert(new(pimplintfentry,init(pobjectdef(def))));
+      end;
+
+    procedure timplementedinterfaces.clearmappings;
+      var
+        i: longint;
+      begin
+        for i:=1 to count do
+          with pimplintfentry(finterfaces.search(i))^ do
+            begin
+             if assigned(namemappings) then
+               dispose(namemappings,done);
+             namemappings:=nil;
+            end;
+      end;
+
+    procedure timplementedinterfaces.addmappings(intfindex: longint; const name, newname: string);
+      begin
+        checkindex(intfindex);
+        with pimplintfentry(finterfaces.search(intfindex))^ do
+          begin
+            if not assigned(namemappings) then
+              new(namemappings,init);
+            namemappings^.insert(new(pnamemap,init(name,newname)));
+          end;
+      end;
+
+    function  timplementedinterfaces.getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
+      begin
+        checkindex(intfindex);
+        if not assigned(nextexist) then
+          with pimplintfentry(finterfaces.search(intfindex))^ do
+            begin
+              if assigned(namemappings) then
+                nextexist:=namemappings^.search(name)
+              else
+                nextexist:=nil;
+            end;
+        if assigned(nextexist) then
+          begin
+            getmappings:=pnamemap(nextexist)^.newname^;
+            nextexist:=pnamemap(nextexist)^.listnext;
+          end
+        else
+          getmappings:='';
+      end;
+
+    procedure timplementedinterfaces.clearimplprocs;
+      var
+        i: longint;
+      begin
+        for i:=1 to count do
+          with pimplintfentry(finterfaces.search(i))^ do
+            begin
+              if assigned(procdefs) then
+                dispose(procdefs,done);
+              procdefs:=nil;
+            end;
+      end;
+
+    procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: pprocdef);
+      begin
+        checkindex(intfindex);
+        with pimplintfentry(finterfaces.search(intfindex))^ do
+          begin
+            if not assigned(procdefs) then
+              new(procdefs,init(4));
+            procdefs^.insert(new(pprocdefstore,init(procdef)));
+          end;
+      end;
+
+    function  timplementedinterfaces.implproccount(intfindex: longint): longint;
+      begin
+        checkindex(intfindex);
+        with pimplintfentry(finterfaces.search(intfindex))^ do
+          if assigned(procdefs) then
+            implproccount:=procdefs^.count
+          else
+            implproccount:=0;
+      end;
+
+    function  timplementedinterfaces.implprocs(intfindex: longint; procindex: longint): pprocdef;
+      begin
+        checkindex(intfindex);
+        with pimplintfentry(finterfaces.search(intfindex))^ do
+          if assigned(procdefs) then
+            implprocs:=pprocdefstore(procdefs^.search(procindex))^.procdef
+          else
+            internalerror(200006131);
+      end;
+
+    function  timplementedinterfaces.isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
+      var
+        possible: boolean;
+        i: longint;
+        iiep1: pindexarray;
+        iiep2: pindexarray;
+      begin
+        checkindex(intfindex);
+        checkindex(remainindex);
+        iiep1:=pimplintfentry(finterfaces.search(intfindex))^.procdefs;
+        iiep2:=pimplintfentry(finterfaces.search(remainindex))^.procdefs;
+        if not assigned(iiep1) then { empty interface is mergeable :-) }
+          begin
+            possible:=true;
+            weight:=0;
+          end
+        else
+          begin
+            possible:=assigned(iiep2) and (iiep1^.count<=iiep2^.count);
+            i:=1;
+            while (possible) and (i<=iiep1^.count) do
+              begin
+                possible:=
+                  pprocdefstore(iiep1^.search(i))^.procdef=
+                  pprocdefstore(iiep2^.search(i))^.procdef;
+                inc(i);
+              end;
+            if possible then
+              weight:=iiep1^.count;
+          end;
+        isimplmergepossible:=possible;
+      end;
+
 {****************************************************************************
                                 TFORWARDDEF
 ****************************************************************************}
@@ -5078,10 +5460,70 @@ Const local_symtable_index : longint = $8001;
           end;
      end;
 
+    function is_interfacecom(def: pdef): boolean;
+      begin
+        is_interfacecom:=
+          assigned(def) and
+          (def^.deftype=objectdef) and
+          (pobjectdef(def)^.objecttype=odt_interfacecom);
+      end;
+
+    function is_interfacecorba(def: pdef): boolean;
+      begin
+        is_interfacecorba:=
+          assigned(def) and
+          (def^.deftype=objectdef) and
+          (pobjectdef(def)^.objecttype=odt_interfacecorba);
+      end;
+
+    function is_interface(def: pdef): boolean;
+      begin
+        is_interface:=
+          assigned(def) and
+          (def^.deftype=objectdef) and
+          (pobjectdef(def)^.objecttype in [odt_interfacecom,odt_interfacecorba]);
+      end;
+
+
+    function is_class(def: pdef): boolean;
+      begin
+        is_class:=
+          assigned(def) and
+          (def^.deftype=objectdef) and
+          (pobjectdef(def)^.objecttype=odt_class);
+      end;
+
+    function is_object(def: pdef): boolean;
+      begin
+        is_object:=
+          assigned(def) and
+          (def^.deftype=objectdef) and
+          (pobjectdef(def)^.objecttype=odt_class);
+      end;
+
+    function is_cppclass(def: pdef): boolean;
+      begin
+        is_cppclass:=
+          assigned(def) and
+          (def^.deftype=objectdef) and
+          (pobjectdef(def)^.objecttype=odt_cppclass);
+      end;
+
+    function is_class_or_interface(def: pdef): boolean;
+      begin
+        is_class_or_interface:=
+          assigned(def) and
+          (def^.deftype=objectdef) and
+          (pobjectdef(def)^.objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
+      end;
+
 end.
 {
   $Log$
-  Revision 1.3  2000-11-02 12:04:10  pierre
+  Revision 1.4  2000-11-04 14:25:22  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.3  2000/11/02 12:04:10  pierre
   * remove RecOffset code, that created problems
 
   Revision 1.2  2000/11/01 23:04:38  peter

compiler/symdefh.inc

@@ -0,0 +1,654 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
+
+    Interface for the definition types of the symtable
+
+    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.
+ ****************************************************************************
+}
+
+{************************************************
+                    TDef
+************************************************}
+
+       tdef = object(tsymtableentry)
+          deftype    : tdeftype;
+          typesym    : ptypesym;  { which type the definition was generated this def }
+
+          has_inittable : boolean;
+          { adress of init informations }
+          inittable_label : pasmlabel;
+
+          has_rtti   : boolean;
+          { address of rtti }
+          rtti_label : pasmlabel;
+
+          nextglobal,
+          previousglobal : pdef;
+{$ifdef GDB}
+          globalnb       : word;
+          is_def_stab_written : tdefstabstatus;
+{$endif GDB}
+          constructor init;
+          constructor load;
+          destructor  done;virtual;
+          procedure deref;virtual;
+          function  typename:string;
+          procedure write;virtual;
+          function  size:longint;virtual;
+          function  alignment:longint;virtual;
+          function  gettypename:string;virtual;
+          function  is_publishable : boolean;virtual;
+          function  is_in_current : boolean;
+          procedure correct_owner_symtable; { registers enumdef inside objects or
+                                              record directly in the owner symtable !! }
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+          function  NumberString:string;
+          procedure set_globalnb;virtual;
+          function  allstabstring : pchar;
+{$endif GDB}
+          { init. tables }
+          function  needs_inittable : boolean;virtual;
+          procedure generate_inittable;
+          function  get_inittable_label : pasmlabel;
+          { the default implemenation calls write_rtti_data     }
+          { if init and rtti data is different these procedures }
+          { must be overloaded                                  }
+          procedure write_init_data;virtual;
+          procedure write_child_init_data;virtual;
+          { rtti }
+          procedure write_rtti_name;
+          function  get_rtti_label : string;virtual;
+          procedure generate_rtti;virtual;
+          procedure write_rtti_data;virtual;
+          procedure write_child_rtti_data;virtual;
+          function is_intregable : boolean;
+          function is_fpuregable : boolean;
+       private
+          savesize  : longint;
+       end;
+
+       targconvtyp = (act_convertable,act_equal,act_exact);
+
+       tvarspez = (vs_value,vs_const,vs_var,vs_out);
+
+       pparaitem = ^tparaitem;
+       tparaitem = object(tlinkedlist_item)
+          paratype     : ttype;
+          paratyp      : tvarspez;
+          argconvtyp   : targconvtyp;
+          convertlevel : byte;
+          register     : tregister;
+          defaultvalue : psym; { pconstsym }
+       end;
+
+       { this is only here to override the count method,
+         which can't be used }
+       pparalinkedlist = ^tparalinkedlist;
+       tparalinkedlist = object(tlinkedlist)
+          function count:longint;
+       end;
+
+       tfiletyp = (ft_text,ft_typed,ft_untyped);
+
+       pfiledef = ^tfiledef;
+       tfiledef = object(tdef)
+          filetyp : tfiletyp;
+          typedfiletype : ttype;
+          constructor inittext;
+          constructor inituntyped;
+          constructor inittyped(const tt : ttype);
+          constructor inittypeddef(p : pdef);
+          constructor load;
+          procedure write;virtual;
+          procedure deref;virtual;
+          function  gettypename:string;virtual;
+          procedure setsize;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+       end;
+
+       pformaldef = ^tformaldef;
+       tformaldef = object(tdef)
+          constructor init;
+          constructor load;
+          procedure write;virtual;
+          function  gettypename:string;virtual;
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+       end;
+
+       pforwarddef = ^tforwarddef;
+       tforwarddef = object(tdef)
+          tosymname : string;
+          forwardpos : tfileposinfo;
+          constructor init(const s:string;const pos : tfileposinfo);
+          function  gettypename:string;virtual;
+       end;
+
+       perrordef = ^terrordef;
+       terrordef = object(tdef)
+          constructor init;
+          function  gettypename:string;virtual;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+{$endif GDB}
+       end;
+
+       { tpointerdef and tclassrefdef should get a common
+         base class, but I derived tclassrefdef from tpointerdef
+         to avoid problems with bugs (FK)
+       }
+
+       ppointerdef = ^tpointerdef;
+       tpointerdef = object(tdef)
+          pointertype : ttype;
+          is_far : boolean;
+          constructor init(const tt : ttype);
+          constructor initfar(const tt : ttype);
+          constructor initdef(p : pdef);
+          constructor initfardef(p : pdef);
+          constructor load;
+          destructor  done;virtual;
+          procedure write;virtual;
+          procedure deref;virtual;
+          function  gettypename:string;virtual;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+          {private}
+          public
+            { I don't know the use of this FK }
+            pointertypeis_forwarddef: boolean;
+       end;
+
+       pprocdef = ^tprocdef;
+       pimplementedinterfaces = ^timplementedinterfaces;
+
+       pobjectdef = ^tobjectdef;
+       tobjectdef = object(tdef)
+          childof  : pobjectdef;
+          objname  : pstring;
+          symtable : psymtable;
+          objectoptions : tobjectoptions;
+          { to be able to have a variable vmt position }
+          { and no vmt field for objects without virtuals }
+          vmt_offset : longint;
+{$ifdef GDB}
+          classglobalnb,
+          classptrglobalnb : word;
+          writing_stabs : boolean;
+{$endif GDB}
+          objecttype : tobjectdeftype;
+          isiidguidvalid: boolean;
+          iidguid: TGUID;
+          iidstr: pstring;
+          lastvtableindex: longint;
+          { store implemented interfaces defs and name mappings }
+          implementedinterfaces: pimplementedinterfaces;
+
+          constructor init(odt : tobjectdeftype; const n : string;c : pobjectdef);
+          constructor load;
+          destructor  done;virtual;
+          procedure write;virtual;
+          procedure deref;virtual;
+          function  size : longint;virtual;
+          function  alignment:longint;virtual;
+          function  vmtmethodoffset(index:longint):longint;
+          function  is_publishable : boolean;virtual;
+          function  vmt_mangledname : string;
+          function  rtti_name : string;
+          procedure check_forwards;
+          function  is_related(d : pobjectdef) : boolean;
+          function  next_free_name_index : longint;
+          procedure insertvmt;
+          procedure set_parent(c : pobjectdef);
+          function searchdestructor : pprocdef;
+          { debug }
+{$ifdef GDB}
+          function stabstring : pchar;virtual;
+          procedure set_globalnb;virtual;
+          function  classnumberstring : string;
+          function  classptrnumberstring : string;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+          { init/final }
+          function  needs_inittable : boolean;virtual;
+          procedure write_init_data;virtual;
+          procedure write_child_init_data;virtual;
+          { rtti }
+          function  get_rtti_label : string;virtual;
+          procedure generate_rtti;virtual;
+          procedure write_rtti_data;virtual;
+          procedure write_child_rtti_data;virtual;
+          function generate_field_table : pasmlabel;
+       end;
+
+       timplementedinterfaces = object
+         constructor init;
+         destructor  done; virtual;
+
+         function  count: longint;
+         function  interfaces(intfindex: longint): pobjectdef;
+         function  ioffsets(intfindex: longint): plongint;
+         function  searchintf(def: pdef): longint;
+         procedure addintf(def: pdef);
+
+         procedure deref;
+         procedure addintfref(def: pdef);
+
+         procedure clearmappings;
+         procedure addmappings(intfindex: longint; const name, newname: string);
+         function  getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
+
+         procedure clearimplprocs;
+         procedure addimplproc(intfindex: longint; procdef: pprocdef);
+         function  implproccount(intfindex: longint): longint;
+         function  implprocs(intfindex: longint; procindex: longint): pprocdef;
+         function  isimplmergepossible(intfindex, remainindex: longint; var weight: longint): boolean;
+
+       private
+         finterfaces: tindexarray;
+         procedure checkindex(intfindex: longint);
+       end;
+
+
+       pclassrefdef = ^tclassrefdef;
+       tclassrefdef = object(tpointerdef)
+          constructor init(def : pdef);
+          constructor load;
+          procedure write;virtual;
+          function gettypename:string;virtual;
+          { debug }
+{$ifdef GDB}
+          function stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+       end;
+
+       parraydef = ^tarraydef;
+       tarraydef = object(tdef)
+       private
+          rangenr    : longint;
+       public
+          lowrange,
+          highrange  : longint;
+          elementtype,
+          rangetype  : ttype;
+          IsDynamicArray,
+          IsVariant,
+          IsConstructor,
+          IsArrayOfConst : boolean;
+          function gettypename:string;virtual;
+          function elesize : longint;
+          constructor init(l,h : longint;rd : pdef);
+          constructor load;
+          procedure write;virtual;
+{$ifdef GDB}
+          function stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+          procedure deref;virtual;
+          function size : longint;virtual;
+          function alignment : longint;virtual;
+          { generates the ranges needed by the asm instruction BOUND (i386)
+            or CMP2 (Motorola) }
+          procedure genrangecheck;
+
+          { returns the label of the range check string }
+          function getrangecheckstring : string;
+          function needs_inittable : boolean;virtual;
+          procedure write_rtti_data;virtual;
+          procedure write_child_rtti_data;virtual;
+       end;
+
+       precorddef = ^trecorddef;
+       trecorddef = object(tdef)
+          symtable : psymtable;
+          constructor init(p : psymtable);
+          constructor load;
+          destructor done;virtual;
+          procedure write;virtual;
+          procedure deref;virtual;
+          function  size:longint;virtual;
+          function  alignment : longint;virtual;
+          function  gettypename:string;virtual;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+          { init/final }
+          procedure write_init_data;virtual;
+          procedure write_child_init_data;virtual;
+          function  needs_inittable : boolean;virtual;
+          { rtti }
+          procedure write_rtti_data;virtual;
+          procedure write_child_rtti_data;virtual;
+       end;
+
+       porddef = ^torddef;
+       torddef = object(tdef)
+        private
+          rangenr  : longint;
+        public
+          low,high : longint;
+          typ      : tbasetype;
+          constructor init(t : tbasetype;v,b : longint);
+          constructor load;
+          procedure write;virtual;
+          function  is_publishable : boolean;virtual;
+          function  gettypename:string;virtual;
+          procedure setsize;
+          { generates the ranges needed by the asm instruction BOUND }
+          { or CMP2 (Motorola)                                       }
+          procedure genrangecheck;
+          function  getrangecheckstring : string;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+{$endif GDB}
+          { rtti }
+          procedure write_rtti_data;virtual;
+       end;
+
+       pfloatdef = ^tfloatdef;
+       tfloatdef = object(tdef)
+          typ : tfloattype;
+          constructor init(t : tfloattype);
+          constructor load;
+          procedure write;virtual;
+          function  gettypename:string;virtual;
+          function  is_publishable : boolean;virtual;
+          procedure setsize;
+          { debug }
+{$ifdef GDB}
+          function stabstring : pchar;virtual;
+{$endif GDB}
+          { rtti }
+          procedure write_rtti_data;virtual;
+       end;
+
+       pabstractprocdef = ^tabstractprocdef;
+       tabstractprocdef = object(tdef)
+          { saves a definition to the return type }
+          rettype         : ttype;
+          proctypeoption  : tproctypeoption;
+          proccalloptions : tproccalloptions;
+          procoptions     : tprocoptions;
+          para            : pparalinkedlist;
+          maxparacount,
+          minparacount    : longint;
+          symtablelevel   : byte;
+          fpu_used        : byte;    { how many stack fpu must be empty }
+          constructor init;
+          constructor load;
+          destructor done;virtual;
+          procedure  write;virtual;
+          procedure deref;virtual;
+          procedure concatpara(tt:ttype;vsp : tvarspez;defval:psym);
+          function  para_size(alignsize:longint) : longint;
+          function  demangled_paras : string;
+          function  proccalloption2str : string;
+          procedure test_if_fpu_result;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+       end;
+
+       pprocvardef = ^tprocvardef;
+       tprocvardef = object(tabstractprocdef)
+          constructor init;
+          constructor load;
+          procedure write;virtual;
+          function  size : longint;virtual;
+          function gettypename:string;virtual;
+          function is_publishable : boolean;virtual;
+          { debug }
+{$ifdef GDB}
+          function stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput); virtual;
+{$endif GDB}
+          { rtti }
+          procedure write_child_rtti_data;virtual;
+          procedure write_rtti_data;virtual;
+       end;
+
+       tmessageinf = record
+         case integer of
+           0 : (str : pchar);
+           1 : (i : longint);
+       end;
+
+       tprocdef = object(tabstractprocdef)
+       private
+          _mangledname : pstring;
+       public
+          extnumber  : longint;
+          messageinf : tmessageinf;
+          nextoverloaded : pprocdef;
+          { where is this function defined, needed here because there
+            is only one symbol for all overloaded functions }
+          fileinfo : tfileposinfo;
+          { pointer to the local symbol table }
+          localst : psymtable;
+          { pointer to the parameter symbol table }
+          parast : psymtable;
+          { symbol owning this definition }
+          procsym : pprocsym;
+          { browser info }
+          lastref,
+          defref,
+          crossref,
+          lastwritten : pref;
+          refcount : longint;
+          _class : pobjectdef;
+          { it's a tree, but this not easy to handle }
+          { used for inlined procs                   }
+          code : pointer;
+          { info about register variables (JM) }
+          regvarinfo: pointer;
+          { true, if the procedure is only declared }
+          { (forward procedure) }
+          forwarddef,
+          { true if the procedure is declared in the interface }
+          interfacedef : boolean;
+          { true if the procedure has a forward declaration }
+          hasforward : boolean;
+          { check the problems of manglednames }
+          count      : boolean;
+          is_used    : boolean;
+          { small set which contains the modified registers }
+{$ifdef newcg}
+          usedregisters : tregisterset;
+{$else newcg}
+          usedregisters : longint;
+{$endif newcg}
+          constructor init;
+          constructor load;
+          destructor  done;virtual;
+          procedure write;virtual;
+          procedure deref;virtual;
+          function  haspara:boolean;
+          function  mangledname : string;
+          procedure setmangledname(const s : string);
+          procedure load_references;
+          function  write_references : boolean;
+{$ifdef dummy}
+          function  procname: string;
+{$endif dummy}
+          function  cplusplusmangledname : string;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+          { browser }
+{$ifdef BrowserLog}
+          procedure add_to_browserlog;
+{$endif BrowserLog}
+       end;
+
+       pstringdef = ^tstringdef;
+       tstringdef = object(tdef)
+          string_typ : tstringtype;
+          len        : longint;
+          constructor shortinit(l : byte);
+          constructor shortload;
+          constructor longinit(l : longint);
+          constructor longload;
+          constructor ansiinit(l : longint);
+          constructor ansiload;
+          constructor wideinit(l : longint);
+          constructor wideload;
+          function  stringtypname:string;
+          function  size : longint;virtual;
+          procedure write;virtual;
+          function  gettypename:string;virtual;
+          function  is_publishable : boolean;virtual;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+          { init/final }
+          function  needs_inittable : boolean;virtual;
+          { rtti }
+          procedure write_rtti_data;virtual;
+       end;
+
+       penumdef = ^tenumdef;
+       tenumdef = object(tdef)
+          rangenr,
+          minval,
+          maxval    : longint;
+          has_jumps : boolean;
+          firstenum : penumsym;
+          basedef   : penumdef;
+          constructor init;
+          constructor init_subrange(_basedef:penumdef;_min,_max:longint);
+          constructor load;
+          destructor done;virtual;
+          procedure write;virtual;
+          procedure deref;virtual;
+          function  gettypename:string;virtual;
+          function  is_publishable : boolean;virtual;
+          procedure calcsavesize;
+          procedure setmax(_max:longint);
+          procedure setmin(_min:longint);
+          function  min:longint;
+          function  max:longint;
+          function  getrangecheckstring:string;
+          procedure genrangecheck;
+          { debug }
+{$ifdef GDB}
+          function stabstring : pchar;virtual;
+{$endif GDB}
+          { rtti }
+          procedure write_child_rtti_data;virtual;
+          procedure write_rtti_data;virtual;
+       end;
+
+       psetdef = ^tsetdef;
+       tsetdef = object(tdef)
+          elementtype : ttype;
+          settype : tsettype;
+          constructor init(s : pdef;high : longint);
+          constructor load;
+          destructor  done;virtual;
+          procedure write;virtual;
+          procedure deref;virtual;
+          function  gettypename:string;virtual;
+          function  is_publishable : boolean;virtual;
+          { debug }
+{$ifdef GDB}
+          function  stabstring : pchar;virtual;
+          procedure concatstabto(asmlist : paasmoutput);virtual;
+{$endif GDB}
+          { rtti }
+          procedure write_rtti_data;virtual;
+          procedure write_child_rtti_data;virtual;
+       end;
+
+{
+  $Log$
+  Revision 1.15  2000-11-04 14:25:22  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.14  2000/10/31 22:02:52  peter
+    * symtable splitted, no real code changes
+
+  Revision 1.13  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.12  2000/10/15 07:47:52  peter
+    * unit names and procedure names are stored mixed case
+
+  Revision 1.11  2000/10/14 10:14:53  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.10  2000/09/24 15:06:29  peter
+    * use defines.inc
+
+  Revision 1.9  2000/09/19 23:08:03  pierre
+   * fixes for local class debuggging problem (merged)
+
+  Revision 1.8  2000/08/21 11:27:44  pierre
+   * fix the stabs problems
+
+  Revision 1.7  2000/08/06 19:39:28  peter
+    * default parameters working !
+
+  Revision 1.6  2000/08/06 14:17:15  peter
+    * overload fixes (merged)
+
+  Revision 1.5  2000/08/03 13:17:26  jonas
+    + allow regvars to be used inside inlined procs, which required  the
+      following changes:
+        + load regvars in genentrycode/free them in genexitcode (cgai386)
+        * moved all regvar related code to new regvars unit
+        + added pregvarinfo type to hcodegen
+        + added regvarinfo field to tprocinfo (symdef/symdefh)
+        * deallocate the regvars of the caller in secondprocinline before
+          inlining the called procedure and reallocate them afterwards
+
+  Revision 1.4  2000/08/02 19:49:59  peter
+    * first things for default parameters
+
+  Revision 1.3  2000/07/13 12:08:27  michael
+  + patched to 1.1.0 with former 1.09patch from peter
+
+  Revision 1.2  2000/07/13 11:32:49  michael
+  + removed logs
+
+}

compiler/symppu.inc

@@ -0,0 +1,782 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
+
+    Implementation of the reading of PPU Files for the symtable
+
+    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.
+ ****************************************************************************
+}
+
+    const
+{$ifdef FPC}
+       ppubufsize=32768;
+{$ELSE}
+    {$IFDEF USEOVERLAY}
+       ppubufsize=512;
+    {$ELSE}
+       ppubufsize=4096;
+    {$ENDIF}
+{$ENDIF}
+
+{$define ORDERSOURCES}
+
+{*****************************************************************************
+                                 PPU Writing
+*****************************************************************************}
+
+    procedure writebyte(b:byte);
+      begin
+        current_ppu^.putbyte(b);
+      end;
+
+
+    procedure writeword(w:word);
+      begin
+        current_ppu^.putword(w);
+      end;
+
+
+    procedure writelong(l:longint);
+      begin
+        current_ppu^.putlongint(l);
+      end;
+
+
+    procedure writereal(d:bestreal);
+      begin
+        current_ppu^.putreal(d);
+      end;
+
+
+    procedure writestring(const s:string);
+      begin
+        current_ppu^.putstring(s);
+      end;
+
+
+    procedure writenormalset(var s); {You cannot pass an array[0..31] of byte!}
+      begin
+        current_ppu^.putdata(s,sizeof(tnormalset));
+      end;
+
+
+    procedure writesmallset(var s; size: longint);
+      var
+        tmpl: longint;
+      begin
+        { The minimum size of a set under Delphi isn't 32 bit }
+        { this is only binary compatible with FPC if first element's value of the set is 0 }
+        tmpl:=0; move(s,tmpl,size);
+        current_ppu^.putdata(tmpl,4);
+        {old code: current_ppu^.putdata(s,4);}
+      end;
+
+    procedure writeguid(var g: tguid);
+      begin
+        current_ppu^.putdata(g,sizeof(g));
+      end;
+
+    { posinfo is not relevant for changes in PPU }
+    procedure writeposinfo(const p:tfileposinfo);
+      var
+        oldcrc : boolean;
+      begin
+        oldcrc:=current_ppu^.do_crc;
+        current_ppu^.do_crc:=false;
+        current_ppu^.putword(p.fileindex);
+        current_ppu^.putlongint(p.line);
+        current_ppu^.putword(p.column);
+        current_ppu^.do_crc:=oldcrc;
+      end;
+
+
+    procedure writederef(p : psymtableentry);
+      begin
+        if p=nil then
+         current_ppu^.putbyte(ord(derefnil))
+        else
+         begin
+           { Static symtable ? }
+           if p^.owner^.symtabletype=staticsymtable then
+            begin
+              current_ppu^.putbyte(ord(derefaktstaticindex));
+              current_ppu^.putword(p^.indexnr);
+            end
+           { Local record/object symtable ? }
+           else if (p^.owner=aktrecordsymtable) then
+            begin
+              current_ppu^.putbyte(ord(derefaktrecordindex));
+              current_ppu^.putword(p^.indexnr);
+            end
+           { Local local/para symtable ? }
+           else if (p^.owner=aktlocalsymtable) then
+            begin
+              current_ppu^.putbyte(ord(derefaktlocal));
+              current_ppu^.putword(p^.indexnr);
+            end
+           else
+            begin
+              current_ppu^.putbyte(ord(derefindex));
+              current_ppu^.putword(p^.indexnr);
+           { Current unit symtable ? }
+              repeat
+                if not assigned(p) then
+                 internalerror(556655);
+                case p^.owner^.symtabletype of
+                 { when writing the pseudo PPU file
+                   to get CRC values the globalsymtable is not yet
+                   a unitsymtable PM }
+                  globalsymtable,
+                  unitsymtable :
+                    begin
+                      { check if the unit is available in the uses
+                        clause, else it's an error }
+                      if p^.owner^.unitid=$ffff then
+                       internalerror(55665566);
+                      current_ppu^.putbyte(ord(derefunit));
+                      current_ppu^.putword(p^.owner^.unitid);
+                      break;
+                    end;
+                  staticsymtable :
+                    begin
+                      current_ppu^.putbyte(ord(derefaktstaticindex));
+                      current_ppu^.putword(p^.indexnr);
+                      break;
+                    end;
+                  localsymtable :
+                    begin
+                      p:=p^.owner^.defowner;
+                      current_ppu^.putbyte(ord(dereflocal));
+                      current_ppu^.putword(p^.indexnr);
+                    end;
+                  parasymtable :
+                    begin
+                      p:=p^.owner^.defowner;
+                      current_ppu^.putbyte(ord(derefpara));
+                      current_ppu^.putword(p^.indexnr);
+                    end;
+                  objectsymtable,
+                  recordsymtable :
+                    begin
+                      p:=p^.owner^.defowner;
+                      current_ppu^.putbyte(ord(derefrecord));
+                      current_ppu^.putword(p^.indexnr);
+                    end;
+                  else
+                    internalerror(556656);
+                end;
+              until false;
+            end;
+         end;
+      end;
+
+    procedure writedefref(p : pdef);
+      begin
+        writederef(p);
+      end;
+
+    procedure writesymref(p : psym);
+      begin
+        writederef(p);
+      end;
+
+    procedure writesourcefiles;
+      var
+        hp    : pinputfile;
+{$ifdef ORDERSOURCES}
+        i,j : longint;
+{$endif ORDERSOURCES}
+      begin
+      { second write the used source files }
+        current_ppu^.do_crc:=false;
+        hp:=current_module^.sourcefiles^.files;
+{$ifdef ORDERSOURCES}
+      { write source files directly in good order }
+        j:=0;
+        while assigned(hp) do
+          begin
+            inc(j);
+            hp:=hp^.ref_next;
+          end;
+        while j>0 do
+          begin
+            hp:=current_module^.sourcefiles^.files;
+            for i:=1 to j-1 do
+              hp:=hp^.ref_next;
+            current_ppu^.putstring(hp^.name^);
+            dec(j);
+         end;
+{$else not ORDERSOURCES}
+        while assigned(hp) do
+         begin
+         { only name and extension }
+           current_ppu^.putstring(hp^.name^);
+           hp:=hp^.ref_next;
+         end;
+{$endif ORDERSOURCES}
+        current_ppu^.writeentry(ibsourcefiles);
+        current_ppu^.do_crc:=true;
+      end;
+
+    procedure writeusedmacros;
+      var
+        hp    : pmacrosym;
+        i     : longint;
+      begin
+      { second write the used source files }
+        current_ppu^.do_crc:=false;
+        for i:=1 to macros^.symindex^.count do
+         begin
+           hp:=pmacrosym(macros^.symindex^.search(i));
+         { only used or init defined macros are stored }
+           if hp^.is_used or hp^.defined_at_startup then
+             begin
+               current_ppu^.putstring(hp^.name);
+               current_ppu^.putbyte(byte(hp^.defined_at_startup));
+               current_ppu^.putbyte(byte(hp^.is_used));
+             end;
+         end;
+        current_ppu^.writeentry(ibusedmacros);
+        current_ppu^.do_crc:=true;
+      end;
+
+
+    procedure writeusedunit;
+      var
+        hp      : pused_unit;
+      begin
+        numberunits;
+        hp:=pused_unit(current_module^.used_units.first);
+        while assigned(hp) do
+         begin
+           { implementation units should not change
+             the CRC PM }
+           current_ppu^.do_crc:=hp^.in_interface;
+           current_ppu^.putstring(hp^.name^);
+           { the checksum should not affect the crc of this unit ! (PFV) }
+           current_ppu^.do_crc:=false;
+           current_ppu^.putlongint(hp^.checksum);
+           current_ppu^.putlongint(hp^.interface_checksum);
+           current_ppu^.putbyte(byte(hp^.in_interface));
+           current_ppu^.do_crc:=true;
+           hp:=pused_unit(hp^.next);
+         end;
+        current_ppu^.do_interface_crc:=true;
+        current_ppu^.writeentry(ibloadunit);
+      end;
+
+
+    procedure writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
+      var
+        hcontainer : tlinkcontainer;
+        s : string;
+        mask : longint;
+      begin
+        hcontainer.init;
+        while not p.empty do
+         begin
+           s:=p.get(mask);
+           if strippath then
+            current_ppu^.putstring(SplitFileName(s))
+           else
+            current_ppu^.putstring(s);
+           current_ppu^.putlongint(mask);
+           hcontainer.insert(s,mask);
+         end;
+        current_ppu^.writeentry(id);
+        p:=hcontainer;
+      end;
+
+
+    procedure writeunitas(const s : string;unittable : punitsymtable;only_crc : boolean);
+      begin
+         Message1(unit_u_ppu_write,s);
+
+       { create unit flags }
+         with Current_Module^ do
+          begin
+{$ifdef GDB}
+            if cs_gdb_dbx in aktglobalswitches then
+             flags:=flags or uf_has_dbx;
+{$endif GDB}
+            if target_os.endian=endian_big then
+             flags:=flags or uf_big_endian;
+            if cs_browser in aktmoduleswitches then
+             flags:=flags or uf_has_browser;
+            if cs_local_browser in aktmoduleswitches then
+             flags:=flags or uf_local_browser;
+          end;
+
+{$ifdef Test_Double_checksum_write}
+        If only_crc then
+          Assign(CRCFile,s+'.INT')
+        else
+          Assign(CRCFile,s+'.IMP');
+        Rewrite(CRCFile);
+{$endif def Test_Double_checksum_write}
+       { open ppufile }
+         current_ppu:=new(pppufile,init(s));
+         current_ppu^.crc_only:=only_crc;
+         if not current_ppu^.create then
+           Message(unit_f_ppu_cannot_write);
+
+{$ifdef Test_Double_checksum}
+         if only_crc then
+           begin
+              new(current_ppu^.crc_test);
+              new(current_ppu^.crc_test2);
+           end
+         else
+           begin
+             current_ppu^.crc_test:=Current_Module^.crc_array;
+             current_ppu^.crc_index:=Current_Module^.crc_size;
+             current_ppu^.crc_test2:=Current_Module^.crc_array2;
+             current_ppu^.crc_index2:=Current_Module^.crc_size2;
+           end;
+{$endif def Test_Double_checksum}
+
+         current_ppu^.change_endian:=source_os.endian<>target_os.endian;
+       { write symbols and definitions }
+         unittable^.writeasunit;
+
+       { flush to be sure }
+         current_ppu^.flush;
+       { create and write header }
+         current_ppu^.header.size:=current_ppu^.size;
+         current_ppu^.header.checksum:=current_ppu^.crc;
+         current_ppu^.header.interface_checksum:=current_ppu^.interface_crc;
+         current_ppu^.header.compiler:=wordversion;
+         current_ppu^.header.cpu:=word(target_cpu);
+         current_ppu^.header.target:=word(target_info.target);
+         current_ppu^.header.flags:=current_module^.flags;
+         If not only_crc then
+           current_ppu^.writeheader;
+       { save crc in current_module also }
+         current_module^.crc:=current_ppu^.crc;
+         current_module^.interface_crc:=current_ppu^.interface_crc;
+         if only_crc then
+          begin
+{$ifdef Test_Double_checksum}
+            Current_Module^.crc_array:=current_ppu^.crc_test;
+            current_ppu^.crc_test:=nil;
+            Current_Module^.crc_size:=current_ppu^.crc_index2;
+            Current_Module^.crc_array2:=current_ppu^.crc_test2;
+            current_ppu^.crc_test2:=nil;
+            Current_Module^.crc_size2:=current_ppu^.crc_index2;
+{$endif def Test_Double_checksum}
+            closecurrentppu;
+          end;
+{$ifdef Test_Double_checksum_write}
+        close(CRCFile);
+{$endif Test_Double_checksum_write}
+      end;
+
+
+    procedure closecurrentppu;
+      begin
+{$ifdef Test_Double_checksum}
+         if assigned(current_ppu^.crc_test) then
+           dispose(current_ppu^.crc_test);
+         if assigned(current_ppu^.crc_test2) then
+           dispose(current_ppu^.crc_test2);
+{$endif Test_Double_checksum}
+       { close }
+         current_ppu^.close;
+         dispose(current_ppu,done);
+         current_ppu:=nil;
+      end;
+
+
+{*****************************************************************************
+                                 PPU Reading
+*****************************************************************************}
+
+    function readbyte:byte;
+      begin
+        readbyte:=current_ppu^.getbyte;
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
+
+    function readword:word;
+      begin
+        readword:=current_ppu^.getword;
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
+
+    function readlong:longint;
+      begin
+        readlong:=current_ppu^.getlongint;
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
+
+    function readreal : bestreal;
+      begin
+        readreal:=current_ppu^.getreal;
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
+
+    function readstring : string;
+      begin
+        readstring:=current_ppu^.getstring;
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
+
+    procedure readnormalset(var s);   {You cannot pass an array [0..31] of byte.}
+      begin
+        current_ppu^.getdata(s,sizeof(tnormalset));
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
+
+    procedure readsmallset(var s;size: longint);
+      var
+        tmpl: longint;
+      begin
+        { The minimum size of a set under Delphi isn't 32 bit }
+        { this is only binary compatible if first element's value of the set is 0 }
+        current_ppu^.getdata(tmpl,4);
+        move(tmpl,s,size);
+        {old code: current_ppu^.getdata(s,4); }
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
+
+    procedure readguid(var g: tguid);
+      begin
+        current_ppu^.getdata(g,sizeof(g));
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
+    procedure readposinfo(var p:tfileposinfo);
+      begin
+        p.fileindex:=current_ppu^.getword;
+        p.line:=current_ppu^.getlongint;
+        p.column:=current_ppu^.getword;
+      end;
+
+
+    function readderef : pderef;
+      var
+        hp,p : pderef;
+        b : tdereftype;
+      begin
+        p:=nil;
+        repeat
+          hp:=p;
+          b:=tdereftype(current_ppu^.getbyte);
+          case b of
+            derefnil :
+              break;
+            derefunit,
+            derefaktrecordindex,
+            derefaktlocal,
+            derefaktstaticindex :
+              begin
+                new(p,init(b,current_ppu^.getword));
+                p^.next:=hp;
+                break;
+              end;
+            derefindex,
+            dereflocal,
+            derefpara,
+            derefrecord :
+              begin
+                new(p,init(b,current_ppu^.getword));
+                p^.next:=hp;
+              end;
+          end;
+        until false;
+        readderef:=p;
+      end;
+
+    function readdefref : pdef;
+      begin
+        readdefref:=pdef(readderef);
+      end;
+
+    function readsymref : psym;
+      begin
+        readsymref:=psym(readderef);
+      end;
+
+    procedure readusedmacros;
+      var
+        hs : string;
+        mac : pmacrosym;
+        was_defined_at_startup,
+        was_used : boolean;
+      begin
+        while not current_ppu^.endofentry do
+         begin
+           hs:=current_ppu^.getstring;
+           was_defined_at_startup:=boolean(current_ppu^.getbyte);
+           was_used:=boolean(current_ppu^.getbyte);
+           mac:=pmacrosym(macros^.search(hs));
+           if assigned(mac) then
+             begin
+{$ifndef EXTDEBUG}
+           { if we don't have the sources why tell }
+              if current_module^.sources_avail then
+{$endif ndef EXTDEBUG}
+               if (not was_defined_at_startup) and
+                  was_used and
+                  mac^.defined_at_startup then
+                Message2(unit_h_cond_not_set_in_last_compile,hs,current_module^.mainsource^);
+             end
+           else { not assigned }
+             if was_defined_at_startup and
+                was_used then
+              Message2(unit_h_cond_not_set_in_last_compile,hs,current_module^.mainsource^);
+         end;
+      end;
+
+    procedure readsourcefiles;
+      var
+        temp,hs       : string;
+        temp_dir      : string;
+{$ifdef ORDERSOURCES}
+        main_dir      : string;
+{$endif ORDERSOURCES}
+        incfile_found,
+        main_found,
+        is_main       : boolean;
+        ppufiletime,
+        source_time   : longint;
+        hp            : pinputfile;
+      begin
+        ppufiletime:=getnamedfiletime(current_module^.ppufilename^);
+        current_module^.sources_avail:=true;
+{$ifdef ORDERSOURCES}
+        is_main:=true;
+        main_dir:='';
+{$endif ORDERSOURCES}
+        while not current_ppu^.endofentry do
+         begin
+           hs:=current_ppu^.getstring;
+{$ifndef ORDERSOURCES}
+           is_main:=current_ppu^.endofentry;
+{$endif ORDERSOURCES}
+           temp_dir:='';
+           if (current_module^.flags and uf_in_library)<>0 then
+            begin
+              current_module^.sources_avail:=false;
+              temp:=' library';
+            end
+           else if pos('Macro ',hs)=1 then
+            begin
+              { we don't want to find this file }
+              { but there is a problem with file indexing !! }
+              temp:='';
+            end
+           else
+            begin
+              { check the date of the source files }
+              Source_Time:=GetNamedFileTime(current_module^.path^+hs);
+              incfile_found:=false;
+              main_found:=false;
+              if Source_Time<>-1 then
+                hs:=current_module^.path^+hs
+{$ifdef ORDERSOURCES}
+              else if not(is_main) then
+                begin
+                  Source_Time:=GetNamedFileTime(main_dir+hs);
+                  if Source_Time<>-1 then
+                    hs:=main_dir+hs;
+                end
+{$endif def ORDERSOURCES}
+                   ;
+              if (Source_Time=-1) then
+                begin
+                  if is_main then
+                    temp_dir:=unitsearchpath.FindFile(hs,main_found)
+                  else
+                    temp_dir:=includesearchpath.FindFile(hs,incfile_found);
+                  if incfile_found or main_found then
+                   begin
+                     hs:=temp_dir+hs;
+                     Source_Time:=GetNamedFileTime(hs);
+                   end
+                end;
+              if Source_Time=-1 then
+               begin
+                 current_module^.sources_avail:=false;
+                 temp:=' not found';
+               end
+              else
+               begin
+                 if main_found then
+                   main_dir:=temp_dir;
+                 { time newer? But only allow if the file is not searched
+                   in the include path (PFV), else you've problems with
+                   units which use the same includefile names }
+                 if incfile_found then
+                  temp:=' found'
+                 else
+                  begin
+                    temp:=' time '+filetimestring(source_time);
+                    if (source_time>ppufiletime) then
+                     begin
+                       current_module^.do_compile:=true;
+                       current_module^.recompile_reason:=rr_sourcenewer;
+                       temp:=temp+' *'
+                     end;
+                  end;
+               end;
+              new(hp,init(hs));
+              { the indexing is wrong here PM }
+              current_module^.sourcefiles^.register_file(hp);
+            end;
+{$ifdef ORDERSOURCES}
+           if is_main then
+             begin
+               stringdispose(current_module^.mainsource);
+               current_module^.mainsource:=stringdup(hs);
+             end;
+{$endif ORDERSOURCES}
+           Message1(unit_u_ppu_source,hs+temp);
+{$ifdef ORDERSOURCES}
+           is_main:=false;
+{$endif ORDERSOURCES}
+         end;
+{$ifndef ORDERSOURCES}
+      { main source is always the last }
+        stringdispose(current_module^.mainsource);
+        current_module^.mainsource:=stringdup(hs);
+
+        { the indexing is corrected here PM }
+        current_module^.sourcefiles^.inverse_register_indexes;
+{$endif ORDERSOURCES}
+      { check if we want to rebuild every unit, only if the sources are
+        available }
+        if do_build and current_module^.sources_avail then
+          begin
+             current_module^.do_compile:=true;
+             current_module^.recompile_reason:=rr_build;
+          end;
+      end;
+
+
+    procedure readloadunit;
+      var
+        hs : string;
+        intfchecksum,
+        checksum : longint;
+        in_interface : boolean;
+      begin
+        while not current_ppu^.endofentry do
+         begin
+           hs:=current_ppu^.getstring;
+           checksum:=current_ppu^.getlongint;
+           intfchecksum:=current_ppu^.getlongint;
+           in_interface:=(current_ppu^.getbyte<>0);
+           current_module^.used_units.concat(new(pused_unit,init_to_load(hs,checksum,intfchecksum,in_interface)));
+         end;
+      end;
+
+
+    procedure readlinkcontainer(var p:tlinkcontainer);
+      var
+        s : string;
+        m : longint;
+      begin
+        while not current_ppu^.endofentry do
+         begin
+           s:=current_ppu^.getstring;
+           m:=current_ppu^.getlongint;
+           p.insert(s,m);
+         end;
+      end;
+
+
+    procedure load_interface;
+      var
+        b : byte;
+        newmodulename : string;
+      begin
+       { read interface part }
+         repeat
+           b:=current_ppu^.readentry;
+           case b of
+             ibmodulename :
+               begin
+                 newmodulename:=current_ppu^.getstring;
+                 if upper(newmodulename)<>current_module^.modulename^ then
+                   Message2(unit_f_unit_name_error,current_module^.realmodulename^,newmodulename);
+                 stringdispose(current_module^.modulename);
+                 stringdispose(current_module^.realmodulename);
+                 current_module^.modulename:=stringdup(upper(newmodulename));
+                 current_module^.realmodulename:=stringdup(newmodulename);
+               end;
+             ibsourcefiles :
+               readsourcefiles;
+             ibusedmacros :
+               readusedmacros;
+             ibloadunit :
+               readloadunit;
+             iblinkunitofiles :
+               readlinkcontainer(current_module^.LinkUnitOFiles);
+             iblinkunitstaticlibs :
+               readlinkcontainer(current_module^.LinkUnitStaticLibs);
+             iblinkunitsharedlibs :
+               readlinkcontainer(current_module^.LinkUnitSharedLibs);
+             iblinkotherofiles :
+               readlinkcontainer(current_module^.LinkotherOFiles);
+             iblinkotherstaticlibs :
+               readlinkcontainer(current_module^.LinkotherStaticLibs);
+             iblinkothersharedlibs :
+               readlinkcontainer(current_module^.LinkotherSharedLibs);
+             ibendinterface :
+               break;
+           else
+             Message1(unit_f_ppu_invalid_entry,tostr(b));
+           end;
+         until false;
+      end;
+
+{
+  $Log$
+  Revision 1.7  2000-11-04 14:25:22  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.6  2000/10/31 22:02:52  peter
+    * symtable splitted, no real code changes
+
+  Revision 1.5  2000/10/15 07:47:53  peter
+    * unit names and procedure names are stored mixed case
+
+  Revision 1.4  2000/09/24 21:33:47  peter
+    * message updates merges
+
+  Revision 1.3  2000/09/21 20:56:19  pierre
+   * fix for bugs 1084/1128 (merged)
+
+  Revision 1.2  2000/07/13 11:32:49  michael
+  + removed logs
+
+}

compiler/symppu.pas

@@ -38,6 +38,7 @@ interface
     procedure writestring(const s:string);
     procedure writenormalset(var s); {You cannot pass an array[0..31] of byte!}
     procedure writesmallset(var s);
+    procedure writeguid(var g: tguid);
     procedure writeposinfo(const p:tfileposinfo);
     procedure writederef(p : psymtableentry);
 
@@ -48,6 +49,7 @@ interface
     function readstring : string;
     procedure readnormalset(var s);   {You cannot pass an array [0..31] of byte.}
     procedure readsmallset(var s);
+    procedure readguid(var g: tguid);
     procedure readposinfo(var p:tfileposinfo);
     function readderef : psymtableentry;
 
@@ -57,6 +59,7 @@ interface
 implementation
 
     uses
+       globals,
        symconst,
        verbose,
        finput,scanner,
@@ -122,6 +125,11 @@ implementation
       end;
 
 
+    procedure writeguid(var g: tguid);
+      begin
+        current_ppu^.putdata(g,sizeof(g));
+      end;
+
     procedure writederef(p : psymtableentry);
       begin
         if p=nil then
@@ -277,6 +285,13 @@ implementation
       end;
 
 
+    procedure readguid(var g: tguid);
+      begin
+        current_ppu^.getdata(g,sizeof(g));
+        if current_ppu^.error then
+         Message(unit_f_ppu_read_error);
+      end;
+
     procedure readposinfo(var p:tfileposinfo);
       begin
         p.fileindex:=current_ppu^.getword;
@@ -322,7 +337,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.1  2000-10-31 22:02:52  peter
+  Revision 1.2  2000-11-04 14:25:22  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.1  2000/10/31 22:02:52  peter
     * symtable splitted, no real code changes
 
 }

compiler/symsym.inc

@@ -0,0 +1,2260 @@
+{
+    $Id$
+    Copyright (c) 1998-2000 by Florian Klaempfl, Pierre Muller
+
+    Implementation for the symbols types of the symtable
+
+    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.
+ ****************************************************************************
+}
+
+{****************************************************************************
+                          TSYM (base for all symtypes)
+****************************************************************************}
+
+    constructor tsym.init(const n : string);
+      begin
+         if n[1]='$' then
+          inherited initname(copy(n,2,255))
+         else
+          inherited initname(upper(n));
+         _realname:=stringdup(n);
+         typ:=abstractsym;
+         symoptions:=current_object_option;
+{$ifdef GDB}
+         isstabwritten := false;
+{$endif GDB}
+         fileinfo:=tokenpos;
+         defref:=nil;
+         refs:=0;
+         lastwritten:=nil;
+         refcount:=0;
+         if (cs_browser in aktmoduleswitches) and make_ref then
+          begin
+            defref:=new(pref,init(defref,@tokenpos));
+            inc(refcount);
+          end;
+         lastref:=defref;
+      end;
+
+
+    constructor tsym.load;
+      begin
+         inherited init;
+         indexnr:=readword;
+         _realname:=stringdup(readstring);
+         if _realname^[1]='$' then
+          setname(copy(_realname^,2,255))
+         else
+          setname(upper(_realname^));
+         typ:=abstractsym;
+         readsmallset(symoptions,sizeof(symoptions));
+         readposinfo(fileinfo);
+         lastref:=nil;
+         defref:=nil;
+         refs:=0;
+         lastwritten:=nil;
+         refcount:=0;
+{$ifdef GDB}
+         isstabwritten := false;
+{$endif GDB}
+      end;
+
+
+    procedure tsym.load_references;
+      var
+        pos : tfileposinfo;
+        move_last : boolean;
+      begin
+        move_last:=lastwritten=lastref;
+        while (not current_ppu^.endofentry) do
+         begin
+           readposinfo(pos);
+           inc(refcount);
+           lastref:=new(pref,init(lastref,@pos));
+           lastref^.is_written:=true;
+           if refcount=1 then
+            defref:=lastref;
+         end;
+        if move_last then
+          lastwritten:=lastref;
+      end;
+
+    { big problem here :
+      wrong refs were written because of
+      interface parsing of other units PM
+      moduleindex must be checked !! }
+
+    function tsym.write_references : boolean;
+      var
+        ref   : pref;
+        symref_written,move_last : boolean;
+      begin
+        write_references:=false;
+        if lastwritten=lastref then
+          exit;
+      { should we update lastref }
+        move_last:=true;
+        symref_written:=false;
+      { write symbol refs }
+        if assigned(lastwritten) then
+          ref:=lastwritten
+        else
+          ref:=defref;
+        while assigned(ref) do
+         begin
+           if ref^.moduleindex=current_module^.unit_index then
+             begin
+              { write address to this symbol }
+                if not symref_written then
+                  begin
+                     writesymref(@self);
+                     symref_written:=true;
+                  end;
+                writeposinfo(ref^.posinfo);
+                ref^.is_written:=true;
+                if move_last then
+                  lastwritten:=ref;
+             end
+           else if not ref^.is_written then
+             move_last:=false
+           else if move_last then
+             lastwritten:=ref;
+           ref:=ref^.nextref;
+         end;
+        if symref_written then
+          current_ppu^.writeentry(ibsymref);
+        write_references:=symref_written;
+      end;
+
+
+{$ifdef BrowserLog}
+    procedure tsym.add_to_browserlog;
+      begin
+        if assigned(defref) then
+         begin
+           browserlog.AddLog('***'+name+'***');
+           browserlog.AddLogRefs(defref);
+         end;
+      end;
+{$endif BrowserLog}
+
+
+    destructor tsym.done;
+      begin
+        if assigned(defref) then
+         begin
+           defref^.freechain;
+           dispose(defref,done);
+         end;
+        stringdispose(_realname);
+        inherited done;
+      end;
+
+
+    procedure tsym.write;
+      begin
+         writeword(indexnr);
+         writestring(_realname^);
+         writesmallset(symoptions,sizeof(symoptions));
+         writeposinfo(fileinfo);
+      end;
+
+
+    procedure tsym.prederef;
+      begin
+      end;
+
+
+    procedure tsym.deref;
+      begin
+      end;
+
+
+    function tsym.realname : string;
+      begin
+        if assigned(_realname) then
+         realname:=_realname^
+        else
+         realname:=name;
+      end;
+
+
+    function tsym.mangledname : string;
+      begin
+         mangledname:=name;
+      end;
+
+
+    { for most symbol types there is nothing to do at all }
+    procedure tsym.insert_in_data;
+      begin
+      end;
+
+
+{$ifdef GDB}
+    function tsym.stabstring : pchar;
+
+      begin
+         stabstring:=strpnew('"'+name+'",'+tostr(N_LSYM)+',0,'+
+           tostr(fileinfo.line)+',0');
+      end;
+
+    procedure tsym.concatstabto(asmlist : paasmoutput);
+
+    var stab_str : pchar;
+      begin
+         if not isstabwritten then
+           begin
+              stab_str := stabstring;
+              { count_dbx(stab_str); moved to GDB.PAS }
+              asmlist^.concat(new(pai_stabs,init(stab_str)));
+              isstabwritten:=true;
+          end;
+    end;
+{$endif GDB}
+
+
+{****************************************************************************
+                                 TLABELSYM
+****************************************************************************}
+
+    constructor tlabelsym.init(const n : string; l : pasmlabel);
+
+      begin
+         inherited init(n);
+         typ:=labelsym;
+         lab:=l;
+         used:=false;
+         defined:=false;
+         code:=nil;
+      end;
+
+    constructor tlabelsym.load;
+
+      begin
+         tsym.load;
+         typ:=labelsym;
+         { this is all dummy
+           it is only used for local browsing }
+         lab:=nil;
+         code:=nil;
+         used:=false;
+         defined:=true;
+      end;
+
+    destructor tlabelsym.done;
+
+      begin
+         inherited done;
+      end;
+
+
+    function tlabelsym.mangledname : string;
+      begin
+         mangledname:=lab^.name;
+      end;
+
+
+    procedure tlabelsym.write;
+      begin
+         if owner^.symtabletype in [unitsymtable,globalsymtable] then
+           Message(sym_e_ill_label_decl)
+         else
+           begin
+              tsym.write;
+              current_ppu^.writeentry(iblabelsym);
+           end;
+      end;
+
+
+{****************************************************************************
+                                  TUNITSYM
+****************************************************************************}
+
+    constructor tunitsym.init(const n : string;ref : punitsymtable);
+      var
+        old_make_ref : boolean;
+      begin
+         old_make_ref:=make_ref;
+         make_ref:=false;
+         inherited init(n);
+         make_ref:=old_make_ref;
+         typ:=unitsym;
+         unitsymtable:=ref;
+         prevsym:=ref^.unitsym;
+         ref^.unitsym:=@self;
+         refs:=0;
+      end;
+
+    constructor tunitsym.load;
+
+      begin
+         tsym.load;
+         typ:=unitsym;
+         unitsymtable:=punitsymtable(current_module^.globalsymtable);
+         prevsym:=nil;
+      end;
+
+    { we need to remove it from the prevsym chain ! }
+
+    procedure tunitsym.restoreunitsym;
+      var pus,ppus : punitsym;
+      begin
+         if assigned(unitsymtable) then
+           begin
+             ppus:=nil;
+             pus:=unitsymtable^.unitsym;
+             if pus=@self then
+               unitsymtable^.unitsym:=prevsym
+             else while assigned(pus) do
+               begin
+                  if pus=@self then
+                    begin
+                       ppus^.prevsym:=prevsym;
+                       break;
+                    end
+                  else
+                    begin
+                       ppus:=pus;
+                       pus:=ppus^.prevsym;
+                    end;
+               end;
+           end;
+         prevsym:=nil;
+      end;
+
+    destructor tunitsym.done;
+      begin
+         restoreunitsym;
+         inherited done;
+      end;
+
+    procedure tunitsym.write;
+      begin
+         tsym.write;
+         current_ppu^.writeentry(ibunitsym);
+      end;
+
+{$ifdef GDB}
+    procedure tunitsym.concatstabto(asmlist : paasmoutput);
+      begin
+      {Nothing to write to stabs !}
+      end;
+{$endif GDB}
+
+{****************************************************************************
+                                  TPROCSYM
+****************************************************************************}
+
+    constructor tprocsym.init(const n : string);
+
+      begin
+         tsym.init(n);
+         typ:=procsym;
+         definition:=nil;
+         owner:=nil;
+         is_global := false;
+      end;
+
+    constructor tprocsym.load;
+
+      begin
+         tsym.load;
+         typ:=procsym;
+         definition:=pprocdef(readdefref);
+         is_global := false;
+      end;
+
+    destructor tprocsym.done;
+
+      begin
+         { don't check if errors !! }
+         if Errorcount=0 then
+           check_forward;
+         tsym.done;
+      end;
+
+    function tprocsym.mangledname : string;
+
+      begin
+         mangledname:=definition^.mangledname;
+      end;
+
+
+    function tprocsym.declarationstr(p : pprocdef):string;
+      begin
+        declarationstr:=realname+p^.demangled_paras;
+      end;
+
+
+    procedure tprocsym.write_parameter_lists(skipdef:pprocdef);
+      var
+         p : pprocdef;
+      begin
+         p:=definition;
+         while assigned(p) do
+           begin
+              if p<>skipdef then
+                MessagePos1(p^.fileinfo,sym_b_param_list,name+p^.demangled_paras);
+              p:=p^.nextoverloaded;
+           end;
+      end;
+
+
+    procedure tprocsym.check_forward;
+      var
+         pd : pprocdef;
+      begin
+         pd:=definition;
+         while assigned(pd) do
+           begin
+              if pd^.forwarddef then
+                begin
+                   if assigned(pd^._class) then
+                     MessagePos1(fileinfo,sym_e_forward_not_resolved,pd^._class^.objname^+'.'+declarationstr(pd))
+                   else
+                     MessagePos1(fileinfo,sym_e_forward_not_resolved,declarationstr(pd));
+                   { Turn futher error messages off }
+                   pd^.forwarddef:=false;
+                end;
+              pd:=pd^.nextoverloaded;
+              { do not check defs of operators in other units }
+              if assigned(pd) and (pd^.procsym<>@self) then
+                pd:=nil;
+           end;
+      end;
+
+
+    procedure tprocsym.deref;
+{$ifdef DONOTCHAINOPERATORS}
+      var
+        t    : ttoken;
+        last,pd : pprocdef;
+{$endif DONOTCHAINOPERATORS}
+      begin
+         resolvedef(pdef(definition));
+{$ifdef DONOTCHAINOPERATORS}
+         if (definition^.proctypeoption=potype_operator) then
+           begin
+              last:=definition;
+              while assigned(last^.nextoverloaded) do
+                last:=last^.nextoverloaded;
+              for t:=first_overloaded to last_overloaded do
+              if (name=overloaded_names[t]) then
+                begin
+                   if assigned(overloaded_operators[t]) then
+                     begin
+                       pd:=overloaded_operators[t]^.definition;
+                       { test if not already in list, bug report by KC Wong PM }
+                       while assigned(pd) do
+                         if pd=last then
+                           break
+                         else
+                           pd:=pd^.nextoverloaded;
+                       if pd=last then
+                         break;
+                       last^.nextoverloaded:=overloaded_operators[t]^.definition;
+                     end;
+                   overloaded_operators[t]:=@self;
+                   break;
+                end;
+           end;
+{$endif DONOTCHAINOPERATORS}
+      end;
+
+    procedure tprocsym.order_overloaded;
+      var firstdef,currdef,lastdef,nextopdef : pprocdef;
+      begin
+         if not assigned(definition) then
+           exit;
+         firstdef:=definition;
+         currdef:=definition;
+         while assigned(currdef) and (currdef^.owner=firstdef^.owner) do
+           begin
+             currdef^.count:=false;
+             currdef:=currdef^.nextoverloaded;
+           end;
+         nextopdef:=currdef;
+         definition:=definition^.nextoverloaded;
+         firstdef^.nextoverloaded:=nil;
+         while (definition<>nextopdef) do
+           begin
+             currdef:=firstdef;
+             lastdef:=definition;
+             definition:=definition^.nextoverloaded;
+             if lastdef^.mangledname<firstdef^.mangledname then
+               begin
+                 lastdef^.nextoverloaded:=firstdef;
+                 firstdef:=lastdef;
+               end
+             else
+               begin
+                 while assigned(currdef^.nextoverloaded) and
+                    (lastdef^.mangledname>currdef^.nextoverloaded^.mangledname) do
+                   currdef:=currdef^.nextoverloaded;
+                 lastdef^.nextoverloaded:=currdef^.nextoverloaded;
+                 currdef^.nextoverloaded:=lastdef;
+               end;
+           end;
+         definition:=firstdef;
+         currdef:=definition;
+         while assigned(currdef) do
+           begin
+             currdef^.count:=true;
+             lastdef:=currdef;
+             currdef:=currdef^.nextoverloaded;
+           end;
+         lastdef^.nextoverloaded:=nextopdef;
+      end;
+
+    procedure tprocsym.write;
+      begin
+         tsym.write;
+         writedefref(pdef(definition));
+         current_ppu^.writeentry(ibprocsym);
+      end;
+
+
+    procedure tprocsym.load_references;
+      (*var
+        prdef,prdef2 : pprocdef;
+        b : byte; *)
+      begin
+         inherited load_references;
+         (*prdef:=definition;
+           done in tsymtable.load_browser (PM)
+         { take care about operators !!  }
+         if (current_module^.flags and uf_has_browser) <>0 then
+           while assigned(prdef) and (prdef^.owner=definition^.owner) do
+             begin
+                b:=current_ppu^.readentry;
+                if b<>ibdefref then
+                  Message(unit_f_ppu_read_error);
+                prdef2:=pprocdef(readdefref);
+                resolvedef(prdef2);
+                if prdef<>prdef2 then
+                  Message(unit_f_ppu_read_error);
+                prdef^.load_references;
+                prdef:=prdef^.nextoverloaded;
+             end; *)
+      end;
+
+    function tprocsym.write_references : boolean;
+      var
+        prdef : pprocdef;
+      begin
+         write_references:=false;
+         if not inherited write_references then
+           exit;
+         write_references:=true;
+         prdef:=definition;
+         while assigned(prdef) and (prdef^.owner=definition^.owner) do
+          begin
+            prdef^.write_references;
+            prdef:=prdef^.nextoverloaded;
+          end;
+      end;
+
+
+{$ifdef BrowserLog}
+    procedure tprocsym.add_to_browserlog;
+      var
+        prdef : pprocdef;
+      begin
+         inherited add_to_browserlog;
+         prdef:=definition;
+         while assigned(prdef) do
+           begin
+              pprocdef(prdef)^.add_to_browserlog;
+              prdef:=pprocdef(prdef)^.nextoverloaded;
+           end;
+      end;
+{$endif BrowserLog}
+
+
+{$ifdef GDB}
+    function tprocsym.stabstring : pchar;
+     Var RetType : Char;
+         Obj,Info : String;
+         stabsstr : string;
+         p : pchar;
+    begin
+      obj := name;
+      info := '';
+      if is_global then
+       RetType := 'F'
+      else
+       RetType := 'f';
+     if assigned(owner) then
+      begin
+        if (owner^.symtabletype = objectsymtable) then
+         obj := owner^.name^+'__'+name;
+        { this code was correct only as long as the local symboltable
+          of the parent had the same name as the function
+          but this is no true anymore !! PM
+        if (owner^.symtabletype=localsymtable) and assigned(owner^.name) then
+         info := ','+name+','+owner^.name^;  }
+        if (owner^.symtabletype=localsymtable) and assigned(owner^.defowner) and
+           assigned(pprocdef(owner^.defowner)^.procsym) then
+          info := ','+name+','+pprocdef(owner^.defowner)^.procsym^.name;
+      end;
+     stabsstr:=definition^.mangledname;
+     getmem(p,length(stabsstr)+255);
+     strpcopy(p,'"'+obj+':'+RetType
+           +definition^.rettype.def^.numberstring+info+'",'+tostr(n_function)
+           +',0,'+
+           tostr(aktfilepos.line)
+           +',');
+     strpcopy(strend(p),stabsstr);
+     stabstring:=strnew(p);
+     freemem(p,length(stabsstr)+255);
+    end;
+
+    procedure tprocsym.concatstabto(asmlist : paasmoutput);
+    begin
+      if (pocall_internproc in definition^.proccalloptions) then exit;
+      if not isstabwritten then
+        asmlist^.concat(new(pai_stabs,init(stabstring)));
+      isstabwritten := true;
+      if assigned(definition^.parast) then
+        definition^.parast^.concatstabto(asmlist);
+      { local type defs and vars should not be written
+        inside the main proc stab }
+      if assigned(definition^.localst) and
+         (lexlevel>main_program_level) then
+        definition^.localst^.concatstabto(asmlist);
+      definition^.is_def_stab_written := written;
+    end;
+{$endif GDB}
+
+
+{****************************************************************************
+                                  TERRORSYM
+****************************************************************************}
+
+    constructor terrorsym.init;
+      begin
+        inherited init('');
+        typ:=errorsym;
+      end;
+
+{****************************************************************************
+                                TPROPERTYSYM
+****************************************************************************}
+
+    constructor tpropertysym.init(const n : string);
+      begin
+         inherited init(n);
+         typ:=propertysym;
+         propoptions:=[];
+         index:=0;
+         default:=0;
+         proptype.reset;
+         indextype.reset;
+         new(readaccess,init);
+         new(writeaccess,init);
+         new(storedaccess,init);
+      end;
+
+
+    constructor tpropertysym.load;
+      begin
+         inherited load;
+         typ:=propertysym;
+         readsmallset(propoptions,sizeof(propoptions));
+         if (ppo_is_override in propoptions) then
+          begin
+            propoverriden:=ppropertysym(readsymref);
+            { we need to have these objects initialized }
+            new(readaccess,init);
+            new(writeaccess,init);
+            new(storedaccess,init);
+          end
+         else
+          begin
+            proptype.load;
+            index:=readlong;
+            default:=readlong;
+            indextype.load;
+            new(readaccess,load);
+            new(writeaccess,load);
+            new(storedaccess,load);
+          end;
+      end;
+
+
+    destructor tpropertysym.done;
+      begin
+         dispose(readaccess,done);
+         dispose(writeaccess,done);
+         dispose(storedaccess,done);
+         inherited done;
+      end;
+
+
+    procedure tpropertysym.deref;
+      begin
+        if (ppo_is_override in propoptions) then
+         begin
+           resolvesym(psym(propoverriden));
+           dooverride(propoverriden);
+         end
+        else
+         begin
+           proptype.resolve;
+           indextype.resolve;
+           readaccess^.resolve;
+           writeaccess^.resolve;
+           storedaccess^.resolve;
+         end;
+      end;
+
+
+    function tpropertysym.getsize : longint;
+      begin
+         getsize:=0;
+      end;
+
+
+    procedure tpropertysym.write;
+      begin
+        tsym.write;
+        writesmallset(propoptions,sizeof(propoptions));
+        if (ppo_is_override in propoptions) then
+         writesymref(propoverriden)
+        else
+         begin
+           proptype.write;
+           writelong(index);
+           writelong(default);
+           indextype.write;
+           readaccess^.write;
+           writeaccess^.write;
+           storedaccess^.write;
+         end;
+        current_ppu^.writeentry(ibpropertysym);
+      end;
+
+
+    procedure tpropertysym.dooverride(overriden:ppropertysym);
+      begin
+        propoverriden:=overriden;
+        proptype:=overriden^.proptype;
+        propoptions:=overriden^.propoptions+[ppo_is_override];
+        index:=overriden^.index;
+        default:=overriden^.default;
+        indextype:=overriden^.indextype;
+        readaccess^.clear;
+        readaccess:=overriden^.readaccess^.getcopy;
+        writeaccess^.clear;
+        writeaccess:=overriden^.writeaccess^.getcopy;
+        storedaccess^.clear;
+        storedaccess:=overriden^.storedaccess^.getcopy;
+      end;
+
+
+{$ifdef GDB}
+    function tpropertysym.stabstring : pchar;
+      begin
+         { !!!! don't know how to handle }
+         stabstring:=strpnew('');
+      end;
+
+    procedure tpropertysym.concatstabto(asmlist : paasmoutput);
+      begin
+         { !!!! don't know how to handle }
+      end;
+{$endif GDB}
+
+{****************************************************************************
+                                  TFUNCRETSYM
+****************************************************************************}
+
+    constructor tfuncretsym.init(const n : string;approcinfo : pointer{pprocinfo});
+
+      begin
+         tsym.init(n);
+         typ:=funcretsym;
+         funcretprocinfo:=approcinfo;
+         rettype:=pprocinfo(approcinfo)^.returntype;
+         { address valid for ret in param only }
+         { otherwise set by insert             }
+         address:=pprocinfo(approcinfo)^.return_offset;
+      end;
+
+    constructor tfuncretsym.load;
+      begin
+         tsym.load;
+         rettype.load;
+         address:=readlong;
+         funcretprocinfo:=nil;
+         typ:=funcretsym;
+      end;
+
+    destructor tfuncretsym.done;
+      begin
+        inherited done;
+      end;
+
+    procedure tfuncretsym.write;
+      begin
+         tsym.write;
+         rettype.write;
+         writelong(address);
+         current_ppu^.writeentry(ibfuncretsym);
+      end;
+
+    procedure tfuncretsym.deref;
+      begin
+         rettype.resolve;
+      end;
+
+{$ifdef GDB}
+    procedure tfuncretsym.concatstabto(asmlist : paasmoutput);
+      begin
+        { Nothing to do here, it is done in genexitcode  }
+      end;
+{$endif GDB}
+
+    procedure tfuncretsym.insert_in_data;
+      var
+        l : longint;
+      begin
+        { if retoffset is already set then reuse it, this is needed
+          when inserting the result variable }
+        if procinfo^.return_offset<>0 then
+         address:=procinfo^.return_offset
+        else
+         begin
+           { allocate space in local if ret in acc or in fpu }
+           if ret_in_acc(procinfo^.returntype.def) or (procinfo^.returntype.def^.deftype=floatdef) then
+            begin
+              l:=rettype.def^.size;
+              inc(owner^.datasize,l);
+{$ifdef m68k}
+              { word alignment required for motorola }
+              if (l=1) then
+               inc(owner^.datasize,1)
+              else
+{$endif}
+              if (l>=4) and ((owner^.datasize and 3)<>0) then
+                inc(owner^.datasize,4-(owner^.datasize and 3))
+              else if (l>=2) and ((owner^.datasize and 1)<>0) then
+                inc(owner^.datasize,2-(owner^.datasize and 1));
+              address:=owner^.datasize;
+              procinfo^.return_offset:=-owner^.datasize;
+            end;
+         end;
+      end;
+
+
+{****************************************************************************
+                                  TABSOLUTESYM
+****************************************************************************}
+
+    constructor tabsolutesym.init(const n : string;const tt : ttype);
+      begin
+        inherited init(n,tt);
+        typ:=absolutesym;
+      end;
+
+
+    constructor tabsolutesym.initdef(const n : string;p : pdef);
+      var
+        t : ttype;
+      begin
+        t.setdef(p);
+        tabsolutesym.init(n,t);
+      end;
+
+
+    constructor tabsolutesym.load;
+      begin
+         tvarsym.load;
+         typ:=absolutesym;
+         ref:=nil;
+         address:=0;
+         asmname:=nil;
+         abstyp:=absolutetyp(readbyte);
+         absseg:=false;
+         case abstyp of
+           tovar :
+             begin
+               asmname:=stringdup(readstring);
+               ref:=srsym;
+             end;
+           toasm :
+             asmname:=stringdup(readstring);
+           toaddr :
+             begin
+               address:=readlong;
+               absseg:=boolean(readbyte);
+             end;
+         end;
+      end;
+
+
+    procedure tabsolutesym.write;
+      var
+        hvo : tvaroptions;
+      begin
+         { Note: This needs to write everything of tvarsym.write }
+         tsym.write;
+         writebyte(byte(varspez));
+         if read_member then
+           writelong(address);
+         { write only definition or definitionsym }
+         vartype.write;
+         hvo:=varoptions-[vo_regable];
+         writesmallset(hvo,sizeof(hvo));
+         writebyte(byte(abstyp));
+         case abstyp of
+           tovar :
+             writestring(ref^.name);
+           toasm :
+             writestring(asmname^);
+           toaddr :
+             begin
+               writelong(address);
+               writebyte(byte(absseg));
+             end;
+         end;
+        current_ppu^.writeentry(ibabsolutesym);
+      end;
+
+
+    procedure tabsolutesym.deref;
+      begin
+         tvarsym.deref;
+         if (abstyp=tovar) and (asmname<>nil) then
+           begin
+              { search previous loaded symtables }
+              getsym(asmname^,false);
+              if not(assigned(srsym)) then
+                getsymonlyin(owner,asmname^);
+              if not(assigned(srsym)) then
+                srsym:=generrorsym;
+              ref:=srsym;
+              stringdispose(asmname);
+           end;
+      end;
+
+
+    function tabsolutesym.mangledname : string;
+      begin
+         case abstyp of
+           tovar :
+             mangledname:=ref^.mangledname;
+           toasm :
+             mangledname:=asmname^;
+           toaddr :
+             mangledname:='$'+tostr(address);
+         else
+           internalerror(10002);
+         end;
+      end;
+
+
+    procedure tabsolutesym.insert_in_data;
+      begin
+      end;
+
+
+{$ifdef GDB}
+    procedure tabsolutesym.concatstabto(asmlist : paasmoutput);
+      begin
+      { I don't know how to handle this !! }
+      end;
+{$endif GDB}
+
+
+{****************************************************************************
+                                  TVARSYM
+****************************************************************************}
+
+    constructor tvarsym.init(const n : string;const tt : ttype);
+      begin
+         tsym.init(n);
+         typ:=varsym;
+         vartype:=tt;
+         _mangledname:=nil;
+         varspez:=vs_value;
+         address:=0;
+         localvarsym:=nil;
+         refs:=0;
+         varstate:=vs_used;
+         varoptions:=[];
+         { can we load the value into a register ? }
+         if tt.def^.is_intregable then
+           include(varoptions,vo_regable)
+         else
+           exclude(varoptions,vo_regable);
+
+         if tt.def^.is_fpuregable then
+           include(varoptions,vo_fpuregable)
+         else
+           exclude(varoptions,vo_fpuregable);
+         reg:=R_NO;
+      end;
+
+
+    constructor tvarsym.init_dll(const n : string;const tt : ttype);
+      begin
+         tvarsym.init(n,tt);
+         include(varoptions,vo_is_dll_var);
+      end;
+
+
+    constructor tvarsym.init_C(const n,mangled : string;const tt : ttype);
+      begin
+         tvarsym.init(n,tt);
+         include(varoptions,vo_is_C_var);
+         setmangledname(mangled);
+      end;
+
+
+    constructor tvarsym.initdef(const n : string;p : pdef);
+      var
+        t : ttype;
+      begin
+        t.setdef(p);
+        tvarsym.init(n,t);
+      end;
+
+
+    constructor tvarsym.load;
+      begin
+         tsym.load;
+         typ:=varsym;
+         _mangledname:=nil;
+         reg:=R_NO;
+         refs := 0;
+         varstate:=vs_used;
+         varspez:=tvarspez(readbyte);
+         if read_member then
+           address:=readlong
+         else
+           address:=0;
+         localvarsym:=nil;
+         vartype.load;
+         readsmallset(varoptions,sizeof(varoptions));
+         if (vo_is_C_var in varoptions) then
+           setmangledname(readstring);
+      end;
+
+
+    destructor tvarsym.done;
+      begin
+         strdispose(_mangledname);
+         inherited done;
+      end;
+
+
+    procedure tvarsym.deref;
+      begin
+        vartype.resolve;
+      end;
+
+
+    procedure tvarsym.write;
+      var
+        hvo : tvaroptions;
+      begin
+         tsym.write;
+         writebyte(byte(varspez));
+         if read_member then
+          writelong(address);
+         vartype.write;
+         { symbols which are load are never candidates for a register,
+           turn off the regable }
+         hvo:=varoptions-[vo_regable];
+         writesmallset(hvo,sizeof(hvo));
+         if (vo_is_C_var in varoptions) then
+           writestring(mangledname);
+         current_ppu^.writeentry(ibvarsym);
+      end;
+
+
+    procedure tvarsym.setmangledname(const s : string);
+      begin
+        _mangledname:=strpnew(s);
+      end;
+
+
+    function tvarsym.mangledname : string;
+      var
+        prefix : string;
+      begin
+         if assigned(_mangledname) then
+           begin
+              mangledname:=strpas(_mangledname);
+              exit;
+           end;
+         case owner^.symtabletype of
+           staticsymtable :
+             if (cs_create_smart in aktmoduleswitches) then
+               prefix:='_'+owner^.name^+'$$$_'
+             else
+               prefix:='_';
+           unitsymtable,
+           globalsymtable :
+             prefix:=
+              'U_'+owner^.name^+'_';
+           else
+             Message(sym_e_invalid_call_tvarsymmangledname);
+         end;
+         mangledname:=prefix+name;
+      end;
+
+
+    function tvarsym.getsize : longint;
+      begin
+        if assigned(vartype.def) then
+          getsize:=vartype.def^.size
+        else
+          getsize:=0;
+      end;
+
+
+    function tvarsym.getvaluesize : longint;
+      begin
+        if assigned(vartype.def) and
+           (varspez=vs_value) and
+           ((vartype.def^.deftype<>arraydef) or
+            (Parraydef(vartype.def)^.highrange>=Parraydef(vartype.def)^.lowrange)) then
+          getvaluesize:=vartype.def^.size
+        else
+          getvaluesize:=0;
+      end;
+
+
+    function tvarsym.getpushsize : longint;
+      begin
+         if assigned(vartype.def) then
+           begin
+              case varspez of
+                vs_out,
+                vs_var :
+                  getpushsize:=target_os.size_of_pointer;
+                vs_value,
+                vs_const :
+                  begin
+                      if push_addr_param(vartype.def) then
+                        getpushsize:=target_os.size_of_pointer
+                      else
+                        getpushsize:=vartype.def^.size;
+                  end;
+              end;
+           end
+         else
+           getpushsize:=0;
+      end;
+
+
+    function  data_align(length : longint) : longint;
+      begin
+         (* this is useless under go32v2 at least
+         because the section are only align to dword
+         if length>8 then
+           data_align:=16
+         else if length>4 then
+           data_align:=8
+         else *)
+         if length>2 then
+           data_align:=4
+         else
+          if length>1 then
+           data_align:=2
+         else
+           data_align:=1;
+      end;
+
+
+    procedure tvarsym.insert_in_data;
+      var
+         varalign,
+         l,ali,modulo : longint;
+         storefilepos : tfileposinfo;
+      begin
+        if (vo_is_external in varoptions) then
+          exit;
+        { handle static variables of objects especially }
+        if read_member and (owner^.symtabletype=objectsymtable) and
+           (sp_static in symoptions) then
+         begin
+            { the data filed is generated in parser.pas
+              with a tobject_FIELDNAME variable }
+            { this symbol can't be loaded to a register }
+            exclude(varoptions,vo_regable);
+            exclude(varoptions,vo_fpuregable);
+         end
+        else
+         if not(read_member) then
+          begin
+             { made problems with parameters etc. ! (FK) }
+             {  check for instance of an abstract object or class }
+             {
+             if (pvarsym(sym)^.definition^.deftype=objectdef) and
+               (oo_is_abstract in pobjectdef(pvarsym(sym)^.definition)^.options) then
+               Message(sym_e_no_instance_of_abstract_object);
+             }
+             storefilepos:=aktfilepos;
+             aktfilepos:=tokenpos;
+             if (vo_is_thread_var in varoptions) then
+               l:=4
+             else
+               l:=getvaluesize;
+             case owner^.symtabletype of
+               stt_exceptsymtable:
+                 { can contain only one symbol, address calculated later }
+                 ;
+               localsymtable :
+                 begin
+                   varstate:=vs_declared;
+                   modulo:=owner^.datasize and 3;
+{$ifdef m68k}
+                 { word alignment required for motorola }
+                   if (l=1) then
+                    l:=2
+                   else
+{$endif}
+{
+                   if (cs_optimize in aktglobalswitches) and
+                      (aktoptprocessor in [classp5,classp6]) and
+                      (l>=8) and ((owner^.datasize and 7)<>0) then
+                     inc(owner^.datasize,8-(owner^.datasize and 7))
+                   else
+}
+                     begin
+                        if (l>=4) and (modulo<>0) then
+                          inc(l,4-modulo)
+                        else
+                          if (l>=2) and ((modulo and 1)<>0) then
+                            inc(l,2-(modulo and 1));
+                     end;
+                   inc(owner^.datasize,l);
+                   address:=owner^.datasize;
+                 end;
+               staticsymtable :
+                 begin
+                   { enable unitialized warning for local symbols }
+                   varstate:=vs_declared;
+                   if (cs_create_smart in aktmoduleswitches) then
+                     bsssegment^.concat(new(pai_cut,init));
+                   ali:=data_align(l);
+                   if ali>1 then
+                     begin
+                        modulo:=owner^.datasize mod ali;
+                        if modulo>0 then
+                          inc(owner^.datasize,ali-modulo);
+                     end;
+{$ifdef GDB}
+                   if cs_debuginfo in aktmoduleswitches then
+                      concatstabto(bsssegment);
+{$endif GDB}
+
+                   if (cs_create_smart in aktmoduleswitches) or
+                      DLLSource or
+                      (vo_is_exported in varoptions) or
+                      (vo_is_C_var in varoptions) then
+                     bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)))
+                   else
+                     bsssegment^.concat(new(pai_datablock,init(mangledname,l)));
+                   { increase datasize }
+                   inc(owner^.datasize,l);
+                   { this symbol can't be loaded to a register }
+                   exclude(varoptions,vo_regable);
+                   exclude(varoptions,vo_fpuregable);
+                 end;
+               globalsymtable :
+                 begin
+                   if (cs_create_smart in aktmoduleswitches) then
+                     bsssegment^.concat(new(pai_cut,init));
+                   ali:=data_align(l);
+                   if ali>1 then
+                     begin
+                        modulo:=owner^.datasize mod ali;
+                        if modulo>0 then
+                          inc(owner^.datasize,ali-modulo);
+                     end;
+{$ifdef GDB}
+                   if cs_debuginfo in aktmoduleswitches then
+                     concatstabto(bsssegment);
+{$endif GDB}
+                   bsssegment^.concat(new(pai_datablock,init_global(mangledname,l)));
+                   inc(owner^.datasize,l);
+                   { this symbol can't be loaded to a register }
+                   exclude(varoptions,vo_regable);
+                   exclude(varoptions,vo_fpuregable);
+                 end;
+               recordsymtable,
+               objectsymtable :
+                 begin
+                 { this symbol can't be loaded to a register }
+                   exclude(varoptions,vo_regable);
+                   exclude(varoptions,vo_fpuregable);
+                 { get the alignment size }
+                   if (aktpackrecords=packrecord_C) then
+                    begin
+                      varalign:=vartype.def^.alignment;
+                      if (varalign>4) and ((varalign mod 4)<>0) and
+                        (vartype.def^.deftype=arraydef) then
+                        begin
+                          Message1(sym_w_wrong_C_pack,vartype.def^.typename);
+                        end;
+                      if varalign=0 then
+                        varalign:=l;
+                      if (owner^.dataalignment<target_os.maxCrecordalignment) then
+                       begin
+                         if (varalign>16) and (owner^.dataalignment<32) then
+                          owner^.dataalignment:=32
+                         else if (varalign>12) and (owner^.dataalignment<16) then
+                          owner^.dataalignment:=16
+                         { 12 is needed for long double }
+                         else if (varalign>8) and (owner^.dataalignment<12) then
+                          owner^.dataalignment:=12
+                         else if (varalign>4) and (owner^.dataalignment<8) then
+                          owner^.dataalignment:=8
+                         else if (varalign>2) and (owner^.dataalignment<4) then
+                          owner^.dataalignment:=4
+                         else if (varalign>1) and (owner^.dataalignment<2) then
+                          owner^.dataalignment:=2;
+                       end;
+                      if owner^.dataalignment>target_os.maxCrecordalignment then
+                        owner^.dataalignment:=target_os.maxCrecordalignment;
+                    end
+                   else
+                    varalign:=vartype.def^.alignment;
+                   if varalign=0 then
+                     varalign:=l;
+                 { align record and object fields }
+                   if (varalign=1) or (owner^.dataalignment=1) then
+                    begin
+                      address:=owner^.datasize;
+                      inc(owner^.datasize,l)
+                    end
+                   else if (varalign=2) or (owner^.dataalignment=2) then
+                     begin
+                       owner^.datasize:=(owner^.datasize+1) and (not 1);
+                       address:=owner^.datasize;
+                       inc(owner^.datasize,l)
+                     end
+                   else if (varalign<=4) or (owner^.dataalignment=4) then
+                     begin
+                       owner^.datasize:=(owner^.datasize+3) and (not 3);
+                       address:=owner^.datasize;
+                       inc(owner^.datasize,l);
+                     end
+                   else if (varalign<=8) or (owner^.dataalignment=8) then
+                     begin
+                       owner^.datasize:=(owner^.datasize+7) and (not 7);
+                       address:=owner^.datasize;
+                       inc(owner^.datasize,l);
+                     end
+                         { 12 is needed for C long double support }
+                   else if (varalign<=12) and (owner^.dataalignment=12) then
+                     begin
+                       owner^.datasize:=((owner^.datasize+11) div 12) * 12;
+                       address:=owner^.datasize;
+                       inc(owner^.datasize,l);
+                     end
+                   else if (varalign<=16) or (owner^.dataalignment=16) then
+                     begin
+                       owner^.datasize:=(owner^.datasize+15) and (not 15);
+                       address:=owner^.datasize;
+                       inc(owner^.datasize,l);
+                     end
+                   else if (varalign<=32) or (owner^.dataalignment=32) then
+                     begin
+                       owner^.datasize:=(owner^.datasize+31) and (not 31);
+                       address:=owner^.datasize;
+                       inc(owner^.datasize,l);
+                     end
+                    else
+                     internalerror(1000022);
+                 end;
+               parasymtable :
+                 begin
+                   { here we need the size of a push instead of the
+                     size of the data }
+                   l:=getpushsize;
+                   varstate:=vs_assigned;
+                   address:=owner^.datasize;
+                   owner^.datasize:=align(owner^.datasize+l,target_os.stackalignment);
+                 end
+               else
+                 begin
+                     modulo:=owner^.datasize and 3;
+                     if (l>=4) and (modulo<>0) then
+                       inc(owner^.datasize,4-modulo)
+                     else
+                       if (l>=2) and ((modulo and 1)<>0) then
+                         inc(owner^.datasize);
+                   address:=owner^.datasize;
+                   inc(owner^.datasize,l);
+                 end;
+               end;
+             aktfilepos:=storefilepos;
+        end;
+      end;
+
+{$ifdef GDB}
+    function tvarsym.stabstring : pchar;
+     var
+       st : string;
+     begin
+       st:=vartype.def^.numberstring;
+       if (owner^.symtabletype = objectsymtable) and
+          (sp_static in symoptions) then
+         begin
+            if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st;
+{$ifndef Delphi}
+            stabstring := strpnew('"'+owner^.name^+'__'+name+':'+st+
+                     '",'+
+                     tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
+{$endif}
+         end
+       else if (owner^.symtabletype = globalsymtable) or
+          (owner^.symtabletype = unitsymtable) then
+         begin
+            { Here we used S instead of
+              because with G GDB doesn't look at the address field
+              but searches the same name or with a leading underscore
+              but these names don't exist in pascal !}
+            if (cs_gdb_gsym in aktglobalswitches) then st := 'G'+st else st := 'S'+st;
+            stabstring := strpnew('"'+name+':'+st+'",'+
+                     tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
+         end
+       else if owner^.symtabletype = staticsymtable then
+         begin
+            stabstring := strpnew('"'+name+':S'+st+'",'+
+                  tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname);
+         end
+       else if (owner^.symtabletype in [parasymtable,inlineparasymtable]) then
+         begin
+            case varspez of
+               vs_out,
+               vs_var   : st := 'v'+st;
+               vs_value,
+               vs_const : if push_addr_param(vartype.def) then
+                            st := 'v'+st { should be 'i' but 'i' doesn't work }
+                          else
+                            st := 'p'+st;
+              end;
+            stabstring := strpnew('"'+name+':'+st+'",'+
+                  tostr(N_PSYM)+',0,'+tostr(fileinfo.line)+','+
+                  tostr(address+owner^.address_fixup));
+                  {offset to ebp => will not work if the framepointer is esp
+                  so some optimizing will make things harder to debug }
+         end
+       else if (owner^.symtabletype in [localsymtable,inlinelocalsymtable]) then
+   {$ifdef i386}
+         if reg<>R_NO then
+           begin
+              { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
+              { this is the register order for GDB}
+              stabstring:=strpnew('"'+name+':r'+st+'",'+
+                        tostr(N_RSYM)+',0,'+
+                        tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
+           end
+         else
+   {$endif i386}
+           { I don't know if this will work (PM) }
+           if (vo_is_C_var in varoptions) then
+            stabstring := strpnew('"'+name+':S'+st+'",'+
+                  tostr(N_LCSYM)+',0,'+tostr(fileinfo.line)+','+mangledname)
+           else
+           stabstring := strpnew('"'+name+':'+st+'",'+
+                  tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',-'+tostr(address-owner^.address_fixup))
+       else
+         stabstring := inherited stabstring;
+  end;
+
+    procedure tvarsym.concatstabto(asmlist : paasmoutput);
+{$ifdef i386}
+      var stab_str : pchar;
+{$endif i386}
+      begin
+         inherited concatstabto(asmlist);
+{$ifdef i386}
+      if (owner^.symtabletype=parasymtable) and
+         (reg<>R_NO) then
+           begin
+           { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
+           { this is the register order for GDB}
+              stab_str:=strpnew('"'+name+':r'
+                     +vartype.def^.numberstring+'",'+
+                     tostr(N_RSYM)+',0,'+
+                     tostr(fileinfo.line)+','+tostr(GDB_i386index[reg]));
+              asmlist^.concat(new(pai_stabs,init(stab_str)));
+           end;
+{$endif i386}
+      end;
+{$endif GDB}
+
+
+{****************************************************************************
+                             TTYPEDCONSTSYM
+*****************************************************************************}
+
+    constructor ttypedconstsym.init(const n : string;p : pdef;really_const : boolean);
+      begin
+         tsym.init(n);
+         typ:=typedconstsym;
+         typedconsttype.setdef(p);
+         is_really_const:=really_const;
+         prefix:=stringdup(procprefix);
+      end;
+
+
+    constructor ttypedconstsym.inittype(const n : string;const tt : ttype;really_const : boolean);
+      begin
+         ttypedconstsym.init(n,nil,really_const);
+         typedconsttype:=tt;
+      end;
+
+
+    constructor ttypedconstsym.load;
+      begin
+         tsym.load;
+         typ:=typedconstsym;
+         typedconsttype.load;
+         prefix:=stringdup(readstring);
+         is_really_const:=boolean(readbyte);
+      end;
+
+
+    destructor ttypedconstsym.done;
+      begin
+         stringdispose(prefix);
+         tsym.done;
+      end;
+
+
+    function ttypedconstsym.mangledname : string;
+      begin
+         mangledname:='TC_'+prefix^+'_'+name;
+      end;
+
+
+    function ttypedconstsym.getsize : longint;
+      begin
+        if assigned(typedconsttype.def) then
+         getsize:=typedconsttype.def^.size
+        else
+         getsize:=0;
+      end;
+
+
+    procedure ttypedconstsym.deref;
+      begin
+        typedconsttype.resolve;
+      end;
+
+
+    procedure ttypedconstsym.write;
+      begin
+         tsym.write;
+         typedconsttype.write;
+         writestring(prefix^);
+         writebyte(byte(is_really_const));
+         current_ppu^.writeentry(ibtypedconstsym);
+      end;
+
+
+    procedure ttypedconstsym.insert_in_data;
+      var
+        curconstsegment : paasmoutput;
+        l,ali,modulo : longint;
+        storefilepos : tfileposinfo;
+      begin
+        storefilepos:=aktfilepos;
+        aktfilepos:=tokenpos;
+        if is_really_const then
+          curconstsegment:=consts
+        else
+          curconstsegment:=datasegment;
+        if (cs_create_smart in aktmoduleswitches) then
+          curconstsegment^.concat(new(pai_cut,init));
+        l:=getsize;
+        ali:=data_align(l);
+        if ali>1 then
+          begin
+             curconstsegment^.concat(new(pai_align,init(ali)));
+             modulo:=owner^.datasize mod ali;
+             if modulo>0 then
+               inc(owner^.datasize,ali-modulo);
+          end;
+        {  Why was there no owner size update here ??? }
+        inc(owner^.datasize,l);
+{$ifdef GDB}
+              if cs_debuginfo in aktmoduleswitches then
+                concatstabto(curconstsegment);
+{$endif GDB}
+        if owner^.symtabletype=globalsymtable then
+          begin
+             curconstsegment^.concat(new(pai_symbol,initdataname_global(mangledname,getsize)));
+          end
+        else
+          if owner^.symtabletype<>unitsymtable then
+            begin
+              if (cs_create_smart in aktmoduleswitches) or
+                 DLLSource then
+                curconstsegment^.concat(new(pai_symbol,initdataname_global(mangledname,getsize)))
+              else
+                curconstsegment^.concat(new(pai_symbol,initdataname(mangledname,getsize)));
+            end;
+        aktfilepos:=storefilepos;
+      end;
+
+{$ifdef GDB}
+    function ttypedconstsym.stabstring : pchar;
+    var
+      st : char;
+    begin
+    if (cs_gdb_gsym in aktglobalswitches) and (owner^.symtabletype in [unitsymtable,globalsymtable]) then
+      st := 'G'
+    else
+      st := 'S';
+    stabstring := strpnew('"'+name+':'+st+
+            typedconsttype.def^.numberstring+'",'+tostr(n_STSYM)+',0,'+
+            tostr(fileinfo.line)+','+mangledname);
+    end;
+{$endif GDB}
+
+
+{****************************************************************************
+                                  TCONSTSYM
+****************************************************************************}
+
+    constructor tconstsym.init(const n : string;t : tconsttyp;v : TConstExprInt);
+      begin
+         inherited init(n);
+         typ:=constsym;
+         consttyp:=t;
+         value:=v;
+         ResStrIndex:=0;
+         consttype.reset;
+         len:=0;
+      end;
+
+
+    constructor tconstsym.init_def(const n : string;t : tconsttyp;v : TConstExprInt;def : pdef);
+      begin
+         inherited init(n);
+         typ:=constsym;
+         consttyp:=t;
+         value:=v;
+         consttype.setdef(def);
+         len:=0;
+      end;
+
+
+    constructor tconstsym.init_string(const n : string;t : tconsttyp;str:pchar;l:longint);
+      begin
+         inherited init(n);
+         typ:=constsym;
+         consttyp:=t;
+         value:=longint(str);
+         consttype.reset;
+         len:=l;
+         if t=constresourcestring then
+           ResStrIndex:=ResourceStrings^.Register(name,
+             pchar(tpointerord(value)),len);
+      end;
+
+    constructor tconstsym.load;
+      var
+         pd : pbestreal;
+         ps : pnormalset;
+         pc : pchar;
+         l1,l2 : longint;
+
+      begin
+         tsym.load;
+         typ:=constsym;
+         consttype.reset;
+         consttyp:=tconsttyp(readbyte);
+         case consttyp of
+           constint:
+             if sizeof(tconstexprint)=8 then
+               begin
+                  l1:=readlong;
+                  l2:=readlong;
+{$ifopt R+}
+  {$define Range_check_on}
+{$endif opt R+}
+{$R- needed here }
+                  value:=qword(l1)+(int64(l2) shl 32);
+{$ifdef Range_check_on}
+  {$R+}
+  {$undef Range_check_on}
+{$endif Range_check_on}
+               end
+             else
+               value:=readlong;
+           constbool,
+           constchar :
+             value:=readlong;
+           constpointer,
+           constord :
+             begin
+               consttype.load;
+               if sizeof(TConstExprInt)=8 then
+                 begin
+                    l1:=readlong;
+                    l2:=readlong;
+{$ifopt R+}
+  {$define Range_check_on}
+{$endif opt R+}
+{$R- needed here }
+                    value:=qword(l1)+(int64(l2) shl 32);
+{$ifdef Range_check_on}
+  {$R+}
+  {$undef Range_check_on}
+{$endif Range_check_on}
+                 end
+               else
+                 value:=readlong;
+             end;
+           conststring,constresourcestring :
+             begin
+               len:=readlong;
+               getmem(pc,len+1);
+               current_ppu^.getdata(pc^,len);
+               if consttyp=constresourcestring then
+                 ResStrIndex:=readlong;
+               value:=tpointerord(pc);
+             end;
+           constreal :
+             begin
+               new(pd);
+               pd^:=readreal;
+               value:=tpointerord(pd);
+             end;
+           constset :
+             begin
+               consttype.load;
+               new(ps);
+               readnormalset(ps^);
+               value:=tpointerord(ps);
+             end;
+           constnil : ;
+           else
+             Message1(unit_f_ppu_invalid_entry,tostr(ord(consttyp)));
+         end;
+      end;
+
+
+    destructor tconstsym.done;
+      begin
+        case consttyp of
+          conststring,constresourcestring :
+            freemem(pchar(tpointerord(value)),len+1);
+          constreal :
+            dispose(pbestreal(tpointerord(value)));
+          constset :
+            dispose(pnormalset(tpointerord(value)));
+        end;
+        inherited done;
+      end;
+
+
+    function tconstsym.mangledname : string;
+      begin
+         mangledname:=name;
+      end;
+
+
+    procedure tconstsym.deref;
+      begin
+        if consttyp in [constord,constpointer,constset] then
+         consttype.resolve;
+      end;
+
+
+    procedure tconstsym.write;
+      begin
+         tsym.write;
+         writebyte(byte(consttyp));
+         case consttyp of
+           constnil : ;
+           constint:
+             if sizeof(TConstExprInt)=8 then
+               begin
+                  writelong(lo(value));
+                  writelong(hi(value));
+               end
+             else
+               writelong(value);
+
+           constbool,
+           constchar :
+             writelong(value);
+           constpointer,
+           constord :
+             begin
+               consttype.write;
+               if sizeof(TConstExprInt)=8 then
+                 begin
+                    writelong(lo(value));
+                    writelong(hi(value));
+                 end
+               else
+                 writelong(value);
+             end;
+           conststring,constresourcestring :
+             begin
+               writelong(len);
+               current_ppu^.putdata(pchar(TPointerOrd(value))^,len);
+               if consttyp=constresourcestring then
+                 writelong(ResStrIndex);
+             end;
+           constreal :
+             writereal(pbestreal(TPointerOrd(value))^);
+           constset :
+             begin
+               consttype.write;
+               writenormalset(pointer(TPointerOrd(value))^);
+             end;
+         else
+           internalerror(13);
+         end;
+        current_ppu^.writeentry(ibconstsym);
+      end;
+
+{$ifdef GDB}
+    function tconstsym.stabstring : pchar;
+    var st : string;
+    begin
+         {even GDB v4.16 only now 'i' 'r' and 'e' !!!}
+         case consttyp of
+            conststring : begin
+                          { I had to remove ibm2ascii !! }
+                          st := pstring(TPointerOrd(value))^;
+                          {st := ibm2ascii(pstring(value)^);}
+                          st := 's'''+st+'''';
+                          end;
+            constbool,
+            constint,
+            constpointer,
+            constord,
+            constchar : st := 'i'+tostr(value);
+            constreal : begin
+                        system.str(pbestreal(TPointerOrd(value))^,st);
+                        st := 'r'+st;
+                        end;
+         { if we don't know just put zero !! }
+         else st:='i0';
+            {***SETCONST}
+            {constset:;}    {*** I don't know what to do with a set.}
+         { sets are not recognized by GDB}
+            {***}
+        end;
+    stabstring := strpnew('"'+name+':c='+st+'",'+tostr(N_function)+',0,'+
+                    tostr(fileinfo.line)+',0');
+    end;
+
+    procedure tconstsym.concatstabto(asmlist : paasmoutput);
+      begin
+        if consttyp <> conststring then
+          inherited concatstabto(asmlist);
+      end;
+{$endif GDB}
+
+
+{****************************************************************************
+                                  TENUMSYM
+****************************************************************************}
+
+    constructor tenumsym.init(const n : string;def : penumdef;v : longint);
+      begin
+         tsym.init(n);
+         typ:=enumsym;
+         definition:=def;
+         value:=v;
+         if def^.min>v then
+           def^.setmin(v);
+         if def^.max<v then
+           def^.setmax(v);
+         order;
+      end;
+
+
+    constructor tenumsym.load;
+      begin
+         tsym.load;
+         typ:=enumsym;
+         definition:=penumdef(readdefref);
+         value:=readlong;
+         nextenum := Nil;
+      end;
+
+
+    procedure tenumsym.deref;
+      begin
+         resolvedef(pdef(definition));
+         order;
+      end;
+
+
+   procedure tenumsym.order;
+      var
+         sym : penumsym;
+      begin
+         sym := definition^.firstenum;
+         if sym = nil then
+          begin
+            definition^.firstenum := @self;
+            nextenum := nil;
+            exit;
+          end;
+         { reorder the symbols in increasing value }
+         if value < sym^.value then
+          begin
+            nextenum := sym;
+            definition^.firstenum := @self;
+          end
+         else
+          begin
+            while (sym^.value <= value) and assigned(sym^.nextenum) do
+             sym := sym^.nextenum;
+            nextenum := sym^.nextenum;
+            sym^.nextenum := @self;
+          end;
+      end;
+
+
+    procedure tenumsym.write;
+      begin
+         tsym.write;
+         writedefref(definition);
+         writelong(value);
+         current_ppu^.writeentry(ibenumsym);
+      end;
+
+
+{$ifdef GDB}
+    procedure tenumsym.concatstabto(asmlist : paasmoutput);
+    begin
+    {enum elements have no stab !}
+    end;
+{$EndIf GDB}
+
+
+{****************************************************************************
+                                  TTYPESYM
+****************************************************************************}
+
+    constructor ttypesym.init(const n : string;const tt : ttype);
+
+      begin
+         tsym.init(n);
+         typ:=typesym;
+         restype:=tt;
+{$ifdef GDB}
+         isusedinstab := false;
+{$endif GDB}
+{$ifdef SYNONYM}
+         if assigned(restype.def) then
+          begin
+             if not(assigned(restype.def^.typesym)) then
+               begin
+                  restype.def^.typesym:=@self;
+                  synonym:=nil;
+                  include(symoptions,sp_primary_typesym);
+               end
+             else
+               begin
+                  synonym:=restype.def^.typesym^.synonym;
+                  restype.def^.typesym^.synonym:=@self;
+               end;
+          end;
+{$else}
+        { register the typesym for the definition }
+        if assigned(restype.def) and
+           not(assigned(restype.def^.typesym)) then
+         restype.def^.typesym:=@self;
+{$endif}
+      end;
+
+    constructor ttypesym.initdef(const n : string;d : pdef);
+      var
+        t : ttype;
+      begin
+        t.setdef(d);
+        ttypesym.init(n,t);
+      end;
+
+    constructor ttypesym.load;
+      begin
+         tsym.load;
+         typ:=typesym;
+{$ifdef SYNONYM}
+         synonym:=nil;
+{$endif}
+{$ifdef GDB}
+         isusedinstab := false;
+{$endif GDB}
+         restype.load;
+      end;
+
+{$ifdef SYNONYM}
+    destructor ttypesym.done;
+      var
+        prevsym : ptypesym;
+      begin
+         if assigned(restype.def) then
+           begin
+              prevsym:=restype.def^.typesym;
+              if prevsym=@self then
+                restype.def^.typesym:=synonym;
+              while assigned(prevsym) do
+                begin
+                   if (prevsym^.synonym=@self) then
+                     begin
+                        prevsym^.synonym:=synonym;
+                        break;
+                     end;
+                   prevsym:=prevsym^.synonym;
+                end;
+           end;
+         synonym:=nil;
+         inherited done;
+      end;
+{$endif}
+
+
+    procedure ttypesym.prederef;
+      begin
+         restype.resolve;
+{$ifdef SYNONYM}
+         if assigned(restype.def) then
+          begin
+            if (sp_primary_typesym in symoptions) then
+              begin
+                 if restype.def^.typesym<>@self then
+                   synonym:=restype.def^.typesym;
+                 restype.def^.typesym:=@self;
+              end
+            else
+              begin
+                 if assigned(restype.def^.typesym) then
+                   begin
+                      synonym:=restype.def^.typesym^.synonym;
+                      if restype.def^.typesym<>@self then
+                        restype.def^.typesym^.synonym:=@self;
+                   end
+                 else
+                   restype.def^.typesym:=@self;
+              end;
+            if (restype.def^.deftype=recorddef) and assigned(precorddef(restype.def)^.symtable) and
+               (restype.def^.typesym=@self) then
+              precorddef(restype.def)^.symtable^.name:=stringdup('record '+name);
+          end;
+{$endif}
+         {KAZ: another test for system unit: current_module^.used_units.first is nil iif system unit}
+         if not assigned(rec_tguid) and { system unit loaded first and TGUID be defined in system unit }
+            (_name^='TGUID') and { name: TGUID and size=16 bytes that is 128 bits }
+            assigned(restype.def) and (restype.def^.size=16) then
+           rec_tguid:=precorddef(restype.def);
+      end;
+
+
+    procedure ttypesym.write;
+      begin
+         tsym.write;
+         restype.write;
+         current_ppu^.writeentry(ibtypesym);
+      end;
+
+
+    procedure ttypesym.load_references;
+      begin
+         inherited load_references;
+         if (restype.def^.deftype=recorddef) then
+           precorddef(restype.def)^.symtable^.load_browser;
+         if (restype.def^.deftype=objectdef) then
+           pobjectdef(restype.def)^.symtable^.load_browser;
+      end;
+
+
+    function ttypesym.write_references : boolean;
+      begin
+        if not inherited write_references then
+         { write address of this symbol if record or object
+           even if no real refs are there
+           because we need it for the symtable }
+         if (restype.def^.deftype=recorddef) or
+            (restype.def^.deftype=objectdef) then
+          begin
+            writesymref(@self);
+            current_ppu^.writeentry(ibsymref);
+          end;
+         write_references:=true;
+         if (restype.def^.deftype=recorddef) then
+           precorddef(restype.def)^.symtable^.write_browser;
+         if (restype.def^.deftype=objectdef) then
+           pobjectdef(restype.def)^.symtable^.write_browser;
+      end;
+
+
+{$ifdef BrowserLog}
+    procedure ttypesym.add_to_browserlog;
+      begin
+         inherited add_to_browserlog;
+         if (restype.def^.deftype=recorddef) then
+           precorddef(restype.def)^.symtable^.writebrowserlog;
+         if (restype.def^.deftype=objectdef) then
+           pobjectdef(restype.def)^.symtable^.writebrowserlog;
+      end;
+{$endif BrowserLog}
+
+
+{$ifdef GDB}
+    function ttypesym.stabstring : pchar;
+    var
+      stabchar : string[2];
+      short : string;
+    begin
+      if restype.def^.deftype in tagtypes then
+        stabchar := 'Tt'
+      else
+        stabchar := 't';
+      short := '"'+name+':'+stabchar+restype.def^.numberstring
+               +'",'+tostr(N_LSYM)+',0,'+tostr(fileinfo.line)+',0';
+      stabstring := strpnew(short);
+    end;
+
+    procedure ttypesym.concatstabto(asmlist : paasmoutput);
+      begin
+      {not stabs for forward defs }
+      if assigned(restype.def) then
+        if (restype.def^.typesym = @self) then
+          restype.def^.concatstabto(asmlist)
+        else
+          inherited concatstabto(asmlist);
+      end;
+{$endif GDB}
+
+
+{****************************************************************************
+                                  TSYSSYM
+****************************************************************************}
+
+    constructor tsyssym.init(const n : string;l : longint);
+      begin
+         inherited init(n);
+         typ:=syssym;
+         number:=l;
+      end;
+
+    constructor tsyssym.load;
+      begin
+         tsym.load;
+         typ:=syssym;
+         number:=readlong;
+      end;
+
+    destructor tsyssym.done;
+      begin
+        inherited done;
+      end;
+
+    procedure tsyssym.write;
+      begin
+         tsym.write;
+         writelong(number);
+         current_ppu^.writeentry(ibsyssym);
+      end;
+
+{$ifdef GDB}
+    procedure tsyssym.concatstabto(asmlist : paasmoutput);
+      begin
+      end;
+{$endif GDB}
+
+
+{****************************************************************************
+                                  TMACROSYM
+****************************************************************************}
+
+    constructor tmacrosym.init(const n : string);
+      begin
+         inherited init(n);
+         typ:=macrosym;
+         defined:=true;
+         defined_at_startup:=false;
+         is_used:=false;
+         buftext:=nil;
+         buflen:=0;
+      end;
+
+    destructor tmacrosym.done;
+      begin
+         if assigned(buftext) then
+           freemem(buftext,buflen);
+         inherited done;
+      end;
+
+
+{
+  $Log$
+  Revision 1.13  2000-11-04 14:25:22  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.12  2000/10/31 22:02:52  peter
+    * symtable splitted, no real code changes
+
+  Revision 1.11  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.10  2000/10/15 07:47:53  peter
+    * unit names and procedure names are stored mixed case
+
+  Revision 1.9  2000/09/24 21:19:52  peter
+    * delphi compile fixes
+
+  Revision 1.8  2000/09/19 23:08:03  pierre
+   * fixes for local class debuggging problem (merged)
+
+  Revision 1.7  2000/08/27 20:19:39  peter
+    * store strings with case in ppu, when an internal symbol is created
+      a '$' is prefixed so it's not automatic uppercased
+
+  Revision 1.6  2000/08/21 11:27:44  pierre
+   * fix the stabs problems
+
+  Revision 1.5  2000/08/16 13:06:07  florian
+    + support of 64 bit integer constants
+
+  Revision 1.4  2000/08/13 12:54:56  peter
+    * class member decl wrong then no other error after it
+    * -vb has now also line numbering
+    * -vb is also used for interface/implementation different decls and
+      doesn't list the current function (merged)
+
+  Revision 1.3  2000/07/13 12:08:27  michael
+  + patched to 1.1.0 with former 1.09patch from peter
+
+  Revision 1.2  2000/07/13 11:32:49  michael
+  + removed logs
+
+}

compiler/symtable.pas

@@ -120,13 +120,24 @@ interface
        lastsrsym      : psym;           { last sym found in statement }
        lastsrsymtable : psymtable;
        lastsymknown   : boolean;
-
        constsymtable  : psymtable;      { symtable were the constants can be inserted }
-
        systemunit     : punitsymtable;  { pointer to the system unit }
-
        read_member : boolean;      { reading members of an symtable }
 
+       aktprocsym : pprocsym;      { pointer to the symbol for the
+                                     currently be parsed procedure }
+
+       aktcallprocsym : pprocsym;  { pointer to the symbol for the
+                                     currently be called procedure,
+                                     only set/unset in firstcall }
+
+       aktvarsym : pvarsym;     { pointer to the symbol for the
+                                     currently read var, only used
+                                     for variable directives }
+
+       procprefix : string;     { eindeutige Namen bei geschachtel- }
+                                   { ten Unterprogrammen erzeugen      }
+
        lexlevel : longint;       { level of code                     }
                                    { 1 for main procedure             }
                                    { 2 for normal function or proc     }
@@ -218,6 +229,8 @@ implementation
 {$ifdef GDB}
       gdb,
 {$endif GDB}
+      { type helpers }
+      types,
       { scanner }
       scanner,
       { codegen }
@@ -309,12 +322,12 @@ implementation
              begin
                 if (psym(p)^.owner^.symtabletype=parasymtable) then
                   begin
-                    if (pvarsym(p)^.varspez<>vs_var)  then
+                    if not(pvarsym(p)^.varspez in [vs_var,vs_out])  then
                       MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_only_set,p^.name)
                   end
                 else if (vo_is_local_copy in pvarsym(p)^.varoptions) then
                   begin
-                    if (pvarsym(p)^.varspez<>vs_var) then
+                    if not(pvarsym(p)^.varspez in [vs_var,vs_out]) then
                       MessagePos1(psym(p)^.fileinfo,sym_h_para_identifier_only_set,p^.name);
                   end
                 else if (psym(p)^.owner^.symtabletype=objectsymtable) then
@@ -1038,7 +1051,7 @@ implementation
                    { delphi allows to reuse the names in a class, but not
                      in object (tp7 compatible) }
                    if not((m_delphi in aktmodeswitches) and
-                          (pobjectdef(next^.next^.defowner)^.is_class)) then
+                          is_class(pdef(next^.next^.defowner))) then
                     begin
                       DuplicateSym(hsym);
                       exit;
@@ -1065,7 +1078,7 @@ implementation
                    { delphi allows to reuse the names in a class, but not
                      in object (tp7 compatible) }
                    if not((m_delphi in aktmodeswitches) and
-                          (procinfo^._class^.is_class)) then
+                          is_class(procinfo^._class)) then
                     begin
                       DuplicateSym(hsym);
                       exit;
@@ -2353,11 +2366,47 @@ implementation
 end.
 {
   $Log$
-  Revision 1.13  2000-11-01 23:04:38  peter
+  Revision 1.14  2000-11-04 14:25:22  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.13  2000/11/01 23:04:38  peter
     * tprocdef.fullprocname added for better casesensitve writing of
       procedures
 
   Revision 1.12  2000/10/31 22:02:52  peter
     * symtable splitted, no real code changes
 
-}
+  Revision 1.11  2000/10/15 07:47:53  peter
+    * unit names and procedure names are stored mixed case
+
+  Revision 1.10  2000/10/14 10:14:53  peter
+    * moehrendorf oct 2000 rewrite
+
+  Revision 1.9  2000/10/01 19:48:25  peter
+    * lot of compile updates for cg11
+
+  Revision 1.8  2000/09/24 15:06:29  peter
+    * use defines.inc
+
+  Revision 1.7  2000/08/27 16:11:54  peter
+    * moved some util functions from globals,cobjects to cutils
+    * splitted files into finput,fmodule
+
+  Revision 1.6  2000/08/21 11:27:45  pierre
+   * fix the stabs problems
+
+  Revision 1.5  2000/08/20 14:58:41  peter
+    * give fatal if objfpc/delphi mode things are found (merged)
+
+  Revision 1.4  2000/08/16 18:33:54  peter
+    * splitted namedobjectitem.next into indexnext and listnext so it
+      can be used in both lists
+    * don't allow "word = word" type definitions (merged)
+
+  Revision 1.3  2000/08/08 19:28:57  peter
+    * memdebug/memory patches (merged)
+    * only once illegal directive (merged)
+
+  Revision 1.2  2000/07/13 11:32:50  michael
+  + removed logs
+}

compiler/temp_gen.pas

@@ -31,7 +31,9 @@ interface
       hcodegen,verbose,fmodule,aasm;
 
     type
-      ttemptype = (tt_none,tt_free,tt_normal,tt_persistant,tt_ansistring,tt_freeansistring,tt_widestring,tt_freewidestring);
+      ttemptype = (tt_none,tt_free,tt_normal,tt_persistant,
+                   tt_ansistring,tt_freeansistring,tt_widestring,tt_freewidestring,
+                   tt_interfacecom,tt_freeinterfacecom);
       ttemptypeset = set of ttemptype;
 
       ptemprecord = ^ttemprecord;
@@ -72,9 +74,12 @@ interface
     procedure gettempofsizereference(l : longint;var ref : treference);
     function istemp(const ref : treference) : boolean;
     procedure ungetiftemp(const ref : treference);
+
     function ungetiftempansi(const ref : treference) : boolean;
     procedure gettempansistringreference(var ref : treference);
 
+    function ungetiftempintfcom(const ref : treference) : boolean;
+    procedure gettempintfcomreference(var ref : treference);
 
   implementation
 
@@ -293,19 +298,19 @@ const
       end;
 
 
-    procedure gettempansistringreference(var ref : treference);
+    procedure gettemppointerreferencefortype(var ref : treference; const usedtype, freetype: ttemptype);
       var
          foundslot,tl : ptemprecord;
       begin
          { do a reset, because the reference isn't used }
          reset_reference(ref);
          ref.base:=procinfo^.framepointer;
-         { Reuse old ansi slot ? }
+         { Reuse old slot ? }
          foundslot:=nil;
          tl:=templist;
          while assigned(tl) do
           begin
-            if tl^.temptype=tt_freeansistring then
+            if tl^.temptype=freetype then
              begin
                foundslot:=tl;
 {$ifdef EXTDEBUG}
@@ -317,16 +322,8 @@ const
           end;
          if assigned(foundslot) then
           begin
-            foundslot^.temptype:=tt_ansistring;
+            foundslot^.temptype:=usedtype;
             ref.offset:=foundslot^.pos;
-            { we're reusing an old slot then set the function result to true
-              so that we can call a decr_ansistr }
-
-            { we never know if a slot was used previously:
-              imagine a loop: in the first run the slot wasn't used
-              while in later runs it is reused (FK)
-            gettempansistringreference:=true;
-            }
           end
          else
           begin
@@ -334,37 +331,32 @@ const
 {$ifdef EXTDEBUG}
             templist^.posinfo:=aktfilepos;
 {$endif}
-            templist^.temptype:=tt_ansistring;
-            { set result to false, we don't need an decr_ansistr
-              gettempansistringreference:=true;
-              Not necessary, the above (FK)
-            }
+            templist^.temptype:=usedtype;
           end;
          exprasmlist^.concat(new(paitempalloc,alloc(ref.offset,target_os.size_of_pointer)));
       end;
 
-
-    function ungetiftempansi(const ref : treference) : boolean;
+    function ungettemppointeriftype(const ref : treference; const usedtype, freetype: ttemptype) : boolean;
       var
          tl : ptemprecord;
       begin
-        ungetiftempansi:=false;
+        ungettemppointeriftype:=false;
         tl:=templist;
         while assigned(tl) do
          begin
            if tl^.pos=ref.offset then
             begin
-              if tl^.temptype=tt_ansistring then
+              if tl^.temptype=usedtype then
                begin
-                 tl^.temptype:=tt_freeansistring;
-                 ungetiftempansi:=true;
+                 tl^.temptype:=freetype;
+                 ungettemppointeriftype:=true;
                  exprasmlist^.concat(new(paitempalloc,dealloc(tl^.pos,tl^.size)));
                  exit;
 {$ifdef EXTDEBUG}
                end
-              else if (tl^.temptype=tt_freeansistring) then
+              else if (tl^.temptype=freetype) then
                begin
-                 Comment(V_Debug,'temp ansi managment problem : ungetiftempansi()'+
+                 Comment(V_Debug,'temp managment problem : ungettemppointeriftype()'+
                      ' at pos '+tostr(ref.offset)+ ' already free !');
 {$endif}
                end;
@@ -373,6 +365,29 @@ const
          end;
       end;
 
+
+    procedure gettempansistringreference(var ref : treference);
+      begin
+        gettemppointerreferencefortype(ref,tt_ansistring,tt_freeansistring);
+      end;
+
+    function ungetiftempansi(const ref : treference) : boolean;
+      begin
+        ungetiftempansi:=ungettemppointeriftype(ref,tt_ansistring,tt_freeansistring);
+      end;
+
+
+    procedure gettempintfcomreference(var ref : treference);
+      begin
+        gettemppointerreferencefortype(ref,tt_interfacecom,tt_freeinterfacecom);
+      end;
+
+
+    function ungetiftempintfcom(const ref : treference) : boolean;
+      begin
+        ungetiftempintfcom:=ungettemppointeriftype(ref,tt_ansistring,tt_freeansistring);
+      end;
+
     function istemp(const ref : treference) : boolean;
 
       begin
@@ -542,7 +557,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.5  2000-09-30 16:08:45  peter
+  Revision 1.6  2000-11-04 14:25:22  florian
+    + merged Attila's changes for interfaces, not tested yet
+
+  Revision 1.5  2000/09/30 16:08:45  peter
     * more cg11 updates
 
   Revision 1.4  2000/09/24 15:06:31  peter

compiler/types.pas

@@ -174,7 +174,9 @@ interface
           tc_proc_2_procvar,
           tc_arrayconstructor_2_set,
           tc_load_smallset,
-          tc_cord_2_pointer
+          tc_cord_2_pointer,
+          tc_intf_2_string,
+          tc_intf_2_guid
        );
 
     function assignment_overloaded(from_def,to_def : pdef) : pprocdef;
@@ -184,7 +186,8 @@ interface
        1 - Convertable
        2 - Convertable, but not first choice }
     function isconvertable(def_from,def_to : pdef;
-             var doconv : tconverttype;fromtreetype : tnodetype;
+             var doconv : tconverttype;
+             fromtree: tnode; fromtreetype : tnodetype;
              explicit : boolean) : byte;
 
     { same as is_equal, but with error message if failed }
@@ -234,7 +237,7 @@ implementation
 
     uses
        globtype,globals,tokens,verbose,
-       symconst,symtable;
+       symconst,symtable,nld;
 
     var
        b_needs_init_final : boolean;
@@ -243,8 +246,7 @@ implementation
       begin
          if (psym(p)^.typ=varsym) and
            assigned(pvarsym(p)^.vartype.def) and
-           not((pvarsym(p)^.vartype.def^.deftype=objectdef) and
-           pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and
+           not is_class(pvarsym(p)^.vartype.def) and
            pstoreddef(pvarsym(p)^.vartype.def)^.needs_inittable then
            b_needs_init_final:=true;
       end;
@@ -380,7 +382,7 @@ implementation
               case acp of
               cp_value_equal_const :
                 begin
-                   if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) or
+                   if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,nil,callparan,false)=0) or
                      ((def1^.paratyp<>def2^.paratyp) and
                       ((def1^.paratyp in [vs_out,vs_var]) or
                        (def2^.paratyp in [vs_out,vs_var])
@@ -393,7 +395,7 @@ implementation
                 end;
               cp_all :
                 begin
-                   if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) or
+                   if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,nil,callparan,false)=0) or
                      (def1^.paratyp<>def2^.paratyp) then
                      begin
                         convertable_paras:=false;
@@ -402,7 +404,7 @@ implementation
                 end;
               cp_none :
                 begin
-                   if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,callparan,false)=0) then
+                   if (isconvertable(def1^.paratype.def,def2^.paratype.def,doconv,nil,callparan,false)=0) then
                      begin
                         convertable_paras:=false;
                         exit;
@@ -695,7 +697,7 @@ implementation
          ret_in_acc:=(def^.deftype in [orddef,pointerdef,enumdef,classrefdef]) or
                      ((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_ansistring,st_widestring])) or
                      ((def^.deftype=procvardef) and not(po_methodpointer in pprocvardef(def)^.procoptions)) or
-                     ((def^.deftype=objectdef) and pobjectdef(def)^.is_class) or
+                     not is_object(def) or
                      ((def^.deftype=setdef) and (psetdef(def)^.settype=smallset)) or
                      ((def^.deftype=floatdef) and (pfloatdef(def)^.typ=f32bit));
       end;
@@ -714,7 +716,7 @@ implementation
          ret_in_param:=(def^.deftype in [arraydef,recorddef]) or
            ((def^.deftype=stringdef) and (pstringdef(def)^.string_typ in [st_shortstring,st_longstring])) or
            ((def^.deftype=procvardef) and (po_methodpointer in pprocvardef(def)^.procoptions)) or
-           ((def^.deftype=objectdef) and not(pobjectdef(def)^.is_class)) or
+           is_object(def) or
            ((def^.deftype=setdef) and (psetdef(def)^.settype<>smallset));
       end;
 
@@ -746,7 +748,7 @@ implementation
                                 is_array_of_const(def) or
                                 is_array_constructor(def);
              objectdef :
-               push_addr_param:=not(pobjectdef(def)^.is_class);
+               push_addr_param:=is_object(def);
              stringdef :
                push_addr_param:=pstringdef(def)^.string_typ in [st_shortstring,st_longstring];
              procvardef :
@@ -1184,7 +1186,7 @@ implementation
             begin
               if is_equal(passproc^.rettype.def,to_def) and
                  (is_equal(pparaitem(passproc^.para^.first)^.paratype.def,from_def) or
-                 (isconvertable(from_def,pparaitem(passproc^.para^.first)^.paratype.def,convtyp,ordconstn,false)=1)) then
+                 (isconvertable(from_def,pparaitem(passproc^.para^.first)^.paratype.def,convtyp,nil,ordconstn,false)=1)) then
                 begin
                    assignment_overloaded:=passproc;
                    break;
@@ -1199,7 +1201,8 @@ implementation
        1 - Convertable
        2 - Convertable, but not first choice }
     function isconvertable(def_from,def_to : pdef;
-             var doconv : tconverttype;fromtreetype : tnodetype;
+             var doconv : tconverttype;
+             fromtree: tnode; fromtreetype : tnodetype;
              explicit : boolean) : byte;
 
       { Tbasetype:  uauto,uvoid,uchar,
@@ -1398,7 +1401,7 @@ implementation
                             end
                            else
                             if isconvertable(parraydef(def_from)^.elementtype.def,
-                                             parraydef(def_to)^.elementtype.def,hct,arrayconstructorn,false)<>0 then
+                                             parraydef(def_to)^.elementtype.def,hct,nil,arrayconstructorn,false)<>0 then
                              begin
                                doconv:=hct;
                                b:=2;
@@ -1508,7 +1511,7 @@ implementation
                      { class types and class reference type
                        can be assigned to void pointers      }
                      if (
-                         ((def_from^.deftype=objectdef) and pobjectdef(def_from)^.is_class) or
+                         is_class_or_interface(def_from) or
                          (def_from^.deftype=classrefdef)
                         ) and
                         (ppointerdef(def_to)^.pointertype.def^.deftype=orddef) and
@@ -1572,7 +1575,7 @@ implementation
                 end
                else
                { Class specific }
-                if (pobjectdef(def_to)^.is_class) then
+                if is_class_or_interface(def_to) then
                  begin
                    { void pointer also for delphi mode }
                    if (m_delphi in aktmodeswitches) and
@@ -1583,7 +1586,7 @@ implementation
                     end
                    else
                    { nil is compatible with class instances }
-                    if (fromtreetype=niln) and (pobjectdef(def_to)^.is_class) then
+                    if (fromtreetype=niln) and is_class(def_to) then
                      begin
                        doconv:=tc_equal;
                        b:=1;
@@ -1648,9 +1651,20 @@ implementation
 
            else
              begin
-             { assignment overwritten ?? }
-               if assignment_overloaded(def_from,def_to)<>nil then
-                b:=2;
+                { Interface 2 GUID handling }
+                if (def_from^.deftype=errordef) and (def_to=pdef(rec_tguid)) and
+                   assigned(fromtree) and (fromtree.nodetype=typen) and
+                   assigned(ttypenode(fromtree).typenodetype) and
+                   is_interface(ttypenode(fromtree).typenodetype) and
+                   pobjectdef(ttypenode(fromtree).typenodetype)^.isiidguidvalid then
+                  begin
+                    b:=1;
+                    doconv:=tc_equal;
+                  end
+                else
+                  { assignment overwritten ?? }
+                  if assignment_overloaded(def_from,def_to)<>nil then
+                    b:=2;
              end;
          end;
         isconvertable:=b;
@@ -1686,7 +1700,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.17  2000-10-31 22:30:13  peter
+  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