compiler: implement properties in records:

  - rename property_dec from pdecobj to struct_property_dec because pdecl also has property_dec and move it to interface to use by records + allow properties for records
  - use struct_property_dec in record parser
  - change structh type from objectdef to abstractrecorddef in read_property_dec to use by records
  - disallow stored and default modifiers for records because records are not used for streaming
  - fix misuse of search_sym_in_class for records in few places

git-svn-id: branches/paul/extended_records@16548 -

compiler/dbgdwarf.pas

@@ -2675,7 +2675,7 @@ implementation
         if not get_symlist_sym_offset(symlist,tosym,offset) then
           exit;
 
-        if (tosym.owner.symtabletype<>objectsymtable) then
+        if not (tosym.owner.symtabletype in [objectsymtable,recordsymtable]) then
           begin
             if (tosym.typ=fieldvarsym) then
               internalerror(2009031404);

compiler/pdecobj.pas

@@ -36,6 +36,7 @@ interface
     function class_destructor_head:tprocdef;
     function constructor_head:tprocdef;
     function destructor_head:tprocdef;
+    procedure struct_property_dec(is_classproperty:boolean);
 
 implementation
 
@@ -111,22 +112,22 @@ implementation
       end;
 
 
-    procedure property_dec(is_classproperty:boolean);
+    procedure struct_property_dec(is_classproperty:boolean);
       var
         p : tpropertysym;
       begin
-        { check for a class }
-        if not((is_class_or_interface_or_dispinterface(current_objectdef)) or
-           (not(m_tp7 in current_settings.modeswitches) and (is_object(current_objectdef)))) then
+        { check for a class or record }
+        if not((is_class_or_interface_or_dispinterface(current_structdef) or is_record(current_structdef)) or
+           (not(m_tp7 in current_settings.modeswitches) and (is_object(current_structdef)))) then
           Message(parser_e_syntax_error);
         consume(_PROPERTY);
-        p:=read_property_dec(is_classproperty, current_objectdef);
+        p:=read_property_dec(is_classproperty,current_structdef);
         consume(_SEMICOLON);
         if try_to_consume(_DEFAULT) then
           begin
-            if oo_has_default_property in current_objectdef.objectoptions then
+            if oo_has_default_property in current_structdef.objectoptions then
               message(parser_e_only_one_default_property);
-            include(current_objectdef.objectoptions,oo_has_default_property);
+            include(current_structdef.objectoptions,oo_has_default_property);
             include(p.propoptions,ppo_defaultproperty);
             if not(ppo_hasparameters in p.propoptions) then
               message(parser_e_property_need_paras);
@@ -144,11 +145,11 @@ implementation
             begin
               if pattern='CURRENT' then
               begin
-                if oo_has_enumerator_current in current_objectdef.objectoptions then
+                if oo_has_enumerator_current in current_structdef.objectoptions then
                   message(parser_e_only_one_enumerator_current);
                 if not p.propaccesslist[palt_read].empty then
                 begin
-                  include(current_objectdef.objectoptions,oo_has_enumerator_current);
+                  include(current_structdef.objectoptions,oo_has_enumerator_current);
                   include(p.propoptions,ppo_enumerator_current);
                 end
                 else
@@ -764,7 +765,7 @@ implementation
               end;
             _PROPERTY :
               begin
-                property_dec(is_classdef);
+                struct_property_dec(is_classdef);
                 fields_allowed:=false;
                 is_classdef:=false;
               end;

compiler/pdecvar.pas

@@ -33,7 +33,7 @@ interface
       tvar_dec_option=(vd_record,vd_object,vd_threadvar,vd_class);
       tvar_dec_options=set of tvar_dec_option;
 
-    function  read_property_dec(is_classproperty:boolean;astruct:tobjectdef):tpropertysym;
+    function  read_property_dec(is_classproperty:boolean;astruct:tabstractrecorddef):tpropertysym;
 
     procedure read_var_decls(options:Tvar_dec_options);
 
@@ -66,7 +66,7 @@ implementation
        ;
 
 
-    function read_property_dec(is_classproperty:boolean;astruct:tobjectdef):tpropertysym;
+    function read_property_dec(is_classproperty:boolean;astruct:tabstractrecorddef):tpropertysym;
 
         { convert a node tree to symlist and return the last
           symbol }
@@ -279,7 +279,7 @@ implementation
                   pt.free;
                 end
               else
-                p.dispid:=astruct.get_next_dispid;
+                p.dispid:=tobjectdef(astruct).get_next_dispid;
             end;
 
           procedure add_index_parameter(var paranr: word; p: tpropertysym; readprocdef, writeprocdef, storedprocdef: tprocvardef);
@@ -457,7 +457,10 @@ implementation
          else
            begin
               { do an property override }
-              overridden:=search_struct_member(astruct.childof,p.name);
+              if (astruct.typ=objectdef) then
+                overridden:=search_struct_member(tobjectdef(astruct).childof,p.name)
+              else
+                overridden:=nil;
               if assigned(overridden) and
                  (overridden.typ=propertysym) and
                  not(is_dispinterface(astruct)) then
@@ -585,7 +588,8 @@ implementation
          else
            parse_dispinterface(p);
 
-         if assigned(astruct) and not(is_dispinterface(astruct)) and not is_classproperty then
+         { stored is not allowed for dispinterfaces, records or class properties }
+         if assigned(astruct) and not(is_dispinterface(astruct) or is_record(astruct)) and not is_classproperty then
            begin
              { ppo_stored is default on for not overridden properties }
              if not assigned(p.overriddenpropsym) then
@@ -672,7 +676,7 @@ implementation
                 end;
               end;
            end;
-         if try_to_consume(_DEFAULT) then
+         if not is_record(astruct) and try_to_consume(_DEFAULT) then
            begin
               if not allow_default_property(p) then
                 begin
@@ -713,7 +717,7 @@ implementation
                   pt.free;
                 end;
            end
-         else if try_to_consume(_NODEFAULT) then
+         else if not is_record(astruct) and try_to_consume(_NODEFAULT) then
            begin
               p.default:=longint($80000000);
            end;
@@ -724,7 +728,7 @@ implementation
            end;
 *)
          { Parse possible "implements" keyword }
-         if try_to_consume(_IMPLEMENTS) then
+         if not is_record(astruct) and try_to_consume(_IMPLEMENTS) then
            begin
              single_type(def,false,false);
 
@@ -782,9 +786,9 @@ implementation
                  exit;
                end;
              found:=false;
-             for i:=0 to astruct.ImplementedInterfaces.Count-1 do
+             for i:=0 to tobjectdef(astruct).ImplementedInterfaces.Count-1 do
                begin
-                 ImplIntf:=TImplementedInterface(astruct.ImplementedInterfaces[i]);
+                 ImplIntf:=TImplementedInterface(tobjectdef(astruct).ImplementedInterfaces[i]);
 
                  if compare_defs(def,ImplIntf.IntfDef,nothingn)>=te_equal then
                    begin

compiler/pexpr.pas

@@ -1083,7 +1083,10 @@ implementation
                          if (sp_static in sym.symoptions) then
                            begin
                              static_name:=lower(sym.owner.name^)+'_'+sym.name;
-                             searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable);
+                             if sym.owner.defowner.typ=objectdef then
+                               searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable)
+                             else
+                               searchsym_in_record(trecorddef(sym.owner.defowner),static_name,sym,srsymtable);
                              if assigned(sym) then
                                check_hints(sym,sym.symoptions,sym.deprecatedmsg);
                              p1.free;
@@ -1134,7 +1137,10 @@ implementation
                          if (sp_static in sym.symoptions) then
                            begin
                              static_name:=lower(sym.owner.name^)+'_'+sym.name;
-                             searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable);
+                             if sym.owner.defowner.typ=objectdef then
+                               searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable)
+                             else
+                               searchsym_in_record(trecorddef(sym.owner.defowner),static_name,sym,srsymtable);
                              if assigned(sym) then
                                check_hints(sym,sym.symoptions,sym.deprecatedmsg);
                              p1.free;

compiler/ptype.pas

@@ -701,7 +701,7 @@ implementation
               end;
             _PROPERTY :
               begin
-                property_dec(is_classdef);
+                struct_property_dec(is_classdef);
                 fields_allowed:=false;
                 is_classdef:=false;
               end;

tests/test/terecs3.pp

@@ -23,5 +23,11 @@ begin
     halt(5);
   if F.F5 <> 6 then
     halt(6);
+  F.P3 := 7;
+  if F.P3 <> 7 then
+    halt(7);
+  F.P5 := 8;
+  if F.P5 <> 8 then
+    halt(8);
   WriteLn('ok');
 end.

tests/test/terecs_u1.pp

@@ -23,6 +23,13 @@ type
       F5: TBar;
     function Test(n: TBar): TBar;
     class function Test1(n: TBar): TBar;
+
+    procedure Set3(const Value: TBar);
+    class procedure Set5(const Value: TBar); static;
+
+    property P3: TBar read F3 write Set3;
+    class property P5: TBar read F5 write Set5;
+
     class constructor Create;
     class destructor Destroy;
   end;
@@ -49,4 +56,14 @@ begin
   WriteLn('TFoo.Destroy');
 end;
 
+procedure TFoo.Set3(const Value: TBar);
+begin
+  F3 := Value;
+end;
+
+class procedure TFoo.Set5(const Value: TBar); static;
+begin
+  F5 := Value;
+end;
+
 end.