* protected visibility fixes

compiler/ncal.pas

@@ -55,6 +55,7 @@ interface
 
        tcallnode = class(tbinarynode)
        private
+          paravisible : boolean;
           paralength : smallint;
           function  candidates_find:pcandidate;
           procedure candidates_free(procs:pcandidate);
@@ -1192,6 +1193,7 @@ type
         procs,hp   : pcandidate;
         found,
         has_overload_directive : boolean;
+        topclassh  : tobjectdef;
         srsymtable : tsymtable;
         srprocsym  : tprocsym;
 
@@ -1226,7 +1228,25 @@ type
            (symtableprocentry.owner.symtabletype=objectsymtable) then
          search_class_overloads(symtableprocentry);
 
+         { when the class passed is defined in this unit we
+           need to use the scope of that class. This is a trick
+           that can be used to access protected members in other
+           units. At least kylix supports it this way (PFV) }
+         if assigned(symtableproc) and
+            (symtableproc.symtabletype=objectsymtable) and
+            (symtableproc.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
+            (symtableproc.defowner.owner.unitid=0) then
+           topclassh:=tobjectdef(symtableproc.defowner)
+         else
+           begin
+             if assigned(current_procinfo) then
+               topclassh:=current_procinfo.procdef._class
+             else
+               topclassh:=nil;
+           end;
+
         { link all procedures which have the same # of parameters }
+        paravisible:=false;
         for j:=1 to symtableprocentry.procdef_count do
           begin
             pd:=symtableprocentry.procdef[j];
@@ -1236,8 +1256,10 @@ type
               when the callnode is generated by a property }
             if (nf_isproperty in flags) or
                (pd.owner.symtabletype<>objectsymtable) or
-               pd.is_visible_for_proc(current_procinfo.procdef) then
+               pd.is_visible_for_object(topclassh) then
              begin
+               { we have at least one procedure that is visible }
+               paravisible:=false;
                { only when the # of parameter are supported by the
                  procedure }
                if (paralength>=pd.minparacount) and
@@ -1267,7 +1289,7 @@ type
                   { process only visible procsyms }
                   if assigned(srprocsym) and
                      (srprocsym.typ=procsym) and
-                     srprocsym.is_visible_for_proc(current_procinfo.procdef) then
+                     srprocsym.is_visible_for_object(topclassh) then
                    begin
                      { if this procedure doesn't have overload we can stop
                        searching }
@@ -1960,7 +1982,8 @@ type
                    procs:=candidates_find;
 
                    { no procedures found? then there is something wrong
-                     with the parameter size }
+                     with the parameter size or the procedures are
+                     not accessible }
                    if not assigned(procs) then
                     begin
                       { when it's an auto inherited call and there
@@ -1997,8 +2020,13 @@ type
                             begin
                               if assigned(left) then
                                aktfilepos:=left.fileinfo;
-                              CGMessage(parser_e_wrong_parameter_size);
-                              symtableprocentry.write_parameter_lists(nil);
+                              if paravisible then
+                                begin
+                                  CGMessage(parser_e_wrong_parameter_size);
+                                  symtableprocentry.write_parameter_lists(nil);
+                                end
+                              else
+                                CGMessage(parser_e_cant_access_private_member);
                             end;
                         end;
                       goto errorexit;
@@ -2516,7 +2544,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.185  2003-10-01 20:34:48  peter
+  Revision 1.186  2003-10-02 21:13:46  peter
+    * protected visibility fixes
+
+  Revision 1.185  2003/10/01 20:34:48  peter
     * procinfo unit contains tprocinfo
     * cginfo renamed to cgbase
     * moved cgmessage to verbose

compiler/pexpr.pas

@@ -27,7 +27,7 @@ unit pexpr;
 interface
 
     uses
-      symtype,
+      symtype,symdef,
       node,
       globals,
       cpuinfo;
@@ -46,7 +46,7 @@ interface
     function parse_paras(__colon,in_prop_paras : boolean) : tnode;
 
     { the ID token has to be consumed before calling this function }
-    procedure do_member_read(getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callnflags:tnodeflags);
+    procedure do_member_read(classh:tobjectdef;getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callnflags:tnodeflags);
 
 {$ifdef int64funcresok}
     function get_intconst:TConstExprInt;
@@ -68,7 +68,7 @@ implementation
        globtype,tokens,verbose,
        systems,widestr,
        { symtable }
-       symconst,symbase,symdef,symsym,symtable,defutil,defcmp,
+       symconst,symbase,symsym,symtable,defutil,defcmp,
        { pass 1 }
        pass_1,htypechk,
        nutils,nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,
@@ -660,7 +660,7 @@ implementation
 
 
     { reads the parameter for a subroutine call }
-    procedure do_proc_call(sym:tsym;st:tsymtable;getaddr:boolean;var again : boolean;var p1:tnode);
+    procedure do_proc_call(sym:tsym;st:tsymtable;obj:tobjectdef;getaddr:boolean;var again : boolean;var p1:tnode);
       var
          membercall,
          prevafterassn : boolean;
@@ -747,7 +747,14 @@ implementation
                    consume(_RKLAMMER);
                  end;
               end;
-             p1:=ccallnode.create(para,tprocsym(sym),st,p1);
+             if assigned(obj) then
+               begin
+                 if (st.symtabletype<>objectsymtable) then
+                   internalerror(200310031);
+                 p1:=ccallnode.create(para,tprocsym(sym),obj.symtable,p1);
+               end
+             else
+               p1:=ccallnode.create(para,tprocsym(sym),st,p1);
              { indicate if this call was generated by a member and
                no explicit self is used, this is needed to determine
                how to handle a destructor call (PFV) }
@@ -953,7 +960,7 @@ implementation
 
 
     { the ID token has to be consumed before calling this function }
-    procedure do_member_read(getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callnflags:tnodeflags);
+    procedure do_member_read(classh:tobjectdef;getaddr : boolean;sym : tsym;var p1 : tnode;var again : boolean;callnflags:tnodeflags);
 
       var
          static_name : string;
@@ -990,7 +997,7 @@ implementation
               case sym.typ of
                  procsym:
                    begin
-                      do_proc_call(sym,sym.owner,
+                      do_proc_call(sym,sym.owner,classh,
                                    (getaddr and not(token in [_CARET,_POINT])),
                                    again,p1);
                       { add provided flags }
@@ -1236,7 +1243,7 @@ implementation
                                  srsym:=searchsym_in_class(tobjectdef(htype.def),pattern);
                                  check_hints(srsym);
                                  consume(_ID);
-                                 do_member_read(false,srsym,p1,again,[]);
+                                 do_member_read(tobjectdef(htype.def),false,srsym,p1,again,[]);
                                end
                               else
                                begin
@@ -1260,7 +1267,7 @@ implementation
                               else
                                begin
                                  consume(_ID);
-                                 do_member_read(getaddr,srsym,p1,again,[]);
+                                 do_member_read(tobjectdef(htype.def),getaddr,srsym,p1,again,[]);
                                end;
                             end;
                          end
@@ -1284,7 +1291,7 @@ implementation
                                 else
                                  begin
                                    consume(_ID);
-                                   do_member_read(getaddr,srsym,p1,again,[]);
+                                   do_member_read(tobjectdef(htype.def),getaddr,srsym,p1,again,[]);
                                  end;
                               end
                              else
@@ -1366,7 +1373,7 @@ implementation
                                     not(is_interface(tdef(srsym.owner.defowner))) and
                                     assigned(current_procinfo) and
                                     (po_classmethod in current_procinfo.procdef.procoptions);
-                    do_proc_call(srsym,srsymtable,
+                    do_proc_call(srsym,srsymtable,nil,
                                  (getaddr and not(token in [_CARET,_POINT])),
                                  again,p1);
                     { we need to know which procedure is called }
@@ -1681,7 +1688,7 @@ implementation
                              else
                               begin
                                 consume(_ID);
-                                do_member_read(getaddr,hsym,p1,again,[]);
+                                do_member_read(classh,getaddr,hsym,p1,again,[]);
                               end;
                            end;
 
@@ -1704,7 +1711,7 @@ implementation
                               else
                                 begin
                                    consume(_ID);
-                                   do_member_read(getaddr,hsym,p1,again,[]);
+                                   do_member_read(classh,getaddr,hsym,p1,again,[]);
                                 end;
                            end;
 
@@ -1886,7 +1893,7 @@ implementation
                         htype.setdef(classh);
                         p1:=ctypenode.create(htype);
                       end;
-                     do_member_read(false,sym,p1,again,[nf_inherited,nf_anon_inherited]);
+                     do_member_read(classh,false,sym,p1,again,[nf_inherited,nf_anon_inherited]);
                    end
                   else
                    begin
@@ -1901,7 +1908,7 @@ implementation
                                (sym.typ<>procsym) then
                               internalerror(200303171);
                             p1:=nil;
-                            do_proc_call(sym,sym.owner,false,again,p1);
+                            do_proc_call(sym,sym.owner,classh,false,again,p1);
                           end
                         else
                           begin
@@ -2416,7 +2423,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.130  2003-10-01 20:34:49  peter
+  Revision 1.131  2003-10-02 21:15:31  peter
+    * protected visibility fixes
+
+  Revision 1.130  2003/10/01 20:34:49  peter
     * procinfo unit contains tprocinfo
     * cginfo renamed to cgbase
     * moved cgmessage to verbose

compiler/pinline.pas

@@ -148,11 +148,11 @@ implementation
                 else
                   callflag:=nf_dispose_call;
                 if is_new then
-                  do_member_read(false,sym,p2,again,[callflag])
+                  do_member_read(classh,false,sym,p2,again,[callflag])
                 else
                   begin
                     if not(m_fpc in aktmodeswitches) then
-                      do_member_read(false,sym,p2,again,[callflag])
+                      do_member_read(classh,false,sym,p2,again,[callflag])
                     else
                       begin
                         p2:=ccallnode.create(nil,tprocsym(sym),sym.owner,p2);
@@ -364,7 +364,7 @@ implementation
             afterassignment:=false;
             sym:=searchsym_in_class(classh,pattern);
             consume(_ID);
-            do_member_read(false,sym,p1,again,[nf_new_call]);
+            do_member_read(classh,false,sym,p1,again,[nf_new_call]);
             { we need to know which procedure is called }
             do_resulttypepass(p1);
             if not(
@@ -685,7 +685,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.19  2003-10-01 20:34:49  peter
+  Revision 1.20  2003-10-02 21:15:31  peter
+    * protected visibility fixes
+
+  Revision 1.19  2003/10/01 20:34:49  peter
     * procinfo unit contains tprocinfo
     * cginfo renamed to cgbase
     * moved cgmessage to verbose

compiler/symdef.pas

@@ -554,7 +554,7 @@ interface
           function  cplusplusmangledname : string;
           function  is_methodpointer:boolean;override;
           function  is_addressonly:boolean;override;
-          function  is_visible_for_proc(currprocdef:tprocdef):boolean;
+//          function  is_visible_for_proc(currprocdef:tprocdef):boolean;
           function  is_visible_for_object(currobjdef:tobjectdef):boolean;
           { debug }
 {$ifdef GDB}
@@ -3709,6 +3709,7 @@ implementation
       end;
 
 
+(*
     function tprocdef.is_visible_for_proc(currprocdef:tprocdef):boolean;
       begin
         is_visible_for_proc:=false;
@@ -3739,7 +3740,7 @@ implementation
 
         is_visible_for_proc:=true;
       end;
-
+*)
 
     function tprocdef.is_visible_for_object(currobjdef:tobjectdef):boolean;
       begin
@@ -3753,7 +3754,8 @@ implementation
           exit;
 
         { protected symbols are vissible in the module that defines them and
-          also visible to related objects }
+          also visible to related objects. The related object must be defined
+          in the current module }
         if (sp_protected in symoptions) and
            (
             (
@@ -3762,6 +3764,7 @@ implementation
             ) and
             not(
                 assigned(currobjdef) and
+                (currobjdef.owner.unitid=0) and
                 currobjdef.is_related(tobjectdef(owner.defowner))
                )
            ) then
@@ -5897,7 +5900,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.168  2003-10-01 20:34:49  peter
+  Revision 1.169  2003-10-02 21:19:42  peter
+    * protected visibility fixes
+
+  Revision 1.168  2003/10/01 20:34:49  peter
     * procinfo unit contains tprocinfo
     * cginfo renamed to cgbase
     * moved cgmessage to verbose

compiler/symtable.pas

@@ -1910,7 +1910,12 @@ implementation
             (classh.owner.unitid=0) then
            topclassh:=classh
          else
-           topclassh:=nil;
+           begin
+             if assigned(current_procinfo) then
+               topclassh:=current_procinfo.procdef._class
+             else
+               topclassh:=nil;
+           end;
          sym:=nil;
          def:=nil;
          while assigned(classh) do
@@ -1929,11 +1934,7 @@ implementation
                       break;
                    end
                   else
-                   begin
-                     if (not assigned(current_procinfo) or
-                         tprocdef(def).is_visible_for_proc(current_procinfo.procdef)) then
-                      break;
-                   end;
+                   break;
                 end;
                def:=tdef(def.indexnext);
              end;
@@ -1960,7 +1961,12 @@ implementation
             (classh.owner.unitid=0) then
            topclassh:=classh
          else
-           topclassh:=nil;
+           begin
+             if assigned(current_procinfo) then
+               topclassh:=current_procinfo.procdef._class
+             else
+               topclassh:=nil;
+           end;
          sym:=nil;
          def:=nil;
          while assigned(classh) do
@@ -1979,11 +1985,7 @@ implementation
                       break;
                    end
                   else
-                   begin
-                     if (not assigned(current_procinfo) or
-                         tprocdef(def).is_visible_for_proc(current_procinfo.procdef)) then
-                      break;
-                   end;
+                   break;
                 end;
                def:=tdef(def.indexnext);
              end;
@@ -2259,7 +2261,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.111  2003-10-01 19:05:33  peter
+  Revision 1.112  2003-10-02 21:13:46  peter
+    * protected visibility fixes
+
+  Revision 1.111  2003/10/01 19:05:33  peter
     * searchsym_type to search for type definitions. It ignores
       records,objects and parameters