* first fixes for published properties

compiler/pdecl.pas

@@ -1129,7 +1129,7 @@ unit pdecl;
            begin
               aktclass^.options:=aktclass^.options or oois_class;
 
-              if (cs_generate_rtti in aktmoduleswitches) or
+              if (cs_generate_rtti in aktlocalswitches) or
                   (assigned(aktclass^.childof) and
                    ((aktclass^.childof^.options and oo_can_have_published)<>0)
                   ) then
@@ -1312,6 +1312,7 @@ unit pdecl;
          testcurobject:=0;
          curobjectname:='';
 
+         aktclass^.generate_rtti;
          if (cs_smartlink in aktmoduleswitches) then
            datasegment^.concat(new(pai_cut,init));
          { write extended info for classes }
@@ -1335,7 +1336,7 @@ unit pdecl;
                 datasegment^.concat(new(pai_const,init_32bit(0)));
 
               { pointer to type info of published section }
-              datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(aktclass^.get_rtti_label)))));
+              datasegment^.concat(new(pai_const,init_symbol(strpnew(aktclass^.rtti_name))));
 
               { pointer to field table }
               datasegment^.concat(new(pai_const,init_32bit(0)));
@@ -1969,7 +1970,10 @@ unit pdecl;
 end.
 {
   $Log$
-  Revision 1.48  1998-09-04 08:42:02  peter
+  Revision 1.49  1998-09-07 17:37:00  florian
+    * first fixes for published properties
+
+  Revision 1.48  1998/09/04 08:42:02  peter
     * updated some error messages
 
   Revision 1.47  1998/09/03 16:03:18  florian

compiler/symdef.inc

@@ -2422,6 +2422,23 @@
         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 name=nil then
+         s2:=''
+       else
+         s2:=name^;
+       rtti_name:='RTTI_'+s1+'$_'+s2;
+    end;
+
     function tobjectdef.isclass : boolean;
       begin
          isclass:=(options and oois_class)<>0;
@@ -2636,7 +2653,12 @@
            typvalue : byte;
 
         begin
-           if sym^.typ=varsym then
+           if not(assigned(sym)) then
+             begin
+                rttilist^.concat(new(pai_const,init_32bit(1)));
+                typvalue:=3;
+             end
+           else if sym^.typ=varsym then
              begin
                 rttilist^.concat(new(pai_const,init_32bit(
                   pvarsym(sym)^.address)));
@@ -2666,7 +2688,14 @@
               rttilist^.concat(new(pai_const,init_symbol(strpnew(lab2str(ppropertysym(sym)^.proptype^.get_rtti_label)))));
               writeproc(ppropertysym(sym)^.readaccesssym,ppropertysym(sym)^.readaccessdef,0);
               writeproc(ppropertysym(sym)^.writeaccesssym,ppropertysym(sym)^.writeaccessdef,2);
-              writeproc(ppropertysym(sym)^.storedsym,ppropertysym(sym)^.storeddef,4);
+              { isn't it stored ? }
+              if (ppropertysym(sym)^.options and ppo_stored)=0 then
+                begin
+                   rttilist^.concat(new(pai_const,init_32bit(1)));
+                   proctypesinfo:=proctypesinfo or (3 shl 4);
+                end
+              else
+                writeproc(ppropertysym(sym)^.storedsym,ppropertysym(sym)^.storeddef,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)));
@@ -2680,16 +2709,27 @@
     procedure generate_published_child_rtti(sym : psym);{$ifndef fpc}far;{$endif}
 
       begin
+         if (sym^.typ=propertysym) and ((sym^.properties and sp_published)<>0) then
+           ppropertysym(sym)^.proptype^.get_rtti_label;
       end;
 
     procedure tobjectdef.write_child_rtti_data;
 
       begin
-         if assigned(childof) then
-           childof^.get_rtti_label;
          publicsyms^.foreach(generate_published_child_rtti);
       end;
 
+    procedure tobjectdef.generate_rtti;
+
+      begin
+         has_rtti:=true;
+         getlabel(rtti_label);
+         write_child_rtti_data;
+         rttilist^.concat(new(pai_symbol,init_global(rtti_name)));
+         rttilist^.concat(new(pai_label,init(rtti_label)));
+         write_rtti_data;
+      end;
+
     procedure tobjectdef.write_rtti_data;
 
       begin
@@ -2706,7 +2746,7 @@
          rttilist^.concat(new(pai_const,init_symbol(strpnew(vmt_mangledname))));
 
          { write owner typeinfo }
-         if assigned(childof) then
+         if assigned(childof) and ((childof^.options and oo_can_have_published)<>0) then
            rttilist^.concat(new(pai_const,init_symbol(strpnew(lab2str(childof^.get_rtti_label)))))
          else
            rttilist^.concat(new(pai_const,init_32bit(0)));
@@ -2751,7 +2791,10 @@
 
 {
   $Log$
-  Revision 1.35  1998-09-06 22:42:02  florian
+  Revision 1.36  1998-09-07 17:37:01  florian
+    * first fixes for published properties
+
+  Revision 1.35  1998/09/06 22:42:02  florian
     + rtti genreation for properties added
 
   Revision 1.34  1998/09/04 18:15:02  peter

compiler/symsym.inc

@@ -523,7 +523,11 @@
          writeaccessdef:=nil;
          readaccesssym:=nil;
          writeaccesssym:=nil;
-         index:=$0;
+         storedsym:=nil;
+         storeddef:=nil;
+
+         index:=0;
+         default:=0;
       end;
 
     destructor tpropertysym.done;
@@ -1620,7 +1624,10 @@
 
 {
   $Log$
-  Revision 1.39  1998-09-05 22:11:02  florian
+  Revision 1.40  1998-09-07 17:37:04  florian
+    * first fixes for published properties
+
+  Revision 1.39  1998/09/05 22:11:02  florian
     + switch -vb
     * while/repeat loops accept now also word/longbool conditions
     * makebooltojump did an invalid ungetregister32, fixed

compiler/types.pas

@@ -147,8 +147,8 @@ unit types;
       begin
          if is_equal(def1^.retdef,def2^.retdef) and
             equal_paras(def1^.para1,def2^.para1,false) and
-            ((def1^.options and po_comptatibility_options)=
-             (def2^.options and po_comptatibility_options)) then
+            ((def1^.options and po_compatibility_options)=
+             (def2^.options and po_compatibility_options)) then
            proc_to_procvar_equal:=true
          else
            proc_to_procvar_equal:=false;
@@ -902,7 +902,10 @@ unit types;
 end.
 {
   $Log$
-  Revision 1.26  1998-09-04 12:24:31  florian
+  Revision 1.27  1998-09-07 17:37:07  florian
+    * first fixes for published properties
+
+  Revision 1.26  1998/09/04 12:24:31  florian
     * bug0159 fixed
 
   Revision 1.25  1998/09/04 09:06:36  florian