freepascal.compiler/compiler/ag68kmot.pas

{
    $Id$
    Copyright (c) 1998 by the FPC development team

    This unit implements an asmoutput class for MOTOROLA syntax with
    Motorola 68000 (recognized by the Amiga Assembler and Charlie Gibbs's
    A68k)

    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 ag68kmot;

    interface

    uses aasm,assemble;

    type
      pm68kmotasmlist=^tm68kmotasmlist;
      tm68kmotasmlist = object(tasmlist)
        procedure WriteTree(p:paasmoutput);virtual;
        procedure WriteAsmList;virtual;
      end;

  implementation

    uses
      dos,globals,systems,cobjects,m68k,
      strings,files,verbose
{$ifdef GDB}
      ,gdb
{$endif GDB}
      ;

    const
      line_length = 70;

    function getreferencestring(const ref : treference) : string;
      var
         s : string;
      begin
         s:='';
         if ref.isintvalue then
             s:='#'+tostr(ref.offset)
         else
           with ref do
             begin
                 if (index=R_NO) and (base=R_NO) and (direction=dir_none) then
                   begin
                     if assigned(symbol) then
                       begin
                         s:=s+symbol^;
                         if offset<0 then
                           s:=s+tostr(offset)
                         else
                         if (offset>0) then
                           s:=s+'+'+tostr(offset);
                       end
                     else
                       begin
                       { direct memory addressing }
                         s:=s+'('+tostr(offset)+').l';
                       end;
                   end
                 else
                   begin
                     if assigned(symbol) then
                       s:=s+symbol^;
                     if offset<0 then
                       s:=s+tostr(offset)
                     else
                     if (offset>0) then
                       begin
                         if (symbol=nil) then s:=tostr(offset)
                         else s:=s+'+'+tostr(offset);
                       end;
                     if (index<>R_NO) and (base=R_NO) and (direction=dir_none) then
                       begin
                         if (scalefactor = 1) or (scalefactor = 0) then
                           begin
                             if offset = 0 then
                               s:=s+'0(,'+mot_reg2str[index]+'.l)'
                             else
                               s:=s+'(,'+mot_reg2str[index]+'.l)';
                           end
                         else
                           begin
                             if offset = 0 then
                               s:=s+'0(,'+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')'
                             else
                               s:=s+'(,'+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')';
                           end
                       end
                     else
                     if (index=R_NO) and (base<>R_NO) and (direction=dir_inc) then
                       begin
                         if (scalefactor = 1) or (scalefactor = 0) then
                           s:=s+'('+mot_reg2str[base]+')+'
                         else
                           InternalError(10002);
                       end
                     else
                     if (index=R_NO) and (base<>R_NO) and (direction=dir_dec) then
                       begin
                         if (scalefactor = 1) or (scalefactor = 0) then
                           s:=s+'-('+mot_reg2str[base]+')'
                         else
                           InternalError(10003);
                       end
                     else
                     if (index=R_NO) and (base<>R_NO) and (direction=dir_none) then
                       begin
                         s:=s+'('+mot_reg2str[base]+')';
                       end
                     else
                     if (index<>R_NO) and (base<>R_NO) and (direction=dir_none) then
                       begin
                         if (scalefactor = 1) or (scalefactor = 0) then
                           begin
                             if offset = 0 then
                               s:=s+'0('+mot_reg2str[base]+','+mot_reg2str[index]+'.l)'
                             else
                               s:=s+'('+mot_reg2str[base]+','+mot_reg2str[index]+'.l)';
                           end
                         else
                          begin
                            if offset = 0 then
                              s:=s+'0('+mot_reg2str[base]+','+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')'
                            else
                              s:=s+'('+mot_reg2str[base]+','+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')';
                          end
                       end
      { if this is not a symbol, and is not in the above, then there is an error }
                     else
                     if NOT assigned(symbol) then
                       InternalError(10004);
                   end; { endif }
            end; { end with }
         getreferencestring:=s;
      end;


    function getopstr(t : byte;o : pointer) : string;
     var
      hs : string;
      i: tregister;
    begin
      case t of
       top_reg : getopstr:=mot_reg2str[tregister(o)];
         top_reglist: begin
                      hs:='';
                      for i:=R_NO to R_FPSR do
                      begin
                        if i in tregisterlist(o^) then
                         hs:=hs+mot_reg2str[i]+'/';
                      end;
                      delete(hs,length(hs),1);
                      getopstr := hs;
                    end;
       top_ref : getopstr:=getreferencestring(preference(o)^);
       top_const : getopstr:='#'+tostr(longint(o));
       top_symbol : begin
             { compare with i386 version, where this is a constant. }
             hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
                     move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
{                     inc(byte(hs[0]));}
{                     hs[1]:='#';}
                     if pcsymbol(o)^.offset>0 then
                       hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
                     else if pcsymbol(o)^.offset<0 then
                       hs:=hs+tostr(pcsymbol(o)^.offset);
                     getopstr:=hs;
                   end;
         else internalerror(10001);
       end;
     end;


   function getopstr_jmp(t : byte;o : pointer) : string;
     var
       hs : string;
     begin
       case t of
         top_reg : getopstr_jmp:=mot_reg2str[tregister(o)];
         top_ref : getopstr_jmp:=getreferencestring(preference(o)^);
         top_const : getopstr_jmp:=tostr(longint(o));
         top_symbol : begin
                     hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
                     move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
                     if pcsymbol(o)^.offset>0 then
                       hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
                     else if pcsymbol(o)^.offset<0 then
                       hs:=hs+tostr(pcsymbol(o)^.offset);
                     getopstr_jmp:=hs;
                   end;
         else internalerror(10001);
       end;
     end;

{****************************************************************************
                              TM68KMOTASMLIST
 ****************************************************************************}

    procedure tm68kmotasmlist.WriteTree(p:paasmoutput);
    var
      hp        : pai;
      s         : string;
      counter,
      i,j,lines : longint;
      quoted    : boolean;
    begin
      hp:=pai(p^.first);
      while assigned(hp) do
       begin
         case hp^.typ of
       ait_comment : ;
         ait_align : AsmWriteLn(#9'CNOP 0,'+tostr(pai_align(hp)^.aligntype));
      ait_external : AsmWriteLn(#9'XREF'#9+StrPas(pai_external(hp)^.name));
 ait_real_extended : Message(assem_e_extended_not_supported);
          ait_comp : Message(assem_e_comp_not_supported);
     ait_datablock : begin
                       { ------------------------------------------------------- }
                       { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- }
                       { ------------- REQUIREMENT FOR 680x0 ------------------- }
                       { ------------------------------------------------------- }
                       if pai_datablock(hp)^.size <> 1 then
                        begin
                          if not(cs_littlesize in aktswitches) then
                           AsmWriteLn(#9'CNOP 0,4')
                          else
                           AsmWriteLn(#9'CNOP 0,2');
                         end;
                       if pai_datablock(hp)^.is_global then
                        AsmWriteLn(#9'XDEF'#9+StrPas(pai_datablock(hp)^.name));
                       AsmWriteLn(StrPas(pai_datablock(hp)^.name)+#9#9'DS.B '+tostr(pai_datablock(hp)^.size));
                     end;
   ait_const_32bit : Begin
                        if not(cs_littlesize in aktswitches) then
                           AsmWriteLn(#9'CNOP 0,4')
                        else
                           AsmWriteLn(#9'CNOP 0,2');
                       AsmWriteLn(#9#9'DC.L'#9+tostr(pai_const(hp)^.value));
                     end;
   ait_const_16bit : Begin
                        if not(cs_littlesize in aktswitches) then
                           AsmWriteLn(#9'CNOP 0,4')
                        else
                           AsmWriteLn(#9'CNOP 0,2');
                       AsmWriteLn(#9#9'DC.W'#9+tostr(pai_const(hp)^.value));
                     end;
    ait_const_8bit : AsmWriteLn(#9#9'DC.B'#9+tostr(pai_const(hp)^.value));
  ait_const_symbol : Begin
                        if not(cs_littlesize in aktswitches) then
                           AsmWriteLn(#9'CNOP 0,4')
                        else
                           AsmWriteLn(#9'CNOP 0,2');
                       AsmWriteLn(#9#9+'DC.L '#9+StrPas(pchar(pai_const(hp)^.value)));
                     end;
    ait_real_64bit : Begin
                        if not(cs_littlesize in aktswitches) then
                           AsmWriteLn(#9'CNOP 0,4')
                        else
                           AsmWriteLn(#9'CNOP 0,2');
                       AsmWriteLn(#9#9'DC.D'#9+double2str(pai_double(hp)^.value));
                     end;
    ait_real_32bit : Begin
                        if not(cs_littlesize in aktswitches) then
                           AsmWriteLn(#9'CNOP 0,4')
                        else
                           AsmWriteLn(#9'CNOP 0,2');
                       AsmWriteLn(#9#9'DC.S'#9+double2str(pai_single(hp)^.value));
                     end;
{ TO SUPPORT SOONER OR LATER!!!
    ait_comp       : AsmWriteLn(#9#9'DC.D'#9+comp2str(pai_extended(hp)^.value));}
        ait_string : begin
                       counter := 0;
                       lines := pai_string(hp)^.len div line_length;
                       { separate lines in different parts }
                       if pai_string(hp)^.len > 0 then
                       Begin
                         for j := 0 to lines-1 do
                           begin
                              AsmWrite(#9#9'DC.B'#9);
                              quoted:=false;
                              for i:=counter to counter+line_length do
                                 begin
                                   { it is an ascii character. }
                                   if (ord(pai_string(hp)^.str[i])>31) and
                                      (ord(pai_string(hp)^.str[i])<128) and
                                      (pai_string(hp)^.str[i]<>'"') then
                                   begin
                                     if not(quoted) then
                                     begin
                                       if i>counter then
                                         AsmWrite(',');
                                       AsmWrite('"');
                                     end;
                                     AsmWrite(pai_string(hp)^.str[i]);
                                     quoted:=true;
                                   end { if > 31 and < 128 and ord('"') }
                                   else
                                   begin
                                     if quoted then
                                       AsmWrite('"');
                                     if i>counter then
                                       AsmWrite(',');
                                     quoted:=false;
                                     AsmWrite(tostr(ord(pai_string(hp)^.str[i])));
                                   end;
                                end; { end for i:=0 to... }
                                if quoted then AsmWrite('"');
                                AsmWrite(target_info.newline);
                                counter := counter+line_length;
                               end; { end for j:=0 ... }
                               { do last line of lines }
                               AsmWrite(#9#9'DC.B'#9);
                               quoted:=false;
                               for i:=counter to pai_string(hp)^.len-1 do
                               begin
                                 { it is an ascii character. }
                                 if (ord(pai_string(hp)^.str[i])>31) and
                                    (ord(pai_string(hp)^.str[i])<128) and
                                    (pai_string(hp)^.str[i]<>'"') then
                                 begin
                                   if not(quoted) then
                                   begin
                                     if i>counter then
                                       AsmWrite(',');
                                     AsmWrite('"');
                                   end;
                                 AsmWrite(pai_string(hp)^.str[i]);
                                   quoted:=true;
                                 end { if > 31 and < 128 and " }
                                 else
                                 begin
                                   if quoted then
                                     AsmWrite('"');
                                     if i>counter then
                                       AsmWrite(',');
                                     quoted:=false;
                                     AsmWrite(tostr(ord(pai_string(hp)^.str[i])));
                                 end;
                               end; { end for i:=0 to... }
                             if quoted then AsmWrite('"');
                          end; { endif }
                        AsmLn;
                      end;
          ait_label : begin
                        AsmWrite(lab2str(pai_label(hp)^.l));
                        if assigned(hp^.next) and not(pai(hp^.next)^.typ in
                           [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
                            ait_real_64bit,ait_string]) then
                         AsmWriteLn(':');
                      end;
         ait_direct : begin
                        AsmWritePChar(pai_direct(hp)^.str);
                        AsmLn;
                      end;
ait_labeled_instruction :
                      Begin
                      { labeled operand }
                        if pai_labeled(hp)^._op1 = R_NO then
                         AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab))
                        else
                      { labeled operand with register }
                         AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+
                                    reg2str(pai_labeled(hp)^._op1)+','+lab2str(pai_labeled(hp)^.lab))
                     end;
        ait_symbol : begin
                       { ------------------------------------------------------- }
                       { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- }
                       { ------------- REQUIREMENT FOR 680x0 ------------------- }
                       { ------------------------------------------------------- }
                       if assigned(hp^.next) and (pai(hp^.next)^.typ in
                          [ait_const_32bit,ait_const_16bit,ait_const_symbol,
                           ait_real_64bit,ait_real_32bit,ait_string]) then
                        begin
                          if not(cs_littlesize in aktswitches) then
                           AsmWriteLn(#9'CNOP 0,4')
                          else
                           AsmWriteLn(#9'CNOP 0,2');
                        end;
                       if pai_symbol(hp)^.is_global then
                        AsmWriteLn(#9'XDEF '+StrPas(pai_symbol(hp)^.name));
                       AsmWritePChar(pai_symbol(hp)^.name);
                       if assigned(hp^.next) and not(pai(hp^.next)^.typ in
                          [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
                           ait_real_64bit,ait_string,ait_real_32bit]) then
                        AsmWriteLn(':');
                     end;
   ait_instruction : begin
                       s:=#9+mot_op2str[pai68k(hp)^._operator]+mot_opsize2str[pai68k(hp)^.size];
                       if pai68k(hp)^.op1t<>top_none then
                        begin
                        { call and jmp need an extra handling                          }
                        { this code is only called if jmp isn't a labeled instruction }
                          if pai68k(hp)^._operator in [A_JSR,A_JMP] then
                           s:=s+#9+getopstr_jmp(pai68k(hp)^.op1t,pai68k(hp)^.op1)
                          else
                           begin
                             if pai68k(hp)^.op1t = top_reglist then
                              s:=s+#9+getopstr(pai68k(hp)^.op1t,@(pai68k(hp)^.reglist))
                             else
                              s:=s+#9+getopstr(pai68k(hp)^.op1t,pai68k(hp)^.op1);
                             if pai68k(hp)^.op2t<>top_none then
                              begin
                                if pai68k(hp)^.op2t = top_reglist then
                                 s:=s+','+getopstr(pai68k(hp)^.op2t,@pai68k(hp)^.reglist)
                                else
                                 s:=s+','+getopstr(pai68k(hp)^.op2t,pai68k(hp)^.op2);
                             { three operands }
                                if pai68k(hp)^.op3t<>top_none then
                                 begin
                                   if (pai68k(hp)^._operator = A_DIVSL) or
                                      (pai68k(hp)^._operator = A_DIVUL) or
                                      (pai68k(hp)^._operator = A_MULU) or
                                      (pai68k(hp)^._operator = A_MULS) or
                                      (pai68k(hp)^._operator = A_DIVS) or
                                      (pai68k(hp)^._operator = A_DIVU) then
                                    s:=s+':'+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3)
                                   else
                                    s:=s+','+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3);
                                 end;
                              end;
                           end;
                        end;
                       AsmWriteLn(s);
                     end;
{$ifdef GDB}
              ait_stabn,
              ait_stabs,
 ait_stab_function_name : ;
{$endif GDB}
         else
          internalerror(10000);
         end;
{         if ((hp^.typ<>ait_label) and (hp^.typ<>ait_symbol)) or (assigned(hp^.next) and not(pai(hp^.next)^.typ in
      [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
       ait_real_64bit,ait_string])) then
         AsmLn}
         hp:=pai(hp^.next);
       end;
    end;

    procedure tm68kmotasmlist.WriteAsmList;
    begin
{$ifdef EXTDEBUG}
      if assigned(current_module^.mainsource) then
       comment(v_info,'Start writing motorola-styled assembler output for '+current_module^.mainsource^);
{$endif}
      WriteTree(externals);

      AsmLn;
      AsmWriteLn(#9'SECTION _CODE,CODE');
      WriteTree(codesegment);

      AsmLn;
      AsmWriteLn(#9'SECTION _DATA,DATA');
    { write a signature to the file }
      AsmWriteLn(#9'CNOP 0,4');
{$ifdef EXTDEBUG}
      AsmWriteLn(#9'DC.B'#9'"compiled by FPC '+version_string+'\0"');
      AsmWriteLn(#9'DC.B'#9'"target: '+target_info.target_name+'\0"');
{$endif EXTDEBUG}
      WriteTree(datasegment);
      WriteTree(consts);

      AsmLn;
      AsmWriteLn(#9'SECTION _BSS,BSS');
      WriteTree(bsssegment);

      AsmLn;
      AsmWriteLn(#9'END');
{$ifdef EXTDEBUG}
      if assigned(current_module^.mainsource) then
       comment(v_info,'Done writing motorola-styled assembler output for '+current_module^.mainsource^);
{$endif}
    end;

end.
{
  $Log$
  Revision 1.1  1998-03-25 11:18:16  root
  Initial revision

  Revision 1.3  1998/03/22 12:45:37  florian
    * changes of Carl-Eric to m68k target commit:
      - wrong nodes because of the new string cg in intel, I had to create
        this under m68k also ... had to work it out to fix potential alignment
        problems --> this removes the crash of the m68k compiler.
      - added absolute addressing in m68k assembler (required for Amiga startup)
      - fixed alignment problems (because of byte return values, alignment
        would not be always valid) -- is this ok if i change the offset if odd in
        setfirsttemp ?? -- it seems ok...

  Revision 1.2  1998/03/10 04:23:33  carl
    - removed in because can cause range check errors under BP

  Revision 1.1  1998/03/10 01:26:10  peter
    + new uniform names

}