{ Inliner Version 1.00 File: INLINER.PAS Last revised: 12 Apr 1985 Author: Anthony M. Marcy DESCRIPTION Inliner is an assembler which translates 8088 assembly language directly into Turbo Pascal INLINE code. It is written in, and generates code for, Turbo Pascal 2.00 for the IBM PC. This program is in the public domain. Inliner accepts a source language similar, but not identical, to that of the IBM Macro Assembler (MASM). It produces a single Turbo INLINE statement ready to be merged into a Pascal program or used as an Include file. All 8088 instructions are supported. MASM pseudo-ops are not, and there are a few differences in syntax between Inliner and MASM, as detailed below. System requirements are those for running Turbo. If you can compile Inliner, you can run it. (If you can't compile it, you don't need it.) Maximum assembly program size is set by the size of memory. Inliner can use all available contiguous memory. The new version 3.00 of Turbo has changes to the INLINE statement which make it not always compatible with code written for Turbo 2.00. Inliner 1.00 is designed to work with Turbo 2.00. In particular, assembly programs which contain both labels and constant identifiers, and assembled by Inliner, may not compile correctly under Turbo 3.00. GETTING STARTED You will be prompted for a source file and a target file. If no source filename extension is given, .ASM is assumed. The default target file is your source filename with extension .PAS; a carriage return accepts the default, or you may enter any legal filename. Quick trick: entering TRM: as the source file will allow you to type your input directly into Inliner. It will not be saved, however, and no editing is available. End your input with ctrl-z. Entering NUL as the target file will cause no output file to be generated, but you can still see the output on the screen. Handy if you just need a line or two, or for testing what will "work". Inliner may also be started from the DOS command line, thus: A> inliner infile.asm outfile.pas The second parameter may be omitted, in which case the default is assumed. INSTRUCTION FORMAT An Inliner source line takes the general form: label: opcode operand, operand ;comment Each of these components is optional. A LABEL can be anything that would be legal as a Turbo identifier, limited in length to a maximum of twenty characters. The colon is mandatory after a label. OPCODEs are the standard Intel mnemonics. LOCK and the various REP prefixes are supported. The segment override prefix can only be placed before an operand, not before the opcode. OPERANDs can be of three general kinds: register, address, and immediate. Register operands are the usual mnemonics - AX,BX, etc. Address operands have the following form: prefix: (type) [base] [index] offset Each component is optional. The ordering is strict. prefix is a segment override -- DS, CS, SS, or ES type is a single letter -- N Near F Far S Short W Word B Byte base is a base register -- BX or BP index is an index register -- SI or DI offset is either a literal constant or a Turbo identifier Turbo identifiers are copied into the INLINE code. Any identifier which does not occur as a label is assumed to be a Turbo identifier. The compiler replaces variable names with their offsets within their segments; it replaces constant identifiers with their values. The location counter, *, is also legal. See the Turbo manual for details. ADD AL,var1 ;var1 is a global variable in the data segment ADD AL,[BP]var2 ;var2 is a local variable in the stack segment ADD AL,CS:var3 ;var3 is a typed constant in the code segment Immediate operands are distinguished by being prefixed with an equal sign. They may be constants or Turbo variables. Thus, MOV AX,=2 ;loads the value 2 into AX MOV AX,2 ;loads AX with the word at offset 2 in the data segment MOV AX,var1 ;loads AX with the contents of variable var1 MOV AX,=var1 ;loads the offset of variable var1 into AX The equal sign is optional in the INT, RET, IN, and OUT instructions, and before character literals. CONSTANTs can be decimal integers (positive or negative), hex constants in Turbo format (preceded by $), constant identifers, or character literals enclosed in single quotes. Examples: 2 -128 $FF cons 'x' The type must be specified when it cannot otherwise be deduced: ADD AX,[BP]2 ;AX - must be a word operand INC (W)[BP]2 ;requires (W) or (B) Immediate numeric constants default to (B)yte if in the range -128..255, otherwise (W)ord. JMP requires special treatment. A (F)ar jump to an absolute address may be coded with two operands, both immediate constants, representing the segment and the offset: JMP =$0060,=$0100 ;absolute address 0060:0100 A (N)ear jump to an offset in the CS requires a single immediate operand: JMP =$0100 ;address CS:0100 JMP =*-1 ;this instruction jumps to itself An indirect jump takes either a register or an address operand. In the latter case, the type must be specified: JMP AX ;must be (N)ear JMP (F)[BP][SI] JMP (N)var1 Lastly, the jump target may be an Inliner label. For forward references, more efficient code can be generated if (S)hort is specified when possible: JMP lab1 JMP (S)lab2 CALL is similar to JMP, except that (S)hort cannot be used. The conditional jump instructions -- JE, JNE, etc. -- take a single operand which may be either an immediate constant in the range -128..127 or an Inliner label. The string instructions vary slightly from MASM syntax. REP, REPZ, etc., are considered prefixes which must be placed before a string opcode on the same line. The special no-operand forms of the string opcodes -- MOVSB, MOVSW, etc. -- are not implemented. Instead, use the basic opcode with a type specifier. The full two-operand forms may also be written. REP CMPS (B) REP MOVS (W)[SI],[DI] Other instructions resemble their counterparts in MASM. Refer to the Macro Assembler manual for their formats. Inliner does not support any pseudo-ops, such as PROC, END, DW, or ASSUME. Nor does it support the 8087 mnemonics. Pascal declarations should be used to define data, in place of DB, DW, EQU, etc. But remember that your variables are Turbo variables -- Inliner cannot see your declarations to check type or addressibility. You must provide segment overrides where needed. EXAMPLES Here are some more examples of Inliner code: PUSH BP h2: CMP var1,=-1 ;byte variable assumed CMP var1,(W)=-1 ;unless overridden MOV var2,=var4 ;address is always two bytes JE (S)h5 REPE SCAS(B) ;instead of SCASB shl ax,cl ;lower case is OK ESC = 23 , [ DI ] var2 ;spaces are OK, too MOV ES:4,'&' h5: SUB (W)var3,=$40 NOP CALL (N)xyz ;indirect through variable xyz ;unless xyz is a label MOV [BX][DI],CS RET (N) 4 ;(N) or (F) required ----------------------------------------------------------------- Inliner is supported on the RBBS-PC operated by James Miles "The Programmer's Toolbox" (301) 540-7230 (data) 24 Hrs. Comments, bug reports, and suggested improvements are encouraged. Address them to ANTHONY MARCY or to SYSOP. If you make extensions or revisions to this program, please upload so that all may share. Enjoy! -----------------------------------------------------------------} program inliner; const tsize = 200; { size of symbol table } type filename = string[20]; opcode = (nul, mov,push,pop,xchg,in_,out,xlat,lea,lds,les,lahf,sahf,pushf, popf,add,adc,inc,sub,sbb,dec,neg,cmp,aas,das,mul,imul,aam,div_, idiv,aad,cbw,cwd,not_,shl_,sal,shr_,sar,rol,ror,rcl,rcr,and_, test_,or_,xor_,aaa,daa,rep,repe,repz,repne,repnz,movs,cmps,scas, lods,stos,call,jmp,ret,je,jz,jl,jnge,jle,jng,jb,jnae,jbe,jna,jp, jpe,jo,js,jne,jnz,jnl,jge,jnle,jg,jnb,jae,jnbe,ja,jnp,jpo,jno,jns, loop,loopz,loope,loopnz,loopne,jcxz,int,into,iret, clc,cmc,stc,cld,std,cli,sti,hlt,wait,esc,lock,nop, valid, assume,comment,db,dd,dq,dt,dw,end_,equ,even,extrn,group,include, label_,name,org,proc,public,record_,segment,struc,macro,endm, page,subttl,title, fld,fst,fstp,fxch,fcom,fcomp,fcompp,ftst,fxam,fadd,fsub,fmul,fdiv, fsqrt,fscale,fprem,frndint,fxtract,fabs,fchs,fptan,fpatan,f2xm1, fyl2x,fyl2xp1,fldz,fld1,fldpi,fldl2t,fldl2e,fldlg2,fldln2,finit, feni,fdisi,fldcw,fstcw,fstsw,fclex,fstenv,fldenv,fsave,frstor, fincstp,fdecstp,ffree,fnop,fwait, last); regs = (firstreg,ax,bx,cx,dx,sp,bp,si,di,al,bl,cl,dl,ah,bh,ch,dh, ds,ss,cs,es,lastreg); line = string[80]; idtype = string[20]; attr = record { attributes of an operand } isop: boolean; isaddr: boolean; isid: boolean; isconst: boolean; value: integer; isreg: boolean; issreg: boolean; rg: regs; isimmed: boolean; isidx,isbase: boolean; idx,base: regs; isbyte,isword: boolean; isshort,isnear,isfar: boolean; ident: idtype; end; cptr = ^codrec; codrec = record { intermediate form of a line of code } next: cptr; labeln: integer; op: opcode; op1,op2: attr; repx: opcode; lockx: boolean; override: regs; source: line; errn: byte; end; charset = set of char; var reg: array[regs] of string[2]; { register mnemonics } rn: array[regs] of 0..7; { register numbers } mn: array[opcode] of string[6]; { opcode mnemonics } tab: array[0..tsize] of record { symbol table } id: idtype; val: integer; end; src,targ: text; { source and target files } errn,pass: byte; { error #, pass # } atstart,ok: boolean; t: string[132]; { target line } loc: integer; { location counter } tcnt: integer; { number of entries in symbol table } n: integer; { index into symbol table } oldlen: integer; firstentry: cptr; { points to first line of intermediate code } codpnt: cptr; { points to current line of intermediate code } op: opcode; op1,op2: attr; repx: opcode; lockx: boolean; override: regs; procedure error(j: integer); { only the first error in a line is recorded } begin if errn = 0 then errn := j; end; procedure message; { print error messages } begin if errn <> 0 then begin ok := false; t := t + '***'; case errn of 1: t := t + 'NOT ENOUGH OPERANDS'; 2: t := t + 'INVALID OPERAND'; 3: t := t + 'TYPE CONFLICT'; 4: t := t + 'INVALID OPCODE'; 5: t := t + 'INVALID REGISTER'; 6: t := t + 'SYNTAX ERROR'; 7: t := t + 'TYPE NOT SPECIFIED'; 8: t := t + 'ILLEGAL REGISTER'; 9: t := t + 'ERROR IN CONSTANT'; 10: t := t + 'ILLEGAL OPERAND'; 11: t := t + 'TOO MANY OPERANDS'; 12: t := t + 'CONSTANT TOO BIG'; 13: t := t + 'DUPLICATE PREFIX'; 14: t := t + 'IDENTIFIER TOO LONG'; 15: t := t + 'DUPLICATE LABEL'; 16: t := t + 'UNDEFINED LABEL'; 17: t := t + 'LABEL TOO FAR'; 18: t := t + 'NOT IMPLEMENTED'; { 29: system error } else t := t + 'SYSTEM ERROR'; end; t := t + '***' end end; function stupcase(st: idtype): idtype; var i: integer; begin for i := 1 to length(st) do st[i] := upcase(st[i]); stupcase := st end; { stupcase } procedure startup; { input names of source and target files } var exists: boolean; inf,outf,tempstr: filename; commandline: string[127] absolute cseg:$80; params: string[127]; default: byte; procedure chkinf; { does source file exist? } begin inf := stupcase(inf); if pos('.',inf) = 0 then inf := inf + '.ASM'; assign(src,inf); {$I-} reset(src) {$I+} ; { if so, open it } exists := (ioresult = 0); if pos(':',inf) = 0 then inf := chr(default+65) + ':' + inf; if not exists then writeln('File ', inf, ' not found'); end; procedure chkoutf; { is target filename valid? } begin outf := stupcase(outf); assign(targ,outf); {$I-} rewrite(targ) {$I+} ; { if so, open it } exists := (ioresult = 0); if pos(':',outf) = 0 then outf := chr(default+65) + ':' + outf; if not exists then writeln('can''t open file ',outf); end; begin inf := ''; outf := ''; params := commandline; Inline( $B4/$19 { MOV AH,=$19 } /$CD/$21 { INT =$21 } /$88/$86/default ); { MOV [BP]default,AL } while (params <> '') and (params[1] = ' ') do delete(params,1,1); if params <> '' then begin { command line parameters } while (params <> '') and (params[1] <> ' ') do begin inf := inf + params[1]; delete(params,1,1); end; chkinf; if not exists then begin commandline := ''; startup; end else begin writeln('Source file: ',inf); while (params <> '') and (params[1] = ' ') do delete(params,1,1); if params <> '' then while (params <> '') and (params[1] <> ' ') do begin outf := outf + params[1]; delete(params,1,1); end else outf := copy(inf,1,pos('.',inf)) + 'PAS'; chkoutf; if not exists then begin commandline := ''; startup; end else writeln('Target file: ',outf); end; end else begin { prompt for filenames } repeat write(' Source file [.ASM] ? '); readln(inf); chkinf; until exists; tempstr := copy(inf,1,pos('.',inf)) + 'PAS'; repeat repeat write(' Target file [',tempstr,'] ? '); readln(outf); outf := stupcase(outf); until inf <> outf; if outf = '' then outf := tempstr; chkoutf; until exists; end; writeln; end; { startup } procedure init; { initialize tables } begin mn[mov ] := 'MOV' ; mn[push] := 'PUSH'; mn[pop ] := 'POP' ; mn[xchg] := 'XCHG'; mn[in_ ] := 'IN' ; mn[out ] := 'OUT' ; mn[xlat] := 'XLAT'; mn[lea ] := 'LEA' ; mn[lds ] := 'LDS' ; mn[les ] := 'LES' ; mn[lahf] := 'LAHF'; mn[pushf] := 'PUSHF'; mn[sahf] := 'SAHF'; mn[popf] := 'POPF'; mn[add ] := 'ADD' ; mn[adc ] := 'ADC' ; mn[inc ] := 'INC' ; mn[sub ] := 'SUB' ; mn[sbb ] := 'SBB' ; mn[dec ] := 'DEC' ; mn[cmp ] := 'CMP' ; mn[aas ] := 'AAS' ; mn[das ] := 'DAS' ; mn[mul ] := 'MUL' ; mn[imul] := 'IMUL'; mn[aam ] := 'AAM' ; mn[div_] := 'DIV' ; mn[idiv] := 'IDIV'; mn[aad ] := 'AAD' ; mn[cbw ] := 'CBW' ; mn[cwd ] := 'CWD' ; mn[aaa ] := 'AAA' ; mn[daa ] := 'DAA' ; mn[not_] := 'NOT' ; mn[shl_] := 'SHL' ; mn[sal ] := 'SAL' ; mn[shr_] := 'SHR' ; mn[sar ] := 'SAR' ; mn[rol ] := 'ROL' ; mn[ror ] := 'ROR' ; mn[rcl ] := 'RCL' ; mn[rcr ] := 'RCR' ; mn[and_] := 'AND' ; mn[or_ ] := 'OR' ; mn[test_] := 'TEST'; mn[xor_] := 'XOR' ; mn[rep ] := 'REP' ; mn[repne] := 'REPNE'; mn[repe] := 'REPE'; mn[repz] := 'REPZ'; mn[repnz] := 'REPNZ'; mn[movs] := 'MOVS'; mn[neg ] := 'NEG' ; mn[nop ] := 'NOP' ; mn[cmps] := 'CMPS'; mn[scas] := 'SCAS'; mn[lods] := 'LODS'; mn[stos] := 'STOS'; mn[call] := 'CALL'; mn[jmp ] := 'JMP' ; mn[ret ] := 'RET' ; mn[je ] := 'JE' ; mn[jz ] := 'JZ' ; mn[jl ] := 'JL' ; mn[jnge] := 'JNGE'; mn[jle ] := 'JLE' ; mn[jng ] := 'JNG' ; mn[jb ] := 'JB' ; mn[jnae] := 'JNAE'; mn[jbe ] := 'JBE' ; mn[jna ] := 'JNA' ; mn[jp ] := 'JP' ; mn[jpe ] := 'JPE' ; mn[jo ] := 'JO' ; mn[js ] := 'JS' ; mn[jne ] := 'JNE' ; mn[jnz ] := 'JNZ' ; mn[jnl ] := 'JNL' ; mn[jge ] := 'JGE' ; mn[jnle] := 'JNLE'; mn[jg ] := 'JG' ; mn[jnb ] := 'JNB' ; mn[jae ] := 'JAE' ; mn[jnbe] := 'JNBE'; mn[ja ] := 'JA' ; mn[jnp ] := 'JNP' ; mn[jpo ] := 'JPO' ; mn[jno ] := 'JNO' ; mn[jns ] := 'JNS' ; mn[loopz ] := 'LOOPZ' ; mn[loop] := 'LOOP'; mn[jcxz] := 'JCXZ'; mn[loopnz] := 'LOOPNZ'; mn[int ] := 'INT' ; mn[into] := 'INTO'; mn[loope ] := 'LOOPE' ; mn[iret] := 'IRET'; mn[clc ] := 'CLC' ; mn[loopne] := 'LOOPNE'; mn[cmc ] := 'CMC' ; mn[stc ] := 'STC' ; mn[cld ] := 'CLD' ; mn[std ] := 'STD' ; mn[cli ] := 'CLI' ; mn[sti ] := 'STI' ; mn[hlt ] := 'HLT' ; mn[wait] := 'WAIT'; mn[esc ] := 'ESC' ; mn[lock] := 'LOCK'; mn[valid] := ''; mn[db ] := 'DB' ; mn[assume ] := 'ASSUME' ; mn[dd ] := 'DD' ; mn[comment] := 'COMMENT'; mn[dq ] := 'DQ' ; mn[extrn ] := 'EXTRN' ; mn[dt ] := 'DT' ; mn[group ] := 'GROUP' ; mn[dw ] := 'DW' ; mn[include] := 'INCLUDE'; mn[end_] := 'END' ; mn[label_ ] := 'LABEL' ; mn[equ ] := 'EQU' ; mn[public ] := 'PUBLIC' ; mn[even] := 'EVEN'; mn[record_] := 'RECORD' ; mn[name] := 'NAME'; mn[segment] := 'SEGMENT'; mn[org ] := 'ORG' ; mn[struc ] := 'STRUC' ; mn[proc] := 'PROC'; mn[macro ] := 'MACRO' ; mn[endm] := 'ENDM'; mn[subttl ] := 'SUBTTL' ; mn[page] := 'PAGE'; mn[title ] := 'TITLE' ; mn[fld ] := 'FLD' ; mn[fst ] := 'FST' ; mn[fstp ] := 'FSTP' ; mn[fxch ] := 'FXCH' ; mn[fcom ] := 'FCOM' ; mn[fcomp ] := 'FCOMP' ; mn[fcompp] := 'FCOMPP'; mn[ftst ] := 'FTST' ; mn[fxam ] := 'FXAM' ; mn[fadd ] := 'FADD' ; mn[fsub ] := 'FSUB' ; mn[fmul ] := 'FMUL' ; mn[fdiv ] := 'FDIV' ; mn[fsqrt ] := 'FSQRT' ; mn[fscale] := 'FSCALE'; mn[fprem ] := 'FPREM' ; mn[fabs ] := 'FABS' ; mn[frndint] := 'FRNDINT'; mn[fchs ] := 'FCHS' ; mn[fptan ] := 'FPTAN' ; mn[fxtract] := 'FXTRACT'; mn[fpatan] := 'FPATAN'; mn[f2xm1 ] := 'F2XM1' ; mn[fyl2x ] := 'FYL2X' ; mn[fldz ] := 'FLDZ' ; mn[fld1 ] := 'FLD1' ; mn[fyl2xp1] := 'FYL2XP1'; mn[fldpi ] := 'FLDPI' ; mn[fldl2t] := 'FLDL2T'; mn[fldl2e] := 'FLDL2E'; mn[fldlg2] := 'FLDLG2'; mn[fldln2] := 'FLDLN2'; mn[finit ] := 'FINIT' ; mn[feni ] := 'FENI' ; mn[fdisi ] := 'FDISI' ; mn[fldcw ] := 'FLDCW' ; mn[fstcw ] := 'FSTCW' ; mn[fstsw ] := 'FSTSW' ; mn[fclex ] := 'FCLEX' ; mn[fstenv] := 'FSTENV'; mn[fldenv] := 'FLDENV'; mn[fsave ] := 'FSAVE' ; mn[frstor] := 'FRSTOR'; mn[ffree ] := 'FFREE' ; mn[fincstp] := 'FINCSTP'; mn[fnop ] := 'FNOP' ; mn[fwait ] := 'FWAIT' ; mn[fdecstp] := 'FDECSTP'; reg[ax] := 'AX'; reg[bx] := 'BX'; reg[cx] := 'CX'; reg[dx] := 'DX'; reg[sp] := 'SP'; reg[bp] := 'BP'; reg[si] := 'SI'; reg[di] := 'DI'; reg[al] := 'AL'; reg[bl] := 'BL'; reg[cl] := 'CL'; reg[dl] := 'DL'; reg[ah] := 'AH'; reg[bh] := 'BH'; reg[ch] := 'CH'; reg[dh] := 'DH'; reg[ds] := 'DS'; reg[ss] := 'SS'; reg[cs] := 'CS'; reg[es] := 'ES'; rn[ax] := 0; rn[bx] := 3; rn[cx] := 1; rn[dx] := 2; rn[sp] := 4; rn[bp] := 5; rn[si] := 6; rn[di] := 7; rn[al] := 0; rn[bl] := 3; rn[cl] := 1; rn[dl] := 2; rn[ah] := 4; rn[bh] := 7; rn[ch] := 5; rn[dh] := 6; rn[ds] := 3; rn[ss] := 2; rn[cs] := 1; rn[es] := 0; end; { init } function search(symbol: idtype): boolean; { search symbol table } begin { return index in global n } n := 0; symbol := stupcase(symbol); while (tab[n].id <> symbol) and (n <= tcnt) do n := n+1; if n = tcnt+1 then search := false else search := true; end; procedure generate; { pass 2 -- maintain location counter } { pass 3 -- generate object code } var q0,w,md,rm: byte; q1: integer; procedure oneop; { test for exactly one operand } begin if op2.isop then error(11); if not op1.isop then error(1); end; procedure emit(q:byte); { emit one byte } function hex(d:byte): char; begin if d <= 9 then hex := chr(48+d) else hex := chr(55+d); end; begin loc := loc+1; if (pass=3) and (errn = 0) then begin if atstart then t := t+' ' else t := t+'/'; atstart := false; t := t+'$'+hex(q shr 4)+hex(q and 15); end; end; procedure emit2(q:integer); { emit two bytes } begin begin emit(q and $ff); emit(q shr 8); end end; procedure emitid(ident: idtype); { emit identifier } begin loc := loc+2; if (pass=3) and (errn = 0) then t := t+'/'+ident; end; procedure emitimm(op:attr); { emit immediate value } begin with op do if isid then emitid(ident) else if isconst then if (w=1) then emit2(value) else emit(value) else error(10); end; procedure checktype(op1,op2:attr); { check compatibility of operands } begin if (op1.isword and not op2.isbyte) or (op2.isword and not op1.isbyte) then w := 1 else if (op1.isbyte and not op2.isword) or (op2.isbyte and not op1.isword) then w := 0 else if not (op1.isbyte or op1.isword or op2.isbyte or op2.isword) then error(7) else error(3); if op1.issreg or op2.issreg then w := 0; end; procedure modrm(q:byte; op:attr); { construct the modregr/m byte } begin with op do begin if isid then md := 2 else if isconst then if (value <= 127) and (value >= -128) then md := 1 else md := 2 else md := 0; if isidx and isbase then begin if base = bx then rm := 0 else rm := 2; if idx = di then rm := rm+1; end else if not isidx and not isbase then begin md := 0; rm := 6; end else begin rm := 4; if isidx and (idx = di) then rm := rm+1; if isbase then if base = bp then rm := rm+2 else rm := rm+3; end; emit((md shl 6)+(q shl 3)+rm); if isid then emitid(ident); if isconst then begin if (value <= 127) and (value >= -128) then begin emit(value); if (md=0) and (rm=6) then if value<0 then emit($ff) else emit(0); end else emit2(value); end; end; end; procedure regtoreg(q:byte; op1,op2:attr); begin checktype(op1,op2); emit(q+w); emit(192 + (rn[op1.rg] shl 3) + rn[op2.rg]); end; procedure imtoacc(q:byte; op1,op2:attr); begin checktype(op1,op2); emit(q+w); emitimm(op2); end; procedure imtoreg(q:byte; op1,op2:attr); begin if op1.isword and op2.isbyte then w := 1 else checktype(op1,op2); emit(q+(w shl 3)+rn[op1.rg]); emitimm(op2); end; procedure onerm(q:byte; op:attr); begin with op do begin if isreg then emit(192+(q shl 3)+rn[rg]) else if isaddr then modrm(q,op) else error(10); end; end; procedure imtorm(q,r:byte; op1,op2:attr; ext:boolean); begin if op1.isbyte and op2.isword then error(3) else if op1.isbyte and op2.isbyte then w := 0 else if op1.isword and op2.isword then w := 1 else if op1.isword and op2.isbyte then if ext then w := 3 else w := 1 else if op1.isaddr and op2.isbyte then w := 0 else if op1.isaddr and op2.isword then w := 1 else error(29); emit(q+w); onerm(r,op1); emitimm(op2); end; procedure regmem(q: byte; op1,op2: attr); begin checktype(op1,op2); emit(q+w); modrm(rn[op1.rg],op2); end; procedure inout(q:byte; op1,op2:attr); begin if not (op1.isreg and (op1.rg in [ax,al])) then error(10); if op1.rg=ax then w := 1 else w := 0; if op2.isconst then begin if op2.isidx or op2.isbase then error(10); if (op2.value < 0) or (op2.value > 255) then error(12); emit(q+w); emit(op2.value); end else if op2.isreg and (op2.rg=dx) then emit(q+8+w) else error(10); end; begin { generate } t := ''; errn := codpnt^.errn; op1 := codpnt^.op1; op2 := codpnt^.op2; with codpnt^ do begin if errn=0 then begin if repx in [rep,repne,repnz] then emit($f2); if repx in [repe,repz] then emit($f3); if lockx then emit($f0); if override in [ds,cs,ss,es] then emit($26+(rn[override] shl 3)); case op of nul: ; mov: begin w := 1; if not (op1.isop and op2.isop) then error(1) else if op1.issreg then begin if op1.rg=cs then error(10); q0 := $8e; if op2.isreg then regtoreg(q0,op1,op2) else if op2.isaddr then regmem(q0,op1,op2) else error(10); end else if op2.issreg then begin q0 := $8c; if op1.isreg then regtoreg(q0,op2,op1) else if op1.isaddr then regmem(q0,op2,op1) else error(10); end else if op2.isimmed then begin if op1.isreg then imtoreg($b0,op1,op2) else imtorm($c6,0,op1,op2,false); end else if op1.isreg and (op1.rg in [ax,al]) and op2.isaddr and not op2.isbase and not op2.isidx then begin if op1.rg = ax then emit($a1) else emit($a0); emitimm(op2); end else if op2.isreg and (op2.rg in [ax,al]) and op1.isaddr and not op1.isbase and not op1.isidx then begin if op2.rg = ax then emit($a3) else emit($a2); emitimm(op1); end else if op1.isreg and op2.isreg then begin q0 := $8a; regtoreg(q0,op1,op2); end else if (op1.isreg and op2.isaddr) or (op1.isaddr and op2.isreg) then begin q0 := $88; if op1.isaddr then regmem(q0,op2,op1) else begin q0 := q0+2; regmem(q0,op1,op2) end end else error(10); end; add,adc,sub,sbb,cmp,and_,or_,xor_,test_: begin if not (op1.isop and op2.isop) then error(1) else if op2.isimmed then if op1.isreg and ((op1.rg=ax) or (op1.rg=al)) then begin if op1.isword then op2.isbyte := false; case op of add: q0 := $04; adc: q0 := $14; sub: q0 := $2c; sbb: q0 := $1c; cmp: q0 := $3c; and_: q0 := $24; or_ : q0 := $0c; xor_: q0 := $34; test_: q0 := $a8; end; imtoacc(q0,op1,op2); end else begin q0 := $80; case op of add: q1 := 0; adc: q1 := 2; sub: q1 := 5; sbb: q1 := 3; cmp: q1 := 7; and_: q1 := 4; or_ : q1 := 1; xor_: q1 := 6; test_: begin q0 := $f6; q1 := 0; end; end; if op in [add,adc,sub,sbb,cmp] then imtorm(q0,q1,op1,op2,true) else imtorm(q0,q1,op1,op2,false); end else if op1.isreg and op2.isreg then begin case op of add: q0 := $02; adc: q0 := $12; sub: q0 := $2a; sbb: q0 := $1a; cmp: q0 := $3a; and_: q0 := $22; or_ : q0 := $0a; xor_: q0 := $32; test_: q0 := $84; end; regtoreg(q0,op1,op2); end else if (op1.isaddr and op2.isreg) or (op1.isreg and op2.isaddr) then begin case op of add: q0 := $00; adc: q0 := $10; sub: q0 := $28; sbb: q0 := $18; cmp: q0 := $38; and_: q0 := $20; or_ : q0 := $08; xor_: q0 := $30; test_: q0 := $84; end; if op1.isaddr then regmem(q0,op2,op1) else begin if op<>test_ then q0 := q0+2; regmem(q0,op1,op2) end end else error(10); end; push,pop: begin with op1 do begin oneop; if issreg then begin if (op=pop) and (rg=cs) then error(10); case op of push: q0 := $06; pop: q0 := $07; end; emit(q0+(rn[rg] shl 3)); end else if isreg then begin if not isword then error(3); case op of push: q0 := $50; pop: q0 := $58; end; emit(q0+rn[rg]); end else if isaddr then begin if isbyte then error(3); case op of push: begin q0 := $ff; q1 := 6; end; pop: begin q0 := $8f; q1 := 0; end; end; emit(q0); onerm(q1,op1); end else error(10); end; end; inc,dec: begin with op1 do begin oneop; if isreg and isword then begin case op of inc: q0 := $40; dec: q0 := $48; end; emit(q0+rn[rg]); end else if isaddr or isreg then begin if isbyte then w := 0 else if isword then w := 1 else error(7); case op of inc: q1 := 0; dec: q1 := 1; end; emit($fe+w); onerm(q1,op1); end else error(10); end; end; xchg: begin if not op2.isop then error(1); if op1.isreg and op2.isreg and ((op1.rg=ax) or (op2.rg=ax)) then begin if op1.rg<>ax then emit($90+rn[op1.rg]) else emit($90+rn[op2.rg]); end else if op1.isreg and op2.isreg then regtoreg($86,op1,op2) else if op1.isreg and op2.isaddr then regmem($86,op1,op2) else if op1.isaddr and op2.isreg then regmem($86,op2,op1) else error(10); end; mul,imul,div_,idiv,neg,not_: begin oneop; if op1.isbyte then q0 := $f6 else if op1.isword then q0 := $f7 else error(7); case op of mul: q1 := 4; imul: q1 := 5; div_: q1 := 6; idiv: q1 := 7; neg: q1 := 3; not_: q1 := 2; end; emit(q0); onerm(q1,op1); end; in_: inout($e4,op1,op2); out: inout($e6,op2,op1); lea,lds,les: begin if not op2.isop then error(1); if not(op1.isreg and op1.isword and op2.isaddr) then error(10); case op of lea: q0 := $8d; lds: q0 := $c5; les: q0 := $c4; end; emit(q0); onerm(rn[op1.rg],op2); end; shl_,sal,shr_,sar,rol,ror,rcl,rcr: begin with op2 do begin if not isop then error(1); if isidx or isbase then error(10); if isconst and (value=1) then q0 := $d0 else if isreg and (rg=cl) then q0 := $d2 else error(10); case op of shl_,sal: q1 := 4; shr_: q1 := 5; sar: q1 := 7; rol: q1 := 0; ror: q1 := 1; rcl: q1 := 2; rcr: q1 := 3; end; if op1.isword then q0 := q0+1 else if not op1.isbyte then error(7); if not(op1.isreg or op1.isaddr) then error(10); emit(q0); onerm(q1,op1); end; end; lods,stos,scas: begin with op1 do begin if op2.isop then error(11); if not op1.isop then error(7); case op of lods: q0 := $ac; stos: q0 := $aa; scas: q0 := $ae; end; if isword then q0 := q0+1 else if not isbyte then error(7); if isbase or isimmed or isreg then error(10); if isidx and (((idx=si) and (op in [stos,scas])) or ((idx=di) and (op=lods))) then error(10); emit(q0); end; end; movs,cmps: begin if op2.isop then begin checktype(op1,op2); if op2.isidx and (((op2.idx=di) and (op=movs)) or ((op2.idx=si) and (op=cmps))) then error(10); if op2.isbase or op2.isimmed or op2.isreg then error(10); end else if op1.isop then begin if op1.isword then w := 1 else if op1.isbyte then w := 0 else error(7); if op1.isimmed or op1.isreg or op1.isaddr then error(10); end else error(7); if op1.isop then begin if op1.isbase or op1.isimmed or op1.isreg then error(10); if op1.isidx and (((op1.idx=si) and (op=movs)) or ((op1.idx=di) and (op=cmps))) then error(10); end; case op of movs: emit($a4+w); cmps: emit($a6+w); end; end; ret: begin if op2.isop then error(11); if not op1.isop then error(1); with op1 do begin if isidx or isbase or isreg or isid then error(10); if isconst then q0 := $c2 else q0 := $c3; if isfar then q0 := q0+8 else if not isnear then if isshort then error(10) else error(7); emit(q0); if isconst then emit2(value); end end; jmp,call: begin with op1 do begin w := 1; if op2.isop then begin if not (isimmed and op2.isimmed) then error(10); if isnear or op2.isnear then error(3); case op of jmp: emit($ea); call: emit($9a); end; emitimm(op1); emitimm(op2); end else if not op1.isop then error(1) else if isfar then begin if (not isaddr) or (isid and search(ident)) then error(10); emit($ff); case op of jmp: onerm(5,op1); call: onerm(3,op1); end; end else if isimmed and isconst then begin if (value<=127) and (value>=-128) and (op=jmp) then begin emit($eb); emit(value); end else begin case op of jmp: emit($e9); call: emit($e8); end; emitimm(op1); end; end else if isid and search(ident) then begin if isidx or isbase then error(2); q1 := tab[n].val-loc-2; if pass=3 then begin if (op=jmp) and (q1 >= -128) and (q1 <= 127) then begin emit($eb); if isshort then emit(q1) else begin emit(q1); emit($90); end; end else begin case op of jmp: begin if isshort then error(17); emit($e9); end; call: begin if isshort then error(10); emit($e8); end; end; emit2(q1-1); end; end else begin {pass2} if (op=jmp) and (isshort or ((tab[n].val > -1) and (q1 > -128))) then begin emit2(0); isshort := true; end else begin emit2(0); emit(0); end; end; end else if (isreg or isaddr) and not (isbyte or isshort) then begin if not (isnear or isreg) then error(7); emit($ff); case op of jmp: onerm(4,op1); call: onerm(2,op1); end; end else error(10); end; end; je,jz,jl,jnge,jle,jng,jb,jnae,jbe,jna,jp,jpe,jo,js,jne,jnz,jnl,jge,jnle, jg,jnb,jae,jnbe,ja,jnp,jpo,jno,jns,loop,loopz,loope,loopnz,loopne,jcxz: begin oneop; with op1 do begin if (isimmed and isconst) then if not ((value>=-128) and (value<=127)) then error(12) else else if not (isid and not (isidx or isbase)) then error(10); case op of je,jz: q0 := $74; jl,jnge: q0 := $7c; jle,jng: q0 := $7e; jb,jnae: q0 := $72; jbe,jna: q0 := $76; jp,jpe: q0 := $7a; jo: q0 := $70; js: q0 := $78; jne,jnz: q0 := $75; jnl,jge: q0 := $7d; jnle,jg: q0 := $7f; jnb,jae: q0 := $73; jnbe,ja: q0 := $77; jnp,jpo: q0 := $7b; jno: q0 := $71; jns: q0 := $79; loop: q0 := $e2; loopz,loope: q0 := $e1; loopnz,loopne: q0 := $e0; jcxz: q0 := $e3; end; if isconst then begin emit(q0); emit(value); end else begin if (pass=3) and not search(ident) then error(16); q1 := tab[n].val-loc-2; if (pass=3) and ((q1 < -128) or (q1 > 127)) then error(17); emit(q0); emit(q1); end; end; end; int: begin with op1 do begin oneop; if isidx or isbase or not isconst then error(10); if (value < 0) or (value > 255) then error(12); if value=3 then emit($cc) else begin emit($cd); emit(value); end; end; end; esc: begin if not op2.isop then error(1); if not op1.isimmed then error(10); if (op1.value < 0) or (op1.value > 63) then error(10); emit($d8+(op1.value shr 3)); onerm((op1.value and 7),op2); end; xlat,lahf,sahf,pushf,popf,aaa,daa,aas,das,cbw,cwd,into,iret,clc,cmc, stc,cld,std,cli,sti,hlt,wait,aam,aad,nop: begin if op1.isop then error(11); case op of xlat: emit($d7); lahf: emit($9f); sahf: emit($9e); pushf:emit($9c); popf: emit($9d); aaa: emit($37); daa: emit($27); aas: emit($3f); das: emit($2f); cbw: emit($98); cwd: emit($99); into: emit($ce); iret: emit($cf); clc: emit($f8); cmc: emit($f5); stc: emit($f9); cld: emit($fc); std: emit($fd); cli: emit($fa); sti: emit($fb); hlt: emit($f4); wait: emit($9b); aam: begin emit($d4); emit($0a); end; aad: begin emit($d5); emit($0a); end; nop: emit($90); end; end; else error(29); end; { case op } end; { if errn } if pass=3 then begin { finish constructing the target line } if codpnt = firstentry then begin writeln(targ,'Inline('); writeln; writeln('Inline('); end; message; if next = nil then t := t + ' );'; while length(t) < 25 do t := t+' '; t := t + ' { ' + source; if length(t) < oldlen-4 { make it look pretty } then begin if length(t) > oldlen-8 then oldlen := oldlen+2; while length(t) < oldlen-4 do t := t+' '; end; t := t+' }'; oldlen := length(t); writeln(targ,t); writeln(t); { and write it to the file } codpnt := next; end; end; {with} end; { generate } procedure address; { compute address of each label } begin if codpnt^.labeln <> 0 then tab[codpnt^.labeln].val := loc; generate; { advance location counter } codpnt^.errn := errn; codpnt := codpnt^.next; end; procedure parse_line; { scan source and build intermediate code } var s: line; { source line } p: integer; { index into s } m: idtype; { mnemonic opcode } labeln: integer; temp: line; id: idtype; { identifier } preventry: cptr; { points to previous line of intermediate code } label nocode; function more: boolean; { any more characters on this line? } begin more := p <= length(s); end; procedure skipblank; begin while more and (s[p] = ' ') do p := p+1; end; function alpha: boolean; begin alpha := more and (s[p] in ['a'..'z','A'..'Z']); end; function digit: boolean; begin digit := more and (s[p] in ['0'..'9']); end; function peek(aset: charset): boolean; { is next character in aset? } begin if more and (s[p] in aset) then peek := true else peek := false; end; function test(c: char): boolean; { is the next character c? } begin { if so, scan over it } if more and (upcase(s[p]) = c) then begin p := p+1; skipblank; test := true end else test := false end; procedure getid; { found an alpha } begin { get rest of identifier } id := ''; while alpha or digit or peek(['_']) do begin if length(id) < 20 then id := id + s[p] { return it in id } else error(14); p := p+1; end; skipblank; end; procedure enter(symbol: idtype; var m: integer); { make entry in symbol table } begin if search(symbol) then error(15) else if tcnt = tsize then begin writeln; writeln('Assembly Aborted -- Symbol Table Full'); close(src); close(targ); halt; end else begin tcnt := tcnt+1; tab[tcnt].id := stupcase(symbol); tab[tcnt].val := -1; m := tcnt; end; end; function code: boolean; { found an id } { is it an opcode? } begin op := nul; m := stupcase(id); repeat { if so, return it in op } op := succ(op) until (mn[op] = m) or (op = last); if op in [rep,repe,repz,repne,repnz] then begin if repx <> nul then error(13); repx := op; { REP prefix } if alpha then begin { look for another opcode } getid; code := code; end else error(4); end else if op=lock then begin if lockx then error(13); lockx := true; { LOCK prefix } if alpha then begin { look for another opcode } getid; code := code; end else error(4); end else if (op > valid) and (op <> last) then error(18) else if op <> last then begin code := true; if (repx<>nul) and not (op in [movs,cmps,scas,lods,stos]) then error(4); end else begin code := false; op := nul; end; end; { code } procedure getoperand(var opr: attr); { scan an operand } { determine its attributes } var r: regs; label gotid; procedure makebyte; { it's a byte } begin if opr.isword then error(3) else opr.isbyte := true; end; procedure makeword; { it's a word } begin if opr.isbyte then error(3) else opr.isword := true; end; procedure getnum; { scan a numeric literal } var code: integer; minus: boolean; procedure gethex; { scan a hexadecimal literal } begin if id = '-' then minus := true; id := '$'; p := p+1; while more and (digit or (upcase(s[p]) in ['A','B','C','D','E','F'])) do begin id := id + s[p]; { return it in id } p := p+1; end; if id = '$' then error(2); end; begin id := ''; minus := false; if test('+') then; if test('-') then id := '-'; if peek(['$']) then gethex { hex } else while digit do begin { decimal } id := id + s[p]; p := p+1; end; if id = '' then error(2); with opr do begin val(id,value,code); { return value } if code<>0 then if id='-32768' then value := $8000 else error(9); if minus then value := -value end; if id[1] = '-' then delete(id,1,1); skipblank; end; { getnum } procedure getchar; { scan a character literal } begin with opr do begin p := p+1; value := ord(s[p]); p := p+1; if not test('''') then error(2) else begin isconst := true; isimmed := true; if not isword then isbyte := true; end; end; end; function testreg: boolean; { is id a register name? } begin r := firstreg; temp := stupcase(id); repeat r := succ(r) { if so, return register number in r } until (reg[r] = temp) or (r = lastreg); if r <> lastreg then testreg := true else testreg := false; end; begin {getoperand} with opr do begin isop := true; if not (alpha or digit or peek(['=','$','*','[','+','-','(',''''])) then error(2) else begin if alpha then begin getid; if testreg and (r in [ds,cs,ss,es]) and peek([':']) then begin { segment override prefix } if test(':') then; if override<>lastreg then error(13); override := r; end else goto gotid; end; if test('(') then begin { type modifier } if test('B') then makebyte else if test('W') then makeword else if test('S') then isshort := true else if test('N') then isnear := true else if test('F') then isfar := true else error(6); if not test(')') then error(6); end; if test('=') then isimmed := true; if test('[') then begin { base or index register } if isimmed then error(2); isaddr := true; getid; if testreg then begin if not test(']') then error(6); if r in [bx,bp] then begin { base register } isbase := true; isop := true; base := r; if test('[') then begin getid; if testreg then begin if not test(']') then error(6); if r in [si,di] then begin { and index register } isidx := true; idx := r; end else error(8) end else error(5) end end else if r in [si,di] then begin { index register } isidx := true; idx := r; end else error(8); end else error(5) end; if alpha then begin { identifier } getid; gotid: if testreg then begin { it's a register } if r in [ds,ss,cs,es] then issreg := true else isreg := true; if r in [ax,bx,cx,dx,sp,bp,si,di,ds,ss,cs,es] then makeword; if r in [ah,bh,ch,dh,al,bl,cl,dl] then makebyte; if isimmed then error(2); rg := r; end else begin { it's a variable or label id } isaddr := not isimmed; isid := true; ident := id; if isimmed then makeword; end; end {alpha} else if digit or peek(['$','+','-']) then begin { numeric literal } getnum; isaddr := not isimmed; isconst := true; if isimmed then if (value <= 255) and (value >= -128) and not isword then makebyte else makeword; end else if test('*') then begin { location counter reference } ident := '*'; isaddr := not isimmed; isid := true; if isimmed then makeword; if test('+') then ident := '*+'; if test('-') then ident := '*-'; if ident<>'*' then begin if not peek(['$','0'..'9']) then error(9); getnum; ident := ident + id; end; end else if peek(['''']) then getchar; { character literal } if isbase and (base=bp) and not isidx and not (isid or isconst) then begin isconst := true; value := 0; ident := '$00'; end; end; if isimmed and not (isid or isconst) then error(6); end; {with} skipblank; end; {getoperand} begin { parse_line } errn := 0; labeln := 0; op := nul; repx := nul; lockx := false; override := lastreg; with op1 do begin isop := false; isaddr := false; isid := false; isreg := false; issreg := false; isidx := false; isbase := false; isbyte := false; isword := false; isshort := false; isnear := false; isfar := false; isimmed := false; isconst := false; end; op2 := op1; readln(src,s); { read in a source line } for p := 1 to length(s) do if ord(s[p]) < 32 then s[p] := ' '; p := 1; if more then begin skipblank; if alpha then begin getid; if test(':') then begin { label } enter(id,labeln); if alpha then getid else goto nocode; end; if code { opcode } then begin if more and not peek([';']) then begin getoperand(op1); { first operand } if test(',') then begin if more then getoperand(op2) { second operand } else error(6); if more and not peek([';']) then error(6); end else if more and not peek([';']) then error(6); end end else error(4) end else nocode: if more and not peek([';']) then error(6); preventry := codpnt; if maxavail > sizeof(codrec) shr 4 +1 then new(codpnt) { create new line of intermediate code } else begin writeln; writeln('Assembly Aborted -- Out of Memory'); close(src); close(targ); halt; end; if firstentry = nil then firstentry := codpnt; preventry^.next := codpnt; { and link it } codpnt^.next := nil; codpnt^.labeln := labeln; codpnt^.op := op; { enter the data } codpnt^.op1 := op1; codpnt^.op2 := op2; codpnt^.repx := repx; codpnt^.lockx := lockx; codpnt^.override := override; codpnt^.errn := errn; codpnt^.source := s; end; end; { parse_line } begin { main } writeln(' InLiner'); writeln; startup; init; atstart := true; ok := true; oldlen := 0; loc := 0; tcnt := 0; pass := 1; firstentry := nil; while not eof(src) do parse_line; pass := 2; codpnt := firstentry; loc := 0; while codpnt <> nil do address; pass := 3; codpnt := firstentry; loc := 0; while codpnt <> nil do generate; writeln; if ok then writeln('Assembly Successful') else writeln('Assembled with Errors'); close(src); close(targ); end.