Power Programming/powerprogramming1994.iso/progtool/disasm/deb2asm.pqs/deb2asm.pas

Pascal/Delphi Source File | 1987-07-22 | 38KB | 1,121 lines

22-Jul-87 11:43:42-PDT,38122;000000000001
Return-Path: <@wiscvm.wisc.edu:[e-mail]>
Received: FROM WISCVM.WISC.EDU BY C.ISI.EDU WITH TCP ; 22 Jul 87 11:41:41 PDT
Received: from HLERUL5.BITNET by wiscvm.wisc.edu ; Wed, 22 Jul 87 13:38:55 CDT
Date:     Fri, 17 Jul 87 15:39 N
From:     <[e-mail]>
Subject:  Deb2asm
To:       [e-mail]
X-Original-To:  "[e-mail]", KRANENBURG

I would like to contribute the appended program DEB2ASM to the library.
DEB2ASM converts a disassembly output from the DOS DEBUG program to a more
regular and (hopefully) more legible format. The source is in TURBO pascal
and is packaged with an I/O -include- file. You will need SORT.BOX
(Borland Turbo Toolbox) or provide your own sorting routine.

The program produces labels from the hexadecimal offsets (both code-labels
and variables) appearing in debugger output and constructs a cross-reference
table with declarations of variables in the format:

     V_XXXX    LABEL    <TYPE> ; R_XXXX, R_XXXX, ...

     where <TYPE> is BYTE, WORD or DWORD
     and the R_XXXX's are the locations where the variable
     occurs in the code.

Usage of a memory location as more than one type (referenced both as a
BYTE and as a WORD for instance) results in multiple entries in the this table.

However, segment declarations are not generated and intersegment references are
not detected (this is an invitation, of cause).

Useful for deciphering ROM's of which the manufacturer failed to publish a
proper listing (for instance my PARADISE Graphics card, which makes improper
 use of the NMI line (IOCHK) on my PC).

I also managed to regenerate the missing part of the AT BIOS Listing this way
(PC-AT Technical Reference, POST6 routine). I never saw a supplement from IBM
here.
If anyone is interested (and if it is not illegal) I can also post it as an
example of the ouput generated by Deb2asm.

Please let me know,

P. Kranenburg. ([e-mail]).

---------- include file IO.INC ---- CUT HERE FOR IO.INC -------------
 procedure WriteHex(B: byte);
  const
     Hex: ARRAY [0 .. 15] OF CHAR = '0123456789ABCDEF';
  var
     i: integer;
  begin
    for i:= 1 downto 0 do
       write(Hex[((B shr (i shl 2)) and $000F)])
  end;
 procedure WritelnHex(B: byte);
  begin
    WriteHex(B);
    writeln
  end;
 procedure WriteHexInt(N: integer);
  begin
    WriteHex(N shr 8);
    WriteHex(N and $00FF)
  end;
 procedure WritelnHexInt(N: integer);
  begin
    WriteHex(N shr 8);
    WritelnHex(N and $00FF)
  end;
 procedure WriteAddress(N, M: integer);
  begin
    WriteHexInt(N);
    Write(':');
    WriteHexInt(M)
  end;
 procedure HexString(var Str; N: INTEGER);
  const
     Hex: ARRAY [0 .. 15] OF CHAR = '0123456789ABCDEF';
  var
     i: byte;
  begin
    for i:= 0 to Mem[Seg(Str):Ofs(Str)] - 1 do
      Mem[Seg(Str):(Ofs(Str)+Mem[Seg(Str):Ofs(Str)]-i)] :=
      Ord(Hex[((N shr (i shl 2)) and $000F)])
  end;

 procedure WriteDouble(High, Low: INTEGER);
 type
   LongInt = ARRAY [0..3] OF BYTE;
 const
   Divisors : ARRAY [0..9] OF LongInt    = ( (  0,   0,   0,   1),
                                             (  0,   0,   0,  $A),
                                             (  0,   0,   0, $64),
                                             (  0,   0,   3, $E8),
                                             (  0,   0, $27, $10),
                                             (  0,   1, $86, $A0),
                                             (  0,  $F, $42, $40),
                                             (  0, $98, $96, $80),
                                             (  5, $F5, $E1,   0),
                                             ($3B, $9A, $CA,   0)  );
 var
   i, j       : INTEGER;
   CharOffset,
   Digit      : BYTE;
   Rep        : ARRAY [0..9] OF CHAR;
   Number     : LongInt absolute Low;
   OldNumber  : LongInt;
   stop       : BOOLEAN;
 begin
   CharOffset := Ord(' ');
   OldNumber := Number;
   Rep := '          ';
   for i:=9 downto 0 do begin
     Digit := 0;
     Number := OldNumber;
     stop := false;
     repeat
       (* subtract Divisor from TestNumber *)
        for j:=0 to 3 do begin
          Number[j] := Number[j] - Divisors[i][3-j];
          if (Number[j] > OldNumber[j]) AND (j<>3) then
              Number[j+1] := number[j+1] - 1;
        end;
       if (Number[3] <= OldNumber[3]) then begin
         Digit := succ(Digit);
         CharOffset := Ord('0');
         OldNumber := Number
       end
       else stop := true;
     until stop;
     Rep[9-i] := Chr(CharOffset+Digit);
   end;
   Write(Rep)
 end;

procedure ComOut(var par);
const
  WriteCommand = 1;
var
  regs: RECORD
         AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: INTEGER
        END;
  B : BYTE absolute par;
begin
  with Regs do begin
    AX := (WriteCommand shl 8) + B;
    DX := 0;
    Intr($14, Regs);
  end
end;


procedure BlockRead (var f: file; var buffer; var n: integer);
const
  readfunction = $3F;

var
  regs: RECORD
         AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: INTEGER
        END;

begin
  with Regs do begin
    AX := (readfunction shl 8);
    BX := MemW[Seg(f):Ofs(f)];
    CX := n;
    DX := Ofs(buffer);
    DS := Seg(buffer);
    Intr($21, Regs);
    if (Flags and $0001) = 1 then begin
       write('I/O Error ');
       writeHex(AX shr 8);
       writeln (' during BlockRead');
     end
    else
     n := AX
  end;
end;

function FileSize (var f: file): INTEGER;
const
  seekfunction      = $42;
  from_begin    = 0;
  from_current  = 1;
  from_end      = 2;

var
  regs: RECORD
         AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: INTEGER
        END;
  CurrentFilePointer_low,
  CurrentFilePointer_high : INTEGER;

begin
  with Regs do begin
    AX := (seekfunction shl 8) + from_current;
    BX := MemW[Seg(f):Ofs(f)];   (* handle ! *)
    CX := 0;       (* offset-high *)
    DX := 0;       (* offset-low  *)
    Intr($21, Regs);
    if (Flags and $0001) = 1 then begin
       write('I/O Error ');
       writeHex(AX shr 8);
       writeln (' during FileSize');
     end;
    CurrentFilePointer_low := AX;
    CurrentFilePointer_high := DX;
    (* determine file size *)
    AX := (seekfunction shl 8) + from_end;
    BX := MemW[Seg(f):Ofs(f)];   (* handle ! *)
    CX := 0;       (* offset-high *)
    DX := 0;       (* offset-low  *)
    Intr($21, Regs);
    if (Flags and $0001) = 1 then begin
       write('I/O Error ');
       writeHex(AX shr 8);
       writeln (' during FileSize');
     end;
    FileSize := AX;
    (* restore FilePointer *)
    AX := (seekfunction shl 8) + from_begin;
    BX := MemW[Seg(f):Ofs(f)];   (* handle ! *)
    CX := CurrentFilePointer_high;
    DX := CurrentFilePointer_low;
    Intr($21, Regs);
    if (Flags and $0001) = 1 then begin
       write('I/O Error ');
       writeHex(AX shr 8);
       writeln (' during FileSize');
     end;
  end
end;


procedure BlockWrite (var f: file; var b; var n: integer);
const
  writefunction = $40;

var
  regs: RECORD
         AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: INTEGER
        END;

begin
  with Regs do begin
    AX := (writefunction shl 8);
    BX := MemW[Seg(f):Ofs(f)];
    CX := n;
    DX := Ofs(b);
    DS := Seg(b);
    Intr($21, Regs);
    if (Flags and $0001) = 1 then begin
       write('I/O Error ');
       writeHex(AX shr 8);
       writeln (' during BlockWrite');
     end
  end;
end;

procedure Open(var f: file; VAR Name);
const
 OpenFunction = $3D;
 OpenMode = 128; (* read only *)

var
  FName: STRING [255] ABSOLUTE Name;
  regs: RECORD
         AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: INTEGER
        END;

begin
  FName := FName + chr (0);
  with Regs do begin
    AX := (OpenFunction shl 8) + OpenMode;
    DX := Ofs (FName) + 1;
    DS := Seg (FName);
    Intr($21, Regs);
    MemW [Seg (f) : Ofs (f)] := AX;
    if (Flags and $0001) = 1 then begin
       write('I/O Error ');
       writeHex(AX shr 8);
       writeln (' during Reset');
     end
 end
end;

----------- start of source ---- CUT HERE FOR DEB2ASM.PAS -------------
(*                                                              *)
(*   DEB2ASM takes disassembly listings from DOS DEBUG and      *)
(*   produces more legible assembly-style listing including     *)
(*   a cross-reference table.                                   *)
(*                                                              *)
(*   author:          P. Kranenburg                             *)
(*                    University of Leiden, Holland             *)
(*                    [e-mail]                   *)
(*                                                              *)
(*   source:          TURBO pascal                              *)
(*   includes files:  SORT.BOX  from TURBO TOOLBOX              *)
(*                    IO.INC I/O routines                       *)
(*                                                              *)
(*   input:           file with disassembly output from DEBUG   *)
(*                    default extension .DEB                    *)
(*   output:          default extension .DBO                    *)
(*                                                              *)
(*                                                              *)
(*   Labels appear in the form  L_XXXX (where XXXX is           *)
(*   the hexadecimal value according to the DEBUG-output        *)
(*                                                              *)
(*   Variables take the form  V_XXXXT                           *)
(*   where XXXX is again a hex value and T is the type          *)
(*       either B, W or D (for BYTE, WORD and DWORD)            *)
(*                                                              *)
(*   In the cross-reference table the variables appear in       *)
(*   one or more entries as:                                    *)
(*                                                              *)
(*     V_XXXX    LABEL    <TYPE> ; R_XXXX, R_XXXX, ...          *)
(*                                                              *)
(*   where <TYPE> is BYTE, WORD or DWORD                        *)
(*   and the R_XXXX's are the locations where the variable      *)
(*   occurs in the code                                         *)
(*                                                              *)
(*                                                              *)
(*   The code has in places be optimized for speed:             *)
(*     - use of GOTO's to break out of loops                    *)
(*     - avoidance of STRING compares                           *)
(*       ie.          case STR[1]                               *)
(*                       'L': if STR='LOOP' then ...            *)
(*                       'J': if STR='JMP'  then ...   etc.     *)
(*                        ...                                   *)
(*                                                              *)
(*       in stead of: if STR='LOOP' then ...                    *)
(*                    else if STR='JMP' then ...                *)
(*                                                              *)
(*  Note: constants appearing in disassembly are not            *)
(*        converted to decimal nor suffixed with an 'H'         *)
(*                                                              *)

const
  blank     = ' ';
  tab       = #9;
  comma     = ',';
  colon     = ':';
  semicolon = ';';

type
  STR4  = STRING[4];
  STR5  = STRING[5];
  STR6  = STRING[6];
  STR12 = STRING[12];
  STR18 = STRING[18];
  STR80 = STRING[80];
  ReferenceTypes = (None, B, W, D, N, F);
  ParseTypes = RECORD
                 Offset       : STR4;
                 HexCode      : STR12;
                 OpCode       : STR6;
                 Operand1,
                 Operand2     : STR12;
                 Comment      : BYTE;   (* position where comment starts *)
                 TypeOverride : ReferenceTypes
               END;

var
  f_in, f_out : text[$2000];
  Line        : STR80;
  LineCount,
  CharPos     : INTEGER;
  FileName    : STR80;
  FileExt     : BOOLEAN;
  Rep         : ARRAY [ReferenceTypes] OF STR5;
  ParsedLine  : ParseTypes;

(*$I <path>\io.inc *)
(*$I <path>\sort.box *)

  const
   SymbolTableSize = 2000;

  type
   TableEntry = RECORD
                  offset,
                  reference : INTEGER;
                  reftype   : ReferenceTypes;
                  position  : BYTE
                END;


  var
   SymbolTable,
   AuxTable      : ARRAY [0 .. SymbolTableSize] OF TableEntry;

   Current_SymbolTable_Index,
   Symbol_Table_Length,
   SortInputIndex,
   SortOutputIndex,
   SortStatus                  : INTEGER;


(* TOOLBOX SORT interface *)

  procedure Inp;
  begin
    while SortInputIndex < Symbol_Table_Length do begin
      SortRelease(SymbolTable[SortInputIndex]);
      SortInputIndex := succ(SortInputIndex)
    end;
  end;

  procedure Outp;
  begin
    while (NOT SortEOS) AND (SortOutputIndex <= Symbol_Table_Length) do begin
      SortReturn(AuxTable[SortOutputIndex]);
      SortOutputIndex := succ(SortOutputIndex) ;
    end;
  end;

  function Less;
  var
    Entry1 : TableEntry absolute X;
    Entry2 : TableEntry absolute Y;
  begin
    if Entry1.reference = Entry2.reference then
      Less := Ord(Entry1.reftype) < Ord(Entry2.reftype)
    else (* compare the Entries as unsigned integers *)
        if ((Entry1.reference XOR Entry2.reference) AND $8000) = 0 then
           Less := Entry1.reference < Entry2.reference
        else if (Entry1.reference AND $8000)= $8000 then Less := false
                                                    else Less := true;
  end;



  procedure StoreReference(_Offset, _Label: INTEGER; _RefType: ReferenceTypes;
                           _position: BYTE);

  (* This procedure keeps a table of locations referenced *)
  (* including the type of reference                      *)

  begin
   (* if _RefType = N then begin
      write('label at ');
      writeHexInt(_Offset); write('  value: ');
      writeHexInt(_Label);
    end else begin
      write('var ref at ');
      writeHexInt(_Offset); write('  to location ');
      writehexint(_Label);
      write('  type: ', rep[_RefType]);
    end;
   *)
    with SymbolTable[Current_SymbolTable_Index] do begin
      offset  := _Offset;
      reference  := _Label;
      reftype := _RefType;
      position := _position
    end;
    Current_SymbolTable_Index := succ(Current_SymbolTable_Index);
    if Current_SymbolTable_Index = SymbolTableSize then begin
      writeln(' SymbolTable overflow ..., program halted');
      halt
    end;
  end;


    procedure ParseLine(var Result: ParseTypes);
    (* Parses one line of disassembly output *)
    label
      EndParseLine;

    type
      CharSet = SET OF CHAR;

    const
      U : CharSet = [#0 .. #$FF];

    var
      j, k : INTEGER;

      procedure SkipBT;   (* Skip blanks and tabs *)
      label
       EndSkip;
      begin
         while CharPos <= Ord(Line[0]) do begin
           case Line[CharPos] of
             blank: CharPos := succ(CharPos);
             tab:   CharPos := succ(CharPos)
             else   goto EndSkip
           end
         end;
      EndSkip: end;
      procedure SkipBTC;   (* Skip blanks, tabs and commas *)
      label
       EndSkip;
      begin
         while CharPos <= Ord(Line[0]) do begin
           case Line[CharPos] of
             blank: CharPos:=succ(CharPos);
             comma: CharPos:=succ(CharPos);
             tab:   CharPos:=succ(CharPos)
             else goto EndSkip
           end
         end;
      EndSkip: end;
      procedure SkipUBT;
      label
       EndSkip;
      begin
        (* Structered code was:                                             *)
        (*                                                                  *)
        (* while (Line[CharPos] IN U-[blank,tab,semicolon]) do              *)
        (*   CharPos:=succ(CharPos)                                         *)
        (* while ( (Line[CharPos] <> blank) AND (Line[CharPos] <> tab)      *)
        (*        AND (Line[CharPos] <> semicolon) )                        *)
        (*        AND (CharPos <= Length(Line)) do CharPos:= succ(CharPos); *)

         while CharPos <= Ord(Line[0]) do begin
           case Line[CharPos] of
             blank:     goto EndSkip;
             tab:       goto EndSkip;
             semicolon: goto EndSkip
             else       CharPos := succ(CharPos)
           end
         end;
      EndSkip: end;
      procedure SkipUBTC;
      label
       EndSkip;
      begin
        (* !! Structered code was:                                       *)
        (*                                                               *)
        (* while (     (Line[CharPos] <> blank)                          *)
        (*         AND (Line[CharPos] <> tab)                            *)
        (*         AND (Line[CharPos] <> comma)                          *)
        (*         AND (Line[CharPos] <> semicolon)                      *)
        (*         AND (CharPos <= Length(Line)       )  do              *)
        (*  CharPos:= succ(CharPos);                                     *)

         while CharPos <= Ord(Line[0]) do begin
           case Line[CharPos] of
             blank:     goto EndSkip;
             comma:     goto EndSkip;
             tab:       goto EndSkip;
             semicolon: goto EndSkip
             else       CharPos := succ(CharPos)
           end
         end;
      EndSkip: end;

      function Stop: BOOLEAN;
      begin
        (* code was:   Stop :=    (Line[CharPos]=semicolon)           *)
        (*                     OR (CharPos > Length(Line)  )          *)
        (* remark: this function should perhaps be inline             *)

        if CharPos > Ord(Line[0]) then Stop := true
        else if Line[CharPos] = semicolon then begin
                                           Stop := true;
                                           Result.Comment := CharPos
                                         end
             else Stop := false
      end;

      function Appropriate: BOOLEAN;
      (* Find out whether the current line should be parsed *)
      var
        k: INTEGER;
      begin
        CharPos := 1;
        if (Length(Line)<5) OR (Line[1]='-') then Appropriate := false
        else begin
          k := 1;
          while NOT (Line[k] IN [colon, semicolon]) AND (k<6) do k:= succ(k);
          if Line[k] <> semicolon then begin
            Appropriate := true;
            if Line[k] = colon then begin
              CharPos := k + 1;
            end
          end else begin
            Appropriate := false;
            Result.Comment := k
          end
        end
      end;


    begin (* ParseLine *)
      with Result do begin
        TypeOverride := None;
        Offset[0]    := Chr(0);
        HexCode[0]   := Chr(0);
        OpCode[0]    := Chr(0);
        Operand1[0]  := Chr(0);
        Operand2[0]  := Chr(0);
        Comment := Ord(Line[0]) + 1;

        if NOT Appropriate then goto EndParseLine;

        SkipBT; if Stop then goto EndParseLine;
        k := CharPos;
        SkipUBT;
      (*  Offset := Copy(Line, k, CharPos-k); *)
        Offset[0] := Chr(CharPos-k);
        Move(Line[k], Offset[1], CharPos-k);

        SkipBT; if Stop then goto EndParseLine;
        k := CharPos;
        SkipUBT;
        (* HexCode := Copy(Line, k, CharPos-k); *)
        HexCode[0] := Chr(CharPos-k);
        Move(Line[k], HexCode[1], CharPos-k);


        SkipBT; if Stop then goto EndParseLine;
        k := CharPos;
        SkipUBT;
      (*  OpCode := Copy(Line, k, CharPos-k); *)
        OpCode[0] := Chr(CharPos-k);
        Move(Line[k], OpCode[1], CharPos-k);

        SkipBT; if Stop then goto EndParseLine;
        (* at first operand *)
        k := CharPos;
        SkipUBTC;
      (*  Operand1 := Copy(Line, k, CharPos-k); *)
        Operand1[0] := Chr(CharPos-k);
        Move(Line[k], Operand1[1], CharPos-k);
        case Operand1[1] of
        'B': if Operand1 = 'BYTE' then begin
               TypeOverride := B;
               SkipBT; if Stop then goto EndParseLine;
               SkipUBT;
               SkipBT; if Stop then goto EndParseLine;
               k := CharPos;
               SkipUBTC;
             (*  Operand1 := Copy(Line, k, CharPos-k); *)
               Operand1[0] := Chr(CharPos-k);
               Move(Line[k], Operand1[1], CharPos-k);
             end;
        'W': if Operand1 = 'WORD'  then begin
               TypeOverride := W;
               SkipBT; if Stop then goto EndParseLine;
               SkipUBT;
               SkipBT; if Stop then goto EndParseLine;
               k := CharPos;
               SkipUBTC;
             (*  Operand1 := Copy(Line, k, CharPos-k); *)
               Operand1[0] := Chr(CharPos-k);
               Move(Line[k], Operand1[1], CharPos-k);
             end;
        'D': if Operand1 = 'DWORD' then begin
               TypeOverride := D;
               SkipBT; if Stop then goto EndParseLine;
               SkipUBT;
               SkipBT; if Stop then goto EndParseLine;
               k := CharPos;
               SkipUBTC;
             (*  Operand1 := Copy(Line, k, CharPos-k); *)
               Operand1[0] := Chr(CharPos-k);
               Move(Line[k], Operand1[1], CharPos-k);
             end;
        'F': if Operand1 = 'FAR'   then begin
               TypeOverride := F;
               SkipBT; if Stop then goto EndParseLine;
               k := CharPos;
               SkipUBTC;
             (*  Operand1 := Copy(Line, k, CharPos-k); *)
               Operand1[0] := Chr(CharPos-k);
               Move(Line[k], Operand1[1], CharPos-k);
             end;
        end;
        SkipBTC; if Stop then goto EndParseLine;
        (* second operand *)
        k := CharPos;
        SkipUBTC;
      (*  Operand2 := Copy(Line, k, CharPos-k); *)
        Operand2[0] := Chr(CharPos-k);
        Move(Line[k], Operand2[1], CharPos-k);
        (* check for type override operators *)
        case Operand2[1] of
        'B': if Operand2 = 'BYTE' then begin
               TypeOverride := B;
               SkipBT; if Stop then goto EndParseLine;
               SkipUBT;
               SkipBT; if Stop then goto EndParseLine;
               k := CharPos;
               SkipUBTC;
             (*  Operand2 := Copy(Line, k, CharPos-k); *)
               Operand2[0] := Chr(CharPos-k);
               Move(Line[k], Operand2[1], CharPos-k);
             end;
        'W': if Operand2 = 'WORD'  then begin
                TypeOverride := W;
                SkipBT; if Stop then goto EndParseLine;
                SkipUBT;
                SkipBT; if Stop then goto EndParseLine;
               k := CharPos;
               SkipUBTC;
             (*  Operand2 := Copy(Line, k, CharPos-k); *)
               Operand2[0] := Chr(CharPos-k);
               Move(Line[k], Operand2[1], CharPos-k);
             end;
        'D': if Operand2 = 'DWORD' then begin
                TypeOverride := D;
                SkipBT; if Stop then goto EndParseLine;
                SkipUBT;
                SkipBT; if Stop then goto EndParseLine;
               k := CharPos;
               SkipUBTC;
             (*  Operand2 := Copy(Line, k, CharPos-k); *)
               Operand2[0] := Chr(CharPos-k);
               Move(Line[k], Operand2[1], CharPos-k);
             end;
        'F': if Operand2 = 'FAR'   then begin
               TypeOverride := F;
               SkipBT; if Stop then goto EndParseLine;
               k := CharPos;
               SkipUBTC;
             (*  Operand2 := Copy(Line, k, CharPos-k); *)
               Operand2[0] := Chr(CharPos-k);
               Move(Line[k], Operand2[1], CharPos-k);
             end
        end
      end;
    EndParseLine: end;


  procedure Pass1;
  var
    _Offset,
    _Label, _Mem,
    Status         : INTEGER;

  function OperandType(var Operand: STR12): ReferenceTypes;
  begin
    case Operand[2] of
     'X': case Operand[1] of
            'A': OperandType := W;
            'B': OperandType := W;
            'C': OperandType := W;
            'D': OperandType := W
          end;
    'S':  case Operand[1] of
            'C': OperandType := W;
            'D': OperandType := W;
            'E': OperandType := W;
            'S': OperandType := W
          end;
    'L': case Operand[1] of
           'A': OperandType := B;
           'B': OperandType := B;
           'C': OperandType := B;
           'D': OperandType := B
         end;
    'H': case Operand[1] of
           'A': OperandType := B;
           'B': OperandType := B;
           'C': OperandType := B;
           'D': OperandType := B
         end;
    'I': case Operand[1] of
           'S': OperandType := W;
           'D': OperandType := W
         end;
    'P': case Operand[1] of
           'B': OperandType := W;
           'S': OperandType := W
         end
   end (* case *)
  end;

  procedure MemoryOperand(var Operand, OperandX: STR12; Position: BYTE;
                                                 ExplicitType: ReferenceTypes);
  begin
    if (Ord(Operand[0])=6) then begin
     if (Operand[1] = '[') AND (Operand[6] = ']') then begin
       Val ( '$'+Copy(Operand, 2, 4), _Mem, Status);
       if Status = 0 then begin (* valid 4 digit hex number *)
         case ExplicitType of
           N: ExplicitType := W; (* indirect jump or call *)
           F: ExplicitType := D  (* far indirect jump or call *)
         end;
         if (ExplicitType <> None) then
           StoreReference (_Offset, _Mem, ExplicitType, Position)
         else
           StoreReference (_Offset, _Mem, OperandType(OperandX), Position);
       end  (* valid memory operand *)
     end   (* [,] *)
    end  (* length = 6 *)
  end;

  begin (* Pass 1 *)
    gotoXY(1,25); Write('Pass 1  , Line ');
    LineCount := 0;
    while NOT EOF(f_in) do begin
      readln(f_in, Line);
      LineCount := succ(LineCount);
      if (LineCount and $000F) = 0 then begin
         gotoXY(16,25);
         write(LineCount:3)
      end;
      ParseLine(ParsedLine);
      with ParsedLine do begin
         (****
           gotoxy(12,wherey);writeln(offset,'|','|',opcode,'|',
                                   operand1,'|',operand2,'|');
          ****)
        Val ( '$'+Offset, _Offset, Status);
        if Status = 0 then begin
         Status := -1;
         (* check for opcodes with CODE_LABEL operands *)
         case OpCode[1] of
            'J': begin
                   Val ( '$'+Operand1, _Label, Status);
                   if Status <> 0 then begin
                     if (OpCode = 'JMP') AND (TypeOverride=None) then
                       TypeOverride := N;   (* try indirect NEAR jump *)
                   end
                 end;
            'C': if OpCode = 'CALL' then begin
                   Val ( '$'+Operand1, _Label, Status);
                   if (Status <> 0) AND (Operand1[5]=':') then begin
                     Val('$'+Copy(Operand1, 6, 4), _Label, Status);
                     if Status = 0 then StoreReference (_Offset, _Label, F, 1);
                     Status := -1;
                   end
                 end;
            'L': if (OpCode = 'LOOP')  OR
                    (OpCode = 'LOOPZ') OR (OpCode = 'LOOPNZ')
                   then Val ( '$'+Operand1, _Label, Status);
            'P': if OpCode = 'PUSH' then TypeOverride := W
                 else if OpCode = 'POP' then TypeOverride := W;
         end (* case *);
         if Status = 0 then begin (* valid near label *)
           StoreReference (_Offset, _Label, N, 1)
         end;

         MemoryOperand(Operand1, Operand2, 1, TypeOverride);
         MemoryOperand(Operand2, Operand1, 2, TypeOverride);

        end (* valid offset *)
      end (* with ParsedLine *)
    end (* while *);
    gotoXY(16,25); write(LineCount:3);
  end (* Pass 1 *);


  procedure Pass2;
  type
    PrefixTypes = (NoPrefix, REP, REPZ, REPNZ, LOCK, CS, DS, ES, SS);
  var
    k, _Offset,
    NextOffset,
    NextRef,
    Status      : INTEGER;
    Prefix      : PrefixTypes;
    ASMLine     : STR80;

  function TestPrefix: BOOLEAN;
  var
    HexByte, Status: INTEGER;
  begin
    case ParsedLine.OpCode[3] of  (* test for prefix opcodes *)
      ':', 'P', 'C' : begin
          Val('$'+ParsedLine.HexCode, HexByte, Status);
          case HexByte of
           $2E: begin Prefix := CS;    TestPrefix := true end;
           $26: begin Prefix := ES;    TestPrefix := true end;
           $3E: begin Prefix := DS;    TestPrefix := true end;
           $36: begin Prefix := SS;    TestPrefix := true end;
           $F2: begin Prefix := REPNZ; TestPrefix := true end;
           $F3: begin Prefix := REPZ;  TestPrefix := true end;
           $F0: begin Prefix := LOCK;  TestPrefix := true end;
           else TestPrefix := false
          end
      end
      else TestPrefix := false
    end;
  end;

  begin (* Pass 2 *)
    gotoXY(1,25); Write('Pass 2  , Line ');
    NextOffset := 0;
    NextRef := 0;
    Prefix := NoPrefix;
    LineCount := 0;
    while NOT EOF(f_in) do begin
      readln(f_in, Line);
      LineCount := succ(LineCount);
      if (LineCount and $000F) = 0 then begin
         gotoXY(16,25);
         write(LineCount:3)
      end;

      ParseLine(ParsedLine);

      if NOT TestPrefix then begin
        with ParsedLine do begin
          if (Prefix = REPZ) OR (Prefix = REPNZ) then begin
            if (Opcode[1] IN ['M', 'L', 'S']) AND (Ord(OpCode[0])<>0) then
              Prefix := REP
          end;
        Val ( '$'+Offset, _Offset, Status);
        if Status = 0 then begin
         if _Offset = SymbolTable[NextOffset].offset then begin
           case SymbolTable[NextOffset].reftype of
             N:     begin
                      Move(Operand1[1], Operand1[3], 4);
                      Operand1[0] := succ(succ(Operand1[0]));
                      Operand1[1] := 'L';
                      Operand1[2] := '_';
                    end;
             B,W,D: begin
                      if SymbolTable[NextOffset].position = 1 then begin
                        Operand1[1] := 'V';
                        Operand1[6] := '_';
                      end else begin
                        Operand2[1] := 'V';
                        Operand2[6] := '_';
                      end
                    end;
           end;
           NextOffset := succ(NextOffset);
         end;
         while AuxTable[NextRef].reference < _Offset do
            NextRef := succ(NextRef);
         while _Offset = AuxTable[NextRef].reference do begin
           case AuxTable[NextRef].reftype of
             N:     begin
                      Writeln(f_out, '  L_'+ Offset+':');
                    end;
             B:     begin
                      Writeln(f_out, '  V_'+ Offset+tab+'DB', tab, '?');
                    end;
             W:     begin
                      Writeln(f_out, '  V_'+ Offset+tab+'DW', tab, '?');
                    end;
             D:     begin
                      Writeln(f_out, '  V_'+ Offset+tab+'DD', tab, '?');
                    end;

           end;
           repeat NextRef:=succ(NextRef)
           until (AuxTable[NextRef].reftype <> AuxTable[NextRef-1].reftype) OR
                 (_Offset <> AuxTable[NextRef].reference) OR
                 (NextRef >= Symbol_Table_Length);
         end;
         if Offset[0] <> Chr(0) then begin
         write(f_out, tab, tab);
         case Prefix of
          REP:  begin
                  write(f_out, 'REP ');
                  Prefix := NoPrefix
                end;
          REPZ: begin
                  write(f_out, 'REPZ ');
                  Prefix := NoPrefix
                end;
          REPNZ:begin
                  write(f_out, 'REPNZ ');
                  Prefix := NoPrefix
                end;
          LOCK: begin
                  write(f_out, 'LOCK ');
                  Prefix := NoPrefix
                end;
         end;
         write(f_out, OpCode, tab);
         if Ord(Operand1[0]) > 2 then begin
           case TypeOverride of
            None: ;
            B   : write(f_out, 'BYTE PTR ');
            W   : write(f_out, 'WORD PTR ');
            D   : write(f_out, 'DWORD PTR ');
            F   : write(f_out, 'FAR PTR ');
           end;
           case Prefix of
             NoPrefix: ;
              CS: begin write(f_out, 'CS:'); Prefix := NoPrefix end;
              ES: begin write(f_out, 'ES:'); Prefix := NoPrefix end;
              SS: begin write(f_out, 'SS:'); Prefix := NoPrefix end;
              DS: begin write(f_out, 'DS:'); Prefix := NoPrefix end;
           end;
         end;
         write(f_out, Operand1);
         if Operand2[0]<>Chr(0) then begin
             write(f_out, ', ');
         if Ord(Operand2[0]) > 2 then begin
           case TypeOverride of
            None: ;
            B   : write(f_out, 'BYTE PTR ');
            W   : write(f_out, 'WORD PTR ');
            D   : write(f_out, 'DWORD PTR ');
            F   : write(f_out, 'FAR PTR ');
           end;
           case Prefix of
            NoPrefix: ;
              CS: begin write(f_out, 'CS:'); Prefix := NoPrefix end;
              ES: begin write(f_out, 'ES:'); Prefix := NoPrefix end;
              SS: begin write(f_out, 'SS:'); Prefix := NoPrefix end;
              DS: begin write(f_out, 'DS:'); Prefix := NoPrefix end;
           end;
         end;
             write(f_out, Operand2);
         end
         else write(f_out, tab);
         end;
         if Comment <= Ord(Line[0]) then
           writeln(f_out, tab, Copy(Line, comment, Ord(Line[0])+1-comment))
         else
           writeln(f_out)
        end (* valid offset *)
      end (* with *)
      end
      end;
    gotoXY(16,25); write(LineCount:3);
  end (* Pass2 *);

  procedure CrossRefList;
  var
    OffsetStr, RefStr: STR4;
    k: INTEGER;

  begin
    writeln(f_out, '    *******   writing cross reference listing  ******');
    writeln(f_out);
    CharPos:= 0;
    while CharPos<= (symbol_table_length-1) do begin
      with AuxTable[CharPos] do begin
        OffsetStr[0] := Chr(4); RefStr[0] := Chr(4);
        HexString(OffsetStr, reference);
        HexString(RefStr, offset);
        case reftype of
        (*   N: Write(f_out, 'L_', OffsetStr, 'N', tab, 'LABEL', tab, 'NEAR',
                           '  ; R_', RefStr);
         *)
           B: Write(f_out, 'V_', OffsetStr, 'B', '    ', 'LABEL', tab, 'BYTE',
                           tab, '; R_', RefStr);
           W: Write(f_out, 'V_', OffsetStr, 'W', '    ', 'LABEL', tab, 'WORD',
                           tab, '; R_', RefStr);
           D: Write(f_out, 'V_', OffsetStr, 'D', '    ', 'LABEL', tab, 'DWORD',
                           tab, '; R_', RefStr);
           F: Write(f_out, 'L_', OffsetStr, 'F', '    ', 'LABEL', tab, 'FAR',
                           tab, '; R_', RefStr);
        end;
   (*
        writehexint(reference);write('  ');
        writehexint(offset);write('  ');
        write(rep[reftype]);write('  ');
        writeln(position:2);
   *)
        CharPos:=succ(CharPos);
        k := 1;
        while (reftype = AuxTable[CharPos].reftype) AND
              (reference = AuxTable[CharPos].reference) AND
              (CharPos<= Symbol_Table_Length - 1)
        do begin
          if reftype <> N then begin
            HexString(RefStr, AuxTable[CharPos].offset);
            if k = 5 then begin
                            k:=0;
                            writeln(f_out);
                            write(f_out, tab,tab,tab,tab, '; R_', RefStr) end
                     else write(f_out, ' ,R_', RefStr);
            k := succ(k)
          end;
          CharPos:= succ(CharPos)
        end;
        if reftype <> N then writeln(f_out);
      end;
    end;
    writeln(f_out);
  end;

begin
  rep[none]:='NONE';
  rep[B]:='BYTE';rep[W]:='WORD';rep[D]:='DWORD';
  rep[N]:='NEAR';rep[F]:='FAR';
  Current_SymbolTable_Index:= 0;
  write('Enter filename: '); readln(FileName);
  FileExt := false;
  for CharPos:=1 to Length(FileName) do FileExt := FileName[CharPos] = '.';

  if FileExt then assign(f_in, FileName)
             else assign(f_in, FileName+'.DEB');

  (* start pass 1 *)
  reset(f_in);
  Pass1;
  Symbol_Table_Length := Current_SymbolTable_Index;
  Current_SymbolTable_Index := 0;
  Writeln;
  Writeln(Symbol_Table_Length, ' symbols');
  (* Sort symboltable *)

  SortInputIndex := 0;
  SortOutputIndex := 0;
  Writeln('Sorting symboltable ...');
  SortStatus := TurboSort(SizeOf(TableEntry));
  if SortStatus <> 0 then writeln('Error ', SortStatus:2, ' during sorting');

  if FileExt then begin
    CharPos:= 1;
    while FileName[CharPos] <> '.' do CharPos:= succ(CharPos);
    FileName := copy(FileName, 1, pred(CharPos));
  end;
  assign(f_out, FileName+'.DBO');
  rewrite(f_out);
  Writeln('Writing cross-reference');
  CrossRefList;

  (* start pass 2 *)
  reset(f_in);
  Pass2;
  close(f_out);
  close(f_in)
end.

-------------------- end --------------