PROGRAM disarel;
{
  Disassemble a 8080 or z80 .ERL or .REL file.

  AUTHOR:
        Professor Ronald E. Bruck
	Department of Mathematics
	University of Southern California
	Los Angeles, CA  90089

  Modified for Turbo Pascal by
        Clarence W. Wilkerson
        Department of Mathematics
        Wayne State University
        Detroit, Michigan 48202

        Adapted to Turbo syntax.
        1) Major problem is  8 bit code assumed pointers of 16 bits
        2) Supports 64k code ( -2 bytes ) now.
        3) Added -v option for dump of .REL file info as changing to
           code.


}

CONST
  tab	   = #9;
  bs       = #8;
  bell     = #7;
  argMark = '%';
{
  Maximum code size.  Maximum REL info size is 1/4 this:
}

  maxpc    = $FFFE; (* upped to max size*)
  maxrel   = $3fff;

  (* these arrays to simulate 16 bit pointers for 8080 code *)

  (* ref_types *)
  maxrefs  = $3ff; (* 1k pointers *)
  startrefs= $000;

  (* offset_types *)
  startoffs= $000; (* 1k pointers  *)
  maxoffs  = $3fF;

  abslute  = 0 ;
  code_rel = 1;
  data_rel = 2;
  common_rel = 3;


  relstr : array[false..true] of string[20] =
  (
    'ABSOLUTE  ',
    'RELATIVE  '
   );
  tipestr : array[0..3] of string[20] =
  ( 'ABSOLUTE   ',
    'CODE_REL   ',
    'DATA_REL   ',
    'COMMON_REL ');
  controlstr : array[0..15] of string[20] =
  ( 'Entry Symbol     ',
    'Select Common    ',
    'Program Name     ',
    'Library Request  ',
    'Reserved Future  ',
    'Common Size      ',
    'Chain External   ',
    'Define Entry     ',
    'External-Offset  ',
    'External+Offset  ',
    'Define Data Size ',
    'Set Loading Loc. ',
    'Chain Address    ',
    'Define Prog Size ',
    'End Program      ',
    'End File         '
  );

const power2 : array[0..15] of word = (1,2,4,8,16,32,64,128,256,512,1024,
       2048,$1000,$2000,$4000,$8000);

(* complement of powers of 2 *)

const copower2 : array[0..7] of byte = ($fe,$fd,$fb,$f7,$ef,$df,$bf,$7f);



TYPE

  buffer = array[0..maxpc] of byte;
  relbuffer = array[0..maxrel] of byte;
  bufferptr = ^buffer;   (* allocate these now *)
  relbufptr = ^relbuffer; (* allocate these *)
  small = 0..2;
  op_code_type =
    RECORD
      follow  : 0..2;		{ # bytes which follow opcode }
      name    : STRING [ 15 ];   { mnemonic for opcode }
    END;


  tipe_type = 0..3 ;

  a_field =
    RECORD
      tipe  : tipe_type;
      value : word;
    END;

  name_type = STRING [ 8 ];

  ms_item =
    RECORD
      rel     : BOOLEAN;
      value   : word;
      tipe    : tipe_type;
      control : word;
      a       : a_field;
      b       : name_type;
      link    : boolean;
    END;

  (* problem in translation : wants to think of ptr_to_ref as two byte *)
  (* quantity *)
  (* so let's allocate and store on a fixed array *)

  ptr_to_ref = 0..maxrefs;  (* just an integer so will fit *)

  ptrref =     ^ref_type; (* the real pointers *)

  ref_type =
    RECORD
      tipe : BYTE;
	{ Bit assignments:
		Bit 0 : 0 = code relative, 1 = data relative;
		Bit 1 : 0 = public name, 1 = private name.
	  Bit 1 is irrelevant if the item is placed in the chain
	  of external references.
	}
      value : word;
      name  : name_type;
      ptr   : ptr_to_ref;
             (* did point to next in the chain, however, now
                not a pointer, but index into an array of pointers
                      so that refs[refs[p]^.ptr] = pointer to next in the
                      chain *)
    END;

  ptr_to_offset = startoffs..maxoffs;
  ptroff = ^offset_type;
  offset_type =
    RECORD
      sign   : -1..+1;
      loc,
      offset : integer;
      next   : ptr_to_offset;
    END;

    refbuf = array[startrefs..maxrefs] of ptrref;
    offbuf = array[startoffs..maxoffs] of ptroff;
    refbufptr = ^refbuf;
    offbufptr = ^offbuf;
VAR
  totalbytes: longint;
  DUMPREL   : boolean; (* true to dump rel files as we go *)
  DODISAM   : boolean; (* true to dis-assemble *)
  BITSTREAM : boolean;(* true to show bits flying by on console *)

  mybyte:   word;  (* holding buffer for bitstream *)

  op_code_filename : array[0..2] of String[64];
  usetxt : small; (* 0 = 8080, 1 = Z80, 2 = default *)
  DUMP : boolean;
  refs :  refbuf; (* an array of pointers *)
  roff :  offbuf;
  repfactor,ii,numrefs, numoffs: word;
  myheap : pointer; (* to mark the space used on the heap *)
  pgm_name,
  in_f_name,
  out_f_name : STRING;
  item       : ms_item;
  ch         : CHAR;
  next_label,
  first_code_ref,
  last_code_ref,
  first_data_ref,
  last_data_ref,
  first_ext_ref,
  last_ext_ref   : ptr_to_ref;
  first_offset,
  last_offset,
  next_offset    : ptr_to_offset;
  n,
  pc, 			  { program counter   }
  final_pc,		  { last byte of code }
  old_mark,		  { mark top of heap  }
  pgm_size,
  data_size,
  result     : word;
  cur_bit    : integer;  (* is -1 when t underflows *)
  fbyte      : FILE OF BYTE;  (*  File of char does interpretation *)
  fout,fopcodes : TEXT;

  code_buffer: bufferptr;
  (* data_buffer: buffer;  *)
  (* common_buffer : buffer *)

  rel_info :   relbufptr;
  op_codes   : ARRAY [ 0..255 ] OF op_code_type;

  const hexdigit : array[0..15] of char = ('0','1','2','3','4','5','6','7',
                                           '8','9','A','B','C','D','E','F');


var maxoption,maxfile : word;
    option : array[1..255] of char;
    fileparam : array[1..10] of string;

procedure getparameters;
label 9922;
var i,j,k : integer;
    ch : char;
    s : string;
begin
  j:=0; k:=0;
  for i:=1 to paramcount do begin
     s:= paramstr(i);
     ch:=char(s[1]);
     if (ch= '-') or (ch ='+') then begin
        j:=j+1;
        if j > 255 then begin
           writeln('Too many options.');
           goto 9922;
        end;
        option[j]:= upcase(s[2]);
     end
     else begin
         k:=k+1;
         if k > 10 then begin
             writeln('Too many files.');
             goto 9922;
         end;
         fileparam[k]:=paramstr(i); (* is file name *)
     end;
    9922:
   end;
   maxfile:=k;
   maxoption:=j;
end; (* getparameters *)


procedure processoptions;
var i : word;
begin
  for i:=1 to maxoption do
     case option[i] of
        'V' : DUMPREL := true; (*  Verbose dump rel directives as we go *)
        'N' : DODISAM := false; (* disable disassembly *)
        'Z' : usetxt :=1;
        '8' : usetxt :=0;
        'B' : BITSTREAM:=true
        else begin writeln('Unknown option ',option[1]); end;
     end;
end; (* process_options *)

PROCEDURE errorhalt ( message : STRING );
BEGIN
  {$I-}
  CLOSE ( fbyte);
  CLOSE ( fout);
  {$I+}
  WRITELN;
  WRITELN (message );
  halt;
END;

PROCEDURE syntax_error;
VAR
  i : word;
BEGIN
  WRITELN ( 'Usage:');
  WRITELN;
  WRITELN ( 'DISAREL [-B] [-N] [-V] [-Z] [-8]  sourcepath' );
  WRITELN ( '  (routing output to STDOUT )' );
  WRITELN;
  WRITELN ( '  OR' );
  WRITELN;
  WRITELN ( 'DISAREL [-B] [-V] [-N] [-Z] [ -8] sourcepath destpath' );
  writeln (' where [-options] are    ');
  writeln (' -B  bitstream is dumped parsed by object format');
  writeln (' -V  verbose  show headers of .rel format ');
  WRITELN (' -N  no dis-assembly.');
  writeln (' -Z or -8  Z80 mnemonics or Intel mnemonics.');
  writeln;
  errorhalt(' Aborting program. Try again. ');
END { syntax_error };


PROCEDURE open_files;
VAR
  i : word;
BEGIN
  in_f_name:='';
  out_f_name:='CON';
  if maxfile = 2 then begin
     in_f_name:=fileparam[1];
     out_f_name:= fileparam[2];
  end;
  if maxfile = 1 then begin
    in_f_name:= fileparam[1];
  end;
  IF (in_f_name = '') THEN syntax_error;
  ASSIGN ( fbyte, in_f_name );
  {$I-}
  RESET ( fbyte );
  {$I+}
  IF IORESULT <> 0 THEN
  errorhalt ( CONCAT ( 'Unable to open file ', in_f_name, '.' ) );
  (* get opcodes *)
  ASSIGN ( fopcodes, op_code_filename[usetxt] );
  {$I-}
  RESET (fopcodes);
  {$I+}
  IF IORESULT <> 0 THEN  begin
    writeln('Unable to open ',op_code_fi;C/80 Compiler 3@0 (7/30/83) - (c) 1983 The Software Toolworks

	DSEG
struct:
	PUBLIC	struct
	DW	tree,0
	DB	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
	DB	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
	DB	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
	DB	0,0
	DW	0
:
	PUBLIC	
	CALL	main
	DW	char,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0
	DSEG
:
	PUBLIC	
	LXI	H,@c
	PUSH	H
	CALL	putstr
	POP	B
	PUSH	H
	LXI	H,c
	PUSH	H
	LXI	H,20
	PUSH	H
	CALL	getline
	POP	B
	POP	B
	PUSH	H
	CALL	while
	POP	B
	POP	B
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0
	DSEG
cmain
	DW	char,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,0,0
	DW	0,0,0,0,0,0,EMRELBUFPTRDEFINE_DATA_SIZEITEMALLOC_PTR_TO_REFPBITSNOP_CODE_TYPEFIRST_DATA_REFFIRST_CODE_REFPRINT_PUBLICSPDUMPOFFBUFDEFINE_ENTRY_POINTITEMIN_F_NAMESTARTOFFSLAST_EXT_REFNEXT_LABELREFBUFSMALLBUFFERMAXPCFBYTESTARTREFSMAXOPTIONPGM_SIZEUSECONSOLEREF_TYPEGET_A_FIELDAWRITE_REF_NAMEPCGET_B_FIELDBPOWER2NAME_TYPECLRBITXYOPEN_FILESFOUTCHAIN_ADDRESSITEMLIST_MS_ITEMXPROCESSOPTIONSA_FIELDHANDLE_SPECIALITEMMYHEAPARGMARKMAXFILECOUNTPPIITEMPVALUENFOUNDPSIZEINTIPEDVMDXYFNNBYTESWRITE_BYTEXICHJSKITEMITEMITEMXDATAQINDEXITEMPROOTLASTPPXYPPPNNBYTESXDATAQINDEXITEMQ1QSTOPJJJPNIDVMDPCANWRITEOPCODETEMPJJJTEXPECTPPFIRSTLASTW1W2ITEMNITEMPCPTIPEVALUENAMEPUBLICYYYIIIXXXITEMXDATAQINDEXMESSAGEITEMITEMPPPNMIPCOUNTITEMPANPCJJPBINXYIITEMQ1QSTOPJJPXNIITEMXLENICHDISAREL.PASSYSTEMBYTEREALSAVEINT00INOUTRESFREEPTROVRHEAPPTRTEXTOVRHEAPENDSAVEINT02OVRHEAPORGOVRCODElename[usetxt] );
    errorhalt ( 'DISAREL aborted. Check directory for opcode files.');
   end;
  writeln;
  writeln('Reading file of op-codes.');
  FOR i := 0 TO 255 DO
    BEGIN (* check on this *)
      READ ( fopcodes, op_codes [ i ].follow );
      READ ( fopcodes, ch );
      READLN ( fopcodes, op_codes [ i ].name );
    END;
  CLOSE ( fopcodes );

  (* get ready to write ouput *)
  ASSIGN ( fout, out_f_name );
  {$I-}
  rewrite(fout);
  {$I+}
  IF IORESULT <> 0 THEN errorhalt ( 'Unable to REWRITE output file.' );

END;



(* these are to deal to fetching and putting data into the code_buffer array *)
(* original code used block moves to do this *)

procedure put2bytes ( xdata : word; qindex : word);
begin
   code_buffer^[qindex]:= lo(xdata);
   code_buffer^[qindex+1]:=hi(xdata);
end;

procedure get2bytes ( var xdata : word; qindex : word);
begin
   if qindex > maxpc then errorhalt('Bad index in get2bytes.');
   xdata:= code_buffer^[qindex];
   xdata:= xdata  or ( word( code_buffer^[qindex+1]) shl 8);
end;

procedure get1byte(var  xdata : word ; qindex : word );
begin
  xdata:= word ( ( code_buffer^[qindex] ) and $ff) ;
end;

procedure put1byte( xdata : word; qindex : word );
begin
  code_buffer^[qindex]:= byte ( xdata and $ff);
end;

procedure write_nibb(var f : text; x : word);
begin
  write(f, hexdigit[ ( x and $0f)]);
end; (* write_byte *)

procedure write_byte(var f : text; x : word);
begin
  write(f, hexdigit[ ( x and $f0) shr 4 ]);
  write(f, hexdigit[ ( x and $0f)]);
end; (* write_byte *)

procedure write_hex ( var f : text;  n : word; nbytes :word );

(* local to write hex *)

procedure write_byte( x : word);
begin
  write(f, hexdigit[ ( x and $f0) shr 4 ]);
  write(f, hexdigit[ ( x and $0f)]);
end; (* write_byte *)

(* beginning  of write hex *)

begin
   if nbytes = 1 then write_byte(n)
   else begin
      write_byte( hi(n) );
      write_byte( lo(n));
   end;
end; (* write_hex *)

function tstbit( x : byte; y : word) : boolean;
begin
  y := y and $07;
  if x and power2[y] <> 0 then tstbit:=true else tstbit:=false;
end;

procedure clrbit( var x :byte; y : word) ;
begin
  y:=y and $07;
  x:= x and copower2[y];
end;

procedure setbit( var x :byte; y : word) ;
begin
  y:=y and $07;
  x :=  x or power2[y];
end;

(* the array  rel_info^[0.. maxpc/4] mirrors code_buffer^[0..maxpc] *)
(* each two bits contains a "type" for the corresponding byte in
   code_buffer *)

FUNCTION test_type ( n : word ) : word;
{
  Each item in the code buffer has associated with it two bits, meaning:
	00 = ABSOLUTE item, use this byte AS-IS;
	01 = CODE-RELATIVE item; relative to program base;
	10 = DATA-RELATIVE item; relative to data base;
	11 = POINTER; the two bytes point to a REF item in the heap
		giving more information.
}
VAR
  dv, md, i : word;
BEGIN
  dv := n shr 2; (* point to byte *)
  md := (n and 3) shl 1;  (* look at starting bits in this byte *)
  i := 0;    (* assume absolute *)
  if dv > maxrel then begin
       writeln(fout,'Here'' the problem ');
       i:=i+i;
   end;
(*     write(bell,bell,'Bad code pointer in test_type. ',n:6 ,'  ', dv:4);
     errorhalt('Halted in test_type .');
  end; *)
  IF TSTBIT ( rel_info^ [ dv ], md ) THEN i := i or 1;
  IF TSTBIT ( rel_info^ [ dv ], md + 1 ) THEN i := i or 2;
  test_type := i;
END;

PROCEDURE set_type ( n, tipe : word );
{
  SETS the two bits mentioned above to reflect tipe.
  Uses only the bottom two bits of tipe.
}
VAR
  dv, md : word;
BEGIN
  dv := n shr 2 ;
  md := ( n and 3 ) shl 1;
  if dv > maxrel then begin
     writeln(bell,bell,'Bad code pointer in set_type.');
     errorhalt('Halted in set_type .');
  end;
  IF TSTBIT ( tipe, 0 )
    THEN SETBIT ( rel_info^ [ dv ], md )
    ELSE CLRBIT ( rel_info^ [ dv ], md );
  IF TSTBIT ( tipe, 1 )
    THEN SETBIT ( rel_info^ [ dv ], md + 1 )
    ELSE CLRBIT ( rel_info^ [ dv ], md + 1 );
  if (test_type(n)) <> tipe then errorhalt('Bad set in set_type.');
END;


(* to get around get syntax*)




procedure putbits ( source,count: word);
var i : word;
    s : string[20];
begin
   s:='';
   if count > 16 then errorhalt('Too many bits in putbits.');
   for i:= (count -1) downto  0 do
      if power2[i] and source <> 0 then s:=s+'1' else s:=s+'0';
      s:=s+'B';
      writeln(s:20,'=',source:6,' using ',count:2,' bits. Total bytes=', totalbytes:6 );
end;
(* reads high order bit first *)

FUNCTION bit : word;
var bytebuffer : byte;
BEGIN
  IF cur_bit < 0 THEN
    BEGIN
      mybyte:=0;
      IF EOF ( fbyte ) THEN errorhalt ( '*** ERROR: Last byte read...' );
      read(fbyte,bytebuffer);
      mybyte:=word(bytebuffer) and $ff;
      totalbytes:= totalbytes + 1;
      cur_bit := 7;
    END;
    (* try just shifting left out of low byte of mybyte into upper *)
    mybyte:= mybyte shl 1;
    bit:= word ( hi ( mybyte));
    mybyte:= mybyte and $FF; (* back to lower 40 *)
    cur_bit := cur_bit - 1;
END;

(* returns the value of the next bit field of length n *)
(* n in range 0..16 *)

FUNCTION bits ( n : word ) : word;
VAR
  i, m : word;
BEGIN
  m := 0;
  if n > 16 then errorhalt('Too many bits requested in bits.');
  FOR i := 1 TO n DO m := ( m shl 1) or bit;
  bits := m;
  if BITSTREAM then  putbits(m,n);
END;

PROCEDURE get_a_field ( VAR a : a_field );
VAR
  n : word;
BEGIN
  n := bits ( 2 );
  CASE n OF
    0 : a.tipe := abslute;
    1 : a.tipe := code_rel;
    2 : a.tipe := data_rel;
    3 : a.tipe := common_rel;
  END;
  n := bits ( 16 );
  a.value := SWAP ( n ); (* read in low byte first *)
END;

PROCEDURE get_b_field ( VAR b : name_type );
VAR
  i, n : word;
BEGIN
  n := bits ( 3 );
  if n > 7 then errorhalt('Too large value for bits in get_b ');
  b:='';
  FOR i := 1 TO n DO b:= b + CHR(bits(8)and $7f);
  if BITSTREAM then writeln(b:10);
END;

PROCEDURE list_ms_item ( x : ms_item );
VAR
  n : word;
BEGIN

        write(fout,relstr[x.rel]);
        if not x.rel then begin
           write_hex(fout,word(x.value),1);
           writeln(fout,'H ');
           exit;
        end;
        case x.link of
	    TRUE  : BEGIN
                  write(fout,'LINK SPEC ');
                  write(fout,controlstr[x.control]);
		  CASE x.control OF
		    0,1,2,3 : begin (* B field only *)
                                  writeln(fout,x.b:8);
                                 end;
		    4 : begin (* B field only *)
                                  write_hex(fout,word(ord(x.b[0])),1);
                                  write(fout,'H ');
                                  writeln(fout,x.b:8);
                                 end;



5,6,7    : BEGIN (* A field and B field *)
                                  write(fout,tipestr[x.a.tipe]);
				  write_hex(fout,word(x.a.value),2);
				  writeln(fout,'H  ',x.b:8);
                                END;
		    8,9,10,11,  (* get_ms_ had 8 here ???? *)
		    12,13,14  : begin (* A field only *)
                                  write(fout,tipestr[x.a.tipe]);
				  write_hex(fout,word(x.a.value),2);
                                  writeln(fout,'H ');
                                 end;
		  END; (* case control *)
		END;    (* link special case *)
	    FALSE : BEGIN  (* was relative item, so print value field *)
                      write(fout,tipestr[x.tipe]);
	              write_hex(fout,word(x.value),2);
                      writeln(fout,'H ');
		    END;   (* code rel,data rel and common rel *)
	  END;  (* case link *)
END;  (* list_ms_item *)


PROCEDURE get_ms_item ( VAR myitem : ms_item );
VAR
  n : word;
BEGIN
  FILLCHAR ( item, SIZEOF ( ms_item ), CHR ( 0 ) );
  CASE bits(1) OF  (* make it go through bits so I can track it *)
    0 : BEGIN
          myitem.link:=false;
	  myitem.rel := FALSE;
	  myitem.value := bits(8);
	END;
    1 : BEGIN
	  myitem.rel := TRUE;
	  n := bits(2);
	  CASE n OF
	    0 : BEGIN      (* link control *)
                  myitem.control:=bits(4);
                  myitem.link:=true;
		  CASE myitem.control OF
		    0,1,2,3 : begin
                                  get_b_field ( myitem.b );
                                 end;
                          4:  begin
                                  write(bell,bell,'RESERVED');
                                  get_b_field ( myitem.b );
                              end;

		    5,6,7    : BEGIN
				  get_a_field ( myitem.a );
				  get_b_field ( myitem.b );
                                END;
		    8,9,10,11,  (* my Link80 manual says 8 belongs above, but
                                it's wrong   *)
		    12,13,14    : begin
                                   get_a_field ( myitem.a );
                                 end;
		  END;
		  IF myitem.control = 14 THEN cur_bit := -1;
		    { force to byte boundary }
		END;
	    1 : BEGIN   (* program rel *)
                  myitem.link:=false;
		  myitem.tipe := code_rel;
		  n := bits (16);
		  myitem.value := SWAP (n);
		END;

	    2 : BEGIN
		  myitem.link:=false;
		  myitem.tipe := data_rel;
		  n := bits (16);
		  myitem.value := SWAP (n);
		END;
	    3 : BEGIN
		  myitem.link:=false;
		  myitem.tipe := common_rel;
		  n := bits (16);
		  myitem.value := SWAP(n);
		END;
	  END;
	END;
  END;
  if DUMPREL then list_ms_item(myitem);
END;


PROCEDURE insert_ext_ref ( VAR p, root, last : ptr_to_ref );
{
  Appends a new REF item to the end of a chain beginning at root.
  We append at the END of the list, instead of the beginning, so
  we keep the EXTERNAL items in the correct order of appearance
  in the .REL file.
}
var pp : ptrref;
BEGIN
  IF last = 0
    THEN { nothing in chain }
      BEGIN
	root := p;
        pp := refs[root];
        pp^.ptr:=0;
	last := root;
      END
    ELSE
      BEGIN
	pp := refs[p];
        pp^.ptr := 0;  (* was nil *)
	refs[last]^.ptr := p;
	last := p;
      END;
END;

PROCEDURE linear_insert ( VAR p, first, last : ptr_to_ref );
{
  Assuming there is a chain of ref_type, beginning with
  sentinel values first and ending with last, linearly ordered
  by value, this procedure breaks the chain and inserts p^.
}
VAR
  w1, w2 : ptr_to_ref;
BEGIN
  w2 := first;
  w1 := refs[w2]^.ptr;
  refs[last]^.value := refs[p]^.value;
  WHILE refs[w1]^.value < refs[p]^.value DO
    BEGIN
      w2 := w1;
      w1 := refs[w2]^.ptr;
    END;   (* leaves this when w1^.value >= p^.value *)
{
  Insert if the value is new, or if it is repeated
  but the name is more specific.
}
  IF (refs[p]^.value <> refs[w1]^.value) OR ( w1 = last )
    THEN
      BEGIN
        refs[p]^.ptr := w1;
        refs[w2]^.ptr := p;
      END
    ELSE IF (refs[p]^.name <> '') THEN
      BEGIN
        refs[w2]^.ptr := p;
	refs[p]^.ptr := refs[w1]^.ptr;
      END
    ELSE p := w1;
END;

{$F+}
function HeapFunc( Size :word) : integer; {$F-}
begin
  HeapFunc:=1;  (* returns nil pointer instead of bombing out *)
end;

procedure alloc_ptr_to_ref( VAR p : ptr_to_ref);
var  pp : ptrref;
begin
  new(refs[numrefs]);
  if refs[numrefs] = NIL then errorhalt('Too many refs.');
  if numrefs > (maxrefs-1) then errorhalt('Too many refs ..');
  fillchar(refs[numrefs],sizeof(refs[numrefs]),chr(0));
  p := numrefs;
  numrefs:= numrefs + 1; (* track it *)
end; (* alloc_ptr_to _ref *)

PROCEDURE create_ref ( VAR p : ptr_to_ref; tipe : tipe_type;
  value : word;     name : name_type;
  public : word { 0 for public, 1 for private } );

BEGIN
  alloc_ptr_to_ref(p);
  refs[p]^.value := value;
  refs[p]^.name := name;
  IF tipe = code_rel
    THEN
      BEGIN
        refs[p]^.tipe :=  (2 * public)  ;
	linear_insert ( p, first_code_ref, last_code_ref );
      END
    ELSE
      BEGIN
 	refs[p]^.tipe :=  1 + 2 * public ;
	linear_insert ( p, first_data_ref, last_data_ref );
      END;
END { create_ref };
var q2 : word;
PROCEDURE chain_external ( item : ms_item );
label 9933;
VAR
  p     : ptr_to_ref;
  jjj, q , q1 : word;  { Indices into code buffer }
  stop  : BOOLEAN;
BEGIN
  alloc_ptr_to_ref(p);
  IF item.a.tipe = code_rel
    THEN
      refs[p]^.tipe :=  0   { code, public }
    ELSE
      refs[p]^.tipe :=  1 ; { data, public }
  refs[p]^.value := item.a.value;
  refs[p]^.name := item.b;
  insert_ext_ref ( p, first_ext_ref, last_ext_ref );
  q :=  item.a.value;
  if q > maxpc then readln;

  REPEAT  { Replace code-file REL quantities with pointers to REF }
    q2:=q; (* pu it in global storage so can see it later *)
    if q > maxpc then begin
         stop:=true;
         goto 9933;
    end;
    stop :=    ( test_type ( word(q) ) = 0 )
	        AND (test_type ( q + 1 ) = 0)
                AND (code_buffer^ [ q ] =  0)
	        AND (code_buffer^ [ q + 1 ] = ( 0 ));
    set_type ( q, 3 );
    set_type ( q + 1, 3 );
    (* get the next word *)
    get2bytes(q1,q);
    put2bytes(p,q);
    q := q1;
    9933:
  UNTIL stop;
END;

PROCEDURE define_entry_point ( item : ms_item );
VAR
  p : ptr_to_ref;
BEGIN
  create_ref ( p, item.a.tipe, item.a.value, item.b, 0 { public } );
END;

PROCEDURE chain_address ( item : ms_item );
VAR
  p     : ptr_to_ref;
  jj,q, q1 : word;
  stop  : BOOLEAN;
BEGIN
  create_ref ( p, code_rel, pc, '', 1 { private } );
  (* allocates space for p to point to, stores it in a table *)
  q := item.a.value;
  if q > maxpc then readln;
  REPEAT  { Replace code-file REL quantities with pointers to REF }
    stop := ( test_type ( q ) = 0 )
            AND (test_type ( q + 1 ) = 0)
	    AND (code_buffer^ [ q ] =  0)
	    AND (code_buffer^ [ q + 1 ] = 0);
    set_type ( q, 3 );
    set_type ( q + 1, 3 );
    get2bytes(q1,q);
    put2bytes(p,q);
    q := q1;
  UNTIL stop;
END;

PROCEDURE program_name ( item : ms_item );
BEGIN
  pgm_name := item.b;
END;

PROCEDURE define_data_size ( item : ms_item );
BEGIN
  data_size := item.a.value;
END;

PROCEDURE set_load ( item : ms_item );
BEGIN
  IF item.a.tipe = code_rel THEN pc := item.a.value;
  if pc > maxpc  then readln;
END;

PROCEDURE define_program_size ( item : ms_item );
BEGIN
  pgm_size := item.a.value;
END;

PROCEDURE name_for_search ( item : ms_item );
BEGIN
END;

procedure alloc_ptr_to_offset( VAR p : ptr_to_offset);
var pp : ptroff;
begin
  new(roff[numoffs]); (* allocate it *)
  if roff[numoffs] = NIL then errorhalt('Too many offsets.');
  if numoffs >= maxoffs then errorhalt('Too many offsets.');
  fillchar(roff[numoffs],sizeof(roff[numoffs]),chr(0));
  p:=numoffs;
  numoffs:= numoffs + 1; (* track it *)
end; (* alloc ptr to offset *)

PROCEDURE offset ( item : ms_item );
VAR
  p : ptr_to_offset;
BEGIN
  alloc_ptr_to_offset(p);
  IF item.control = 8 { - offset } THEN roff[p]^.sign := -1
  ELSE roff[p]^.sign := +1;
  roff[p]^.loc := pc;
  roff[p]^.offset := integer(item.a.value);
  roff[p]^.next := 0; (* NIL *)
{
  Now insert the item at the END of the offset chain.  Because
  the pc increases, the chain will be ordered on its LOC field.
}
  IF last_offset = 0 (* NIL *)
    THEN
      BEGIN
	first_offset := p;
	last_offset := first_offset;
      END
    ELSE
      BEGIN
	roff[last_offset]^.next := p;
	last_offset := p;
      END;
END;

PROCEDURE end_pgm ( item : ms_item );
BEGIN
END;

PROCEDURE end_file ( item : ms_item );
BEGIN
END;

procedure sel_comm_blk(item : ms_item);
begin
writeln('Select Common Block ',item.b);
end;

procedure req_library(item : ms_item);
begin
writeln('Request Library ',item.b);
end;


procedure future_reserve(item : ms_item);
begin
writeln('Future Reserved Item ',item.b);
end;


procedure define_comm_size(item : ms_item);
begin
   writeln('Define Common Size for block ',item.b, 'size ',item.a.value:6);
end;

PROCEDURE handle_special ( item : ms_item );
BEGIN
  CASE item.control OF
      0 : name_for_search ( item );
      1 : sel_comm_blk(item);
      2 : program_name ( item );
      3 : req_library(item);
      4 : future_reserve(item);
      5 : define_comm_size(item);
      6 : chain_external ( item );
      7 : define_entry_point ( item );
      8,
      9 : offset ( item );
     10 : define_data_size ( item );
     11 : set_load ( item );
     12 : chain_address ( item );
     13 : define_program_size ( item );
     14 : end_pgm ( item );
     15 : end_file ( item );
  END;
END { handle_special };

PROCEDURE write_name ( p : ptr_to_ref );
VAR
  i : word;
BEGIN
  IF refs[p]^.name <> ''
    THEN
      WRITE ( fout, refs[p]^.name)
    ELSE
      BEGIN
	IF TSTBIT ( refs[p]^.tipe, 0 )
	  THEN WRITE ( fout, 'D$' )
	  ELSE WRITE ( fout, 'C$' );
	WRITE_HEX ( fout, word(refs[p]^.value), 2 );
      END;
END;

PROCEDURE write_ref_name ( pc : word );
VAR
  p : ptr_to_ref;
  jj : word;
BEGIN
  (* suspicious code *)
  (* move (code_buffer [pc], p , 2 ); *)
  get2bytes(jj,pc);
  write_name ( jj );
END;

PROCEDURE write_next_label;
BEGIN
  write_name ( next_label );
  WRITE( fout, ':', tab );
END;


PROCEDURE w_hex ( n, nbytes : word );
{
  Writes the integer n (one or two bytes) to file f in hex form,
  in M80-readable form; e.g., 0FFFFh.
}
BEGIN
  IF ( (nbytes = 1) AND (LO ( n ) >= $a0) ) OR ( (nbytes = 2) AND
    (HI ( n ) >= $a0) ) THEN WRITE ( fout, '0' );
  WRITE_HEX ( fout, n, nbytes );
  WRITE ( fout, 'H' );
END;

PROCEDURE write_offset ( pc : word );
BEGIN
  IF next_offset <> 0 (* NIL *) THEN
  WITH roff[next_offset]^ DO
    BEGIN
      IF loc = pc THEN
	BEGIN
	  IF sign = 1
	    THEN
	      BEGIN
	        IF offset >= 0
		  THEN WRITE ( fout, '+', offset )
		  ELSE WRITE ( fout, offset );
	      END
	    ELSE IF offset >= 0
	      THEN WRITE ( fout, '-', offset )
	      ELSE WRITE ( fout, '+', -offset );
	  next_offset := roff[next_offset]^.next;
	END;
    END;
END;


PROCEDURE WriteDB;
BEGIN
  WRITE ( fout, 'DB', TAB );
  w_hex ( ord ( code_buffer^ [ pc ] ), 1 );
  WRITELN ( fout );
  WRITELN ( fout, TAB, ';  *** SYNC ERROR: inconsistent REL type' );
END; (* WriteDB *)


PROCEDURE dis_asm ( VAR pc : word );
VAR
  a : a_field;
  p : word ; (* ptr_to_ref; *)
  expect,
  n,
  t,
  temp : word;
  jjj : word;

  PROCEDURE WriteOpCode;
  VAR
   i,len: word;
   ch: CHAR;
  BEGIN
    WITH op_Codes[ code_buffer^[ pc ] ] DO BEGIN
      i := 1;
      len := ORD( name[0] );	(* length *)
      ch := name[1];
      WHILE (i <= len) AND (ch <> argMark) DO BEGIN
	IF ch = ' ' THEN
	  WRITE( fout, TAB )
	ELSE
	  WRITE ( fout, ch );
	i := i + 1;
	ch := name[i];
      END;
      IF follow <> 0 THEN BEGIN
        IF follow = 1 THEN
 	  W_hex( ORD( code_buffer^[ pc + 1 ] ), 1 )
        ELSE IF follow = 2 THEN BEGIN
          IF t = 0 THEN BEGIN
            get2bytes(temp,pc+1);
	    w_hex ( temp, 2 )
	  END
          ELSE IF t = 3 THEN BEGIN
            write_ref_name ( pc + 1 );
          END;
	  write_offset ( pc + 1 );
        END;
	i := i + 1;	(* move behind % *)
        WHILE i <= len DO BEGIN
	  IF ch = ' ' THEN
	    WRITE( fout, tab )
	  ELSE
	    WRITE ( fout, name[i] );
	  i := i + 1;
        END;
      END; (* follow # 0 *)
      WRITELN ( fout );
    END; (* WITH *)
  END; (* WriteOpCode *)

BEGIN
  IF refs[next_label]^.ptr <> 0  (* NIL *)
    THEN
      BEGIN
        IF pc = refs[next_label]^.value
          THEN
            BEGIN
	      write_next_label;
	      next_label := refs[next_label]^.ptr;
            END
          ELSE
	    WRITE ( fout, TAB );
      END
    ELSE
      WRITE ( fout, TAB);
  CASE test_type ( pc ) OF
    0 :BEGIN
          expect := op_codes [ code_buffer^ [ pc ] ].follow;
	  CASE expect OF
	    0 : BEGIN
		  IF op_codes [ code_buffer^ [ pc ] ].name <> '???' THEN BEGIN
		    WriteOpCode;
		  END
		  ELSE BEGIN
		    WriteDB; 
		  END;
		  pc := pc + 1;
	        END;
	    1 : BEGIN
		  IF test_type ( pc + 1 ) <> 0 THEN BEGIN
		    WriteDB;
		    pc := pc + 1;
		  END
		  ELSE BEGIN
		    WriteOpCode;
		    pc := pc + 2;
		  END;
		END;
	    2 : BEGIN
		  t := test_type ( pc + 1 );
		  IF t <> test_type ( pc + 2 ) THEN BEGIN
		    WriteDB;
		    pc := pc + 1;
		  END
		  ELSE BEGIN
		    WriteOpCode;
		    pc := pc + 3;
		  END;
		END;
	    END; { case expect of }
          END;
    1,2:
	BEGIN
	  WRITELN ( fout, TAB, ';  *** WOW!!  HOW DID THAT HAPPEN?!!' );
	  pc := pc + 1;
	END;
    3 : BEGIN
          (* suspicious code *)
          (* move ( code_buffer^ [ pc ], p, 2 ); *)
          get2bytes(p,pc);
          if p > maxrefs then writeln('Oophs, bad code pointer.');
	  WRITE ( fout, 'DW', TAB );
	  write_ref_name ( pc );
	  WRITELN ( fout );
	  pc := pc + 2;
	END;
  END { case test_type of }
END;


PROCEDURE print_publics ( VAR p : ptr_to_ref );
VAR
  count : word;
BEGIN
  count := 0;
  WHILE refs[p]^.ptr <> 0 (* NIL *) DO
    BEGIN
      IF refs[p]^.name <> '' THEN
	BEGIN
	  IF count = 0
	    THEN WRITE ( fout, TAB, 'PUBLIC', TAB, refs[p]^.name )
	    ELSE WRITE ( fout, ',' , refs[p]^.name );
	  count := count + 1;
	  IF count = 6 THEN
	    BEGIN
	      WRITELN ( fout );
	      count := 0;
	    END;
	END;
      p := refs[p]^.ptr;
    END;
  IF count > 0 THEN WRITELN ( fout );
END { print_publics };

PROCEDURE print_it;
VAR
  p     : ptr_to_ref;
  count : word;
BEGIN
  WRITELN;
  WRITELN ( 'Disassembling ', pgm_name );
  pc := 0;
  p := first_ext_ref;
  IF pgm_name <> '' THEN
    WRITELN ( fout, TAB, 'TITLE', TAB, pgm_name );
  count := 0;
  WHILE p <> 0 DO
    BEGIN
      IF count = 0
	THEN WRITE ( fout, TAB, 'EXTRN', TAB, refs[p]^.name )
	ELSE WRITE ( fout, ',' , refs[p]^.name );
      count := count + 1;
      IF count = 6 THEN
        BEGIN
	  WRITELN ( fout );
	  count := 0;
        END;
      p := refs[p]^.ptr;
    END;
  IF count > 0 THEN WRITELN ( fout );
  p := refs[ first_code_ref]^.ptr;
  print_publics ( p );
  p := refs[first_data_ref]^.ptr;
  print_publics ( p );
  WRITELN ( fout, TAB, 'CSEG' );
  next_label := refs[first_code_ref]^.ptr;
  next_offset := first_offset;
  WHILE pc < final_pc DO
    dis_asm ( pc );
  IF pc < pgm_size THEN
    WRITELN ( fout, TAB, 'DS', TAB, pgm_size - pc );
  WHILE next_label <> last_code_ref DO
    BEGIN
      WRITE ( fout, TAB, 'ORG', TAB );
      w_hex ( refs[next_label]^.value, 2 );
      WRITELN ( fout );
      write_next_label;
      WRITELN ( fout );
      next_label := refs[next_label]^.ptr;
    END;
  IF data_size > 0 THEN
    BEGIN
      WRITELN ( fout, TAB, 'DSEG', TAB );
      next_label := refs[first_data_ref]^.ptr;
      pc := 0;
      WHILE refs[next_label]^.ptr <> 0 (* NIL *) DO
        BEGIN
          IF pc = refs[next_label]^.value
            THEN
	      BEGIN
	        write_next_label;
	        WRITE ( fout, 'DS', TAB );
	        next_label := refs[next_label]^.ptr;
	        IF refs[next_label]^.ptr <> 0 (* NIL *)
	          THEN
		    BEGIN
		      WRITELN ( fout, refs[next_label]^.value - pc );
		      pc := refs[next_label]^.value;
		    END
	          ELSE
		    WRITELN ( fout, data_size - pc );
	      END
	    ELSE
	      BEGIN
	        WRITELN ( fout, TAB, 'DS', TAB,
			  refs[next_label]^.value - pc );
	        pc := refs[next_label]^.value;
	      END;
        END;
    END;
  WRITELN ( fout, TAB, 'END' );
END;

PROCEDURE replace_names;
VAR
  p     : ptr_to_ref;
  found : BOOLEAN;
  n,
  value : word;
BEGIN
  pc := 0;
  WHILE pc < final_pc DO
    BEGIN
      n := test_type ( pc );
      if n > 4 then writeln('Bad test_type in Replace_NAmes ');
      CASE n OF
	0   : pc := pc + 1;
	3   : pc := pc + 2;
	1,2 : BEGIN
		get2bytes(value,pc);
		IF n = 1
		  THEN p := refs[first_code_ref]^.ptr
		  ELSE p := refs[first_data_ref]^.ptr;
	        found := FALSE;
		WHILE (p <> last_code_ref) AND (p <> last_data_ref)
		      AND NOT found DO
		  BEGIN
		    found := (refs[p]^.value = value);
		    IF NOT found THEN p := refs[p]^.ptr;
		  END;
		IF (p = last_code_ref)
                THEN create_ref ( p, code_rel, value, '', 1 { private } )
		ELSE IF (p = last_data_ref ) THEN
		    create_ref ( p, data_rel, value, '', 1 );
	{
	  Now that p points to an appropriate reference -- one already
	  in the chain, or one we just added -- we can push its address
	  into the code buffer and adjust the REL bits to POINTER.
	}
		(* move ( p, code_buffer^ [ pc ], 2 ); *)
                put2bytes(p,pc);
		set_type ( pc, 3 );
		set_type ( pc + 1, 3 );
		pc := pc + 2;
	      END  { Case 1,2 };
      END { Case n of };
    END { While pc < final_pc };
END { replace_names };

PROCEDURE initialize;
var iii : word ;
    xxx : ptr_to_ref;
    yyy : ptr_to_offset;

BEGIN

  pc := 0;
  pgm_name := '';
  pgm_size := 0;
  data_size := 0;
  (* count of bytes from that segment *)
  fillchar(code_buffer^[0],maxpc,0);
  fillchar(rel_info^[0],maxrel,0);
  numoffs:=startrefs;
  numrefs:=startoffs;
  release(myheap); (* release all heap space used for last prog. segment *)

  for iii:=startrefs to maxrefs do begin
    refs[iii] := NIL;
  end;

  for iii:=startoffs to maxoffs do
      roff[iii] := NIL;
  alloc_ptr_to_ref( xxx );  (* use up 0 pointer *)
  alloc_ptr_to_ref( first_code_ref );  (* 1 *)
  alloc_ptr_to_ref( last_code_ref  );  (* 2 *)
  alloc_ptr_to_ref( first_data_ref );  (* 3 *)
  alloc_ptr_to_ref( last_data_ref  );  (* 4 *)

  refs[first_code_ref]^.ptr := last_code_ref;
  refs[last_code_ref]^.ptr := 0; (* NIL; *)
  refs[first_data_ref]^.ptr := last_data_ref;
  refs[last_data_ref]^.ptr := 0 (* NIL *) ;
  first_ext_ref := 0;
  last_ext_ref  := 0;
  alloc_ptr_to_offset(yyy); (* use up zero pointer *)
  first_offset := 0;
  last_offset := 0;
END;



PROCEDURE one_program ( VAR item : ms_item );
label 9911;
BEGIN
  initialize;
  REPEAT
    get_ms_item ( item );
   IF (item.rel) AND (item.tipe = abslute) AND (item.control = 15)
         THEN goto 9911; (* EXIT; *)
    IF NOT item.rel
      THEN
	BEGIN
          put1byte(item.value,p