+ first batch of patches to support tdef.getcopy fully

compiler/defcmp.pas

@@ -164,6 +164,7 @@ implementation
          hct : tconverttype;
          hd3 : tobjectdef;
          hpd : tprocdef;
+         hpe : tenumsym;
       begin
          eq:=te_incompatible;
          doconv:=tc_not_possible;
@@ -430,16 +431,27 @@ implementation
                       begin
                         hd1:=def_from;
                         while assigned(tenumdef(hd1).basedef) do
-                         hd1:=tenumdef(hd1).basedef;
+                          hd1:=tenumdef(hd1).basedef;
                         hd2:=def_to;
                         while assigned(tenumdef(hd2).basedef) do
-                         hd2:=tenumdef(hd2).basedef;
+                          hd2:=tenumdef(hd2).basedef;
                         if (hd1=hd2) then
-                         begin
-                           eq:=te_convert_l1;
-                           { because of packenum they can have different sizes! (JM) }
-                           doconv:=tc_int_2_int;
-                         end;
+                          begin
+                            eq:=te_convert_l1;
+                            { because of packenum they can have different sizes! (JM) }
+                            doconv:=tc_int_2_int;
+                          end
+                        else
+                          begin
+                            { assignment of an enum symbol to an unique type? }
+                            if (fromtreetype=ordconstn) and
+                              (tenumsym(tenumdef(hd1).firstenum)=tenumsym(tenumdef(hd2).firstenum)) then
+                              begin
+                                { because of packenum they can have different sizes! (JM) }
+                                eq:=te_convert_l1;
+                                doconv:=tc_int_2_int;
+                              end;
+                          end;
                       end;
                    end;
                  orddef :
@@ -1311,7 +1323,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.62  2004-12-05 12:28:10  peter
+  Revision 1.63  2005-01-03 17:55:57  florian
+    + first batch of patches to support tdef.getcopy fully
+
+  Revision 1.62  2004/12/05 12:28:10  peter
     * procvar handling for tp procvar mode fixed
     * proc to procvar moved from addrnode to typeconvnode
     * inlininginfo is now allocated only for inline routines that

compiler/ncnv.pas

@@ -46,6 +46,7 @@ interface
           procedure buildderefimpl;override;
           procedure derefimpl;override;
           function getcopy : tnode;override;
+          procedure printnodeinfo(var t : text);override;
           function pass_1 : tnode;override;
           function det_resulttype:tnode;override;
           procedure mark_write;override;
@@ -567,10 +568,8 @@ implementation
 
 
     function ttypeconvnode.getcopy : tnode;
-
       var
          n : ttypeconvnode;
-
       begin
          n:=ttypeconvnode(inherited getcopy);
          n.convtype:=convtype;
@@ -578,6 +577,51 @@ implementation
          getcopy:=n;
       end;
 
+    procedure ttypeconvnode.printnodeinfo(var t : text);
+      const
+        convtyp2str : array[tconverttype] of pchar = (
+          'tc_none',
+          'tc_equal',
+          'tc_not_possible',
+          'tc_string_2_string',
+          'tc_char_2_string',
+          'tc_char_2_chararray',
+          'tc_pchar_2_string',
+          'tc_cchar_2_pchar',
+          'tc_cstring_2_pchar',
+          'tc_ansistring_2_pchar',
+          'tc_string_2_chararray',
+          'tc_chararray_2_string',
+          'tc_array_2_pointer',
+          'tc_pointer_2_array',
+          'tc_int_2_int',
+          'tc_int_2_bool',
+          'tc_bool_2_bool',
+          'tc_bool_2_int',
+          'tc_real_2_real',
+          'tc_int_2_real',
+          'tc_real_2_currency',
+          'tc_proc_2_procvar',
+          'tc_arrayconstructor_2_set',
+          'tc_load_smallset',
+          'tc_cord_2_pointer',
+          'tc_intf_2_string',
+          'tc_intf_2_guid',
+          'tc_class_2_intf',
+          'tc_char_2_char',
+          'tc_normal_2_smallset',
+          'tc_dynarray_2_openarray',
+          'tc_pwchar_2_string',
+          'tc_variant_2_dynarray',
+          'tc_dynarray_2_variant',
+          'tc_variant_2_enum',
+          'tc_enum_2_variant'
+        );
+      begin
+        inherited printnodeinfo(t);
+        write(', convtype = ',strpas(convtyp2str[convtype]));
+      end;
+
 
     function ttypeconvnode.resulttype_cord_to_pointer : tnode;
 
@@ -2497,7 +2541,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.169  2004-12-27 16:54:29  peter
+  Revision 1.170  2005-01-03 17:55:57  florian
+    + first batch of patches to support tdef.getcopy fully
+
+  Revision 1.169  2004/12/27 16:54:29  peter
     * also don't call procvar when converting to procvar
 
   Revision 1.168  2004/12/26 16:22:01  peter

compiler/nflw.pas

@@ -338,6 +338,7 @@ implementation
         write(t,printnodeindention,'(');
         printnodeindent;
         printnodeinfo(t);
+        writeln(t);
         printnode(t,left);
         printnode(t,right);
         printnode(t,t1);
@@ -1424,7 +1425,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.103  2004-12-26 16:22:01  peter
+  Revision 1.104  2005-01-03 17:55:57  florian
+    + first batch of patches to support tdef.getcopy fully
+
+  Revision 1.103  2004/12/26 16:22:01  peter
     * fix lineinfo for with blocks
 
   Revision 1.102  2004/11/08 22:09:59  peter

compiler/node.pas

@@ -332,7 +332,7 @@ interface
           { writes a node for debugging purpose, shouldn't be called }
           { direct, because there is no test for nil, use printnode  }
           { to write a complete tree }
-          procedure printnodeinfo(var t:text);
+          procedure printnodeinfo(var t:text);virtual;
           procedure printnodedata(var t:text);virtual;
           procedure printnodetree(var t:text);virtual;
           procedure concattolist(l : tlinkedlist);virtual;
@@ -741,7 +741,7 @@ implementation
           write(t,', resulttype = "',resulttype.def.gettypename,'"')
         else
           write(t,', resulttype = <nil>');
-        writeln(t,', pos = (',fileinfo.line,',',fileinfo.column,')',
+        write(t,', pos = (',fileinfo.line,',',fileinfo.column,')',
                   ', loc = ',tcgloc2str[location.loc],
                   ', expectloc = ',tcgloc2str[expectloc],
                   ', intregs = ',registersint,
@@ -758,6 +758,7 @@ implementation
       begin
          write(t,printnodeindention,'(');
          printnodeinfo(t);
+         writeln(t);
          printnodeindent;
          printnodedata(t);
          printnodeunindent;
@@ -1095,6 +1096,7 @@ implementation
            printnodeindent;
            hp.printnodeinfo(t);
            printnode(t,hp.left);
+           writeln(t);
            printnodeunindent;
            writeln(t,printnodeindention,')');
            hp:=tbinarynode(hp.right);
@@ -1124,7 +1126,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.93  2004-12-26 16:22:01  peter
+  Revision 1.94  2005-01-03 17:55:57  florian
+    + first batch of patches to support tdef.getcopy fully
+
+  Revision 1.93  2004/12/26 16:22:01  peter
     * fix lineinfo for with blocks
 
   Revision 1.92  2004/12/05 12:28:11  peter

compiler/symdef.pas

@@ -113,6 +113,7 @@ interface
           constructor createuntyped;
           constructor createtyped(const tt : ttype);
           constructor ppuload(ppufile:tcompilerppufile);
+          function getcopy : tstoreddef;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderef;override;
           procedure deref;override;
@@ -130,6 +131,7 @@ interface
           varianttype : tvarianttype;
           constructor create(v : tvarianttype);
           constructor ppuload(ppufile:tcompilerppufile);
+          function getcopy : tstoreddef;override;
           function gettypename:string;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure setsize;
@@ -224,6 +226,7 @@ interface
           constructor create(p : tsymtable);
           constructor ppuload(ppufile:tcompilerppufile);
           destructor destroy;override;
+          function getcopy : tstoreddef;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderef;override;
           procedure deref;override;
@@ -278,6 +281,7 @@ interface
           constructor create(ot : tobjectdeftype;const n : string;c : tobjectdef);
           constructor ppuload(ppufile:tcompilerppufile);
           destructor  destroy;override;
+          function getcopy : tstoreddef;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           function gettypename:string;override;
           procedure buildderef;override;
@@ -373,6 +377,7 @@ interface
           constructor create_from_pointer(const elemt : ttype);
           constructor create(l,h : aint;const t : ttype);
           constructor ppuload(ppufile:tcompilerppufile);
+          function getcopy : tstoreddef;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           function  gettypename:string;override;
           function  getmangledparaname : string;override;
@@ -469,6 +474,7 @@ interface
        tprocvardef = class(tabstractprocdef)
           constructor create(level:byte);
           constructor ppuload(ppufile:tcompilerppufile);
+          function getcopy : tstoreddef;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderef;override;
           procedure deref;override;
@@ -658,6 +664,7 @@ interface
           constructor create_subrange(_basedef:tenumdef;_min,_max:aint);
           constructor ppuload(ppufile:tcompilerppufile);
           destructor destroy;override;
+          function getcopy : tstoreddef;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderef;override;
           procedure deref;override;
@@ -685,6 +692,7 @@ interface
           constructor create(const t:ttype;high : longint);
           constructor ppuload(ppufile:tcompilerppufile);
           destructor  destroy;override;
+          function getcopy : tstoreddef;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderef;override;
           procedure deref;override;
@@ -1326,6 +1334,7 @@ implementation
          savesize:=POINTER_SIZE;
       end;
 
+
     constructor tstringdef.loadansi(ppufile:tcompilerppufile;bits:Tstringbits);
       begin
          inherited ppuloaddef(ppufile);
@@ -1351,6 +1360,7 @@ implementation
          savesize:=sizeof(aint);
       end;
 
+
     constructor tstringdef.loadansi(ppufile:tcompilerppufile);
 
       begin
@@ -1643,6 +1653,7 @@ implementation
          correct_owner_symtable;
       end;
 
+
     constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:aint);
       begin
          inherited create;
@@ -1654,7 +1665,7 @@ implementation
          has_jumps:=false;
          firstenum:=basedef.firstenum;
          while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
-          firstenum:=tenumsym(firstenum).nextenum;
+           firstenum:=tenumsym(firstenum).nextenum;
          correct_owner_symtable;
       end;
 
@@ -1672,6 +1683,22 @@ implementation
       end;
 
 
+    function tenumdef.getcopy : tstoreddef;
+      begin
+        if assigned(basedef) then
+          result:=tenumdef.create_subrange(basedef,minval,maxval)
+        else
+          begin
+            result:=tenumdef.create;
+            tenumdef(result).minval:=minval;
+            tenumdef(result).maxval:=maxval;
+          end;
+        tenumdef(result).has_jumps:=has_jumps;
+        tenumdef(result).firstenum:=firstenum;
+        tenumdef(result).basedefderef:=basedefderef;
+      end;
+
+
     procedure tenumdef.calcsavesize;
       begin
         if (aktpackenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then
@@ -2220,6 +2247,21 @@ implementation
       end;
 
 
+    function tfiledef.getcopy : tstoreddef;
+      begin
+        case filetyp of
+          ft_typed:
+            result:=tfiledef.createtyped(typedfiletype);
+          ft_untyped:
+            result:=tfiledef.createuntyped;
+          ft_text:
+            result:=tfiledef.createtext;
+          else
+            internalerror(2004121201);
+        end;
+      end;
+
+
     procedure tfiledef.buildderef;
       begin
         inherited buildderef;
@@ -2373,6 +2415,12 @@ implementation
       end;
 
 
+    function tvariantdef.getcopy : tstoreddef;
+      begin
+        result:=tvariantdef.create(varianttype);
+      end;
+
+
     procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
       begin
          inherited ppuwritedef(ppufile);
@@ -2661,6 +2709,19 @@ implementation
       end;
 
 
+    function tsetdef.getcopy : tstoreddef;
+      begin
+        case settype of
+          smallset:
+            result:=tsetdef.create(elementtype,31);
+          normset:
+            result:=tsetdef.create(elementtype,255);
+          else
+            internalerror(2004121202);
+        end;
+      end;
+
+
     procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
       begin
          inherited ppuwritedef(ppufile);
@@ -2844,6 +2905,18 @@ implementation
       end;
 
 
+    function tarraydef.getcopy : tstoreddef;
+      begin
+        result:=tarraydef.create(lowrange,highrange,rangetype);
+        tarraydef(result).IsConvertedPointer:=IsConvertedPointer;
+        tarraydef(result).IsDynamicArray:=IsDynamicArray;
+        tarraydef(result).IsVariant:=IsVariant;
+        tarraydef(result).IsConstructor:=IsConstructor;
+        tarraydef(result).IsArrayOfConst:=IsArrayOfConst;
+        tarraydef(result)._elementtype:=_elementtype;
+      end;
+
+
     procedure tarraydef.buildderef;
       begin
         inherited buildderef;
@@ -3172,6 +3245,13 @@ implementation
       end;
 
 
+    function trecorddef.getcopy : tstoreddef;
+      begin
+        result:=trecorddef.create(symtable.getcopy);
+        trecorddef(result).isunion:=isunion;
+      end;
+
+
     function trecorddef.needs_inittable : boolean;
       begin
         needs_inittable:=trecordsymtable(symtable).needs_init_final
@@ -4450,6 +4530,34 @@ implementation
       end;
 
 
+    function tprocvardef.getcopy : tstoreddef;
+      begin
+      {
+          { saves a definition to the return type }
+          rettype         : ttype;
+          parast          : tsymtable;
+          paras           : tparalist;
+          proctypeoption  : tproctypeoption;
+          proccalloption  : tproccalloption;
+          procoptions     : tprocoptions;
+          requiredargarea : aint;
+          { number of user visibile parameters }
+          maxparacount,
+          minparacount    : byte;
+{$ifdef i386}
+          fpu_used        : longint;    { how many stack fpu must be empty }
+{$endif i386}
+          funcretloc : array[tcallercallee] of TLocation;
+          has_paraloc_info : boolean; { paraloc info is available }
+
+       tprocvardef = class(tabstractprocdef)
+          constructor create(level:byte);
+          constructor ppuload(ppufile:tcompilerppufile);
+          function getcopy : tstoreddef;override;
+       }
+      end;
+
+
     procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
       var
         oldparasymtable,
@@ -4796,21 +4904,45 @@ implementation
 {$endif GDB}
        end;
 
+    destructor tobjectdef.destroy;
+      begin
+         if assigned(symtable) then
+           symtable.free;
+         stringdispose(objname);
+         stringdispose(objrealname);
+         if assigned(iidstr) then
+           stringdispose(iidstr);
+         if assigned(implementedinterfaces) then
+           implementedinterfaces.free;
+         if assigned(iidguid) then
+           dispose(iidguid);
+         inherited destroy;
+      end;
+
 
-   destructor tobjectdef.destroy;
-     begin
-        if assigned(symtable) then
-          symtable.free;
-        stringdispose(objname);
-        stringdispose(objrealname);
-        if assigned(iidstr) then
-          stringdispose(iidstr);
-        if assigned(implementedinterfaces) then
-          implementedinterfaces.free;
-        if assigned(iidguid) then
-          dispose(iidguid);
-        inherited destroy;
-     end;
+    function tobjectdef.getcopy : tstoreddef;
+      begin
+        result:=inherited getcopy;
+      {
+        result:=tobjectdef.create(objecttype,objname^,childof);
+          childofderef  : tderef;
+          objname,
+          objrealname   : pstring;
+          objectoptions : tobjectoptions;
+          { to be able to have a variable vmt position }
+          { and no vmt field for objects without virtuals }
+          vmt_offset : longint;
+{$ifdef GDB}
+          writing_class_record_stab : boolean;
+{$endif GDB}
+          objecttype : tobjectdeftype;
+          iidguid: pguid;
+          iidstr: pstring;
+          lastvtableindex: longint;
+          { store implemented interfaces defs and name mappings }
+          implementedinterfaces: timplementedinterfaces;
+      }
+      end;
 
 
     procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
@@ -6189,7 +6321,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.286  2004-12-30 14:36:29  florian
+  Revision 1.287  2005-01-03 17:55:57  florian
+    + first batch of patches to support tdef.getcopy fully
+
+  Revision 1.286  2004/12/30 14:36:29  florian
     * alignment fixes for sparc
 
   Revision 1.285  2004/12/27 15:54:54  florian