{ $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_datablock(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_datablock(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:=''; prefix:= ''; { 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]+#9; hp:=Pai(hp^.next); { this is theorically impossible... } if hp=nil then begin s:=#9#9+prefix; AsmWriteLn(s); break; end; { nasm prefers prefix on a line alone } if (current_module^.output_format in [of_nasm,of_obj]) then begin AsmWriteln(#9#9+prefix); prefix:=''; end; end else prefix:= ''; { A_FNSTS need the w as suffix at least for nasm} if (current_module^.output_format in [of_nasm,of_obj]) then if (pai386(hp)^._operator = A_FNSTS) then pai386(hp)^._operator:=A_FNSTSW else if (pai386(hp)^._operator = A_FSTS) then pai386(hp)^._operator:=A_FSTSW; 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+prefix+int_op2str[pai386(hp)^._operator]+suffix+s); end; {$ifdef GDB} ait_stabn, ait_stabs, ait_stab_function_name : ; {$endif GDB} else internalerror(10000); end; 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.3 1998-04-08 16:58:01 pierre * several bugfixes ADD ADC and AND are also sign extended nasm output OK (program still crashes at end and creates wrong assembler files !!) procsym types sym in tdef removed !! Revision 1.2 1998/04/08 11:34:17 peter * nasm works (linux only tested) Revision 1.1.1.1 1998/03/25 11:18:16 root * Restored version 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 }