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 = '%';
  LINEMARK = 4; (* new tipe for including source file lines in disassembly *)

{
  Maximum code size.  Maximum REL info size is 1/4 this:
}

  maxpc    = $FFFE; (* upped to max size*)
  maxrel   = $7fff; (* half of maxpc, since uses 4 bits *)

  (* 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..15] of string[20] =
  ( 'ABSOLUTE   ',
    'CODE_REL   ',
    'DATA_REL   ',
    'COMMON_REL ',
    'ABS-LINE   ',
    '','','','','','','','','','','');
  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
  shortstring = string[11];
  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..15 ; (* CWW modified to leave pointers to source lines *)

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

  name_type = STRING [ 10 ];

  ms_item =
    RECORD
      rel     : BOOLEAN;
      value   : word;
      tipe    : tipe_type;
      control : word;
      a       : a_field;
      b       : name_type;
      link    : boolean;    (* CWW *)
    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 2 : 1 = externally determined;
	  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
                down 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
  oldpc : word;
  linemarker : boolean;
  whichline : array[0..$1FFF] of word;
  toomany: word;  (* count of total lines in program as known to .erl file *)
  line : word;
  linebuffer: string;
      (* collect one code line of disassembly before printing *)
  stutter : string[5] ; (* preface to lines if doing DOLISTING, no code *)
  totalbytes: longint;
  DIS80     : boolean; (* doing dis-assembly of pascal source file *)
  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 *)
  DOLISTING : boolean;
  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 *)
  listname,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 , listfile : 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 liststring : string; (* one line buffer *)
const   queueisempty : boolean = true;

function is_code_line ( s : string ) : integer;
var i,k,lineno : word;
begin
   is_code_line:= -1; (* eternal optimist *)
   lineno:=0;
   i:=1;
   (* set a sentinal *)
   s:=s + 'XYZ'; (* so don't have to check overruns *)
   while s[i] in [#32,#9] do i:=i+ 1;
   while (s[i] in [#48..#57]) do begin
      lineno:= 10*lineno + (ord(s[i]) -48 );
      i:=i+1;
   end;
   if not (s[i] in [' ',tab]) then exit;
   is_code_line:=lineno;
end;

 const waiting : boolean = false;
       done : boolean = false;

procedure fetchline(myline : word);
label 9977;
(* get a line from the listing file and put it on page *)
var k : integer;
    realline : word;
begin
  if myline < toomany then myline:= whichline[myline]
  else myline:=$FFFF;
if done then exit;
repeat
  if eof(listfile) then begin
    if waiting then writeln(fout,liststring);
    done:=true;
    waiting:=false;
    exit;
  end;
  if not waiting then begin
        readln(listfile,liststring);
        waiting:=true; (* got a line now to be queued for printing *)
        done:=false;
  end;
  k:= is_code_line(liststring);
  (* -1 if not a line of code *)
  if K < 0 then waiting:=false; (* discard it *)
  if (k <= myline) and ( k >= 0 ) then begin
      waiting:= false; (* will perhaps flush *) ;
      writeln(fout,liststring) ;
  end;
until (waiting) ;

(* finishes when has first line with number larger
   than current line read *)
9977:
end; (* fetch line *)


procedure flushline;
begin
  writeln(fout,linebuffer);
  linebuffer:='';
end;

function word_str ( n : word ): shortstring;
var t : longint;
    s : shortstring;
begin
  t:= longint(n);
  str(t:6,s);
  word_str:=s;
end;


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; (* dump rel directives as we go *)
        'N' : DODISAM := false; (* disable disassembly *)
        'Z' : usetxt :=1;
        '8' : usetxt :=0;
        'B' : BITSTREAM:=true;
        'L' : DOLISTING:= TRUE;
        'P' : DIS80 := true;
        else begin writeln('Unknown option ',option[1]); end;
     end;
end; (* process_options *)

PROCEDURE errorhalt ( message : STRING );
BEGIN
  WRITELN;
  WRITELN (message );
  flushline;  (* finish piece of listing *)
  if DIS80 then begin   (* and program listing *)
    line:=$ffff;
    fetchline(line);
  end;
    {$I-}
  CLOSE ( fbyte);
  CLOSE ( fout);
  if DIS80 then close(listfile);
  {$I+}
  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, '.' ) );
  (* look for a listing file *)
  if DIS80 then begin
    ii:= pos('.',in_f_name);
    if (ii - 1) <= 0 then errorhalt('Check input file name.');
    listname := copy(in_f_name,1,ii-1 ) + '.prn';
    assign(listfile,listname);
    {$I-}
    reset(listfile);
    {$I+}
    if ioresult <> 0 then errorhalt('Can''t find listing file. Don''t use -P.');
   end;
  (* get opcodes *)
  ASSIGN ( fopcodes, op_code_filename[usetxt] );
  {$I-}
  RESET (fopcodes);
  {$I+}
  IF IORESULT <> 0 THEN  begin
    writeln('Unable to open ',op_code_filename[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 new primitives to hide precise nature of the code_buffer array *)
(* this way can allocat it or have vitual memory, with out changing rest
   of code *)
(* original code used block moves to do this *)
(* right now code_buffer is a pointer to an array of FFFF elements *)
(* these primitives will change if this changes *)

procedure zero_code; (* sets all bytes of code buffer to zero *)
begin
  fillchar(code_buffer^[0],maxpc,0);
end; (* zero_code *)

procedure zero_rel;
begin
    fillchar(rel_info^[0],maxrel,0);
end; (* zero_rel *)

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

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

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

function get2bytes (qindex : word) : word;
var xdata : word;
begin
   get2bytes := 0;
   if qindex > maxpc then errorhalt('Bad index in get2bytes.');
   xdata:= get1byte(qindex);
   get2bytes:= xdata or (word( get1byte(qindex+1) shl 8));
end;


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

procedure str_write_byte( var s : string; x : word );
begin
  s:=s+ hexdigit[ ( x and $f0) shr 4 ];
  s:=s+ hexdigit[ ( x and $0f)];
end; (* str_write_byte *)

procedure str_write_hex  ( var s : string; n : word; nbytes : word );
begin
   if nbytes = 1 then str_write_byte(s,n)
   else begin
      str_write_byte(s, hi(n) );
      str_write_byte(s, lo(n));
   end;
end; (* str_write_hex *)

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 *)

(* details of rel_info are hidden here *)

FUNCTION test_type ( n : word ) : word;
{       use 4 bits of info now for each pc }
{  Each item in the code buffer has associated with it four 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.
        100 = line pointer
        gives room to work some common_rel stuff in also

}
VAR
  dv, md, x : word;
BEGIN
  (* look at n/2, and choose top or bottom nibble *)
  dv := n shr 1;  (* point to byte *)
  md := n and 1;  (* look at starting bits in this byte *)
  x:=rel_info^[dv];
  if md = 0 then x:= ( x shr 4 ) ;   (* was top nibble *)
  test_type:= x and $0f;   (* just nibble away *)
END;

PROCEDURE set_type ( n, tipe : word );
{
  SETS the four bits mentioned above to reflect tipe.
  Uses only the bottom four bits of tipe.
}
VAR
  dv, md,x : word;
BEGIN
  dv := n shr 1 ;
  md :=  n and 1;
  if dv > maxrel then begin
     writeln(bell,bell,'Bad code pointer in set_type.');
     errorhalt('Halted in set_type .');
  end;
  x := rel_info^[dv] and $ff;
  if md = 0 then (* using top nibble *)
     x:= (( x and $0f) or (tipe shl 4)) and $ff
  (* clear the nibble to be changed *)
  else x:= (( x and $f0) or tipe)  and $ff; (* using bottom nibble *)
  rel_info^[dv]:= byte(x);
  if (test_type(n)) <> tipe then
      errorhalt('Bad set in set_type.');
END;

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(fout,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(fout,b:10);
END;

PROCEDURE list_ms_item ( x : ms_item );
VAR
  n : word;
BEGIN
        if not x.rel then begin
           linebuffer:=linebuffer + relstr[x.rel];
           str_write_hex(linebuffer,word(x.value),1);
           linebuffer:=linebuffer+'H';
           flushline;
           exit;
        end;
        case x.link of
	    TRUE  : BEGIN
                  linebuffer:=linebuffer+ controlstr[x.control];
		  CASE x.control OF
		    0,1,2,3 : begin (* B field only *)
                                  linebuffer:=linebuffer+ x.b;
                                  flushline;
                                 end;
		    4 : begin (* B field only *)
                                  str_write_hex(linebuffer,word(ord(x.b[0])),1);
                                  linebuffer:=linebuffer+'H '+ x.b;
                                  
                                  flushline;
                                 end;



5,6,7    : BEGIN (* A field and B field *)
                                  linebuffer:=linebuffer+tipestr[x.a.tipe];
				  str_write_hex(linebuffer,word(x.a.value),2);
				  linebuffer:=linebuffer+'H  '+ x.b;
                                  flushline;
                                END;
		    8,9,10,11,  (* get_ms_ had 8 here ???? *)
		    12,13,14  : begin (* A field only *)
                                  linebuffer:=linebuffer+tipestr[x.a.tipe];
				  str_write_hex(linebuffer,word(x.a.value),2);
                                  linebuffer:=linebuffer+'H '
                                  ;
                                  flushline;
                                 end;
		  END; (* case control *)
		END;    (* link special case *)
	    FALSE : BEGIN  (* was relative item, so print value field *)
                      (* write(fout,relstr[x.rel]); *)
                      linebuffer:=linebuffer+tipestr[x.tipe];
	              str_write_hex(linebuffer,word(x.value),2);
                      linebuffer:=linebuffer+'H ';
                      flushline;
		    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
               (*  special for DRI use. Microsoft use is for COMMON.
                   The .erl file produced in the X dis-assembly mode
                   of MTPLUS has a couple of phony things here.
                1) items marked as common-rel are really one byte
                   absolutes, except for case where value is $FFFF,
                   in which case, it's a clue that a new line of
                   pascal source code has just begun.
                  *)
		  myitem.link:=false; (* correct *)
                  myitem.rel:=false;  (* say it's not so *)
                  n := bits (16);
                  myitem.value := ( SWAP(n) and $FF); (* ignores top byte *)
                  if ( n = $FFFF ) then begin
                       linemarker:=true;
                       line:=line+1;
                       (* marks line in source code *)
                       (* so mark it so will be ignored *)
                       (* fake it and call it a link item instead *)
                       myitem.rel:=TRUE;
                       myitem.link := True;
                       str(line:4,myitem.b);
                       myitem.b:='Line '+ myitem.b;
                       myitem.control:= 4;
                   end;
		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;

const REPSMAX  = 1000; (* bound on reps in a single chain external *)

PROCEDURE chain_external ( item : ms_item );
label 9933;
VAR
  p     : ptr_to_ref;
  jjj, q , q1 : word;  { Indices into code buffer }
  stop  : BOOLEAN;
  loopcount : word;
BEGIN
  loopcount := 0;
  (* limit the total number of times through *)
  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 }
    loopcount:=loopcount + 1;
    if loopcount > REPSMAX then begin
       stop:=TRUE; goto 9933; end;
    q2:=q; (* put it in global storage so can see it later *)
    if q > maxpc then begin
         stop:=true;
         goto 9933;
    end;
    stop :=    ( test_type(q) and 3 = 0)      (* bytes absolute *)
	        AND (test_type(q+1) and 3 = 0)
                AND (get2bytes(q)  =  0) ;  (* and end of chain? *)
    set_type (q,3);
    set_type (q+1,3 );
    (* get the next word *)
    q1:= get2bytes(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 );
label 9123;
VAR
  p     : ptr_to_ref;
  jj,q, q1 : word;
  stop  : BOOLEAN;
  loopcount : word;
BEGIN
  loopcount:=0;
  create_ref ( p, code_rel, pc, '', 1 { private } );
  (* allocates space for p to point to, stores it in a table *)
  q := item.a.value;
  REPEAT  { Replace code-file REL quantities with pointers to REF }
    loopcount := loopcount + 1;
    if loopcount > REPSMAX then goto 9123;
    stop := (test_type(q) and 3 = 0 )
            AND (test_type(q+1) and 3 = 0)
	    AND (get2bytes(q) =  0);
    set_type (q, 3);
    set_type (q+1,3 );
    q1:=get2bytes(q);
    put2bytes(p,q);
    q := q1;
  UNTIL stop;
  9123:
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
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
      linebuffer:=linebuffer +  refs[p]^.name
    ELSE
      BEGIN
	IF  refs[p]^.tipe and 1 <> 0
	  THEN linebuffer:=linebuffer +  'D$'
	ELSE linebuffer:=linebuffer + 'C$';
	  str_WRITE_HEX (linebuffer, word(refs[p]^.value), 2 );
      END;
END;

PROCEDURE write_list ( p : ptr_to_ref );
VAR
  i : word;
BEGIN
        str_WRITE_HEX (linebuffer, word(refs[p]^.value), 2 );
	case  (refs[p]^.tipe and 1)   of
          0 : linebuffer:=linebuffer + ''' '; (* prog rel     *)
          1 : linebuffer:=linebuffer + '" ';(* data rel   *)
         end; (* case *)
END;

PROCEDURE write_ref_name ( pc : word );
BEGIN
  write_name (get2bytes(pc));
END;

PROCEDURE write_next_label;
BEGIN
  write_name ( next_label );
  linebuffer:=linebuffer + ':' + tab ;
END;

PROCEDURE str_w_hex ( var s : string; 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 s := s + '0';
  str_WRITE_HEX ( s, n, nbytes );
  s:=s+ 'H';
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;

var list_offset : ptr_to_offset;

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 linebuffer:= linebuffer + '+' + word_str(offset)
		ELSE linebuffer  := linebuffer + word_str(offset );
	      END
	    ELSE IF offset >= 0
	      THEN linebuffer:= linebuffer + '-' + word_str(offset )
	      ELSE linebuffer:= linebuffer + '+' + word_str(-offset);
	  next_offset := roff[next_offset]^.next;
	END;
    END;
END;


PROCEDURE WriteDB;
BEGIN
  linebuffer:=linebuffer+'DB' + TAB;
  str_w_hex(linebuffer,get1byte(pc),1);
  flushline;
  linebuffer:=linebuffer + stutter + tab
              + ';  *** SYNC ERROR: inconsistent REL type' ;
  flushline;
  (* found a non opcode in code section, but marked relocatable ?? *)
END; (* WriteDB *)

PROCEDURE ListOpcode(pc : word);
VAR
   i,t: word;
   x : word;
  BEGIN
     list_offset:=next_offset;
     x:=get1byte(pc);
     t:= test_type(pc+1) and 3;
     str_write_hex(linebuffer,pc,2);
     linebuffer:=linebuffer + '  ';
     str_write_hex(linebuffer,x,1);
     linebuffer:=linebuffer + ' ';
    WITH op_Codes[ x ] DO BEGIN
      IF follow <> 0 THEN BEGIN
        IF follow = 1 THEN begin
 	      str_Write_hex(linebuffer, get1byte(pc+1), 1 );
              linebuffer:=linebuffer + '  ';
        end
        ELSE IF follow = 2 THEN BEGIN
          IF t = 0 THEN BEGIN
	    str_write_hex (linebuffer, get2bytes(pc+1), 2 )
	  END
          ELSE IF t = 3 THEN BEGIN
            write_list ( get2bytes(pc + 1) );
          END;
	  write_offset( pc + 1 );
        END;  (* follow = 2 *)
      end (* follow <> 0 *)
      else linebuffer:=linebuffer + '   ';
    END; (* WITH *)
    linebuffer:=linebuffer + tab;
    next_offset:= list_offset; (* get it back *)
  END; (* ListOpCode *)

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,x: word;
   ch: CHAR;
   check: boolean;
  BEGIN
     check := (test_type(pc) = LINEMARK);
    x:=get1byte(pc);
    if check then
         if DIS80 then begin fetchline(line);line:=line+1;end;
    WITH op_Codes[ x ] DO BEGIN
      i := 1;
      len := ORD( name[0] );	(* length *)
      ch := name[1];
      WHILE (i <= len) AND (ch <> argMark) DO BEGIN
	IF ch = ' ' THEN
	  linebuffer:=linebuffer + TAB
	ELSE
	  linebuffer:=linebuffer+ ch;
	i := i + 1;
	ch := name[i];
      END;

      IF follow <> 0 THEN BEGIN
        IF follow = 1 THEN
 	      str_W_hex(linebuffer, get1byte(pc+1), 1 )
        ELSE IF follow = 2 THEN BEGIN
          IF t = 0 THEN BEGIN
            temp:= get2bytes(pc+1);
	    str_w_hex (linebuffer, 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
	    linebuffer:=linebuffer+ tab
	  ELSE
	    linebuffer:=linebuffer + name[i] ;

	  i := i + 1;
        END;
      END; (* follow # 0 *)
      flushline;
    END; (* WITH *)
  END; (* WriteOpCode *)


BEGIN

  if DOLISTING then ListOpcode(pc);
  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
	    linebuffer:= linebuffer + TAB;
      END
    ELSE
      linebuffer:= linebuffer + tab;
  CASE (test_type (pc) and 3) OF
    0 :BEGIN
          expect := op_codes [ get1byte(pc) ].follow;
	  CASE expect OF
	    0 : BEGIN
		  IF op_codes [ get1byte(pc) ].name <> '???' THEN BEGIN
		    WriteOpCode;
		  END
		  ELSE BEGIN
		    WriteDB;
		  END;
		  pc := pc + 1;
	        END;
	    1 : BEGIN
		  IF test_type ( pc + 1 ) and 3 <> 0 THEN BEGIN
		    WriteDB;
		    pc := pc + 1;
		  END
		  ELSE BEGIN
		    WriteOpCode;
		    pc := pc + 2;
		  END;
		END;
	    2 : BEGIN
		  t := test_type (pc +1) and 3;
		  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
	  linebuffer:= linebuffer + stutter + tab +
                        ';  *** WOW!!  HOW DID THAT HAPPEN?!!' ;
          flushline;
	  pc := pc + 1;
	END;
    3 : BEGIN
          p:= get2bytes(pc);
          if p > maxrefs then writeln('Oophs, bad code pointer.');
	  linebuffer:=linebuffer+ 'DW' + TAB;
	  write_ref_name ( pc );
	  flushline;
	  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
                 linebuffer:=linebuffer + stutter + tab + 'PUBLIC'
                             + tab + refs[p]^.name
      	    ELSE linebuffer:= linebuffer + ',' + refs[p]^.name;
            count := count + 1;
	  IF count = 6 THEN
	    BEGIN
	      flushline;
	      count := 0;
	    END;
	END;
      p := refs[p]^.ptr;
    END;
  IF count > 0 THEN flushline ;
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 begin
    linebuffer:= linebuffer + stutter + tab + 'TITLE'+ tab + pgm_name;
    flushline;
   end;
  count := 0;
  WHILE p <> 0 DO
    BEGIN
      IF count = 0
	THEN linebuffer:=linebuffer + stutter + tab + 'EXTRN'
                         + tab + refs[p]^.name
	ELSE linebuffer:=linebuffer + ',' + refs[p]^.name;
      count := count + 1;
      IF count = 6 THEN
        BEGIN
	  flushline;
	  count := 0;
        END;
      p := refs[p]^.ptr;
    END;
  IF count > 0 THEN flushline;
  p := refs[ first_code_ref]^.ptr;
  print_publics ( p );
  p := refs[first_data_ref]^.ptr;
  print_publics ( p );
  (* finished the preface *)
  linebuffer:=linebuffer + stutter + tab + 'CSEG'; (* no code generated *)
  flushline;
  next_label := refs[first_code_ref]^.ptr;
  next_offset := first_offset;
  WHILE pc < final_pc DO    begin
    if DIS80 then begin end;
    dis_asm ( pc );
  end;
  IF pc < pgm_size THEN begin
    linebuffer:=linebuffer + stutter+ tab +
                'DS' + tab+ word_str(pgm_size -pc);
    flushline;
  end;
  WHILE next_label <> last_code_ref DO
    BEGIN
      linebuffer:=linebuffer + tab + 'ORG' + tab;
      str_w_hex (linebuffer, refs[next_label]^.value, 2 );
      flushline;
      write_next_label;
      flushline;
      next_label := refs[next_label]^.ptr;
    END;
  IF data_size > 0 THEN
    BEGIN
      linebuffer:=linebuffer + stutter + tab + 'DSEG';
      flushline;
      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;
	        linebuffer:=linebuffer + tab + 'DS' + TAB;
	        next_label := refs[next_label]^.ptr;
	        IF refs[next_label]^.ptr <> 0 (* NIL *)
	          THEN
		    BEGIN
		      linebuffer:=linebuffer +
                         word_str(refs[next_label]^.value - pc);
		      flushline;
                      pc := refs[next_label]^.value;
		    END
	          ELSE  begin
		    linebuffer:=linebuffer + word_str(data_size - pc );
                    flushline;
                  end;
	      END
	    ELSE
	      BEGIN
	        linebuffer:=linebuffer + TAB+ 'DS'+ TAB +
                            word_str(refs[next_label]^.value - pc );
                flushline;
	        pc := refs[next_label]^.value;
	      END;
        END;
    END;
    linebuffer:= linebuffer+ stutter + tab + 'END';
    flushline;
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 ) and 3;
      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
		value:=get2bytes(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.
	}
                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;
  oldpc:=0;
  pgm_name := '';
  pgm_size := 0;
  data_size := 0;
  (* count of bytes from that segment *)
  zero_code;
  zero_rel;
  linebuffer:='' ; (* hold current line *)
  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;
var mytest : word;
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  (* real machine instructions should always be here *)
          put1byte(item.value,pc);
          (* here put in line marker code *)
          if linemarker then begin
               linemarker:=false;
               set_type(pc, 0 or LINEMARK);
               if pc = oldpc then
                    whichline[toomany]:= line
               else begin
                    toomany:=toomany+1;
                    whichline[toomany]:=line;
                    oldpc:=pc;
               end;
               mytest:=test_type(pc);
          end
          else set_type( pc, 0 );
	  pc := pc + 1;
	END
      ELSE           (* is reloc *)
	CASE item.link OF
	    FALSE : BEGIN
			   IF pc <= maxpc - 1
			     THEN
                               put2bytes(item.value,pc)
			     ELSE
			       errorhalt ( '*** ERROR: Code file overflow.' );
			   CASE item.tipe OF
			     code_rel : n := 1;
			     data_rel : n := 2;
			     common_rel: n := 0;
		           END;
                              set_type ( pc, n  );
		    	      set_type ( pc+1, n );
			   pc := pc + 2;
			 END;
	     TRUE    : handle_special ( item ); (* was a directive *)
	END;
    UNTIL (* (item.rel) AND (item.tipe=abslute) AND*)  (item.control IN [14,15]);
9911:
    line:=0;
    final_pc := pc;  { save program counter }
    pc:= pc;
    if DODISAM then begin
       replace_names;
       print_it;
    end;
END;     (* one program *)

procedure alloc_rel_info;
begin
 new(rel_info);     (* zero this out on each use *)
end;

procedure alloc_code;
begin
  new(code_buffer);
end;


BEGIN { >>> MAIN PROGRAM <<< }
  (* these are allocated once and not released *)
   alloc_rel_info ;
   alloc_code;
   (* refs is an array of pointers *)
   (* roff is an array of pointers *)

   fillchar(refs,sizeof(refs),chr(0) );
   fillchar(roff,sizeof(roff),chr(0) );
   op_code_filename[0]:= '8080CODE.TXT';
   op_code_filename[1]:= 'Z80CODE.TXT';
   op_code_filename[2]:= 'OPCODES.TXT';
   totalbytes:=0;
   line:= 0;
   DODISAM:=TRUE; (* assume want dis-assembly *)
   DUMPREL:=FALSE; (* no detailed .rel format dump, however *)
   BITSTREAM:=FALSE;  (* or break down of incoming bitstream *)
   DOLISTING:= FALSE;   (* or print out of code file generated along side *)
   DIS80:=false;
   maxfile:=0;   (* only two allowed, and order matters .rel or .erl first *)
   maxoption:=0; (* + or - items on command line *)
   toomany:=0;
   usetxt:= 2 ; (* the default 'opcodes.txt' *)
   for ii:=1 to 255 do option[ii]  := ' ';
   for ii:=1 to 10 do fileparam[ii]:=  '';
   for ii:=0 to $1fff do whichline[ii]:=0;
   HeapError:=@HeapFunc;
   getparameters; (* grab the command line info *)
   processoptions;
   IF DOLISTING then stutter:=tab+tab+tab else stutter:='';
      (* set left offset for prnt *)
   numrefs:=startrefs;
   numoffs:=startoffs;
   open_files;
   mark(myheap);  (* preserve the lower allocated stuff *)
  REPEAT
   cur_bit:= -1; (* reset bit stream *)
   one_program ( item ) ;

  UNTIL (item.rel) AND (item.tipe = abslute) AND (item.control = 15 );
   errorhalt ( 'End of file - Normal termination.' );
 END.