compiler: add support for visibility blocks in records and type, const declarations:

  - add parse_record_members function to parse record blocks based on parse_object_members code
  - disable published section in records
  - rename in_class argument in some functions to in_structure because the same code can work for records now which are not classes

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

compiler/msg/errore.msg

@@ -368,7 +368,7 @@ scanner_w_illegal_warn_identifier=02087_W_Illegal identifier "$1" for $WARN dire
 #
 # Parser
 #
-# 03296 is the last used one
+# 03298 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -1342,6 +1342,8 @@ parser_f_no_generic_inside_generic=03297_F_Declaration of generic class inside a
 % Since generics are implemented by recording tokens, it is not possible to
 % have declaration of generic class inside another generic class.
 % \end{description}
+parser_e_no_record_published=03298_E_Record types cannot have published sections.
+% Published sections can be used only inside classes
 #
 # Type Checking
 #

compiler/msgidx.inc

@@ -386,6 +386,7 @@ const
   parser_e_objc_missing_enumeration_defs=03295;
   parser_e_no_procvarnested_const=03296;
   parser_f_no_generic_inside_generic=03297;
+  parser_e_no_record_published=03298;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -871,9 +872,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 57905;
+  MsgTxtSize = 57958;
 
   MsgIdxMax : array[1..20] of longint=(
-    24,88,298,97,82,54,111,22,202,63,
+    24,88,299,97,82,54,111,22,202,63,
     49,20,1,1,1,1,1,1,1,1
   );

compiler/pdecl.pas

@@ -36,10 +36,10 @@ interface
     function  readconstant(const orgname:string;const filepos:tfileposinfo):tconstsym;
 
     procedure const_dec;
-    procedure consts_dec(in_class: boolean);
+    procedure consts_dec(in_structure: boolean);
     procedure label_dec;
     procedure type_dec;
-    procedure types_dec(in_class: boolean);
+    procedure types_dec(in_structure: boolean);
     procedure var_dec;
     procedure threadvar_dec;
     procedure property_dec(is_classpropery: boolean);
@@ -161,7 +161,7 @@ implementation
         consts_dec(false);
       end;
 
-    procedure consts_dec(in_class: boolean);
+    procedure consts_dec(in_structure: boolean);
       var
          orgname : TIDString;
          hdef : tdef;
@@ -254,7 +254,7 @@ implementation
                         tclist:=current_asmdata.asmlists[al_rotypedconsts]
                       else
                         tclist:=current_asmdata.asmlists[al_typedconsts];
-                      read_typed_const(tclist,tstaticvarsym(sym),in_class);
+                      read_typed_const(tclist,tstaticvarsym(sym),in_structure);
                     end;
                 end;
 
@@ -262,7 +262,7 @@ implementation
                 { generate an error }
                 consume(_EQUAL);
            end;
-         until (token<>_ID)or(in_class and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
+         until (token<>_ID)or(in_structure and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
          block_type:=old_block_type;
       end;
 
@@ -309,7 +309,7 @@ implementation
       end;
 
 
-    procedure types_dec(in_class: boolean);
+    procedure types_dec(in_structure: boolean);
 
       procedure get_cpp_class_external_status(od: tobjectdef);
         var
@@ -669,7 +669,7 @@ implementation
              end;
            if assigned(generictypelist) then
              generictypelist.free;
-         until (token<>_ID)or(in_class and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
+         until (token<>_ID)or(in_structure and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
          { resolve type block forward declarations and restore a unit
            container for them }
          resolve_forward_types;

compiler/pdecvar.pas

@@ -1407,7 +1407,7 @@ implementation
          sc:=TFPObjectList.create(false);
          recstlist:=TFPObjectList.create(false);;
          while (token=_ID) and
-            not((vd_object in options) and
+            not(([vd_object,vd_record]*options<>[]) and
                 (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED,_STRICT])) do
            begin
              visibility:=symtablestack.top.currentvisibility;

compiler/ptconst.pas

@@ -27,7 +27,7 @@ interface
 
    uses symtype,symsym,aasmdata;
 
-    procedure read_typed_const(list:tasmlist;sym:tstaticvarsym;in_class:boolean);
+    procedure read_typed_const(list:tasmlist;sym:tstaticvarsym;in_structure:boolean);
 
 
 implementation
@@ -1429,7 +1429,7 @@ implementation
 
 {$maxfpuregisters default}
 
-    procedure read_typed_const(list:tasmlist;sym:tstaticvarsym;in_class:boolean);
+    procedure read_typed_const(list:tasmlist;sym:tstaticvarsym;in_structure:boolean);
       var
         storefilepos : tfileposinfo;
         cursectype   : TAsmSectionType;
@@ -1461,7 +1461,7 @@ implementation
         consume(_SEMICOLON);
 
         { parse public/external/export/... }
-        if not in_class and
+        if not in_structure and
            (
             (
              (token = _ID) and

compiler/ptype.pas

@@ -72,7 +72,7 @@ implementation
        nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
        { parser }
        scanner,
-       pbase,pexpr,pdecsub,pdecvar,pdecobj;
+       pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl;
 
 
     procedure resolve_forward_types;
@@ -551,6 +551,325 @@ implementation
           end;
       end;
 
+    procedure parse_record_members(recorddef: trecorddef);
+
+        procedure maybe_parse_hint_directives(pd:tprocdef);
+        var
+          dummysymoptions : tsymoptions;
+          deprecatedmsg : pshortstring;
+        begin
+          dummysymoptions:=[];
+          deprecatedmsg:=nil;
+          while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do
+            Consume(_SEMICOLON);
+          if assigned(pd) then
+            begin
+              pd.symoptions:=pd.symoptions+dummysymoptions;
+              pd.deprecatedmsg:=deprecatedmsg;
+            end
+          else
+            stringdispose(deprecatedmsg);
+        end;
+
+      var
+        pd : tprocdef;
+        has_destructor,
+        oldparse_only: boolean;
+        member_blocktype : tblock_type;
+        fields_allowed, is_classdef, classfields: boolean;
+        vdoptions: tvar_dec_options;
+      begin
+        { empty record declaration ? }
+        if (token=_SEMICOLON) then
+          Exit;
+
+        recorddef.symtable.currentvisibility:=vis_public;
+        has_destructor:=false;
+        fields_allowed:=true;
+        is_classdef:=false;
+        classfields:=false;
+        member_blocktype:=bt_general;
+        repeat
+          case token of
+            _TYPE :
+              begin
+                consume(_TYPE);
+                member_blocktype:=bt_type;
+              end;
+            _VAR :
+              begin
+                consume(_VAR);
+                fields_allowed:=true;
+                member_blocktype:=bt_general;
+                classfields:=is_classdef;
+                is_classdef:=false;
+              end;
+            _CONST:
+              begin
+                consume(_CONST);
+                member_blocktype:=bt_const;
+              end;
+            _ID, _CASE :
+              begin
+                case idtoken of
+                  _PRIVATE :
+                    begin
+                       consume(_PRIVATE);
+                       recorddef.symtable.currentvisibility:=vis_private;
+                       fields_allowed:=true;
+                       is_classdef:=false;
+                       classfields:=false;
+                       member_blocktype:=bt_general;
+                     end;
+                   _PROTECTED :
+                     begin
+                       consume(_PROTECTED);
+                       recorddef.symtable.currentvisibility:=vis_protected;
+                       fields_allowed:=true;
+                       is_classdef:=false;
+                       classfields:=false;
+                       member_blocktype:=bt_general;
+                     end;
+                   _PUBLIC :
+                     begin
+                       consume(_PUBLIC);
+                       recorddef.symtable.currentvisibility:=vis_public;
+                       fields_allowed:=true;
+                       is_classdef:=false;
+                       classfields:=false;
+                       member_blocktype:=bt_general;
+                     end;
+                   _PUBLISHED :
+                     begin
+                       Message(parser_e_no_record_published);
+                       consume(_PUBLISHED);
+                       recorddef.symtable.currentvisibility:=vis_published;
+                       fields_allowed:=true;
+                       is_classdef:=false;
+                       classfields:=false;
+                       member_blocktype:=bt_general;
+                     end;
+                   _STRICT :
+                     begin
+                        consume(_STRICT);
+                        if token=_ID then
+                          begin
+                            case idtoken of
+                              _PRIVATE:
+                                begin
+                                  consume(_PRIVATE);
+                                  recorddef.symtable.currentvisibility:=vis_strictprivate;
+                                end;
+                              _PROTECTED:
+                                begin
+                                  consume(_PROTECTED);
+                                  recorddef.symtable.currentvisibility:=vis_strictprotected;
+                                end;
+                              else
+                                message(parser_e_protected_or_private_expected);
+                            end;
+                          end
+                        else
+                          message(parser_e_protected_or_private_expected);
+                        fields_allowed:=true;
+                        is_classdef:=false;
+                        classfields:=false;
+                        member_blocktype:=bt_general;
+                     end
+                    else
+                      begin
+                        if member_blocktype=bt_general then
+                          begin
+                            if (not fields_allowed) then
+                              Message(parser_e_field_not_allowed_here);
+                            vdoptions:=[vd_record];
+                            if classfields then
+                              include(vdoptions,vd_class);
+                            read_record_fields(vdoptions);
+                          end
+                        else if member_blocktype=bt_type then
+                          types_dec(true)
+                        else if member_blocktype=bt_const then
+                          consts_dec(true)
+                        else
+                          internalerror(201001110);
+                      end;
+                end;
+              end;
+            _PROPERTY :
+              begin
+                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 modifier is only allowed for procedures, functions, }
+                   { constructors, destructors, fields and properties          }
+                   if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR]) then
+                     Message(parser_e_procedure_or_function_expected);
+
+                   is_classdef:=true;
+                 end;
+              end;
+{ todo: record methods
+            _PROCEDURE,
+            _FUNCTION:
+              begin
+                oldparse_only:=parse_only;
+                parse_only:=true;
+                pd:=parse_proc_dec(is_classdef, recorddef);
+
+                { this is for error recovery as well as forward }
+                { interface mappings, i.e. mapping to a method  }
+                { which isn't declared yet                      }
+                if assigned(pd) then
+                  begin
+                    parse_object_proc_directives(pd);
+
+                    { check if dispid is set }
+                    if is_dispinterface(pd._class) and not (po_dispid in pd.procoptions) then
+                      begin
+                        pd.dispid:=pd._class.get_next_dispid;
+                        include(pd.procoptions, po_dispid);
+                      end;
+
+                    { all Macintosh Object Pascal methods are virtual.  }
+                    { this can't be a class method, because macpas mode }
+                    { has no m_class                                    }
+                    if (m_mac in current_settings.modeswitches) then
+                      include(pd.procoptions,po_virtualmethod);
+
+                    handle_calling_convention(pd);
+
+                    { add definition to procsym }
+                    proc_add_definition(pd);
+
+                    { add procdef options to objectdef options }
+                    if (po_msgint in pd.procoptions) then
+                      include(current_objectdef.objectoptions,oo_has_msgint);
+                    if (po_msgstr in pd.procoptions) then
+                      include(current_objectdef.objectoptions,oo_has_msgstr);
+                    if (po_virtualmethod in pd.procoptions) then
+                      include(current_objectdef.objectoptions,oo_has_virtual);
+
+                    chkcpp(pd);
+                    chkobjc(pd);
+                  end;
+
+                maybe_parse_hint_directives(pd);
+
+                parse_only:=oldparse_only;
+                fields_allowed:=false;
+                is_classdef:=false;
+              end;
+            _CONSTRUCTOR :
+              begin
+                if (current_objectdef.symtable.currentvisibility=vis_published) and
+                  not(oo_can_have_published in current_objectdef.objectoptions) then
+                  Message(parser_e_cant_have_published);
+
+                if not is_classdef and not(current_objectdef.symtable.currentvisibility in [vis_public,vis_published]) then
+                  Message(parser_w_constructor_should_be_public);
+
+                if is_interface(current_objectdef) then
+                  Message(parser_e_no_con_des_in_interfaces);
+
+                { Objective-C does not know the concept of a constructor }
+                if is_objc_class_or_protocol(current_objectdef) then
+                  Message(parser_e_objc_no_constructor_destructor);
+
+                { only 1 class constructor is allowed }
+                if is_classdef and (oo_has_class_constructor in current_objectdef.objectoptions) then
+                  Message1(parser_e_only_one_class_constructor_allowed, current_objectdef.objrealname^);
+
+                oldparse_only:=parse_only;
+                parse_only:=true;
+                if is_classdef then
+                  pd:=class_constructor_head
+                else
+                  pd:=constructor_head;
+                parse_object_proc_directives(pd);
+                handle_calling_convention(pd);
+
+                { add definition to procsym }
+                proc_add_definition(pd);
+
+                { add procdef options to objectdef options }
+                if (po_virtualmethod in pd.procoptions) then
+                  include(current_objectdef.objectoptions,oo_has_virtual);
+                chkcpp(pd);
+                maybe_parse_hint_directives(pd);
+
+                parse_only:=oldparse_only;
+                fields_allowed:=false;
+                is_classdef:=false;
+              end;
+            _DESTRUCTOR :
+              begin
+                if (current_objectdef.symtable.currentvisibility=vis_published) and
+                   not(oo_can_have_published in current_objectdef.objectoptions) then
+                  Message(parser_e_cant_have_published);
+
+                if not is_classdef then
+                  if has_destructor then
+                    Message(parser_n_only_one_destructor)
+                  else
+                    has_destructor:=true;
+
+                if is_interface(current_objectdef) then
+                  Message(parser_e_no_con_des_in_interfaces);
+
+                if not is_classdef and (current_objectdef.symtable.currentvisibility<>vis_public) then
+                  Message(parser_w_destructor_should_be_public);
+
+                { Objective-C does not know the concept of a destructor }
+                if is_objc_class_or_protocol(current_objectdef) then
+                  Message(parser_e_objc_no_constructor_destructor);
+
+                { only 1 class destructor is allowed }
+                if is_classdef and (oo_has_class_destructor in current_objectdef.objectoptions) then
+                  Message1(parser_e_only_one_class_destructor_allowed, current_objectdef.objrealname^);
+
+                oldparse_only:=parse_only;
+                parse_only:=true;
+                if is_classdef then
+                  pd:=class_destructor_head
+                else
+                  pd:=destructor_head;
+                parse_object_proc_directives(pd);
+                handle_calling_convention(pd);
+
+                { add definition to procsym }
+                proc_add_definition(pd);
+
+                { add procdef options to objectdef options }
+                if (po_virtualmethod in pd.procoptions) then
+                  include(current_objectdef.objectoptions,oo_has_virtual);
+
+                chkcpp(pd);
+                maybe_parse_hint_directives(pd);
+
+                parse_only:=oldparse_only;
+                fields_allowed:=false;
+                is_classdef:=false;
+              end;
+}
+            _END :
+              begin
+                consume(_END);
+                break;
+              end;
+            else
+              consume(_ID); { Give a ident expected message, like tp7 }
+          end;
+        until false;
+      end;
+
     { reads a record declaration }
     function record_dec : tdef;
       var
@@ -558,13 +877,12 @@ implementation
       begin
          { create recdef }
          recst:=trecordsymtable.create(current_settings.packrecords);
-         record_dec:=trecorddef.create(recst);
+         result:=trecorddef.create(recst);
          { insert in symtablestack }
          symtablestack.push(recst);
          { parse record }
          consume(_RECORD);
-         read_record_fields([vd_record]);
-         consume(_END);
+         parse_record_members(trecorddef(result));
          { make the record size aligned }
          recst.addalignmentpadding;
          { restore symtable stack }