compiler: allow const, type, var and class var sections for objects + test

git-svn-id: trunk@15092 -

.gitattributes

@@ -9182,6 +9182,7 @@ tests/test/tobject2.pp svneol=native#text/plain
 tests/test/tobject3.pp svneol=native#text/plain
 tests/test/tobject4.pp svneol=native#text/plain
 tests/test/tobject5.pp svneol=native#text/pascal
+tests/test/tobject6.pp svneol=native#text/plain
 tests/test/toperator1.pp svneol=native#text/plain
 tests/test/toperator2.pp svneol=native#text/plain
 tests/test/toperator3.pp svneol=native#text/plain

compiler/pdecobj.pas

@@ -552,7 +552,7 @@ implementation
             _TYPE :
               begin
                 if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
-                   (current_objectdef.objecttype<>odt_class) then
+                   not(current_objectdef.objecttype in [odt_class,odt_object]) then
                   Message(parser_e_type_var_const_only_in_generics_and_classes);
                  consume(_TYPE);
                  object_member_blocktype:=bt_type;
@@ -560,7 +560,7 @@ implementation
             _VAR :
               begin
                 if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
-                   (current_objectdef.objecttype<>odt_class) then
+                   not(current_objectdef.objecttype in [odt_class,odt_object]) then
                   Message(parser_e_type_var_const_only_in_generics_and_classes);
                 consume(_VAR);
                 fields_allowed:=true;
@@ -571,7 +571,7 @@ implementation
             _CONST:
               begin
                 if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
-                   (current_objectdef.objecttype<>odt_class) then
+                   not(current_objectdef.objecttype in [odt_class,odt_object]) then
                   Message(parser_e_type_var_const_only_in_generics_and_classes);
                 consume(_CONST);
                 object_member_blocktype:=bt_const;

compiler/pdecvar.pas

@@ -1413,12 +1413,11 @@ implementation
              { Don't search in the recordsymtable for types (can be nested!) }
              recstlist.count:=0;
              if ([df_generic,df_specialization]*tdef(recst.defowner).defoptions=[]) and
-                 not is_class(tdef(recst.defowner)) then
+                 not is_class_or_object(tdef(recst.defowner)) then
                begin
                  recstlist.add(recst);
                  symtablestack.pop(recst);
-                 while (is_object(tdef(symtablestack.top.defowner)) or
-                        (symtablestack.top.symtabletype=recordsymtable)) and
+                 while (symtablestack.top.symtabletype=recordsymtable) and
                        ([df_generic,df_specialization]*tdef(symtablestack.top.defowner).defoptions=[]) do
                    begin
                      recst:=tabstractrecordsymtable(symtablestack.top);

compiler/pexpr.pas

@@ -1530,7 +1530,8 @@ implementation
                               if assigned(srsym) then
                                 begin
                                   check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
-                                  if not(getaddr) and not(sp_static in srsym.symoptions) then
+                                  if not(getaddr) and
+                                     not((sp_static in srsym.symoptions) or (srsym.typ=constsym)) then
                                     Message(sym_e_only_static_in_static)
                                   else
                                     begin

compiler/symdef.pas

@@ -758,6 +758,7 @@ interface
     function is_class_or_interface_or_object(def: tdef): boolean;
     function is_class_or_interface_or_dispinterface(def: tdef): boolean;
     function is_class_or_interface_or_dispinterface_or_objc(def: tdef): boolean;
+    function is_class_or_object(def: tdef): boolean;
 
     procedure loadobjctypes;
 
@@ -4786,7 +4787,6 @@ implementation
       var
         def: tdef absolute data;
         pd: tprocdef absolute data;
-        founderrordef: tdef;
         i,
         paracount: longint;
       begin
@@ -5351,6 +5351,13 @@ implementation
           (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol]);
       end;
 
+    function is_class_or_object(def: tdef): boolean;
+      begin
+        result:=
+          assigned(def) and
+          (def.typ=objectdef) and
+          (tobjectdef(def).objecttype in [odt_class,odt_object]);
+      end;
 
     procedure loadobjctypes;
       begin

compiler/symtable.pas

@@ -1828,7 +1828,7 @@ implementation
                 records
                 objects
                 parameters
-              Exception are classes, generic definitions and specializations
+              Exception are classes, objects, generic definitions and specializations
               that have the parameterized types inserted in the symtable.
             }
             srsymtable:=stackitem^.symtable;
@@ -1837,7 +1837,7 @@ implementation
                 (
                  (df_generic in tdef(srsymtable.defowner).defoptions) or
                  (df_specialization in tdef(srsymtable.defowner).defoptions) or
-                 is_class(tdef(srsymtable.defowner)))
+                 is_class_or_object(tdef(srsymtable.defowner)))
                 ) then
               begin
                 srsym:=tsym(srsymtable.FindWithHash(hashedid));

tests/test/tobject6.pp

@@ -0,0 +1,38 @@
+program tobject6;
+{$APPTYPE console}
+{$ifdef fpc}
+  {$mode delphi}{$H+}
+{$endif}
+
+type
+  TR = object
+  private
+    type
+      tsometype = integer;
+    class var
+      ffield1: tsometype;
+    var
+      ffield2: string;
+    const
+      somevalue = 1;
+    class procedure SetField1(const Value: tsometype); static;
+  public
+    class property field1: tsometype read ffield1 write SetField1;
+  end;
+
+{ TR }
+
+class procedure TR.SetField1(const Value: tsometype);
+begin
+  ffield1 := Value;
+end;
+
+begin
+  TR.field1 := 10;
+  if TR.field1 <> 10 then
+    halt(1);
+  WriteLn(TR.somevalue);
+  if TR.somevalue <> 1 then
+    halt(2);
+  WriteLn('ok');
+end.