* merged sealed and abstract support by Paul Ishenin

-- Zusammenführen von r13884 in ».«:
U    compiler/msgtxt.inc
U    compiler/msgidx.inc
U    compiler/pdecsub.pas
U    compiler/pdecobj.pas
U    compiler/tokens.pas
U    compiler/ppu.pas
U    compiler/symconst.pas
U    compiler/msg/errore.msg
U    compiler/utils/ppudump.pp
-- Zusammenführen von r13885 in ».«:
A    tests/test/tsealed1.pp
A    tests/test/tabstract1.pp
A    tests/test/tsealed2.pp
-- Zusammenführen von r13893 in ».«:
A    tests/test/tsealed3.pp
A    tests/test/tsealed4.pp

git-svn-id: trunk@13908 -

.gitattributes

@@ -8087,6 +8087,7 @@ tests/test/packages/win-base/tdispvar1.pp svneol=native#text/plain
 tests/test/packages/zlib/tzlib1.pp svneol=native#text/plain
 tests/test/t4cc1.pp svneol=native#text/plain
 tests/test/t4cc2.pp svneol=native#text/plain
+tests/test/tabstract1.pp svneol=native#text/pascal
 tests/test/tabstrcl.pp svneol=native#text/plain
 tests/test/tabsvr1.pp svneol=native#text/plain
 tests/test/tabsvr2.pp svneol=native#text/plain
@@ -8397,6 +8398,10 @@ tests/test/trtti2.pp svneol=native#text/plain
 tests/test/trtti3.pp svneol=native#text/plain
 tests/test/trtti4.pp svneol=native#text/plain
 tests/test/trtti5.pp svneol=native#text/plain
+tests/test/tsealed1.pp svneol=native#text/pascal
+tests/test/tsealed2.pp svneol=native#text/pascal
+tests/test/tsealed3.pp svneol=native#text/pascal
+tests/test/tsealed4.pp svneol=native#text/pascal
 tests/test/tsel1.pp svneol=native#text/plain
 tests/test/tsel2.pp svneol=native#text/plain
 tests/test/tset1.pp svneol=native#text/plain

compiler/msg/errore.msg

@@ -366,7 +366,7 @@ scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure
 #
 # Parser
 #
-# 03252 is the last used one
+# 03255 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -1189,6 +1189,12 @@ parser_e_no_local_para_def=03252_E_Parameters cannot contain local type definiti
 % refer to the same type definition in the procedure headers of the interface and implementation of a unit
 % (both procedure headers would define a separate type). Keep in mind that expressions such as
 % ``file of byte'' or ``string[50]'' also define a new type.
+parser_e_abstract_and_sealed_conflict=03253_E_ABSTRACT and SEALED conflict
+% ABSTRACT and SEALED can not be used together in one declaration
+parser_e_sealed_descendant=03254_E_Can not create a descendant of the sealed class "$1"
+% Sealed means that class can not be derived by another class.
+parser_e_sealed_class_cannot_have_abstract_methods=03255_E_SEALED class can not have an ABSTRACT method
+% Sealed means that class cannot be derived. Therefore no one class is able to override an abstract method in a sealed class.
 % \end{description}
 #
 # Type Checking

compiler/msgidx.inc

@@ -340,6 +340,9 @@ const
   parser_n_ignore_lower_visibility=03250;
   parser_e_field_not_allowed_here=03251;
   parser_e_no_local_para_def=03252;
+  parser_e_abstract_and_sealed_conflict=03253;
+  parser_e_sealed_descendant=03254;
+  parser_e_sealed_class_cannot_have_abstract_methods=03255;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -792,9 +795,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 51733;
+  MsgTxtSize = 51884;
 
   MsgIdxMax : array[1..20] of longint=(
-    24,87,253,90,65,50,108,22,202,62,
+    24,87,256,90,65,50,108,22,202,62,
     48,20,1,1,1,1,1,1,1,1
   );

compiler/pdecobj.pas

@@ -218,6 +218,24 @@ implementation
         p.free;
       end;
 
+    procedure parse_object_options;
+      begin
+        if current_objectdef.objecttype = odt_class then
+          begin
+            while true do
+              begin
+                if try_to_consume(_ABSTRACT) then
+                  include(current_objectdef.objectoptions,oo_is_abstract)
+                else
+                if try_to_consume(_SEALED) then
+                  include(current_objectdef.objectoptions,oo_is_sealed)
+                else
+                  break;
+              end;
+            if [oo_is_abstract, oo_is_sealed] * current_objectdef.objectoptions = [oo_is_abstract, oo_is_sealed] then
+              Message(parser_e_abstract_and_sealed_conflict);
+          end;
+      end;
 
     procedure parse_parent_classes;
       var
@@ -260,7 +278,10 @@ implementation
                             end
                           else
                             Message(parser_e_mix_of_classes_and_objects);
-                       end;
+                       end
+                     else
+                       if oo_is_sealed in childof.objectoptions then
+                         Message1(parser_e_sealed_descendant,childof.typename);
                    odt_interfacecorba,
                    odt_interfacecom:
                      begin
@@ -716,6 +737,9 @@ implementation
           end
         else
           begin
+            { parse list of options (abstract / sealed) }
+            parse_object_options;
+
             { parse list of parent classes }
             parse_parent_classes;
 

compiler/pdecsub.pas

@@ -1254,6 +1254,9 @@ procedure pd_abstract(pd:tabstractprocdef);
 begin
   if pd.typ<>procdef then
     internalerror(200304269);
+  if oo_is_sealed in tprocdef(pd)._class.objectoptions then
+    Message(parser_e_sealed_class_cannot_have_abstract_methods)
+  else
   if (po_virtualmethod in pd.procoptions) then
     include(pd.procoptions,po_abstractmethod)
   else

compiler/ppu.pas

@@ -43,7 +43,7 @@ type
 {$endif Test_Double_checksum}
 
 const
-  CurrentPPUVersion = 100;
+  CurrentPPUVersion = 101;
 
 { buffer sizes }
   maxentrysize = 1024;

compiler/symconst.pas

@@ -304,6 +304,8 @@ type
   { options for objects and classes }
   tobjectoption=(oo_none,
     oo_is_forward,         { the class is only a forward declared yet }
+    oo_is_abstract,        { the class is abstract - only descendants can be used }
+    oo_is_sealed,          { the class is sealed - can't have descendants }
     oo_has_virtual,        { the object/class has virtual methods }
     oo_has_private,
     oo_has_protected,

compiler/tokens.pas

@@ -170,6 +170,7 @@ type
     _REPEAT,
     _RESULT,
     _RETURN,
+    _SEALED,
     _STATIC,
     _STORED,
     _STRICT,
@@ -422,6 +423,7 @@ const
       (str:'REPEAT'        ;special:false;keyword:m_all;op:NOTOKEN),
       (str:'RESULT'        ;special:false;keyword:m_none;op:NOTOKEN),
       (str:'RETURN'        ;special:false;keyword:m_mac;op:NOTOKEN),
+      (str:'SEALED'        ;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),

compiler/utils/ppudump.pp

@@ -1354,6 +1354,8 @@ procedure readobjectdefoptions;
 type
   tobjectoption=(oo_none,
     oo_is_forward,         { the class is only a forward declared yet }
+    oo_is_abstract,        { the class is abstract - only descendants can be used }
+    oo_is_sealed,          { the class is sealed - can't have descendants }
     oo_has_virtual,        { the object/class has virtual methods }
     oo_has_private,
     oo_has_protected,
@@ -1376,6 +1378,8 @@ type
 const
   symopt : array[1..ord(high(tobjectoption))] of tsymopt=(
      (mask:oo_is_forward;         str:'IsForward'),
+     (mask:oo_is_abstract;        str:'IsAbstract'),
+     (mask:oo_is_sealed;          str:'IsSealed'),
      (mask:oo_has_virtual;        str:'HasVirtual'),
      (mask:oo_has_private;        str:'HasPrivate'),
      (mask:oo_has_protected;      str:'HasProtected'),

tests/test/tabstract1.pp

@@ -0,0 +1,49 @@
+{$ifdef fpc}
+{$mode objfpc}
+{$endif fpc}
+type
+  TAbstractClass = class abstract
+  public
+    procedure Test; virtual;
+  end;
+
+  TAbstractClassDescendant = class(TAbstractClass)
+  public
+    procedure Test; override;
+  end;
+
+  TSealedClass = class sealed
+  public
+    procedure Test;
+  end;
+
+procedure TAbstractClass.Test;
+begin
+end;
+
+procedure TAbstractClassDescendant.Test;
+begin
+end;
+
+procedure TSealedClass.Test;
+begin
+end;
+
+var
+  AClass: TAbstractClass;
+  AClassDesc: TAbstractClassDescendant;
+  SClass: TSealedClass;
+begin
+  AClass := TAbstractClass.Create;
+  AClass.Test;
+  AClass.Free;
+
+  AClassDesc:= TAbstractClassDescendant.Create;
+  AClassDesc.Test;
+  AClassDesc.Free;
+
+  SClass := TSealedClass.Create;
+  SClass.Test;
+  SClass.Free;
+end.
+

tests/test/tsealed1.pp

@@ -0,0 +1,17 @@
+{ %fail }
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  TSealedClass = class sealed
+  public
+  end;
+
+  TSealedDesdentantClass = class(TSealedClass)
+  public
+  end;
+
+begin
+end.
+

tests/test/tsealed2.pp

@@ -0,0 +1,14 @@
+{ %fail }
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  TSealedClass = class sealed
+  public
+    procedure TestAbstract; virtual; abstract;
+  end;
+
+begin
+end.
+

tests/test/tsealed3.pp

@@ -0,0 +1,12 @@
+{ %fail }
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  TSealedClass = class abstract sealed
+  public
+  end;
+begin
+end.
+

tests/test/tsealed4.pp

@@ -0,0 +1,15 @@
+{$ifdef fpc}
+{$mode objfpc}
+{$endif}
+
+type
+  TAbstractClass = class abstract abstract abstract
+  public
+  end;
+
+  TSealedClass = class sealed sealed sealed
+  public
+  end;
+begin
+end.
+