* rtti/init table updates

  * rttisym for reusable global rtti/init info
  * support published for interfaces

compiler/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 1.1 [2001/08/22]
+# Don't edit, this file is generated by FPCMake Version 1.1 [2001/08/30]
 #
 default: all
 override PATH:=$(subst \,/,$(PATH))
@@ -681,15 +681,22 @@ override FPCOPT+=-gl
 override FPCOPTDEF+=DEBUG
 endif
 ifdef RELEASE
-override FPCOPT+=-Xs -OG2p3 -n
+ifeq ($(CPU_TARGET),i386)
+FPCCPUOPT:=-OG2p3
+else
+FPCCPUOPT:=
+endif
+override FPCOPT+=-Xs $(FPCCPUOPT) -n
 override FPCOPTDEF+=RELEASE
 endif
 ifdef STRIP
 override FPCOPT+=-Xs
 endif
 ifdef OPTIMIZE
+ifeq ($(CPU_TARGET),i386)
 override FPCOPT+=-OG2p3
 endif
+endif
 ifdef VERBOSE
 override FPCOPT+=-vwni
 endif
@@ -865,7 +872,7 @@ endif
 ifdef LIB_NAME
 	-$(DEL) $(LIB_NAME) $(LIB_FULLNAME)
 endif
-	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE)
+	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
 fpc_distclean: clean
 ifdef COMPILER_UNITTARGETDIR
 TARGETDIRCLEAN=fpc_clean

compiler/i386/cga.pas

@@ -1646,11 +1646,10 @@ implementation
          else
            begin
               reset_reference(hr);
-              hr.symbol:=tstoreddef(t).get_inittable_label;
+              hr.symbol:=tstoreddef(t).get_rtti_label(initrtti);
               emitpushreferenceaddr(hr);
               if is_already_ref then
-                exprasmList.concat(Taicpu.Op_ref(A_PUSH,S_L,
-                  newreference(ref)))
+                exprasmList.concat(Taicpu.Op_ref(A_PUSH,S_L,newreference(ref)))
               else
                 emitpushreferenceaddr(ref);
               emitcall('FPC_INITIALIZE');
@@ -1667,7 +1666,7 @@ implementation
 
       begin
          if is_ansistring(t) or
-           is_widestring(t) then
+            is_widestring(t) then
            begin
               decrstringref(t,ref);
            end
@@ -1678,7 +1677,7 @@ implementation
          else
            begin
               reset_reference(r);
-              r.symbol:=tstoreddef(t).get_inittable_label;
+              r.symbol:=tstoreddef(t).get_rtti_label(initrtti);
               emitpushreferenceaddr(r);
               if is_already_ref then
                 exprasmList.concat(Taicpu.Op_ref(A_PUSH,S_L,
@@ -1751,7 +1750,7 @@ implementation
                else
                  begin
                    reset_reference(hr);
-                   hr.symbol:=tstoreddef(tvarsym(p).vartype.def).get_inittable_label;
+                   hr.symbol:=tstoreddef(tvarsym(p).vartype.def).get_rtti_label(initrtti);
                    emitpushreferenceaddr(hr);
                    emitpushreferenceaddr(hrv);
                    emitcall('FPC_ADDREF');
@@ -1803,7 +1802,7 @@ implementation
                else
                  begin
                    reset_reference(hr);
-                   hr.symbol:=tstoreddef(tvarsym(p).vartype.def).get_inittable_label;
+                   hr.symbol:=tstoreddef(tvarsym(p).vartype.def).get_rtti_label(initrtti);
                    emitpushreferenceaddr(hr);
                    emitpushreferenceaddr(hrv);
                    emitcall('FPC_DECREF');
@@ -2561,7 +2560,7 @@ implementation
                    emitinsertcall('FPC_FINALIZE');
                    ungetregister32(R_EDI);
                    exprasmList.insert(Taicpu.Op_reg(A_PUSH,S_L,R_ESI));
-                   exprasmList.insert(Taicpu.Op_sym(A_PUSH,S_L,procinfo^._class.get_inittable_label));
+                   exprasmList.insert(Taicpu.Op_sym(A_PUSH,S_L,procinfo^._class.get_rtti_label(initrtti)));
                    ai:=Taicpu.Op_sym(A_Jcc,S_NO,nofinal);
                    ai.SetCondition(C_Z);
                    exprasmList.insert(ai);
@@ -2984,7 +2983,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.3  2001-08-29 12:01:47  jonas
+  Revision 1.4  2001-08-30 20:13:57  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.3  2001/08/29 12:01:47  jonas
     + support for int64 LOC_REGISTERS in remove_non_regvars_from_loc
 
   Revision 1.2  2001/08/26 13:36:52  florian

compiler/i386/n386inl.pas

@@ -522,19 +522,16 @@ implementation
 
             in_typeinfo_x:
                begin
-                  tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).generate_rtti;
                   location.register:=getregister32;
                   new(r);
                   reset_reference(r^);
-                  r^.symbol:=tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).rtti_label;
+                  r^.symbol:=tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).get_rtti_label(fullrtti);
                   emit_ref_reg(A_LEA,S_L,r,location.register);
                end;
 
              in_finalize_x:
                begin
                   pushusedregisters(pushed,$ff);
-                  { force rtti generation }
-                  tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).generate_rtti;
                   { if a count is passed, push size, typeinfo and count }
                   if assigned(tcallparanode(left).right) then
                     begin
@@ -547,7 +544,7 @@ implementation
 
                   { generate a reference }
                   reset_reference(hr);
-                  hr.symbol:=tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).rtti_label;
+                  hr.symbol:=tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).get_rtti_label(initrtti);
                   emitpushreferenceaddr(hr);
 
                   { data to finalize }
@@ -642,7 +639,7 @@ implementation
                        emitpushreferenceaddr(hr2);
                        push_int(l);
                        reset_reference(hr2);
-                       hr2.symbol:=tstoreddef(def).get_inittable_label;
+                       hr2.symbol:=tstoreddef(def).get_rtti_label(initrtti);
                        emitpushreferenceaddr(hr2);
                        emitpushreferenceaddr(tcallparanode(hp).left.location.reference);
                        saveregvars($ff);
@@ -882,7 +879,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.22  2001-08-28 13:24:47  jonas
+  Revision 1.23  2001-08-30 20:13:57  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.22  2001/08/28 13:24:47  jonas
     + compilerproc implementation of most string-related type conversions
     - removed all code from the compiler which has been replaced by
       compilerproc implementations (using {$ifdef hascompilerproc} is not

compiler/i386/n386ld.pas

@@ -643,7 +643,7 @@ implementation
                                    { increment source reference counter }
                                    new(r);
                                    reset_reference(r^);
-                                   r^.symbol:=tstoreddef(right.resulttype.def).get_inittable_label;
+                                   r^.symbol:=tstoreddef(right.resulttype.def).get_rtti_label(initrtti);
                                    emitpushreferenceaddr(r^);
 
                                    emitpushreferenceaddr(right.location.reference);
@@ -651,7 +651,7 @@ implementation
                                    { decrement destination reference counter }
                                    new(r);
                                    reset_reference(r^);
-                                   r^.symbol:=tstoreddef(left.resulttype.def).get_inittable_label;
+                                   r^.symbol:=tstoreddef(left.resulttype.def).get_rtti_label(initrtti);
                                    emitpushreferenceaddr(r^);
                                    emitpushreferenceaddr(left.location.reference);
                                    emitcall('FPC_DECREF');
@@ -1088,7 +1088,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.20  2001-08-30 11:57:20  michael
+  Revision 1.21  2001-08-30 20:13:57  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.20  2001/08/30 11:57:20  michael
   + Patch for wrong paramsize
 
   Revision 1.19  2001/08/26 13:36:59  florian

compiler/i386/n386mem.pas

@@ -149,7 +149,7 @@ implementation
                 begin
                    new(r);
                    reset_reference(r^);
-                   r^.symbol:=tstoreddef(tpointerdef(resulttype.def).pointertype.def).get_inittable_label;
+                   r^.symbol:=tstoreddef(tpointerdef(resulttype.def).pointertype.def).get_rtti_label(initrtti);
                    emitpushreferenceaddr(r^);
                    dispose(r);
                    { push pointer we just allocated, we need to initialize the
@@ -223,7 +223,7 @@ implementation
                   begin
                      new(r);
                      reset_reference(r^);
-                     r^.symbol:=tstoreddef(tpointerdef(left.resulttype.def).pointertype.def).get_inittable_label;
+                     r^.symbol:=tstoreddef(tpointerdef(left.resulttype.def).pointertype.def).get_rtti_label(initrtti);
                      emitpushreferenceaddr(r^);
                      dispose(r);
                      { push pointer adress }
@@ -243,7 +243,7 @@ implementation
                   begin
                      new(r);
                      reset_reference(r^);
-                     r^.symbol:=tstoreddef(tpointerdef(left.resulttype.def).pointertype.def).get_inittable_label;
+                     r^.symbol:=tstoreddef(tpointerdef(left.resulttype.def).pointertype.def).get_rtti_label(initrtti);
                      emitpushreferenceaddr(r^);
                      dispose(r);
                      emit_push_loc(left.location);
@@ -1055,7 +1055,12 @@ begin
 end.
 {
   $Log$
-  Revision 1.15  2001-08-26 13:37:00  florian
+  Revision 1.16  2001-08-30 20:13:57  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.15  2001/08/26 13:37:00  florian
     * some cg reorganisation
     * some PPC updates
 

compiler/link.pas

@@ -42,6 +42,7 @@ Type
       ExeCmd,
       DllCmd        : array[1..3] of string[100];
       ResName       : string[12];
+      ScriptName    : string[12];
       ExtraOptions  : string;
       DynamicLinker : string[100];
     end;
@@ -105,6 +106,7 @@ begin
 { set generic defaults }
   FillChar(Info,sizeof(Info),0);
   Info.ResName:='link.res';
+  Info.ScriptName:='script.res';
 { set the linker specific defaults }
   SetDefaultInfo;
 { Allow Parameter overrides for linker info }
@@ -483,7 +485,12 @@ initialization
 end.
 {
   $Log$
-  Revision 1.21  2001-08-19 11:22:22  peter
+  Revision 1.22  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.21  2001/08/19 11:22:22  peter
     * palmos support from v10 merged
 
   Revision 1.20  2001/08/13 19:26:03  peter

compiler/new/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 1.1 [2001/08/22]
+# Don't edit, this file is generated by FPCMake Version 1.1 [2001/08/30]
 #
 default: all
 override PATH:=$(subst \,/,$(PATH))
@@ -680,15 +680,22 @@ override FPCOPT+=-gl
 override FPCOPTDEF+=DEBUG
 endif
 ifdef RELEASE
-override FPCOPT+=-Xs -OG2p3 -n
+ifeq ($(CPU_TARGET),i386)
+FPCCPUOPT:=-OG2p3
+else
+FPCCPUOPT:=
+endif
+override FPCOPT+=-Xs $(FPCCPUOPT) -n
 override FPCOPTDEF+=RELEASE
 endif
 ifdef STRIP
 override FPCOPT+=-Xs
 endif
 ifdef OPTIMIZE
+ifeq ($(CPU_TARGET),i386)
 override FPCOPT+=-OG2p3
 endif
+endif
 ifdef VERBOSE
 override FPCOPT+=-vwni
 endif
@@ -864,7 +871,7 @@ endif
 ifdef LIB_NAME
 	-$(DEL) $(LIB_NAME) $(LIB_FULLNAME)
 endif
-	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE)
+	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
 fpc_distclean: clean
 ifdef COMPILER_UNITTARGETDIR
 TARGETDIRCLEAN=fpc_clean

compiler/nobj.pas

@@ -1146,7 +1146,6 @@ implementation
 {$endif WITHDMT}
          interfacetable : tasmlabel;
       begin
-
 {$ifdef WITHDMT}
          dmtlabel:=gendmt;
 {$endif WITHDMT}
@@ -1160,9 +1159,6 @@ implementation
           begin
             methodnametable:=genpublishedmethodstable;
             fieldtablelabel:=_class.generate_field_table;
-            { rtti }
-            if (oo_can_have_published in _class.objectoptions) then
-             _class.generate_rtti;
             { write class name }
             getdatalabel(classnamelabel);
             dataSegment.concat(Tai_label.Create(classnamelabel));
@@ -1234,20 +1230,11 @@ implementation
             dataSegment.concat(Tai_const_symbol.Create(fieldtablelabel));
             { pointer to type info of published section }
             if (oo_can_have_published in _class.objectoptions) then
-              dataSegment.concat(Tai_const_symbol.Createname(_class.rtti_name))
+              dataSegment.concat(Tai_const_symbol.Create(_class.get_rtti_label(fullrtti)))
             else
               dataSegment.concat(Tai_const.Create_32bit(0));
-            { inittable for con-/destruction }
-            {
-            if _class.needs_inittable then
-            }
-            { we generate the init table for classes always, because needs_inittable }
-            { for classes is always false, it applies only for objects               }
-            dataSegment.concat(Tai_const_symbol.Create(_class.get_inittable_label));
-            {
-            else
-              dataSegment.concat(Tai_const.Create_32bit(0));
-            }
+            { inittable for con-/destruction, for classes this is always generated }
+            dataSegment.concat(Tai_const_symbol.Create(_class.get_rtti_label(initrtti)));
             { auto table }
             dataSegment.concat(Tai_const.Create_32bit(0));
             { interface table }
@@ -1273,7 +1260,12 @@ initialization
 end.
 {
   $Log$
-  Revision 1.2  2001-08-22 21:16:20  florian
+  Revision 1.3  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.2  2001/08/22 21:16:20  florian
     * some interfaces related problems regarding
       mapping of interface implementions fixed
 

compiler/options.pas

@@ -1297,8 +1297,6 @@ end;
 procedure read_arguments(cmd:string);
 var
   configpath : pathstr;
-  s : string;
-  i : integer;
 begin
   option:=coption.create;
   disable_configfile:=false;
@@ -1597,7 +1595,12 @@ finalization
 end.
 {
   $Log$
-  Revision 1.56  2001-08-20 10:58:48  florian
+  Revision 1.57  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.56  2001/08/20 10:58:48  florian
     * renamed messages unit to cmsgs to avoid conflicts with the
       win32 messages unit
 

compiler/pdecl.pas

@@ -52,11 +52,11 @@ implementation
        globtype,tokens,verbose,
        systems,
        { aasm }
-       aasm,
+       aasm,fmodule,
        { symtable }
        symconst,symbase,symtype,symdef,symtable,
        { pass 1 }
-       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
+       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nobj,
        { parser }
        scanner,
        pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj;
@@ -374,8 +374,10 @@ implementation
          sym      : tsym;
          srsymtable : tsymtable;
          tt       : ttype;
+         oldfilepos,
          defpos,storetokenpos : tfileposinfo;
          old_block_type : tblock_type;
+         ch       : tclassheader;
       begin
          old_block_type:=block_type;
          block_type:=bt_type;
@@ -408,6 +410,7 @@ implementation
                     { the definition is modified }
                     object_dec(orgtypename,tobjectdef(ttypesym(sym).restype.def));
                     newtype:=ttypesym(sym);
+                    tt:=newtype.restype;
                   end;
                end;
             end;
@@ -437,15 +440,15 @@ implementation
                  assigned(tt.def) and (tt.def.deftype=recorddef) and (tt.def.size=16) then
                 rec_tguid:=trecorddef(tt.def);
             end;
-           if assigned(newtype.restype.def) then
+           if assigned(tt.def) then
             begin
-              case newtype.restype.def.deftype of
+              case tt.def.deftype of
                 pointerdef :
                   begin
                     consume(_SEMICOLON);
                     if try_to_consume(_FAR) then
                      begin
-                       tpointerdef(newtype.restype.def).is_far:=true;
+                       tpointerdef(tt.def).is_far:=true;
                        consume(_SEMICOLON);
                      end;
                   end;
@@ -465,6 +468,47 @@ implementation
                   consume(_SEMICOLON);
               end;
             end;
+
+           { Write tables if we are the typesym that defines
+             this type. This will not be done for simple type renamings }
+           if (tt.def.typesym=newtype) then
+            begin
+              { file position }
+              oldfilepos:=aktfilepos;
+              aktfilepos:=newtype.fileinfo;
+
+              { generate rtti info for classes, but not for forward classes }
+              if (tt.def.deftype=objectdef) and
+                 (oo_can_have_published in tobjectdef(tt.def).objectoptions) and
+                 not(oo_is_forward in tobjectdef(tt.def).objectoptions) then
+                generate_rtti(newtype);
+
+              { generate persistent init/final tables when it's declared in the interface so it can
+                be reused in other used }
+              if (not current_module.in_implementation) and
+                 (tt.def.needs_inittable or
+                  is_class(tt.def)) then
+                generate_inittable(newtype);
+
+              { for objects we should write the vmt and interfaces.
+                This need to be done after the rtti has been written, because
+                it can contain a reference to that data (PFV)
+                This is not for forward classes }
+              if (tt.def.deftype=objectdef) and
+                 not(oo_is_forward in tobjectdef(tt.def).objectoptions) then
+               begin
+                 if (cs_create_smart in aktmoduleswitches) then
+                   dataSegment.concat(Tai_cut.Create);
+                 ch:=cclassheader.create(tobjectdef(tt.def));
+                 if is_interface(tobjectdef(tt.def)) then
+                   ch.writeinterfaceids;
+                 if (oo_has_vmt in tobjectdef(tt.def).objectoptions) then
+                   ch.writevmt;
+                 ch.free;
+               end;
+
+              aktfilepos:=oldfilepos;
+            end;
          until token<>_ID;
          typecanbeforward:=false;
          symtablestack.foreach_static({$ifdef FPCPROCVAR}@{$endif}resolve_type_forward);
@@ -551,7 +595,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.31  2001-06-03 21:57:35  peter
+  Revision 1.32  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.31  2001/06/03 21:57:35  peter
     + hint directive parsing support
 
   Revision 1.30  2001/05/08 21:06:31  florian

compiler/pdecobj.pas

@@ -39,7 +39,7 @@ implementation
       globals,verbose,systems,tokens,
       aasm,symconst,symbase,symsym,symtable,types,
       cgbase,
-      node,nld,ncon,ncnv,nobj,pass_1,
+      node,nld,ncon,ncnv,pass_1,
       scanner,
       pbase,pexpr,pdecsub,pdecvar,ptype;
 
@@ -534,9 +534,10 @@ implementation
       procedure setclassattributes;
 
         begin
-           if classtype=odt_class then
+           { publishable }
+           if classtype in [odt_interfacecom,odt_class] then
              begin
-                aktclass.objecttype:=odt_class;
+                aktclass.objecttype:=classtype;
                 if (cs_generate_rtti in aktlocalswitches) or
                     (assigned(aktclass.childof) and
                      (oo_can_have_published in aktclass.childof.objectoptions)) then
@@ -829,7 +830,6 @@ implementation
 
       var
         temppd : tprocdef;
-        ch : tclassheader;
       begin
          {Nowadays aktprocsym may already have a value, so we need to save
           it.}
@@ -1007,9 +1007,6 @@ implementation
             until false;
             current_object_option:=[sp_public];
           end;
-         testcurobject:=0;
-         curobjectname:='';
-         typecanbeforward:=storetypecanbeforward;
 
          { generate vmt space if needed }
          if not(oo_has_vmt in aktclass.objectoptions) and
@@ -1017,19 +1014,14 @@ implementation
              (classtype in [odt_class])
             ) then
            aktclass.insertvmt;
-         if (cs_create_smart in aktmoduleswitches) then
-           dataSegment.concat(Tai_cut.Create);
-
-         ch:=cclassheader.create(aktclass);
-         if is_interface(aktclass) then
-           ch.writeinterfaceids;
-         if (oo_has_vmt in aktclass.objectoptions) then
-           ch.writevmt;
-         ch.free;
 
          if is_interface(aktclass) then
            setinterfacemethodoptions;
 
+         { reset }
+         testcurobject:=0;
+         curobjectname:='';
+         typecanbeforward:=storetypecanbeforward;
          { restore old state }
          symtablestack:=symtablestack.next;
          aktobjectdef:=nil;
@@ -1045,7 +1037,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.28  2001-08-26 13:36:44  florian
+  Revision 1.29  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.28  2001/08/26 13:36:44  florian
     * some cg reorganisation
     * some PPC updates
 

compiler/pdecvar.pas

@@ -170,7 +170,10 @@ implementation
               end
              else
               read_type(tt,'');
-             if (variantrecordlevel>0) and tt.def.needs_inittable then
+             { types that use init/final are not allowed in variant parts, but
+               classes are allowed }
+             if (variantrecordlevel>0) and
+                (tt.def.needs_inittable and not is_class(tt.def)) then
                Message(parser_e_cant_use_inittable_here);
              ignore_equal:=false;
              symdone:=false;
@@ -550,7 +553,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.18  2001-07-01 20:16:16  peter
+  Revision 1.19  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.18  2001/07/01 20:16:16  peter
     * alignmentinfo record added
     * -Oa argument supports more alignment settings that can be specified
       per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN

compiler/ppu.pas

@@ -91,6 +91,7 @@ const
   iblabelsym      = 30;
   ibfuncretsym    = 31;
   ibsyssym        = 32;
+  ibrttisym       = 33;
   {definitions}
   iborddef         = 40;
   ibpointerdef     = 41;
@@ -985,7 +986,12 @@ end;
 end.
 {
   $Log$
-  Revision 1.11  2001-06-27 21:37:36  peter
+  Revision 1.12  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.11  2001/06/27 21:37:36  peter
     * v10 merges
 
   Revision 1.10  2001/06/18 20:36:25  peter

compiler/psystem.pas

@@ -84,9 +84,13 @@ procedure insert_intern_types(p : tsymtable);
   all the types inserted into the system unit
 }
 
-  procedure addtype(const s:string;const t:ttype);
+  function addtype(const s:string;const t:ttype):ttypesym;
   begin
-    p.insert(ttypesym.create(s,t));
+    result:=ttypesym.create(s,t);
+    p.insert(result);
+    { add init/final table if required }
+    if t.def.needs_inittable then
+     generate_inittable(result);
   end;
 
   procedure adddef(const s:string;def:tdef);
@@ -271,7 +275,12 @@ end;
 end.
 {
   $Log$
-  Revision 1.18  2001-07-30 20:59:27  peter
+  Revision 1.19  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.18  2001/07/30 20:59:27  peter
     * m68k updates from v10 merged
 
   Revision 1.17  2001/07/09 21:15:41  peter

compiler/ptype.pas

@@ -59,6 +59,8 @@ implementation
        { global }
        globals,tokens,verbose,
        systems,
+       { aasm }
+       aasm,
        { symtable }
        symconst,symbase,symdef,symsym,symtable,types,
        { pass 1 }
@@ -602,7 +604,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.29  2001-08-12 22:10:16  peter
+  Revision 1.30  2001-08-30 20:13:53  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.29  2001/08/12 22:10:16  peter
     * write name in original case when type not found
 
   Revision 1.28  2001/07/09 21:15:41  peter

compiler/symconst.pas

@@ -110,12 +110,8 @@ type
     sp_static,
     sp_hint_deprecated,
     sp_hint_platform,
-    sp_hint_library
-    { is there any use for this constants        }
-    { else sp_has_overloaded can be moved up  FK }
-    ,sp_7
-    ,sp_8
-    ,sp_9
+    sp_hint_library,
+    sp_has_overloaded
     ,sp_10
     ,sp_11
     ,sp_12
@@ -131,14 +127,13 @@ type
     ,sp_22
     ,sp_23
     ,sp_24
-    ,sp_has_overloaded
   );
   tsymoptions=set of tsymoption;
 
   { flags for a definition }
   tdefoption=(df_none,
-    df_need_rtti,          { the definitions needs rtti }
-    df_has_rtti            { the rtti is generated      }
+    df_has_inittable,           { init data has been generated }
+    df_has_rttitable            { rtti data has been generated }
     ,df_3
     ,df_4
     ,df_5
@@ -393,7 +388,7 @@ type
   tsymtyp = (abstractsym,varsym,typesym,procsym,unitsym,
              constsym,enumsym,typedconstsym,errorsym,syssym,
              labelsym,absolutesym,propertysym,funcretsym,
-             macrosym);
+             macrosym,rttisym);
 
   { State of the variable, if it's declared, assigned or used }
   tvarstate=(vs_none,
@@ -409,6 +404,11 @@ type
     constresourcestring,constwstring,constwchar
   );
 
+  { RTTI information to store }
+  trttitype = (
+    fullrtti,initrtti
+  );
+
 {$ifdef GDB}
 type
   tdefstabstatus = (
@@ -446,14 +446,19 @@ const
      ('abstractsym','variable','type','proc','unit',
       'const','enum','typed const','errorsym','system sym',
       'label','absolute','property','funcret',
-      'macrosym');
+      'macrosym','rttisym');
 
 implementation
 
 end.
 {
   $Log$
-  Revision 1.22  2001-08-19 21:11:21  florian
+  Revision 1.23  2001-08-30 20:13:54  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.22  2001/08/19 21:11:21  florian
     * some bugs fix:
       - overload; with external procedures fixed
       - better selection of routine to do an overloaded

compiler/symsym.pas

@@ -58,6 +58,7 @@ interface
           destructor destroy;override;
           procedure write(ppufile:tcompilerppufile);virtual;abstract;
           procedure writesym(ppufile:tcompilerppufile);
+          procedure deref;override;
           function  mangledname : string;override;
           procedure insert_in_data;virtual;
 {$ifdef GDB}
@@ -288,6 +289,17 @@ interface
 {$endif GDB}
        end;
 
+       { compiler generated symbol to point to rtti and init/finalize tables }
+       trttisym = class(tstoredsym)
+          lab     : tasmsymbol;
+          rttityp : trttitype;
+          constructor create(const n:string;rt:trttitype);
+          constructor load(ppufile:tcompilerppufile);
+          procedure write(ppufile:tcompilerppufile);override;
+          function  mangledname:string;override;
+          function  get_label:tasmsymbol;
+       end;
+
        { register variables }
        pregvarinfo = ^tregvarinfo;
        tregvarinfo = record
@@ -321,6 +333,12 @@ interface
        current_object_option : tsymoptions = [sp_public];
 
 
+    { rtti and init/final }
+    procedure generate_rtti(p:tsym);
+    procedure generate_inittable(p:tsym);
+
+
+
 implementation
 
     uses
@@ -394,6 +412,11 @@ implementation
       end;
 
 
+    procedure tstoredsym.deref;
+      begin
+      end;
+
+
     procedure tstoredsym.load_references(ppufile:tcompilerppufile;locals:boolean);
       var
         pos : tfileposinfo;
@@ -2237,10 +2260,144 @@ implementation
 {$endif GDB}
 
 
+{****************************************************************************
+                                  TRTTISYM
+****************************************************************************}
+
+    constructor trttisym.create(const n:string;rt:trttitype);
+      const
+        prefix : array[trttitype] of string[5]=('$rtti','$init');
+      begin
+        inherited create(prefix[rt]+n);
+        typ:=rttisym;
+        lab:=nil;
+        rttityp:=rt;
+      end;
+
+
+    constructor trttisym.load(ppufile:tcompilerppufile);
+      begin
+        inherited loadsym(ppufile);
+        typ:=rttisym;
+        lab:=nil;
+        rttityp:=trttitype(ppufile.getbyte);
+      end;
+
+
+    procedure trttisym.write(ppufile:tcompilerppufile);
+      begin
+         inherited writesym(ppufile);
+         ppufile.putbyte(byte(rttityp));
+         ppufile.writeentry(ibrttisym);
+      end;
+
+
+    function trttisym.mangledname : string;
+      const
+        prefix : array[trttitype] of string[5]=('RTTI_','INIT_');
+      var
+        s : string;
+        p : tsymtable;
+      begin
+        s:='';
+        p:=owner;
+        while assigned(p) and (p.symtabletype=localsymtable) do
+         begin
+           s:=s+'_'+p.defowner.name;
+           p:=p.defowner.owner;
+         end;
+        if not(p.symtabletype in [globalsymtable,staticsymtable]) then
+         internalerror(200108265);
+        mangledname:=prefix[rttityp]+p.name^+s+'$_'+Copy(name,5,255);
+      end;
+
+
+    function trttisym.get_label:tasmsymbol;
+      begin
+        { the label is always a global label }
+        if not assigned(lab) then
+         lab:=newasmsymboltype(mangledname,AB_GLOBAL,AT_DATA);
+        get_label:=lab;
+      end;
+
+
+    { persistent rtti generation }
+    procedure generate_rtti(p:tsym);
+      var
+        rsym : trttisym;
+        def  : tstoreddef;
+      begin
+        { rtti can only be generated for classes that are always typesyms }
+        if not(p.typ=typesym) then
+         internalerror(200108261);
+        def:=tstoreddef(ttypesym(p).restype.def);
+        { only create rtti once for each definition }
+        if not(df_has_rttitable in def.defoptions) then
+         begin
+           { definition should be in the same symtable as the symbol }
+           if p.owner<>def.owner then
+            internalerror(200108262);
+           { create rttisym }
+           rsym:=trttisym.create(p.name,fullrtti);
+           p.owner.insert(rsym);
+           { register rttisym in definition }
+           include(def.defoptions,df_has_rttitable);
+           def.rttitablesym:=rsym;
+           { write rtti data }
+           def.write_child_rtti_data(fullrtti);
+           rttiList.concat(Tai_symbol.Create(rsym.get_label,0));
+           def.write_rtti_data(fullrtti);
+           rttiList.concat(Tai_symbol_end.Create(rsym.get_label));
+         end;
+      end;
+
+
+    { persistent init table generation }
+    procedure generate_inittable(p:tsym);
+      var
+        rsym : trttisym;
+        def  : tstoreddef;
+      begin
+        { anonymous types are also allowed for records that can be varsym }
+        case p.typ of
+          typesym :
+            def:=tstoreddef(ttypesym(p).restype.def);
+          varsym :
+            def:=tstoreddef(tvarsym(p).vartype.def);
+          else
+            internalerror(200108263);
+        end;
+        { only create inittable once for each definition }
+        if not(df_has_inittable in def.defoptions) then
+         begin
+           { definition should be in the same symtable as the symbol }
+           if p.owner<>def.owner then
+            internalerror(200108264);
+           { create rttisym }
+           rsym:=trttisym.create(p.name,initrtti);
+           p.owner.insert(rsym);
+           { register rttisym in definition }
+           include(def.defoptions,df_has_inittable);
+           def.inittablesym:=rsym;
+           { write inittable data }
+           def.write_child_rtti_data(initrtti);
+           rttiList.concat(Tai_symbol.Create(rsym.get_label,0));
+           def.write_rtti_data(initrtti);
+           rttiList.concat(Tai_symbol_end.Create(rsym.get_label));
+         end;
+      end;
+
+
+
 end.
 {
   $Log$
-  Revision 1.19  2001-08-26 13:36:50  florian
+  Revision 1.20  2001-08-30 20:13:54  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.19  2001/08/26 13:36:50  florian
     * some cg reorganisation
     * some PPC updates
 

compiler/symtable.pas

@@ -381,6 +381,7 @@ implementation
                 ibunitsym : sym:=tunitsym.load(ppufile);
                iblabelsym : sym:=tlabelsym.load(ppufile);
                  ibsyssym : sym:=tsyssym.load(ppufile);
+                ibrttisym : sym:=trttisym.load(ppufile);
                 ibendsyms : break;
                     ibend : Message(unit_f_ppu_read_error);
            else
@@ -2071,7 +2072,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.42  2001-08-26 13:36:51  florian
+  Revision 1.43  2001-08-30 20:13:56  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.42  2001/08/26 13:36:51  florian
     * some cg reorganisation
     * some PPC updates
 

compiler/symtype.pas

@@ -64,9 +64,10 @@ interface
 
       tdef = class(tdefentry)
          typesym    : tsym;  { which type the definition was generated this def }
+         defoptions : tdefoptions;
          constructor create;
-         procedure deref;virtual;
-         procedure derefimpl;virtual;
+         procedure deref;virtual;abstract;
+         procedure derefimpl;virtual;abstract;
          function  typename:string;
          function  gettypename:string;virtual;
          function  size:longint;virtual;abstract;
@@ -74,7 +75,6 @@ interface
          function  getsymtable(t:tgetsymtable):tsymtable;virtual;
          function  is_publishable:boolean;virtual;abstract;
          function  needs_inittable:boolean;virtual;abstract;
-         function  get_rtti_label : string;virtual;abstract;
       end;
 
 {************************************************
@@ -89,7 +89,7 @@ interface
          constructor create(const n : string);
          destructor destroy;override;
          function  realname:string;
-         procedure deref;virtual;
+         procedure deref;virtual;abstract;
          function  gettypedef:tdef;virtual;
          function  mangledname : string;virtual;abstract;
       end;
@@ -153,6 +153,7 @@ implementation
          deftype:=abstractdef;
          owner := nil;
          typesym := nil;
+         defoptions:=[];
       end;
 
 
@@ -174,17 +175,6 @@ implementation
       end;
 
 
-    procedure tdef.deref;
-      begin
-        resolvesym(typesym);
-      end;
-
-
-    procedure tdef.derefimpl;
-      begin
-      end;
-
-
     function tdef.getsymtable(t:tgetsymtable):tsymtable;
       begin
         getsymtable:=nil;
@@ -203,6 +193,7 @@ implementation
           inherited createname(upper(n));
          _realname:=stringdup(n);
          typ:=abstractsym;
+         symoptions:=[];
       end;
 
 
@@ -213,11 +204,6 @@ implementation
       end;
 
 
-    procedure tsym.deref;
-      begin
-      end;
-
-
     function tsym.realname : string;
       begin
         if assigned(_realname) then
@@ -501,7 +487,12 @@ implementation
 end.
 {
   $Log$
-  Revision 1.8  2001-08-06 21:40:49  peter
+  Revision 1.9  2001-08-30 20:13:57  peter
+    * rtti/init table updates
+    * rttisym for reusable global rtti/init info
+    * support published for interfaces
+
+  Revision 1.8  2001/08/06 21:40:49  peter
     * funcret moved from tprocinfo to tprocdef
 
   Revision 1.7  2001/05/06 14:49:19  peter

compiler/utils/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 1.1 [2001/08/22]
+# Don't edit, this file is generated by FPCMake Version 1.1 [2001/08/30]
 #
 default: all
 override PATH:=$(subst \,/,$(PATH))
@@ -623,15 +623,22 @@ override FPCOPT+=-gl
 override FPCOPTDEF+=DEBUG
 endif
 ifdef RELEASE
-override FPCOPT+=-Xs -OG2p3 -n
+ifeq ($(CPU_TARGET),i386)
+FPCCPUOPT:=-OG2p3
+else
+FPCCPUOPT:=
+endif
+override FPCOPT+=-Xs $(FPCCPUOPT) -n
 override FPCOPTDEF+=RELEASE
 endif
 ifdef STRIP
 override FPCOPT+=-Xs
 endif
 ifdef OPTIMIZE
+ifeq ($(CPU_TARGET),i386)
 override FPCOPT+=-OG2p3
 endif
+endif
 ifdef VERBOSE
 override FPCOPT+=-vwni
 endif
@@ -828,7 +835,7 @@ endif
 ifdef LIB_NAME
 	-$(DEL) $(LIB_NAME) $(LIB_FULLNAME)
 endif
-	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE)
+	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
 fpc_distclean: clean
 ifdef COMPILER_UNITTARGETDIR
 TARGETDIRCLEAN=fpc_clean