{ $Id$ Copyright (c) 1996,97 by Florian Klaempfl This unit implements an asmoutput class for Intel syntax with Intel i386+ 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 ag386int; interface uses aasm,assemble; type pi386intasmlist=^ti386intasmlist; ti386intasmlist = object(tasmlist) procedure WriteTree(p:paasmoutput);virtual; procedure WriteAsmList;virtual; end; implementation uses dos,globals,systems,cobjects,i386, strings,files,verbose {$ifdef GDB} ,gdb {$endif GDB} ; const line_length = 70; extstr : array[EXT_NEAR..EXT_ABS] of String[8] = ('NEAR','FAR','PROC','BYTE','WORD','DWORD', 'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS'); function getreferencestring(const ref : treference) : string; var s : string; first : boolean; begin if ref.isintvalue then s:= tostr(ref.offset) else {$ifdef ver0_6} begin first:=true; { have we a segment prefix ? } if ref.segment<>R_DEFAULT_SEG then begin if current_module^.output_format in [of_nasm,of_obj] then s:='['+_reg2str[ref.segment]+':' else s:=_reg2str[ref.segment]+':['; end else s:='['; if assigned(ref.symbol) then begin s:=s+ref.symbol^; first:=false; end; if (ref.base<>R_NO) then begin if not(first) then s:=s+'+' else first:=false; s:=s+_reg2str[ref.base]; end; if (ref.index<>R_NO) then begin if not(first) then s:=s+'+' else first:=false; s:=s+_reg2str[ref.index]; if ref.scalefactor<>0 then s:=s+'*'+tostr(ref.scalefactor); end; if ref.offset<0 then s:=s+tostr(ref.offset) else if (ref.offset>0) then s:=s+'+'+tostr(ref.offset); s:=s+']'; end; {$else} with ref do begin first:=true; if ref.segment<>R_DEFAULT_SEG then begin if current_module^.output_format in [of_nasm,of_obj] then s:='['+int_reg2str[segment]+':' else s:=int_reg2str[segment]+':['; end else s:='['; if assigned(symbol) then begin s:=s+symbol^; first:=false; end; if (base<>R_NO) then begin if not(first) then s:=s+'+' else first:=false; s:=s+int_reg2str[base]; end; if (index<>R_NO) then begin if not(first) then s:=s+'+' else first:=false; s:=s+int_reg2str[index]; if scalefactor<>0 then s:=s+'*'+tostr(scalefactor); end; if offset<0 then s:=s+tostr(offset) else if (offset>0) then s:=s+'+'+tostr(offset); s:=s+']'; end; {$endif} getreferencestring:=s; end; function getopstr(t : byte;o : pointer;s : topsize; _operator: tasmop;dest : boolean) : string; var hs : string; begin case t of top_reg : { a floating point register can be only a register operand } if current_module^.output_format in [of_nasm,of_obj] then getopstr:=int_nasmreg2str[tregister(o)] else getopstr:=int_reg2str[tregister(o)]; top_const, top_ref : begin if t=top_const then hs := tostr(longint(o)) else hs:=getreferencestring(preference(o)^); if current_module^.output_format in [of_nasm,of_obj] then if (_operator = A_LEA) or (_operator = A_LGS) or (_operator = A_LSS) or (_operator = A_LFS) or (_operator = A_LES) or (_operator = A_LDS) or (_operator = A_SHR) or (_operator = A_SHL) or (_operator = A_SAR) or (_operator = A_SAL) or (_operator = A_OUT) or (_operator = A_IN) then begin end else case s of S_B : hs:='byte '+hs; S_W : hs:='word '+hs; S_L : hs:='dword '+hs; S_S : hs:='dword '+hs; S_Q : hs:='qword '+hs; S_X : if current_module^.output_format in [of_nasm,of_obj] then hs:='tword '+hs else hs:='tbyte '+hs; S_BW : if dest then hs:='word '+hs else hs:='byte '+hs; S_BL : if dest then hs:='dword '+hs else hs:='byte '+hs; S_WL : if dest then hs:='dword '+hs else hs:='word '+hs; end else Begin { can possibly give a range check error under tp } { if using in... } if ((_operator <> A_LGS) and (_operator <> A_LSS) and (_operator <> A_LFS) and (_operator <> A_LDS) and (_operator <> A_LES)) then Begin case s of S_B : hs:='byte ptr '+hs; S_W : hs:='word ptr '+hs; S_L : hs:='dword ptr '+hs; S_BW : if dest then hs:='word ptr '+hs else hs:='byte ptr '+hs; S_BL : if dest then hs:='dword ptr '+hs else hs:='byte ptr '+hs; S_WL : if dest then hs:='dword ptr '+hs else hs:='word ptr '+hs; end; end; end; getopstr:=hs; end; top_symbol : begin hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol))); move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0])); if current_module^.output_format=of_masm then hs:='offset '+hs else hs:='dword '+hs; 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:=int_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; {**************************************************************************** TI386INTASMLIST ****************************************************************************} const ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]= (#9'DD'#9,'',#9'DW'#9,#9'DB'#9); Function PadTabs(p:pchar;addch:char):string; var s : string; i : longint; begin i:=strlen(p); if addch<>#0 then begin inc(i); s:=StrPas(p)+addch; end else s:=StrPas(p); if i<8 then PadTabs:=s+#9#9 else PadTabs:=s+#9; end; procedure ti386intasmlist.WriteTree(p:paasmoutput); type twowords=record word1,word2:word; end; var s, prefix, suffix : string; hp : pai; counter, lines, i,j,l : longint; consttyp : tait; found, quoted : boolean; begin hp:=pai(p^.first); while assigned(hp) do begin case hp^.typ of ait_comment : ; ait_align : begin { align not supported at all with nasm v095 } { align with specific value not supported by } { turbo assembler. } { CAUSES PROBLEMS WITH THE SEGMENT DEFINITION } { SEGMENT DEFINITION SHOULD MATCH TYPE OF ALIGN } { HERE UNDER TASM! } { if current_module^.output_format<>of_nasm then AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype));} end; ait_external : begin if current_module^.output_format in [of_nasm,of_obj] then AsmWriteLn('EXTERN '+StrPas(pai_external(hp)^.name)) else AsmWriteLn(#9#9'EXTRN'#9+StrPas(pai_external(hp)^.name)+ ' :'+extstr[pai_external(hp)^.exttyp]); end; ait_datablock : begin if current_module^.output_format in [of_nasm,of_obj] then begin if pai_symbol(hp)^.is_global then AsmWriteLn('GLOBAL '+StrPas(pai_datablock(hp)^.name)); AsmWriteLn(PadTabs(pai_datablock(hp)^.name,':')+'RESB'#9+tostr(pai_datablock(hp)^.size)); end else begin if pai_symbol(hp)^.is_global then AsmWriteLn(#9#9'PUBLIC'#9+StrPas(pai_datablock(hp)^.name)); AsmWriteLn(PadTabs(pai_datablock(hp)^.name,#0)+'DB'#9+tostr(pai_datablock(hp)^.size)+' DUP(?)'); end; end; ait_const_32bit, ait_const_8bit, ait_const_16bit : begin AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value)); consttyp:=hp^.typ; l:=0; repeat found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp); if found then begin hp:=Pai(hp^.next); s:=','+tostr(pai_const(hp)^.value); AsmWrite(s); inc(l,length(s)); end; until (not found) or (l>line_length); AsmLn; end; ait_const_symbol : begin if current_module^.output_format<>of_nasm then AsmWrite(#9#9+'DD '#9'offset ') else AsmWrite(#9#9+'DD '#9); AsmWriteLn(StrPas(pchar(pai_const(hp)^.value))); end; ait_real_32bit : AsmWriteLn(#9#9'DD'#9+double2str(pai_single(hp)^.value)); ait_real_64bit : AsmWriteLn(#9#9'DQ'#9+double2str(pai_double(hp)^.value)); ait_real_extended : begin { nasm v095 does not like DT with real constants } { therefore write as double. } { other possible solution: decode directly to hex} { value. } if current_module^.output_format<>of_nasm then AsmWriteLn(#9#9'DT'#9+double2str(pai_extended(hp)^.value)) else begin {$ifdef EXTDEBUG} AsmLn; AsmWriteLn('; NASM bug work around for extended real'); {$endif} AsmWriteLn(#9#9'DD'#9+double2str(pai_extended(hp)^.value)) end; end; ait_comp : AsmWriteLn(#9#9'DQ'#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'DB'#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'DB'#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; AsmLn; end; ait_label : begin AsmWrite(lab2str(pai_label(hp)^.l)); if (current_module^.output_format in [of_obj,of_nasm]) 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_32bit,ait_real_64bit,ait_real_extended,ait_string])) then AsmWriteLn(':'); end; ait_direct : begin AsmWritePChar(pai_direct(hp)^.str); AsmLn; end; ait_labeled_instruction : begin if (current_module^.output_format in [of_nasm,of_obj]) and not (pai_labeled(hp)^._operator in [A_JMP,A_LOOP,A_LOOPZ,A_LOOPE, A_LOOPNZ,A_LOOPNE,A_JCXZ,A_JECXZ]) then AsmWriteLn(#9#9+int_op2str[pai_labeled(hp)^._operator]+#9+'near '+lab2str(pai_labeled(hp)^.lab)) else AsmWriteLn(#9#9+int_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab)); end; ait_symbol : begin if pai_symbol(hp)^.is_global then begin if current_module^.output_format in [of_nasm,of_obj] then AsmWriteLn('GLOBAL '+StrPas(pai_symbol(hp)^.name)) else AsmWriteLn(#9#9'PUBLIC'#9+StrPas(pai_symbol(hp)^.name)); end; 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]) then AsmWriteLn(':') end; ait_instruction : begin suffix:=''; { added prefix instructions } { must be on same line as opcode } if (pai386(hp)^.op1t = top_none) and ((pai386(hp)^._operator = A_REP) or (pai386(hp)^._operator = A_LOCK) or (pai386(hp)^._operator = A_REPE) or (pai386(hp)^._operator = A_REPNE)) then Begin prefix:=int_op2str[pai386(hp)^._operator]+' '; hp:=Pai(hp^.next); { this is theorically impossible... } if hp=nil then begin s:=#9#9+prefix; AsmWriteLn(s); break; end; end else prefix:= ''; if pai386(hp)^.op1t<>top_none then begin if pai386(hp)^._operator in [A_CALL] then begin if output_format=of_nasm then s:=getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1) else s:='near ptr '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1); end else begin s:=getopstr(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.size,pai386(hp)^._operator,false); if pai386(hp)^.op3t<>top_none then begin if pai386(hp)^.op2t<>top_none then s:=getopstr(pai386(hp)^.op2t,pointer(longint(twowords(pai386(hp)^.op2).word1)), pai386(hp)^.size,pai386(hp)^._operator,true)+','+s; s:=getopstr(pai386(hp)^.op3t,pointer(longint(twowords(pai386(hp)^.op2).word2)), pai386(hp)^.size,pai386(hp)^._operator,false)+','+s; end else if pai386(hp)^.op2t<>top_none then s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,pai386(hp)^.size, pai386(hp)^._operator,true)+','+s; end; s:=#9+s; end else begin { check if string instruction } { long form, otherwise may give range check errors } { in turbo pascal... } if ((pai386(hp)^._operator = A_CMPS) or (pai386(hp)^._operator = A_INS) or (pai386(hp)^._operator = A_OUTS) or (pai386(hp)^._operator = A_SCAS) or (pai386(hp)^._operator = A_STOS) or (pai386(hp)^._operator = A_MOVS) or (pai386(hp)^._operator = A_LODS) or (pai386(hp)^._operator = A_XLAT)) then Begin case pai386(hp)^.size of S_B: suffix:='b'; S_W: suffix:='w'; S_L: suffix:='d'; else Message(assem_f_invalid_suffix_intel); end; end; s:=''; end; AsmWriteLn(#9#9+int_op2str[pai386(hp)^._operator]+s); end; {$ifdef GDB} ait_stabn, ait_stabs, ait_stab_function_name : ; {$endif GDB} else internalerror(10000); end; { we only write a line if not a variable otherwise might } { cause some problems. } { 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_real_extended,ait_string,ait_comp])) then AsmWrite(target_info.newline);} hp:=pai(hp^.next); end; end; procedure ti386intasmlist.WriteAsmList; begin {$ifdef EXTDEBUG} if assigned(current_module^.mainsource) then comment(v_info,'Start writing intel-styled assembler output for '+current_module^.mainsource^); {$endif} if current_module^.output_format in [of_nasm,of_obj] then begin WriteTree(externals); { INTEL ASM doesn't support stabs WriteTree(debuglist);} AsmWriteLn('BITS 32'); AsmWriteLn('SECTION .text'); { AsmWriteLn(#9#9'ASSUME'#9'CS:_TEXT,ES:DGROUP,DS:DGROUP,SS:DGROUP'); } WriteTree(codesegment); AsmLn; AsmWriteLn('SECTION .data'); {$ifdef EXTDEBUG} AsmWriteLn(#9#9'DB'#9'"compiled by FPC '+version_string+'\0"'); AsmWriteLn(#9#9'DB'#9'"target: '+target_info.target_name+'\0"'); {$endif EXTDEBUG} WriteTree(datasegment); WriteTree(consts); AsmLn; AsmWriteLn('SECTION .bss'); WriteTree(bsssegment); end else begin AsmWriteLn('.386p'); WriteTree(externals); { INTEL ASM doesn't support stabs WriteTree(debuglist);} AsmWriteLn('DGROUP'#9#9'GROUP'#9'_BSS,_DATA'); AsmWriteLn('_TEXT'#9#9'SEGMENT'#9'BYTE PUBLIC USE32 ''CODE'''); AsmWriteLn(#9#9'ASSUME'#9'CS:_TEXT,ES:DGROUP,DS:DGROUP,SS:DGROUP'); AsmLn; WriteTree(codesegment); AsmWriteLn('_TEXT'#9#9'ENDS'); AsmLn; AsmWriteLn('_DATA'#9#9'SEGMENT'#9'DWORD PUBLIC USE32 ''DATA'''); {$ifdef EXTDEBUG} AsmWriteLn(#9#9'DB'#9'"compiled by FPC '+version_string+'\0"'); AsmWriteLn(#9#9'DB'#9'"target: '+target_info.target_name+'\0"'); {$endif EXTDEBUG} WriteTree(datasegment); WriteTree(consts); AsmWriteLn('_DATA'#9#9'ENDS'); AsmLn; AsmWriteLn('_BSS'#9#9'SEGMENT'#9'DWORD PUBLIC USE32 ''BSS'''); WriteTree(bsssegment); AsmWriteLn('_BSS'#9#9'ENDS'); AsmLn; AsmWriteLn(#9#9'END'); end; {$ifdef EXTDEBUG} if assigned(current_module^.mainsource) then comment(v_info,'Done writing intel-styled assembler output for '+current_module^.mainsource^); {$endif EXTDEBUG} end; end. { $Log$ Revision 1.1 1998-03-25 11:18:16 root Initial revision Revision 1.1 1998/03/10 01:26:09 peter + new uniform names Revision 1.18 1998/03/09 12:58:11 peter * FWait warning is only showed for Go32V2 and $E+ * opcode tables moved to i386.pas/m68k.pas to reduce circular uses (and for m68k the same tables are removed) + $E for i386 Revision 1.17 1998/03/06 00:52:23 peter * replaced all old messages from errore.msg, only ExtDebug and some Comment() calls are left * fixed options.pas Revision 1.16 1998/03/02 01:48:41 peter * renamed target_DOS to target_GO32V1 + new verbose system, merged old errors and verbose units into one new verbose.pas, so errors.pas is obsolete Revision 1.15 1998/02/23 02:57:41 carl * small bugfix when compiling $extdebug Revision 1.14 1998/02/15 21:16:20 peter * all assembler outputs supported by assemblerobject * cleanup with assembleroutputs, better .ascii generation * help_constructor/destructor are now added to the externals - generation of asmresponse is not outputformat depended Revision 1.13 1998/02/13 10:35:07 daniel * Made Motorola version compilable. * Fixed optimizer Revision 1.12 1998/02/12 17:19:07 florian * fixed to get remake3 work, but needs additional fixes (output, I don't like also that aktswitches isn't a pointer) Revision 1.11 1998/02/12 11:50:11 daniel Yes! Finally! After three retries, my patch! Changes: Complete rewrite of psub.pas. Added support for DLL's. Compiler requires less memory. Platform units for each platform. Revision 1.10 1997/12/13 18:59:48 florian + I/O streams are now also declared as external, if neccessary * -Aobj generates now a correct obj file via nasm Revision 1.9 1997/12/12 13:28:26 florian + version 0.99.0 * all WASM options changed into MASM + -O2 for Pentium II optimizations Revision 1.8 1997/12/09 13:45:10 carl * bugfix of DT under nasm (not allowed if non integral - nasm v095) + added pai_align --> useless here see file for more info * bugfix of problems with in,out instructions under nasm * bugfix of call under nasm (not fully tested though -- not sure) * some range check errors removed (probably a few left though) * bugfix of checking for extended type when emitting ':' Revision 1.7 1997/12/04 15:20:47 carl * esthetic bugfix with extdebug on. Revision 1.6 1997/12/03 13:46:40 carl * bugfix of my bug with near, now near in nasm mode for all non-rel8 instructions. (jcxz,jecxz still does not work thoug - assumed short now). Revision 1.5 1997/12/02 15:52:26 carl * bugfix of string (again...) - would be sometimes invalid. * bugfix of segment overrides under nasm. - removed near in labeled instructions (would cause errors). Revision 1.4 1997/12/01 17:42:51 pierre + added some more functionnality to the assembler parser Revision 1.3 1997/11/28 18:14:36 pierre working version with several bug fixes Revision 1.2 1997/11/28 14:54:50 carl + added popfd instruction. Revision 1.1.1.1 1997/11/27 08:32:57 michael FPC Compiler CVS start Pre-CVS log: CEC Carl-Eric Codere FK Florian Klaempfl PM Pierre Muller + feature added - removed * bug fixed or changed History: 9th october 1997: * bugfix of string write, closing quotes would never be written. (CEC) 23 october 1997: * fixed problem with writing strings of length = 0 (CEC). + added line separation of long string chains. (CEC). 31st october 1997: + completed the table of opcodes. (CEC) 3rd november 1997: + MMX instructions added (FK) 9th november 1997: * movsb represented the AT&T movsx - fixed, absolute values in getreferencestring would be preceded by $ - fixed (CEC). What's to do: o Fix problems regarding the segment names under NASM o generate extern entries for typed constants and variables o write lines numbers and file names to output file o comments }