compiler: implement class constants + tests

git-svn-id: trunk@14609 -

.gitattributes

@@ -8892,6 +8892,8 @@ tests/test/tclass1.pp svneol=native#text/plain
 tests/test/tclass10.pp svneol=native#text/pascal
 tests/test/tclass11a.pp svneol=native#text/pascal
 tests/test/tclass11b.pp svneol=native#text/pascal
+tests/test/tclass12a.pp svneol=native#text/pascal
+tests/test/tclass12b.pp svneol=native#text/pascal
 tests/test/tclass2.pp svneol=native#text/plain
 tests/test/tclass3.pp svneol=native#text/plain
 tests/test/tclass4.pp svneol=native#text/plain

compiler/msg/errore.msg

@@ -1104,8 +1104,8 @@ parser_e_packed_element_no_loop=03223_E_Bit packed array elements and record fie
 % (or as \var{packed} in any mode with \var{\{\$bitpacking on\}}), it will
 % be packed at the bit level. For performance reasons, they cannot be
 % used as loop variables.
-parser_e_type_and_var_only_in_generics_and_classes=03224_E_VAR and TYPE are allowed only in generics and classes
-% The usage of VAR and TYPE to declare new types inside an object is allowed only inside
+parser_e_type_var_const_only_in_generics_and_classes=03224_E_VAR, TYPE and CONST are allowed only in generics and classes
+% The usage of VAR, TYPE and CONST to declare new types inside an object is allowed only inside
 % generics and classes.
 parser_e_cant_create_generics_of_this_type=03225_E_This type can't be a generic
 % Only Classes, Objects, Interfaces and Records are allowed to be used as generic.

compiler/msgidx.inc

@@ -312,7 +312,7 @@ const
   parser_e_packed_element_no_var_addr=03221;
   parser_e_packed_dynamic_open_array=03222;
   parser_e_packed_element_no_loop=03223;
-  parser_e_type_and_var_only_in_generics_and_classes=03224;
+  parser_e_type_var_const_only_in_generics_and_classes=03224;
   parser_e_cant_create_generics_of_this_type=03225;
   parser_w_no_lineinfo_use_switch=03226;
   parser_e_no_funcret_specified=03227;
@@ -840,7 +840,7 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 55239;
+  MsgTxtSize = 55246;
 
   MsgIdxMax : array[1..20] of longint=(
     24,87,285,95,71,51,110,22,202,63,

compiler/ncon.pas

@@ -291,15 +291,23 @@ implementation
         p1:=nil;
         case p.consttyp of
           constord :
-            p1:=cordconstnode.create(p.value.valueord,p.constdef,true);
+            begin
+              if p.constdef=nil then
+                internalerror(200403232);
+              p1:=cordconstnode.create(p.value.valueord,p.constdef,true);
+            end;
           conststring :
             begin
               len:=p.value.len;
+              if not(cs_ansistrings in current_settings.localswitches) and (len>255) then
+               len:=255;
               getmem(pc,len+1);
               move(pchar(p.value.valueptr)^,pc^,len);
               pc[len]:=#0;
               p1:=cstringconstnode.createpchar(pc,len);
             end;
+          constwstring :
+            p1:=cstringconstnode.createwstr(pcompilerwidestring(p.value.valueptr));
           constreal :
             p1:=crealconstnode.create(pbestreal(p.value.valueptr)^,pbestrealtype^);
           constset :
@@ -308,6 +316,8 @@ implementation
             p1:=cpointerconstnode.create(p.value.valueordptr,p.constdef);
           constnil :
             p1:=cnilnode.create;
+          constguid :
+            p1:=cguidconstnode.create(pguid(p.value.valueptr)^);
           else
             internalerror(200205103);
         end;

compiler/pdecl.pas

@@ -36,6 +36,7 @@ interface
     function  readconstant(const orgname:string;const filepos:tfileposinfo):tconstsym;
 
     procedure const_dec;
+    procedure consts_dec(in_class: boolean);
     procedure label_dec;
     procedure type_dec;
     procedure types_dec(in_class: boolean);
@@ -154,8 +155,13 @@ implementation
         readconstant:=hp;
       end;
 
-
     procedure const_dec;
+      begin
+        consume(_CONST);
+        consts_dec(false);
+      end;
+
+    procedure consts_dec(in_class: boolean);
       var
          orgname : TIDString;
          hdef : tdef;
@@ -168,7 +174,6 @@ implementation
          tclist : tasmlist;
          varspez : tvarspez;
       begin
-         consume(_CONST);
          old_block_type:=block_type;
          block_type:=bt_const;
          repeat
@@ -189,6 +194,7 @@ implementation
                      begin
                        sym.symoptions:=sym.symoptions+dummysymoptions;
                        sym.deprecatedmsg:=deprecatedmsg;
+                       sym.visibility:=symtablestack.top.currentvisibility;
                        symtablestack.top.insert(sym);
                      end
                    else
@@ -213,6 +219,7 @@ implementation
                    else
                      varspez:=vs_value;
                    sym:=tstaticvarsym.create(orgname,varspez,hdef,[]);
+                   sym.visibility:=symtablestack.top.currentvisibility;
                    current_tokenpos:=storetokenpos;
                    symtablestack.top.insert(sym);
                    { procvar can have proc directives, but not type references }
@@ -255,7 +262,7 @@ implementation
                 { generate an error }
                 consume(_EQUAL);
            end;
-         until token<>_ID;
+         until (token<>_ID)or(in_class and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
          block_type:=old_block_type;
       end;
 

compiler/pdecobj.pas

@@ -553,7 +553,7 @@ implementation
               begin
                 if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
                    (current_objectdef.objecttype<>odt_class) then
-                  Message(parser_e_type_and_var_only_in_generics_and_classes);
+                  Message(parser_e_type_var_const_only_in_generics_and_classes);
                  consume(_TYPE);
                  object_member_blocktype:=bt_type;
               end;
@@ -561,13 +561,21 @@ implementation
               begin
                 if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
                    (current_objectdef.objecttype<>odt_class) then
-                  Message(parser_e_type_and_var_only_in_generics_and_classes);
+                  Message(parser_e_type_var_const_only_in_generics_and_classes);
                 consume(_VAR);
                 fields_allowed:=true;
                 object_member_blocktype:=bt_general;
                 classfields:=is_classdef;
                 is_classdef:=false;
               end;
+            _CONST:
+              begin
+                if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
+                   (current_objectdef.objecttype<>odt_class) then
+                  Message(parser_e_type_var_const_only_in_generics_and_classes);
+                consume(_CONST);
+                object_member_blocktype:=bt_const;
+              end;
             _ID :
               begin
                 if is_objcprotocol(current_objectdef) and
@@ -671,7 +679,13 @@ implementation
                               read_record_fields([vd_object])
                           end
                         else
-                          types_dec(true);
+                        if object_member_blocktype=bt_type then
+                          types_dec(true)
+                        else
+                        if object_member_blocktype=bt_const then
+                          consts_dec(true)
+                        else
+                          internalerror(201001110);
                       end;
                 end;
               end;

compiler/pexpr.pas

@@ -1252,7 +1252,12 @@ implementation
                    begin
                      p1:=ctypenode.create(ttypesym(sym).typedef);
                    end;
-                 else internalerror(16);
+                 constsym:
+                   begin
+                     p1:=genconstsymtree(tconstsym(sym));
+                   end
+                 else
+                   internalerror(16);
               end;
            end;
       end;
@@ -1559,44 +1564,14 @@ implementation
 
                 constsym :
                   begin
-                    case tconstsym(srsym).consttyp of
-                      constord :
-                        begin
-                          if tconstsym(srsym).constdef=nil then
-                            internalerror(200403232);
-                          p1:=cordconstnode.create(tconstsym(srsym).value.valueord,tconstsym(srsym).constdef,true);
-                        end;
-                      conststring :
-                        begin
-                          len:=tconstsym(srsym).value.len;
-                          if not(cs_ansistrings in current_settings.localswitches) and (len>255) then
-                           len:=255;
-                          getmem(pc,len+1);
-                          move(pchar(tconstsym(srsym).value.valueptr)^,pc^,len);
-                          pc[len]:=#0;
-                          p1:=cstringconstnode.createpchar(pc,len);
-                        end;
-                      constwstring :
-                        p1:=cstringconstnode.createwstr(pcompilerwidestring(tconstsym(srsym).value.valueptr));
-                      constreal :
-                        p1:=crealconstnode.create(pbestreal(tconstsym(srsym).value.valueptr)^,pbestrealtype^);
-                      constset :
-                        p1:=csetconstnode.create(pconstset(tconstsym(srsym).value.valueptr),tconstsym(srsym).constdef);
-                      constpointer :
-                        p1:=cpointerconstnode.create(tconstsym(srsym).value.valueordptr,tconstsym(srsym).constdef);
-                      constnil :
-                        p1:=cnilnode.create;
-                      constresourcestring:
-                        begin
-                          p1:=cloadnode.create(srsym,srsymtable);
-                          do_typecheckpass(p1);
-                          p1.resultdef:=cansistringtype;
-                        end;
-                      constguid :
-                        p1:=cguidconstnode.create(pguid(tconstsym(srsym).value.valueptr)^);
-                      else
-                        internalerror(200507181);
-                    end;
+                    if tconstsym(srsym).consttyp=constresourcestring then
+                      begin
+                        p1:=cloadnode.create(srsym,srsymtable);
+                        do_typecheckpass(p1);
+                        p1.resultdef:=cansistringtype;
+                      end
+                    else
+                      p1:=genconstsymtree(tconstsym(srsym));
                   end;
 
                 procsym :

tests/test/tclass12a.pp

@@ -0,0 +1,23 @@
+program tclass12a;
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+{$apptype console}
+
+type
+  TSomeClass = class
+  strict private
+    const
+      PrivateConst = 3.14;
+  public
+    class procedure WritePrivateConst; static;
+  end;
+
+  class procedure TSomeClass.WritePrivateConst;
+  begin
+    WriteLn(PrivateConst);
+  end;
+
+begin
+  TSomeClass.WritePrivateConst;
+end.

tests/test/tclass12b.pp

@@ -0,0 +1,27 @@
+{ %FAIL}
+program tclass12b;
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+{$apptype console}
+
+type
+  TSomeClass = class
+  strict private
+    const
+      PrivateConst = 3.14;
+  end;
+
+  TAnotherClass = class(TSomeClass)
+  public
+    class procedure WritePrivateConst; static;
+  end;
+
+  class procedure TAnotherClass.WritePrivateConst;
+  begin
+    WriteLn(PrivateConst)
+  end;
+
+begin
+  TAnotherClass.WritePrivateConst
+end.