+ support for "final" fields in *external* (Java and other) classes, enabled

    via {$modeswitch finalfields} (on by default on the JVM target). The
    meaning is the same as in Java: a final (class) field can only be set
    in a (class) constructor of the class it's defined in, and can only be
    written once there (and *must* be set there). They are currently only
    supported for external classes since that basically turns them into
    constants, since for non-external classes we need full dataflow analysis
  o refactored pdecobj.parse_object_members() a bit in the process to reduce
    the amount of repetition (which would have been further increased for
    the support for final fields)
  o made error message about "wrong use of absolute" for fields etc generic,
    so it gives a proper error depending on which token was used (it had
    to be made generic for "final" support, but already was used for other
    things that were wrongly reported as "absolute" misusages)

git-svn-id: branches/jvmbackend@18398 -

compiler/globtype.pas

@@ -288,7 +288,10 @@ interface
          m_nested_procvars,     { support nested procedural variables }
          m_non_local_goto,      { support non local gotos (like iso pascal) }
          m_advanced_records,    { advanced record syntax with visibility sections, methods and properties }
-         m_isolike_unary_minus  { unary minus like in iso pascal: same precedence level as binary minus/plus }
+         m_isolike_unary_minus, { unary minus like in iso pascal: same precedence level as binary minus/plus }
+         m_final_fields         { allows declaring fields as "final", which means they must be initialised
+                                  in the (class) constructor and are constant from then on (same as final
+                                  fields in Java) }
        );
        tmodeswitches = set of tmodeswitch;
 
@@ -440,7 +443,8 @@ interface
          'NESTEDPROCVARS',
          'NONLOCALGOTO',
          'ADVANCEDRECORDS',
-         'ISOUNARYMINUS');
+         'ISOUNARYMINUS',
+         'FINALFIELDS');
 
 
      type

compiler/htypechk.pas

@@ -983,6 +983,11 @@ implementation
                  if (tloadnode(p).symtableentry.typ in [localvarsym,paravarsym,staticvarsym]) then
                    begin
                      hsym:=tabstractvarsym(tloadnode(p).symtableentry);
+                     { this check requires proper data flow analysis... }
+(*                     if (hsym.varspez=vs_final) and
+                        (hsym.varstate in [vs_written,vs_readwritten]) and
+                        (newstate in [vs_written,vs_readwritten]) then
+                       CGMessagePos1(p.fileinfo,sym_e_final_write_once); *)
                      if (vsf_must_be_valid in varstateflags) and
                         (hsym.varstate in [vs_declared,vs_read_not_warned,vs_referred_not_inited]) then
                        begin
@@ -1080,6 +1085,32 @@ implementation
         todef    : tdef;
         errmsg,
         temp     : longint;
+
+        function constaccessok(vs: tabstractvarsym): boolean;
+          begin
+            result:=false;
+            { allow p^:= constructions with p is const parameter }
+            if gotderef or gotdynarray or (Valid_Const in opts) or
+              (nf_isinternal_ignoreconst in hp.flags) then
+              result:=true
+            { final (class) fields can only be initialised in the (class) constructors of
+              class in which they have been declared (not in descendent constructors) }
+            else if vs.varspez=vs_final then
+              begin
+                if (current_procinfo.procdef.owner=vs.owner) then
+                  if sp_static in vs.symoptions then
+                    result:=current_procinfo.procdef.proctypeoption=potype_class_constructor
+                  else
+                    result:=current_procinfo.procdef.proctypeoption=potype_constructor;
+                if not result and
+                   report_errors then
+                  CGMessagePos(hp.fileinfo,type_e_invalid_final_assignment);
+              end
+            else
+              if report_errors then
+                CGMessagePos(hp.fileinfo,type_e_no_assign_to_const);
+          end;
+
       begin
         if valid_const in opts then
           errmsg:=type_e_variable_id_expected
@@ -1316,6 +1347,10 @@ implementation
                          CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr);
                      exit;
                    end;
+                 { check for final fields }
+                 if (tsubscriptnode(hp).vs.varspez=vs_final) and
+                    not constaccessok(tsubscriptnode(hp).vs) then
+                   exit;
                  gotsubscript:=true;
                  { loop counter? }
                  if not(Valid_Const in opts) and
@@ -1480,15 +1515,9 @@ implementation
                            exit;
                          end;
                        { read-only variable? }
-                       if (tabstractvarsym(tloadnode(hp).symtableentry).varspez in [vs_const,vs_constref]) then
+                       if (tabstractvarsym(tloadnode(hp).symtableentry).varspez in [vs_const,vs_constref,vs_final]) then
                         begin
-                          { allow p^:= constructions with p is const parameter }
-                          if gotderef or gotdynarray or (Valid_Const in opts) or
-                            (nf_isinternal_ignoreconst in tloadnode(hp).flags) then
-                            result:=true
-                          else
-                            if report_errors then
-                              CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const);
+                          result:=constaccessok(tabstractvarsym(tloadnode(hp).symtableentry));
                           exit;
                         end;
                        result:=true;

compiler/msg/errore.msg

@@ -375,7 +375,7 @@ scanner_e_illegal_alignment_directive=02088_E_Illegal alignment directive
 #
 # Parser
 #
-# 03310 is the last used one
+# 03315 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -675,9 +675,10 @@ parser_e_mix_of_classes_and_objects=03093_E_The mix of different kind of objects
 % a class cannot have an object as parent and vice versa.
 parser_w_unknown_proc_directive_ignored=03094_W_Unknown procedure directive had to be ignored: "$1"
 % The procedure directive you specified is unknown.
-parser_e_absolute_only_one_var=03095_E_absolute can only be associated to one variable
-% You cannot specify more than one variable before the \var{absolute} directive.
-% Thus, the following construct will provide this error:
+parser_e_directive_only_one_var=03095_E_$1 can be associated with only one variable
+% You cannot specify more than one variable before the \var{absolute}, \var{export}, \var{external},
+% \var{weakexternal}, \var{public} and \var{cvar} directives.
+% As a result, for example the following construct will provide this error:
 % \begin{verbatim}
 % Var Z : Longint;
 %     X,Y : Longint absolute Z;
@@ -1400,10 +1401,16 @@ parser_e_mapping_no_implements=03312_E_Interface "$1" can't be delegated by "$2"
 % has to implement the interface directly. Delegation is not possible.
 parser_e_implements_no_mapping=03313_E_Interface "$1" can't have method resolutions, "$2" already delegates it
 % Method resoulution is only possible for interfaces that are implemented directly, not by delegation.
+parser_e_final_only_const_var=03314_E_Only fields (var-sections) and constants can be final in object types
+% A final (class) field must be assigned a single value in the (class) constructor, and cannot
+% be overwritten afterwards. A final (typed) constant is read-only.
+parser_e_final_only_external=03315_E_Final fields are currently only supported for external classes
+% Support for final fields in non-external classes requires a full data flow
+% analysis implementation in FPC, which it currently still lacks.
 % \end{description}
 # Type Checking
 #
-# 04103 is the last used one
+# 04104 is the last used one
 #
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
@@ -1764,6 +1771,9 @@ type_e_record_helper_must_extend_same_record=04102_E_Derived record helper must
 type_e_java_class_method_not_static=04103_E_Java class methods have to be static
 % All methods in Java are either regular (virtual) methods, or static class
 % methods. It is not possible to declare non-static class methods.
+type_e_invalid_final_assignment=04104_E_Final (class) fields can only be assigned in their class' (class) constructor
+% It is only possible to assign a value to a final (class) field inside a (class) constructor of its owning class.
+%
 %
 % \end{description}
 #

compiler/msgidx.inc

@@ -194,7 +194,7 @@ const
   parser_f_unsupported_feature=03092;
   parser_e_mix_of_classes_and_objects=03093;
   parser_w_unknown_proc_directive_ignored=03094;
-  parser_e_absolute_only_one_var=03095;
+  parser_e_directive_only_one_var=03095;
   parser_e_absolute_only_to_var_or_const=03096;
   parser_e_initialized_only_one_var=03097;
   parser_e_abstract_no_definition=03098;
@@ -405,6 +405,8 @@ const
   parser_e_duplicate_implements_clause=03311;
   parser_e_mapping_no_implements=03312;
   parser_e_implements_no_mapping=03313;
+  parser_e_final_only_const_var=03314;
+  parser_e_final_only_external=03315;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -499,6 +501,7 @@ const
   type_e_class_helper_must_extend_subclass=04101;
   type_e_record_helper_must_extend_same_record=04102;
   type_e_java_class_method_not_static=04103;
+  type_e_invalid_final_assignment=04104;
   sym_e_id_not_found=05000;
   sym_f_internal_error_in_symtablestack=05001;
   sym_e_duplicate_id=05002;
@@ -901,9 +904,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 61050;
+  MsgTxtSize = 61281;
 
   MsgIdxMax : array[1..20] of longint=(
-    26,89,314,104,85,54,111,23,202,63,
+    26,89,316,105,85,54,111,23,202,63,
     49,20,1,1,1,1,1,1,1,1
   );

compiler/pdecl.pas

@@ -290,7 +290,11 @@ implementation
                 { generate an error }
                 consume(_EQ);
            end;
-         until (token<>_ID)or(in_structure and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
+         until (token<>_ID) or
+               (in_structure and
+                ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
+                 ((m_final_fields in current_settings.modeswitches) and
+                  (idtoken=_FINAL))));
          block_type:=old_block_type;
       end;
 
@@ -666,7 +670,11 @@ implementation
                hdef.typesym:=newtype;
                generictypelist.free;
              end;
-         until (token<>_ID)or(in_structure and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
+         until (token<>_ID) or
+               (in_structure and
+                ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
+                 ((m_final_fields in current_settings.modeswitches) and
+                  (idtoken=_FINAL))));
          { resolve type block forward declarations and restore a unit
            container for them }
          resolve_forward_types;

compiler/pdecobj.pas

@@ -754,10 +754,81 @@ implementation
       var
         pd : tprocdef;
         has_destructor,
-        oldparse_only: boolean;
+        oldparse_only,
+        typedconstswritable: boolean;
         object_member_blocktype : tblock_type;
-        fields_allowed, is_classdef, classfields: boolean;
+        fields_allowed, is_classdef, class_fields, is_final, final_fields: boolean;
         vdoptions: tvar_dec_options;
+
+
+      procedure parse_const;
+        begin
+          if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper,odt_javaclass]) then
+            Message(parser_e_type_var_const_only_in_records_and_classes);
+          consume(_CONST);
+          object_member_blocktype:=bt_const;
+          final_fields:=is_final;
+          is_final:=false;
+        end;
+
+
+      procedure parse_var;
+        begin
+          if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper,odt_javaclass]) then
+            Message(parser_e_type_var_const_only_in_records_and_classes);
+          consume(_VAR);
+          fields_allowed:=true;
+          object_member_blocktype:=bt_general;
+          class_fields:=is_classdef;
+          final_fields:=is_final;
+          is_classdef:=false;
+          is_final:=false;
+        end;
+
+
+      procedure parse_class;
+        begin
+          is_classdef:=false;
+          { read class method/field/property }
+          consume(_CLASS);
+          { 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);
+
+          if is_interface(current_structdef) or
+             is_javainterface(current_structdef) then
+            Message(parser_e_no_static_method_in_interfaces)
+          else
+            { class methods are also allowed for Objective-C protocols }
+            is_classdef:=true;
+        end;
+
+
+      procedure parse_visibility(vis: tvisibility; oo: tobjectoption);
+        begin
+          { Objective-C and Java classes do not support "published",
+            as basically everything is published.  }
+          if (vis=vis_published) and
+             (is_objc_class_or_protocol(current_structdef) or
+              is_java_class_or_interface(current_structdef)) then
+             Message(parser_e_no_objc_published)
+          else if is_interface(current_structdef) or
+             is_objc_protocol_or_category(current_structdef) or
+             is_javainterface(current_structdef) then
+            Message(parser_e_no_access_specifier_in_interfaces);
+          current_structdef.symtable.currentvisibility:=vis;
+          consume(token);
+          if (oo<>oo_none) then
+            include(current_structdef.objectoptions,oo);
+          fields_allowed:=true;
+          is_classdef:=false;
+          class_fields:=false;
+          is_final:=false;
+          object_member_blocktype:=bt_general;
+        end;
+
+
       begin
         { empty class declaration ? }
         if (current_objectdef.objecttype in [odt_class,odt_objcclass,odt_javaclass]) and
@@ -772,7 +843,9 @@ implementation
         has_destructor:=false;
         fields_allowed:=true;
         is_classdef:=false;
-        classfields:=false;
+        class_fields:=false;
+        is_final:=false;
+        final_fields:=false;
         object_member_blocktype:=bt_general;
         repeat
           case token of
@@ -785,20 +858,11 @@ implementation
               end;
             _VAR :
               begin
-                if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper,odt_javaclass]) then
-                  Message(parser_e_type_var_const_only_in_records_and_classes);
-                consume(_VAR);
-                fields_allowed:=true;
-                object_member_blocktype:=bt_general;
-                classfields:=is_classdef;
-                is_classdef:=false;
+                parse_var;
               end;
             _CONST:
               begin
-                if not(current_objectdef.objecttype in [odt_class,odt_object,odt_helper,odt_javaclass]) then
-                  Message(parser_e_type_var_const_only_in_records_and_classes);
-                consume(_CONST);
-                object_member_blocktype:=bt_const;
+                parse_const
               end;
             _ID :
               begin
@@ -812,63 +876,19 @@ implementation
                 else case idtoken of
                   _PRIVATE :
                     begin
-                      if is_interface(current_structdef) or
-                         is_objc_protocol_or_category(current_structdef) or
-                         is_javainterface(current_structdef) then
-                        Message(parser_e_no_access_specifier_in_interfaces);
-                       consume(_PRIVATE);
-                       current_structdef.symtable.currentvisibility:=vis_private;
-                       include(current_structdef.objectoptions,oo_has_private);
-                       fields_allowed:=true;
-                       is_classdef:=false;
-                       classfields:=false;
-                       object_member_blocktype:=bt_general;
+                      parse_visibility(vis_private,oo_has_private);
                      end;
                    _PROTECTED :
                      begin
-                       if is_interface(current_structdef) or
-                          is_objc_protocol_or_category(current_structdef) or
-                          is_javainterface(current_structdef) then
-                         Message(parser_e_no_access_specifier_in_interfaces);
-                       consume(_PROTECTED);
-                       current_structdef.symtable.currentvisibility:=vis_protected;
-                       include(current_structdef.objectoptions,oo_has_protected);
-                       fields_allowed:=true;
-                       is_classdef:=false;
-                       classfields:=false;
-                       object_member_blocktype:=bt_general;
+                       parse_visibility(vis_protected,oo_has_protected);
                      end;
                    _PUBLIC :
                      begin
-                       if is_interface(current_structdef) or
-                          is_objc_protocol_or_category(current_structdef) or
-                          is_javainterface(current_structdef) then
-                         Message(parser_e_no_access_specifier_in_interfaces);
-                       consume(_PUBLIC);
-                       current_structdef.symtable.currentvisibility:=vis_public;
-                       fields_allowed:=true;
-                       is_classdef:=false;
-                       classfields:=false;
-                       object_member_blocktype:=bt_general;
+                       parse_visibility(vis_public,oo_none);
                      end;
                    _PUBLISHED :
                      begin
-                       { we've to check for a pushlished section in non-  }
-                       { publishable classes later, if a real declaration }
-                       { this is the way, delphi does it                  }
-                       if is_interface(current_structdef) then
-                         Message(parser_e_no_access_specifier_in_interfaces);
-                       { Objective-C and Java classes do not support "published",
-                         as basically everything is published.  }
-                       if is_objc_class_or_protocol(current_structdef) or
-                          is_java_class_or_interface(current_structdef) then
-                         Message(parser_e_no_objc_published);
-                       consume(_PUBLISHED);
-                       current_structdef.symtable.currentvisibility:=vis_published;
-                       fields_allowed:=true;
-                       is_classdef:=false;
-                       classfields:=false;
-                       object_member_blocktype:=bt_general;
+                       parse_visibility(vis_published,oo_none);
                      end;
                    _STRICT :
                      begin
@@ -900,9 +920,27 @@ implementation
                           message(parser_e_protected_or_private_expected);
                         fields_allowed:=true;
                         is_classdef:=false;
-                        classfields:=false;
+                        class_fields:=false;
+                        is_final:=false;
+                        final_fields:=false;
                         object_member_blocktype:=bt_general;
                      end
+                    else if (m_final_fields in current_settings.modeswitches) and
+                            (token=_ID) and
+                            (idtoken=_FINAL) then
+                      begin
+                        { currently only supported for external classes, because
+                          requires fully working DFA otherwise }
+                        if (current_structdef.typ<>objectdef) or
+                           not(oo_is_external in tobjectdef(current_structdef).objectoptions) then
+                          Message(parser_e_final_only_external);
+                        consume(_final);
+                        is_final:=true;
+                        if token=_CLASS then
+                          parse_class;
+                        if not(token in [_CONST,_VAR]) then
+                          message(parser_e_final_only_const_var);
+                      end
                     else
                       begin
                         if object_member_blocktype=bt_general then
@@ -920,14 +958,28 @@ implementation
                               Message(parser_e_field_not_allowed_here);
 
                             vdoptions:=[vd_object];
-                            if classfields then
+                            if class_fields then
                               include(vdoptions,vd_class);
+                            if final_fields then
+                              include(vdoptions,vd_final);
                             read_record_fields(vdoptions);
                           end
                         else if object_member_blocktype=bt_type then
                           types_dec(true)
                         else if object_member_blocktype=bt_const then
-                          consts_dec(true)
+                          begin
+                            if final_fields then
+                              begin
+                                { the value of final fields cannot be changed
+                                  once they've been assigned a value }
+                                typedconstswritable:=cs_typed_const_writable in current_settings.localswitches;
+                                exclude(current_settings.localswitches,cs_typed_const_writable);
+                              end;
+                            consts_dec(true);
+                            if final_fields and
+                               typedconstswritable then
+                              include(current_settings.localswitches,cs_typed_const_writable);
+                          end
                         else
                           internalerror(201001110);
                       end;
@@ -941,20 +993,7 @@ implementation
               end;
             _CLASS:
               begin
-                is_classdef:=false;
-                { read class method/field/property }
-                consume(_CLASS);
-                { 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);
-
-                if is_interface(current_structdef) or
-                   is_javainterface(current_structdef) then
-                  Message(parser_e_no_static_method_in_interfaces)
-                else
-                  { class methods are also allowed for Objective-C protocols }
-                  is_classdef:=true;
+                parse_class;
               end;
             _PROCEDURE,
             _FUNCTION:

compiler/pdecvar.pas

@@ -30,7 +30,7 @@ interface
       symsym,symdef;
 
     type
-      tvar_dec_option=(vd_record,vd_object,vd_threadvar,vd_class);
+      tvar_dec_option=(vd_record,vd_object,vd_threadvar,vd_class,vd_final);
       tvar_dec_options=set of tvar_dec_option;
 
     function  read_property_dec(is_classproperty:boolean;astruct:tabstractrecorddef):tpropertysym;
@@ -925,7 +925,7 @@ implementation
       { only allowed for one var }
       vs:=tabstractvarsym(sc[0]);
       if sc.count>1 then
-        Message(parser_e_absolute_only_one_var);
+        Message1(parser_e_directive_only_one_var,arraytokeninfo[idtoken].str);
       read_public_and_external(vs);
     end;
 
@@ -1127,7 +1127,7 @@ implementation
           C_Name:=get_stringconst;
           vs:=tabstractnormalvarsym(sc[0]);
           if sc.count>1 then
-            Message(parser_e_absolute_only_one_var);
+            Message(parser_e_directive_only_one_var,'ABSOLUTE');
           if vs.typ=staticvarsym then
             begin
               tstaticvarsym(vs).set_mangledname(C_Name);
@@ -1152,7 +1152,7 @@ implementation
           { only allowed for one var }
           vs:=tabstractvarsym(sc[0]);
           if sc.count>1 then
-            Message(parser_e_absolute_only_one_var);
+            Message1(parser_e_directive_only_one_var,'ABSOLUTE');
           if vo_is_typed_const in vs.varoptions then
             Message(parser_e_initialized_not_for_external);
           { parse the rest }
@@ -1525,7 +1525,9 @@ implementation
          while (token=_ID) and
             not(((vd_object in options) or
                  ((vd_record in options) and (m_advanced_records in current_settings.modeswitches))) and
-                (idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED,_STRICT])) do
+                ((idtoken in [_PUBLIC,_PRIVATE,_PUBLISHED,_PROTECTED,_STRICT]) or
+                 ((m_final_fields in current_settings.modeswitches) and
+                  (idtoken=_FINAL)))) do
            begin
              visibility:=symtablestack.top.currentvisibility;
              semicoloneaten:=false;
@@ -1688,12 +1690,23 @@ implementation
                      fieldvs.Rename(internal_static_field_name(fieldvs.name));
                      recst.insert(hstaticvs);
 {$endif not jvm}
+                     if vd_final in options then
+                       hstaticvs.varspez:=vs_final;
                      { generate the symbol for the access }
                      sl:=tpropaccesslist.create;
                      sl.addsym(sl_load,hstaticvs);
                      recst.insert(tabsolutevarsym.create_ref('$'+static_name,hdef,sl));
                    end;
                end;
+             if vd_final in options then
+               begin
+                 { add final flag }
+                 for i:=0 to sc.count-1 do
+                   begin
+                     fieldvs:=tfieldvarsym(sc[i]);
+                     fieldvs.varspez:=vs_final;
+                   end;
+               end;
              if (visibility=vis_published) and
                 not(is_class(hdef)) then
                begin

compiler/scanner.pas

@@ -356,6 +356,11 @@ implementation
         else
          b:=false;
 
+{$ifdef jvm}
+          { enable final fields by default for the JVM targets }
+          include(current_settings.modeswitches,m_final_fields);
+{$endif jvm}
+
         if b and changeInit then
           init_settings.modeswitches := current_settings.modeswitches;
 

compiler/symconst.pas

@@ -517,7 +517,7 @@ type
     vs_referred_not_inited,vs_written,vs_readwritten
   );
 
-  tvarspez = (vs_value,vs_const,vs_var,vs_out,vs_constref);
+  tvarspez = (vs_value,vs_const,vs_var,vs_out,vs_constref,vs_final);
 
   absolutetyp = (tovar,toasm,toaddr);