+ support for instance and class fields, and unit-level global variables

   o hlcgobj support in tcgsubscriptnode.pass_2 for JVM-required functionality
   o slightly different handling for class fields for the JVM than for other
     platforms: instead of adding a unit-level staticvarsym with a hidden name,
     rename the original (unused) field and add the staticvarsym with the original
     name to the object symtable. This is required because the JVM code generator
     has to know the class the field belongs to, as well as its real name
   o moved tprocdef.makejvmmangledcallname() functionality mostly to
     jvmdef.jvmaddtypeownerprefix() because it's also required for mangling
     field symbol names
  * changed the interface of jvmdef from ansistring to shortstring because
    all of its results are also used in shortstring contexts (and they're
    unlikely to overflow the shortstring limit)
  * "protected", "private" (without strict) and implementation-only symbols
    now get "package" visibility instead of "public" visibility

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

compiler/agjasmin.pas

@@ -30,7 +30,7 @@ interface
     uses
       cclasses,
       globtype,globals,
-      symbase,symdef,
+      symconst,symbase,symdef,symsym,
       aasmbase,aasmtai,aasmdata,aasmcpu,
       assemble;
 
@@ -50,8 +50,14 @@ interface
         procedure WriteExtraHeader(obj: tobjectdef);
         procedure WriteInstruction(hp: tai);
         procedure NewAsmFileForObjectDef(obj: tobjectdef);
+
+        function VisibilityToStr(vis: tvisibility): string;
         function MethodDefinition(pd: tprocdef): string;
+        function FieldDefinition(sym: tabstractvarsym): string;
+
         procedure WriteProcDef(pd: tprocdef);
+        procedure WriteFieldSym(sym: tabstractvarsym);
+        procedure WriteSymtableVarSyms(st: TSymtable);
         procedure WriteSymtableProcdefs(st: TSymtable);
         procedure WriteSymtableObjectDefs(st: TSymtable);
        public
@@ -88,7 +94,7 @@ implementation
       SysUtils,
       cutils,cfileutl,systems,script,
       fmodule,finput,verbose,
-      symconst,symtype,
+      symtype,symtable,jvmdef,
       itcpujas,cpubase,cgutils,
       widestr
       ;
@@ -520,21 +526,30 @@ implementation
       end;
 
 
-    function TJasminAssembler.MethodDefinition(pd: tprocdef): string;
+    function TJasminAssembler.VisibilityToStr(vis: tvisibility): string;
       begin
-        case pd.visibility of
+        case vis of
           vis_hidden,
           vis_strictprivate:
             result:='private ';
           vis_strictprotected:
             result:='protected ';
           vis_protected,
-          vis_private,
+          vis_private:
+            { pick default visibility = "package" visibility; required because
+              other classes in the same unit can also access these symbols }
+            result:='';
           vis_public:
-            result:='public ';
+            result:='public '
           else
             internalerror(2010122609);
         end;
+      end;
+
+
+    function TJasminAssembler.MethodDefinition(pd: tprocdef): string;
+      begin
+        result:=VisibilityToStr(pd.visibility);
         if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or
            (po_staticmethod in pd.procoptions) then
           result:=result+'static ';
@@ -544,9 +559,45 @@ implementation
       end;
 
 
-    procedure TJasminAssembler.WriteProcDef(pd: tprocdef);
+    function TJasminAssembler.FieldDefinition(sym: tabstractvarsym): string;
       var
-        procname: string;
+        vissym: tabstractvarsym;
+      begin
+        vissym:=sym;
+        { static field definition -> get original field definition for
+          visibility }
+        if (vissym.typ=staticvarsym) and
+           (vissym.owner.symtabletype=objectsymtable) then
+          begin
+            vissym:=tabstractvarsym(search_struct_member(
+              tobjectdef(vissym.owner.defowner),
+              jvminternalstaticfieldname(vissym.name)));
+            if not assigned(vissym) or
+               (vissym.typ<>fieldvarsym) then
+              internalerror(2011011501);
+          end;
+        case vissym.typ of
+          staticvarsym:
+            begin
+              if vissym.owner.symtabletype=globalsymtable then
+                result:='public '
+              else
+                { package visbility }
+                result:='';
+            end;
+          fieldvarsym:
+            result:=VisibilityToStr(tfieldvarsym(vissym).visibility);
+          else
+            internalerror(2011011204);
+        end;
+        if (vissym.owner.symtabletype in [staticsymtable,globalsymtable]) or
+           (sp_static in vissym.symoptions) then
+          result:=result+'static ';
+        result:=result+sym.jvmmangledbasename;
+      end;
+
+
+    procedure TJasminAssembler.WriteProcDef(pd: tprocdef);
       begin
         if not assigned(pd.exprasmlist) and
            (not is_javainterface(pd.struct) or
@@ -560,11 +611,41 @@ implementation
       end;
 
 
+    procedure TJasminAssembler.WriteFieldSym(sym: tabstractvarsym);
+      begin
+        { internal static field definition alias -> skip }
+        if sp_static in sym.symoptions then
+          exit;
+        AsmWrite('.field ');
+        AsmWriteln(FieldDefinition(sym));
+      end;
+
+
+    procedure TJasminAssembler.WriteSymtableVarSyms(st: TSymtable);
+      var
+        sym : tsym;
+        i   : longint;
+      begin
+        if not assigned(st) then
+          exit;
+        for i:=0 to st.SymList.Count-1 do
+         begin
+           sym:=tsym(st.SymList[i]);
+           case sym.typ of
+             staticvarsym,
+             fieldvarsym:
+               begin
+                 WriteFieldSym(tabstractvarsym(sym));
+               end;
+           end;
+         end;
+      end;
+
+
     procedure TJasminAssembler.WriteSymtableProcdefs(st: TSymtable);
       var
         i   : longint;
         def : tdef;
-        obj : tobjectdef;
       begin
         if not assigned(st) then
           exit;
@@ -613,6 +694,8 @@ implementation
             obj:=tobjectdef(nestedclasses[i]);
             NewAsmFileForObjectDef(obj);
             WriteExtraHeader(obj);
+            WriteSymtableVarSyms(obj.symtable);
+            AsmLn;
             WriteSymtableProcDefs(obj.symtable);
             WriteSymtableObjectDefs(obj.symtable);
           end;
@@ -647,6 +730,10 @@ implementation
           AsmWriteLn(target_asm.comment+'End asmlist '+AsmlistTypeStr[hal]);
         end;
 *)
+      { print all global variables }
+      WriteSymtableVarSyms(current_module.globalsymtable);
+      WriteSymtableVarSyms(current_module.localsymtable);
+      AsmLn;
       { print all global procedures/functions }
       WriteSymtableProcdefs(current_module.globalsymtable);
       WriteSymtableProcdefs(current_module.localsymtable);
@@ -678,9 +765,11 @@ implementation
           internalerror(2010122809);
         if assigned(ref.symbol) then
           begin
-            // global symbol -> full type/name
-            if (ref.base<>NR_NO) or
-               (ref.offset<>0) then
+            // global symbol or field -> full type and name
+            // ref.base can be <> NR_NO in case an instance field is loaded.
+            // This register is not part of this instruction, it will have
+            // been placed on the stack by the previous one.
+            if (ref.offset<>0) then
               internalerror(2010122811);
             result:=ref.symbol.name;
           end

compiler/jvmdef.pas

@@ -29,18 +29,25 @@ interface
 
     uses
       node,
-      symtype;
+      symbase,symtype;
 
     { Encode a type into the internal format used by the JVM (descriptor).
       Returns false if a type is not representable by the JVM,
       and in that case also the failing definition.  }
-    function jvmtryencodetype(def: tdef; out encodedtype: ansistring; out founderror: tdef): boolean;
+    function jvmtryencodetype(def: tdef; out encodedtype: string; out founderror: tdef): boolean;
 
     { Check whether a type can be used in a JVM methom signature or field
       declaration.  }
     function jvmchecktype(def: tdef; out founderror: tdef): boolean;
 
-    function jvmaddencodedtype(def: tdef; bpacked: boolean; var encodedstr: ansistring; out founderror: tdef): boolean;
+    { incremental version of jvmtryencodetype() }
+    function jvmaddencodedtype(def: tdef; bpacked: boolean; var encodedstr: string; out founderror: tdef): boolean;
+
+    { add type prefix (package name) to a type }
+    procedure jvmaddtypeownerprefix(owner: tsymtable; var name: string);
+
+    { generate internal static field name based on regular field name }
+    function jvminternalstaticfieldname(const fieldname: string): string;
 
 implementation
 
@@ -48,6 +55,7 @@ implementation
     globtype,
     cutils,cclasses,
     verbose,systems,
+    fmodule,
     symtable,symconst,symsym,symdef,
     defutil,paramgr;
 
@@ -55,14 +63,9 @@ implementation
                           Type encoding
 *******************************************************************}
 
-    function jvmaddencodedtype(def: tdef; bpacked: boolean; var encodedstr: ansistring; out founderror: tdef): boolean;
+    function jvmaddencodedtype(def: tdef; bpacked: boolean; var encodedstr: string; out founderror: tdef): boolean;
       var
-        recname: ansistring;
-        recdef: trecorddef;
-        objdef: tobjectdef;
-        len: aint;
         c: char;
-        addrpara: boolean;
       begin
         result:=true;
         case def.typ of
@@ -199,19 +202,59 @@ implementation
       end;
 
 
-    function jvmtryencodetype(def: tdef; out encodedtype: ansistring; out founderror: tdef): boolean;
+    function jvmtryencodetype(def: tdef; out encodedtype: string; out founderror: tdef): boolean;
       begin
+        encodedtype:='';
         result:=jvmaddencodedtype(def,false,encodedtype,founderror);
       end;
 
 
+    procedure jvmaddtypeownerprefix(owner: tsymtable; var name: string);
+      var
+        owningunit: tsymtable;
+        tmpresult: string;
+      begin
+        { see tprocdef.jvmmangledbasename for description of the format }
+        case owner.symtabletype of
+          globalsymtable,
+          staticsymtable,
+          localsymtable:
+            begin
+              owningunit:=owner;
+              while (owningunit.symtabletype in [localsymtable,objectsymtable,recordsymtable]) do
+                owningunit:=owningunit.defowner.owner;
+              tmpresult:=find_module_from_symtable(owningunit).realmodulename^+'/';
+            end;
+          objectsymtable:
+            case tobjectdef(owner.defowner).objecttype of
+              odt_javaclass,
+              odt_interfacejava:
+                begin
+                  tmpresult:=tobjectdef(owner.defowner).jvm_full_typename+'/'
+                end
+              else
+                internalerror(2010122606);
+            end
+          else
+            internalerror(2010122605);
+        end;
+        name:=tmpresult+name;
+      end;
+
+
+    function jvminternalstaticfieldname(const fieldname: string): string;
+      begin
+        result:='$_static_'+fieldname;
+      end;
+
+
 {******************************************************************
                     jvm type validity checking
 *******************************************************************}
 
    function jvmchecktype(def: tdef; out founderror: tdef): boolean;
       var
-        encodedtype: ansistring;
+        encodedtype: string;
       begin
         { don't duplicate the code like in objcdef, since the resulting strings
           are much shorter here so it's not worth it }

compiler/ncgmem.pas

@@ -85,7 +85,7 @@ implementation
       aasmbase,aasmtai,aasmdata,
       procinfo,pass_2,parabase,
       pass_1,nld,ncon,nadd,nutils,
-      cgutils,cgobj,
+      cgutils,cgobj,hlcgobj,
       tgobj,ncgutil,objcgutl
       ;
 
@@ -307,7 +307,7 @@ implementation
                         if getregtype(left.location.register)<>R_ADDRESSREGISTER then
                           begin
                             location.reference.base:=rg.getaddressregister(current_asmdata.CurrAsmList);
-                            cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,
+                            hlcg.a_load_reg_reg(current_asmdata.CurrAsmList,left.resultdef,left.resultdef,
                               left.location.register,location.reference.base);
                           end
                         else
@@ -318,7 +318,7 @@ implementation
                     LOC_REFERENCE:
                       begin
                          location.reference.base:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                         cg.a_load_loc_reg(current_asmdata.CurrAsmList,OS_ADDR,left.location,location.reference.base);
+                         hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,left.resultdef,left.resultdef,left.location,location.reference.base);
                       end;
                     LOC_CONSTANT:
                       begin
@@ -454,6 +454,14 @@ implementation
              { always packrecords C -> natural alignment }
              location.reference.alignment:=vs.vardef.alignment;
            end
+         else if is_java_class_or_interface(left.resultdef) then
+           begin
+             if (location.loc<>LOC_REFERENCE) or
+                (location.reference.index<>NR_NO) or
+                assigned(location.reference.symbol) then
+               internalerror(2011011301);
+             location.reference.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname);
+           end
          else if (location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
            begin
              if not is_packed_record_or_object(left.resultdef) then

compiler/pdecvar.pas

@@ -54,6 +54,9 @@ implementation
        systems,
        { symtable }
        symconst,symbase,symtype,symtable,defutil,defcmp,
+{$ifdef jvm}
+       jvmdef,
+{$endif}
        fmodule,htypechk,
        { pass 1 }
        node,pass_1,aasmdata,
@@ -1665,10 +1668,26 @@ implementation
                      include(fieldvs.symoptions,sp_static);
                      { generate the symbol which reserves the space }
                      static_name:=lower(generate_nested_name(recst,'_'))+'_'+fieldvs.name;
+{$ifndef jvm}
                      hstaticvs:=tstaticvarsym.create('$_static_'+static_name,vs_value,hdef,[]);
                      include(hstaticvs.symoptions,sp_internal);
                      recst.get_unit_symtable.insert(hstaticvs);
                      insertbssdata(hstaticvs);
+{$else not jvm}
+                     { for the JVM, static field accesses are name-based and
+                       hence we have to keep the original name of the field.
+                       Create a staticvarsym instead of a fieldvarsym so we can
+                       nevertheless use a loadn instead of a subscriptn though,
+                       since a subscriptn requires something to subscript and
+                       there is nothing in this case (class+field name will be
+                       encoded in the mangled symbol name) }
+                     hstaticvs:=tstaticvarsym.create(fieldvs.realname,vs_value,hdef,[]);
+                     include(hstaticvs.symoptions,sp_internal);
+                     { rename the original field to prevent a name clash when
+                       inserting the new one }
+                     fieldvs.Rename(jvminternalstaticfieldname(fieldvs.name));
+                     recst.insert(hstaticvs);
+{$endif not jvm}
                      { generate the symbol for the access }
                      sl:=tpropaccesslist.create;
                      sl.addsym(sl_load,hstaticvs);

compiler/symdef.pas

@@ -580,7 +580,6 @@ interface
           function  cplusplusmangledname : string;
           function  objcmangledname : string;
           function  jvmmangledbasename: string;
-          procedure makejvmmangledcallname(var name: string);
           function  is_methodpointer:boolean;override;
           function  is_addressonly:boolean;override;
           procedure make_external;
@@ -3967,7 +3966,16 @@ implementation
         mangledname:=defaultmangledname;
 {$else not jvm}
         mangledname:=jvmmangledbasename;
-        makejvmmangledcallname(mangledname);
+        if (po_has_importdll in procoptions) then
+          begin
+            { import_dll comes from "external 'import_dll_name' name 'external_name'" }
+            if assigned(import_dll) then
+              mangledname:=import_dll^+'/'+mangledname
+            else
+              internalerror(2010122607);
+          end
+        else
+          jvmaddtypeownerprefix(owner,mangledname);
 {$endif not jvm}
        {$ifdef compress}
         _mangledname:=stringdup(minilzw_encode(mangledname));
@@ -4199,57 +4207,12 @@ implementation
       end;
 
 
-    procedure tprocdef.makejvmmangledcallname(var name: string);
-      var
-        owningunit: tsymtable;
-        tmpresult: string;
-      begin
-        { see tprocdef.jvmmangledbasename for description of the format }
-        { invocation: package/class name }
-        case procsym.owner.symtabletype of
-          globalsymtable,
-          staticsymtable,
-          localsymtable:
-            begin
-              if po_has_importdll in procoptions then
-                begin
-                  tmpresult:='';
-                  { import_dll comes from "external 'import_dll_name' name 'external_name'" }
-                  if assigned(import_dll) then
-                    tmpresult:=import_dll^+'/'
-                  else
-                    internalerror(2010122607);
-                end;
-              owningunit:=procsym.owner;
-              while (owningunit.symtabletype in [localsymtable,objectsymtable,recordsymtable]) do
-                owningunit:=owner.defowner.owner;
-              tmpresult:=tmpresult+owningunit.realname^+'/';
-            end;
-          objectsymtable:
-            case tobjectdef(procsym.owner.defowner).objecttype of
-              odt_javaclass,
-              odt_interfacejava:
-                begin
-                  tmpresult:=tobjectdef(procsym.owner.defowner).jvm_full_typename+'/'
-                end
-              else
-                internalerror(2010122606);
-            end
-          else
-            internalerror(2010122605);
-        end;
-        name:=tmpresult+name;
-      end;
-
-
     function tprocdef.jvmmangledbasename: string;
       var
-        owningunit: tsymtable;
-        parasize,
         vs: tparavarsym;
         i: longint;
         founderror: tdef;
-        tmpresult: ansistring;
+        tmpresult: string;
       begin
         { format:
             * method definition (in Jasmin):

compiler/symsym.pas

@@ -145,6 +145,7 @@ interface
           function register_notification(flags:Tnotification_flags;
                                          callback:Tnotification_callback):cardinal;
           procedure unregister_notification(id:cardinal);
+          function  jvmmangledbasename:string;
         private
           _vardef     : tdef;
           vardefderef : tderef;
@@ -156,7 +157,7 @@ interface
 
       tfieldvarsym = class(tabstractvarsym)
           fieldoffset   : asizeint;   { offset in record/object }
-          objcoffsetmangledname: pshortstring; { mangled name of offset, calculated as needed }
+          cachedmangledname: pshortstring; { mangled name for ObjC or Java }
           constructor create(const n : string;vsp:tvarspez;def:tdef;vopts:tvaroptions);
           constructor ppuload(ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
@@ -335,7 +336,7 @@ implementation
        { target }
        systems,
        { symtable }
-       defutil,symtable,
+       defutil,symtable,jvmdef,
        fmodule,
        { tree }
        node,
@@ -1146,6 +1147,17 @@ implementation
         end;
     end;
 
+
+    function tabstractvarsym.jvmmangledbasename: string;
+      var
+        founderror: tdef;
+      begin
+        if not jvmtryencodetype(vardef,result,founderror) then
+          internalerror(2011011203);
+        result:=realname+' '+result;
+      end;
+
+
     procedure tabstractvarsym.setvardef(def:tdef);
       begin
         _vardef := def;
@@ -1207,6 +1219,20 @@ implementation
         srsym : tsym;
         srsymtable : tsymtable;
       begin
+{$ifdef jvm}
+        if is_javaclass(tdef(owner.defowner)) then
+          begin
+            if assigned(cachedmangledname) then
+              result:=cachedmangledname^
+            else
+              begin
+                result:=jvmmangledbasename;
+                jvmaddtypeownerprefix(owner,result);
+                cachedmangledname:=stringdup(result);
+              end;
+          end
+        else
+{$endif jvm}
         if sp_static in symoptions then
           begin
             if searchsym(lower(owner.name^)+'_'+name,srsym,srsymtable) then
@@ -1221,12 +1247,12 @@ implementation
           end
         else if is_objcclass(tdef(owner.defowner)) then
           begin
-            if assigned(objcoffsetmangledname) then
-              result:=objcoffsetmangledname^
+            if assigned(cachedmangledname) then
+              result:=cachedmangledname^
             else
               begin
                 result:=target_info.cprefix+'OBJC_IVAR_$_'+tobjectdef(owner.defowner).objextname^+'.'+RealName;
-                objcoffsetmangledname:=stringdup(result);
+                cachedmangledname:=stringdup(result);
               end;
           end
         else
@@ -1236,7 +1262,7 @@ implementation
 
     destructor tfieldvarsym.destroy;
       begin
-        stringdispose(objcoffsetmangledname);
+        stringdispose(cachedmangledname);
         inherited destroy;
       end;
 
@@ -1349,19 +1375,29 @@ implementation
 
     function tstaticvarsym.mangledname:string;
       var
+{$ifdef jvm}
+        tmpname: string;
+{$else jvm}
         prefix : string[2];
+{$endif jvm}
       begin
         if not assigned(_mangledname) then
           begin
+{$ifdef jvm}
+            tmpname:=jvmmangledbasename;
+            jvmaddtypeownerprefix(owner,tmpname);
+            _mangledname:=stringdup(tmpname);
+{$else jvm}
             if (vo_is_typed_const in varoptions) then
               prefix:='TC'
             else
               prefix:='U';
-      {$ifdef compress}
+{$ifdef compress}
             _mangledname:=stringdup(minilzw_encode(make_mangledname(prefix,owner,name)));
-      {$else}
+{$else compress}
            _mangledname:=stringdup(make_mangledname(prefix,owner,name));
-      {$endif}
+{$endif compress}
+{$endif jvm}
           end;
         result:=_mangledname^;
       end;
@@ -1370,11 +1406,13 @@ implementation
     procedure tstaticvarsym.set_mangledname(const s:string);
       begin
         stringdispose(_mangledname);
-      {$ifdef compress}
+{$if defined(jvm)}
+        internalerror(2011011202);
+{$elseif defined(compress)}
         _mangledname:=stringdup(minilzw_encode(s));
-      {$else}
+{$else}
         _mangledname:=stringdup(s);
-      {$endif}
+{$endif}
         include(varoptions,vo_has_mangledname);
       end;