compiler:

  - implement class properties: properties which can access only static fields and static class methods
  - tests
  - fix a possibility to call an instance method from the class method

git-svn-id: trunk@14585 -

.gitattributes

@@ -9222,6 +9222,9 @@ tests/test/tset7.pp svneol=native#text/plain
 tests/test/tsetsize.pp svneol=native#text/plain
 tests/test/tstack.pp svneol=native#text/plain
 tests/test/tstatic1.pp svneol=native#text/pascal
+tests/test/tstatic2.pp svneol=native#text/pascal
+tests/test/tstatic3.pp svneol=native#text/pascal
+tests/test/tstatic4.pp svneol=native#text/pascal
 tests/test/tstprocv.pp svneol=native#text/plain
 tests/test/tstring1.pp svneol=native#text/plain
 tests/test/tstring10.pp svneol=native#text/plain

compiler/msg/errore.msg

@@ -366,7 +366,7 @@ scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure
 #
 # Parser
 #
-# 03282 is the last used one
+# 03284 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -514,7 +514,7 @@ parser_e_fail_only_in_constructor=03051_E_FAIL can be used in constructors only
 parser_e_no_paras_for_destructor=03052_E_Destructors can't have parameters
 % You are declaring a destructor with a parameter list. Destructor methods
 % cannot have parameters.
-parser_e_only_class_methods_via_class_ref=03053_E_Only class methods can be referred with class references
+parser_e_only_class_members_via_class_ref=03053_E_Only class methods, class properties and class variables can be referred with class references
 % This error occurs in a situation like the following:
 % \begin{verbatim}
 % Type :
@@ -528,7 +528,7 @@ parser_e_only_class_methods_via_class_ref=03053_E_Only class methods can be refe
 % \end{verbatim}
 % \var{Free} is not a class method and hence cannot be called with a class
 % reference.
-parser_e_only_class_methods=03054_E_Only class methods can be accessed in class methods
+parser_e_only_class_members=03054_E_Only class class methods, class properties and class variables can be accessed in class methods
 % This is related to the previous error. You cannot call a method of an object
 % from inside a class method. The following code would produce this error:
 % \begin{verbatim}

compiler/msgidx.inc

@@ -151,8 +151,8 @@ const
   parser_e_error_in_real=03050;
   parser_e_fail_only_in_constructor=03051;
   parser_e_no_paras_for_destructor=03052;
-  parser_e_only_class_methods_via_class_ref=03053;
-  parser_e_only_class_methods=03054;
+  parser_e_only_class_members_via_class_ref=03053;
+  parser_e_only_class_members=03054;
   parser_e_case_mismatch=03055;
   parser_e_illegal_symbol_exported=03056;
   parser_w_should_use_override=03057;
@@ -840,7 +840,7 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 55145;
+  MsgTxtSize = 55227;
 
   MsgIdxMax : array[1..20] of longint=(
     24,87,285,95,71,51,110,22,202,63,

compiler/ncal.pas

@@ -2771,6 +2771,14 @@ implementation
                 while assigned(hpt) and (hpt.nodetype in [subscriptn,vecn]) do
                   hpt:=tunarynode(hpt).left;
 
+                if ((hpt.nodetype=loadvmtaddrn) or
+                   ((hpt.nodetype=loadn) and assigned(tloadnode(hpt).resultdef) and (tloadnode(hpt).resultdef.typ=classrefdef))) and
+                   not (procdefinition.proctypeoption=potype_constructor) and
+                   not (po_classmethod in procdefinition.procoptions) and
+                   not (po_staticmethod in procdefinition.procoptions) then
+                  { error: we are calling instance method from the class method/static method }
+                  CGMessage(parser_e_only_class_members);
+
                if (procdefinition.proctypeoption=potype_constructor) and
                   assigned(symtableproc) and
                   (symtableproc.symtabletype=withsymtable) and

compiler/pdecl.pas

@@ -41,7 +41,7 @@ interface
     procedure types_dec;
     procedure var_dec;
     procedure threadvar_dec;
-    procedure property_dec;
+    procedure property_dec(is_classpropery: boolean);
     procedure resourcestring_dec;
 
 implementation
@@ -642,7 +642,7 @@ implementation
       end;
 
 
-    procedure property_dec;
+    procedure property_dec(is_classpropery: boolean);
       var
          old_block_type : tblock_type;
       begin
@@ -652,7 +652,7 @@ implementation
          old_block_type:=block_type;
          block_type:=bt_const;
          repeat
-           read_property_dec(nil);
+           read_property_dec(is_classpropery, nil);
            consume(_SEMICOLON);
          until token<>_ID;
          block_type:=old_block_type;

compiler/pdecobj.pas

@@ -82,7 +82,7 @@ implementation
       end;
 
 
-    procedure property_dec;
+    procedure property_dec(is_classproperty:boolean);
       var
         p : tpropertysym;
       begin
@@ -91,7 +91,7 @@ implementation
            (not(m_tp7 in current_settings.modeswitches) and (is_object(current_objectdef)))) then
           Message(parser_e_syntax_error);
         consume(_PROPERTY);
-        p:=read_property_dec(current_objectdef);
+        p:=read_property_dec(is_classproperty, current_objectdef);
         consume(_SEMICOLON);
         if try_to_consume(_DEFAULT) then
           begin
@@ -526,7 +526,7 @@ implementation
         oldparse_only,
         old_parse_generic : boolean;
         object_member_blocktype : tblock_type;
-        fields_allowed: boolean;
+        fields_allowed, is_classdef: boolean;
       begin
         { empty class declaration ? }
         if (current_objectdef.objecttype in [odt_class,odt_objcclass]) and
@@ -544,6 +544,7 @@ implementation
         testcurobject:=1;
         has_destructor:=false;
         fields_allowed:=true;
+        is_classdef:=false;
         object_member_blocktype:=bt_general;
         repeat
           case token of
@@ -667,12 +668,29 @@ implementation
               end;
             _PROPERTY :
               begin
-                property_dec;
+                property_dec(is_classdef);
                 fields_allowed:=false;
+                is_classdef:=false;
+              end;
+            _CLASS:
+              begin
+                is_classdef:=false;
+                { read class method }
+                if try_to_consume(_CLASS) then
+                 begin
+                   { class method only allowed for procedures and functions }
+                   if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY]) then
+                     Message(parser_e_procedure_or_function_expected);
+
+                   if is_interface(current_objectdef) then
+                     Message(parser_e_no_static_method_in_interfaces)
+                   else
+                     { class methods are also allowed for Objective-C protocols }
+                     is_classdef:=true;
+                 end;
               end;
             _PROCEDURE,
-            _FUNCTION,
-            _CLASS :
+            _FUNCTION:
               begin
                 if (current_objectdef.symtable.currentvisibility=vis_published) and
                    not(oo_can_have_published in current_objectdef.objectoptions) then
@@ -680,7 +698,7 @@ implementation
 
                 oldparse_only:=parse_only;
                 parse_only:=true;
-                pd:=parse_proc_dec(current_objectdef);
+                pd:=parse_proc_dec(is_classdef, current_objectdef);
 
                 { this is for error recovery as well as forward }
                 { interface mappings, i.e. mapping to a method  }
@@ -716,6 +734,7 @@ implementation
 
                 parse_only:=oldparse_only;
                 fields_allowed:=false;
+                is_classdef:=false;
               end;
             _CONSTRUCTOR :
               begin

compiler/pdecsub.pas

@@ -60,7 +60,7 @@ interface
     procedure parse_var_proc_directives(sym:tsym);
     procedure parse_object_proc_directives(pd:tabstractprocdef);
     function  parse_proc_head(aclass:tobjectdef;potype:tproctypeoption;var pd:tprocdef):boolean;
-    function  parse_proc_dec(aclass:tobjectdef):tprocdef;
+    function  parse_proc_dec(isclassmethod:boolean; aclass:tobjectdef):tprocdef;
 
 implementation
 
@@ -948,30 +948,15 @@ implementation
       end;
 
 
-    function parse_proc_dec(aclass:tobjectdef):tprocdef;
+    function parse_proc_dec(isclassmethod:boolean; aclass:tobjectdef):tprocdef;
       var
         pd : tprocdef;
-        isclassmethod : boolean;
         locationstr: string;
         old_parse_generic,
         popclass           : boolean;
       begin
         locationstr:='';
         pd:=nil;
-        isclassmethod:=false;
-        { read class method }
-        if try_to_consume(_CLASS) then
-         begin
-           { class method only allowed for procedures and functions }
-           if not(token in [_FUNCTION,_PROCEDURE]) then
-             Message(parser_e_procedure_or_function_expected);
-
-           if is_interface(aclass) then
-             Message(parser_e_no_static_method_in_interfaces)
-           else
-             { class methods are also allowed for Objective-C protocols }
-             isclassmethod:=true;
-         end;
         case token of
           _FUNCTION :
             begin

compiler/pdecvar.pas

@@ -33,7 +33,7 @@ interface
       tvar_dec_option=(vd_record,vd_object,vd_threadvar);
       tvar_dec_options=set of tvar_dec_option;
 
-    function  read_property_dec(aclass:tobjectdef):tpropertysym;
+    function  read_property_dec(is_classproperty:boolean; aclass:tobjectdef):tpropertysym;
 
     procedure read_var_decls(options:Tvar_dec_options);
 
@@ -66,7 +66,7 @@ implementation
        ;
 
 
-    function read_property_dec(aclass:tobjectdef):tpropertysym;
+    function read_property_dec(is_classproperty:boolean; aclass:tobjectdef):tpropertysym;
 
         { convert a node tree to symlist and return the last
           symbol }
@@ -269,8 +269,8 @@ implementation
          writeprocdef:=tprocvardef.create(normal_function_level);
          storedprocdef:=tprocvardef.create(normal_function_level);
 
-         { make it method pointers }
-         if assigned(aclass) then
+         { make them method pointers }
+         if assigned(aclass) and not is_classproperty then
            begin
              include(readprocdef.procoptions,po_methodpointer);
              include(writeprocdef.procoptions,po_methodpointer);
@@ -290,6 +290,8 @@ implementation
          p:=tpropertysym.create(orgpattern);
          p.visibility:=symtablestack.top.currentvisibility;
          p.default:=longint($80000000);
+         if is_classproperty then
+           include(p.symoptions, sp_static);
          symtablestack.top.insert(p);
          consume(_ID);
          { property parameters ? }
@@ -461,8 +463,9 @@ implementation
                                the parameter.
                                Note: In the help of Kylix it is written
                                that it isn't allowed, but the compiler accepts it (PFV) }
-                             if (ppo_hasparameters in p.propoptions) then
-                              Message(parser_e_ill_property_access_sym);
+                             if (ppo_hasparameters in p.propoptions) or
+                                ((sp_static in p.symoptions) <> (sp_static in sym.symoptions)) then
+                               Message(parser_e_ill_property_access_sym);
                            end
                           else
                            IncompatibleTypes(def,p.propdef);
@@ -505,7 +508,8 @@ implementation
                                the parameter.
                                Note: In the help of Kylix it is written
                                that it isn't allowed, but the compiler accepts it (PFV) }
-                             if (ppo_hasparameters in p.propoptions) then
+                             if (ppo_hasparameters in p.propoptions) or
+                                ((sp_static in p.symoptions) <> (sp_static in sym.symoptions)) then
                               Message(parser_e_ill_property_access_sym);
                            end
                           else
@@ -536,7 +540,7 @@ implementation
                end;
            end;
 
-         if assigned(aclass) and not(is_dispinterface(aclass)) then
+         if assigned(aclass) and not(is_dispinterface(aclass)) and not is_classproperty then
            begin
              { ppo_stored is default on for not overriden properties }
              if not assigned(p.overridenpropsym) then

compiler/pexpr.pas

@@ -1028,6 +1028,9 @@ implementation
          membercall : boolean;
          callflags  : tcallnodeflags;
          propaccesslist : tpropaccesslist;
+         static_name : shortstring;
+         sym: tsym;
+         srsymtable : tsymtable;
       begin
          { property parameters? read them only if the property really }
          { has parameters                                             }
@@ -1052,7 +1055,8 @@ implementation
            begin
               if getpropaccesslist(propsym,palt_write,propaccesslist) then
                 begin
-                   case propaccesslist.firstsym^.sym.typ of
+                   sym:=propaccesslist.firstsym^.sym;
+                   case sym.typ of
                      procsym :
                        begin
                          callflags:=[];
@@ -1060,8 +1064,8 @@ implementation
                          membercall:=maybe_load_methodpointer(st,p1);
                          if membercall then
                            include(callflags,cnf_member_call);
-                         p1:=ccallnode.create(paras,tprocsym(propaccesslist.firstsym^.sym),st,p1,callflags);
-                         addsymref(propaccesslist.firstsym^.sym);
+                         p1:=ccallnode.create(paras,tprocsym(sym),st,p1,callflags);
+                         addsymref(sym);
                          paras:=nil;
                          consume(_ASSIGNMENT);
                          { read the expression }
@@ -1078,7 +1082,19 @@ implementation
                      fieldvarsym :
                        begin
                          { generate access code }
-                         propaccesslist_to_node(p1,st,propaccesslist);
+                         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 assigned(sym) then
+                               check_hints(sym,sym.symoptions,sym.deprecatedmsg);
+                             p1.free;
+                             p1:=nil;
+                             { static syms are always stored as absolutevarsym to handle scope and storage properly }
+                             propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
+                           end
+                         else
+                           propaccesslist_to_node(p1,st,propaccesslist);
                          include(p1.flags,nf_isproperty);
                          consume(_ASSIGNMENT);
                          { read the expression }
@@ -1102,12 +1118,25 @@ implementation
            begin
               if getpropaccesslist(propsym,palt_read,propaccesslist) then
                 begin
-                   case propaccesslist.firstsym^.sym.typ of
+                   sym := propaccesslist.firstsym^.sym;
+                   case sym.typ of
                      fieldvarsym :
                        begin
-                          { generate access code }
-                          propaccesslist_to_node(p1,st,propaccesslist);
-                          include(p1.flags,nf_isproperty);
+                         { generate access code }
+                         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 assigned(sym) then
+                               check_hints(sym,sym.symoptions,sym.deprecatedmsg);
+                             p1.free;
+                             p1:=nil;
+                             { static syms are always stored as absolutevarsym to handle scope and storage properly }
+                             propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
+                           end
+                         else
+                           propaccesslist_to_node(p1,st,propaccesslist);
+                         include(p1.flags,nf_isproperty);
                        end;
                      procsym :
                        begin
@@ -1116,7 +1145,7 @@ implementation
                           membercall:=maybe_load_methodpointer(st,p1);
                           if membercall then
                             include(callflags,cnf_member_call);
-                          p1:=ccallnode.create(paras,tprocsym(propaccesslist.firstsym^.sym),st,p1,callflags);
+                          p1:=ccallnode.create(paras,tprocsym(sym),st,p1,callflags);
                           paras:=nil;
                           include(p1.flags,nf_isproperty);
                        end
@@ -1184,7 +1213,7 @@ implementation
                          assigned(tcallnode(p1).procdefinition) and
                          not(po_classmethod in tcallnode(p1).procdefinition.procoptions) and
                          not(tcallnode(p1).procdefinition.proctypeoption=potype_constructor) then
-                        Message(parser_e_only_class_methods_via_class_ref);
+                        Message(parser_e_only_class_members_via_class_ref);
                    end;
                  fieldvarsym:
                    begin
@@ -1203,17 +1232,20 @@ implementation
                         begin
                           if isclassref then
                             if assigned(p1) and
-                               is_self_node(p1) then
-                              Message(parser_e_only_class_methods)
+                              (
+                                is_self_node(p1) or
+                                (assigned(current_procinfo) and ([po_staticmethod,po_classmethod] <= current_procinfo.procdef.procoptions) and
+                                 (current_procinfo.procdef._class = classh))) then
+                              Message(parser_e_only_class_members)
                             else
-                              Message(parser_e_only_class_methods_via_class_ref);
+                              Message(parser_e_only_class_members_via_class_ref);
                           p1:=csubscriptnode.create(sym,p1);
                         end;
                    end;
                  propertysym:
                    begin
-                      if isclassref then
-                        Message(parser_e_only_class_methods_via_class_ref);
+                      if isclassref and not (sp_static in sym.symoptions) then
+                        Message(parser_e_only_class_members_via_class_ref);
                       handle_propertysym(tpropertysym(sym),sym.owner,p1);
                    end;
                  typesym:
@@ -1595,7 +1627,11 @@ implementation
                     if is_member_read(srsym,srsymtable,p1,hdef) then
                       begin
                         if (srsymtable.symtabletype=ObjectSymtable) then
-                          p1:=load_self_node;
+                           if (assigned(current_procinfo) and ([po_staticmethod,po_classmethod] <= current_procinfo.procdef.procoptions)) then
+                          { no self node in static class methods }
+                            p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
+                          else
+                            p1:=load_self_node;
                         { not srsymtable.symtabletype since that can be }
                         { withsymtable as well                          }
                         if (srsym.owner.symtabletype=ObjectSymtable) then

compiler/psub.pas

@@ -1545,7 +1545,7 @@ implementation
       end;
 
 
-    procedure read_proc;
+    procedure read_proc(isclassmethod:boolean);
       {
         Parses the procedure directives, then parses the procedure body, then
         generates the code for it
@@ -1568,7 +1568,7 @@ implementation
          current_objectdef:=nil;
 
          { parse procedure declaration }
-         pd:=parse_proc_dec(old_current_objectdef);
+         pd:=parse_proc_dec(isclassmethod, old_current_objectdef);
 
          { set the default function options }
          if parse_only then
@@ -1713,8 +1713,11 @@ implementation
 
 
     procedure read_declarations(islibrary : boolean);
+      var
+        is_classdef:boolean;
       begin
-         repeat
+        is_classdef:=false;
+        repeat
            if not assigned(current_procinfo) then
              internalerror(200304251);
            case token of
@@ -1728,13 +1731,31 @@ implementation
                 var_dec;
               _THREADVAR:
                 threadvar_dec;
+              _CLASS:
+                begin
+                  is_classdef:=false;
+                  if try_to_consume(_CLASS) then
+                   begin
+                     { class method only allowed for procedures and functions }
+                     if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY]) then
+                       Message(parser_e_procedure_or_function_expected);
+
+                     if is_interface(current_objectdef) then
+                       Message(parser_e_no_static_method_in_interfaces)
+                     else
+                       { class methods are also allowed for Objective-C protocols }
+                       is_classdef:=true;
+                   end;
+                end;
               _CONSTRUCTOR,
               _DESTRUCTOR,
               _FUNCTION,
               _PROCEDURE,
-              _OPERATOR,
-              _CLASS:
-                read_proc;
+              _OPERATOR:
+                begin
+                  read_proc(is_classdef);
+                  is_classdef:=false;
+                end;
               _EXPORTS:
                 begin
                    if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
@@ -1766,7 +1787,10 @@ implementation
                     _PROPERTY:
                       begin
                         if (m_fpc in current_settings.modeswitches) then
-                          property_dec
+                        begin
+                          property_dec(is_classdef);
+                          is_classdef:=false;
+                        end
                         else
                           break;
                       end;
@@ -1799,7 +1823,7 @@ implementation
              _FUNCTION,
              _PROCEDURE,
              _OPERATOR :
-               read_proc;
+               read_proc(false);
              else
                begin
                  case idtoken of
@@ -1808,7 +1832,7 @@ implementation
                    _PROPERTY:
                      begin
                        if (m_fpc in current_settings.modeswitches) then
-                         property_dec
+                         property_dec(false)
                        else
                          break;
                      end;

tests/test/tstatic2.pp

@@ -0,0 +1,34 @@
+program tstatic2;
+{$APPTYPE console}
+{$ifdef fpc}
+  {$mode delphi}{$H+}
+{$endif}
+
+type
+  TSomeClass = class
+  private
+    {$ifndef fpc}class var{$endif}FSomethingStatic: Integer; {$ifdef fpc}static;{$endif}
+  public
+    class procedure SetSomethingStatic(AValue: Integer); static;
+    class property SomethingStatic: Integer read FSomethingStatic write SetSomethingStatic;
+  end;
+
+  TAnotherClass = class(TSomeClass)
+  end;
+
+{ TSomeClass }
+
+class procedure TSomeClass.SetSomethingStatic(AValue: Integer);
+begin
+  FSomethingStatic := AValue;
+  WriteLn('SomethingStatic:', SomethingStatic);
+end;
+
+begin
+  TSomeClass.SomethingStatic := 4;
+  if TSomeClass.SomethingStatic <> 4 then
+    halt(1);
+  TAnotherClass.SomethingStatic := 10;
+  if TSomeClass.SomethingStatic <> 10 then
+    halt(2); // outputs 10
+end.

tests/test/tstatic3.pp

@@ -0,0 +1,27 @@
+{ %FAIL}
+program tstatic3;
+{$APPTYPE console}
+{$ifdef fpc}
+  {$mode delphi}{$H+}
+{$endif}
+
+type
+  TSomeClass = class
+  private
+    {$ifndef fpc}class var{$endif}FSomethingStatic: Integer;
+    {$ifndef fpc}var{$endif} FSomethingRegular: Integer;
+    class procedure SetSomethingStatic(AValue: Integer); static;
+  public
+    class property SomethingStatic: Integer read FSomethingStatic write SetSomethingStatic;
+    property SomethingRegular: Integer read FSomethingRegular write FSomethingRegular;
+  end;
+
+{ TSomeClass }
+
+class procedure TSomeClass.SetSomethingStatic(AValue: Integer);
+begin
+  FSomethingRegular := AValue;
+end;
+
+begin
+end.

tests/test/tstatic4.pp

@@ -0,0 +1,32 @@
+{ %FAIL}
+program tstatic4;
+{$APPTYPE console}
+{$ifdef fpc}
+  {$mode delphi}{$H+}
+{$endif}
+
+type
+
+  { TSomeClass }
+
+  TSomeClass = class
+  public
+    class procedure StaticProc; static;
+    procedure RegularProc;
+  end;
+
+
+{ TSomeClass }
+
+procedure TSomeClass.RegularProc;
+begin
+
+end;
+
+class procedure TSomeClass.StaticProc;
+begin
+  RegularProc;
+end;
+
+begin
+end.