+ support for initialising typed constants via compiler-generated

    assignment-nodes. For global typed constants and typed constants/
    local variable initialisers in regular functions/procedurs, the
    assignments are performed in the unit initialisation code. For
    those in object/record definitions and their methods, it's done
    in the class constructor. Since we may not yet have parsed all
    method implementations when the class constructor is parsed, part
    of these may be initialised in a helper routine called from the
    class constructor. The ones known when the class constructor is
    parsed are inited there, because the ones marked as "final" and
    declared as static class fields must be initialised in the class
    constructor for Java
   o new set systems_typed_constants_node_init in systems unit that
     indicates that a target uses node trees to initialise typed consts
     instead of an initialised data section
   o mark typed constants in {$j-} mode as "final" for JVM
   o mangle the name of staticvarsyms inside localtables a bit to avoid
     name clashes (only with procedure names for now, no parameters yet
     so can still cause problems with overloaded routines)
   o after a routine has been parsed, it is now processed by
     cnodeutils.wrap_proc_body(), which can add extra nodes before code
     generation (used for injected the typed constant node trees)

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

compiler/agjasmin.pas

@@ -788,14 +788,18 @@ implementation
         vissym:=sym;
         { static field definition -> get original field definition for
           visibility }
-        if (vissym.typ=staticvarsym) and
-           (vissym.owner.symtabletype=objectsymtable) then
+        if (sym.typ=staticvarsym) and
+           (sym.owner.symtabletype=objectsymtable) then
           begin
-            vissym:=tabstractvarsym(search_struct_member(
-              tabstractrecorddef(vissym.owner.defowner),
-              internal_static_field_name(vissym.name)));
+            vissym:=tabstractvarsym(
+              tabstractrecorddef(sym.owner.defowner).symtable.find(
+                internal_static_field_name(sym.name)));
+            if not assigned(vissym) then
+              vissym:=tabstractvarsym(
+                tabstractrecorddef(sym.owner.defowner).symtable.find(
+                  generate_nested_name(sym.owner,'_')+'_'+sym.name));
             if not assigned(vissym) or
-               (vissym.typ<>fieldvarsym) then
+               not(vissym.typ in [fieldvarsym,absolutevarsym]) then
               internalerror(2011011501);
           end;
         case vissym.typ of
@@ -807,7 +811,8 @@ implementation
                 { package visbility }
                 result:='';
             end;
-          fieldvarsym:
+          fieldvarsym,
+          absolutevarsym:
             result:=VisibilityToStr(tstoredsym(vissym).visibility);
           else
             internalerror(2011011204);
@@ -815,6 +820,8 @@ implementation
         if (sym.typ=staticvarsym) or
            (sp_static in sym.symoptions) then
           result:=result+'static ';
+        if sym.varspez=vs_const then
+          result:=result+'final ';
         result:=result+jvmmangledbasename(sym);
       end;
 

compiler/fmodule.pas

@@ -185,6 +185,13 @@ interface
 
         namespace: pshortstring; { for JVM target: corresponds to Java package name }
 
+        { for targets that initialise typed constants via explicit assignments
+          instead of by generating an initialised data section (holds typed
+          constant assignments at the module level; does not have to be saved
+          into the ppu file, because translated into code during compilation)
+           -- actual type: tnode (but fmodule should not depend on node) }
+         tcinitcode     : tobject;
+
         {create creates a new module which name is stored in 's'. LoadedFrom
         points to the module calling it. It is nil for the first compiled
         module. This allow inheritence of all path lists. MUST pay attention
@@ -543,6 +550,7 @@ implementation
         moduleoptions:=[];
         deprecatedmsg:=nil;
         namespace:=nil;
+        tcinitcode:=nil;
         _exports:=TLinkedList.Create;
         dllscannerinputlist:=TFPHashList.Create;
         asmdata:=TAsmData.create(realmodulename^);
@@ -620,6 +628,7 @@ implementation
         stringdispose(asmprefix);
         stringdispose(deprecatedmsg);
         stringdispose(namespace);
+        tcinitcode.free;
         localunitsearchpath.Free;
         localobjectsearchpath.free;
         localincludesearchpath.free;
@@ -751,6 +760,8 @@ implementation
         mode_switch_allowed:=true;
         stringdispose(deprecatedmsg);
         stringdispose(namespace);
+        tcinitcode.free;
+        tcinitcode:=nil;
         moduleoptions:=[];
         is_dbginfo_written:=false;
         crc:=0;

compiler/jvm/njvmutil.pas

@@ -43,7 +43,7 @@ interface
 implementation
 
     uses
-      verbose,constexp,
+      verbose,constexp,fmodule,
       aasmdata,aasmtai,
       symconst,symtype,symdef,symbase,symtable,defutil,jvmdef,
       nbas,ncnv,ncon,ninl,ncal,
@@ -90,7 +90,9 @@ implementation
     begin
       { we need an initialisation in case the al_globals list is not empty
         (that's where the initialisation for global records is added) }
-      result:=not current_asmdata.asmlists[al_globals].empty;
+      result:=
+        inherited or
+        not current_asmdata.asmlists[al_globals].empty;
     end;
 
   class procedure tjvmnodeutils.insertbssdata(sym: tstaticvarsym);
@@ -103,6 +105,7 @@ implementation
         current_asmdata.asmlists[al_globals].concat(cai_align.Create(1));
     end;
 
+
 begin
   cnodeutils:=tjvmnodeutils;
 end.

compiler/jvmdef.pas

@@ -226,37 +226,36 @@ implementation
 
     procedure jvmaddtypeownerprefix(owner: tsymtable; var name: string);
       var
-        owningunit: tsymtable;
+        owningcontainer: tsymtable;
         tmpresult: string;
         module: tmodule;
       begin
         { see tprocdef.jvmmangledbasename for description of the format }
-        case owner.symtabletype of
+        owningcontainer:=owner;
+        while (owningcontainer.symtabletype=localsymtable) do
+          owningcontainer:=owningcontainer.defowner.owner;
+        case owningcontainer.symtabletype of
           globalsymtable,
-          staticsymtable,
-          localsymtable:
+          staticsymtable:
             begin
-              owningunit:=owner;
-              while (owningunit.symtabletype in [localsymtable,objectsymtable,recordsymtable]) do
-                owningunit:=owningunit.defowner.owner;
-              module:=find_module_from_symtable(owningunit);
+              module:=find_module_from_symtable(owningcontainer);
               tmpresult:='';
               if assigned(module.namespace) then
-                tmpresult:=module.namespace^+'.';
+                tmpresult:=module.namespace^+'/';
               tmpresult:=tmpresult+module.realmodulename^+'/';
             end;
           objectsymtable:
-            case tobjectdef(owner.defowner).objecttype of
+            case tobjectdef(owningcontainer.defowner).objecttype of
               odt_javaclass,
               odt_interfacejava:
                 begin
-                  tmpresult:=tobjectdef(owner.defowner).jvm_full_typename(true)+'/'
+                  tmpresult:=tobjectdef(owningcontainer.defowner).jvm_full_typename(true)+'/'
                 end
               else
                 internalerror(2010122606);
             end;
           recordsymtable:
-            tmpresult:=trecorddef(owner.defowner).jvm_full_typename(true)+'/'
+            tmpresult:=trecorddef(owningcontainer.defowner).jvm_full_typename(true)+'/'
           else
             internalerror(2010122605);
         end;
@@ -341,6 +340,7 @@ implementation
 
     function jvmmangledbasename(sym: tsym; const usesymname: string): string;
       var
+        container: tsymtable;
         vsym: tabstractvarsym;
         csym: tconstsym;
         founderror: tdef;
@@ -360,7 +360,22 @@ implementation
                       ([vo_is_funcret,vo_is_result] * tabstractnormalvarsym(vsym).varoptions <> []) then
                 result:='result '+result
               else
-                result:=usesymname+' '+result;
+                begin
+                  { we have to mangle staticvarsyms in localsymtables to
+                    prevent name clashes... }
+                  container:=sym.Owner;
+                  result:=usesymname+' '+result;
+                  while (container.symtabletype=localsymtable) do
+                    begin
+                      if tdef(container.defowner).typ<>procdef then
+                        internalerror(2011040303);
+                      { not safe yet in case of overloaded routines, need to
+                        encode parameters too or find another way for conflict
+                        resolution }
+                      result:=tprocdef(container.defowner).procsym.realname+'$'+result;
+                      container:=container.defowner.owner;
+                    end;
+                end;
             end;
           constsym:
             begin

compiler/ngenutil.pas

@@ -27,7 +27,7 @@ unit ngenutil;
 interface
 
   uses
-    node,symsym;
+    node,symsym,symdef;
 
 
   type
@@ -42,6 +42,12 @@ interface
       { idem for finalization }
       class function force_final: boolean; virtual;
 
+      { called after parsing a routine with the code of the entire routine
+        as argument; can be used to modify the node tree. By default handles
+        insertion of code for systems that perform the typed constant
+        initialisation via the node tree }
+      class function wrap_proc_body(pd: tprocdef; n: tnode): tnode; virtual;
+
       class procedure insertbssdata(sym : tstaticvarsym); virtual;
 
     end;
@@ -55,9 +61,9 @@ implementation
 
     uses
       verbose,globtype,globals,cutils,constexp,
-      scanner,systems,procinfo,
+      scanner,systems,procinfo,fmodule,
       aasmbase,aasmdata,aasmtai,
-      symconst,symtype,symdef,symbase,symtable,defutil,
+      symconst,symtype,symbase,symtable,defutil,
       nadd,nbas,ncal,ncnv,ncon,nflw,nld,nmem,nobj,nutils,
 
       pass_1;
@@ -219,7 +225,9 @@ implementation
 
   class function tnodeutils.force_init: boolean;
     begin
-      result:=false;
+      result:=
+        (target_info.system in systems_typed_constants_node_init) and
+        assigned(current_module.tcinitcode);
     end;
 
 
@@ -229,6 +237,72 @@ implementation
     end;
 
 
+  class function tnodeutils.wrap_proc_body(pd: tprocdef; n: tnode): tnode;
+    var
+      stat: tstatementnode;
+      block: tnode;
+      psym: tsym;
+      tcinitproc: tprocdef;
+    begin
+      result:=n;
+      if target_info.system in systems_typed_constants_node_init then
+        begin
+          case pd.proctypeoption of
+            potype_class_constructor:
+              begin
+                { even though the initialisation code for typed constants may
+                  not yet be complete at this point (there may be more inside
+                  method definitions coming after this class constructor), the
+                  ones from inside the class definition have already been parsed.
+                  in case of {$j-}, these are marked "final" in Java and such
+                  static fields must be initialsed in the class constructor
+                  itself -> add them here }
+                block:=internalstatements(stat);
+                if assigned(tabstractrecorddef(pd.owner.defowner).tcinitcode) then
+                  begin
+                    addstatement(stat,tabstractrecorddef(pd.owner.defowner).tcinitcode);
+                    tabstractrecorddef(pd.owner.defowner).tcinitcode:=nil;
+                  end;
+                psym:=tsym(tabstractrecorddef(pd.owner.defowner).symtable.find('FPC_INIT_TYPED_CONSTS_HELPER'));
+                if not assigned(psym) or
+                   (psym.typ<>procsym) or
+                   (tprocsym(psym).procdeflist.count<>1) then
+                  internalerror(2011040301);
+                tcinitproc:=tprocdef(tprocsym(psym).procdeflist[0]);
+                addstatement(stat,ccallnode.create(nil,tprocsym(psym),
+                  tabstractrecorddef(pd.owner.defowner).symtable,nil,[]));
+                addstatement(stat,result);
+                result:=block
+              end;
+            potype_unitinit:
+              begin
+                if assigned(current_module.tcinitcode) then
+                  begin
+                    block:=internalstatements(stat);
+                    addstatement(stat,tnode(current_module.tcinitcode));
+                    current_module.tcinitcode:=nil;
+                    addstatement(stat,result);
+                    result:=block;
+                  end;
+              end;
+            else case pd.synthetickind of
+              tsk_tcinit:
+                begin
+                  if assigned(tabstractrecorddef(pd.owner.defowner).tcinitcode) then
+                    begin
+                      block:=internalstatements(stat);
+                      addstatement(stat,tabstractrecorddef(pd.owner.defowner).tcinitcode);
+                      tabstractrecorddef(pd.owner.defowner).tcinitcode:=nil;
+                      addstatement(stat,result);
+                      result:=block
+                    end
+                end;
+            end;
+          end;
+        end;
+    end;
+
+
   class procedure tnodeutils.insertbssdata(sym: tstaticvarsym);
     var
       l : asizeint;

compiler/ngtcon.pp

@@ -28,7 +28,7 @@ interface
     uses
       globtype,
       aasmdata,
-      node,
+      node,nbas,
       symtype, symbase, symdef,symsym;
 
 
@@ -99,6 +99,33 @@ interface
         function parse_into_asmlist: tasmlist;
       end;
 
+      tnodetreetypedconstbuilder = class(ttypedconstbuilder)
+       private
+        resultblock: tblocknode;
+        statmnt: tstatementnode;
+
+        { when parsing a record, the base nade becomes a loadnode of the record,
+          etc. }
+        basenode: tnode;
+
+       protected
+        procedure parse_arraydef(def:tarraydef);override;
+        procedure parse_procvardef(def:tprocvardef);override;
+        procedure parse_recorddef(def:trecorddef);override;
+        procedure parse_objectdef(def:tobjectdef);override;
+
+        procedure tc_emit_orddef(def: torddef; var node: tnode);override;
+        procedure tc_emit_floatdef(def: tfloatdef; var node: tnode); override;
+        procedure tc_emit_classrefdef(def: tclassrefdef; var node: tnode);override;
+        procedure tc_emit_pointerdef(def: tpointerdef; var node: tnode);override;
+        procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
+        procedure tc_emit_enumdef(def: tenumdef; var node: tnode);override;
+        procedure tc_emit_stringdef(def: tstringdef; var node: tnode);override;
+       public
+        constructor create(sym: tstaticvarsym; previnit: tnode);
+        destructor destroy;override;
+        function parse_into_nodetree: tnode;
+      end;
 implementation
 
 uses
@@ -1574,5 +1601,421 @@ uses
       end;
 
 
+    { tnodetreetypedconstbuilder }
+
+    procedure tnodetreetypedconstbuilder.parse_arraydef(def: tarraydef);
+      var
+        n : tnode;
+        i : longint;
+        orgbase: tnode;
+      begin
+        { dynamic array nil }
+        if is_dynamic_array(def) then
+          begin
+            { Only allow nil initialization }
+            consume(_NIL);
+            addstatement(statmnt,cassignmentnode.create_internal(basenode,cnilnode.create));
+            basenode:=nil;
+          end
+        { array const between brackets }
+        else if try_to_consume(_LKLAMMER) then
+          begin
+            orgbase:=basenode;
+            for i:=def.lowrange to def.highrange-1 do
+              begin
+                basenode:=cvecnode.create(orgbase.getcopy,genintconstnode(i));
+                read_typed_const_data(def.elementdef);
+                if token=_RKLAMMER then
+                  begin
+                    Message1(parser_e_more_array_elements_expected,tostr(def.highrange-i));
+                    consume(_RKLAMMER);
+                    exit;
+                  end
+                else
+                  consume(_COMMA);
+              end;
+            basenode:=cvecnode.create(orgbase,genintconstnode(def.highrange));
+            read_typed_const_data(def.elementdef);
+            consume(_RKLAMMER);
+          end
+        { if array of char then we allow also a string }
+        else if is_anychar(def.elementdef) then
+          begin
+             n:=comp_expr(true,false);
+             addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
+             basenode:=nil;
+          end
+        else
+          begin
+            { we want the ( }
+            consume(_LKLAMMER);
+          end;
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.parse_procvardef(def: tprocvardef);
+      begin
+        addstatement(statmnt,cassignmentnode.create_internal(basenode,comp_expr(true,false)));
+        basenode:=nil;
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.parse_recorddef(def: trecorddef);
+      var
+        n,n2    : tnode;
+        orgbasenode : tnode;
+        symidx  : longint;
+        recsym,
+        srsym   : tsym;
+        sorg,s  : TIDString;
+        recoffset : aint;
+        error,
+        is_packed: boolean;
+
+      procedure handle_stringconstn;
+        begin
+          addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
+          basenode:=nil;
+          n:=nil;
+        end;
+
+      begin
+        { GUID }
+        if (def=rec_tguid) and (token=_ID) then
+          begin
+            n:=comp_expr(true,false);
+            if n.nodetype=stringconstn then
+              handle_stringconstn
+            else
+              begin
+                inserttypeconv(n,rec_tguid);
+                if n.nodetype=guidconstn then
+                  begin
+                    n2:=cstringconstnode.createstr(guid2string(tguidconstnode(n).value));
+                    n.free;
+                    n:=n2;
+                    handle_stringconstn;
+                  end
+                else
+                  Message(parser_e_illegal_expression);
+              end;
+            n.free;
+            exit;
+          end;
+        if (def=rec_tguid) and ((token=_CSTRING) or (token=_CCHAR)) then
+          begin
+            n:=comp_expr(true,false);
+            inserttypeconv(n,cshortstringtype);
+            if n.nodetype=stringconstn then
+              handle_stringconstn
+            else
+              Message(parser_e_illegal_expression);
+            n.free;
+            exit;
+          end;
+        { bitpacked record? }
+        is_packed:=is_packed_record_or_object(def);
+        { normal record }
+        consume(_LKLAMMER);
+        recoffset:=0;
+        symidx:=0;
+        sorg:='';
+        srsym:=tsym(def.symtable.SymList[symidx]);
+        recsym := nil;
+        orgbasenode:=basenode;
+        basenode:=nil;
+        while token<>_RKLAMMER do
+          begin
+            s:=pattern;
+            sorg:=orgpattern;
+            consume(_ID);
+            consume(_COLON);
+            error := false;
+            recsym := tsym(def.symtable.Find(s));
+            if not assigned(recsym) then
+              begin
+                Message1(sym_e_illegal_field,sorg);
+                error := true;
+              end;
+            if (not error) and
+               (not assigned(srsym) or
+                (s <> srsym.name)) then
+              { possible variant record (JM) }
+              begin
+                { All parts of a variant start at the same offset      }
+                { Also allow jumping from one variant part to another, }
+                { as long as the offsets match                         }
+                if (assigned(srsym) and
+                    (tfieldvarsym(recsym).fieldoffset = tfieldvarsym(srsym).fieldoffset)) or
+                   { srsym is not assigned after parsing w2 in the      }
+                   { typed const in the next example:                   }
+                   {   type tr = record case byte of                    }
+                   {          1: (l1,l2: dword);                        }
+                   {          2: (w1,w2: word);                         }
+                   {        end;                                        }
+                   {   const r: tr = (w1:1;w2:1;l2:5);                  }
+                   (tfieldvarsym(recsym).fieldoffset = recoffset) then
+                  begin
+                    srsym := recsym;
+                    symidx := def.symtable.SymList.indexof(srsym)
+                  end
+                { going backwards isn't allowed in any mode }
+                else if (tfieldvarsym(recsym).fieldoffset<recoffset) then
+                  begin
+                    Message(parser_e_invalid_record_const);
+                    error := true;
+                  end
+                { Delphi allows you to skip fields }
+                else if (m_delphi in current_settings.modeswitches) then
+                  begin
+                    Message1(parser_w_skipped_fields_before,sorg);
+                    srsym := recsym;
+                  end
+                { FPC and TP don't }
+                else
+                  begin
+                    Message1(parser_e_skipped_fields_before,sorg);
+                    error := true;
+                  end;
+              end;
+            if error then
+              consume_all_until(_SEMICOLON)
+            else
+              begin
+                { skipping fill bytes happens automatically, since we only
+                  initialize the defined fields }
+                { new position }
+                recoffset:=tfieldvarsym(srsym).fieldoffset;
+                if not(is_packed) then
+                  inc(recoffset,tfieldvarsym(srsym).vardef.size)
+                 else
+                   inc(recoffset,tfieldvarsym(srsym).vardef.packedbitsize);
+
+                { read the data }
+                if is_packed and
+                   { only orddefs and enumdefs are bitpacked, as in gcc/gpc }
+                   not(tfieldvarsym(srsym).vardef.typ in [orddef,enumdef]) then
+                  recoffset:=align(recoffset,8);
+                basenode:=csubscriptnode.create(srsym,orgbasenode.getcopy);
+                read_typed_const_data(tfieldvarsym(srsym).vardef);
+
+                { keep previous field for checking whether whole }
+                { record was initialized (JM)                    }
+                recsym := srsym;
+                { goto next field }
+                repeat
+                  inc(symidx);
+                  if symidx<def.symtable.SymList.Count then
+                    srsym:=tsym(def.symtable.SymList[symidx])
+                  else
+                    srsym:=nil;
+                until (srsym=nil) or
+                      (srsym.typ=fieldvarsym);
+
+                if token=_SEMICOLON then
+                  consume(_SEMICOLON)
+                else if (token=_COMMA) and (m_mac in current_settings.modeswitches) then
+                  consume(_COMMA)
+                else
+                  break;
+              end;
+          end;
+
+        { are there any fields left, but don't complain if there only
+          come other variant parts after the last initialized field }
+        if assigned(srsym) and
+           (
+            (recsym=nil) or
+            (tfieldvarsym(srsym).fieldoffset > tfieldvarsym(recsym).fieldoffset)
+           ) then
+          Message1(parser_w_skipped_fields_after,sorg);
+        orgbasenode.free;
+        basenode:=nil;
+
+        consume(_RKLAMMER);
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.parse_objectdef(def: tobjectdef);
+      var
+        n,
+        orgbasenode : tnode;
+        obj    : tobjectdef;
+        srsym  : tsym;
+        st     : tsymtable;
+        objoffset : aint;
+        s,sorg : TIDString;
+      begin
+        { no support for packed object }
+        if is_packed_record_or_object(def) then
+          begin
+            Message(type_e_no_const_packed_record);
+            exit;
+          end;
+
+        { only allow nil for implicit pointer object types }
+        if is_implicit_pointer_object_type(def) then
+          begin
+            n:=comp_expr(true,false);
+            if n.nodetype<>niln then
+              begin
+                Message(parser_e_type_const_not_possible);
+                consume_all_until(_SEMICOLON);
+              end
+            else
+              begin
+                addstatement(statmnt,cassignmentnode.create_internal(basenode,n));
+                n:=nil;
+                basenode:=nil;
+              end;
+            n.free;
+            exit;
+          end;
+
+        { for objects we allow it only if it doesn't contain a vmt }
+        if (oo_has_vmt in def.objectoptions) and
+           (m_fpc in current_settings.modeswitches) then
+          begin
+            Message(parser_e_type_object_constants);
+            exit;
+          end;
+
+        consume(_LKLAMMER);
+        objoffset:=0;
+        orgbasenode:=basenode;
+        basenode:=nil;
+        while token<>_RKLAMMER do
+          begin
+            s:=pattern;
+            sorg:=orgpattern;
+            consume(_ID);
+            consume(_COLON);
+            srsym:=nil;
+            obj:=tobjectdef(def);
+            st:=obj.symtable;
+            while (srsym=nil) and assigned(st) do
+              begin
+                srsym:=tsym(st.Find(s));
+                if assigned(obj) then
+                  obj:=obj.childof;
+                if assigned(obj) then
+                  st:=obj.symtable
+                else
+                  st:=nil;
+              end;
+
+            if (srsym=nil) or
+               (srsym.typ<>fieldvarsym) then
+              begin
+                if (srsym=nil) then
+                  Message1(sym_e_id_not_found,sorg)
+                else
+                  Message1(sym_e_illegal_field,sorg);
+                consume_all_until(_RKLAMMER);
+                break;
+              end
+            else
+              with tfieldvarsym(srsym) do
+                begin
+                  { check position }
+                  if fieldoffset<objoffset then
+                    message(parser_e_invalid_record_const);
+
+                  { new position }
+                  objoffset:=fieldoffset+vardef.size;
+
+                  { read the data }
+                  basenode:=csubscriptnode.create(srsym,orgbasenode.getcopy);
+                  read_typed_const_data(vardef);
+
+                  if not try_to_consume(_SEMICOLON) then
+                    break;
+                end;
+          end;
+        consume(_RKLAMMER);
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
+      begin
+        addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
+        basenode:=nil;
+        node:=nil;
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.tc_emit_floatdef(def: tfloatdef; var node: tnode);
+      begin
+        addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
+        basenode:=nil;
+        node:=nil;
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.tc_emit_classrefdef(def: tclassrefdef; var node: tnode);
+      begin
+        addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
+        basenode:=nil;
+        node:=nil;
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.tc_emit_pointerdef(def: tpointerdef; var node: tnode);
+      begin
+        addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
+        basenode:=nil;
+        node:=nil;
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
+      begin
+        addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
+        basenode:=nil;
+        node:=nil;
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.tc_emit_enumdef(def: tenumdef; var node: tnode);
+      begin
+        addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
+        basenode:=nil;
+        node:=nil;
+      end;
+
+
+    procedure tnodetreetypedconstbuilder.tc_emit_stringdef(def: tstringdef; var node: tnode);
+      begin
+        addstatement(statmnt,cassignmentnode.create_internal(basenode,node));
+        basenode:=nil;
+        node:=nil;
+      end;
+
+
+    constructor tnodetreetypedconstbuilder.create(sym: tstaticvarsym; previnit: tnode);
+      begin
+        inherited create(sym);
+        basenode:=cloadnode.create(sym,sym.owner);
+        resultblock:=internalstatements(statmnt);
+        if assigned(previnit) then
+          addstatement(statmnt,previnit);
+      end;
+
+
+    destructor tnodetreetypedconstbuilder.destroy;
+      begin
+        freeandnil(basenode);
+        freeandnil(resultblock);
+        inherited destroy;
+      end;
+
+
+    function tnodetreetypedconstbuilder.parse_into_nodetree: tnode;
+      begin
+        read_typed_const_data(tcsym.vardef);
+        result:=self.resultblock;
+        self.resultblock:=nil;
+      end;
+
 
 end.

compiler/nld.pas

@@ -68,6 +68,8 @@ interface
        tassignmentnode = class(tbinarynode)
           assigntype : tassigntype;
           constructor create(l,r : tnode);virtual;
+          { no checks for validity of assignment }
+          constructor create_internal(l,r : tnode);virtual;
           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           function dogetcopy : tnode;override;
@@ -470,6 +472,13 @@ implementation
       end;
 
 
+    constructor tassignmentnode.create_internal(l, r: tnode);
+      begin
+        create(l,r);
+        include(flags,nf_internal);
+      end;
+
+
     constructor tassignmentnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
       begin
         inherited ppuload(t,ppufile);
@@ -541,7 +550,8 @@ implementation
           CGMessage(type_e_assignment_not_allowed);
 
         { test if node can be assigned, properties are allowed }
-        valid_for_assignment(left,true);
+        if not(nf_internal in flags) then
+          valid_for_assignment(left,true);
 
         { assigning nil to a dynamic array clears the array }
         if is_dynamic_array(left.resultdef) and

compiler/pdecl.pas

@@ -238,9 +238,16 @@ implementation
                      begin
                        { generate the symbol which reserves the space }
                        static_name:=lower(generate_nested_name(symtablestack.top,'_'))+'_'+orgname;
+{$ifndef jvm}
                        sym:=tstaticvarsym.create(internal_static_field_name(static_name),varspez,hdef,[]);
                        include(sym.symoptions,sp_internal);
                        tabstractrecordsymtable(symtablestack.top).get_unit_symtable.insert(sym);
+{$else not jvm}
+                       sym:=tstaticvarsym.create(orgname,varspez,hdef,[]);
+                       include(sym.symoptions,sp_internal);
+                       symtablestack.top.insert(sym);
+                       orgname:=static_name;
+{$endif not jvm}
                        { generate the symbol for the access }
                        sl:=tpropaccesslist.create;
                        sl.addsym(sl_load,sym);

compiler/pdecobj.pas

@@ -1378,13 +1378,18 @@ implementation
             { parse and insert object members }
             parse_object_members;
 
-            { In Java, constructors are not automatically inherited (so you can
-              hide them). Emulate the Pascal behaviour for classes implemented
-              in Pascal (we cannot do it for classes implemented in Java, since
-              we obviously cannot add constructors to those) }
-          if is_javaclass(current_structdef) and
-             not(oo_is_external in current_structdef.objectoptions) then
-            maybe_add_public_default_java_constructor(tobjectdef(current_structdef));
+          if not(oo_is_external in current_structdef.objectoptions) then
+            begin
+              { In Java, constructors are not automatically inherited (so you can
+                hide them). Emulate the Pascal behaviour for classes implemented
+                in Pascal (we cannot do it for classes implemented in Java, since
+                we obviously cannot add constructors to those) }
+              if is_javaclass(current_structdef) then
+                maybe_add_public_default_java_constructor(tobjectdef(current_structdef));
+              { need method to hold the initialization code for typed constants? }
+              if target_info.system in systems_typed_constants_node_init then
+                add_typedconst_init_routine(current_structdef);
+            end;
 
             symtablestack.pop(current_structdef.symtable);
           end;

compiler/psub.pas

@@ -256,6 +256,7 @@ implementation
                    current_filepos:=oldfilepos;
                  end;
             end;
+        block:=cnodeutils.wrap_proc_body(current_procinfo.procdef,block);
       end;
 
 

compiler/ptconst.pas

@@ -35,10 +35,10 @@ implementation
     uses
        globtype,systems,globals,verbose,cutils,tokens,
        aasmbase,aasmtai,
-       procinfo,
+       procinfo,fmodule,
        scanner,pbase,pdecvar,
-       ngtcon,
-       symconst,symbase
+       node,nbas,ngtcon,
+       symconst,symbase,symdef
        ;
 
 
@@ -49,6 +49,8 @@ implementation
         section      : ansistring;
         tcbuilder    : ttypedconstbuilder;
         reslist      : tasmlist;
+        restree,
+        previnit     : tnode;
       begin
         { mark the staticvarsym as typedconst }
         include(sym.varoptions,vo_is_typed_const);
@@ -73,7 +75,19 @@ implementation
             tcbuilder.free;
           end
         else
-          internalerror(2011040203);
+          begin
+            if assigned(current_structdef) then
+              previnit:=current_structdef.tcinitcode
+            else
+              previnit:=tnode(current_module.tcinitcode);
+            tcbuilder:=tnodetreetypedconstbuilder.create(sym,previnit);
+            restree:=tnodetreetypedconstbuilder(tcbuilder).parse_into_nodetree;
+            if assigned(current_structdef) then
+              current_structdef.tcinitcode:=restree
+            else
+              current_module.tcinitcode:=restree;
+            tcbuilder.free;
+          end;
 
         { Parse hints }
         try_consume_hintdirective(sym.symoptions,sym.deprecatedmsg);
@@ -139,7 +153,9 @@ implementation
             list.concat(tai_symbol_end.Createname(sym.mangledname));
           end
         else
-          internalerror(2011040204);
+          begin
+            { nothing to do }
+          end;
 
         current_filepos:=storefilepos;
       end;

compiler/ptype.pas

@@ -54,6 +54,11 @@ interface
 
     procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname : string);
 
+    { add a definition for a method to a record/objectdef that will contain
+      all code for initialising typed constants (only for targets in
+      systems.systems_typed_constants_node_init) }
+    procedure add_typedconst_init_routine(def: tabstractrecorddef);
+
 implementation
 
     uses
@@ -65,7 +70,7 @@ implementation
        { target }
        paramgr,procinfo,
        { symtable }
-       symconst,symsym,symtable,
+       symconst,symsym,symtable,symcreat,
        defutil,defcmp,jvmdef,
        { modules }
        fmodule,
@@ -406,7 +411,6 @@ implementation
           consume(_RSHARPBRACKET);
       end;
 
-
     procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef:boolean); forward;
 
     { def is the outermost type in which other types have to be searched
@@ -947,6 +951,8 @@ implementation
               begin
                 if (target_info.system=system_jvm_java32) then
                   add_java_default_record_methods_intf(trecorddef(current_structdef));
+                if target_info.system in systems_typed_constants_node_init then
+                  add_typedconst_init_routine(current_structdef);
                 consume(_END);
                 break;
               end;
@@ -996,6 +1002,8 @@ implementation
              { we need a constructor to create temps, a deep copy helper, ... }
              if (target_info.system=system_jvm_java32) then
                add_java_default_record_methods_intf(trecorddef(current_structdef));
+             if target_info.system in systems_typed_constants_node_init then
+               add_typedconst_init_routine(current_structdef);
              consume(_END);
             end;
          { make the record size aligned }
@@ -1789,4 +1797,38 @@ implementation
           end;
       end;
 
+
+    procedure add_typedconst_init_routine(def: tabstractrecorddef);
+      var
+        sstate: symcreat.tscannerstate;
+        pd: tprocdef;
+      begin
+        replace_scanner('tcinit_routine',sstate);
+        { the typed constant initialization code is called from the class
+          constructor by tnodeutils.wrap_proc_body; at this point, we don't
+          know yet whether that will be necessary, because there may be
+          typed constants inside method bodies -> always force the addition
+          of a class constructor.
+
+          We cannot directly add the typed constant initialisations to the
+          class constructor, because when it's parsed not all method bodies
+          are necessarily already parsed }
+        pd:=def.find_procdef_bytype(potype_class_constructor);
+        { the class constructor }
+        if not assigned(pd) then
+          begin
+            if str_parse_method_dec('constructor fpc_init_typed_consts_class_constructor;',true,def,pd) then
+              pd.synthetickind:=tsk_empty
+            else
+              internalerror(2011040206);
+          end;
+        { the initialisation helper }
+        if str_parse_method_dec('procedure fpc_init_typed_consts_helper; static;',true,def,pd) then
+          pd.synthetickind:=tsk_tcinit
+        else
+          internalerror(2011040207);
+        restore_scanner(sstate);
+      end;
+
+
 end.

compiler/symcreat.pas

@@ -321,7 +321,9 @@ implementation
               implement_jvm_clone(pd);
             tsk_record_deepcopy:
               implement_record_deepcopy(pd);
-            tsk_empty:
+            tsk_empty,
+            { special handling for this one is done in tnodeutils.wrap_proc_body }
+            tsk_tcinit:
               implement_empty(pd);
             else
               internalerror(2011032801);

compiler/symdef.pas

@@ -184,6 +184,9 @@ interface
           cloneddef      : tabstractrecorddef;
           cloneddefderef : tderef;
           objectoptions  : tobjectoptions;
+          { for targets that initialise typed constants via explicit assignments
+            instead of by generating an initialised data sectino }
+          tcinitcode     : tnode;
           constructor create(const n:string; dt:tdeftyp);
           constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
@@ -492,7 +495,8 @@ interface
          tsk_anon_inherited,        // anonymous inherited call
          tsk_jvm_clone,             // Java-style clone method
          tsk_record_deepcopy,       // deepcopy for records field by field
-         tsk_empty                  // an empty routine
+         tsk_empty,                 // an empty routine
+         tsk_tcinit                 // initialisation of typed constants
        );
 
 {$ifdef oldregvars}
@@ -2891,6 +2895,7 @@ implementation
         stringdispose(objname);
         stringdispose(objrealname);
         stringdispose(import_lib);
+        tcinitcode.free;
         inherited destroy;
       end;
 
@@ -3118,6 +3123,8 @@ implementation
         result:=trecorddef.create(objrealname^,symtable.getcopy);
         trecorddef(result).isunion:=isunion;
         include(trecorddef(result).defoptions,df_copied_def);
+        if assigned(tcinitcode) then
+          trecorddef(result).tcinitcode:=tcinitcode.getcopy;
          if assigned(import_lib) then
            trecorddef(result).import_lib:=stringdup(import_lib^);
       end;
@@ -4761,6 +4768,8 @@ implementation
         tobjectdef(result).objectoptions:=objectoptions;
         include(tobjectdef(result).defoptions,df_copied_def);
         tobjectdef(result).extendeddef:=extendeddef;
+        if assigned(tcinitcode) then
+          tobjectdef(result).tcinitcode:=tcinitcode.getcopy;
         tobjectdef(result).vmt_offset:=vmt_offset;
         if assigned(iidguid) then
           begin