home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / INLINE.ZIP / INLINER.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1985-12-28  |  51.0 KB  |  1,596 lines
  1.  
  2. {                                Inliner
  3.  
  4.     Version 1.00                                     File: INLINER.PAS
  5. Last revised: 12 Apr 1985                          Author: Anthony M. Marcy
  6.  
  7. DESCRIPTION
  8.  
  9.    Inliner is an assembler which translates 8088 assembly language directly
  10. into Turbo Pascal INLINE code.  It is written in, and generates code for,
  11. Turbo Pascal 2.00 for the IBM PC.  This program is in the public domain.
  12.    Inliner accepts a source language similar, but not identical, to that
  13. of the IBM Macro Assembler (MASM).  It produces a single Turbo INLINE statement
  14. ready to be merged into a Pascal program or used as an Include file.
  15.    All 8088 instructions are supported.  MASM pseudo-ops are not, and there
  16. are a few differences in syntax between Inliner and MASM, as detailed below.
  17.    System requirements are those for running Turbo.  If you can compile
  18. Inliner, you can run it.  (If you can't compile it, you don't need it.)
  19. Maximum assembly program size is set by the size of memory.  Inliner can use
  20. all available contiguous memory.
  21.    The new version 3.00 of Turbo has changes to the INLINE statement which
  22. make it not always compatible with code written for Turbo 2.00.  Inliner 1.00
  23. is designed to work with Turbo 2.00.  In particular, assembly programs which
  24. contain both labels and constant identifiers, and assembled by Inliner, may
  25. not compile correctly under Turbo 3.00.
  26.  
  27. GETTING STARTED
  28.  
  29.    You will be prompted for a source file and a target file.  If no source
  30. filename extension is given, .ASM is assumed.  The default target file is
  31. your source filename with extension .PAS; a carriage return accepts the
  32. default, or you may enter any legal filename.
  33.    Quick trick: entering TRM: as the source file will allow you to type your
  34. input directly into Inliner.  It will not be saved, however, and no editing
  35. is available.  End your input with ctrl-z.  Entering NUL as the target file
  36. will cause no output file to be generated, but you can still see the output
  37. on the screen.  Handy if you just need a line or two, or for testing what
  38. will "work".
  39.    Inliner may also be started from the DOS command line, thus:
  40.                 A> inliner infile.asm outfile.pas
  41. The second parameter may be omitted, in which case the default is assumed.
  42.  
  43.  
  44. INSTRUCTION FORMAT
  45.  
  46.    An Inliner source line takes the general form:
  47.                label: opcode operand, operand ;comment
  48. Each of these components is optional.
  49.  
  50.    A LABEL can be anything that would be legal as a Turbo identifier, limited
  51. in length to a maximum of twenty characters.  The colon is mandatory after
  52. a label.
  53.  
  54.    OPCODEs are the standard Intel mnemonics.  LOCK and the various REP
  55. prefixes are supported.  The segment override prefix can only be placed before
  56. an operand, not before the opcode.
  57.  
  58.    OPERANDs can be of three general kinds: register, address, and immediate.
  59. Register operands are the usual mnemonics - AX,BX, etc.
  60. Address operands have the following form:
  61.                prefix: (type) [base] [index] offset
  62. Each component is optional.  The ordering is strict.
  63.        prefix is a segment override -- DS, CS, SS, or ES
  64.        type is a single letter --  N   Near
  65.                                    F   Far
  66.                                    S   Short
  67.                                    W   Word
  68.                                    B   Byte
  69.        base is a base register -- BX or BP
  70.        index is an index register -- SI or DI
  71.        offset is either a literal constant or a Turbo identifier
  72.  
  73. Turbo identifiers are copied into the INLINE code.  Any identifier which does
  74. not occur as a label is assumed to be a Turbo identifier. The compiler replaces
  75. variable names with their offsets within their segments; it replaces constant
  76. identifiers with their values.  The location counter, *, is also legal.  See
  77. the Turbo manual for details.
  78.      ADD AL,var1     ;var1 is a global variable in the data segment
  79.      ADD AL,[BP]var2 ;var2 is a local variable in the stack segment
  80.      ADD AL,CS:var3  ;var3 is a typed constant in the code segment
  81.  
  82. Immediate operands are distinguished by being prefixed with an equal sign.
  83. They may be constants or Turbo variables.  Thus,
  84.      MOV AX,=2 ;loads the value 2 into AX
  85.      MOV AX,2  ;loads AX with the word at offset 2 in the data segment
  86.      MOV AX,var1  ;loads AX with the contents of variable var1
  87.      MOV AX,=var1 ;loads the offset of variable var1 into AX
  88. The equal sign is optional in the INT, RET, IN, and OUT instructions, and
  89. before character literals.
  90.  
  91.    CONSTANTs can be decimal integers (positive or negative), hex constants
  92. in Turbo format (preceded by $), constant identifers, or character literals
  93. enclosed in single quotes.  Examples:  2   -128   $FF   cons   'x'
  94.    The type must be specified when it cannot otherwise be deduced:
  95.      ADD AX,[BP]2  ;AX - must be a word operand
  96.      INC (W)[BP]2  ;requires (W) or (B)
  97. Immediate numeric constants default to (B)yte if in the range -128..255,
  98. otherwise (W)ord.
  99.  
  100.    JMP requires special treatment.  A (F)ar jump to an absolute address may be
  101. coded with two operands, both immediate constants, representing the segment
  102. and the offset:
  103.      JMP =$0060,=$0100   ;absolute address 0060:0100
  104. A (N)ear jump to an offset in the CS requires a single immediate operand:
  105.      JMP =$0100   ;address CS:0100
  106.      JMP =*-1   ;this instruction jumps to itself
  107. An indirect jump takes either a register or an address operand.  In the latter
  108. case, the type must be specified:
  109.      JMP AX     ;must be (N)ear
  110.      JMP (F)[BP][SI]
  111.      JMP (N)var1
  112. Lastly, the jump target may be an Inliner label.  For forward references,
  113. more efficient code can be generated if (S)hort is specified when possible:
  114.      JMP lab1
  115.      JMP (S)lab2
  116.  
  117.    CALL is similar to JMP, except that (S)hort cannot be used.
  118.  
  119.    The conditional jump instructions -- JE, JNE, etc. -- take a single
  120. operand which may be either an immediate constant in the range -128..127
  121. or an Inliner label.
  122.  
  123.    The string instructions vary slightly from MASM syntax.  REP, REPZ, etc.,
  124. are considered prefixes which must be placed before a string opcode on the
  125. same line.  The special no-operand forms of the string opcodes -- MOVSB,
  126. MOVSW, etc. -- are not implemented.  Instead, use the basic opcode with
  127. a type specifier.  The full two-operand forms may also be written.
  128.      REP CMPS (B)
  129.      REP MOVS (W)[SI],[DI]
  130.  
  131.    Other instructions resemble their counterparts in MASM.  Refer to the
  132. Macro Assembler manual for their formats.  Inliner does not support any
  133. pseudo-ops, such as PROC, END, DW, or ASSUME.  Nor does it support the
  134. 8087 mnemonics.
  135.    Pascal declarations should be used to define data, in place of DB, DW,
  136. EQU, etc.  But remember that your variables are Turbo variables -- Inliner
  137. cannot see your declarations to check type or addressibility.  You must
  138. provide segment overrides where needed.
  139.  
  140.  
  141. EXAMPLES
  142.  
  143.    Here are some more examples of Inliner code:
  144.  
  145.      PUSH BP
  146.  h2: CMP var1,=-1    ;byte variable assumed
  147.      CMP var1,(W)=-1  ;unless overridden
  148.      MOV var2,=var4  ;address is always two bytes
  149.      JE (S)h5
  150.      REPE SCAS(B) ;instead of SCASB
  151.      shl ax,cl   ;lower case is OK
  152.      ESC = 23 , [ DI ] var2 ;spaces are OK, too
  153.      MOV ES:4,'&'
  154.  h5: SUB (W)var3,=$40
  155.      NOP
  156.      CALL (N)xyz ;indirect through variable xyz
  157.                  ;unless xyz is a label
  158.      MOV [BX][DI],CS
  159.      RET (N) 4   ;(N) or (F) required
  160.  
  161.      -----------------------------------------------------------------
  162.  
  163.    Inliner is supported on the RBBS-PC operated by
  164.               James Miles
  165.               "The Programmer's Toolbox"
  166.               (301) 540-7230 (data)
  167.               24 Hrs.
  168. Comments, bug reports, and suggested improvements are encouraged.  Address
  169. them to ANTHONY MARCY or to SYSOP.  If you make extensions or revisions
  170. to this program, please upload so that all may share.
  171.  
  172.                              Enjoy!
  173.  
  174.      -----------------------------------------------------------------}
  175.  
  176.  
  177. program inliner;
  178.  
  179. const
  180.   tsize = 200;     { size of symbol table }
  181.  
  182. type
  183.   filename = string[20];
  184.   opcode = (nul,
  185.             mov,push,pop,xchg,in_,out,xlat,lea,lds,les,lahf,sahf,pushf,
  186.             popf,add,adc,inc,sub,sbb,dec,neg,cmp,aas,das,mul,imul,aam,div_,
  187.             idiv,aad,cbw,cwd,not_,shl_,sal,shr_,sar,rol,ror,rcl,rcr,and_,
  188.             test_,or_,xor_,aaa,daa,rep,repe,repz,repne,repnz,movs,cmps,scas,
  189.             lods,stos,call,jmp,ret,je,jz,jl,jnge,jle,jng,jb,jnae,jbe,jna,jp,
  190.             jpe,jo,js,jne,jnz,jnl,jge,jnle,jg,jnb,jae,jnbe,ja,jnp,jpo,jno,jns,
  191.             loop,loopz,loope,loopnz,loopne,jcxz,int,into,iret,
  192.             clc,cmc,stc,cld,std,cli,sti,hlt,wait,esc,lock,nop,
  193.             valid,
  194.             assume,comment,db,dd,dq,dt,dw,end_,equ,even,extrn,group,include,
  195.             label_,name,org,proc,public,record_,segment,struc,macro,endm,
  196.             page,subttl,title,
  197.             fld,fst,fstp,fxch,fcom,fcomp,fcompp,ftst,fxam,fadd,fsub,fmul,fdiv,
  198.             fsqrt,fscale,fprem,frndint,fxtract,fabs,fchs,fptan,fpatan,f2xm1,
  199.             fyl2x,fyl2xp1,fldz,fld1,fldpi,fldl2t,fldl2e,fldlg2,fldln2,finit,
  200.             feni,fdisi,fldcw,fstcw,fstsw,fclex,fstenv,fldenv,fsave,frstor,
  201.             fincstp,fdecstp,ffree,fnop,fwait,
  202.             last);
  203.   regs = (firstreg,ax,bx,cx,dx,sp,bp,si,di,al,bl,cl,dl,ah,bh,ch,dh,
  204.           ds,ss,cs,es,lastreg);
  205.   line = string[80];
  206.   idtype = string[20];
  207.   attr = record                   { attributes of an operand }
  208.            isop: boolean;
  209.            isaddr: boolean;
  210.            isid: boolean;
  211.            isconst: boolean;
  212.            value: integer;
  213.            isreg: boolean;
  214.            issreg: boolean;
  215.            rg: regs;
  216.            isimmed: boolean;
  217.            isidx,isbase: boolean;
  218.            idx,base: regs;
  219.            isbyte,isword: boolean;
  220.            isshort,isnear,isfar: boolean;
  221.            ident: idtype;
  222.          end;
  223.   cptr = ^codrec;
  224.   codrec = record                  { intermediate form of a line of code }
  225.              next: cptr;
  226.              labeln: integer;
  227.              op: opcode;
  228.              op1,op2: attr;
  229.              repx: opcode;
  230.              lockx: boolean;
  231.              override: regs;
  232.              source: line;
  233.              errn: byte;
  234.            end;
  235.   charset = set of char;
  236.  
  237. var
  238.   reg: array[regs] of string[2];             { register mnemonics }
  239.   rn: array[regs] of 0..7;                   { register numbers   }
  240.   mn: array[opcode] of string[6];            { opcode mnemonics   }
  241.   tab: array[0..tsize] of record             { symbol table }
  242.                             id: idtype;
  243.                             val: integer;
  244.                           end;
  245.   src,targ: text;                       { source and target files }
  246.   errn,pass: byte;                      { error #, pass # }
  247.   atstart,ok: boolean;
  248.   t: string[132];                       { target line }
  249.   loc: integer;          { location counter }
  250.   tcnt: integer;         { number of entries in symbol table }
  251.   n: integer;            { index into symbol table }
  252.   oldlen: integer;
  253.   firstentry: cptr;      { points to first line of intermediate code }
  254.   codpnt: cptr;          { points to current line of intermediate code }
  255.  
  256.   op: opcode;
  257.   op1,op2: attr;
  258.   repx: opcode;
  259.   lockx: boolean;
  260.   override: regs;
  261.  
  262.  
  263. procedure error(j: integer);    { only the first error in a line is recorded }
  264.  
  265. begin
  266.   if errn = 0 then errn := j;
  267. end;
  268.  
  269. procedure message;         { print error messages }
  270.  
  271. begin
  272.   if errn <> 0
  273.   then begin
  274.     ok := false;
  275.     t := t + '***';
  276.     case errn of
  277.      1: t := t + 'NOT ENOUGH OPERANDS';
  278.      2: t := t + 'INVALID OPERAND';
  279.      3: t := t + 'TYPE CONFLICT';
  280.      4: t := t + 'INVALID OPCODE';
  281.      5: t := t + 'INVALID REGISTER';
  282.      6: t := t + 'SYNTAX ERROR';
  283.      7: t := t + 'TYPE NOT SPECIFIED';
  284.      8: t := t + 'ILLEGAL REGISTER';
  285.      9: t := t + 'ERROR IN CONSTANT';
  286.     10: t := t + 'ILLEGAL OPERAND';
  287.     11: t := t + 'TOO MANY OPERANDS';
  288.     12: t := t + 'CONSTANT TOO BIG';
  289.     13: t := t + 'DUPLICATE PREFIX';
  290.     14: t := t + 'IDENTIFIER TOO LONG';
  291.     15: t := t + 'DUPLICATE LABEL';
  292.     16: t := t + 'UNDEFINED LABEL';
  293.     17: t := t + 'LABEL TOO FAR';
  294.     18: t := t + 'NOT IMPLEMENTED';
  295.   { 29: system error }
  296.  
  297.     else t := t + 'SYSTEM ERROR';
  298.     end;
  299.     t := t + '***'
  300.   end
  301. end;
  302.  
  303. function stupcase(st: idtype): idtype;
  304.  
  305. var i: integer;
  306.  
  307. begin
  308.   for i := 1 to length(st) do
  309.     st[i] := upcase(st[i]);
  310.   stupcase := st
  311. end;  { stupcase }
  312.  
  313. procedure startup;       { input names of source and target files }
  314.  
  315. var
  316.   exists: boolean;
  317.   inf,outf,tempstr: filename;
  318.   commandline: string[127] absolute cseg:$80;
  319.   params: string[127];
  320.   default: byte;
  321.  
  322.   procedure chkinf;             { does source file exist? }
  323.   begin
  324.     inf := stupcase(inf);
  325.     if pos('.',inf) = 0
  326.     then inf := inf + '.ASM';
  327.     assign(src,inf);
  328.     {$I-} reset(src) {$I+} ;            { if so, open it }
  329.     exists := (ioresult = 0);
  330.     if pos(':',inf) = 0
  331.     then inf := chr(default+65) + ':' + inf;
  332.     if not exists
  333.     then writeln('File ', inf, ' not found');
  334.   end;
  335.  
  336.   procedure chkoutf;               { is target filename valid? }
  337.   begin
  338.     outf := stupcase(outf);
  339.     assign(targ,outf);
  340.     {$I-} rewrite(targ) {$I+} ;         { if so, open it }
  341.     exists := (ioresult = 0);
  342.     if pos(':',outf) = 0
  343.     then outf := chr(default+65) + ':' + outf;
  344.     if not exists
  345.     then writeln('can''t open file ',outf);
  346.   end;
  347.  
  348. begin
  349.   inf := ''; outf := ''; params := commandline;
  350.   Inline(
  351.      $B4/$19                    { MOV AH,=$19 }
  352.     /$CD/$21                    { INT =$21    }
  353.     /$88/$86/default );         { MOV [BP]default,AL }
  354.   while (params <> '') and (params[1] = ' ') do
  355.     delete(params,1,1);
  356.   if params <> ''
  357.   then begin                                       { command line parameters }
  358.     while (params <> '') and (params[1] <> ' ') do begin
  359.       inf := inf + params[1];
  360.       delete(params,1,1); end;
  361.     chkinf;
  362.     if not exists then begin
  363.       commandline := '';
  364.       startup; end
  365.     else begin
  366.       writeln('Source file: ',inf);
  367.       while (params <> '') and (params[1] = ' ') do
  368.         delete(params,1,1);
  369.       if params <> ''
  370.       then while (params <> '') and (params[1] <> ' ') do begin
  371.         outf := outf + params[1];
  372.         delete(params,1,1); end
  373.       else outf := copy(inf,1,pos('.',inf)) + 'PAS';
  374.       chkoutf;
  375.       if not exists then begin
  376.         commandline := '';
  377.         startup; end
  378.       else writeln('Target file: ',outf);
  379.       end;
  380.     end
  381.   else begin                                        { prompt for filenames }
  382.     repeat
  383.       write('  Source file [.ASM] ? '); readln(inf);
  384.       chkinf;
  385.     until exists;
  386.     tempstr := copy(inf,1,pos('.',inf)) + 'PAS';
  387.     repeat
  388.       repeat
  389.         write('  Target file [',tempstr,'] ? ');
  390.         readln(outf); outf := stupcase(outf);
  391.       until inf <> outf;
  392.       if outf = '' then outf := tempstr;
  393.       chkoutf;
  394.     until exists;
  395.     end;
  396.   writeln;
  397. end;  { startup }
  398.  
  399. procedure init;               { initialize tables }
  400.  
  401. begin
  402.   mn[mov ] := 'MOV' ;   mn[push] := 'PUSH';   mn[pop ] := 'POP' ;
  403.   mn[xchg] := 'XCHG';   mn[in_ ] := 'IN'  ;   mn[out ] := 'OUT' ;
  404.   mn[xlat] := 'XLAT';   mn[lea ] := 'LEA' ;   mn[lds ] := 'LDS' ;
  405.   mn[les ] := 'LES' ;   mn[lahf] := 'LAHF';   mn[pushf] := 'PUSHF';
  406.   mn[sahf] := 'SAHF';   mn[popf] := 'POPF';   mn[add ] := 'ADD' ;
  407.   mn[adc ] := 'ADC' ;   mn[inc ] := 'INC' ;   mn[sub ] := 'SUB' ;
  408.   mn[sbb ] := 'SBB' ;   mn[dec ] := 'DEC' ;   mn[cmp ] := 'CMP' ;
  409.   mn[aas ] := 'AAS' ;   mn[das ] := 'DAS' ;   mn[mul ] := 'MUL' ;
  410.   mn[imul] := 'IMUL';   mn[aam ] := 'AAM' ;   mn[div_] := 'DIV' ;
  411.   mn[idiv] := 'IDIV';   mn[aad ] := 'AAD' ;   mn[cbw ] := 'CBW' ;
  412.   mn[cwd ] := 'CWD' ;   mn[aaa ] := 'AAA' ;   mn[daa ] := 'DAA' ;
  413.   mn[not_] := 'NOT' ;   mn[shl_] := 'SHL' ;   mn[sal ] := 'SAL' ;
  414.   mn[shr_] := 'SHR' ;   mn[sar ] := 'SAR' ;   mn[rol ] := 'ROL' ;
  415.   mn[ror ] := 'ROR' ;   mn[rcl ] := 'RCL' ;   mn[rcr ] := 'RCR' ;
  416.   mn[and_] := 'AND' ;   mn[or_ ] := 'OR'  ;   mn[test_] := 'TEST';
  417.   mn[xor_] := 'XOR' ;   mn[rep ] := 'REP' ;   mn[repne] := 'REPNE';
  418.   mn[repe] := 'REPE';   mn[repz] := 'REPZ';   mn[repnz] := 'REPNZ';
  419.   mn[movs] := 'MOVS';   mn[neg ] := 'NEG' ;   mn[nop ] := 'NOP' ;
  420.   mn[cmps] := 'CMPS';   mn[scas] := 'SCAS';   mn[lods] := 'LODS';
  421.   mn[stos] := 'STOS';   mn[call] := 'CALL';   mn[jmp ] := 'JMP' ;
  422.   mn[ret ] := 'RET' ;   mn[je  ] := 'JE'  ;   mn[jz  ] := 'JZ'  ;
  423.   mn[jl  ] := 'JL'  ;   mn[jnge] := 'JNGE';   mn[jle ] := 'JLE' ;
  424.   mn[jng ] := 'JNG' ;   mn[jb  ] := 'JB'  ;   mn[jnae] := 'JNAE';
  425.   mn[jbe ] := 'JBE' ;   mn[jna ] := 'JNA' ;   mn[jp  ] := 'JP'  ;
  426.   mn[jpe ] := 'JPE' ;   mn[jo  ] := 'JO'  ;   mn[js  ] := 'JS'  ;
  427.   mn[jne ] := 'JNE' ;   mn[jnz ] := 'JNZ' ;   mn[jnl ] := 'JNL' ;
  428.   mn[jge ] := 'JGE' ;   mn[jnle] := 'JNLE';   mn[jg  ] := 'JG'  ;
  429.   mn[jnb ] := 'JNB' ;   mn[jae ] := 'JAE' ;   mn[jnbe] := 'JNBE';
  430.   mn[ja  ] := 'JA'  ;   mn[jnp ] := 'JNP' ;   mn[jpo ] := 'JPO' ;
  431.   mn[jno ] := 'JNO' ;   mn[jns ] := 'JNS' ;   mn[loopz ] := 'LOOPZ' ;
  432.   mn[loop] := 'LOOP';   mn[jcxz] := 'JCXZ';   mn[loopnz] := 'LOOPNZ';
  433.   mn[int ] := 'INT' ;   mn[into] := 'INTO';   mn[loope ] := 'LOOPE' ;
  434.   mn[iret] := 'IRET';   mn[clc ] := 'CLC' ;   mn[loopne] := 'LOOPNE';
  435.   mn[cmc ] := 'CMC' ;   mn[stc ] := 'STC' ;   mn[cld ] := 'CLD' ;
  436.   mn[std ] := 'STD' ;   mn[cli ] := 'CLI' ;   mn[sti ] := 'STI' ;
  437.   mn[hlt ] := 'HLT' ;   mn[wait] := 'WAIT';   mn[esc ] := 'ESC' ;
  438.   mn[lock] := 'LOCK';
  439.   mn[valid] := '';
  440.   mn[db  ] := 'DB'  ;   mn[assume ] := 'ASSUME' ;
  441.   mn[dd  ] := 'DD'  ;   mn[comment] := 'COMMENT';
  442.   mn[dq  ] := 'DQ'  ;   mn[extrn  ] := 'EXTRN'  ;
  443.   mn[dt  ] := 'DT'  ;   mn[group  ] := 'GROUP'  ;
  444.   mn[dw  ] := 'DW'  ;   mn[include] := 'INCLUDE';
  445.   mn[end_] := 'END' ;   mn[label_ ] := 'LABEL'  ;
  446.   mn[equ ] := 'EQU' ;   mn[public ] := 'PUBLIC' ;
  447.   mn[even] := 'EVEN';   mn[record_] := 'RECORD' ;
  448.   mn[name] := 'NAME';   mn[segment] := 'SEGMENT';
  449.   mn[org ] := 'ORG' ;   mn[struc  ] := 'STRUC'  ;
  450.   mn[proc] := 'PROC';   mn[macro  ] := 'MACRO'  ;
  451.   mn[endm] := 'ENDM';   mn[subttl ] := 'SUBTTL' ;
  452.   mn[page] := 'PAGE';   mn[title  ] := 'TITLE'  ;
  453.   mn[fld   ] := 'FLD'   ;  mn[fst   ] := 'FST'   ;  mn[fstp  ] := 'FSTP'  ;
  454.   mn[fxch  ] := 'FXCH'  ;  mn[fcom  ] := 'FCOM'  ;  mn[fcomp ] := 'FCOMP' ;
  455.   mn[fcompp] := 'FCOMPP';  mn[ftst  ] := 'FTST'  ;  mn[fxam  ] := 'FXAM'  ;
  456.   mn[fadd  ] := 'FADD'  ;  mn[fsub  ] := 'FSUB'  ;  mn[fmul  ] := 'FMUL'  ;
  457.   mn[fdiv  ] := 'FDIV'  ;  mn[fsqrt ] := 'FSQRT' ;  mn[fscale] := 'FSCALE';
  458.   mn[fprem ] := 'FPREM' ;  mn[fabs  ] := 'FABS'  ;  mn[frndint] := 'FRNDINT';
  459.   mn[fchs  ] := 'FCHS'  ;  mn[fptan ] := 'FPTAN' ;  mn[fxtract] := 'FXTRACT';
  460.   mn[fpatan] := 'FPATAN';  mn[f2xm1 ] := 'F2XM1' ;  mn[fyl2x ] := 'FYL2X' ;
  461.   mn[fldz  ] := 'FLDZ'  ;  mn[fld1  ] := 'FLD1'  ;  mn[fyl2xp1] := 'FYL2XP1';
  462.   mn[fldpi ] := 'FLDPI' ;  mn[fldl2t] := 'FLDL2T';  mn[fldl2e] := 'FLDL2E';
  463.   mn[fldlg2] := 'FLDLG2';  mn[fldln2] := 'FLDLN2';  mn[finit ] := 'FINIT' ;
  464.   mn[feni  ] := 'FENI'  ;  mn[fdisi ] := 'FDISI' ;  mn[fldcw ] := 'FLDCW' ;
  465.   mn[fstcw ] := 'FSTCW' ;  mn[fstsw ] := 'FSTSW' ;  mn[fclex ] := 'FCLEX' ;
  466.   mn[fstenv] := 'FSTENV';  mn[fldenv] := 'FLDENV';  mn[fsave ] := 'FSAVE' ;
  467.   mn[frstor] := 'FRSTOR';  mn[ffree ] := 'FFREE' ;  mn[fincstp] := 'FINCSTP';
  468.   mn[fnop  ] := 'FNOP'  ;  mn[fwait ] := 'FWAIT' ;  mn[fdecstp] := 'FDECSTP';
  469.  
  470.   reg[ax] := 'AX';  reg[bx] := 'BX';  reg[cx] := 'CX';  reg[dx] := 'DX';
  471.   reg[sp] := 'SP';  reg[bp] := 'BP';  reg[si] := 'SI';  reg[di] := 'DI';
  472.   reg[al] := 'AL';  reg[bl] := 'BL';  reg[cl] := 'CL';  reg[dl] := 'DL';
  473.   reg[ah] := 'AH';  reg[bh] := 'BH';  reg[ch] := 'CH';  reg[dh] := 'DH';
  474.   reg[ds] := 'DS';  reg[ss] := 'SS';  reg[cs] := 'CS';  reg[es] := 'ES';
  475.   rn[ax] := 0;      rn[bx] := 3;      rn[cx] := 1;      rn[dx] := 2;
  476.   rn[sp] := 4;      rn[bp] := 5;      rn[si] := 6;      rn[di] := 7;
  477.   rn[al] := 0;      rn[bl] := 3;      rn[cl] := 1;      rn[dl] := 2;
  478.   rn[ah] := 4;      rn[bh] := 7;      rn[ch] := 5;      rn[dh] := 6;
  479.   rn[ds] := 3;      rn[ss] := 2;      rn[cs] := 1;      rn[es] := 0;
  480. end;   { init }
  481.  
  482. function search(symbol: idtype): boolean;     { search symbol table }
  483. begin                                         { return index in global n }
  484.   n := 0;
  485.   symbol := stupcase(symbol);
  486.   while (tab[n].id <> symbol) and (n <= tcnt) do n := n+1;
  487.   if n = tcnt+1
  488.   then search := false
  489.   else search := true;
  490. end;
  491.  
  492. procedure generate;                   { pass 2 -- maintain location counter }
  493.                                       { pass 3 -- generate object code }
  494. var
  495.   q0,w,md,rm: byte;
  496.   q1: integer;
  497.  
  498.   procedure oneop;         { test for exactly one operand }
  499.   begin
  500.       if op2.isop then error(11);
  501.       if not op1.isop then error(1);
  502.   end;
  503.  
  504.   procedure emit(q:byte);             { emit one byte }
  505.     function hex(d:byte): char;
  506.     begin
  507.       if d <= 9
  508.       then hex := chr(48+d)
  509.       else hex := chr(55+d);
  510.     end;
  511.   begin
  512.     loc := loc+1;
  513.     if (pass=3) and (errn = 0) then begin
  514.       if atstart then t := t+' ' else t := t+'/';
  515.       atstart := false;
  516.       t := t+'$'+hex(q shr 4)+hex(q and 15);
  517.     end;
  518.   end;
  519.  
  520.   procedure emit2(q:integer);         { emit two bytes }
  521.   begin
  522.     begin
  523.       emit(q and $ff);
  524.       emit(q shr 8);
  525.     end
  526.   end;
  527.  
  528.   procedure emitid(ident: idtype);    { emit identifier }
  529.   begin
  530.     loc := loc+2;
  531.     if (pass=3) and (errn = 0) then t := t+'/'+ident;
  532.   end;
  533.  
  534.   procedure emitimm(op:attr);         { emit immediate value }
  535.   begin
  536.   with op do
  537.     if isid then emitid(ident)
  538.     else if isconst then if (w=1) then emit2(value) else emit(value)
  539.     else error(10);
  540.   end;
  541.  
  542.   procedure checktype(op1,op2:attr);  { check compatibility of operands }
  543.   begin
  544.     if (op1.isword and not op2.isbyte) or (op2.isword and not op1.isbyte)
  545.     then w := 1
  546.     else if (op1.isbyte and not op2.isword) or (op2.isbyte and not op1.isword)
  547.          then w := 0
  548.     else if not (op1.isbyte or op1.isword or op2.isbyte or op2.isword)
  549.          then error(7)
  550.     else error(3);
  551.     if op1.issreg or op2.issreg then w := 0;
  552.   end;
  553.  
  554.   procedure modrm(q:byte; op:attr);       { construct the modregr/m byte }
  555.   begin
  556.   with op do begin
  557.     if isid then md := 2
  558.     else if isconst
  559.       then if (value <= 127) and (value >= -128) then md := 1 else md := 2
  560.     else md := 0;
  561.  
  562.     if isidx and isbase
  563.     then begin
  564.       if base = bx then rm := 0 else rm := 2;
  565.       if idx = di then rm := rm+1;
  566.       end
  567.     else if not isidx and not isbase
  568.     then begin
  569.       md := 0; rm := 6; end
  570.     else begin
  571.       rm := 4;
  572.       if isidx and (idx = di) then rm := rm+1;
  573.       if isbase
  574.       then if base = bp then rm := rm+2 else rm := rm+3;
  575.       end;
  576.       emit((md shl 6)+(q shl 3)+rm);
  577.       if isid then emitid(ident);
  578.       if isconst then begin
  579.         if (value <= 127) and (value >= -128) then begin
  580.           emit(value);
  581.           if (md=0) and (rm=6) then if value<0 then emit($ff) else emit(0);
  582.           end
  583.         else emit2(value);
  584.         end;
  585.   end; end;
  586.  
  587.   procedure regtoreg(q:byte; op1,op2:attr);
  588.   begin
  589.     checktype(op1,op2);
  590.     emit(q+w);
  591.     emit(192 + (rn[op1.rg] shl 3) + rn[op2.rg]);
  592.   end;
  593.  
  594.   procedure imtoacc(q:byte; op1,op2:attr);
  595.   begin
  596.     checktype(op1,op2);
  597.     emit(q+w);
  598.     emitimm(op2);
  599.   end;
  600.  
  601.   procedure imtoreg(q:byte; op1,op2:attr);
  602.   begin
  603.     if op1.isword and op2.isbyte then w := 1 else checktype(op1,op2);
  604.     emit(q+(w shl 3)+rn[op1.rg]);
  605.     emitimm(op2);
  606.   end;
  607.  
  608.   procedure onerm(q:byte; op:attr);
  609.   begin
  610.   with op do begin
  611.     if isreg
  612.     then emit(192+(q shl 3)+rn[rg])
  613.     else if isaddr then modrm(q,op)
  614.     else error(10);
  615.   end;
  616.   end;
  617.  
  618.   procedure imtorm(q,r:byte; op1,op2:attr; ext:boolean);
  619.   begin
  620.     if op1.isbyte and op2.isword then error(3)
  621.     else if op1.isbyte and op2.isbyte then w := 0
  622.     else if op1.isword and op2.isword then w := 1
  623.     else if op1.isword and op2.isbyte then if ext then w := 3 else w := 1
  624.     else if op1.isaddr and op2.isbyte then w := 0
  625.     else if op1.isaddr and op2.isword then w := 1
  626.     else error(29);
  627.     emit(q+w);
  628.     onerm(r,op1);
  629.     emitimm(op2);
  630.   end;
  631.  
  632.   procedure regmem(q: byte; op1,op2: attr);
  633.   begin
  634.     checktype(op1,op2);
  635.     emit(q+w);
  636.     modrm(rn[op1.rg],op2);
  637.   end;
  638.  
  639.   procedure inout(q:byte; op1,op2:attr);
  640.   begin
  641.     if not (op1.isreg and (op1.rg in [ax,al])) then error(10);
  642.     if op1.rg=ax then w := 1 else w := 0;
  643.     if op2.isconst then begin
  644.       if op2.isidx or op2.isbase then error(10);
  645.       if (op2.value < 0) or (op2.value > 255) then error(12);
  646.       emit(q+w);
  647.       emit(op2.value);
  648.       end
  649.     else if op2.isreg and (op2.rg=dx) then emit(q+8+w)
  650.     else error(10);
  651.   end;
  652.  
  653. begin   { generate }
  654.   t := ''; errn := codpnt^.errn;
  655.   op1 := codpnt^.op1; op2 := codpnt^.op2;
  656.   with codpnt^ do begin
  657.   if errn=0 then begin
  658.     if repx in [rep,repne,repnz] then emit($f2);
  659.     if repx in [repe,repz] then emit($f3);
  660.     if lockx then emit($f0);
  661.     if override in [ds,cs,ss,es] then emit($26+(rn[override] shl 3));
  662.  
  663.     case op of
  664.  
  665.    nul: ;
  666.  
  667.    mov: begin
  668.       w := 1;
  669.       if not (op1.isop and op2.isop)
  670.       then error(1)
  671.       else if op1.issreg then begin
  672.           if op1.rg=cs then error(10);
  673.           q0 := $8e;
  674.           if op2.isreg then regtoreg(q0,op1,op2)
  675.           else if op2.isaddr then regmem(q0,op1,op2)
  676.           else error(10);
  677.         end
  678.       else if op2.issreg then begin
  679.           q0 := $8c;
  680.           if op1.isreg then regtoreg(q0,op2,op1)
  681.           else if op1.isaddr then regmem(q0,op2,op1)
  682.           else error(10);
  683.         end
  684.       else if op2.isimmed then begin
  685.           if op1.isreg
  686.           then imtoreg($b0,op1,op2)
  687.           else imtorm($c6,0,op1,op2,false);
  688.         end
  689.       else if op1.isreg and (op1.rg in [ax,al]) and op2.isaddr
  690.               and not op2.isbase and not op2.isidx then begin
  691.           if op1.rg = ax then emit($a1) else emit($a0);
  692.           emitimm(op2);
  693.         end
  694.       else if op2.isreg and (op2.rg in [ax,al]) and op1.isaddr
  695.               and not op1.isbase and not op1.isidx then begin
  696.           if op2.rg = ax then emit($a3) else emit($a2);
  697.           emitimm(op1);
  698.         end
  699.       else if op1.isreg and op2.isreg then begin
  700.           q0 := $8a;
  701.           regtoreg(q0,op1,op2); end
  702.       else if (op1.isreg and op2.isaddr) or (op1.isaddr and op2.isreg)
  703.         then begin
  704.           q0 := $88;
  705.           if op1.isaddr
  706.           then regmem(q0,op2,op1)
  707.           else begin
  708.             q0 := q0+2;
  709.             regmem(q0,op1,op2)
  710.             end
  711.         end
  712.       else error(10);
  713.     end;
  714.  
  715.    add,adc,sub,sbb,cmp,and_,or_,xor_,test_:
  716.     begin
  717.       if not (op1.isop and op2.isop)
  718.       then error(1)
  719.       else
  720.       if op2.isimmed
  721.       then if op1.isreg and ((op1.rg=ax) or (op1.rg=al))
  722.            then begin
  723.              if op1.isword then op2.isbyte := false;
  724.              case op of
  725.             add: q0 := $04;
  726.             adc: q0 := $14;
  727.             sub: q0 := $2c;
  728.             sbb: q0 := $1c;
  729.             cmp: q0 := $3c;
  730.             and_: q0 := $24;
  731.             or_ : q0 := $0c;
  732.             xor_: q0 := $34;
  733.             test_: q0 := $a8;
  734.              end;
  735.              imtoacc(q0,op1,op2);
  736.            end
  737.            else begin
  738.              q0 := $80;
  739.              case op of
  740.             add: q1 := 0;
  741.             adc: q1 := 2;
  742.             sub: q1 := 5;
  743.             sbb: q1 := 3;
  744.             cmp: q1 := 7;
  745.             and_: q1 := 4;
  746.             or_ : q1 := 1;
  747.             xor_: q1 := 6;
  748.             test_: begin q0 := $f6; q1 := 0; end;
  749.              end;
  750.              if op in [add,adc,sub,sbb,cmp]
  751.              then imtorm(q0,q1,op1,op2,true)
  752.              else imtorm(q0,q1,op1,op2,false);
  753.            end
  754.  
  755.       else if op1.isreg and op2.isreg
  756.            then begin
  757.              case op of
  758.             add: q0 := $02;
  759.             adc: q0 := $12;
  760.             sub: q0 := $2a;
  761.             sbb: q0 := $1a;
  762.             cmp: q0 := $3a;
  763.             and_: q0 := $22;
  764.             or_ : q0 := $0a;
  765.             xor_: q0 := $32;
  766.             test_: q0 := $84;
  767.              end;
  768.              regtoreg(q0,op1,op2);
  769.            end
  770.       else if (op1.isaddr and op2.isreg) or (op1.isreg and op2.isaddr)
  771.            then begin
  772.              case op of
  773.             add: q0 := $00;
  774.             adc: q0 := $10;
  775.             sub: q0 := $28;
  776.             sbb: q0 := $18;
  777.             cmp: q0 := $38;
  778.             and_: q0 := $20;
  779.             or_ : q0 := $08;
  780.             xor_: q0 := $30;
  781.             test_: q0 := $84;
  782.              end;
  783.              if op1.isaddr
  784.              then regmem(q0,op2,op1)
  785.              else begin
  786.                if op<>test_ then q0 := q0+2;
  787.                regmem(q0,op1,op2)
  788.                end
  789.            end
  790.       else error(10);
  791.     end;
  792.  
  793.    push,pop:
  794.     begin
  795.     with op1 do begin
  796.       oneop;
  797.       if issreg then begin
  798.         if (op=pop) and (rg=cs) then error(10);
  799.         case op of
  800.        push: q0 := $06;
  801.        pop:  q0 := $07;
  802.         end;
  803.         emit(q0+(rn[rg] shl 3));
  804.         end
  805.       else if isreg then begin
  806.         if not isword then error(3);
  807.         case op of
  808.        push: q0 := $50;
  809.        pop:  q0 := $58;
  810.         end;
  811.         emit(q0+rn[rg]);
  812.         end
  813.       else if isaddr then begin
  814.         if isbyte then error(3);
  815.         case op of
  816.        push: begin q0 := $ff; q1 := 6; end;
  817.        pop:  begin q0 := $8f; q1 := 0; end;
  818.         end;
  819.         emit(q0);
  820.         onerm(q1,op1);
  821.         end
  822.       else error(10);
  823.     end;
  824.     end;
  825.  
  826.    inc,dec:
  827.     begin
  828.     with op1 do begin
  829.       oneop;
  830.       if isreg and isword then begin
  831.         case op of
  832.        inc: q0 := $40;
  833.        dec: q0 := $48;
  834.         end;
  835.         emit(q0+rn[rg]);
  836.         end
  837.       else if isaddr or isreg then begin
  838.         if isbyte then w := 0
  839.         else if isword then w := 1
  840.         else error(7);
  841.         case op of
  842.        inc: q1 := 0;
  843.        dec: q1 := 1;
  844.         end;
  845.         emit($fe+w);
  846.         onerm(q1,op1);
  847.         end
  848.       else error(10);
  849.     end;
  850.     end;
  851.  
  852.    xchg:
  853.     begin
  854.       if not op2.isop then error(1);
  855.       if op1.isreg and op2.isreg and ((op1.rg=ax) or (op2.rg=ax))
  856.       then begin
  857.         if op1.rg<>ax
  858.         then emit($90+rn[op1.rg])
  859.         else emit($90+rn[op2.rg]);
  860.         end
  861.       else if op1.isreg and op2.isreg
  862.       then regtoreg($86,op1,op2)
  863.       else if op1.isreg and op2.isaddr
  864.       then regmem($86,op1,op2)
  865.       else if op1.isaddr and op2.isreg
  866.       then regmem($86,op2,op1)
  867.       else error(10);
  868.     end;
  869.  
  870.    mul,imul,div_,idiv,neg,not_:
  871.     begin
  872.       oneop;
  873.       if op1.isbyte then q0 := $f6
  874.       else if op1.isword then q0 := $f7
  875.       else error(7);
  876.       case op of
  877.      mul:  q1 := 4;
  878.      imul: q1 := 5;
  879.      div_:  q1 := 6;
  880.      idiv: q1 := 7;
  881.      neg:  q1 := 3;
  882.      not_:  q1 := 2;
  883.       end;
  884.       emit(q0);
  885.       onerm(q1,op1);
  886.     end;
  887.  
  888.    in_: inout($e4,op1,op2);
  889.    out: inout($e6,op2,op1);
  890.  
  891.    lea,lds,les:
  892.     begin
  893.       if not op2.isop then error(1);
  894.       if not(op1.isreg and op1.isword and op2.isaddr) then error(10);
  895.       case op of
  896.      lea: q0 := $8d;
  897.      lds: q0 := $c5;
  898.      les: q0 := $c4;
  899.       end;
  900.       emit(q0);
  901.       onerm(rn[op1.rg],op2);
  902.     end;
  903.  
  904.    shl_,sal,shr_,sar,rol,ror,rcl,rcr:
  905.     begin
  906.     with op2 do begin
  907.       if not isop then error(1);
  908.       if isidx or isbase then error(10);
  909.       if isconst and (value=1) then q0 := $d0
  910.       else if isreg and (rg=cl) then q0 := $d2
  911.       else error(10);
  912.       case op of
  913.      shl_,sal: q1 := 4;
  914.      shr_: q1 := 5;
  915.      sar: q1 := 7;
  916.      rol: q1 := 0;
  917.      ror: q1 := 1;
  918.      rcl: q1 := 2;
  919.      rcr: q1 := 3;
  920.       end;
  921.       if op1.isword
  922.       then q0 := q0+1
  923.       else if not op1.isbyte then error(7);
  924.       if not(op1.isreg or op1.isaddr) then error(10);
  925.       emit(q0);
  926.       onerm(q1,op1);
  927.     end;
  928.     end;
  929.  
  930.    lods,stos,scas:
  931.     begin
  932.     with op1 do begin
  933.       if op2.isop then error(11);
  934.       if not op1.isop then error(7);
  935.       case op of
  936.      lods: q0 := $ac;
  937.      stos: q0 := $aa;
  938.      scas: q0 := $ae;
  939.       end;
  940.       if isword then q0 := q0+1 else if not isbyte then error(7);
  941.       if isbase or isimmed or isreg then error(10);
  942.       if isidx and (((idx=si) and (op in [stos,scas]))
  943.                     or ((idx=di) and (op=lods))) then error(10);
  944.       emit(q0);
  945.     end; end;
  946.  
  947.    movs,cmps:
  948.     begin
  949.       if op2.isop then begin
  950.         checktype(op1,op2);
  951.         if op2.isidx and (((op2.idx=di) and (op=movs))
  952.            or ((op2.idx=si) and (op=cmps))) then error(10);
  953.         if op2.isbase or op2.isimmed or op2.isreg then error(10);
  954.         end
  955.       else if op1.isop then begin
  956.         if op1.isword then w := 1
  957.         else if op1.isbyte then w := 0
  958.         else error(7);
  959.         if op1.isimmed or op1.isreg or op1.isaddr then error(10);
  960.         end
  961.       else error(7);
  962.       if op1.isop then begin
  963.         if op1.isbase or op1.isimmed or op1.isreg then error(10);
  964.         if op1.isidx and (((op1.idx=si) and (op=movs))
  965.            or ((op1.idx=di) and (op=cmps))) then error(10);
  966.         end;
  967.       case op of
  968.      movs: emit($a4+w);
  969.      cmps: emit($a6+w);
  970.       end;
  971.     end;
  972.  
  973.    ret:
  974.     begin
  975.       if op2.isop then error(11);
  976.       if not op1.isop then error(1);
  977.       with op1 do begin
  978.         if isidx or isbase or isreg or isid then error(10);
  979.         if isconst then q0 := $c2 else q0 := $c3;
  980.         if isfar then q0 := q0+8
  981.         else if not isnear
  982.           then if isshort then error(10) else error(7);
  983.         emit(q0);
  984.         if isconst then emit2(value);
  985.       end
  986.     end;
  987.  
  988.    jmp,call:
  989.     begin
  990.     with op1 do begin
  991.       w := 1;
  992.       if op2.isop then begin
  993.         if not (isimmed and op2.isimmed) then error(10);
  994.         if isnear or op2.isnear then error(3);
  995.         case op of
  996.        jmp:  emit($ea);
  997.        call: emit($9a);
  998.         end;
  999.         emitimm(op1);
  1000.         emitimm(op2);
  1001.         end
  1002.       else if not op1.isop then error(1)
  1003.       else if isfar then begin
  1004.         if (not isaddr) or (isid and search(ident)) then error(10);
  1005.         emit($ff);
  1006.         case op of
  1007.        jmp:  onerm(5,op1);
  1008.        call: onerm(3,op1);
  1009.         end;
  1010.         end
  1011.       else if isimmed and isconst then begin
  1012.         if (value<=127) and (value>=-128) and (op=jmp)
  1013.         then begin emit($eb); emit(value); end
  1014.         else begin
  1015.           case op of
  1016.          jmp:  emit($e9);
  1017.          call: emit($e8);
  1018.           end;
  1019.           emitimm(op1); end;
  1020.         end
  1021.       else if isid and search(ident) then begin
  1022.         if isidx or isbase then error(2);
  1023.         q1 := tab[n].val-loc-2;
  1024.         if pass=3 then begin
  1025.           if (op=jmp) and (q1 >= -128) and (q1 <= 127)
  1026.           then begin
  1027.             emit($eb);
  1028.             if isshort then emit(q1)
  1029.             else begin emit(q1); emit($90); end;
  1030.             end
  1031.           else begin
  1032.             case op of
  1033.            jmp:  begin
  1034.               if isshort then error(17);
  1035.               emit($e9); end;
  1036.            call: begin
  1037.               if isshort then error(10);
  1038.               emit($e8); end;
  1039.             end;
  1040.             emit2(q1-1);
  1041.             end;
  1042.           end
  1043.         else begin  {pass2}
  1044.             if (op=jmp) and (isshort or ((tab[n].val > -1) and (q1 > -128)))
  1045.             then begin emit2(0); isshort := true; end
  1046.             else begin emit2(0); emit(0); end;
  1047.           end;
  1048.         end
  1049.       else if (isreg or isaddr) and not (isbyte or isshort) then begin
  1050.         if not (isnear or isreg) then error(7);
  1051.         emit($ff);
  1052.         case op of
  1053.        jmp:  onerm(4,op1);
  1054.        call: onerm(2,op1);
  1055.         end;
  1056.         end
  1057.       else error(10);
  1058.     end;
  1059.     end;
  1060.  
  1061.    je,jz,jl,jnge,jle,jng,jb,jnae,jbe,jna,jp,jpe,jo,js,jne,jnz,jnl,jge,jnle,
  1062.    jg,jnb,jae,jnbe,ja,jnp,jpo,jno,jns,loop,loopz,loope,loopnz,loopne,jcxz:
  1063.     begin
  1064.       oneop;
  1065.       with op1 do begin
  1066.       if (isimmed and isconst)
  1067.       then if not ((value>=-128) and (value<=127)) then error(12) else
  1068.       else if not (isid and not (isidx or isbase)) then error(10);
  1069.       case op of
  1070.      je,jz:   q0 := $74;
  1071.      jl,jnge: q0 := $7c;
  1072.      jle,jng: q0 := $7e;
  1073.      jb,jnae: q0 := $72;
  1074.      jbe,jna: q0 := $76;
  1075.      jp,jpe:  q0 := $7a;
  1076.      jo:      q0 := $70;
  1077.      js:      q0 := $78;
  1078.      jne,jnz: q0 := $75;
  1079.      jnl,jge: q0 := $7d;
  1080.      jnle,jg: q0 := $7f;
  1081.      jnb,jae: q0 := $73;
  1082.      jnbe,ja: q0 := $77;
  1083.      jnp,jpo: q0 := $7b;
  1084.      jno:     q0 := $71;
  1085.      jns:     q0 := $79;
  1086.      loop:          q0 := $e2;
  1087.      loopz,loope:   q0 := $e1;
  1088.      loopnz,loopne: q0 := $e0;
  1089.      jcxz:          q0 := $e3;
  1090.       end;
  1091.       if isconst
  1092.       then begin emit(q0); emit(value); end
  1093.       else begin
  1094.         if (pass=3) and not search(ident) then error(16);
  1095.         q1 := tab[n].val-loc-2;
  1096.         if (pass=3) and ((q1 < -128) or (q1 > 127)) then error(17);
  1097.         emit(q0);
  1098.         emit(q1);
  1099.         end;
  1100.       end;
  1101.     end;
  1102.  
  1103.    int:
  1104.     begin
  1105.     with op1 do begin
  1106.       oneop;
  1107.       if isidx or isbase or not isconst then error(10);
  1108.       if (value < 0) or (value > 255) then error(12);
  1109.       if value=3 then emit($cc)
  1110.       else begin emit($cd); emit(value); end;
  1111.     end;
  1112.     end;
  1113.  
  1114.    esc:
  1115.     begin
  1116.       if not op2.isop then error(1);
  1117.       if not op1.isimmed then error(10);
  1118.       if (op1.value < 0) or (op1.value > 63) then error(10);
  1119.       emit($d8+(op1.value shr 3));
  1120.       onerm((op1.value and 7),op2);
  1121.     end;
  1122.  
  1123.    xlat,lahf,sahf,pushf,popf,aaa,daa,aas,das,cbw,cwd,into,iret,clc,cmc,
  1124.    stc,cld,std,cli,sti,hlt,wait,aam,aad,nop:
  1125.     begin
  1126.       if op1.isop then error(11);
  1127.       case op of
  1128.      xlat: emit($d7);
  1129.      lahf: emit($9f);
  1130.      sahf: emit($9e);
  1131.      pushf:emit($9c);
  1132.      popf: emit($9d);
  1133.      aaa:  emit($37);
  1134.      daa:  emit($27);
  1135.      aas:  emit($3f);
  1136.      das:  emit($2f);
  1137.      cbw:  emit($98);
  1138.      cwd:  emit($99);
  1139.      into: emit($ce);
  1140.      iret: emit($cf);
  1141.      clc:  emit($f8);
  1142.      cmc:  emit($f5);
  1143.      stc:  emit($f9);
  1144.      cld:  emit($fc);
  1145.      std:  emit($fd);
  1146.      cli:  emit($fa);
  1147.      sti:  emit($fb);
  1148.      hlt:  emit($f4);
  1149.      wait: emit($9b);
  1150.      aam:  begin emit($d4); emit($0a); end;
  1151.      aad:  begin emit($d5); emit($0a); end;
  1152.      nop:  emit($90);
  1153.       end;
  1154.     end;
  1155.  
  1156.     else error(29);
  1157.     end; { case op }
  1158.   end; { if errn }
  1159.  
  1160.   if pass=3 then begin                { finish constructing the target line }
  1161.     if codpnt = firstentry
  1162.     then begin
  1163.       writeln(targ,'Inline(');
  1164.       writeln; writeln('Inline('); end;
  1165.     message;
  1166.     if next = nil then  t := t + '  );';
  1167.     while length(t) < 25 do t := t+' ';
  1168.     t := t + '   { ' + source;
  1169.     if length(t) < oldlen-4          { make it look pretty }
  1170.     then begin
  1171.       if length(t) > oldlen-8 then oldlen := oldlen+2;
  1172.       while length(t) < oldlen-4 do t := t+' ';
  1173.       end;
  1174.     t := t+' }';
  1175.     oldlen := length(t);
  1176.     writeln(targ,t); writeln(t);     { and write it to the file }
  1177.     codpnt := next;
  1178.   end;
  1179.  
  1180. end; {with}
  1181. end; { generate }
  1182.  
  1183.  
  1184. procedure address;         { compute address of each label }
  1185.  
  1186. begin
  1187.   if codpnt^.labeln <> 0
  1188.   then tab[codpnt^.labeln].val := loc;
  1189.   generate;                { advance location counter }
  1190.   codpnt^.errn := errn;
  1191.   codpnt := codpnt^.next;
  1192. end;
  1193.  
  1194.  
  1195. procedure parse_line;       { scan source and build intermediate code }
  1196.  
  1197. var
  1198.   s: line;       { source line }
  1199.   p: integer;    { index into s }
  1200.   m: idtype;     { mnemonic opcode }
  1201.   labeln: integer;
  1202.   temp: line;
  1203.   id: idtype;    { identifier }
  1204.   preventry: cptr;    { points to previous line of intermediate code }
  1205.  
  1206. label nocode;
  1207.  
  1208.   function more: boolean;      { any more characters on this line? }
  1209.   begin
  1210.     more := p <= length(s);
  1211.   end;
  1212.  
  1213.   procedure skipblank;
  1214.   begin
  1215.     while more and (s[p] = ' ') do
  1216.     p := p+1;
  1217.   end;
  1218.  
  1219.   function alpha: boolean;
  1220.   begin
  1221.     alpha := more and (s[p] in ['a'..'z','A'..'Z']);
  1222.   end;
  1223.  
  1224.   function digit: boolean;
  1225.   begin
  1226.     digit := more and (s[p] in ['0'..'9']);
  1227.   end;
  1228.  
  1229.   function peek(aset: charset): boolean;   { is next character in aset? }
  1230.   begin
  1231.     if more and (s[p] in aset) then peek := true else peek := false;
  1232.   end;
  1233.  
  1234.   function test(c: char): boolean;       { is the next character c? }
  1235.   begin                                  { if so, scan over it      }
  1236.     if more and (upcase(s[p]) = c)
  1237.     then begin
  1238.       p := p+1; skipblank;
  1239.       test := true
  1240.       end
  1241.     else test := false
  1242.   end;
  1243.  
  1244.   procedure getid;               { found an alpha }
  1245.   begin                          { get rest of identifier }
  1246.     id := '';
  1247.     while alpha or digit or peek(['_']) do begin
  1248.       if length(id) < 20
  1249.       then id := id + s[p]       { return it in id }
  1250.       else error(14);
  1251.       p := p+1;
  1252.     end;
  1253.     skipblank;
  1254.   end;
  1255.  
  1256.   procedure enter(symbol: idtype; var m: integer);
  1257.                                { make entry in symbol table }
  1258.   begin
  1259.     if search(symbol)
  1260.     then error(15)
  1261.     else if tcnt = tsize then begin
  1262.       writeln; writeln('Assembly Aborted -- Symbol Table Full');
  1263.       close(src); close(targ);
  1264.       halt; end
  1265.     else begin
  1266.       tcnt := tcnt+1;
  1267.       tab[tcnt].id := stupcase(symbol);
  1268.       tab[tcnt].val := -1;
  1269.       m := tcnt;
  1270.     end;
  1271.   end;
  1272.  
  1273.   function code: boolean;            { found an id }
  1274.                                      { is it an opcode? }
  1275.   begin
  1276.     op := nul;
  1277.     m := stupcase(id);
  1278.     repeat                           { if so, return it in op }
  1279.       op := succ(op)
  1280.     until (mn[op] = m) or (op = last);
  1281.     if op in [rep,repe,repz,repne,repnz] then begin
  1282.       if repx <> nul then error(13);
  1283.       repx := op;                      { REP prefix }
  1284.       if alpha then begin              { look for another opcode }
  1285.         getid;
  1286.         code := code; end
  1287.       else error(4);
  1288.       end
  1289.     else if op=lock then begin
  1290.       if lockx then error(13);
  1291.       lockx := true;                   { LOCK prefix }
  1292.       if alpha then begin              { look for another opcode }
  1293.         getid;
  1294.         code := code; end
  1295.       else error(4);
  1296.       end
  1297.     else if (op > valid) and (op <> last) then error(18)
  1298.     else if op <> last then begin
  1299.       code := true;
  1300.       if (repx<>nul) and not (op in [movs,cmps,scas,lods,stos]) then error(4);
  1301.       end
  1302.     else begin code := false; op := nul; end;
  1303.   end;  { code }
  1304.  
  1305.   procedure getoperand(var opr: attr);    { scan an operand }
  1306.                                           { determine its attributes }
  1307.   var r: regs;
  1308.  
  1309.   label gotid;
  1310.  
  1311.     procedure makebyte;         { it's a byte }
  1312.     begin
  1313.       if opr.isword then error(3) else opr.isbyte := true;
  1314.     end;
  1315.  
  1316.     procedure makeword;         { it's a word }
  1317.     begin
  1318.       if opr.isbyte then error(3) else opr.isword := true;
  1319.     end;
  1320.  
  1321.     procedure getnum;           { scan a numeric literal }
  1322.  
  1323.     var code: integer;
  1324.         minus: boolean;
  1325.  
  1326.       procedure gethex;           { scan a hexadecimal literal }
  1327.       begin
  1328.         if id = '-' then minus := true;
  1329.         id := '$'; p := p+1;
  1330.         while more and (digit or (upcase(s[p]) in ['A','B','C','D','E','F']))
  1331.         do begin
  1332.           id := id + s[p];        { return it in id }
  1333.           p := p+1;
  1334.         end;
  1335.         if id = '$' then error(2);
  1336.       end;
  1337.  
  1338.     begin
  1339.       id := ''; minus := false;
  1340.       if test('+') then;
  1341.       if test('-') then id := '-';
  1342.       if peek(['$'])
  1343.       then gethex                          { hex }
  1344.       else while digit do begin            { decimal }
  1345.         id := id + s[p];
  1346.         p := p+1;
  1347.       end;
  1348.       if id = '' then error(2);
  1349.       with opr do begin
  1350.         val(id,value,code);              { return value }
  1351.         if code<>0
  1352.         then if id='-32768'
  1353.           then value := $8000
  1354.           else error(9);
  1355.         if minus then value := -value
  1356.       end;
  1357.       if id[1] = '-' then delete(id,1,1);
  1358.       skipblank;
  1359.     end;   { getnum }
  1360.  
  1361.  
  1362.     procedure getchar;          { scan a character literal }
  1363.     begin
  1364.       with opr do begin
  1365.       p := p+1;
  1366.       value := ord(s[p]); p := p+1;
  1367.       if not test('''') then error(2)
  1368.       else begin
  1369.         isconst := true;
  1370.         isimmed := true;
  1371.         if not isword then isbyte := true;
  1372.       end;
  1373.     end; end;
  1374.  
  1375.     function testreg: boolean;        { is id a register name? }
  1376.     begin
  1377.       r := firstreg;
  1378.       temp := stupcase(id);
  1379.       repeat
  1380.         r := succ(r)                  { if so, return register number in r }
  1381.       until (reg[r] = temp) or (r = lastreg);
  1382.       if r <> lastreg then testreg := true else testreg := false;
  1383.     end;
  1384.  
  1385.  
  1386.   begin  {getoperand}
  1387.     with opr do begin
  1388.     isop := true;
  1389.     if not (alpha or digit or peek(['=','$','*','[','+','-','(','''']))
  1390.     then error(2)
  1391.     else begin
  1392.       if alpha then begin
  1393.         getid;
  1394.         if testreg and (r in [ds,cs,ss,es]) and peek([':'])
  1395.         then begin                                { segment override prefix }
  1396.           if test(':') then;
  1397.           if override<>lastreg then error(13);
  1398.           override := r; end
  1399.         else goto gotid;
  1400.         end;
  1401.       if test('(') then begin                     { type modifier }
  1402.         if test('B') then makebyte
  1403.         else if test('W') then makeword
  1404.         else if test('S') then isshort := true
  1405.         else if test('N') then isnear := true
  1406.         else if test('F') then isfar := true
  1407.         else error(6);
  1408.         if not test(')') then error(6);
  1409.         end;
  1410.       if test('=') then isimmed := true;
  1411.       if test('[')
  1412.       then begin                                  { base or index register }
  1413.         if isimmed then error(2);
  1414.         isaddr := true;
  1415.         getid;
  1416.         if testreg
  1417.         then begin
  1418.           if not test(']') then error(6);
  1419.           if r in [bx,bp]
  1420.           then begin                              { base register }
  1421.             isbase := true; isop := true;
  1422.             base := r;
  1423.             if test('[')
  1424.             then begin
  1425.               getid;
  1426.               if testreg
  1427.               then begin
  1428.                 if not test(']') then error(6);
  1429.                 if r in [si,di]
  1430.                 then begin                        { and index register }
  1431.                   isidx := true;
  1432.                   idx := r;
  1433.                   end
  1434.                 else error(8)
  1435.                 end
  1436.               else error(5)
  1437.               end
  1438.             end
  1439.           else if r in [si,di]
  1440.             then begin                            { index register }
  1441.               isidx := true;
  1442.               idx := r;
  1443.             end
  1444.           else error(8);
  1445.           end
  1446.         else error(5)
  1447.         end;
  1448.       if alpha
  1449.       then begin                                  { identifier }
  1450.         getid;
  1451. gotid:  if testreg
  1452.         then begin                                { it's a register }
  1453.           if r in [ds,ss,cs,es]
  1454.           then issreg := true
  1455.           else isreg := true;
  1456.           if r in [ax,bx,cx,dx,sp,bp,si,di,ds,ss,cs,es]
  1457.           then makeword;
  1458.           if r in [ah,bh,ch,dh,al,bl,cl,dl]
  1459.           then makebyte;
  1460.           if isimmed then error(2);
  1461.           rg := r;
  1462.           end
  1463.         else begin                              { it's a variable or label id }
  1464.           isaddr := not isimmed;
  1465.           isid := true;
  1466.           ident := id;
  1467.           if isimmed then makeword;
  1468.           end;
  1469.       end  {alpha}
  1470.       else if digit or peek(['$','+','-'])
  1471.       then begin                                  { numeric literal }
  1472.         getnum;
  1473.         isaddr := not isimmed;
  1474.         isconst := true;
  1475.         if isimmed
  1476.         then if (value <= 255) and (value >= -128) and not isword
  1477.              then makebyte
  1478.              else makeword;
  1479.       end
  1480.       else if test('*')
  1481.       then begin                                { location counter reference }
  1482.         ident := '*';
  1483.         isaddr := not isimmed;
  1484.         isid := true;
  1485.         if isimmed then makeword;
  1486.         if test('+') then ident := '*+';
  1487.         if test('-') then ident := '*-';
  1488.         if ident<>'*' then begin
  1489.           if not peek(['$','0'..'9']) then error(9);
  1490.           getnum;
  1491.           ident := ident + id;
  1492.         end;
  1493.       end
  1494.       else if peek(['''']) then getchar;        { character literal }
  1495.     if isbase and (base=bp) and not isidx and not (isid or isconst)
  1496.     then begin
  1497.       isconst := true; value := 0;
  1498.       ident := '$00';
  1499.       end;
  1500.     end;
  1501.     if isimmed and not (isid or isconst) then error(6);
  1502.     end; {with}
  1503.     skipblank;
  1504.   end;   {getoperand}
  1505.  
  1506.  
  1507. begin    { parse_line }
  1508.   errn := 0; labeln := 0;
  1509.   op := nul; repx := nul; lockx := false; override := lastreg;
  1510.   with op1 do begin
  1511.       isop := false; isaddr := false;
  1512.       isid := false; isreg := false; issreg := false;
  1513.       isidx := false; isbase := false;
  1514.       isbyte := false; isword := false;
  1515.       isshort := false; isnear := false; isfar := false;
  1516.       isimmed := false; isconst := false;
  1517.     end;
  1518.   op2 := op1;
  1519.   readln(src,s);                       { read in a source line }
  1520.   for p := 1 to length(s) do
  1521.     if ord(s[p]) < 32 then s[p] := ' ';
  1522.   p := 1;
  1523.   if more
  1524.   then begin
  1525.     skipblank;
  1526.     if alpha then begin
  1527.       getid;
  1528.       if test(':') then begin                               { label }
  1529.         enter(id,labeln);
  1530.         if alpha
  1531.         then getid
  1532.         else goto nocode;
  1533.         end;
  1534.       if code                                             { opcode }
  1535.       then begin
  1536.         if more and not peek([';'])
  1537.         then begin
  1538.           getoperand(op1);                               { first operand }
  1539.           if test(',')
  1540.           then begin
  1541.             if more
  1542.             then getoperand(op2)                         { second operand }
  1543.             else error(6);
  1544.             if more and not peek([';']) then error(6);
  1545.             end
  1546.           else if more and not peek([';']) then error(6);
  1547.           end
  1548.         end
  1549.         else error(4)
  1550.       end
  1551.     else
  1552. nocode: if more and not peek([';']) then error(6);
  1553.   preventry := codpnt;
  1554.   if maxavail > sizeof(codrec) shr 4 +1
  1555.   then new(codpnt)                    { create new line of intermediate code }
  1556.   else begin
  1557.     writeln; writeln('Assembly Aborted -- Out of Memory');
  1558.     close(src); close(targ); halt; end;
  1559.   if firstentry = nil then firstentry := codpnt;
  1560.   preventry^.next := codpnt;                                { and link it }
  1561.   codpnt^.next := nil;
  1562.   codpnt^.labeln := labeln;
  1563.   codpnt^.op := op;                                { enter the data }
  1564.   codpnt^.op1 := op1;
  1565.   codpnt^.op2 := op2;
  1566.   codpnt^.repx := repx;
  1567.   codpnt^.lockx := lockx;
  1568.   codpnt^.override := override;
  1569.   codpnt^.errn := errn;
  1570.   codpnt^.source := s;
  1571.   end;
  1572. end;  { parse_line }
  1573.  
  1574.  
  1575. begin  { main }
  1576.   writeln('                    InLiner'); writeln;
  1577.   startup;
  1578.   init;
  1579.   atstart := true; ok := true;
  1580.   oldlen := 0; loc := 0; tcnt := 0;
  1581.  
  1582.   pass := 1; firstentry := nil;
  1583.   while not eof(src) do parse_line;
  1584.  
  1585.   pass := 2; codpnt := firstentry; loc := 0;
  1586.   while codpnt <> nil do address;
  1587.  
  1588.   pass := 3; codpnt := firstentry; loc := 0;
  1589.   while codpnt <> nil do generate;
  1590.  
  1591.   writeln;
  1592.   if ok then writeln('Assembly Successful')
  1593.         else writeln('Assembled with Errors');
  1594.   close(src); close(targ);
  1595. end.
  1596.