Simtel MSDOS 1992 December/simtel1292_SIMTEL_1292_Walnut_Creek.iso/msdos/pcmag/vol6n20.arc/INLINE.ARC/INLINE.PAS

Pascal/Delphi Source File | 1987-03-29 | 54KB | 2,008 lines

                             {
Inline22}

(*********  Source code Copyright 1986, by L. David Baldwin   *********)

{Compiling with mAx=2000 will give sufficient heap for most applications
 and prevent overwriting COMMAND.COM in most cases.}

{
22 Vers 2.14 Change output format to better accomodate map file line numbers.
21 Vers 2.13 Allow JMP SHORT direct using symbols.
20 Vers 2.12 Allow CALL and JMP direct using symbols.
19 Vers 2.11
   Fix bug in CallJmp and ShortJmp which didn't restrict short
   jump range properly.
   Fix bug which didn't allow CALL or JMP register. (CALL BX).
18 Vers 2.1
   Fix bug in Accum which occasionally messed up IN and OUT instr.
   Fix unintialized function in getnumber for quoted chars.
17 Vers 2.03
    Change GetSymbol to accept about anything after '>' or '<'
    Add 'NEW' pseudoinstruction.
    Fix serious bug in defaultextension.
    Add Wait_Already to prevent 2 'WAIT's from occuring.
    Use 'tindex<maxbyte' comparison rather than <= which won't work
    with integer comparison in this case.
}
{$v-}
PROGRAM Inline_Asm;

Const
  CommentColumn = 25;     {column where comments start in object file}
  Symbolleng = 32;        {maximum of 32 char symbols}
  CR = 13; Lf = 10; Tab = 9;
  Maxbyte = MaxInt;
  BigStringSize = 127;

  Signon1 : String[32] =

            ^M^J'Inline Assembler, Vers 2.14';

  Signon2 : String[43] =

            ^M^J'(C) Copyright 1986-7 by L. David Baldwin'^M^J;

Type
  FileString = String[64];
  SymString = String[Symbolleng];
  IndxReg = (BX, SI, DI, BP, None);
  IndxSet = set of IndxReg;
  PtrType = (BPtr, WPtr, DwPtr, QwPtr, TbPtr, UnkPtr); {keep order}
  String4 = String[4];
  String5 = Array[1..5] of Char;
  Symtype = (Address, Disp8, Disp16, Othersym, EOLsym, Identifier, JmpDist,
    LfBrack, RtBrack, Plus, Comma, STsym);
  Table = Array[0..20] of SymString; {fake}
  BigString = String[BigStringSize]; {125 chars on a turbo line}
  Label_info_ptr = ^Label_info;
  Label_info = Record
                 Name : SymString;
                 ByteCnt : Integer;
                 Next : Label_info_ptr;
               end;
  Fixup_info_ptr = ^Fixup_info;
  Fixup_info = Record
                 Name : SymString;
                 Indx, Indx2, Fix_pt : Integer;
                 Jmptype : (Short, Med);
                 Prev, Next : Fixup_info_ptr;
               end;

Var
  NoAddrs, Aerr, Symbol, TheEnd, NewFnd, St_first,
  Displace, Word, Bits_7, Wait_Already : Boolean;
  Addr : Integer;
  Sym : Symtype;
  ModeByte, Reg1, Reg2, W1, W2, Sti_val : Integer;
  SaveOfs, DataVal : Record
                       Symb : Boolean;
                       Sname : SymString;
                       Value : Integer;
                     end;
  IRset : IndxSet;
  Rmm, Md : Integer;
  ByWord : PtrType;
  Byt, SignExt : Byte;
  Tindex, Tindex0, Column, I, ByteCount, LastSlash : Integer;
  TextArray : Array[0..Maxbyte] of Char;

  Lsid : SymString;
  Str8 : Array[1..9] of Char; {the following 4 are at the same location}
  Str : String5 Absolute Str8;
  ID2 : Array[1..2] of Char Absolute Str8;
  ID3 : Array[1..3] of Char Absolute Str8;
  UCh, Lch : Char;
  Chi, OldChi : Integer;
  Out, Inn : Text;

  Start_Col : Integer;
  St : BigString;
  Firstlabel, Pl : Label_info_ptr;
  Firstfix, Pf : Fixup_info_ptr;

{
-------------DefaultExtension}
PROCEDURE DefaultExtension(Extension:FileString;Var Infile,Name :FileString);
{Given a filename, infile, add a default extension if none exists. Return
 also the name without any extension.}
Var
 I,J : Integer;
 Temp : FileString;
begin
I:=Pos('..',Infile);
if I=0 then
  Temp:=Infile
else
  begin   {a pathname starting with ..}
  Temp:=Copy(Infile,I+2,64);
  I:=I+1;
  end;
J:=Pos('.',Temp);
if J=0 then
  begin
  Name := Infile;
  Infile:=Infile+'.'+Extension;
  end
else Name:=Copy(Infile,1,I+J-1);
end;

{
-------------Space}
PROCEDURE Space(N : Integer);
Var I : Integer;
begin for I := 1 to N do Write(' '); end;

{
-------------Error}
PROCEDURE Error(II : Integer; S : BigString);
begin
if not Aerr then
  begin
  WriteLn(St);
  Space(Start_Col+II-4);
  Write('^Error');
  if Length(S) > 0 then
    begin Write(', '); Write(S); end;
  WriteLn;
  Aerr := True;
  end;
end;

{the following are definitions and variables for the parser}
Var Segm, NValue : Integer;
Symname : SymString;
{end of parser defs}

{
-------------GetCh}
PROCEDURE GetCh;
  {return next char in uch and lch with uch in upper case.}
begin
if Chi <= Ord(St[0]) then Lch := St[Chi] else Lch := Chr(CR);
UCh := UpCase(Lch);
Chi := Chi+1;
end;

{
-------------SkipSpaces}
PROCEDURE SkipSpaces;
begin
while (UCh = ' ') or (UCh = Chr(Tab)) do GetCh;
end;

{
-------------GetDec}
FUNCTION GetDec(Var V : Integer) : Boolean;
Const Ssize = 8;
Var
  S : String[Ssize];
  Getd : Boolean;
  Code : Integer;
begin
Getd := False;
S := '';
while (UCh >= '0') and (UCh <= '9') do
  begin
  Getd := True;
  if Ord(S[0]) < Ssize then S := S+UCh;
  GetCh;
  end;
if Getd then
  begin
  Val(S, V, Code);
  if Code <> 0 then Error(Chi, 'Bad number format');
  end;
GetDec := Getd;
end;

{
-------------GetHex}
FUNCTION GetHex(Var H : Integer) : Boolean;
Var Digit : Integer;        {check for '$' before the call}
begin
H := 0; GetHex := False;
while (UCh in ['A'..'F', '0'..'9']) do
  begin
  GetHex := True;
  if (UCh >= 'A') then Digit := Ord(UCh)-Ord('A')+10
    else Digit := Ord(UCh)-Ord('0');
  if H and $F000 <>0 then Error(Chi, 'Overflow');
  H := (H Shl 4)+Digit;
  GetCh;
  end;
end;

{
-------------GetNumber}
FUNCTION GetNumber(Var N : Integer) : Boolean;
  {get a number and return it in n}
Var Term : Char;
  Err : Boolean;
begin
N := 0;
if UCh = '(' then GetCh;    {ignore ( }
if (UCh = '''') or (UCh = '"') then
  begin
  GetNumber := True;
  Term := UCh; GetCh; Err := False;
  while (UCh <> Term) and not Err do
    begin
    Err := N and $FF00 <> 0;
    N := (N Shl 8)+Ord(Lch);
    GetCh;
    if Err then Error(Chi, 'Overflow');
    end;
  GetCh;                    {use up termination char}
  end
else if UCh = '$' then
  begin                     {a hex number}
  GetCh;
  if not GetHex(N) then Error(Chi, 'Hex number exp');
  GetNumber := True;
  end
else
  GetNumber := GetDec(N);   {maybe a decimal number}
if UCh = ')' then GetCh;    {ignore an ending parenthesis}
end;

{
-------------GetExpr}
FUNCTION GetExpr(Var Rslt : Integer) : Boolean;
Var
  Rs1, Rs2, SaveChi : Integer;
  Pos, Neg : Boolean;
begin
SaveChi := Chi;
GetExpr := False;
SkipSpaces;
Neg := UCh = '-';
Pos := UCh = '+';
if Pos or Neg then GetCh;
if GetNumber(Rs1) then
  begin
  GetExpr := True;
  if Neg then Rs1 := -Rs1;
  if (UCh = '+') or (UCh = '-') then
    if GetExpr(Rs2) then
      Rs1 := Rs1+Rs2;       {getexpr will take care of sign}
  Rslt := Rs1;
  end
else
  begin
  Chi := SaveChi-1; GetCh;
  end;
end;

{$v+}
{
-------------GetSymbol}
FUNCTION GetSymbol(Var S : SymString) : Boolean;
Const Symchars : set of Char = ['A'..'Z', '0'..'9', '_', '+', '-','$','*'];
begin
if UCh in Symchars then
  begin
  GetSymbol := True;
  S[0] := Chr(0);
  while UCh in Symchars do
    begin
    if Ord(S[0]) < Symbolleng then S := S+UCh;
    GetCh;
    end
  end
else GetSymbol := False;
end;
{$v-}

{
-------------GetAddress}
FUNCTION GetAddress : Boolean;
Var Result : Boolean;
  SaveChi : Integer;
begin
Result := False; SaveChi := Chi;
if GetExpr(Segm) then
  begin
  SkipSpaces;
  if UCh = ':' then
    begin
    GetCh; SkipSpaces;
    Result := GetExpr(NValue);
    end;
  end;
GetAddress := Result;
if not Result then
  begin Chi := SaveChi-1; GetCh; end;
end;

{
-------------ErrNull}
PROCEDURE ErrNull;
begin Error(Chi, ''); end;

{
-------------ErrIncorrect}
PROCEDURE ErrIncorrect;
begin Error(Chi, 'Incorrect or No Operand'); end;

{
-------------SegmErr}
PROCEDURE SegmErr;
begin Error(Chi, 'Segm Reg not Permitted'); end;

{
-------------WordReg}
PROCEDURE WordReg;
begin Error(Chi, 'Word Reg Exp'); end;

{
-------------DataLarge}
PROCEDURE DataLarge;
begin Error(Chi, 'Data Too Large'); end;

{
-------------Chk_BwPtr}
PROCEDURE Chk_BwPtr;
begin
if ByWord >= DwPtr then Error(Chi, 'BYTE or WORD Req''d');
end;

{
-------------ByteSize}
FUNCTION ByteSize(Val : Integer) : Boolean;
  {return true if val is a byte}
begin
ByteSize := (Hi(Val) = 0) or (Val and $FF80 = $FF80);
end;

{
-------------ReadByte}
FUNCTION ReadByte : Boolean;
Var Rb : Boolean;
begin
Rb := GetExpr(NValue);
if Rb then
  if ByteSize(NValue) then
    Byt := Lo(NValue)
  else DataLarge;
ReadByte := Rb;
end;

{
-------------MatchSt}
FUNCTION MatchSt(Var Table; Size, Maxindx : Integer; Var Indx : Integer) :
  Boolean;                  {see if str8 matches any string in a table}
Var Ca : Array[0..MaxInt] of Char Absolute Table;
  Rslt : Boolean;

  FUNCTION EqArray(Var A1; N : Integer) : Boolean;
  Type Bigarray = Array[1..MaxInt] of Char;
  Var
    B1 : Bigarray Absolute A1;
    I : Integer;
  begin
  for I := 1 to N do
    if B1[I] <> Str8[I] then
      begin EqArray := False; Exit; end;
  EqArray := Str8[N+1] = ' '; {must have blank on end for complete match}
end;

begin
Indx := 0; Rslt := False;
while (Indx <= Maxindx) and not Rslt do
  if EqArray(Ca[Indx*Size], Size) then
    Rslt := True
  else
    Indx := Indx+1;
MatchSt := Rslt;
end;

{
-------------GetString}
PROCEDURE GetString;
  {Fill in lsid, str8, str, id2,id3.  They are, in fact, all in the
   same locations}
Var I : Integer;
begin
SkipSpaces;
Lsid := '          ';
I := 1;
if (UCh >= 'A') and (UCh <= 'Z') then
  begin
  while (UCh >= 'A') and (UCh <= 'Z') or (UCh >= '0') and (UCh <= '9') do
    begin
    if I <= Symbolleng then
      begin Lsid[I] := UCh; I := I+1; end;
    GetCh;
    end;
  end;
Lsid[0] := Chr(I-1);
Move(Lsid[1], Str8, 9);     {Fill in str8,str,id2,id3}
end;

{
-------------InsertChr}
PROCEDURE InsertChr(C : Char);
begin
if Tindex < Maxbyte then
  begin
  TextArray[Tindex] := C;
  Tindex := Tindex+1; Column := Column+1;
  end
else
  begin
  WriteLn('Object Code Overflow!');
  Halt(1);
  end;
end;

{
-------------InsertStr}
PROCEDURE InsertStr(S : BigString);
Var I : Integer;
begin
for I := 1 to Ord(S[0]) do InsertChr(S[I]);
end;

{
-------------Hex2}
FUNCTION Hex2(B : Byte) : String4;
Const HexDigs : Array[0..15] of Char = '0123456789ABCDEF';
Var Bz : Byte;
begin
Bz := B and $F; B := B Shr 4;
Hex2 := HexDigs[B]+HexDigs[Bz];
end;

{
-------------Hex4}
FUNCTION Hex4(W : Integer) : String4;
begin Hex4 := Hex2(Lo(W))+Hex2(Hi(W)); end;

{
-------------InsertByte}
PROCEDURE InsertByte(B : Byte);
begin
InsertStr('$'+Hex2(B));
ByteCount := ByteCount+1;
LastSlash:=Tindex;
InsertChr('/');
Wait_Already:=False;  {any byte inserted cancels a WAIT}
end;

{
-------------InsertWord}
PROCEDURE InsertWord(W : Integer);
begin
InsertByte(Lo(W)); InsertByte(Hi(W));
end;

{
-------------InsertHi_Low}
PROCEDURE InsertHi_Low(W : Integer);
  {insert a word in reverse order}
begin
InsertByte(Hi(W)); InsertByte(Lo(W));
end;

{
-------------InsertWait}
PROCEDURE InsertWait;
begin  {Insert a 'WAIT' for Fl Pt only if none already input}
if not Wait_Already then InsertByte($9B);
end;

{
-------------Modify_Byte}
PROCEDURE Modify_Byte(I : Integer; Modify : Byte);
  {Modify an ascii byte string in textarray by adding modify to its value}
Var
  St : String4;
  J : Integer;

  FUNCTION HexToByte(I : Integer; Var J : Integer) : Byte;
    {Starting at tindex, i, convert hex to a byte. return j, the tindex where
     byte started}
  Var
    Result, Tmp : Byte;
    K : Integer;
    C : Char;
  Const Hex : set of Char = ['0'..'9', 'A'..'F'];
  begin
  Result := 0;
  while not(TextArray[I] in Hex) do I := I+1; {skip '/' and '$'}
  J := I;
  for K:=I to I+1 do
    begin
    C := TextArray[K];
    if C <= '9' then Tmp := Ord(C)-Ord('0') else Tmp := Ord(C)-Ord('A')+10;
    Result := (Result Shl 4)+Tmp;
    end;
  HexToByte := Result;
  end;

begin
St := Hex2(HexToByte(I, J)+Modify);
TextArray[J] := St[1];
TextArray[J+1] := St[2];
end;

{
-------------DoNext}
PROCEDURE DoNext;
Var TmpCh : Char;

begin
OldChi := Chi;
Symbol := False;
if Sym = EOLsym then Exit;  {do nothing}
SkipSpaces;                 {note commas are significant}
if (UCh = Chr(CR)) or (UCh = ';') then Sym := EOLsym
else if UCh = ',' then begin Sym := Comma; GetCh; end
else if (UCh = '>') or (UCh = '<') then
  begin
  TmpCh := UCh; GetCh;
  if not GetSymbol(Symname) then Error(Chi, 'Symbol Name Exp');
  if TmpCh = '<' then Sym := Disp8 else Sym := Disp16;
  Symbol := True;           {disp8/16 is a symbol}
  end
else if GetAddress then
  begin
  if NoAddrs then ErrNull
  else Sym := Address;
  end
else if GetExpr(NValue) then
  begin
  if ByteSize(NValue) then
    Sym := Disp8 else Sym := Disp16;
  end
else if (UCh >= 'A') and (UCh <= 'Z') then
  begin GetString; Symname := Lsid;
  if (Lsid = 'FAR') or (Lsid = 'NEAR') or (Lsid = 'SHORT') then
    Sym := JmpDist
  else if Lsid = 'ST' then Sym := STsym
  else Sym := Identifier;
  end
else if UCh = '+' then begin Sym := Plus; GetCh; end
else if UCh = '[' then begin Sym := LfBrack; GetCh; end
else if UCh = ']' then begin Sym := RtBrack; GetCh; end
else begin Sym := Othersym; GetCh; end;
end;

{
-------------NextA}
PROCEDURE NextA;            {Get the next item but also process any
                            'WORD' 'BYTE', 'DWORD', 'QWORD',etc 'PTR'}
Type Sizeary = Array[0..4] of String[2];
Var Tmp : PtrType;
  Indx : Integer;
Const Ptrary : Sizeary = ('BY', 'WO', 'DW', 'QW', 'TB');
      Ptrary1 : Array[0..4] of String[5] =
                  ('BYTE','WORD','DWORD','QWORD','TBYTE');

begin
DoNext;
if Sym = Identifier then
  begin
  Tmp := BPtr; Indx := 0;
  while (Tmp < UnkPtr) and (Lsid <> Ptrary[Indx]) and (Lsid <>Ptrary1[Indx]) do
    begin
    Tmp := Succ(Tmp); Indx := Indx+1;
    end;
  if Tmp < UnkPtr then
    begin ByWord := Tmp; DoNext; end;
  if Str = 'PTR  ' then DoNext; {ignore 'PTR'}
  end;
end;

{
-------------Displace_Bytes}
PROCEDURE Displace_Bytes(W : Integer);
Var C : Char;
begin
if Displace then
  with SaveOfs do
    begin
    if Symb then
      begin                 {displacement is a symbol}
      if W = 1 then C := '>' else C := '<';
      InsertStr(C+Sname);
      if Value <> 0 then    {Add it in too, don't reverse bytes}
        InsertStr('+$'+Hex2(Hi(Value))+Hex2(Lo(Value)));
      if W = 1 then ByteCount := ByteCount+2 else ByteCount := ByteCount+1;
      LastSlash:=Tindex;
      InsertChr('/');
      end
    else
      if W = 1 then InsertWord(Value) else InsertByte(Lo(Value));
    end;
end;

{
-------------Data_Bytes}
PROCEDURE Data_Bytes(Word : Boolean);
Var C : Char;
begin
with DataVal do
  begin
  if Symb then
    begin                   {data is a symbol}
    if Word then C := '>' else C := '<';
    InsertStr(C+Sname);
    if Value <> 0 then      {add it in too}
      InsertStr('+$'+Hex2(Hi(Value))+Hex2(Lo(Value)));
    if Word then ByteCount := ByteCount+2 else ByteCount := ByteCount+1;
    LastSlash:=Tindex;
    InsertChr('/');
    end
  else
    if Word then InsertWord(Value) else InsertByte(Lo(Value));
  end;
end;

{
-------------GetIR}
FUNCTION GetIR : Boolean;
Var Reg : IndxReg;
begin
GetIR := False; Reg := None;
if (Sym = Identifier) and (Lsid[0] = Chr(2)) then
  if ID2 = 'BX' then Reg := BX
  else if ID2 = 'SI' then Reg := SI
  else if ID2 = 'DI' then Reg := DI
  else if ID2 = 'BP' then Reg := BP;
if Reg <> None then
  begin
  IRset := IRset+[Reg];
  GetIR := True;
  NextA;
  end;
end;

{
-------------MemReg}
FUNCTION MemReg(Var W : Integer) : Boolean;
Label 10;

  {Does not handle the 'reg' part of the mem/reg. Returns disp true if
  a displacement is found with w=0 for byte disp and w=1 for word
  disp.  Any displacement is output in saveofs.}

Var
  SaveChi : Integer;
  Dsp16, OldAddrs, Result_MemReg : Boolean;
begin
SaveChi := OldChi; Dsp16 := False;
Result_MemReg := False;
OldAddrs := NoAddrs; NoAddrs := True;
SaveOfs.Value := 0; SaveOfs.Symb := False; IRset := [];
while (Sym <> Comma) and (Sym <> EOLsym) do {',' or cr terminate a MemReg}
  begin
  if Sym = LfBrack then
    begin Result_MemReg := True; NextA; end;
  if Sym = Plus then NextA;
  if (Sym = Disp8) or (Sym = Disp16) then
    with SaveOfs do
      begin
      Dsp16 := Dsp16 or (Sym = Disp16);
      if Symbol then
        begin
        Symb := True; Sname := Symname;
        end
      else Value := Value+NValue;
      NextA;
      end
  else if not GetIR then
    if Sym = RtBrack then NextA
    else if Result_MemReg then
      begin Error(Chi, 'Comma or Line End Exp'); NextA; end
    else GOTO 10;           {abort}
  end;
if Result_MemReg then
  begin                     {at least one '[' found}
  if (IRset = []) or (IRset = [BP]) then Rmm := 6
  else if IRset = [BX, SI] then Rmm := 0
  else if IRset = [BX, DI] then Rmm := 1
  else if IRset = [BP, SI] then Rmm := 2
  else if IRset = [BP, DI] then Rmm := 3
  else if IRset = [SI] then Rmm := 4
  else if IRset = [DI] then Rmm := 5
  else if IRset = [BX] then Rmm := 7
  else Error(Chi, 'Bad Register Combination');

  NextA;                    {pass over any commas}
  with SaveOfs do
    Dsp16 := Dsp16 or (Symb and (Value <> 0)) or not ByteSize(Value);
  if IRset = [] then
    begin Displace := True; Md := 0; W := 1; end {direct address}
  else if (IRset = [BP]) and not Dsp16 then
    begin Displace := True; Md := 1; W := 0; end {bp must have displ}
  else if (SaveOfs.Value = 0) and not SaveOfs.Symb then
    begin Displace := False; Md := 0; W := 3; end
  else if not Dsp16 then    {8 bit}
    begin Displace := True; Md := 1; W := 0; end
  else begin Displace := True; Md := 2; W := 1; end;
  ModeByte := 64*Md+Rmm;
  end
else
10: begin                     {not a MemReg}
  Chi := SaveChi-1; GetCh;  {restore as in beginning}
  NextA;
  end;
NoAddrs := OldAddrs;
MemReg := Result_MemReg;
end;

{
-------------St_st}
FUNCTION St_st : Boolean;   {pick up st,st(i) or st(i),st or just st(i)}
Var Err, Rslt : Boolean;

  FUNCTION Getsti_val : Boolean;
  Var Grslt : Boolean;
  begin
  NextA;
  Grslt := Sym = Disp8;
  if Grslt then
    begin
    Sti_val := NValue;
    Err := ((Sti_val and $F8) <> 0); {check limit of 7}
    NextA;
    end;
  Getsti_val := Grslt;
  end;

begin
Err := False;
Rslt := Sym = STsym;
if Rslt then
  begin
  if Getsti_val then
    begin
    St_first := False;      {st(i) is first}
    while (Sym = Comma) or (Sym = STsym) do NextA;
    end
  else
    begin
    St_first := True;       {st preceeds st(i)}
    if Sym = Comma then NextA;
    if Sym = STsym then
      begin
      if not Getsti_val then
        Err := True;
      end
    else Err := True;
    end;
  if Err then ErrNull;
  end;
St_st := Rslt;
end;

{
-------------FstiOnly}
FUNCTION FstiOnly : Boolean;
  {Fl Pt instructions having only one form using st(i) operand}
  {faddp,fmulp,fsubp,fsubrp,fdivp,fdivrp,ffree,fxch -- 0..7 }
Type Arraytype = Array[0..7] of Integer;
  Table = Array[0..7, 0..5] of Char;
Var Indx : Integer;
  Rslt : Boolean;
Const
  Stiary : Arraytype =
       ($DEC0, $DEC8, $DEE8, $DEE0, $DEF8, $DEF0, $DDC0, $D9C8);
  StiOnlyTable : Table = ('FADDP ', 'FMULP ', 'FSUBP ',
       'FSUBRP', 'FDIVP ', 'FDIVRP', 'FFREE ', 'FXCH  ');

begin
Rslt := MatchSt(StiOnlyTable, 6, 7, Indx);
if Rslt then
  begin
  NextA;
  if not St_st then
    begin
    if Sym = EOLsym then Sti_val := 1
    else ErrIncorrect;
    end;
  InsertWait;
  InsertHi_Low(Stiary[Indx]+Sti_val);
  end;
FstiOnly := Rslt;
end;

{
-------------FmemOnly}
FUNCTION FmemOnly : Boolean;
  {Fl Pt instructions having only one form using a memory operand}
  {fldenv,fldcw,fstenv,fstcw,fbstp,fbld,frstor,fsave,fstsw,
  fnsave,fnstcw,fnstenv,fnstsw--0..12 }
Type Arraytype = Array[0..12] of Integer;
  Table = Array[0..12, 0..6] of Char;
Var Indx : Integer;
  Rslt : Boolean;
Const
  Memary : Arraytype = (
    $D920, $D928, $D930, $D938, $DF30, $DF20, $DD20, $DD30, $DD38,
    $DD30, $D938, $D930, $DD38);
  MemOnlyTable : Table =
   ('FLDENV ', 'FLDCW  ', 'FSTENV ', 'FSTCW  ', 'FBSTP  ', 'FBLD   ',
    'FRSTOR ', 'FSAVE  ', 'FSTSW  ',
    'FNSAVE ', 'FNSTCW ', 'FNSTENV', 'FNSTSW ');
begin
Rslt := MatchSt(MemOnlyTable, 7, 12, Indx);
if Rslt then
  begin
  NextA;
  if Indx < 9 then InsertWait; {fwait}
  if MemReg(W1) then
    begin
    InsertHi_Low(Memary[Indx]+ModeByte);
    Displace_Bytes(W1);
    end
  else ErrIncorrect;
  end;
FmemOnly := Rslt;
end;

{
-------------FldType}
FUNCTION FldType : Boolean;
  {Do fld,fst,fstp-- 0..2}
Type
  Arraytype = Array[0..2, DwPtr..UnkPtr] of Integer;
  Table = Array[0..2, 0..3] of Char;
Var Indx, Tmp : Integer;
  Rslt : Boolean;
Const
  Fldarray : Arraytype = (
    ($D900, $DD00, $DB28, $D9C0),
    ($D910, $DD10, 0, $DDD0),
    ($D918, $DD18, $DB38, $DDD8));
  Fldtable : Table = ('FLD ', 'FST ', 'FSTP');
begin
Rslt := MatchSt(Fldtable, 4, 2, Indx);
if Rslt then
  begin
  NextA;
  InsertWait;           {fwait}
  if ByWord >= DwPtr then
    Tmp := Fldarray[Indx, ByWord];
  if MemReg(W1) then
    begin
    if (ByWord >= DwPtr) and (ByWord <= TbPtr) then
      begin
      InsertHi_Low(Tmp+ModeByte);
      Displace_Bytes(W1);
      if Tmp = 0 then Error(Chi, 'TBYTE not Permitted');
      end
    else Error(Chi, 'DWORD, QWORD, or TBYTE Req''d');
    end
  else if St_st then
    InsertHi_Low(Tmp+Sti_val)
  else ErrIncorrect;
  end;
FldType := Rslt;
end;

{
-------------FildType}
FUNCTION FildType : Boolean;
  {do fild,fist,fistp-- 0..2}
Type
  Arraytype = Array[0..2, WPtr..QwPtr] of Integer;
  Table = Array[0..2, 0..4] of Char;
Var Indx, Tmp : Integer;
  Rslt : Boolean;
Const
  Fildarray : Arraytype = (
    ($DF00, $DB00, $DF28),
    ($DF10, $DB10, 0),
    ($DF18, $DB18, $DF38));
  Fildtable : Table = ('FILD ', 'FIST ', 'FISTP');
begin
Rslt := MatchSt(Fildtable, 5, 2, Indx);
if Rslt then
  begin
  NextA;
  if MemReg(W1) then
    begin
    if (ByWord >= WPtr) and (ByWord <= QwPtr) then
      begin
      InsertWait;       {fwait}
      Tmp := Fildarray[Indx, ByWord];
      InsertHi_Low(Tmp+ModeByte);
      Displace_Bytes(W1);
      if Tmp = 0 then Error(Chi, 'QWORD not Permitted');
      end
    else Error(Chi, 'WORD, DWORD, or QWORD Req''d');
    end
  else ErrIncorrect;
  end;
FildType := Rslt;
end;

{
-------------FaddType}
FUNCTION FaddType : Boolean;
  {The fadd,fmul,fcom,fcomp,fsub,fsubr,fdiv,fdivr instructions}
Var Indx : Integer;
  Rslt : Boolean;
Type Table = Array[0..7, 0..4] of Char;
Const Faddtable : Table = ('FADD ', 'FMUL ', 'FCOM ', 'FCOMP',
  'FSUB ', 'FSUBR', 'FDIV ', 'FDIVR');
begin
Rslt := False;
if MatchSt(Faddtable, 5, 7, Indx) then
  begin
  NoAddrs := True;
  Rslt := True;
  NextA;
  InsertWait;           {fwait}
  if MemReg(W1) then
    begin
    if ByWord = DwPtr then InsertByte($D8)
    else if ByWord = QwPtr then InsertByte($DC)
    else Error(Chi, 'DWORD or QWORD Req''d');
    InsertByte(ModeByte+8*Indx);
    Displace_Bytes(W1);
    end
  else if St_st then        {Must be st,st(i) or st(i),st }
    begin
    if St_first or (Indx = 2 {fcom} ) or (Indx = 3 {fcomp} ) then
    InsertByte($D8) else InsertByte($DC);
    ModeByte := $C0+8*Indx+Sti_val;
    if not St_first and (Indx >= 6 {fdiv} ) then
      ModeByte := ModeByte Xor 8; {reverse fdiv,fdivr for not st_first}
    InsertByte(ModeByte);
    end
  else ErrIncorrect;
  end;
FaddType := Rslt;
end;

{
-------------FiaddType}
FUNCTION FiaddType : Boolean;
  {the fiadd,fimul,ficom,ficomp,fisub,fisubr,fidiv,fidivr instructions}
Type Table = Array[0..7, 0..5] of Char;
Var Indx : Integer;
  Rslt : Boolean;
Const Fiaddtable : Table = ('FIADD ', 'FIMUL ', 'FICOM ', 'FICOMP',
  'FISUB ', 'FISUBR', 'FIDIV ', 'FIDIVR');
begin
Rslt := False;
if MatchSt(Fiaddtable, 6, 7, Indx) then
  begin
  NoAddrs := True;
  Rslt := True;
  NextA;
  if MemReg(W1) then
    begin
    InsertWait;         {fwait}
    if ByWord = DwPtr then InsertByte($DA)
    else if ByWord = WPtr then InsertByte($DE)
    else Error(Chi, 'WORD or DWORD Req''d');
    InsertByte(ModeByte+8*Indx);
    Displace_Bytes(W1);
    end
  else ErrIncorrect;
  end;
FiaddType := Rslt;
end;

{
-------------Fnoperand}
FUNCTION Fnoperand : Boolean;
  {do the Fl Pt no operand instructions}
Type Table = Array[0..32, 0..6] of Char;
Var Indx : Integer;
  Rslt : Boolean;
Const
  Fnoptable : Table =       {Ordered with fnopcode}
   ('FNOP   ', 'FCHS   ', 'FABS   ', 'FTST   ', 'FXAM   ',
    'FLD1   ', 'FLDL2T ', 'FLDL2E ', 'FLDPI  ', 'FLDLG2 ', 'FLDLN2 ',
    'FLDZ   ', 'F2XM1  ', 'FYL2X  ', 'FPTAN  ', 'FPATAN ', 'FXTRACT',
    'FDECSTP', 'FINCSTP', 'FPREM  ', 'FYL2XP1', 'FSQRT  ', 'FRNDINT',
    'FSCALE ', 'FENI   ', 'FDISI  ', 'FCLEX  ', 'FINIT  ', 'FCOMPP ',
    'FNCLEX ', 'FNDISI ', 'FNENI  ', 'FNINIT ');

  Fnopcode : Array[0..32] of Integer =
   ($D9D0, $D9E0, $D9E1, $D9E4, $D9E5, $D9E8,
    $D9E9, $D9EA, $D9EB, $D9EC, $D9ED, $D9EE,
    $D9F0, $D9F1, $D9F2, $D9F3, $D9F4, $D9F6,
    $D9F7, $D9F8, $D9F9, $D9FA, $D9FC, $D9FD,
    $DBE0, $DBE1, $DBE2, $DBE3, $DED9,
    $DBE2, $DBE1, $DBE0, $DBE3);

begin
Rslt := MatchSt(Fnoptable, 7, 32, Indx);
if Rslt then
  begin
  NextA;
  if Indx < 29 then InsertWait; {fwait}
  InsertHi_Low(Fnopcode[Indx]);
  end;
Fnoperand := Rslt;
end;

{
-------------Register}
FUNCTION Register(Var R, W : Integer) : Boolean;
Type
  Regarytype = Array[0..15] of Array[1..2] of Char;
Const Regarray : Regarytype = (
  'AL', 'CL', 'DL', 'BL', 'AH', 'CH', 'DH', 'BH',
  'AX', 'CX', 'DX', 'BX', 'SP', 'BP', 'SI', 'DI');
Var Result_Reg : Boolean;
begin
Result_Reg := False;
if (Lsid[0] = Chr(2)) and (Sym = Identifier) then
  begin
  R := $FFFF;
  repeat
    R := R+1;
  until (R > 15) or (ID2 = Regarray[R]);
  Result_Reg := R <= 15;
  if Result_Reg then
    begin
    NextA;
    if Sym = Comma then NextA;
    end;
  W := R div 8;             {w=1 for word type register}
  R := R and 7;
  end;
Register := Result_Reg;
end;

{
-------------SegRegister}
FUNCTION SegRegister(Var R : Integer) : Boolean;
Var Result_Segr : Boolean;
begin
if (Sym = Identifier) and (Lsid[0] = Chr(2)) then
  begin
  Result_Segr := True;
  if ID2 = 'ES' then R := 0
  else if ID2 = 'CS' then R := 1
  else if ID2 = 'SS' then R := 2
  else if ID2 = 'DS' then R := 3
  else Result_Segr := False;
  if Result_Segr then
    begin
    NextA;
    if Sym = Comma then NextA;
    end;
  end
else Result_Segr := False;
SegRegister := Result_Segr;
end;

{
-------------Data}
FUNCTION Data(Var Wd : Boolean) : Boolean;
  {See if immediate data is present.  Set wd if data found is word size}
Var SaveChi : Integer;
  Result : Boolean;
begin
Result := False; Wd := False;
SaveChi := OldChi;
with DataVal do
  begin
  Value := 0; Symb := False;
  while (Sym = Disp8) or (Sym = Disp16) do
    begin
    Result := True;
    if Symbol then
      begin
      Wd := Wd or (Sym = Disp16);
      Symb := True;
      Sname := Symname;
      end
    else Value := Value+NValue;
    NextA; if Sym = Plus then NextA;
    end;
  Result := (Sym = EOLsym) and Result;
  Wd := Wd or not ByteSize(Value);
  end;
Data := Result;
if not Result then
  begin
  Chi := SaveChi-1; GetCh; NextA;
  end;
end;

{
-------------TwoOperands}
FUNCTION TwoOperands : Boolean;
  {Handles codes with two operands}
Label 2;
Type InsType = (Mov, Adc, Addx, Andx, Cmp, Orx, Sbb, Sub, Xorx, Test, Xchg,
  Lds, Les, Lea);
  Nametype = Array[Mov..Lea] of Array[1..5] of Char;
  Codetype = Array[Mov..Lea] of Byte;
  Shcodetype = Array[Mov..Test] of Byte;
Var Inst : InsType;
  Tmp : Byte;

Const Instname : Nametype = (
  'MOV  ', 'ADC  ', 'ADD  ', 'AND  ', 'CMP  ', 'OR   ',
  'SBB  ', 'SUB  ', 'XOR  ', 'TEST ', 'XCHG ', 'LDS  ',
  'LES  ', 'LEA  ');

  Immedop : Codetype = ($C6, $80, $80, $80, $80, $80, $80, $80, $80, $F6, 0,
    0, 0, 0);
  Immedreg : Codetype = (0, $10, 0, $20, $38, 8, $18, $28, $30, 0, 0,
    0, 0, 0);
  Memregop : Codetype = ($88, $10, 0, $20, $38, 8, $18, $28, $30, $84, $86,
    $C5, $C4, $8D);
  Shimmedop : Shcodetype = (0, $14, 4, $24, $3C, $C, $1C, $2C, $34, $A8);

begin TwoOperands := False;
for Inst := Mov to Lea do
  if Str = Instname[Inst] then
    GOTO 2;
Exit;                         {not found}
2:                            {found}
NoAddrs := True;            {full address not acceptable}
TwoOperands := True;
NextA;
if Register(Reg1, W1) then
  begin
  if Register(Reg2, W2) then
    begin                   {mov reg,reg}
    if Inst >= Lds then Error(Chi, 'Register not Permitted');
    if W1 <> W2 then Error(Chi, 'Registers Incompatible');
    if (Inst = Xchg) and ((W1 = 1) and ((Reg1 = 0) or (Reg2 = 0))) then
      InsertByte($90+Reg1+Reg2)
    else
      begin
      InsertByte(Memregop[Inst]+W1);
      InsertByte($C0+Reg1+8*Reg2);
      end;
    end
  else if SegRegister(Reg2) then
    begin                   {mov reg,segreg}
    if (W1 = 0) or (Inst <> Mov) then SegmErr;
    InsertByte($8C); InsertByte($C0+8*Reg2+Reg1);
    end
  else if Data(Word) then
    begin                   {mov reg,data}
    SignExt := 0;           {signext not presently in use}
    if Inst >= Xchg then Error(Chi, 'Immediate not Permitted');
    if (Ord(Word) > W1) then DataLarge;
    if (Inst = Mov) then
      begin
      InsertByte($B0+8*W1+Reg1);
      end
    else
      if (Reg1 = 0) {ax or al} then
        InsertByte(Shimmedop[Inst]+W1) {add ac,immed}
      else
        begin
        (*       if (inst<>test) and (w1=1) and bits_7 then
        signext:=2;         {the sign extension bit}     *)
        InsertByte(Immedop[Inst]+W1+SignExt);
        InsertByte($C0+Immedreg[Inst]+Reg1);
        end;
    (*    Insertbyte(lo(dataval));
    if (w1>0) and (signext=0) then Insertbyte(hi(dataval));   *)
    Data_Bytes(W1 > 0);     {output the immediate data}
    end
  else if MemReg(W2) then
    begin                   {mov reg,mem/reg}
    if (Inst = Mov) and (Reg1 = 0) {ax or al} and (Rmm = 6) and (Md = 0) then
      begin                 {mov ac,mem}
      InsertByte($A0+W1);
      end
    else
      begin
      Tmp := Memregop[Inst];
      if Inst <= Xchg then
        begin
        Tmp := Tmp+W1;
        if Inst <> Test then Tmp := Tmp or 2; {to,from bit}
        end;
      InsertByte(Tmp);
      InsertByte(ModeByte+8*Reg1);
      end;
    Displace_Bytes(W2);     {add on any displacement bytes}
    end
  else ErrNull;
  end
else if SegRegister(Reg1) then
  begin
  if Inst <> Mov then SegmErr;
  InsertByte($8E);
  if Register(Reg2, W2) then
    begin                   {mov segreg,reg}
    if (W2 = 0) then WordReg;
    InsertByte($C0+8*Reg1+Reg2);
    end
  else if MemReg(W2) then
    begin                   {mov segreg,mem/reg}
    InsertByte(ModeByte+8*Reg1);
    Displace_Bytes(W2);     {add any displacement bytes}
    end
  else ErrNull;
  end
else if MemReg(W1) and (Inst <= Xchg) then
  begin
  if Register(Reg2, W2) then
    begin                   {mov mem/reg,reg}
    if (W2 > Ord(ByWord)) then Error(Chi, 'Byte Reg Exp');
    if (Inst = Mov) and (Reg2 = 0) {ax or al} and (Rmm = 6) and (Md = 0) then
      begin                 {mov ac, mem}
      InsertByte($A2+W2);
      end
    else
      begin
      InsertByte(Memregop[Inst]+W2);
      InsertByte(ModeByte+8*Reg2);
      end;
    Displace_Bytes(W1);
    end
  else if SegRegister(Reg2) then
    begin                   {mov mem/reg,segreg}
    if (Inst <> Mov) then SegmErr;
    InsertByte($8C); InsertByte(ModeByte+8*Reg2);
    Displace_Bytes(W1);
    end
  else if (Data(Word)) and (Inst < Xchg) then
    begin                   {mov mem/reg, data}
    Chk_BwPtr;
    if (Ord(Word) > Ord(ByWord)) then DataLarge;
    (*     if (inst>=adc) and (inst<=xorx) and (byword=wptr) and bits_7 then
    signext:=2 else *) SignExt := 0; {the sign extension bit,
                                       not currently used}
    InsertByte(Immedop[Inst]+Ord(ByWord)+SignExt);
    InsertByte(ModeByte+Immedreg[Inst]);
    Displace_Bytes(W1);     {add displacement bytes}
    (*     Insertbyte(lo(dataval));
    if (byword=wptr) and (signext=0) then Insertbyte(hi(dataval));  *)
    Data_Bytes(ByWord = WPtr); {the immediate data}
    end
  else ErrNull;
  end
else if (Sym = Disp8) or (Sym = Disp16) then
  Error(Chi, 'Immediate not Permitted')
else ErrNull;
end;

{
-------------OneOperand}
FUNCTION OneOperand : Boolean;
  {Handles codes with one operand}
Type InsType = (Dec, Inc, Push, Pop, Nott, Neg);
  Nametype = Array[Dec..Neg] of Array[1..5] of Char;
  Codetype = Array[Dec..Neg] of Byte;
Var Inst : InsType;
  Pushpop : Boolean;

Const
  Instname : Nametype = (
     'DEC  ', 'INC  ', 'PUSH ', 'POP  ', 'NOT  ', 'NEG  ');

  Regop : Codetype = ($48, $40, $50, $58, 0, 0);
  Segregop : Codetype = (0, 0, 6, 7, 0, 0);
  Memregop : Codetype = ($FE, $FE, $FF, $8F, $F6, $F6);
  Memregcode : Codetype = ($8, 0, $30, 0, $10, $18);

begin OneOperand := False;
for Inst := Dec to Neg do
  if Str = Instname[Inst] then
    begin
    Pushpop := (Inst = Push) or (Inst = Pop);
    NoAddrs := True;
    OneOperand := True;
    NextA;
    if Register(Reg1, W1) then
      begin
      if (W1 = 1) and (Inst < Nott) then
        begin               {16 bit register instructions}
        InsertByte(Regop[Inst]+Reg1);
        end
      else begin            {byte register or neg,not with any reg}
      InsertByte(Memregop[Inst]+W1);
      InsertByte($C0+Memregcode[Inst]+Reg1);
      if Pushpop then
        WordReg;
      end
      end                   {if reg}
    else if SegRegister(Reg1) then
      begin                 {segment reg--push,pop only}
      InsertByte(Segregop[Inst]+8*Reg1);
      if not Pushpop then SegmErr
      end
    else if MemReg(W1) then
      begin                 {memreg  (not register)}
      if not Pushpop then Chk_BwPtr;
      InsertByte(Memregop[Inst] or Ord(ByWord));
      InsertByte(ModeByte+Memregcode[Inst]);
      Displace_Bytes(W1);
      end
    else ErrIncorrect;
    end;                    {if st}
end;

{
-------------NoOperand}
FUNCTION NoOperand : Boolean;
  {Those instructions consisting only of opcode}
Const Nmbsop = 31;
Type Sofield = Array[0..Nmbsop] of Array[1..5] of Char;
  Opfield = Array[0..Nmbsop] of Byte;
Var Index : Integer;
Const
  Sop : Sofield = (
    'DAA  ', 'AAA  ', 'NOP  ', 'MOVSB', 'MOVSW', 'CMPSB', 'CMPSW',
    'XLAT ', 'HLT  ',
    'CMC  ', 'DAS  ', 'AAS  ', 'CBW  ', 'CWD  ', 'PUSHF',
    'POPF ', 'SAHF ', 'LAHF ', 'STOSB', 'STOSW', 'LODSB', 'LODSW',
    'SCASB', 'SCASW', 'INTO ', 'IRET ', 'CLC  ', 'STC  ', 'CLI  ',
    'STI  ', 'CLD  ', 'STD  ');
  Opcode : Opfield = (
    $27, $37, $90, $A4, $A5, $A6, $A7, $D7, $F4,
    $F5, $2F, $3F, $98, $99, $9C, $9D, $9E, $9F, $AA, $AB, $AC, $AD,
    $AE, $AF, $CE, $CF, $F8, $F9, $FA, $FB, $FC, $FD);

begin NoOperand := False;
for Index := 0 to Nmbsop do
  if Str = Sop[Index] then
    begin
    InsertByte(Opcode[Index]);
    NoOperand := True;
    NextA;
    Exit;
    end;
end;

{
-------------Prefix}
FUNCTION Prefix : Boolean;
  {process the prefix instructions}
Const Nmbsop = 11;
Type Field = Array[0..Nmbsop] of String5;
  Opfield = Array[0..Nmbsop] of Byte;
Var Index : Integer;
    SaveWait : Boolean;
    Opc : Byte;
Const
  Ops : Field = (
    'LOCK ', 'REP  ', 'REPZ ',
    'REPNZ', 'REPE ', 'REPNE', 'WAIT ', 'FWAIT',
    'ES   ', 'DS   ', 'CS   ', 'SS   ');
  Opcode : Opfield = (
    $F0, $F2, $F3, $F2, $F3, $F2, $9B, $9B, $26, $3E, $2E, $36);

begin Prefix := False;
for Index := 0 to Nmbsop do
  if Str = Ops[Index] then
    begin
    Opc:=Opcode[Index];
    SaveWait := Wait_Already;  {save any WAIT already programed}
    InsertByte(Opc);
    Wait_Already:=SaveWait or (Opc=$9B); {set for WAIT or FWAIT}
    Tindex0 := Tindex;      {for future fix ups}
    if UCh = ':' then GetCh; {es: etc permitted with a colon}
    Prefix := True;
    Exit;
    end;
end;

{
-------------FindLabel}
FUNCTION FindLabel(Var B : Integer) : Boolean;
  {Find a label if it exists in the label chain}
Var Found : Boolean;
begin
Pl := Firstlabel; Found := False;
while (Pl <> Nil) and not Found do
  with Pl^ do
    if Symname = Name then
      begin
      Found := True;
      B := ByteCnt;
      end
    else Pl := Next;
FindLabel := Found;
end;

{
-------------ShortJmp}
FUNCTION ShortJmp : Boolean;
  {short jump instructions}
Const Numjmp = 34;
Type
  Sjfield = Array[0..Numjmp] of Array[1..5] of Char;
  Opfield = Array[0..Numjmp] of Byte;
Var I, B : Integer;
Const
  Jumps : Sjfield = (
    'JO   ', 'JNO  ', 'JB   ', 'JNAE ', 'JNB  ', 'JAE  ',
    'JE   ', 'JZ   ', 'JNE  ', 'JNZ  ', 'JBE  ', 'JNA  ',
    'JNBE ', 'JA   ', 'LOOPN', 'LOOPZ', 'LOOPE', 'LOOP ',
    'JCXZ ', 'JS   ', 'JNS  ', 'JP   ', 'JPE  ', 'JNP  ',
    'JPO  ', 'JL   ', 'JNGE ', 'JNL  ', 'JGE  ', 'JLE  ',
    'JNG  ', 'JNLE ', 'JG   ', 'JC   ', 'JNC  ');

  Opcode : Opfield = (
    $70, $71, $72, $72, $73, $73, $74, $74, $75, $75, $76, $76,
    $77, $77, $E0, $E1, $E1, $E2, $E3, $78, $79, $7A, $7A, $7B,
    $7B, $7C, $7C, $7D, $7D, $7E, $7E, $7F, $7F, $72, $73);

begin ShortJmp := False;
for I := 0 to Numjmp do
  if Str = Jumps[I] then
    begin
    InsertByte(Opcode[I]);
    ShortJmp := True;
    NoAddrs := True;
    NextA;
    if Sym = Identifier then
      begin
      if FindLabel(B) then
        begin
        Addr := B-(ByteCount+1);
        if Addr+$8080 <= $80FF then InsertByte(Lo(Addr))
        else Error(Chi, 'Too Far');
        end
      else
        begin               {enter jump into fixups}
        New(Pf);
        with Pf^ do
          begin
          Next := Firstfix;
          if Firstfix <> Nil then
            Firstfix^.Prev := Pf;
          Firstfix := Pf;
          Prev := Nil;
          Jmptype := Short;
          Name := Symname;
          Fix_pt := ByteCount; Indx := Tindex;
          InsertByte(0);     {dummy insertion}
          end;
        end;
      NextA;
      end
    else Error(Chi, 'Label Exp');
    end;
end;

{
-------------ShfRot}
FUNCTION ShfRot : Boolean;
Type
  InsType = (Rclx, Rcrx, Rolx, Rorx, Salx, Sarx, Shlx, Shrx);
  Nametype = Array[Rclx..Shrx] of Array[1..3] of Char;
  Codetype = Array[Rclx..Shrx] of Byte;
Var
  Inst : InsType;
  CL : Byte;

Const
  Instname : Nametype = (
    'RCL', 'RCR', 'ROL', 'ROR', 'SAL', 'SAR',
    'SHL', 'SHR');

  Regcode : Codetype = ($10, $18, 0, 8, $20, $38, $20, $28);

begin ShfRot := False;
if Lsid[0] = Chr(3) then
  for Inst := Rclx to Shrx do
    if ID3 = Instname[Inst] then
      begin
      NoAddrs := True; ShfRot := True;
      NextA;
      InsertByte($D0);       {may get modified later}
      if Register(Reg1, W1) then
        InsertByte($C0+Regcode[Inst]+Reg1)
      else if MemReg(W2) then
        begin
        Chk_BwPtr;
        W1 := Ord(ByWord);
        InsertByte(ModeByte+Regcode[Inst]);
        Displace_Bytes(W2);
        end
      else Error(Chi, 'Reg or Mem Exp');
      if Sym = Comma then NextA;
      CL := 0;
      if (ID3 = 'CL ') then CL := 2
      else if NValue <> 1 then Error(Chi, 'CL or 1 Exp');
      NextA;
      Modify_Byte(Tindex0, CL+W1); {modify the opcode}
      end;
end;

{
-------------CallJmp}
FUNCTION CallJmp : Boolean;
Type InsType = (CALL, JMP);
  Codetype = Array[CALL..JMP] of Byte;
Var
  Inst : InsType;
  Dist : (Nodist, Long, Shrt, Near);
  Tmp : Byte;
  Dwtmp : PtrType;
  B : Integer;
  WordSize : Boolean;

Const
  Shortop : Codetype = ($E8, $E9);
  Longop : Codetype = ($9A, $EA);
  Longcode : Codetype = ($18, $28);
  Shortcode : Codetype = ($10, $20);

begin CallJmp := False;
if Str = 'CALL ' then Inst := CALL
else if Str = 'JMP  ' then Inst := JMP
else Exit;

CallJmp := True;
NextA;
Dist := Nodist;
Dwtmp := ByWord;            {could have passed a 'DWORD PTR' here}
if Sym = JmpDist then
  begin
  if ID2 = 'FA' then Dist := Long
  else if ID2 = 'NE' then Dist := Near
  else if ID2 = 'SH' then Dist := Shrt;
  NextA;
  end;
if (Sym = Address) then
  begin
  InsertByte(Longop[Inst]);
  InsertWord(NValue);
  InsertWord(Segm);
  end
else if Register(Reg1, W1) then
  begin
  if W1 = 0 then WordReg;
  if Dist = Long then Error(Chi, 'FAR not Permitted');
  InsertByte($FF);
  InsertByte($C0+Shortcode[Inst]+Reg1);
  end
else if Sym = Identifier then
  begin
  if Dist = Long then Error(Chi, 'Far not Permitted with Label');
  if FindLabel(B) then
    begin
    Addr := B-(ByteCount+2);
    if Inst = CALL then
      begin
      InsertByte($E8);
      InsertWord(Addr-1);
      end
    else
      if (Addr+$8080 <= $80FF) and (Dist <> Near) then   {inst=jmp}
        begin               {short jump}
        InsertByte($EB); InsertByte(Lo(Addr));
        end
      else
        begin
        InsertByte($E9); InsertWord(Addr-1);
        end;
    end                     {findlabel}
  else
    begin                   {enter it into fixup chain}
    New(Pf);
    with Pf^ do
      begin
      Next := Firstfix;
      if Firstfix <> Nil then
        Firstfix^.Prev := Pf;
      Firstfix := Pf;
      Prev := Nil;
      Name := Symname;
      if Dist = Shrt then
        begin
        Jmptype := Short;
        InsertByte($EB);
        Fix_pt := ByteCount; Indx := Tindex;
        InsertByte(0);       {dummy insertion}
        end
      else
        begin
        Jmptype := Med;
        if Inst = CALL then InsertByte($E8) else InsertByte($E9);
        Fix_pt := ByteCount; Indx := Tindex;
        InsertByte(0);       {dummy insertion}
        Indx2 := Tindex;
        InsertByte(0);       {another dummy byte}
        end;
      end;
    end;
  end                       {identifier}
else if Data(WordSize) then
  begin  {Direct CALL or JMP}
  if (Inst=JMP) and (Dist=Shrt) then
    begin
    if WordSize then Error(Chi,'Must be byte size');
    InsertByte($EB);
    Data_Bytes(False);
    end
  else
    begin
    if not ((Dist=Nodist) or (Dist=Near)) or (Dwtmp<>UnkPtr) then
      Error(Chi, 'Only NEAR permitted');
    if not WordSize then Error(Chi, 'Must be word size');
    InsertByte(Shortop[Inst]);
    Data_Bytes(True);
    end;
  end
else if MemReg(W1) then
  begin
  if (Dist = Long) or (Dwtmp = DwPtr) then Tmp := Longcode[Inst]
  else Tmp := Shortcode[Inst];
  InsertByte($FF);
  InsertByte(ModeByte+Tmp);
  Displace_Bytes(W1);
  end
else ErrNull;
NextA;
end;

{
-------------Retrn}
PROCEDURE Retrn(Far : Boolean);
begin
if (Sym = Disp16) or (Sym = Disp8) then
  begin
  if Far then InsertByte($CA) else InsertByte($C2);
  InsertWord(NValue);
  NextA;
  end
else begin
if Far then InsertByte($CB) else InsertByte($C3);
end;
end;

{
-------------OtherInst}
FUNCTION OtherInst : Boolean;
Label 2, 10, 20, 30;
Type
  Instsym = (Ret, Retf, Aam, Aad, Inn, Out, Mul, Imul, Divd, Idiv, Int);
  Nametype = Array[Ret..Int] of Array[1..5] of Char;
Var Index : Instsym;
  Tmp : Byte;
Const Instname : Nametype = (
  'RET  ', 'RETF ', 'AAM  ', 'AAD  ', 'IN   ', 'OUT  ', 'MUL  ',
  'IMUL ', 'DIV  ', 'IDIV ', 'INT  ');

  PROCEDURE MulDiv(B : Byte);
  Var Wordbit : Integer;
  begin
  InsertByte($F6);
  if Register(Reg2, W2) then
    begin
    InsertByte($C0+B+Reg2);
    Wordbit := W2;
    end
  else if MemReg(W2) then
    begin
    Chk_BwPtr;
    Wordbit := Ord(ByWord);
    InsertByte(ModeByte+B);
    Displace_Bytes(W2);
    end
  else Error(Chi, 'Reg or Mem Exp');
  Modify_Byte(Tindex0, Wordbit);
  end;

  FUNCTION DXreg : Boolean;
  begin
  DXreg := False;
  if Sym = Identifier then
    if ID2 = 'DX' then
      begin DXreg := True; NextA; end;
  end;

  FUNCTION Accum(Var W : Integer) : Boolean;
  Var Result_acc : Boolean;
    {See if next is AL or AX}
  begin
  Result_acc := False;
  if (Sym = Identifier) then
    begin
    Result_acc := (ID3 = 'AX ') or (ID3 = 'AL ');
    if Result_acc then
      begin
      if Str[2] = 'X' then W := 1 else W := 0; {word vs byte register}
      NextA;
      end;
    end;
  Accum := Result_acc;
  end;

begin
OtherInst := False;
for Index := Ret to Int do
  if Str = Instname[Index] then GOTO 2;
Exit;

2: OtherInst := True; NextA;
case Index of
  Ret : Retrn(False);
  Retf : Retrn(True);
  Out : begin
        if DXreg then InsertByte($EE) {out dx,ac}
        else if Sym = Disp8 then
          begin             {out port,ac}
          InsertByte($E6);
          InsertByte(Lo(NValue));
          NextA;
          end
        else GOTO 10;
        if Sym = Comma then NextA;
        if Accum(W1) then
          Modify_Byte(Tindex0, W1) {al or ax}
        else GOTO 20;
        end;
  Inn : begin
        if Accum(W1) then
          begin
          if Sym = Comma then NextA;
          if DXreg then InsertByte($EC+W1) {in ac,dx}
          else
            begin
            if Sym = Disp8 then
              begin         {in ac,port}
              InsertByte($E4+W1);
              InsertByte(Lo(NValue));
              NextA;
              end
            else
              10:Error(Chi, 'DX or Port Exp');
            end
          end
        else
          20:Error(Chi, 'AX or AL Exp');
        end;
  Aam : begin
        Tmp := $D4;
        GOTO 30;
        end;
  Aad : begin
        Tmp := $D5;
        30 : InsertByte(Tmp);
        InsertByte($A);
        end;
  Mul : MulDiv($20);
  Imul : MulDiv($28);
  Divd : MulDiv($30);
  Idiv : MulDiv($38);
  Int : begin
        if Sym = Disp8 then
          begin
          if NValue = 3 then InsertByte($CC)
          else
            begin
            InsertByte($CD);
            InsertByte(Lo(NValue));
            end;
          NextA;
          end
        else ErrNull;
        end;
 end;
end;

{
-------------GetQuoted}
FUNCTION GetQuoted(Var Ls : BigString) : Boolean;
Var SaveChi, K : Integer;
  Term : Char;
  Gq : Boolean;
begin
SkipSpaces;
SaveChi := Chi; K := 1;
Gq := False;
if (UCh = '''') or (UCh = '"') then
  begin
  Term := UCh; GetCh;
  while (UCh <> Term) and (UCh <> Chr(CR)) do
    if (UCh <> Chr(CR)) and (K <= BigStringSize) then
      begin
      Ls[K] := Lch; K := K+1; GetCh;
      end;
  GetCh;                    {pass by term}
  Gq := not(UCh in ['+', '-', '*', '/']); {else was meant to be expr}
  end;
Ls[0] := Chr(K-1);
if not Gq then
  begin Chi := SaveChi-1; GetCh; end;
GetQuoted := Gq;
end;

{
-------------DataByte}
PROCEDURE DataByte;
Var I : Integer;
  Lst : BigString;
begin
repeat
  if GetQuoted(Lst) then
    begin
    for I := 1 to Ord(Lst[0]) do
      InsertByte(Lo(Ord(Lst[I])));
    end
  else
    if ReadByte then InsertByte(Byt)
    else begin ErrNull; end;
  SkipSpaces;
until (UCh = Chr(CR)) or (UCh = ';') or Aerr;
NextA;
end;

{
-------------Chk_For_Label}
PROCEDURE Chk_For_Label;
Var Dum1,Dum2 : Integer;
begin
if not Prefix then          {could be prefix here}
  begin
  SkipSpaces;
  if (Lsid[0] > Chr(0)) and (UCh = ':') then
    begin                 {label found}
    Sym := Identifier;
    if Register(Dum1,Dum2) then Error(Chi, 'Register name used as label')
    else
      begin
      GetCh; Symname := Lsid;
      Pl := Firstlabel;       {check for duplication of label}
      while Pl <> Nil do
        with Pl^ do
          begin
          if Symname = Name then Error(Chi, 'Duplicate Label');
          Pl := Next;
          end;
      New(Pl);                {add the label to the label chain}
      with Pl^ do
        begin
        Next := Firstlabel;
        Firstlabel := Pl;
        ByteCnt := ByteCount;
        Name := Symname;
        end;
      Pf := Firstfix;         {see if any fixups are required}
      while Pf <> Nil do
        with Pf^ do
          begin
          if Name = Symname then
            begin             {remove this fixup from chain}
            if Pf = Firstfix then
              Firstfix := Next
            else Prev^.Next := Next;
            if Next <> Nil then Next^.Prev := Prev;
            Dispose(Pf);
            Addr := ByteCount-(Fix_pt+1);
            if Jmptype = Short then
              begin
              if Addr+$80 <= $FF then Modify_Byte(Indx, Lo(Addr))
              else Error(Chi, 'Too Far');
              end
            else
              begin           {jmptype=med}
              Addr := Addr-1;
              Modify_Byte(Indx, Lo(Addr));
              Modify_Byte(Indx2, Hi(Addr));
              end;
            end;
          Pf := Next;
          end;
      end;                    {label found}
    GetString;              {for next item to use}
    end;
  end                       {neither a label or a prefix}
else GetString;             {it was a prefix}
end;

{
-------------Interpret}
PROCEDURE Interpret;
begin
Tindex0 := Tindex;          {opcode position}
GetString;
Chk_For_Label;
while Prefix do             {process any prefix instructions}
  GetString;
if Lsid[0] > Chr(0) then
  begin
  if not NoOperand then
  if not OneOperand then
  if not TwoOperands then
  if not ShortJmp then
  if not CallJmp then
  if not ShfRot then
  if not OtherInst then
  if not FaddType then
  if not Fnoperand then
  if not FiaddType then
  if not FldType then
  if not FmemOnly then
  if not FildType then
  if not FstiOnly then
  if ID3 = 'DB ' then DataByte
  else if Lsid = 'NEW' then begin NewFnd:=True; NextA; end
  else if Lsid = 'END' then
    begin
    TheEnd := True;
    NextA;
    end
  else Error(Chi, 'Unknown Instruction');
  end
else
  NextA;                 {if not a string find out what}
if Sym <> EOLsym then Error(Chi, 'End of Line Exp');
end;

{
-------------Chk_IOerror}
FUNCTION Chk_IOerror(S : FileString): Integer;
Var IOerr : Integer;
begin
IOerr := IOResult;
if IOerr = 1 then WriteLn('Can''t find ', S)
else if IOerr <> 0 then WriteLn('I/O Error ', Hex4(IOerr));
Chk_IOerror := IOerr;
end;

{
-------------PromptForInput}
PROCEDURE PromptForInput;
Var
  InName,Name : FileString;
  Err : Integer;
begin
{$I-}
repeat
  Write('Source Filename [.ASM]: '); ReadLn(InName);
  if InName='' then Halt;
  DefaultExtension('ASM', InName, Name);
  Assign(Inn, InName); Reset(Inn);
  Err:=Chk_IOerror(InName);
  if Err>1 then Halt(1);
until Err=0;
Write('Object Filename [', Name, '.OBJ]: '); ReadLn(InName);
if InName='' then InName:=Name;   {Use the same name}
DefaultExtension('OBJ',InName,Name);
Assign(Out, InName);
Rewrite(Out);
if Chk_IOerror(InName)<>0 then Halt(1);
{$I+}
end;

{
-------------CommandInput}
PROCEDURE CommandInput;
Var
  InName,Name : FileString;
begin
InName:=ParamStr(1);
DefaultExtension('ASM', InName, Name);
{$I-}
Assign(Inn, InName);
Reset(Inn);
if Chk_IOerror(InName)<>0 then Halt(1);
if ParamCount>=2 then InName:=ParamStr(2)
  else InName:=Name;             {Use the old name}
DefaultExtension('OBJ',InName,Name);
Assign(Out, InName);
Rewrite(Out);
if Chk_IOerror(InName)<>0 then Halt(1);
{$I+}
end;

{
-------------LabelReport}
PROCEDURE LabelReport;  {Report any fixups not made and restore heap}
Var
  Pftmp : Fixup_info_ptr;
  Pltmp : Label_info_ptr;
begin
Pf := Firstfix;
while Pf <> Nil do
  with Pf^ do
    begin
    WriteLn('Label not Found-- ', Name);
    Pftmp := Next;
    Dispose(Pf);
    Pf:=Pftmp;
    end;
Pl := Firstlabel;
while Pl <> Nil do
  begin
  Pltmp := Pl^.Next;
  Dispose(Pl);
  Pl:=Pltmp;
  end;
end;

{
-------------Main}
begin
Write(Signon1); WriteLn(Signon2);
if ParamCount >= 1 then CommandInput else PromptForInput;

Wait_Already:=False;
NewFnd:=True;
while NewFnd and not EOF(Inn) do
  begin
  NewFnd:=False;
  Start_Col := 1; TheEnd := False;
  Tindex := 0;
  ByteCount := 0;
  Firstlabel := Nil; Firstfix := Nil;
  InsertStr('Inline('+^M^J);

  while not EOF(Inn) and not TheEnd and not NewFnd do
    begin
    Aerr := False; NoAddrs := False;
    ByWord := UnkPtr;
    Column := 0;
    ReadLn(Inn, St); Chi := 1; GetCh; Sym := Othersym;
    SkipSpaces;
    if UCh<>Chr(CR) then   {skip blank lines}
      begin
      InsertStr('  ');
      Interpret;
      InsertChr(' ');   {Space for possible ');' fixup}
      if not NewFnd and not TheEnd then
        begin
        while Column < CommentColumn do InsertChr(' ');
        InsertChr('{');
        I := 1;
        while (Column < 124) and (I <= Length(St)) do
          begin
          InsertChr(St[I]);
          I := I+1;
          end;
        InsertStr('}'^M^J);
        end;
      end;
    if EOF(Inn) or TheEnd or NewFnd then
      begin   {Fix up the last '/' inserted}
      Textarray[LastSlash]:=')';
      TextArray[Succ(LastSlash)]:=';';
      InsertStr(^M^J);
      end;
    end;
  LabelReport;       {report any fixups not made and dispose all heap items}
  for I := 0 to Tindex-1 do Write(Out, TextArray[I]);
  end;
Close(Out);
Close(Inn);
end.