fpc/compiler/agjasmin.pas

{
    Copyright (c) 1998-2010 by the Free Pascal team

    This unit implements the Jasmin assembler writer

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****************************************************************************
}
{ Unit for writing Jasmin assembler (JVM bytecode) output.
}
unit agjasmin;

{$i fpcdefs.inc}

interface

    uses
      cclasses,
      globtype,globals,
      symconst,symbase,symdef,symsym,
      aasmbase,aasmtai,aasmdata,aasmcpu,
      assemble;

    type
      TJasminInstrWriter = class;
      {# This is a derived class which is used to write
         Jasmin-styled assembler.
      }

      { TJasminAssembler }

      TJasminAssembler=class(texternalassembler)
       protected
        jasminjar: tcmdstr;
        asmfiles: TCmdStrList;

        procedure WriteExtraHeader(obj: tabstractrecorddef);
        procedure WriteInstruction(hp: tai);
        procedure NewAsmFileForStructDef(obj: tabstractrecorddef);

        function VisibilityToStr(vis: tvisibility): ansistring;
        function MethodDefinition(pd: tprocdef): ansistring;
        function ConstValue(csym: tconstsym): ansistring;
        function ConstAssignmentValue(csym: tconstsym): ansistring;
        function ConstDefinition(sym: tconstsym): ansistring;
        function FieldDefinition(sym: tabstractvarsym): ansistring;
        function InnerStructDef(obj: tabstractrecorddef): ansistring;

        procedure WriteProcDef(pd: tprocdef);
        procedure WriteFieldSym(sym: tabstractvarsym);
        procedure WriteConstSym(sym: tconstsym);
        procedure WriteSymtableVarSyms(st: TSymtable);
        procedure WriteSymtableProcdefs(st: TSymtable);
        procedure WriteSymtableStructDefs(st: TSymtable);
       public
        constructor Create(smart: boolean); override;
        function MakeCmdLine: TCmdStr;override;
        procedure WriteTree(p:TAsmList);override;
        procedure WriteAsmList;override;
        destructor destroy; override;
       protected
        InstrWriter: TJasminInstrWriter;
      end;


      {# This is the base class for writing instructions.

         The WriteInstruction() method must be overridden
         to write a single instruction to the assembler
         file.
      }

      { TJasminInstrWriter }

      TJasminInstrWriter = class
        constructor create(_owner: TJasminAssembler);
        procedure WriteInstruction(hp : tai); virtual;
       protected
        owner: TJasminAssembler;
      end;


implementation

    uses
      SysUtils,
      cutils,cfileutl,systems,script,
      fmodule,finput,verbose,
      symtype,symtable,jvmdef,
      itcpujas,cpubase,cpuinfo,cgutils,
      widestr
      ;

    const
      line_length = 70;

    type
      t64bitarray = array[0..7] of byte;
      t32bitarray = array[0..3] of byte;

{****************************************************************************}
{                          Support routines                                  }
{****************************************************************************}

   function fixline(s:string):string;
   {
     return s with all leading and ending spaces and tabs removed
   }
     var
       i,j,k : integer;
     begin
       i:=length(s);
       while (i>0) and (s[i] in [#9,' ']) do
        dec(i);
       j:=1;
       while (j<i) and (s[j] in [#9,' ']) do
        inc(j);
       for k:=j to i do
        if s[k] in [#0..#31,#127..#255] then
         s[k]:='.';
       fixline:=Copy(s,j,i-j+1);
     end;


   function constastr(p: pchar; len: longint): ansistring;
     var
       i,runstart,runlen: longint;

       procedure flush;
         begin
           if runlen>0 then
             begin
               setlength(result,length(result)+runlen);
               move(p[runstart],result[length(result)-runlen+1],runlen);
               runlen:=0;
             end;
         end;

     begin
       result:='"';
       runlen:=0;
       runstart:=0;
       for i:=0 to len-1 do
         begin
           { escape control codes }
           case p[i] of
             { LF and CR must be escaped specially, because \uXXXX parsing
               happens in the pre-processor, so it's the same as actually
               inserting a newline in the middle of a string constant }
             #10:
               begin
                 flush;
                 result:=result+'\n';
               end;
             #13:
               begin
                 flush;
                 result:=result+'\r';
               end;
             '"','\':
               begin
                 flush;
                 result:=result+'\'+p[i];
               end
             else if p[i]<#32 then
               begin
                 flush;
                 result:=result+'\u'+hexstr(ord(p[i]),4);
               end
             else if p[i]<#127 then
               begin
                 if runlen=0 then
                   runstart:=i;
                 inc(runlen);
               end
             else
               begin
                 { see comments in njvmcon }
                 flush;
                 result:=result+'\u'+hexstr(ord(p[i]),4)
               end;
           end;
         end;
       flush;
       result:=result+'"';
     end;


   function constwstr(w: pcompilerwidechar; len: longint): ansistring;
     var
       i: longint;
     begin
       result:='"';
       for i:=0 to len-1 do
         begin
           { escape control codes }
           case w[i] of
             10:
               result:=result+'\n';
             13:
               result:=result+'\r';
             ord('"'),ord('\'):
               result:=result+'\'+chr(w[i]);
             else if (w[i]<32) or
                (w[i]>=127) then
               result:=result+'\u'+hexstr(w[i],4)
             else
               result:=result+char(w[i]);
           end;
         end;
       result:=result+'"';
     end;


   function constsingle(s: single): ansistring;
     begin
       result:='0fx'+hexstr(longint(t32bitarray(s)),8);
     end;


   function constdouble(d: double): ansistring;
      begin
        // force interpretation as double (since we write it out as an
        // integer, we never have to swap the endianess). We have to
        // include the sign separately because of the way Java parses
        // hex numbers (0x8000000000000000 is not a valid long)
       result:=hexstr(abs(int64(t64bitarray(d))),16);
       if int64(t64bitarray(d))<0 then
         result:='-'+result;
       result:='0dx'+result;
      end;

{****************************************************************************}
{                       Jasmin Assembler writer                              }
{****************************************************************************}

    destructor TJasminAssembler.Destroy;
      begin
        InstrWriter.free;
        asmfiles.free;
        inherited destroy;
      end;


    procedure TJasminAssembler.WriteTree(p:TAsmList);
      var
        ch       : char;
        hp       : tai;
        hp1      : tailineinfo;
        s        : ansistring;
        i,pos    : longint;
        InlineLevel : longint;
        do_line  : boolean;
      begin
        if not assigned(p) then
         exit;

        InlineLevel:=0;
        { lineinfo is only needed for al_procedures (PFV) }
        do_line:=(cs_asm_source in current_settings.globalswitches);
        hp:=tai(p.first);
        while assigned(hp) do
         begin
           prefetch(pointer(hp.next)^);
           if not(hp.typ in SkipLineInfo) then
            begin
              hp1 := hp as tailineinfo;
              current_filepos:=hp1.fileinfo;
               { no line info for inlined code }
               if do_line and (inlinelevel=0) then
                begin
                  { load infile }
                  if lastfileinfo.fileindex<>hp1.fileinfo.fileindex then
                   begin
                     infile:=current_module.sourcefiles.get_file(hp1.fileinfo.fileindex);
                     if assigned(infile) then
                      begin
                        { open only if needed !! }
                        if (cs_asm_source in current_settings.globalswitches) then
                         infile.open;
                      end;
                     { avoid unnecessary reopens of the same file !! }
                     lastfileinfo.fileindex:=hp1.fileinfo.fileindex;
                     { be sure to change line !! }
                     lastfileinfo.line:=-1;
                   end;

                { write source }
                  if (cs_asm_source in current_settings.globalswitches) and
                     assigned(infile) then
                   begin
                     if (infile<>lastinfile) then
                       begin
                         AsmWriteLn(target_asm.comment+'['+infile.name^+']');
                         if assigned(lastinfile) then
                           lastinfile.close;
                       end;
                     if (hp1.fileinfo.line<>lastfileinfo.line) and
                        ((hp1.fileinfo.line<infile.maxlinebuf) or (InlineLevel>0)) then
                       begin
                         if (hp1.fileinfo.line<>0) and
                            ((infile.linebuf^[hp1.fileinfo.line]>=0) or (InlineLevel>0)) then
                           AsmWriteLn(target_asm.comment+'['+tostr(hp1.fileinfo.line)+'] '+
                             fixline(infile.GetLineStr(hp1.fileinfo.line)));
                         { set it to a negative value !
                         to make that is has been read already !! PM }
                         if (infile.linebuf^[hp1.fileinfo.line]>=0) then
                           infile.linebuf^[hp1.fileinfo.line]:=-infile.linebuf^[hp1.fileinfo.line]-1;
                       end;
                   end;
                  lastfileinfo:=hp1.fileinfo;
                  lastinfile:=infile;
                end;
            end;

           case hp.typ of

             ait_comment :
               Begin
                 AsmWrite(target_asm.comment);
                 AsmWritePChar(tai_comment(hp).str);
                 AsmLn;
               End;

             ait_regalloc :
               begin
                 if (cs_asm_regalloc in current_settings.globalswitches) then
                   begin
                     AsmWrite(#9+target_asm.comment+'Register ');
                     repeat
                       AsmWrite(std_regname(Tai_regalloc(hp).reg));
                       if (hp.next=nil) or
                          (tai(hp.next).typ<>ait_regalloc) or
                          (tai_regalloc(hp.next).ratype<>tai_regalloc(hp).ratype) then
                         break;
                       hp:=tai(hp.next);
                       AsmWrite(',');
                     until false;
                     AsmWrite(' ');
                     AsmWriteLn(regallocstr[tai_regalloc(hp).ratype]);
                   end;
               end;

             ait_tempalloc :
               begin
                 if (cs_asm_tempalloc in current_settings.globalswitches) then
                   begin
  {$ifdef EXTDEBUG}
                     if assigned(tai_tempalloc(hp).problem) then
                       AsmWriteLn(target_asm.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+
                         tostr(tai_tempalloc(hp).tempsize)+' '+tai_tempalloc(hp).problem^)
                     else
  {$endif EXTDEBUG}
                       AsmWriteLn(target_asm.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+
                         tostr(tai_tempalloc(hp).tempsize)+' '+tempallocstr[tai_tempalloc(hp).allocation]);
                   end;
               end;

             ait_align :
               begin

               end;

             ait_section :
               begin

               end;

             ait_datablock :
               begin
                 internalerror(2010122701);
               end;

             ait_const:
               begin
                 AsmWriteln('constant');
//                 internalerror(2010122702);
               end;

             ait_real_64bit :
               begin
                 internalerror(2010122703);
               end;

             ait_real_32bit :
               begin
                 internalerror(2010122703);
               end;

             ait_comp_64bit :
               begin
                 internalerror(2010122704);
               end;

             ait_string :
               begin
                 pos:=0;
                  for i:=1 to tai_string(hp).len do
                   begin
                     if pos=0 then
                      begin
                        AsmWrite(#9'strconst: '#9'"');
                        pos:=20;
                      end;
                     ch:=tai_string(hp).str[i-1];
                     case ch of
                        #0, {This can't be done by range, because a bug in FPC}
                   #1..#31,
                #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7);
                       '"' : s:='\"';
                       '\' : s:='\\';
                     else
                      s:=ch;
                     end;
                     AsmWrite(s);
                     inc(pos,length(s));
                     if (pos>line_length) or (i=tai_string(hp).len) then
                      begin
                        AsmWriteLn('"');
                        pos:=0;
                      end;
                   end;
               end;

             ait_label :
               begin
                 if (tai_label(hp).labsym.is_used) then
                  begin
                    AsmWrite(tai_label(hp).labsym.name);
                    AsmWriteLn(':');
                  end;
               end;

             ait_symbol :
               begin
                  if (tai_symbol(hp).sym.typ = AT_FUNCTION) then
                    begin
                    end
                  else
                   begin
                     AsmWrite('data symbol: ');
                     AsmWriteln(tai_symbol(hp).sym.name);
//                     internalerror(2010122706);
                   end;
               end;
             ait_symbol_end :
               begin
               end;

             ait_instruction :
               begin
                 WriteInstruction(hp);
               end;

             ait_force_line,
             ait_function_name : ;

             ait_cutobject :
               begin
               end;

             ait_marker :
               if tai_marker(hp).kind=mark_NoLineInfoStart then
                 inc(InlineLevel)
               else if tai_marker(hp).kind=mark_NoLineInfoEnd then
                 dec(InlineLevel);

             ait_directive :
               begin
                 AsmWrite('.'+directivestr[tai_directive(hp).directive]+' ');
                 if assigned(tai_directive(hp).name) then
                   AsmWrite(tai_directive(hp).name^);
                 AsmLn;
               end;

             ait_jvar:
               begin
                 AsmWrite('.var ');
                 AsmWrite(tostr(tai_jvar(hp).stackslot));
                 AsmWrite(' is ');
                 AsmWrite(tai_jvar(hp).desc^);
                 AsmWrite(' from ');
                 AsmWrite(tai_jvar(hp).startlab.name);
                 AsmWrite(' to ');
                 AsmWriteLn(tai_jvar(hp).stoplab.name);
               end;

             ait_jcatch:
               begin
                 AsmWrite('.catch ');
                 AsmWrite(tai_jcatch(hp).name^);
                 AsmWrite(' from ');
                 AsmWrite(tai_jcatch(hp).startlab.name);
                 AsmWrite(' to ');
                 AsmWrite(tai_jcatch(hp).stoplab.name);
                 AsmWrite(' using ');
                 AsmWriteLn(tai_jcatch(hp).handlerlab.name);
               end;
             else
               internalerror(2010122707);
           end;
           hp:=tai(hp.next);
         end;
      end;


    procedure TJasminAssembler.WriteExtraHeader(obj: tabstractrecorddef);
      var
        superclass,
        intf: tobjectdef;
        n: ansistring;
        i: longint;
        toplevelowner: tsymtable;
      begin
        { JVM 1.5+ }
        AsmWriteLn('.bytecode 49.0');
        // include files are not support by Java, and the directory of the main
        // source file must not be specified
        if assigned(current_module.mainsource) then
          n:=ExtractFileName(current_module.mainsource^)
        else
          n:=InputFileName;
        AsmWriteLn('.source '+ExtractFileName(n));

        { class/interface name }
        if not assigned(obj) then
          begin
            { fake class type for unit -> name=unitname and
              superclass=java.lang.object, make final so you cannot descend
              from it }
            AsmWrite('.class final public ');
            if assigned(current_module.namespace) then
              AsmWrite(current_module.namespace^+'.');
            AsmWriteln(current_module.realmodulename^);
            AsmWriteLn('.super java/lang/Object');
          end
        else
          begin
            toplevelowner:=obj.owner;
            while not(toplevelowner.symtabletype in [staticsymtable,globalsymtable]) do
              toplevelowner:=toplevelowner.defowner.owner;
            case obj.typ of
              recorddef:
                begin
                  AsmWrite('.class ');
                  if toplevelowner.symtabletype=globalsymtable then
                    AsmWrite('public ');
                  AsmWriteln(obj.jvm_full_typename(true));
                  superclass:=java_fpcbaserecordtype;
                end;
              objectdef:
                begin
                  case tobjectdef(obj).objecttype of
                    odt_javaclass:
                      begin
                        AsmWrite('.class ');
                        if toplevelowner.symtabletype=globalsymtable then
                          AsmWrite('public ');
                        AsmWriteln(obj.jvm_full_typename(true));
                        superclass:=tobjectdef(obj).childof;
                      end;
                    odt_interfacejava:
                      begin
                        AsmWrite('.interface abstract ');
                        if toplevelowner.symtabletype=globalsymtable then
                          AsmWrite('public ');
                        AsmWriteLn(obj.jvm_full_typename(true));
                        { interfaces must always specify Java.lang.object as
                          superclass }
                        superclass:=java_jlobject;
                      end
                    else
                      internalerror(2011010906);
                  end;
                end;
            end;
            { superclass }
            if assigned(superclass) then
              begin
                AsmWrite('.super ');
                if assigned(superclass.import_lib) then
                  AsmWrite(superclass.import_lib^+'/');
                AsmWriteln(superclass.objextname^);
              end;
            { implemented interfaces }
            if (obj.typ=objectdef) and
               assigned(tobjectdef(obj).ImplementedInterfaces) then
              begin
                for i:=0 to tobjectdef(obj).ImplementedInterfaces.count-1 do
                  begin
                    intf:=TImplementedInterface(tobjectdef(obj).ImplementedInterfaces[i]).IntfDef;
                    AsmWrite('.implements ');
                    if assigned(intf.import_lib) then
                      AsmWrite(intf.import_lib^+'/');
                    AsmWriteln(intf.objextname^);
                  end;
              end;
            { in case of nested class: relation to parent class }
            if obj.owner.symtabletype in [objectsymtable,recordsymtable] then
              AsmWriteln(InnerStructDef(obj));
            { all all nested classes }
            for i:=0 to obj.symtable.deflist.count-1 do
              if is_java_class_or_interface(tdef(obj.symtable.deflist[i])) or
                 (tdef(obj.symtable.deflist[i]).typ=recorddef) then
                AsmWriteln(InnerStructDef(tabstractrecorddef(obj.symtable.deflist[i])));
          end;
        AsmLn;
      end;


    procedure TJasminAssembler.WriteInstruction(hp: tai);
      begin
        InstrWriter.WriteInstruction(hp);
      end;


   function TJasminAssembler.MakeCmdLine: TCmdStr;
     const
       jasminjarname = 'jasmin.jar';
     var
       filenames: tcmdstr;
       jasminjarfound: boolean;
     begin
       if jasminjar='' then
         begin
           jasminjarfound:=false;
           if utilsdirectory<>'' then
             jasminjarfound:=FindFile(jasminjarname,utilsdirectory,false,jasminjar);
           if not jasminjarfound then
             jasminjarfound:=FindFileInExeLocations(jasminjarname,false,jasminjar);
           if (not jasminjarfound) and not(cs_asm_extern in current_settings.globalswitches) then
             begin
               Message1(exec_e_assembler_not_found,jasminjarname);
               current_settings.globalswitches:=current_settings.globalswitches+[cs_asm_extern];
             end;
           if jasminjarfound then
             Message1(exec_t_using_assembler,jasminjar);
         end;
       result:=target_asm.asmcmd;
       filenames:=maybequoted(ScriptFixFileName(AsmFileName));
       while not asmfiles.empty do
         filenames:=filenames+' '+asmfiles.GetFirst;
       Replace(result,'$ASM',filenames);
       if (path<>'') then
         Replace(result,'$OBJDIR',maybequoted(ScriptFixFileName(path)))
       else
         Replace(result,'$OBJDIR','.');
       Replace(result,'$JASMINJAR',maybequoted(ScriptFixFileName(jasminjar)));
     end;


   procedure TJasminAssembler.NewAsmFileForStructDef(obj: tabstractrecorddef);
      begin
        if AsmSize<>AsmStartSize then
          begin
            AsmClose;
            asmfiles.Concat(maybequoted(ScriptFixFileName(AsmFileName)));
          end
        else
          AsmClear;

        AsmFileName:=obj.jvm_full_typename(false);
        AsmFileName:=Path+FixFileName(AsmFileName)+target_info.asmext;
        AsmCreate(cut_normal);
      end;


    function TJasminAssembler.VisibilityToStr(vis: tvisibility): ansistring;
      begin
        case vis of
          vis_hidden,
          vis_strictprivate:
            result:='private ';
          vis_strictprotected:
            result:='protected ';
          vis_protected,
          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 '
          else
            internalerror(2010122609);
        end;
      end;


    function TJasminAssembler.MethodDefinition(pd: tprocdef): ansistring;
      begin
        result:=VisibilityToStr(pd.visibility);
        if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or
           (po_classmethod in pd.procoptions) then
          result:=result+'static ';
        if is_javainterface(tdef(pd.owner.defowner)) then
          result:=result+'abstract ';
        if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or
           (po_finalmethod in pd.procoptions) or
           (not(po_virtualmethod in pd.procoptions) and
            not(pd.proctypeoption in [potype_constructor,potype_class_constructor])) then
          result:=result+'final ';
        result:=result+pd.jvmmangledbasename(false);
      end;


    function TJasminAssembler.ConstValue(csym: tconstsym): ansistring;
      begin
        case csym.consttyp of
          constord:
            { always interpret as signed value, because the JVM does not
              support unsigned 64 bit values }
            result:=tostr(csym.value.valueord.svalue);
          conststring:
            result:=constastr(pchar(csym.value.valueptr),csym.value.len);
          constreal:
            case tfloatdef(csym.constdef).floattype of
              s32real:
                result:=constsingle(pbestreal(csym.value.valueptr)^);
              s64real:
                result:=constdouble(pbestreal(csym.value.valueptr)^);
              else
                internalerror(2011021204);
              end;
          constset:
            result:='TODO: add support for constant sets';
          constpointer:
            { can only be null, but that's the default value and should not
              be written; there's no primitive type that can hold nill }
            internalerror(2011021201);
          constnil:
            internalerror(2011021202);
          constresourcestring:
            result:='TODO: add support for constant resource strings';
          constwstring:
            result:=constwstr(pcompilerwidestring(csym.value.valueptr)^.data,pcompilerwidestring(csym.value.valueptr)^.len);
          constguid:
            result:='TODO: add support for constant guids';
          else
            internalerror(2011021205);
        end;
      end;


    function TJasminAssembler.ConstAssignmentValue(csym: tconstsym): ansistring;
      begin
        { nil is the default value -> don't write explicitly }
        case csym.consttyp of
          constpointer:
            begin
              if csym.value.valueordptr<>0 then
                internalerror(2011021206);
              result:='';
            end;
          constnil:
            result:='';
        else
          result:=' = '+ConstValue(csym)
        end;
      end;


    function TJasminAssembler.ConstDefinition(sym: tconstsym): ansistring;
      begin
        result:=VisibilityToStr(sym.visibility);
        { formal constants are always class-level, not instance-level }
        result:=result+'static final ';
        result:=result+jvmmangledbasename(sym,true);
        result:=result+ConstAssignmentValue(tconstsym(sym));
      end;


    function TJasminAssembler.FieldDefinition(sym: tabstractvarsym): ansistring;
      var
        vissym: tabstractvarsym;
      begin
        vissym:=sym;
        { static field definition -> get original field definition for
          visibility }
        if (sym.typ=staticvarsym) and
           (sym.owner.symtabletype=objectsymtable) then
          begin
            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
               not(vissym.typ in [fieldvarsym,absolutevarsym]) then
              internalerror(2011011501);
          end;
        case vissym.typ of
          staticvarsym:
            begin
              if vissym.owner.symtabletype=globalsymtable then
                result:='public '
              else
                { package visbility }
                result:='';
            end;
          fieldvarsym,
          absolutevarsym:
            result:=VisibilityToStr(tstoredsym(vissym).visibility);
          else
            internalerror(2011011204);
        end;
        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,true);
      end;


    function TJasminAssembler.InnerStructDef(obj: tabstractrecorddef): ansistring;
      var
        extname: pshortstring;
        kindname: ansistring;
      begin
        if not(obj.owner.defowner.typ in [objectdef,recorddef]) then
          internalerror(2011021701);
        case obj.typ of
          recorddef:
            begin
              kindname:='class ';
              extname:=obj.symtable.realname;
            end;
          objectdef:
            begin
              extname:=tobjectdef(obj).objextname;
              case tobjectdef(obj).objecttype of
                odt_javaclass:
                  kindname:='class ';
                odt_interfacejava:
                  kindname:='interface ';
                else
                  internalerror(2011021702);
              end;
            end;
          else
            internalerror(2011032809);
        end;
        result:=
          '.inner '+
          kindname+
          VisibilityToStr(obj.typesym.visibility)+
          { Nested classes in the Pascal sense are equivalent to "static"
            inner classes in Java -- will be changed when support for
            Java-style non-static classes is added }
         ' static '+
         extname^+
         ' inner '+
         obj.jvm_full_typename(true)+
         ' outer '+
         tabstractrecorddef(obj.owner.defowner).jvm_full_typename(true);
      end;


    procedure TJasminAssembler.WriteProcDef(pd: tprocdef);
      begin
        if not assigned(pd.exprasmlist) and
           (not is_javainterface(pd.struct) or
            (pd.proctypeoption in [potype_unitinit,potype_unitfinalize])) then
          exit;
        AsmWrite('.method ');
        AsmWriteln(MethodDefinition(pd));
        if jvmtypeneedssignature(pd) then
          begin
            AsmWrite('.signature "');
            AsmWrite(pd.jvmmangledbasename(true));
            AsmWriteln('"');
          end;
        WriteTree(pd.exprasmlist);
        AsmWriteln('.end method');
        AsmLn;
      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.WriteConstSym(sym: tconstsym);
      begin
        AsmWrite('.field ');
        AsmWriteln(ConstDefinition(sym));
      end;


    procedure TJasminAssembler.WriteSymtableVarSyms(st: TSymtable);
      var
        sym : tsym;
        i,j : 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));
                 if (sym.typ=staticvarsym) and
                    assigned(tstaticvarsym(sym).defaultconstsym) then
                   WriteFieldSym(tabstractvarsym(tstaticvarsym(sym).defaultconstsym));
               end;
             constsym:
               begin
                 { multiple procedures can have constants with the same name }
                 if not assigned(sym.owner.defowner) or
                    (tdef(sym.owner.defowner).typ<>procdef) then
                   WriteConstSym(tconstsym(sym));
               end;
             procsym:
               begin
                 for j:=0 to tprocsym(sym).procdeflist.count-1 do
                   WriteSymtableVarSyms(tprocdef(tprocsym(sym).procdeflist[j]).localst);
               end;
           end;
         end;
      end;


    procedure TJasminAssembler.WriteSymtableProcdefs(st: TSymtable);
      var
        i   : longint;
        def : tdef;
      begin
        if not assigned(st) then
          exit;
        for i:=0 to st.DefList.Count-1 do
          begin
            def:=tdef(st.DefList[i]);
            case def.typ of
              procdef :
                begin
                  { methods are also in the static/globalsymtable of the unit
                    -> make sure they are only written for the objectdefs that
                    own them }
                  if not(st.symtabletype in [staticsymtable,globalsymtable]) or
                     (def.owner=st) then
                    begin
                      WriteProcDef(tprocdef(def));
                      if assigned(tprocdef(def).localst) then
                        WriteSymtableProcdefs(tprocdef(def).localst);
                    end;
                end;
            end;
          end;
      end;

    procedure TJasminAssembler.WriteSymtableStructDefs(st: TSymtable);
      var
        i   : longint;
        def : tdef;
        obj : tabstractrecorddef;
        nestedstructs: tfpobjectlist;
      begin
        if not assigned(st) then
          exit;
        nestedstructs:=tfpobjectlist.create(false);
        for i:=0 to st.DefList.Count-1 do
          begin
            def:=tdef(st.DefList[i]);
            case def.typ of
              objectdef:
                if not(oo_is_external in tobjectdef(def).objectoptions) then
                  nestedstructs.add(def);
              recorddef:
                nestedstructs.add(def);
            end;
          end;
        for i:=0 to nestedstructs.count-1 do
          begin
            obj:=tabstractrecorddef(nestedstructs[i]);
            NewAsmFileForStructDef(obj);
            WriteExtraHeader(obj);
            WriteSymtableVarSyms(obj.symtable);
            AsmLn;
            WriteSymtableProcDefs(obj.symtable);
            WriteSymtableStructDefs(obj.symtable);
          end;
        nestedstructs.free;
      end;

    constructor TJasminAssembler.Create(smart: boolean);
      begin
        inherited create(smart);
        InstrWriter:=TJasminInstrWriter.Create(self);
        asmfiles:=TCmdStrList.Create;
      end;


    procedure TJasminAssembler.WriteAsmList;
    begin
{$ifdef EXTDEBUG}
      if assigned(current_module.mainsource) then
       Comment(V_Debug,'Start writing Jasmin-styled assembler output for '+current_module.mainsource^);
{$endif}

      AsmStartSize:=AsmSize;
      WriteExtraHeader(nil);
(*
      for hal:=low(TasmlistType) to high(TasmlistType) do
        begin
          AsmWriteLn(target_asm.comment+'Begin asmlist '+AsmlistTypeStr[hal]);
          writetree(current_asmdata.asmlists[hal]);
          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);

      WriteSymtableStructDefs(current_module.globalsymtable);
      WriteSymtableStructDefs(current_module.localsymtable);

      AsmLn;
{$ifdef EXTDEBUG}
      if assigned(current_module.mainsource) then
       Comment(V_Debug,'Done writing gas-styled assembler output for '+current_module.mainsource^);
{$endif EXTDEBUG}
    end;

{****************************************************************************}
{                         Jasmin Instruction Writer                          }
{****************************************************************************}

     constructor TJasminInstrWriter.create(_owner: TJasminAssembler);
       begin
         inherited create;
         owner := _owner;
       end;

    function getreferencestring(var ref : treference) : ansistring;
      begin
        if (ref.arrayreftype<>art_none) or
           (ref.index<>NR_NO) then
          internalerror(2010122809);
        if assigned(ref.symbol) then
          begin
            // 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
        else
          begin
            // local symbol -> stack slot, stored in offset
            if ref.base<>NR_STACK_POINTER_REG then
              internalerror(2010122810);
            result:=tostr(ref.offset);
          end;
      end;


    function getopstr(const o:toper) : ansistring;
      var
        d: double;
        s: single;
      begin
        case o.typ of
          top_reg:
            // should have been translated into a memory location by the
            // register allocator)
            if (cs_no_regalloc in current_settings.globalswitches) then
              getopstr:=std_regname(o.reg)
            else
              internalerror(2010122803);
          top_const:
            str(o.val,result);
          top_ref:
            getopstr:=getreferencestring(o.ref^);
          top_single:
            begin
              result:=constsingle(o.sval);
            end;
          top_double:
            begin
              result:=constdouble(o.dval);
            end;
          top_string:
            begin
              result:=constastr(o.pcval,o.pcvallen);
            end;
          top_wstring:
            begin
              result:=constwstr(o.pwstrval^.data,getlengthwidestring(o.pwstrval));
            end
          else
            internalerror(2010122802);
        end;
      end;


    procedure TJasminInstrWriter.WriteInstruction(hp: tai);
      var
        s: ansistring;
        i: byte;
        sep: ansistring;
      begin
        s:=#9+jas_op2str[taicpu(hp).opcode];
        if taicpu(hp).ops<>0 then
          begin
            sep:=#9;
            for i:=0 to taicpu(hp).ops-1 do
              begin
                 s:=s+sep+getopstr(taicpu(hp).oper[i]^);
                 sep:=' ';
              end;
          end;
        owner.AsmWriteLn(s);
      end;

{****************************************************************************}
{                         Jasmin Instruction Writer                          }
{****************************************************************************}

  const
    as_jvm_jasmin_info : tasminfo =
       (
         id     : as_jvm_jasmin;
         idtxt  : 'Jasmin';
         asmbin : 'java';
         asmcmd : '-jar $JASMINJAR $ASM -d $OBJDIR';
         supported_targets : [system_jvm_java32];
         flags : [];
         labelprefix : 'L';
         comment : ' ; ';
       );


begin
  RegisterAssembler(as_jvm_jasmin_info,TJasminAssembler);
end.