+ strict protected and strict private support

git-svn-id: trunk@512 -

.gitattributes

@@ -4419,6 +4419,10 @@ tests/tbf/tb0170.pp svneol=native#text/plain
 tests/tbf/tb0171.pp svneol=native#text/plain
 tests/tbf/tb0172.pp svneol=native#text/plain
 tests/tbf/tb0173.pp svneol=native#text/plain
+tests/tbf/tb0174a.pp svneol=native#text/plain
+tests/tbf/tb0174b.pp svneol=native#text/plain
+tests/tbf/tb0174c.pp svneol=native#text/plain
+tests/tbf/tb0174d.pp svneol=native#text/plain
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain
@@ -4905,6 +4909,7 @@ tests/tbs/tb0489.pp svneol=native#text/plain
 tests/tbs/tb0490.pp svneol=native#text/plain
 tests/tbs/tb0491.pp svneol=native#text/plain
 tests/tbs/tb0492.pp svneol=native#text/plain
+tests/tbs/tb0493.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
 tests/tbs/ub0119.pp svneol=native#text/plain

compiler/msg/errore.msg

@@ -1008,6 +1008,8 @@ parser_e_no_static_method_in_interfaces=03212_E_Class and static methods can't b
 % because all methods of an interfaces must be public.
 parser_e_arithmetic_operation_overflow=03213_E_Overflow in arithmetic operation
 % An operation on two integers values produced an overflow
+parser_e_protected_or_private_expected=03214_E_Protected or private expected
+% \var{strict} can be only used together with \var{protected} or \var{private}.
 % \end{description}
 #
 # Type Checking

compiler/pdecobj.pas

@@ -561,17 +561,44 @@ implementation
                            consume(_PUBLISHED);
                            current_object_option:=[sp_published];
                          end;
-                       else
+                       _STRICT :
                          begin
                            if is_interface(aktclass) then
-                             Message(parser_e_no_vars_in_interfaces);
+                              Message(parser_e_no_access_specifier_in_interfaces);
+                            consume(_STRICT);
+                            if token=_ID then
+                              begin
+                                case idtoken of
+                                  _PRIVATE:
+                                    begin
+                                      consume(_PRIVATE);
+                                      current_object_option:=[sp_strictprivate];
+                                      include(aktclass.objectoptions,oo_has_strictprivate);
+                                    end;
+                                  _PROTECTED:
+                                    begin
+                                      consume(_PROTECTED);
+                                      current_object_option:=[sp_strictprotected];
+                                      include(aktclass.objectoptions,oo_has_strictprotected);
+                                    end;
+                                  else
+                                    message(parser_e_protected_or_private_expected);
+                                end;
+                              end
+                            else
+                              message(parser_e_protected_or_private_expected);
+                          end;
+                        else
+                          begin
+                            if is_interface(aktclass) then
+                              Message(parser_e_no_vars_in_interfaces);
 
-                           if (sp_published in current_object_option) and
-                             not(oo_can_have_published in aktclass.objectoptions) then
-                             Message(parser_e_cant_have_published);
+                            if (sp_published in current_object_option) and
+                              not(oo_can_have_published in aktclass.objectoptions) then
+                              Message(parser_e_cant_have_published);
 
-                           read_var_decs(false,true,false);
-                         end;
+                            read_var_decs(false,true,false);
+                          end;
                     end;
                   end;
                 _PROPERTY :

compiler/pdecvar.pas

@@ -721,7 +721,7 @@ implementation
          { read vars }
          sc:=tsinglelist.create;
          while (token=_ID) and
-               not(is_object and (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED])) do
+               not(is_object and (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED,_STRICT])) do
            begin
              sorg:=orgpattern;
              semicoloneaten:=false;

compiler/ptype.pas

@@ -550,19 +550,19 @@ implementation
                      { don't forget that min can be negativ  PM }
                      enumdef :
                        if tenumdef(tt2.def).min>=0 then
-                        tt.setdef(tsetdef.create(tt2,tenumdef(tt2.def).max))
+                        tt.setdef(tsetdef.create(tt2,tenumdef(tt2.def).min,tenumdef(tt2.def).max))
                        else
                         Message(sym_e_ill_type_decl_set);
                      orddef :
                        begin
                          case torddef(tt2.def).typ of
                            uchar :
-                             tt.setdef(tsetdef.create(tt2,255));
+                             tt.setdef(tsetdef.create(tt2,0,255));
                            u8bit,u16bit,u32bit,
                            s8bit,s16bit,s32bit :
                              begin
                                if (torddef(tt2.def).low>=0) then
-                                tt.setdef(tsetdef.create(tt2,torddef(tt2.def).high))
+                                tt.setdef(tsetdef.create(tt2,torddef(tt2.def).low,torddef(tt2.def).high))
                                else
                                 Message(sym_e_ill_type_decl_set);
                              end;

compiler/symconst.pas

@@ -145,7 +145,9 @@ type
     sp_hint_library,
     sp_hint_unimplemented,
     sp_has_overloaded,
-    sp_internal  { internal symbol, not reported as unused }
+    sp_internal,  { internal symbol, not reported as unused }
+    sp_strictprivate,
+    sp_strictprotected
   );
   tsymoptions=set of tsymoption;
 
@@ -201,7 +203,7 @@ type
 
   { set types }
   tsettype = (
-    normset,smallset,varset
+    normset,smallset
   );
 
   tvarianttype = (
@@ -283,6 +285,8 @@ type
     oo_has_virtual,        { the object/class has virtual methods }
     oo_has_private,
     oo_has_protected,
+    oo_has_strictprivate,
+    oo_has_strictprotected,
     oo_has_constructor,    { the object/class has a constructor }
     oo_has_destructor,     { the object/class has a destructor }
     oo_has_vmt,            { the object/class has a vmt }
@@ -410,6 +414,8 @@ const
 
 
 const
+   inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has_protected,
+                oo_has_strictprotected,oo_has_strictprivate,oo_has_constructor,oo_has_destructor];
    clearstack_pocalls = [
      pocall_cdecl,pocall_cppdecl,pocall_syscall
    ];

compiler/symdef.pas

@@ -705,7 +705,9 @@ interface
        tsetdef = class(tstoreddef)
           elementtype : ttype;
           settype : tsettype;
-          constructor create(const t:ttype;high : longint);
+          setbase,
+          setmax : aint;
+          constructor create(const t:ttype;low,high : aint);
           constructor ppuload(ppufile:tcompilerppufile);
           destructor  destroy;override;
           function getcopy : tstoreddef;override;
@@ -2714,7 +2716,9 @@ implementation
          inherited create;
          deftype:=setdef;
          elementtype:=t;
-         if high<32 then
+         setbase:=low;
+         setmax:=high;
+         if (high-low)+1<=32 then
            begin
             settype:=smallset;
            {$ifdef testvarsets}
@@ -2757,6 +2761,9 @@ implementation
             varset : savesize:=ppufile.getlongint;
             smallset : savesize:=Sizeof(longint);
          end;
+          normset : savesize:=ppufile.getaint;
+          smallset : savesize:=Sizeof(longint);
+        end;
       end;
 
 
@@ -2786,6 +2793,8 @@ implementation
          ppufile.putbyte(byte(settype));
          if settype=varset then
            ppufile.putlongint(savesize);
+         if settype=normset then
+           ppufile.putaint(savesize);
          ppufile.writeentry(ibsetdef);
       end;
 
@@ -3202,9 +3211,9 @@ implementation
         { static variables from objects are like global objects }
         if (Tsym(p).typ=fieldvarsym) and not (sp_static in Tsym(p).symoptions) then
           begin
-            if (sp_protected in tsym(p).symoptions) then
+            if ([sp_protected,sp_strictprotected]*tsym(p).symoptions)<>[] then
               spec:='/1'
-            else if (sp_private in tsym(p).symoptions) then
+            else if ([sp_private,sp_strictprivate]*tsym(p).symoptions)<>[] then
               spec:='/0'
             else
               spec:='';
@@ -4069,7 +4078,20 @@ implementation
            not(owner.defowner.owner.iscurrentunit) then
           exit;
 
-        { protected symbols are vissible in the module that defines them and
+        if (sp_strictprivate in symoptions) then
+          begin
+            result:=currobjdef=tobjectdef(owner.defowner);
+            exit;
+          end;
+
+        if (sp_strictprotected in symoptions) then
+          begin
+             result:=assigned(currobjdef) and
+               currobjdef.is_related(tobjectdef(owner.defowner));
+             exit;
+          end;
+
+        { protected symbols are visible in the module that defines them and
           also visible to related objects. The related object must be defined
           in the current module }
         if (sp_protected in symoptions) and
@@ -5139,8 +5161,7 @@ implementation
              { only important for classes }
              lastvtableindex:=c.lastvtableindex;
              objectoptions:=objectoptions+(c.objectoptions*
-               [oo_has_virtual,oo_has_private,oo_has_protected,
-                oo_has_constructor,oo_has_destructor]);
+               inherited_objectoptions);
              if not (objecttype in [odt_interfacecom,odt_interfacecorba]) then
                begin
                   { add the data of the anchestor class }
@@ -5387,9 +5408,9 @@ implementation
               end;
            { here 2A must be changed for private and protected }
            { 0 is private 1 protected and 2 public }
-           if (sp_private in tsym(p).symoptions) then
+           if ([sp_private,sp_strictprivate]*tsym(p).symoptions)<>[] then
              sp:='0'
-           else if (sp_protected in tsym(p).symoptions) then
+           else if ([sp_protected,sp_strictprocted*tsym(p).symoptions)<>[] then
              sp:='1'
            else
              sp:='2';

compiler/symsym.pas

@@ -125,7 +125,11 @@ interface
           function search_procdef_byprocvardef(d:Tprocvardef):Tprocdef;
           function search_procdef_assignment_operator(fromdef,todef:tdef;var besteq:tequaltype):Tprocdef;
           function  write_references(ppufile:tcompilerppufile;locals:boolean):boolean;override;
-          function is_visible_for_object(currobjdef:tdef):boolean;override;
+          { currobjdef is the object def to assume, this is necessary for protected and
+            private,
+            context is the object def we're really in, this is for the strict stuff
+          }
+          function is_visible_for_object(currobjdef:tdef;context:tdef):boolean;override;
 {$ifdef GDB}
           function stabstring : pchar;override;
 {$endif GDB}
@@ -1107,7 +1111,7 @@ implementation
       end;
 
 
-    function tprocsym.is_visible_for_object(currobjdef:tdef):boolean;
+    function tprocsym.is_visible_for_object(currobjdef:tdef;context:tdef):boolean;
       var
         p : pprocdeflist;
       begin

compiler/symtable.pas

@@ -1196,7 +1196,7 @@ implementation
               { but private ids can be reused }
               hsym:=search_class_member(tobjectdef(defowner),sym.name);
               if assigned(hsym) and
-                 Tsym(hsym).is_visible_for_object(tobjectdef(defowner)) then
+                 tsym(hsym).is_visible_for_object(tobjectdef(defowner),tobjectdef(defowner)) then
                 DuplicateSym(sym,hsym);
            end;
          inherited insert(sym);
@@ -1282,7 +1282,7 @@ implementation
                hsym:=search_class_member(tobjectdef(next.next.defowner),sym.name);
                if assigned(hsym) and
                  { private ids can be reused }
-                  (hsym.is_visible_for_object(tobjectdef(next.next.defowner)) or
+                  (hsym.is_visible_for_object(tobjectdef(next.next.defowner),tobjectdef(next.next.defowner)) or
                    (hsym.owner.defowner.owner.symtabletype<>globalsymtable)) then
                 begin
                   { delphi allows to reuse the names in a class, but not
@@ -1323,7 +1323,7 @@ implementation
               hsym:=search_class_member(tobjectdef(next.defowner),sym.name);
               { private ids can be reused }
               if assigned(hsym) and
-                 Tsym(hsym).is_visible_for_object(tobjectdef(next.defowner)) then
+                 Tsym(hsym).is_visible_for_object(tobjectdef(next.defowner),tobjectdef(next.defowner)) then
                begin
                  { delphi allows to reuse the names in a class, but not
                    in object (tp7 compatible) }
@@ -1809,6 +1809,7 @@ implementation
       var
         speedvalue : cardinal;
         topclass   : tobjectdef;
+        context : tobjectdef;
       begin
          speedvalue:=getspeedvalue(s);
          srsymtable:=symtablestack;
@@ -1831,7 +1832,11 @@ implementation
                      if assigned(current_procinfo) then
                        topclass:=current_procinfo.procdef._class;
                    end;
-                 if Tsym(srsym).is_visible_for_object(topclass) then
+                 if assigned(current_procinfo) then
+                   context:=current_procinfo.procdef._class
+                 else
+                   context:=nil;
+                 if tsym(srsym).is_visible_for_object(topclass,context) then
                    begin
                      { we need to know if a procedure references symbols
                        in the static symtable, because then it can't be
@@ -1868,7 +1873,7 @@ implementation
                   srsym:=tsym(srsymtable.speedsearch(s,speedvalue));
                   if assigned(srsym) and
                      (not assigned(current_procinfo) or
-                      Tsym(srsym).is_visible_for_object(current_procinfo.procdef._class)) then
+                      tsym(srsym).is_visible_for_object(current_procinfo.procdef._class,current_procinfo.procdef._class)) then
                     begin
                       result:=true;
                       exit;
@@ -1909,7 +1914,7 @@ implementation
        end;
 
 
-    function  searchsym_in_class(classh:tobjectdef;const s : stringid):tsym;
+    function searchsym_in_class(classh:tobjectdef;const s : stringid):tsym;
       var
         speedvalue : cardinal;
         topclassh  : tobjectdef;
@@ -1936,7 +1941,7 @@ implementation
           begin
             sym:=tsym(classh.symtable.speedsearch(s,speedvalue));
             if assigned(sym) and
-               Tsym(sym).is_visible_for_object(topclassh) then
+               Tsym(sym).is_visible_for_object(topclassh,current_procinfo.procdef._class) then
               break;
             classh:=classh.childof;
           end;
@@ -1944,7 +1949,7 @@ implementation
       end;
 
 
-    function  searchsym_in_class_by_msgint(classh:tobjectdef;i:longint):tsym;
+    function searchsym_in_class_by_msgint(classh:tobjectdef;i:longint):tsym;
       var
         topclassh  : tobjectdef;
         def        : tdef;
@@ -1995,7 +2000,7 @@ implementation
       end;
 
 
-    function  searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string):tsym;
+    function searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string):tsym;
       var
         topclassh  : tobjectdef;
         def        : tdef;
@@ -2218,7 +2223,7 @@ implementation
             begin
               if (srsym.typ<>procsym) then
                internalerror(200111022);
-              if srsym.is_visible_for_object(tobjectdef(aprocsym.owner.defowner)) then
+              if srsym.is_visible_for_object(tobjectdef(aprocsym.owner.defowner),tobjectdef(aprocsym.owner.defowner)) then
                begin
                  srsym.add_para_match_to(Aprocsym,[cpo_ignorehidden,cpo_allowdefaults]);
                  { we can stop if the overloads were already added

compiler/symtype.pas

@@ -118,7 +118,11 @@ interface
          function  gettypedef:tdef;virtual;
          procedure load_references(ppufile:tcompilerppufile;locals:boolean);virtual;
          function  write_references(ppufile:tcompilerppufile;locals:boolean):boolean;virtual;
-         function is_visible_for_object(currobjdef:Tdef):boolean;virtual;
+         { currobjdef is the object def to assume, this is necessary for protected and
+           private,
+           context is the object def we're really in, this is for the strict stuff
+         }
+         function is_visible_for_object(currobjdef:tdef;context : tdef):boolean;virtual;
       end;
 
       tsymarr = array[0..maxlongint div sizeof(pointer)-1] of tsym;
@@ -475,7 +479,7 @@ implementation
       end;
 
 
-    function Tsym.is_visible_for_object(currobjdef:Tdef):boolean;
+    function Tsym.is_visible_for_object(currobjdef:Tdef;context : tdef):boolean;
       begin
         is_visible_for_object:=false;
 
@@ -487,7 +491,21 @@ implementation
            (not owner.defowner.owner.iscurrentunit) then
           exit;
 
-        { protected symbols are vissible in the module that defines them and
+        if (sp_strictprivate in symoptions) then
+          begin
+            result:=assigned(currobjdef) and
+              (context=tdef(owner.defowner));
+            exit;
+          end;
+
+        if (sp_strictprotected in symoptions) then
+          begin
+            result:=assigned(context) and
+              context.is_related(tdef(owner.defowner));
+            exit;
+          end;
+
+        { protected symbols are visible in the module that defines them and
           also visible to related objects }
         if (sp_protected in symoptions) and
            (

compiler/tokens.pas

@@ -167,6 +167,7 @@ type
     _RESULT,
     _STATIC,
     _STORED,
+    _STRICT,
     _STRING,
     _SYSTEM,
     _ASMNAME,
@@ -406,6 +407,7 @@ const
       (str:'RESULT'        ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'STATIC'        ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'STORED'        ;special:false;keyword:m_none;op:NOTOKEN),
+      (str:'STRICT'        ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'STRING'        ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'SYSTEM'        ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'ASMNAME'       ;special:false;keyword:m_none;op:NOTOKEN),

tests/tbf/tb0174a.pp

@@ -0,0 +1,42 @@
+{ %fail }
+{$mode objfpc}
+
+type
+  tobject1 = class
+  strict protected
+    spro : integer;
+  strict private
+    spriv : integer;
+  public
+    procedure p1;
+  end;
+
+
+  tobject2 = class(tobject1)
+    procedure p2;
+  end;
+
+procedure tobject1.p1;
+  begin
+    spro:=1;
+    spriv:=2;
+  end;
+
+procedure tobject2.p2;
+  begin
+    spro:=3;
+    spriv:=1;
+  end;
+
+var
+  o1 : tobject1;
+  o2 : tobject2;
+
+begin
+  o1:=tobject1.create;
+  o2:=tobject2.create;
+  o1.free;
+  o2.free;
+end.
+
+

tests/tbf/tb0174b.pp

@@ -0,0 +1,42 @@
+{ %fail }
+{$mode objfpc}
+
+type
+  tobject1 = class
+  strict protected
+    spro : integer;
+  strict private
+    spriv : integer;
+  public
+    procedure p1;
+  end;
+
+
+  tobject2 = class(tobject1)
+    procedure p2;
+  end;
+
+procedure tobject1.p1;
+  begin
+    spro:=1;
+    spriv:=2;
+  end;
+
+procedure tobject2.p2;
+  begin
+    spro:=3;
+  end;
+
+var
+  o1 : tobject1;
+  o2 : tobject2;
+
+begin
+  o1:=tobject1.create;
+  o2:=tobject2.create;
+  o1.spro:=1;
+  o1.free;
+  o2.free;
+end.
+
+

tests/tbf/tb0174c.pp

@@ -0,0 +1,42 @@
+{ %fail }
+{$mode objfpc}
+
+type
+  tobject1 = class
+  strict protected
+    spro : integer;
+  strict private
+    spriv : integer;
+  public
+    procedure p1;
+  end;
+
+
+  tobject2 = class(tobject1)
+    procedure p2;
+  end;
+
+procedure tobject1.p1;
+  begin
+    spro:=1;
+    spriv:=2;
+  end;
+
+procedure tobject2.p2;
+  begin
+    spro:=3;
+  end;
+
+var
+  o1 : tobject1;
+  o2 : tobject2;
+
+begin
+  o1:=tobject1.create;
+  o2:=tobject2.create;
+  o1.spriv:=1;
+  o1.free;
+  o2.free;
+end.
+
+

tests/tbf/tb0174d.pp

@@ -0,0 +1,39 @@
+{ %fail }
+{$mode objfpc}
+
+type
+  tobject1 = class
+  strict protected
+    spro : integer;
+  strict private
+    spriv : integer;
+  public
+    procedure p1;
+  end;
+
+
+  tobject2 = class(tobject1)
+    procedure p2;
+  end;
+
+procedure tobject1.p1;
+  begin
+  end;
+
+procedure tobject2.p2;
+  begin
+  end;
+
+var
+  o1 : tobject1;
+  o2 : tobject2;
+
+begin
+  o1:=tobject1.create;
+  o2:=tobject2.create;
+  o2.spro:=1;
+  o1.free;
+  o2.free;
+end.
+
+

tests/tbs/tb0493.pp

@@ -0,0 +1,40 @@
+{$mode objfpc}
+
+type
+  tobject1 = class
+  strict protected
+    spro : integer;
+  strict private
+    spriv : integer;
+  public
+    procedure p1;
+  end;
+
+
+  tobject2 = class(tobject1)
+    procedure p2;
+  end;
+
+procedure tobject1.p1;
+  begin
+    spro:=1;
+    spriv:=2;
+  end;
+
+procedure tobject2.p2;
+  begin
+    spro:=3;
+  end;
+
+var
+  o1 : tobject1;
+  o2 : tobject2;
+
+begin
+  o1:=tobject1.create;
+  o2:=tobject2.create;
+  o1.free;
+  o2.free;
+end.
+
+