compiler: check visibility of record members, allow access to record consts and types:

  - add searchsym_in_record function
  - change is_visible_for_object to accept tabstractrecorddef instead of tobjectdef arguments because records also have visibility sections now
  - change arguments in do_member_read, do_proc_call to tabstractrecorddef from tobjectdef to accept records
  - rename classh arguments to structh and change their type to tabstractrecorddef to show that they can accept records now too
  - move RttiName from tobjectdef to tabstractrecorddef

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

compiler/pexpr.pas

@@ -44,7 +44,7 @@ interface
     function parse_paras(__colon,__namedpara : boolean;end_of_paras : ttoken) : tnode;
 
     { the ID token has to be consumed before calling this function }
-    procedure do_member_read(classh:tobjectdef;getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callflags:tcallnodeflags);
+    procedure do_member_read(structh:tabstractrecorddef;getaddr:boolean;sym:tsym;var p1:tnode;var again:boolean;callflags:tcallnodeflags);
 
     function get_intconst:TConstExprInt;
     function get_stringconst:string;
@@ -854,7 +854,7 @@ implementation
 
 
     { reads the parameter for a subroutine call }
-    procedure do_proc_call(sym:tsym;st:TSymtable;obj:tobjectdef;getaddr:boolean;var again : boolean;var p1:tnode;callflags:tcallnodeflags);
+    procedure do_proc_call(sym:tsym;st:TSymtable;obj:tabstractrecorddef;getaddr:boolean;var again : boolean;var p1:tnode;callflags:tcallnodeflags);
       var
          membercall,
          prevafterassn : boolean;
@@ -965,7 +965,7 @@ implementation
                include(callflags,cnf_member_call);
              if assigned(obj) then
                begin
-                 if (st.symtabletype<>ObjectSymtable) then
+                 if not (st.symtabletype in [ObjectSymtable,recordsymtable]) then
                    internalerror(200310031);
                  p1:=ccallnode.create(para,tprocsym(sym),obj.symtable,p1,callflags);
                end
@@ -1190,7 +1190,7 @@ implementation
 
 
     { the ID token has to be consumed before calling this function }
-    procedure do_member_read(classh:tobjectdef;getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callflags:tcallnodeflags);
+    procedure do_member_read(structh:tabstractrecorddef;getaddr:boolean;sym:tsym;var p1:tnode;var again:boolean;callflags:tcallnodeflags);
       var
          static_name : string;
          isclassref  : boolean;
@@ -1222,7 +1222,7 @@ implementation
               case sym.typ of
                  procsym:
                    begin
-                      do_proc_call(sym,sym.owner,classh,
+                      do_proc_call(sym,sym.owner,structh,
                                    (getaddr and not(token in [_CARET,_POINT])),
                                    again,p1,callflags);
                       { we need to know which procedure is called }
@@ -1255,7 +1255,7 @@ implementation
                               (
                                 is_self_node(p1) or
                                 (assigned(current_procinfo) and (current_procinfo.procdef.no_self_node) and
-                                 (current_procinfo.procdef._class = classh))) then
+                                 (current_procinfo.procdef._class = structh))) then
                               Message(parser_e_only_class_members)
                             else
                               Message(parser_e_only_class_members_via_class_ref);
@@ -1875,7 +1875,7 @@ implementation
           p2,p3  : tnode;
           srsym  : tsym;
           srsymtable : TSymtable;
-          classh     : tobjectdef;
+          structh    : tabstractrecorddef;
           { shouldn't be used that often, so the extra overhead is ok to save
             stack space }
           dispatchstring : ansistring;
@@ -2059,21 +2059,25 @@ implementation
                         begin
                           if token=_ID then
                             begin
-                              srsym:=tsym(trecorddef(p1.resultdef).symtable.Find(pattern));
-                              if assigned(srsym) and
-                                 (srsym.typ=fieldvarsym) then
+                              structh:=tabstractrecorddef(p1.resultdef);
+                              searchsym_in_record(structh,pattern,srsym,srsymtable);
+                              if assigned(srsym) and (srsym.typ=fieldvarsym) then
                                 begin
                                   check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
-                                  p1:=csubscriptnode.create(srsym,p1)
+                                  consume(_ID);
+                                  do_member_read(structh,getaddr,srsym,p1,again,[]);
                                 end
                               else
                                 begin
-                                  Message1(sym_e_illegal_field,pattern);
+                                  Message1(sym_e_id_no_member,orgpattern);
                                   p1.destroy;
                                   p1:=cerrornode.create;
+                                  { try to clean up }
+                                  consume(_ID);
                                 end;
-                            end;
-                          consume(_ID);
+                            end
+                          else
+                            consume(_ID);
                         end;
                       enumdef:
                         begin
@@ -2134,13 +2138,13 @@ implementation
                          begin
                            if token=_ID then
                              begin
-                               classh:=tobjectdef(tclassrefdef(p1.resultdef).pointeddef);
-                               searchsym_in_class(classh,classh,pattern,srsym,srsymtable);
+                               structh:=tobjectdef(tclassrefdef(p1.resultdef).pointeddef);
+                               searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable);
                                if assigned(srsym) then
                                  begin
                                    check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
                                    consume(_ID);
-                                   do_member_read(classh,getaddr,srsym,p1,again,[]);
+                                   do_member_read(structh,getaddr,srsym,p1,again,[]);
                                  end
                                else
                                  begin
@@ -2158,13 +2162,13 @@ implementation
                          begin
                            if token=_ID then
                              begin
-                               classh:=tobjectdef(p1.resultdef);
-                               searchsym_in_class(classh,classh,pattern,srsym,srsymtable);
+                               structh:=tobjectdef(p1.resultdef);
+                               searchsym_in_class(tobjectdef(structh),tobjectdef(structh),pattern,srsym,srsymtable);
                                if assigned(srsym) then
                                  begin
                                     check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
                                     consume(_ID);
-                                    do_member_read(classh,getaddr,srsym,p1,again,[]);
+                                    do_member_read(structh,getaddr,srsym,p1,again,[]);
                                  end
                                else
                                  begin

compiler/symdef.pas

@@ -168,12 +168,15 @@ interface
           function  GetTypeName:string;override;
        end;
 
+       { tabstractrecorddef }
+
        tabstractrecorddef= class(tstoreddef)
           symtable : TSymtable;
           cloneddef      : tabstractrecorddef;
           cloneddefderef : tderef;
           function  GetSymtable(t:tGetSymtable):TSymtable;override;
           function is_packed:boolean;
+          function RttiName: string;
        end;
 
        trecorddef = class(tabstractrecorddef)
@@ -320,7 +323,6 @@ interface
           function check_objc_types: boolean;
           { C++ }
           procedure finish_cpp_data;
-          function RttiName: string;
        end;
 
        tclassrefdef = class(tabstractpointerdef)
@@ -2565,6 +2567,21 @@ implementation
         result:=tabstractrecordsymtable(symtable).is_packed;
       end;
 
+    function tabstractrecorddef.RttiName: string;
+      var
+        tmp: tabstractrecorddef;
+      begin
+        Result:=typename;
+        tmp:=self;
+        repeat
+          if tmp.owner.symtabletype in [ObjectSymtable,recordsymtable] then
+            tmp:=tabstractrecorddef(tmp.owner.defowner)
+          else
+            break;
+          Result:=tmp.typename+'.'+Result;
+        until tmp=nil;
+      end;
+
 
 {***************************************************************************
                                   trecorddef
@@ -5057,22 +5074,6 @@ implementation
         self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
       end;
 
-    function tobjectdef.RttiName: string;
-      var
-        tmp: tobjectdef;
-      begin
-        Result:=objrealname^;
-        tmp:=self;
-        repeat
-          if tmp.owner.symtabletype=ObjectSymtable then
-            tmp:=tobjectdef(tmp.owner.defowner)
-          else
-            break;
-          Result:=tmp.objrealname^+'.'+Result;
-        until tmp=nil;
-      end;
-
-
 {****************************************************************************
                              TImplementedInterface
 ****************************************************************************}

compiler/symtable.pas

@@ -200,14 +200,15 @@ interface
 
 {*** Search ***}
     procedure addsymref(sym:tsym);
-    function  is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tobjectdef):boolean;
-    function  is_visible_for_object(pd:tprocdef;contextobjdef:tobjectdef):boolean;
-    function  is_visible_for_object(sym:tsym;contextobjdef:tobjectdef):boolean;
+    function  is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
+    function  is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
+    function  is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
     function  searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
     function  searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
+    function  searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  search_system_type(const s: TIDString): ttypesym;
@@ -579,7 +580,7 @@ implementation
       begin
          if (tsym(sym).typ in [staticvarsym,localvarsym,paravarsym,fieldvarsym]) and
             ((tsym(sym).owner.symtabletype in
-             [parasymtable,localsymtable,ObjectSymtable,staticsymtable])) then
+             [parasymtable,localsymtable,ObjectSymtable,recordsymtable,staticsymtable])) then
            begin
             { unused symbol should be reported only if no }
             { error is reported                     }
@@ -602,8 +603,8 @@ implementation
                    end
                  else if (tsym(sym).owner.symtabletype=parasymtable) then
                    MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_not_used,tsym(sym).prettyname)
-                 else if (tsym(sym).owner.symtabletype=ObjectSymtable) then
-                   MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_not_used,tobjectdef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname)
+                 else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
+                   MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname)
                  else
                    MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_not_used,tsym(sym).prettyname);
               end
@@ -615,8 +616,8 @@ implementation
                         not(vo_is_funcret in tabstractvarsym(sym).varoptions) then
                        MessagePos1(tsym(sym).fileinfo,sym_h_para_identifier_only_set,tsym(sym).prettyname)
                    end
-                 else if (tsym(sym).owner.symtabletype=ObjectSymtable) then
-                   MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_only_set,tobjectdef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname)
+                 else if (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
+                   MessagePos2(tsym(sym).fileinfo,sym_n_private_identifier_only_set,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname)
                  else if tabstractvarsym(sym).varoptions*[vo_is_funcret,vo_is_public,vo_is_external]=[] then
                    MessagePos1(tsym(sym).fileinfo,sym_n_local_identifier_only_set,tsym(sym).prettyname);
               end
@@ -625,22 +626,22 @@ implementation
               MessagePos1(tsym(sym).fileinfo,sym_w_identifier_only_read,tsym(sym).prettyname)
           end
         else if ((tsym(sym).owner.symtabletype in
-              [ObjectSymtable,parasymtable,localsymtable,staticsymtable])) then
+              [ObjectSymtable,parasymtable,localsymtable,staticsymtable,recordsymtable])) then
           begin
            if (Errorcount<>0) or
               (sp_internal in tsym(sym).symoptions) then
              exit;
            { do not claim for inherited private fields !! }
-           if (tsym(sym).refs=0) and (tsym(sym).owner.symtabletype=ObjectSymtable) then
+           if (tsym(sym).refs=0) and (tsym(sym).owner.symtabletype in [ObjectSymtable,recordsymtable]) then
              case tsym(sym).typ of
                typesym:
-                 MessagePos2(tsym(sym).fileinfo,sym_n_private_type_not_used,tobjectdef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname);
+                 MessagePos2(tsym(sym).fileinfo,sym_n_private_type_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname);
                constsym:
-                 MessagePos2(tsym(sym).fileinfo,sym_n_private_const_not_used,tobjectdef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname);
+                 MessagePos2(tsym(sym).fileinfo,sym_n_private_const_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname);
                propertysym:
-                 MessagePos2(tsym(sym).fileinfo,sym_n_private_property_not_used,tobjectdef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname);
+                 MessagePos2(tsym(sym).fileinfo,sym_n_private_property_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname);
              else
-               MessagePos2(tsym(sym).fileinfo,sym_n_private_method_not_used,tobjectdef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname);
+               MessagePos2(tsym(sym).fileinfo,sym_n_private_method_not_used,tabstractrecorddef(tsym(sym).owner.defowner).RttiName,tsym(sym).prettyname);
              end
            { units references are problematic }
            else
@@ -679,9 +680,9 @@ implementation
            Don't test simple object aliases PM
          }
          if (tsym(sym).typ=typesym) and
-            (ttypesym(sym).typedef.typ=objectdef) and
+            (ttypesym(sym).typedef.typ in [objectdef,recorddef]) and
             (ttypesym(sym).typedef.typesym=tsym(sym)) then
-           tobjectdef(ttypesym(sym).typedef).symtable.SymList.ForEachCall(@TestPrivate,nil);
+           tabstractrecorddef(ttypesym(sym).typedef).symtable.SymList.ForEachCall(@TestPrivate,nil);
       end;
 
 
@@ -1603,8 +1604,8 @@ implementation
       var
         s1,s2 : string;
       begin
-        if def.typ=objectdef then
-          s1:=tobjectdef(def).RttiName
+        if def.typ in [objectdef,recorddef] then
+          s1:=tabstractrecorddef(def).RttiName
         else
           s1:=def.typename;
         { When the names are the same try to include the unit name }
@@ -1692,25 +1693,25 @@ implementation
        end;
 
 
-    function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tobjectdef):boolean;
+    function is_visible_for_object(symst:tsymtable;symvisibility:tvisibility;contextobjdef:tabstractrecorddef):boolean;
 
-      function is_holded_by(childdef,ownerdef: tobjectdef): boolean;
+      function is_holded_by(childdef,ownerdef: tabstractrecorddef): boolean;
         begin
           result:=childdef=ownerdef;
-          if not result and (childdef.owner.symtabletype=ObjectSymtable) then
-            result:=is_holded_by(tobjectdef(childdef.owner.defowner),ownerdef);
+          if not result and (childdef.owner.symtabletype in [ObjectSymtable,recordsymtable]) then
+            result:=is_holded_by(tabstractrecorddef(childdef.owner.defowner),ownerdef);
         end;
 
       var
-        symownerdef : tobjectdef;
+        symownerdef : tabstractrecorddef;
       begin
         result:=false;
 
         { Get objdectdef owner of the symtable for the is_related checks }
         if not assigned(symst) or
-           (symst.symtabletype<>objectsymtable) then
+           not (symst.symtabletype in [objectsymtable,recordsymtable]) then
           internalerror(200810285);
-        symownerdef:=tobjectdef(symst.defowner);
+        symownerdef:=tabstractrecorddef(symst.defowner);
         case symvisibility of
           vis_private :
             begin
@@ -1785,13 +1786,13 @@ implementation
       end;
 
 
-    function is_visible_for_object(pd:tprocdef;contextobjdef:tobjectdef):boolean;
+    function is_visible_for_object(pd:tprocdef;contextobjdef:tabstractrecorddef):boolean;
       begin
         result:=is_visible_for_object(pd.owner,pd.visibility,contextobjdef);
       end;
 
 
-    function is_visible_for_object(sym:tsym;contextobjdef:tobjectdef):boolean;
+    function is_visible_for_object(sym:tsym;contextobjdef:tabstractrecorddef):boolean;
       var
         i  : longint;
         pd : tprocdef;
@@ -1819,7 +1820,7 @@ implementation
     function  searchsym(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
       var
         hashedid   : THashedIDString;
-        contextobjdef : tobjectdef;
+        contextstructdef : tabstractrecorddef;
         stackitem  : psymtablestackitem;
       begin
         result:=false;
@@ -1845,14 +1846,14 @@ implementation
                       defined in this unit }
                     if (srsymtable.symtabletype=withsymtable) and
                        assigned(srsymtable.defowner) and
-                       (srsymtable.defowner.typ=objectdef) and
+                       (srsymtable.defowner.typ in [recorddef,objectdef]) and
                        (srsymtable.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
                        (srsymtable.defowner.owner.iscurrentunit) then
-                      contextobjdef:=tobjectdef(srsymtable.defowner)
+                      contextstructdef:=tobjectdef(srsymtable.defowner)
                     else
-                      contextobjdef:=current_objectdef;
-                    if (srsym.owner.symtabletype<>objectsymtable) or
-                       is_visible_for_object(srsym,contextobjdef) then
+                      contextstructdef:=current_objectdef;
+                    if not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or
+                       is_visible_for_object(srsym,contextstructdef) then
                       begin
                         { we need to know if a procedure references symbols
                           in the static symtable, because then it can't be
@@ -1903,7 +1904,7 @@ implementation
                 if assigned(srsym) and
                    not(srsym.typ in [fieldvarsym,paravarsym]) and
                    (
-                    (srsym.owner.symtabletype<>objectsymtable) or
+                    not (srsym.owner.symtabletype in [objectsymtable,recordsymtable]) or
                     (is_visible_for_object(srsym,current_objectdef) and
                      (srsym.typ=typesym))
                    ) then
@@ -2113,6 +2114,22 @@ implementation
           end;
       end;
 
+    function  searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
+      var
+        hashedid : THashedIDString;
+      begin
+        hashedid.id:=s;
+        srsymtable:=recordh.symtable;
+        srsym:=tsym(srsymtable.FindWithHash(hashedid));
+        if assigned(srsym) and is_visible_for_object(srsym,recordh) then
+          begin
+            addsymref(srsym);
+            result:=true;
+            exit;
+          end;
+        srsym:=nil;
+        srsymtable:=nil;
+      end;
 
     function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
       var