head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.22.55;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.02.55;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.58.31;  author jwh;  state Exp;
branches ;
next     55.2;

55.2
date     91.11.04.14.29.00;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.33.42;  author jwh;  state Exp;
branches ;
next     54.3;

54.3
date     91.08.21.12.40.46;  author jwh;  state Exp;
branches ;
next     54.2;

54.2
date     91.08.21.09.53.00;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.34.11;  author jwh;  state Exp;
branches ;
next     53.3;

53.3
date     91.03.18.13.33.58;  author jwh;  state Exp;
branches ;
next     53.2;

53.2
date     91.03.15.16.17.14;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.34.00;  author jwh;  state Exp;
branches ;
next     52.2;

52.2
date     91.03.11.16.54.42;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.20.10;  author jwh;  state Exp;
branches ;
next     51.2;

51.2
date     91.02.18.20.52.09;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.18.37;  author jwh;  state Exp;
branches ;
next     50.2;

50.2
date     91.01.30.09.23.44;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.32.33;  author jwh;  state Exp;
branches ;
next     49.2;

49.2
date     90.10.29.14.15.24;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.16.17;  author jwh;  state Exp;
branches ;
next     48.2;

48.2
date     90.08.14.09.42.02;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.22.50;  author jwh;  state Exp;
branches ;
next     47.2;

47.2
date     90.07.24.15.00.40;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.11.08.43;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.55.32;  author jwh;  state Exp;
branches ;
next     45.2;

45.2
date     90.05.04.14.57.31;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.16.03.41;  author jwh;  state Exp;
branches ;
next     44.2;

44.2
date     90.04.19.13.26.41;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.20.47;  author jwh;  state Exp;
branches ;
next     43.3;

43.3
date     90.04.01.16.26.33;  author jwh;  state Exp;
branches ;
next     43.2;

43.2
date     90.03.22.11.34.01;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.14.13.40;  author jwh;  state Exp;
branches ;
next     42.2;

42.2
date     90.03.19.16.14.32;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.57.40;  author jwh;  state Exp;
branches ;
next     41.5;

41.5
date     90.01.20.16.46.07;  author jwh;  state Exp;
branches ;
next     41.4;

41.4
date     89.12.26.17.15.51;  author jwh;  state Exp;
branches ;
next     41.3;

41.3
date     89.12.26.15.11.15;  author jwh;  state Exp;
branches ;
next     41.2;

41.2
date     89.12.26.09.56.14;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.39.37;  author jwh;  state Exp;
branches ;
next     40.2;

40.2
date     89.12.21.15.09.10;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.12.00.42;  author jwh;  state Exp;
branches ;
next     39.2;

39.2
date     89.09.28.17.30.13;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.45.33;  author dew;  state Exp;
branches ;
next     38.2;

38.2
date     89.09.26.14.46.11;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.38.00;  author jwh;  state Exp;
branches ;
next     37.2;

37.2
date     89.08.28.12.29.28;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.51.31;  author dew;  state Exp;
branches ;
next     36.3;

36.3
date     89.05.12.09.18.39;  author quist;  state Exp;
branches ;
next     36.2;

36.2
date     89.05.11.11.50.52;  author quist;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.28.53;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.46.01;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.16.20.17;  author jwh;  state Exp;
branches ;
next     33.2;

33.2
date     89.01.20.16.33.03;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.51.08;  author dew;  state Exp;
branches ;
next     32.3;

32.3
date     89.01.13.11.33.46;  author dew;  state Exp;
branches ;
next     32.2;

32.2
date     89.01.11.09.54.47;  author jws;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.12.01.15;  author bayes;  state Exp;
branches ;
next     31.2;

31.2
date     89.01.09.12.07.17;  author dew;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.18.22.04;  author bayes;  state Exp;
branches ;
next     30.3;

30.3
date     88.12.14.13.40.21;  author bayes;  state Exp;
branches ;
next     30.2;

30.2
date     88.12.12.12.26.15;  author dew;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.58.42;  author dew;  state Exp;
branches ;
next     29.2;

29.2
date     88.12.08.15.48.38;  author bayes;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.43.25;  author bayes;  state Exp;
branches ;
next     28.2;

28.2
date     88.10.31.10.50.23;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.11.09.09;  author dew;  state Exp;
branches ;
next     27.2;

27.2
date     88.10.05.17.50.10;  author bayes;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.52.46;  author bayes;  state Exp;
branches ;
next     26.6;

26.6
date     88.09.28.14.12.56;  author bayes;  state Exp;
branches ;
next     26.5;

26.5
date     88.09.28.14.12.16;  author bayes;  state Exp;
branches ;
next     26.4;

26.4
date     88.09.28.14.11.35;  author bayes;  state Exp;
branches ;
next     26.3;

26.3
date     88.09.28.14.10.54;  author bayes;  state Exp;
branches ;
next     26.2;

26.2
date     88.09.28.14.10.22;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.14.09.35;  author bayes;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.10.21.53;  author jws;  state Exp;
branches ;
next     23.2;

23.2
date     87.08.30.16.35.40;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.11.08.51;  author bayes;  state Exp;
branches ;
next     22.2;

22.2
date     87.08.25.20.22.06;  author jws;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.11.48.00;  author bayes;  state Exp;
branches ;
next     21.2;

21.2
date     87.08.15.18.23.34;  author larry;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.14.33.01;  author bayes;  state Exp;
branches ;
next     20.2;

20.2
date     87.08.12.11.58.30;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.11.44.09;  author bayes;  state Exp;
branches ;
next     19.2;

19.2
date     87.07.29.19.33.28;  author larry;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.08.58.46;  author jws;  state Exp;
branches ;
next     18.2;

18.2
date     87.05.31.16.16.41;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.16.03.31;  author bayes;  state Exp;
branches ;
next     17.2;

17.2
date     87.05.20.12.09.13;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.11.06.10;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.16.16.12;  author jws;  state Exp;
branches ;
next     15.2;

15.2
date     87.04.24.19.28.08;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.09.58.32;  author jws;  state Exp;
branches ;
next     14.3;

14.3
date     87.04.12.18.45.13;  author jws;  state Exp;
branches ;
next     14.2;

14.2
date     87.04.07.16.33.17;  author larry;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.16.09.52;  author jws;  state Exp;
branches ;
next     13.3;

13.3
date     87.04.01.11.36.16;  author jws;  state Exp;
branches ;
next     13.2;

13.2
date     87.03.27.12.59.14;  author bayes;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.58.55;  author jws;  state Exp;
branches ;
next     12.2;

12.2
date     87.02.28.17.03.39;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.13.53.13;  author jws;  state Exp;
branches ;
next     11.2;

11.2
date     87.02.02.11.39.26;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.10.19.38;  author jws;  state Exp;
branches ;
next     10.2;

10.2
date     87.01.18.20.19.16;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.11.35.08;  author jws;  state Exp;
branches ;
next     9.2;

9.2
date     86.12.23.18.25.09;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.15.20.14;  author bayes;  state Exp;
branches ;
next     8.3;

8.3
date     86.12.12.12.09.05;  author bayes;  state Exp;
branches ;
next     8.2;

8.2
date     86.12.09.11.07.10;  author jws;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.12.27.57;  author jws;  state Exp;
branches ;
next     7.2;

7.2
date     86.11.25.14.52.43;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.14.44.25;  author hal;  state Exp;
branches ;
next     6.2;

6.2
date     86.11.19.17.46.26;  author bayes;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.18.33.31;  author paws;  state Exp;
branches ;
next     5.2;

5.2
date     86.11.04.14.58.01;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.17.23.17;  author hal;  state Exp;
branches ;
next     4.2;

4.2
date     86.10.28.13.01.24;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.20.17.26;  author hal;  state Exp;
branches ;
next     3.2;

3.2
date     86.09.30.16.35.37;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.12.39.39;  author hal;  state Exp;
branches ;
next     2.4;

2.4
date     86.09.01.10.15.25;  author hal;  state Exp;
branches ;
next     2.3;

2.3
date     86.08.20.14.05.55;  author danm;  state Exp;
branches ;
next     2.2;

2.2
date     86.08.19.14.26.48;  author danm;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.15.17.12;  author hal;  state Exp;
branches ;
next     1.3;

1.3
date     86.07.30.12.03.00;  author geli;  state Exp;
branches ;
next     1.2;

1.2
date     86.07.15.18.27.36;  author geli;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.17.09.47;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@					       (*

 (c) Copyright Hewlett-Packard Company, 1985,1991.
All rights are reserved.  Copying or other
reproduction of this program except for archival
purposes is prohibited without the prior
written consent of Hewlett-Packard Company.


	    RESTRICTED RIGHTS LEGEND

Use, duplication, or disclosure by the Government
is subject to restrictions as set forth in
paragraph (b) (3) (B) of the Rights in Technical
Data and Computer Software clause in
DAR 7-104.9(a).

HEWLETT-PACKARD COMPANY
Fort Collins, Colorado                         *)


$MODCAL,debug off,iocheck off,range off,ovflcheck off$ $ref 60$
$ALLOW_PACKED ON$ {JWS 3/31/87}

program linker(input, output, keyboard);


import sysglobals,fs,loader,ldr,asm,sysdevs,ci,misc;


const   pagelines = 63;
	pageblocks = 2;
	entrysize = 26;

type    address = integer;
	point = ^integer;

var     keyboard:       text;
	todaysdate:     daterec;
	linkerdate:     daterec;
	tempstring:     string[12];
	gvaluestring:   string80;
	copyright,
	listfilename:   string80;
	listing:        text;
	pagenum,
	linenum:        shortint;
	linking,booting,
	outopen,
	verifying,defsout,
	printopen,
	printeron:      boolean;
	commandchar: char;
	startgvr:       addrec;
	startgvrmod:    moddescptr;
	modsave:        moddescptr;
	infost:         addrec;

	ires:   integer;        {saved ioresult}
	errors: integer;
	esccode: integer;
	lowheap0,highheap0: addrec;

	infilename:     string80;
	vmodnum:        shortint;

	{output file information: }
	outdirectory:   addrec;         {new library directory pointer}
	outfile:        phyle;          {file being written}
	firstoutblock,
	outblock:       integer;        {next block within library to write}
	nextblock:      integer;        {next block within module to write}
	outfilename:    string80;
	outmodnum:      integer;        {number of modules created so far}
	outdirectsize,
	maxmodules:     integer;

	{linker information:  }
	totalpatchspace: integer;       {bytes of patch space}
	patchbytes:     integer;
	backwardpatches,
	forwardpatches: moddescptr;
	newmodname:     addrec;         {new name for linked module}
	infostart:      addrec;         {pointer to bottom of linker memory}
	newexttable:    address;        {location of new EXT table}
	newextsize:     integer;        {size in bytes of EXT table}
	newdirectory:   addrec;         {pointer to new module directory}
	loadgvr:        gvrptr;
	modulepc:       integer;        { module body entry point }

procedure dobeep;
begin beep;if streaming then escape(-1); end;

procedure errorline;
begin ires := ioresult; fgotoxy(output, 0, 22); write(bellchar, cteol); end;

procedure ioerror;
begin write(' ioresult = ',ires:1); escape(123); end;

procedure getcommandchar(s:string80; var c:char);
begin
  fgotoxy(output,0,23); write(s,cteol);
  read(keyboard,c);
  fgotoxy(output,0,22); writeln(cteol);write(cteol);
  if (c>='a') and (c<='z') then c:= chr(ord(c)-32);
end;

procedure writedate(var f:  text;  date: daterec);
type months = packed array[0..35] of char;
const monthname = months['JanFebMarAprMayJunJulAugSepOctNovDec'];
var i,j: shortint;
begin
with date do
  begin
  {LAF 880101 added "mod 100" and removed test for "year<100"}
  if (month in [1..12]) and (day>0) then
    begin { Valid date }
    write(f, day:2, '-');
    j := (month - 1) * 3;
    for i := j to j+2 do write(f, monthname[i]);
    write(f, '-',year mod 100:2);
    end
  else write(f, '<no date>'); { Invalid date }
  end;
end; {datestring}

procedure gbytes(var p: integer; size: integer);
begin
 p := lowheap.a;        lowheap.a := lowheap.a + size;
 if lowheap.a > highheap.a then escape(112);
end;

procedure blockwrite(anyvar f: fib; anyvar obj: window; blocks,block: integer);
begin
  call (f.am, addr(f), writebytes, obj, blocks*fblksize, block*fblksize);
  if ioresult <> ord(inoerror) then escape(113);
end;

procedure readblocks(var f: fib; anyvar obj: window; size, block: integer);
begin
  call (f.am, addr(f), readbytes, obj, size, block*fblksize);
  if ioresult <> ord(inoerror) then escape(-10);
end;

procedure gvrstring(var gvp:gvrptr; var val:integer; pcrel,nores: boolean);

(*advances g past the GVR, adds any absolute part to VAL,
  and constructs a string representing the GVR in gvaluestring          *)

type
  rpp = ^referenceptr;
var
  Rcount:       shortint;
  done:         boolean;
  g:            gvrptr;
  i:            integer;

procedure sign(sub: boolean);
begin
 if sub then sappend(gvaluestring,'-')
 else if strlen(gvaluestring)>0 then sappend(gvaluestring,'+');
end;

begin {gvrstring}
 gvaluestring := '';       Rcount := 0;
 repeat
 if pcrel then g := loadgvr
	  else g := gvp;
 if g <> NIL then with g^ do
  begin
  if longoffset then
    g:=gvrptr(integer(g)+sizeof(generalvalue,true))
  else
    g:=gvrptr(integer(g)+sizeof(generalvalue,false));
  if valueextend then
    begin
    if not pcrel then val:= val + veptr(g)^.value;
    g:=gvrptr(integer(g)+sizeof(valueextension,sint));
    end;
  case primarytype of
   absolute: {no more value};
   relocatable: Rcount := Rcount + 1;
   global: begin sign(false); sappend(gvaluestring,'Gbase'); end;
   general:
    begin
    done := false;
    repeat with rpp(g)^ do
      begin
       if adr=0 then
	 if op=addit then Rcount := Rcount + 1
	 else Rcount := Rcount - 1
       else if adr=1 then
	 begin sign(op=subit); sappend(gvaluestring,'Gbase'); end
       else
	 begin sign(op=subit);
	 if newmods^.unresbits.bmp^[adr] or nores
	     then sappend(gvaluestring,symbolptr(newexttable+4*adr)^)
	     else sappend(gvaluestring,symbolptr(point(newexttable+4*adr)^)^);
	 end;
      done := last;
      g := gvrptr(integer(g)+sizeof(referenceptr));
      end;
    until done;
    end; {general}
   end; {primarytype cases}
  if not pcrel then gvp := g;
  end; {with g^}
 pcrel := not pcrel;
 until pcrel;
 while Rcount <> 0 do
  begin sign(Rcount<0); sappend(gvaluestring,'Rbase');
	if Rcount < 0 then Rcount := Rcount + 1
	else Rcount := Rcount - 1;
  end;
 if (val <> 0) or (strlen(gvaluestring)=0) then
  begin
  if val >= 0 then sign(false);
  strwrite(gvaluestring,strlen(gvaluestring)+1,i,val:1);
  end;
end; {gvrstring}


procedure printheader(var f: text);
var time: timerec;
begin
 write(f,'Librarian  [Rev.  3.25 ');
 if ioresult <> 0 then
   begin
   printopen := false;
   printeron := false;
   escape(118);
   end;
 writedate(f, linkerdate);
 write(f,']',' ':7);
 writedate(f, todaysdate);
 systime(time);
 with time do write(f, hour:4,':',minute:2,':',centisecond div 100:2);
 if pagenum > 0 then write(f,'page ':10,pagenum:1);
 writeln(f);
 writeln(f);
end;

procedure pageeject;
var i: integer;
begin
 if linenum > 0 then page(listing);
 linenum := 0;
end;

procedure list;
begin
  if linenum >= pagelines then pageeject;
  if linenum = 0 then
    begin
    pagenum := pagenum + 1;
    printheader(listing);
    linenum := linenum + 2;
    end;
  linenum := linenum + 1;
end;

procedure listln;
begin writeln(listing); linenum := linenum + 1;
end;

procedure quit;
var ch: char;
begin
  if (outopen and (outmodnum>0)) or
     (booting and (outblock>0)) then
  begin
  errorline;
  if booting then writeln('WARNING:  You didn''t finish booting')
  else writeln('WARNING:  You didn''t ''Keep'' the output file.');
  if streaming then escape(123)
  else
    begin
    write('Are you sure you want to quit?  (type Y if yes)  ');
    read(keyboard, ch);
    if (ch<>'y') and (ch<>'Y') then commandchar := ' ';
    end;
  end;
end;

function readint(var value: integer): boolean;
var s: string80;
    i: integer;
begin
  readln(s);
  strread(s,1,i,value);
  if ioresult<>ord(inoerror) then
    if i <= strlen(s) then escape(124);
  readint := ioresult=ord(inoerror);
end;

procedure unassemble;

type hex = 0..15;
     htoctyp = array[0..15] of char;
     decodestatetype = (consts,code,abscode,startcase,casetable,
			endofproc,quittype,notype,phdr);

const htoc = htoctyp['0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'];

var
  nilgvr:       gvrptr;
  dumped:       boolean;
  fortranflag:  boolean;
  rangetype: (norange, pcrange, linerange);
  lowrange, highrange, lastline: integer;
  decodestate,oldstate: decodestatetype;
  PC,tablePC,casecodestart: integer;
  codecount: integer; {bytes left in current inbuf}
  codeindex: integer; {next byte of code in inbuf}
  instrsize: 0..22;  {byte count of current instruction}
  refgvr: addrec;       reflim,refloc: address;
  inbuf,refptr: addrec;

procedure dumpmod (mp:moddescptr);
var junkint:    integer;
    producername: string[30];
    textstep: addrec;
    modulename: string255;      { rdq }
    def       : addrec;         { rdq }
    done      : boolean;        { rdq }

begin {dumpmod}
 dumped := true;
 with mp^,directory.drp^ do
  begin
  pageeject;
  textstep.a:=directory.a+sizeof(moduledirectory);
  list; write(listing,'MODULE    ');
  modulepc := -2;  { rdq }  { no module body }
  modulename := textstep.syp^; { rdq }
  if strlen(modulename) = 0 then write(listing,'(no name)')
  else
    begin
    write(listing,modulename);
    modulepc := -1;
    end;
  modulename := modulename+' '+modulename; { rdq } { make module entrypoint symbol }
  write(listing,'    Created ');
  writedate(listing, date); writeln(listing);
  list; write(listing,'NOTICE:  ');
  if strlen(notice)=0 then writeln(listing,'(none)')
		      else writeln(listing,notice);
  fortranflag := (producer = 'F');
  case producer of
    'M': producername := 'Modcal Compiler';
    'P': producername := 'Pascal Compiler';
    'L': producername := 'Librarian';
    'F': producername := 'FORTRAN Compiler';
    'B': producername := 'BASIC Compiler';
    'A': producername := 'Assembler';
    'C': producername := '''C'' Compiler';
    'D': producername := 'Ada Compiler';
    otherwise producername := '" "';
	      producername[2] := producer;
    end;
  list; write(listing,'  Produced by ', producername, ' of ');
  writedate(listing,revision); writeln(listing);
  if systemid = 0 then systemid := 1;
  list; writeln(listing,'  Revision number ',systemid:1);
  list; writeln(listing,'  Directory size ',directorysize:6,' bytes');
  list; writeln(listing,'  Module size    ',modulesize:6,' bytes');
  junkint:=strlen(textstep.syp^);
  textstep.a := textstep.a+junkint+2-ord(odd(junkint));
  if executable then
    begin
    startgvr := textstep;
    junkint := 0;
    modulepc := -2; { rdq executable so no 'module body' }
    gvrstring(textstep.gvp,junkint,false,false);
    list; writeln(listing,'  Execution address    ',gvaluestring);
    end
  else
    begin
    startgvr.gvp:=NIL;
    list; writeln(listing,'  Module NOT executable');
    end;
  list; writeln(listing,'  Code base      ',relocatablebase,
			'     Size ',relocatablesize,' bytes');
  list; writeln(listing,'  Global base    ',globalbase,
			'     Size ',globalsize,' bytes');
  if extsize <= 8 then extsize := 0;
  list; writeln(listing,'  EXT    block ',extblock:3,'     Size ',extsize,
	     ' bytes');
  list; writeln(listing,'  DEF    block ',defblock:3,'     Size ',defsize,
	     ' bytes');
  list;

  if (defsize>0) and (modulepc>-2) then       {RDQ}
  begin { find the module entry point }
    def:=defaddr;
    done:=false;
    REPEAT
      if def.a >= defaddr.a + defsize then done:=true
      else
      begin
	if def.syp^=modulename then
	begin { foundit now get its value }
	  done:=true;
	  def.a := def.a + strlen(def.syp^)+2-ord(odd(strlen(def.syp^)));
	  junkint:=0;
	  gvrstring(def.gvp,junkint,false,false);
	  strread(gvaluestring,7,junkint,modulepc);
	end
	else
	begin { advance to the next symbol }
	  def.a := def.a + strlen(def.syp^)+2-ord(odd(strlen(def.syp^)));
	  def.a := def.a + def.gvp^.short;
	end;
      end;
    UNTIL done;
  end;

if sourcesize <> 0 then
      writeln(listing,'  EXPORT block ',sourceblock:3,'     Size ',
	      sourcesize,' bytes')
  else
    writeln(listing,'  No EXPORT text');
  list; writeln(listing,'  There are ',textrecords,' TEXT records');
  listln; listln;
  end; {with mp^,directory^}
end; {dumpmod}

procedure prepunassem;
var i: integer;
begin
  modsave := newmods;
  newmods := NIL;
  infost  := lowheap;
  loadinfo(vmodnum, true, true);
  with newmods^,directory.drp^ do
   begin
   newexttable := extaddr.a;
   gbytes(unresbits.a, ((extsize div 4 + 15) div 16)*2);
   for i := 2 to extsize div 4 - 1 do unresbits.bmp^[i] := false;
   for i := 2 to listsize-1 do unresbits.bmp^[listaddr^[i] div 4] := true;
   end;
  if not dumped then dumpmod(newmods);
end;

procedure nextref;
begin
if refgvr.a < reflim then
  if refgvr.gvp^.longoffset then
    refloc:=refloc+refgvr.gvp^.long
  else
    refloc:=refloc+refgvr.gvp^.short;
end;

procedure listinstruction;
type
  regtype  = (D,A);
  regrange = 0..7;
  siz = (bytesiz,wordsiz,longsiz,invalid);
  opsizetype = array[bytesiz..longsiz] of string[3];
  exttype =
	packed record
	  case integer of
	    1: (uwordext: 0..65535);
	    2: (wordext: shortint);
	    3: (longext: integer);
	    4: (regclass: regtype;
		reg: regrange;
		long: boolean;
		scale : 0..3;
		case fullindex : boolean of
		  false: (case integer of
			   1: (byteext: -128..127);
			   2: (ubyteext: 0..255));
		  true:  (exbs : boolean;
			  exis : boolean;
			  exbdsize : 0..3;
			  expadbit : boolean;
			  exindirect : 0..7));
	    5: (mask: packed array [0..15] of boolean);
	    6: (bf_bit  : 0..1;
		bf_reg  : 0..7;
		bf_Do   : boolean;
		bf_offset : 0..31;
		bf_Dw   : boolean;
		bf_width  : 0..31);
	    7: (exDAbit1 : 0..1;
		exRn1  : 0..7;
		expad1 : 0..7;
		exDu1  : 0..7;
		expad2 : 0..7;
		exDc1  : 0..7;
		exDAbit2 : 0..1;
		exRn2  : 0..7;
		expad3 : 0..7;
		exDu2  : 0..7;
		expad4 : 0..7;
		exDc2  : 0..7);
	    8: (fopclas : 0..7;
		frx : 0..7;
		fry : 0..7;
		case integer of
		  0: (fextension : 0..127);
		  1: (fext : 0..15;
		      sincosreg : 0..7);
		  2: (Kfactor : -64..63);
		  3: (KDreg : 0..7;
		      zeros : 0..15));
	    end;


const       opsize = opsizetype['.b ','.w ','.l '];

var
  hexout: packed array[0..10,0..3] of hex;
  firstline: boolean;  { 1st line of current instruction? }
  bytesleft: 0..22;    { to be listed in current instr }
  instrbuf: string[255];{ alpha form of instruction }

  instr: packed record case integer of
	   1: (opcode: 0..15;
	       case integer of
		 1: (cond: 0..15;
		     displ: -128..127);
		 2: (reg1: regrange;
		     opmode: 0..7;
		     eamode: 0..7;
		     eareg: regrange);
		 3: (dummy: 0..7;
		     bit8: boolean;
		     size: siz;
		     fpredicate: 0..63)
	      );
	   3: (w: shortint);
	   4: (lb, rb: byte);
	   end; {instr}

  ext: exttype;
  procedure emitint(val: integer);
  var i: integer;
  begin
    strwrite(instrbuf, strlen(instrbuf)+1, i, val:1);
  end;

  procedure comma;
  begin  sappend(instrbuf, ','); end;

  procedure space;
  begin  sappend(instrbuf, ' '); end;

  procedure printinstrword;
  var k: integer;
  begin write(listing,' ');
    for k := 0 to 3 do
      write(listing,htoc[hexout[(instrsize-bytesleft) div 2,k]]);
    bytesleft := bytesleft-2;
  end;

  procedure getinstrbytes(size: shortint);
  begin
  if codecount < size then escape(121);
  moveleft(inbuf.stp^[codeindex],ext,size);
  moveleft(ext,hexout[instrsize div 2],size);
  instrsize := instrsize+size;
  codeindex := codeindex+size;
  codecount := codecount-size;
  end;

  procedure getinstruction;
  begin
  instrsize := 0;
  getinstrbytes(2);     instr.w := ext.wordext;
  end;

  procedure defineword;
  begin
  instrbuf := 'dc.w ';
  with instr do
    begin
    emitint(w);
    while strlen(instrbuf) < 11 do space;
    sappend(instrbuf,'   or dc.b ');
    emitint(lb); comma; emitint(rb);
    while strlen(instrbuf) < 30 do space;
    sappend(instrbuf,'   or dc.b ''  ''');
    if (lb >= 32) and (lb < 127) then instrbuf[43] := chr(lb);
    if (rb >= 32) and (rb < 127) then instrbuf[44] := chr(rb);
    end;
  end;

  procedure extend(size: integer; pcrel: boolean; fudge: integer);
    var offset, location, PCtemp: integer;
    begin
      location := PC+instrsize;
      if size = 1 then {byte extension}
	begin
	PCtemp := location + 1;
	size := 2;
	end
      else PCtemp := location;

      while (refgvr.a<reflim) and (refloc<PCtemp) do
	begin
	offset := 0;
	gvrstring(refgvr.gvp,offset,false,false);
	nextref;
	end;

      getinstrbytes(size);
      if odd(PCtemp)   then offset := ext.byteext
      else if size = 2 then offset := ext.wordext
		       else offset := ext.longext;
      if pcrel then offset := offset + location + fudge;
      if refloc=PCtemp then
	begin
	gvrstring(refgvr.gvp,offset,pcrel,false) ;
	nextref;
	end
      else
	gvrstring(nilgvr,offset,pcrel,false);
      sappend(instrbuf,gvaluestring);
    end;

  procedure unsigned_byte_extend;
    var offset, location, PCtemp: integer;
    begin
      location := PC+instrsize;
      PCtemp := location + 1;

      while (refgvr.a<reflim) and (refloc<PCtemp) do
	begin
	offset := 0;
	gvrstring(refgvr.gvp,offset,false,false);
	nextref;
	end;

      getinstrbytes(2);
      offset := ext.ubyteext;
      if refloc=PCtemp then
	begin
	gvrstring(refgvr.gvp,offset,false,false) ;
	nextref;
	end
      else
	gvrstring(nilgvr,offset,false,false);
      sappend(instrbuf,gvaluestring);
    end;

  procedure decode;
  label 1,2;
  type
    opndtype = (source,dest);
    regsymtype = array[regtype] of string[1];
    extsiztype = array[bytesiz..longsiz] of 1..4;
    arithoptype = array[8..13] of string[3];

    condcodetype = array[0..15] of string[2];

  const
    SP = 7;

    regsym = regsymtype['d','a'];
    extsize = extsiztype[1,2,4];

    condcode = condcodetype['t','f','hi','ls','cc','cs','ne','eq',
			    'vc','vs','pl','mi','ge','lt','gt','le'];
    arithop = arithoptype['or','sub','','cmp','and','add'];

  var
    tempint,I : integer;
    bf_reg : 0..7;
    bf_Do : boolean;
    bf_offset : 0..31;
    bf_Dw : boolean;
    bf_width : 0..32;

    procedure osize;
    var size: siz;
    begin size := instr.size;
    if size = invalid then goto 2;
    sappend(instrbuf, opsize[size])
    end;

    procedure emitdir(regclass: regtype; reg: regrange);
    begin if (regclass = A) and (reg = SP) then sappend(instrbuf,'sp')
	  else begin
	       sappend(instrbuf,regsym[regclass]);
	       setstrlen(instrbuf, strlen(instrbuf) + 1);
	       instrbuf[strlen(instrbuf)] := htoc[reg];
	       end;
    end;

    procedure emitardef(reg: regrange);
    begin sappend(instrbuf,'(');
	  emitdir(A,reg);
	  sappend(instrbuf,')');
    end;

    procedure emitardisp(reg: regrange);
    begin extend(2,false,0);
	  emitardef(reg);
    end;

    procedure emitpostincr(reg: regrange);
    begin emitardef(reg);
	  sappend(instrbuf, '+');
    end;

    procedure emitpredecr(reg: regrange);
    begin sappend(instrbuf, '-');
	  emitardef(reg);
    end;

    procedure emitindx(pcrel: boolean);
      var
	I : integer;
	saveext : exttype;
    begin
    moveleft(inbuf.stp^[codeindex],ext,2); { fake 'getinstrbytes(2)' }
    if not ext.fullindex then
      if ext.scale = 0 then
	begin
	extend(1,pcrel,0); sappend(instrbuf, '(');
	with instr, ext do
	  begin
	  if not pcrel then
	    begin emitdir(A, eareg); comma; end;
	  emitdir(regclass,reg);
	  if long then sappend(instrbuf,'.l)')
		  else sappend(instrbuf,'.w)');
	  end;
	end
      else
	begin
	sappend(instrbuf,'(');
	extend(1,pcrel,0);
	if pcrel then
	  sappend(instrbuf,',')
	else
	  strwrite(instrbuf,strlen(instrbuf)+1,I,',a',instr.eareg:1,',');
	emitdir(ext.regclass,ext.reg);
	if ext.long then sappend(instrbuf,'.l')
		    else sappend(instrbuf,'.w');
	case ext.scale of
	  1: sappend(instrbuf,'*2)');
	  2: sappend(instrbuf,'*4)');
	  3: sappend(instrbuf,'*8)');
	end;
	end
    else { fullindex }
      begin
      getinstrbytes(2);  { Now do this for real }
      if ext.exindirect <> 0 then sappend(instrbuf,'([')
			     else sappend(instrbuf,'(');
      saveext := ext;
      case saveext.exbdsize of
	0: goto 2;
	1: ;
	2: extend(2,pcrel and (not saveext.exbs),-2);
	3: extend(4,pcrel and (not saveext.exbs),-2);
      end;
      if not saveext.exbs then
	begin
	if not pcrel then
	  begin
	  if (instrbuf[strlen(instrbuf)] <> '(') and
	     (instrbuf[strlen(instrbuf)] <> '[') then
	    comma;
	  strwrite(instrbuf,strlen(instrbuf)+1,I,'a',instr.eareg:1);
	  end
	else if (saveext.exbdsize = 1) { suppress displacement ? } then
	  sappend(instrbuf,'PC');
	end
      else
	if pcrel then
	  begin
	  if (instrbuf[strlen(instrbuf)] <> '(') and
	     (instrbuf[strlen(instrbuf)] <> '[') then
	    comma;
	  sappend(instrbuf,'ZPC')
	  end;
      if saveext.exindirect in [5,6,7] then
	sappend(instrbuf,']');
      if not saveext.exis then
	begin
	if (instrbuf[strlen(instrbuf)] <> '(') and
	   (instrbuf[strlen(instrbuf)] <> '[') then
	  comma;
	emitdir(saveext.regclass,saveext.reg);
	if saveext.long then sappend(instrbuf,'.l')
			else sappend(instrbuf,'.w');
	case saveext.scale of
	  0: ;
	  1: sappend(instrbuf,'*2');
	  2: sappend(instrbuf,'*4');
	  3: sappend(instrbuf,'*8');
	end;
	end;
      if saveext.exindirect in [1,2,3] then
	sappend(instrbuf,']');
      case saveext.exindirect of
	0,1,4,5: ;
	2,6: begin
	     if (instrbuf[strlen(instrbuf)] <> '(') and
		(instrbuf[strlen(instrbuf)] <> '[') then
	       comma;
	     extend(2,false,0);
	     end;
	3,7: begin
	     if (instrbuf[strlen(instrbuf)] <> '(') and
		(instrbuf[strlen(instrbuf)] <> '[') then
	       comma;
	     extend(4,false,0);
	     end;
      end;
      sappend(instrbuf,')');
      end;
    end;

    procedure emitimm(val: integer);
    begin
      sappend(instrbuf,'#'); emitint(val);
    end;

    procedure immediate(fsize: siz);
    begin
      if fsize = invalid then goto 2;
      sappend(instrbuf,'#');
      extend(extsize[fsize],false,0);
    end; {immediate}

    procedure emitea(fsize: siz);
    begin
      with instr do
	case eamode of
      0: emitdir(D,eareg);
      1: emitdir(A,eareg);
      2: emitardef(eareg);
      3: emitpostincr(eareg);
      4: emitpredecr(eareg);
      5: emitardisp(eareg);
      6: emitindx(false);
      7: case eareg of
	0: extend(2,false,0);
	1: extend(4,false,0);
	2: extend(2,true,0);
	3: emitindx(true);
	4: immediate(fsize);
	5..7: goto 2;
	 end; {case eareg}
       end; {case eamode}
    end; {emitea}

    procedure opcode0;
      { bit, MOVEP, immediate, MOVES }

    type bitoptype = array[siz] of string[5];
	 immoptype = array[0..6] of string[4];
    const bitop = bitoptype['btst ','bchg ','bclr ','bset '];
	  immop = immoptype['ori','andi','subi','addi','','eori','cmpi'];
    var
      I : integer;
      regsave : 0..7;

    begin { opcode0 }
      with instr do
	if bit8 then
	  if eamode = 1 then
	    begin
	      if odd(opmode) then instrbuf := 'movep.l '
			     else instrbuf := 'movep.w ';
	      if opmode <= 5 then
		begin emitardisp(eareg);
		  comma; emitdir(D,reg1);
		end
	      else begin
		   emitdir(D,reg1);
		   comma; emitardisp(eareg);
		   end;
	    end
	  else begin {dynamic bit}
		 instrbuf := bitop[size];
		 emitdir(D,reg1);
		 comma; emitea(bytesiz);
	       end
	else if reg1=4 then
	  begin instrbuf := bitop[size];
	    immediate(bytesiz); comma;
	    emitea(bytesiz {invalid});
	  end
	else { NOT bit8 } if ord(size) = 3 then
	  if (reg1 > 4) {bit 11 on} then
	    if (eamode = 7) and (eareg = 4) then {cas2}
	      begin
	      case reg1 of
		5: instrbuf := 'cas2.b ';
		6: instrbuf := 'cas2.w ';
		7: instrbuf := 'cas2.l ';
	      otherwise ;
	      end;
	      getinstrbytes(4);
	      strwrite(instrbuf,strlen(instrbuf),I,
				' d',ext.exDc1:1,':d',ext.exDc2:1,
				',d',ext.exDu1:1,':d',ext.exDu2:1,',(');
	      if ext.exDAbit1 = 0 then sappend(instrbuf,'d ')
				  else sappend(instrbuf,'a ');
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exRn1:1,'):(');
	      if ext.exDAbit2 = 0 then sappend(instrbuf,'d ')
				  else sappend(instrbuf,'a ');
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exRn2:1,')');
	      end
	    else {cas}
	      begin
	      case reg1 of
		5: instrbuf := 'cas.b d ';
		6: instrbuf := 'cas.w d ';
		7: instrbuf := 'cas.l d ';
		otherwise ;
	      end;
	      getinstrbytes(2);
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exDc1:1,',d',
						   ext.exDu1:1,',');
	      emitea(bytesiz);
	      end
	  else if reg1 < 3 then {chk2 cmp2}
	    begin
	    getinstrbytes(2);
	    if ext.long then instrbuf := 'chk2'
			else instrbuf := 'cmp2';
	    case reg1 of
	      0: sappend(instrbuf,'.b ');
	      1: sappend(instrbuf,'.w ');
	      2: sappend(instrbuf,'.l ');
	    end;
	    regsave := ext.reg;
	    if ext.regclass = D then
	      begin
	      emitea(bytesiz);
	      strwrite(instrbuf,strlen(instrbuf)+1,I,',d',regsave:1);
	      end
	    else
	      begin
	      emitea(bytesiz);
	      strwrite(instrbuf,strlen(instrbuf)+1,I,',a',regsave:1);
	      end;
	    end
	  else if eamode <= 1 then
	    begin
	    if eamode = 0 then instrbuf := 'rtm d '
			  else instrbuf := 'rtm a ';
	    strwrite(instrbuf,strlen(instrbuf),I,eareg:1);
	    end
	  else
	    begin
	    instrbuf := 'callm ';
	    sappend(instrbuf,'#');
	    unsigned_byte_extend;
	    comma;
	    emitea(bytesiz);
	    end
	else { ord(size) <> 3 }
	  begin
	  if reg1=7 then
	    begin { moves }
	    instrbuf:='moves'; osize;
	    getinstrbytes(2);
	    if ext.long then
	      begin emitdir(ext.regclass,ext.reg); comma; emitea(size);
	      end
	    else
	      begin emitea(size); comma; emitdir(ext.regclass,ext.reg);
	      end;
	    end
	  else
	    begin
	    instrbuf := immop[reg1];
	    if (eamode=7) and (eareg=4) then
		 begin
		 space; immediate(wordsiz); comma;
		 if size = bytesiz then sappend(instrbuf, 'ccr')
				   else sappend(instrbuf, 'sr');
		 end
	    else begin
		 osize; immediate(size); comma; emitea(size);
		 end;
	    end;
	  end;
    end; {opcode0}

    procedure move;
    { opcodes 1..3: move byte,long,word }
    var lsize: siz;
    begin
      with instr do
	begin
	  case opcode of
	 1: lsize := bytesiz;
	 2: lsize := longsiz;
	 3: lsize := wordsiz;
	  end;
	  instrbuf := 'move';
	  if opmode=1 then sappend(instrbuf,'a');
	  sappend(instrbuf,opsize[lsize]);
	  emitea(lsize); comma;
	  if (opmode=7) and (reg1>1) then goto 2;
	  {kluge to make emitea emit destination}
	  eamode := opmode; eareg := reg1;
	  emitea(lsize  {invalid});
	end;
    end; {move}

    procedure opcode4;
    type miscoptype = array[0..7] of string[5];
	 unoptype = array[0..5] of string[4];
    const predecr = 4; { eamode for predecrement }
	 miscop =
	  miscoptype['reset','nop','stop','rte','rtd','rts','trapv','rtr'];
	 unop = unoptype['negx', 'clr', 'neg', 'not', '', 'tst'];
    var   regstring: string80;
	  I : integer;
	  Dl, Dh : shortint;
	  variantrec : packed record case boolean of
			 true: (w1,w2: shortint);
			 false: (i : integer);
		       end;

      procedure emitreglist
	(optype: opndtype; predecr: boolean; var regstring: string80);
	{ emit register list to 'regstring' according to mask }
      type
	regmasksymtype = array[0..15] of string[2];
      const
	regmasksym = regmasksymtype
	  ['d0','d1','d2','d3','d4','d5','d6','d7',
	   'a0','a1','a2','a3','a4','a5','a6','a7'];
      var
	state: (start,         {waiting for a '1'}
		open,          {have seen a lone '1'}
		cont);         {at least two consecutive '1's}
	j,k,bitcount: integer;

	procedure transition(b: boolean);
	var states: shortint;
	begin
	  if b then
	     if optype = source then states := 6 else states := 5;
	  case state of
	start: if b then
		 begin state := open;
		 sappend(regstring,regmasksym[bitcount]);
		 end;
	open : if b then
		 begin state := cont;
		 sappend(regstring,'-');
		 end
	       else begin state := start;
		    sappend(regstring,'/');
		    end;
	cont : if not b then
		 begin state := start;
		 sappend(regstring,regmasksym[bitcount-1]);
		 sappend(regstring,'/');
		 end;
	  end; {case}
	end; {transition}

      begin {emitreglist}
	getinstrbytes(2);
	if ext.wordext = 0 then regstring := '(none) '
	else
	  begin
	  state := start;
	  bitcount := 0; regstring := '';
	  if not predecr then
	    for j := 1 downto 0 do
	      begin
		for k := 7 downto 0 do
		  begin transition(ext.mask[k+j*8]);
		    bitcount := bitcount+1;
		  end;
		transition(false);
	      end
	  else
	    for j := 0 to 1 do
	      begin
		for k := 0 to 7 do
		  begin transition(ext.mask[k+j*8]);
		    bitcount := bitcount+1;
		  end;
		transition(false);
	      end;
	  end;
	if optype = source then
	  regstring[strlen(regstring)] := ','
	else setstrlen(regstring, strlen(regstring)-1);
      end; {emitreglist}

    procedure emitunop;
    begin with instr do
     begin
     instrbuf := unop[reg1]; osize;
     emitea(size {invalid});
     end;
    end;

    procedure emitsreg;
    begin
      with ext do
      begin
	if (scale <> 0) or (fullindex) then goto 2;
	if not long then
	begin
	  if byteext=0 then sappend(instrbuf,'sfc')
	  else if byteext=1 then sappend(instrbuf,'dfc')
	  else if byteext = 2 then sappend(instrbuf,'cacr')
	  else if byteext = 3 then sappend(instrbuf,'tc') { JWH 12/22/89 }
	  else if byteext = 4 then sappend(instrbuf,'itt0') { JWH 12/22/89 }
	  else if byteext = 5 then sappend(instrbuf,'itt1') { JWH 12/22/89 }
	  else if byteext = 6 then sappend(instrbuf,'dtt0') { JWH 12/22/89 }
	  else if byteext = 7 then sappend(instrbuf,'dtt1') { JWH 12/22/89 }
	       else goto 2;
	end
	else
	begin
	  if byteext=0 then sappend(instrbuf,'usp')
	  else if byteext=1 then sappend(instrbuf,'vbr')
	  else if byteext = 2 then sappend(instrbuf,'caar')
	  else if byteext = 3 then sappend(instrbuf,'msp')
	  else if byteext = 4 then sappend(instrbuf,'isp')
	  else if byteext = 5 then sappend(instrbuf,'mmusr') { JWH 12/22/89 }
	  else if byteext = 6 then sappend(instrbuf,'urp') { JWH 12/22/89 }
	  else if byteext = 7 then sappend(instrbuf,'srp') { JWH 12/22/89 }
	       else goto 2;
	end;
      end;
    end;

    procedure jmpstates;
    begin with instr do
      case eamode of
	2,5,6:;
	7:  if eareg>3 then goto 2;
	otherwise goto 2;
	end;
    end;

    begin {opcode4}
      with instr do
	if bit8 then
	  if ord(size) = 2 then
	    begin
	    instrbuf := 'chk ';
	     emitea(wordsiz); comma;
	     emitdir(D,reg1);
	     end
	  else if ord(size) = 0 then
	    begin
	    instrbuf := 'chk.l ';
	    emitea(longsiz);
	    comma;
	    emitdir(D,reg1);
	    end
	  else if eamode = 0 then
	    begin
	    instrbuf := 'extb.l ';
	    emitdir(D,eareg);
	    end
	  else
	    begin
	    instrbuf := 'lea ';
	    emitea(invalid); comma;
	    emitdir(A,reg1);
	    end
	else { NOT bit8 }
	  case reg1 of
	    0: if size=invalid then
		 begin instrbuf := 'move sr,'; emitea(wordsiz);
		 end
	       else emitunop;
	    1: if size=invalid then
		 begin instrbuf := 'move ccr,'; emitea(wordsiz);
		 end
	       else emitunop;
	       2: if size = invalid then
		 begin instrbuf := 'move ';
		 emitea(wordsiz);
		 sappend(instrbuf, ',ccr');
		 end
	       else emitunop;
	    3: if size = invalid then
		 begin instrbuf := 'move ';
		 emitea(wordsiz);
		 sappend(instrbuf, ',sr');
		 end
	       else emitunop;
	    4: case ord(size) of
		 0: if eamode = 1 then
		   begin
		   instrbuf := 'link.l ';
		   emitdir(A,eareg);
		   comma;
		   immediate(longsiz);
		   end
		 else
		   begin
		   instrbuf := 'nbcd ';
		   emitea(bytesiz {invalid});
		   end;
		 1: if eamode = 0 then
		      begin instrbuf := 'swap '; emitdir(D,eareg);
		      end
		    else if eamode = 1 then
		      begin
		      instrbuf := 'bkpt # ';
		      strwrite(instrbuf,strlen(instrbuf),I,eareg:1);
		      end
		    else
		      begin instrbuf := 'pea '; emitea(invalid);
		      end;
	       2,3: if eamode = 0 then
		      begin instrbuf := 'ext';
		      sappend(instrbuf,opsize[pred(size)]);
		      emitdir(D,eareg);
		      end
		    else
		      begin
		      instrbuf := 'movem';
		      sappend(instrbuf,opsize[pred(size)]);
		      emitreglist(source,eamode=predecr,regstring);
		      sappend(instrbuf,regstring);
		      emitea(invalid);
		      end;
		 end; {case size}
	    5: if instr.w = 19196 {hex('4AFC')} then
		 instrbuf := 'illegal'
	       else if size = invalid then
		  begin instrbuf := 'tas ';
		  emitea(bytesiz {invalid});
		  end
	       else emitunop;
	    6: if size<longsiz then
		 begin
		 getinstrbytes(2);
		 if size = bytesiz then
		   if ext.long then instrbuf := 'muls.l '
				else instrbuf := 'mulu.l '
		 else
		   begin
		   if ext.long then instrbuf := 'divs'
				else instrbuf := 'divu';
		   if ext.scale = 2 then sappend(instrbuf,'.l ')
		   else if ext.reg = ext.byteext then sappend(instrbuf,'.l ')
						 else sappend(instrbuf,'l.l ');
		   end;
		 Dl := ext.reg;
		 if (ext.scale = 2) or
		    ((Dl <> ext.byteext) and (size <> bytesiz)) then
		   Dh := ext.byteext
		 else
		   Dh := -1;
		 emitea(longsiz);
		 comma;
		 if (Dh >= 0) and (Dh <= 7) then
		   begin
		   emitdir(D,Dh);
		   sappend(instrbuf,':');
		   end;
		 emitdir(D,Dl);
		 end
	       else
		 begin instrbuf := 'movem';
		 sappend(instrbuf,opsize[pred(size)]);
		 emitreglist(dest,false,regstring);
		 emitea(invalid); comma;
		 sappend(instrbuf,regstring);
		 end;
	    7: if ord(size) = 2 then
		 begin instrbuf := 'jsr ';
		 jmpstates;
		 emitea(invalid);
		 end
	       else if ord(size) = 3 then
		 begin instrbuf := 'jmp ';
		 jmpstates;
		 emitea(invalid);
		 end
	       else
		 case eamode of
		   0,1:
		      begin instrbuf := 'trap ';
		      emitimm(eareg+8*eamode);
		      if eareg + 8*eamode = 9 then
			begin
			comma; immediate(wordsiz);
			comma; extend(4,true,0);
			end
		      else
		      if eareg + 8*eamode = 1 then
			begin
			sappend(instrbuf,',# ');
			getinstrbytes(2);
			if ext.wordext > 0 then
			  begin
			  variantrec.w1 := ext.wordext;
			  getinstrbytes(2);
			  variantrec.w2 := ext.wordext;
			  variantrec.i := -(variantrec.i - 1073741824);
			  strwrite(instrbuf,strlen(instrbuf),I,variantrec.i:1)
			  end
			else
			  strwrite(instrbuf,strlen(instrbuf),I,ext.wordext:1);
			end
		      else
		      if eareg + 8*eamode = 0 then
			begin
			comma; getinstrbytes(2);
			lastline := ext.uwordext;
			emitimm(lastline);
			while strlen(instrbuf) < 20 do space;
			sappend(instrbuf, 'COMPILED LINE NUMBER ');
			emitint(lastline);
			end;
		      end;
		   2: begin instrbuf := 'link ';
			emitdir(A,eareg); comma;
			immediate(wordsiz);
		      end;
		   3: begin instrbuf := 'unlk '; emitdir(A,eareg);
		      end;
		   4,5:
		      begin instrbuf := 'move ';
			if eamode = 5 then sappend(instrbuf,'usp,');
			emitdir(A,eareg);
			if eamode = 4 then sappend(instrbuf,',usp');
		      end;
		   6: begin
		      instrbuf := miscop[eareg];
		      if (eareg=2) or (eareg=4) then {stop}{rtd}
			  begin space; immediate(wordsiz);
			  end;
		      end;
		   7: begin     { movec }
			if ord(size)<>1 then goto 2;
			instrbuf := 'movec ';
			getinstrbytes(2);
			if eareg=2 then
			begin
			emitsreg; comma; emitdir(ext.regclass,ext.reg);
			end
			else
			  if eareg=3 then
			  begin
			  emitdir(ext.regclass,ext.reg); comma; emitsreg;
			  end
			  else goto 2;
		      end;
		  end; {case eamode}
	    end; {case reg1}
    end; {opcode4}

    procedure quick;
    begin
    with instr do if reg1 = 0 then emitimm(8)
			      else emitimm(reg1);
    comma;
    end;

    procedure shift;
    type
      shiftoptype = array[0..7] of string[4];
    const
      shiftop =
	shiftoptype['asr','lsr','roxr','ror','asl','lsl','roxl','rol'];
    begin
      with instr do
	if size = invalid then
	  begin instrbuf := shiftop[4*ord(bit8)+reg1];
	  space; emitea(bytesiz {invalid});
	  end
	else
	  begin
	  instrbuf := shiftop[4*ord(bit8)+eamode mod 4];
	  osize;
	  if eamode div 4 = 1 then
	    begin
	    emitdir(D,reg1);
	    comma;
	    end
	  else quick;
	  emitdir(D,eareg);
	  end;
    end; {shift}

  procedure mc68881;
    var
      I,j,k : integer;
      saveext : exttype;

    procedure emitfdir(reg: regrange);
      begin
      sappend(instrbuf,'fp ');
      instrbuf[strlen(instrbuf)] := htoc[reg];
      end;

    procedure emitfea(size: integer);
      type
	hexarray = array[0..15] of char;
      const
	hex = hexarray['0','1','2','3','4','5','6','7','8','9',
		       'a','b','c','d','e','f'];
      var
	j,l : integer;
	variantrec : packed record case integer of
		       0: (i: integer);
		       1: (h: packed array[1..24] of 0..15);
		       2: (i1,i2,i3: integer);
		       3: (r : longreal);
		     end;
      begin
      if (instr.eamode = 7) and (instr.eareg = 4) then { Immediate }
	case size of
	  0: {L} immediate(longsiz);
	  1: {S} begin
		 sappend(instrbuf,'#');
		 getinstrbytes(4);
		 variantrec.i := ext.longext;
		 sappend(instrbuf,'$');
		 for j := 1 to 8 do
		   strwrite(instrbuf,strlen(instrbuf)+1,I,hex[variantrec.h[j]]);
		 end;
	  2,3: {X,P}
		begin
		sappend(instrbuf,'#');
		getinstrbytes(4);
		variantrec.i1 := ext.longext;
		getinstrbytes(4);
		variantrec.i2 := ext.longext;
		getinstrbytes(4);
		variantrec.i3 := ext.longext;
		sappend(instrbuf,'$');
		for j := 1 to 24 do
		  strwrite(instrbuf,strlen(instrbuf)+1,I,hex[variantrec.h[j]]);
		end;
	  4: {W} immediate(wordsiz);
	  5: {D} begin
		 sappend(instrbuf,'#');
		 getinstrbytes(4);
		 variantrec.i1 := ext.longext;
		 getinstrbytes(4);
		 variantrec.i2 := ext.longext;
		 try
		   if variantrec.r > 0 then
		     strwrite(instrbuf,strlen(instrbuf)+1,i,variantrec.r:21)
		   else
		     strwrite(instrbuf,strlen(instrbuf)+1,i,variantrec.r:22)
		 recover
		   if escapecode = -18 { bad arg in real/BCD conversion} then
		     begin
		     sappend(instrbuf,'$');
		     for j := 1 to 16 do
		       strwrite(instrbuf,strlen(instrbuf)+1,i,hex[variantrec.h[j]]);
		     end
		   else
		     escape(escapecode);
		 end;
	  6: {B} immediate(bytesiz);
	  otherwise goto 2;
	end {case}
      else
	emitea(bytesiz);
      end;

    procedure dumpfregbits(reglist : byte; zfirst : boolean);
      type
	string1 = string[1];
      var
	variantrec : packed record case boolean of
		       true: (b: byte);
		       false:(a: packed array[0..7] of boolean);
		     end;
	regnum, bitnum, lastbit : integer;

      function makestring(c: char): string1;
	var
	  s: string1;
	begin
	setstrlen(s,1);
	s[1] := c;
	makestring := s;
	end;

      procedure hithit; forward;

      procedure hitmiss; forward;

      procedure hithithit;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then
	    hithithit
	  else
	    begin
	    sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum-1)));
	    hitmiss;
	    end
	else
	  sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum-1)));
	end;

      procedure misshit;
	begin
	sappend(instrbuf,'/fp' + makestring(chr(ord('0')+regnum)));
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then hithit
				  else hitmiss;
	end;

      procedure hitmiss;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then misshit
				  else hitmiss;
	end;

      procedure hithit;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if (bitnum = lastbit) then
	  begin
	  sappend(instrbuf,'-fp' + makestring(chr(ord('0')+regnum-1)));
	  end
	else if not variantrec.a[bitnum] then
	  begin
	  sappend(instrbuf,'-fp' + makestring(chr(ord('0')+regnum-1)));
	  hitmiss;
	  end
	else
	  begin
	  sappend(instrbuf,'-');
	  hithithit;
	  end;
	end;

      procedure firsthit;
	begin
	sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum)));
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then hithit
				  else hitmiss;
	end;

      procedure firstmiss;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then firsthit
				  else firstmiss;
	end;

      begin
      variantrec.b := reglist;
      if zfirst then
	begin
	bitnum := 0;
	lastbit := 8;
	end
      else
	begin
	bitnum := 7;
	lastbit := -1;
	end;
      regnum := 0;
      if variantrec.a[bitnum] then firsthit
			      else firstmiss;
      end;

    procedure appendfloatsize(size : integer);
      begin
      case size of
	0: sappend(instrbuf,'.l ');
	1: sappend(instrbuf,'.s ');
	2: sappend(instrbuf,'.x ');
	3,7: sappend(instrbuf,'.p ');
	4: sappend(instrbuf,'.w ');
	5: sappend(instrbuf,'.d ');
	6: sappend(instrbuf,'.b ');
	otherwise goto 2;
      end; {case}
      end;

    procedure appendfloatcondition(predicate : integer);
      begin
      case predicate of
	0:  sappend(instrbuf,'f');
	1:  sappend(instrbuf,'eq');
	2:  sappend(instrbuf,'ogt');
	3:  sappend(instrbuf,'oge');
	4:  sappend(instrbuf,'olt');
	5:  sappend(instrbuf,'ole');
	6:  sappend(instrbuf,'ogl');
	7:  sappend(instrbuf,'or');
	8:  sappend(instrbuf,'un');
	9:  sappend(instrbuf,'ueq');
	10: sappend(instrbuf,'ugt');
	11: sappend(instrbuf,'uge');
	12: sappend(instrbuf,'ult');
	13: sappend(instrbuf,'ule');
	14: sappend(instrbuf,'neq');
	15: sappend(instrbuf,'t');
	16: sappend(instrbuf,'sf');
	17: sappend(instrbuf,'seq');
	18: sappend(instrbuf,'gt');
	19: sappend(instrbuf,'ge');
	20: sappend(instrbuf,'lt');
	21: sappend(instrbuf,'le');
	22: sappend(instrbuf,'gl');
	23: sappend(instrbuf,'leg');
	24: sappend(instrbuf,'nleg');
	25: sappend(instrbuf,'ngl');
	26: sappend(instrbuf,'nle');
	27: sappend(instrbuf,'nlt');
	28: sappend(instrbuf,'nge');
	29: sappend(instrbuf,'ngt');
	30: sappend(instrbuf,'sne');
	31: sappend(instrbuf,'st');
	otherwise goto 2;
      end;
      end;

    begin { mc68881 }
    with instr do
      begin
      if opmode = 0 then
	begin
	getinstrbytes(2);
	if ext.fopclas >= 6 then { FMOVEM }
	  begin
	  instrbuf := 'fmovem ';
	  if ext.fopclas = 6 then { move to FP data registers }
	    begin
	    saveext := ext;
	    emitea(bytesiz);
	    comma;
	    if saveext.frx = 6 then { D reg }
	      emitdir(D,saveext.KDreg)
	    else if saveext.frx = 4 then { register mask }
	      dumpfregbits(saveext.ubyteext,true)
	    else goto 2;
	    end
	  else { move from FP data registers }
	    begin
	    if (ext.frx = 2) or (ext.frx = 6) then
	      emitdir(D,ext.KDreg)
	    else if (ext.frx = 0) or (ext.frx = 4) then
	      if ext.frx = 0 then dumpfregbits(ext.ubyteext,false)
			     else dumpfregbits(ext.ubyteext,true)
	    else goto 2;
	    comma;
	    emitea(bytesiz);
	    end;
	  end
	else if ext.fopclas >= 4 then { FMOVE sysreg }
	  begin
	  if ext.frx in [1,2,4] then
	    instrbuf := 'fmove '
	  else
	    instrbuf := 'fmovem ';
	  if ext.fopclas = 4 then { move to sysregs }
	    begin
	    saveext := ext;
	    emitea(longsiz);
	    case saveext.frx of
	      0: sappend(instrbuf,',-');
	      1: sappend(instrbuf,',fpiaddr');
	      2: sappend(instrbuf,',fpstatus');
	      3: sappend(instrbuf,',fpstatus/fpiaddr');
	      4: sappend(instrbuf,',fpcontrol');
	      5: sappend(instrbuf,',fpcontrol/fpiaddr');
	      6: sappend(instrbuf,',fpcontrol/fpstatus');
	      7: sappend(instrbuf,',fpcontrol/fpstatus/fpiaddr');
	    end; {case}
	    end
	  else { move from sysregs }
	    begin
	    case ext.frx of
	      0: escape(0);
	      1: sappend(instrbuf,'fpiaddr,');
	      2: sappend(instrbuf,'fpstatus,');
	      3: sappend(instrbuf,'fpstatus/fpiaddr,');
	      4: sappend(instrbuf,'fpcontrol,');
	      5: sappend(instrbuf,'fpcontrol/fpiaddr,');
	      6: sappend(instrbuf,'fpcontrol/fpstatus,');
	      7: sappend(instrbuf,'fpcontrol/fpstatus/fpiaddr,');
	    end; {case}
	    emitea(bytesiz);
	    end;
	  end
	else if (ext.fopclas = 2) and (ext.frx = 7) then { FMOVECR }
	  begin
	  instrbuf := 'fmovecr # ';
	  strwrite(instrbuf,strlen(instrbuf),I,ext.fextension:1,',');
	  emitfdir(ext.fry);
	  end
	else { general }
	  begin
	  case ext.fextension of
	    0: instrbuf := 'fmove';
	    1: instrbuf := 'fint';
	    2: instrbuf := 'fsinh';
	    3: instrbuf := 'fintrz';    (* LAF 861204 *)
	    4: instrbuf := 'fsqrt';
	    6: instrbuf := 'flognp1';
	    8: instrbuf := 'fetoxm1';
	    9: instrbuf := 'ftanh';
	    10:instrbuf := 'fatan';
	    12:instrbuf := 'fasin';
	    13:instrbuf := 'fatanh';
	    14:instrbuf := 'fsin';
	    15:instrbuf := 'ftan';
	    16:instrbuf := 'fetox';
	    17:instrbuf := 'ftwotox';
	    18:instrbuf := 'ftentox';
	    20:instrbuf := 'flogn';
	    21:instrbuf := 'flog10';
	    22:instrbuf := 'flog2';
	    24:instrbuf := 'fabs';
	    25:instrbuf := 'fcosh';
	    26:instrbuf := 'fneg';
	    28:instrbuf := 'facos';
	    29:instrbuf := 'fcos';
	    30:instrbuf := 'fgetexp';
	    31:instrbuf := 'fgetman';
	    32:instrbuf := 'fdiv';
	    33:instrbuf := 'fmod';
	    34:instrbuf := 'fadd';
	    35:instrbuf := 'fmul';
	    36:instrbuf := 'fsgldiv';
	    37:instrbuf := 'frem';
	    38:instrbuf := 'fscale';
	    39:instrbuf := 'fsglmul';
	    40:instrbuf := 'fsub';
	    48..55:instrbuf := 'fsincos';
	    56:instrbuf := 'fcmp';
	    58:instrbuf := 'ftst';
	    64:instrbuf := 'fsmove';  { JWH 12/21/89 }
	    65:instrbuf := 'fssqrt';  { JWH 12/21/89 }
	    68:instrbuf := 'fdmove';  { JWH 12/21/89 }
	    69:instrbuf := 'fdsqrt';  { JWH 12/21/89 }
	    88:instrbuf := 'fsabs';  { JWH 12/21/89 }
	    90:instrbuf := 'fsneg';  { JWH 12/21/89 }
	    92:instrbuf := 'fdabs';  { JWH 12/21/89 }
	    94:instrbuf := 'fdneg';  { JWH 12/21/89 }
	    96:instrbuf := 'fsdiv';  { JWH 12/21/89 }
	    98:instrbuf := 'fsadd';  { JWH 12/21/89 }
	    99:instrbuf := 'fsmul';  { JWH 12/21/89 }
	    100:instrbuf := 'fddiv';  { JWH 12/21/89 }
	    102:instrbuf := 'fdadd';  { JWH 12/21/89 }
	    103:instrbuf := 'fdmul';  { JWH 12/21/89 }
	    104:instrbuf := 'fssub';  { JWH 12/21/89 }
	    108:instrbuf := 'fdsub';  { JWH 12/21/89 }
	    otherwise ;
	  end; {case}
	  if ext.fopclas = 0 then { source is Freg }
	    begin
	    sappend(instrbuf,' ');
	    emitfdir(ext.frx);
	    if (ext.fextension = 58 {FTST}) or ((ext.frx = ext.fry) and
	       (ext.fextension <> 0 {FMOVE}) and (ext.fextension < 32)) then
	      { Do not display second op for FTST or "single op" instructions }
	    else
	      begin
	      comma;
	      if ext.fext = 6 then { FSINCOS }
		begin
		emitfdir(ext.sincosreg);
		sappend(instrbuf,':');
		end;
	      emitfdir(ext.fry);
	      end;
	    end
	  else if ext.fopclas = 2 then { source is <ea> }
	    begin
	    appendfloatsize(ext.frx);
	    saveext := ext;
	    emitfea(saveext.frx);
	    if  saveext.fextension <> 58 {FTST} then
	      begin
	      comma;
	      if saveext.fext = 6 then { FSINCOS }
		begin
		emitfdir(saveext.sincosreg);
		sappend(instrbuf,':');
		end;
	      emitfdir(saveext.fry);
	      end;
	    end
	  else if ext.fopclas = 3 then { dest is <ea> }
	    begin { FMOVE from MC68881 }
	    instrbuf := 'fmove';
	    appendfloatsize(ext.frx);
	    emitfdir(ext.fry);
	    comma;
	    saveext := ext;
	    emitea(bytesiz);
	    if saveext.frx = 3 {size P} then
	      strwrite(instrbuf,strlen(instrbuf)+1,I,'{#',saveext.Kfactor:1,'}')
	    else if saveext.frx = 7 {size P} then
	      strwrite(instrbuf,strlen(instrbuf)+1,I,'{d',saveext.KDreg:1,'}');
	    end
	  else goto 2;
	  end;
	end
      else
	case opmode of
	  1: { FScc, FDBcc, FTRAPcc }
	     begin
	     if eamode = 1 then
	       instrbuf := 'fdb'
	     else if (eamode = 7) and (eareg = 4) then
	       instrbuf := 'ftrap'      (* LAF 861204 *)
	     else if (eamode = 7) and ((eareg = 2) or (eareg = 3)) then
	       instrbuf := 'ftrap'      (* LAF 861204 *)
	     else
	       instrbuf := 'fs';
	     getinstrbytes(2);
	     appendfloatcondition(ext.ubyteext);
	     if eamode = 1 then
	       begin
	       if instrbuf = 'fdbf' then
		 instrbuf := 'fdbra '
	       else
		  sappend(instrbuf,' ');
	       emitdir(D,eareg);
	       comma;
	       extend(2,true,0);
	       end
	     else if (eamode = 7) and (eareg = 4) then
	       { FTcc }
	     else if (eamode = 7) and (eareg = 2) then
	       begin { FTPcc.W }
	       sappend(instrbuf,'.w ');
	       immediate(wordsiz);
	       end
	     else if (eamode = 7) and (eareg = 3) then
	       begin { FTPcc.L }
	       sappend(instrbuf,'.l ');
	       immediate(longsiz);
	       end
	     else
	       begin
	       sappend(instrbuf,' ');
	       emitea(bytesiz);
	       end;
	     end;
	  2,3: { Revearse assemble FBF *+2 as FNOP }
	       begin
	       moveleft(inbuf.stp^[codeindex],ext,2);
	       if (instr.fpredicate = 0) and (opmode = 2) and
		  (ext.wordext = 0) then
		 begin { FNOP }
		 instrbuf := 'fnop';
		 getinstrbytes(2);
		 end
	       else
		 begin { FBcc }
		 if instr.fpredicate = 15 {FBT} then
		   instrbuf := 'fbra'
		 else
		   begin
		   instrbuf := 'fb';
		   appendfloatcondition(instr.fpredicate);
		   end;
		 if opmode = 3 then
		   begin
		   sappend(instrbuf,'.l ');
		   extend(4,true,0);
		   end
		 else
		   begin
		   sappend(instrbuf,' ');
		   extend(2,true,0);
		   end;
		 end;
	       end;
	  4,5: { FSAVE, FRESTORE }
	       begin
	       if opmode = 4 then
		 instrbuf := 'fsave '
	       else
		 instrbuf := 'frestore ';
	       emitea(bytesiz);
	       end;
	  otherwise goto 2;
	end {case};
      end {with instr};
    end; { mc68881 }

  { Added 12/22/89 JWH : }

  procedure move16; { Handle the '040 move16 instruction }
  LABEL 1;
  type move16_type =
	packed record
	  case integer of
	    1: (the_op : byte;
		which : 0..7;
		mode_16 : 0..3;
		reg_ax : regrange);
	    2: (w : shortint);
	end; { move16_type }
   type my_type = packed record
      case integer of
      1: ( nib1,nib2 : 0..15;
	byte_it : byte) ;
      2: (w : shortint);
     end; { my_type }
    var see_it : move16_type;
    var see_ex : my_type;
    begin
      { So far we've seen first 7 bits of instruction }
      see_it.w := instr.w; { see it as a move16 }
      instrbuf := 'move16 ';
      with see_it do
       begin
	if the_op <> 246 { hex('F6') } then
	  begin defineword; goto 1; end; { First 8 bits }
	if which > 1 then
	  begin defineword; goto 1; end; { First 11 bits }
	if which = 1 then { have post increment format }
	 begin
	  if mode_16 <> 0 then { gotta be for this format }
	     begin defineword; goto 1; end; { First 13 bits }
	  getinstrbytes(2);
	  if ext.exDAbit1 <> 1  then
	     begin defineword; goto 1; end; { First 17 bits }
	  see_ex.w := ext.wordext;
	  if ((see_ex.nib2 <> 0) or (see_ex.byte_it <> 0))  then
	     begin defineword; goto 1; end; { First 32 bits }
	  { Have a valid move16 of this format if we get this far }
	  emitpostincr(reg_ax);
	  comma;
	  emitpostincr(ext.exRn1);
	 end { which = 1 , post increment format }
	else  { which = 0, have absolute format }
	 begin
	  { Have a valid move16 of this format if we get here. }
	   case mode_16 of
	    0 : begin emitpostincr(reg_ax); comma; extend(4,false,0); end;
	    1 : begin extend(4,false,0); comma; emitpostincr(reg_ax); end;
	    2 : begin emitardef(reg_ax); comma; extend(4,false,0); end;
	    3 : begin extend(4,false,0); comma; emitardef(reg_ax); end;
	    otherwise ; { this really can't happen }
	   end; { case }
	 end; { which = 0, absolute format }
       end; { with see_it }
    1: end; { move16 }

    { Added 12/22/89 JWH : }


  procedure cinv_cpush; { Handle '040 CINV and CPUSH instructions }
  LABEL 1;
  type cache_40_type =
	packed record
	  case integer of
	    1: (the_op : byte;
		which_caches : 0..3;
		which_instr : 0..1;
		scope : 0..3;
		reg_ax : regrange);
	    2: (w : shortint);
	end; { cache_40_type }
    var see_it : cache_40_type;
    begin
    { Have seen the first seven bits of the instruction }
     see_it.w := instr.w; { see it as a cinv or cpush }
     with see_it do
      begin
       if the_op <> 244 { hex('F4') } then
	  begin defineword; goto 1; end; { Seen 8 bits now }
       if which_instr = 0 then
	begin { CINV }
	 case scope of
	  0 : begin defineword; goto 1; end; { ILLEGAL }
	  1 : instrbuf := 'cinvl ';
	  2 : instrbuf := 'cinvp ';
	  3 : instrbuf := 'cinva ';
	  otherwise ;
	 end; { case }
	 case which_caches of
	  0 : strappend(instrbuf,'NONE');  { NOOP, NOT ILLEGAL }
	  1 : strappend(instrbuf,'DC');
	  2 : strappend(instrbuf,'IC');
	  3 : strappend(instrbuf,'DC/IC');
	  otherwise ;
	 end; { case }
	 if ((scope = 1) or (scope = 2)) then { CINVL or CINVP .. }
	  begin { get the reg ... }
	    comma; emitardef(reg_ax);
	  end; { CINVL or CINVP }
	end { CINV }
       else
	begin { CPUSH }
	 case scope of
	  0 : begin defineword; goto 1; end; { ILLEGAL }
	  1 : instrbuf := 'cpushl ';
	  2 : instrbuf := 'cpushp ';
	  3 : instrbuf := 'cpusha ';
	  otherwise ;
	 end; { case }
	 case which_caches of
	  0 : strappend(instrbuf,'NONE'); { NOOP, NOT ILLEGAL }
	  1 : strappend(instrbuf,'DC');
	  2 : strappend(instrbuf,'IC');
	  3 : strappend(instrbuf,'DC/IC');
	  otherwise ;
	 end; { case }
	 if ((scope = 1) or (scope = 2)) then { CPUSHL or CPUSHP .. }
	  begin { get the register ... }
	    comma; emitardef(reg_ax);
	  end; { CPUSHL or CPUSHP }
	end; { CPUSH }
      end; { with see_it }
      1 :
    end; { cinv_cpush }

  begin {decode}
    with instr do
      case opcode of
	0: opcode0;
	1,2,3: move;
	4: opcode4;
	5: if size = invalid then
	     begin
	     if eamode = 1 then
	       begin
	       instrbuf := 'db';
	       if cond = 1 then sappend(instrbuf,'ra')
	       else sappend(instrbuf,condcode[cond]);
	       space; emitdir(D, eareg);
	       comma; extend(2,true,0);
	       end
	     else if (eamode < 7) or ((eamode = 7) and (eareg <= 1)) then
	       begin
	       instrbuf := 's';
	       sappend(instrbuf,condcode[cond]);
	       space; emitea(bytesiz {invalid});
	       end
	     else { trapcc }
	       begin
	       case cond of
		 0: instrbuf := 'trapt';
		 1: instrbuf := 'trapf';
		 2: instrbuf := 'traphi';
		 3: instrbuf := 'trapls';
		 4: instrbuf := 'trapcc';
		 5: instrbuf := 'trapcs';
		 6: instrbuf := 'trapne';
		 7: instrbuf := 'trapeq';
		 8: instrbuf := 'trapvc';
		 9: instrbuf := 'trapvs';
		 10:instrbuf := 'trappl';
		 11:instrbuf := 'trapmi';
		 12:instrbuf := 'trapge';
		 13:instrbuf := 'traplt';
		 14:instrbuf := 'trapgt';
		 15:instrbuf := 'traple';
	       end;
	       if eareg = 2 then { .w }
		 begin
		 sappend(instrbuf,'.w ');
		 immediate(wordsiz);
		 end
	       else if eareg = 3 then { .l }
		 begin
		 sappend(instrbuf,'.l ');
		 immediate(longsiz);
		 end;
	       end;
	     end
	   else
	     begin
	     if bit8 then instrbuf := 'subq'
	     else instrbuf := 'addq';
	     osize; quick;
	     emitea(size {invalid});
	     end;
	6: begin instrbuf := 'b';
	     if cond = 0 then sappend(instrbuf,'ra')
	     else if cond = 1 then sappend(instrbuf,'sr')
			      else sappend(instrbuf,condcode[cond]);

	     if displ = -1 then { 32 bit displ }
	       begin
	       sappend(instrbuf,'.l ');
	       extend(4,true,0);
	       end
	     else if displ = 0 then
	       begin
	       sappend(instrbuf,'.w ');
	       extend(2,true,0);
	       end
	     else
	       begin sappend(instrbuf,'.s ');
	       ext.longext := pc + 2 + displ;
	       tempint := ext.longext;
	       gvrstring(nilgvr,tempint,true,false);
	       sappend(instrbuf,gvaluestring);
	       end;
	   end;
	7: begin instrbuf := 'moveq ';
	     emitimm(displ); comma;
	     emitdir(D,reg1);
	   end;



8,9,11,12,13: begin
	   instrbuf := arithop[opcode];
	   if size=invalid then
	    begin
	    if odd(opcode) then
	     begin
	     sappend(instrbuf,'a');
	     if bit8 then
		  begin
		  sappend(instrbuf, opsize[longsiz]);
		  emitea(longsiz);
		  end
	     else begin
		  sappend(instrbuf,opsize[wordsiz]);
		  emitea(wordsiz);
		  end;
	     comma; emitdir(A,reg1);
	     end
	    else
	     begin
	     if opcode = 8 then instrbuf := 'div'
			   else instrbuf := 'mul';
	     if bit8 then sappend(instrbuf,'s ')
		     else sappend(instrbuf,'u ');
	     emitea(wordsiz); comma; emitdir(D,reg1);
	     end
	    end
	   else if (not bit8) or (eamode > 1) or (opcode = 11) then
	     begin
	     if opcode = 11 then
	      if bit8 then
	       if eamode = 1 then
		 begin
		 sappend(instrbuf,'m'); osize;
		 emitpostincr(eareg); comma; emitpostincr(reg1);
		 goto 1;
		 end
	       else instrbuf := 'eor';
	     osize;
	     if bit8 then begin emitdir(D,reg1); comma; emitea(size);
			  end
		     else begin emitea(size); comma; emitdir(D,reg1);
			  end;
	     end
	   else
	     begin
	     if odd(opcode) then begin sappend(instrbuf,'x'); osize; end
	     else if opcode = 8 then
	       if size = bytesiz then instrbuf := 'sbcd '
	       else if size = wordsiz then instrbuf := 'pack '
	       else { size = longsiz }     instrbuf := 'unpk '
	     else if size = bytesiz then instrbuf := 'abcd '
	     else begin
		  instrbuf := 'exg ';
		  if eamode = 0 then
		    begin emitdir(D,reg1); comma; emitdir(D,eareg) end
		  else if opmode = 5 then
		    begin emitdir(A,reg1); comma; emitdir(A,eareg) end
		  else
		    begin emitdir(D,reg1); comma; emitdir(A,eareg) end;
		  goto 1;
		  end;
	     if eamode = 0 then
		  begin emitdir(D,eareg); comma; emitdir(D,reg1);
		  end
	     else begin emitpredecr(eareg); comma; emitpredecr(reg1);
		  end;
	     if (opcode = 8) and (size >= wordsiz) then { pack unpk }
	       begin
	       comma;
	       immediate(wordsiz);
	       end;
	     end;
	   end;
       14:
	 if (ord(size) = 3) and (reg1 >= 4) then { bit field op }
	   begin
	   case cond of
	     8: instrbuf := 'bftst ';
	     9: instrbuf := 'bfextu ';
	     10: instrbuf := 'bfchg ';
	     11: instrbuf := 'bfexts ';
	     12: instrbuf := 'bfclr ';
	     13: instrbuf := 'bfffo ';
	     14: instrbuf := 'bfset ';
	     15: instrbuf := 'bfins ';
	   end;
	   getinstrbytes(2);
	   bf_reg := ext.bf_reg;
	   bf_Do := ext.bf_Do;
	   bf_offset := ext.bf_offset;
	   bf_Dw := ext.bf_Dw;
	   bf_width := ext.bf_width;
	   if cond = 15 then
	     begin
	     emitdir(D,bf_reg);
	     comma;
	     end;
	   emitea(bytesiz);
	   sappend(instrbuf,'{');
	   if bf_Do then
	     sappend(instrbuf,'d');
	   strwrite(instrbuf,strlen(instrbuf)+1,I,bf_offset:1);
	   sappend(instrbuf,':');
	   if bf_Dw then
	     strwrite(instrbuf,strlen(instrbuf)+1,I,'d',bf_width:1)
	   else
	     begin
	     if bf_width = 0 then
	       bf_width := 32;
	     strwrite(instrbuf,strlen(instrbuf)+1,I,bf_width:1);
	     end;
	   sappend(instrbuf,'}');
	   if cond in [9,11,13] then
	     begin
	     comma;
	     emitdir(D,bf_reg);
	     end;
	   end
	 else
	   shift;
	 15: if reg1 = 1 then mc68881
	      { Next two lines JWH 12/22/89 : }
	      else if reg1 = 2 then cinv_cpush
	      else if ((reg1 = 3) and (instr.opmode = 0)) then move16
	     else goto 2;
	otherwise goto 2;
	end; {case}
       goto 1;
      2: begin defineword;
	   if decodestate <> abscode then decodestate := consts;
	 end;
    1: end; {decode}

  procedure definecaseword;
  var savepc: integer;
  begin
  instrsize := 0;
  instrbuf := 'case jump   ';
  savepc := pc; pc := tablepc;
  extend(2, true,0);
  pc := savepc;
  end;

  procedure decodestuff;
  label 1;
  var temp: integer;

    procedure printprocboundary;
    label 1;
    var  defaddr,deflimit,len,gvrbase: integer;
	 veloc:  addrec;
    begin
      defaddr:=newmods^.defaddr.a;
      deflimit:=defaddr+newmods^.defsize;
      while defaddr < deflimit do
	begin
	  len:=strlen(symbolptr(defaddr)^);
	  len:=len+2-ord(odd(len));
	  gvrbase:=defaddr+len;
	  with gvrptr(gvrbase)^ do
	    if primarytype = loadgvr^.primarytype then
	      begin
	      veloc.a:=gvrbase+sizeof(generalvalue,false);
	      if veloc.vep^.value = PC then goto 1;
	      end;
	  defaddr:=defaddr+len+ord(symtableptr(defaddr)^[len+1]);
	end;
	listln;
1:    list;
      if MODULEPC = PC then write(listing,'- * module body * -')
		       else write(listing,'- - - - - - - - - -');
      write(listing,' - - - - - - - - - - - - - - - -  ');
      if defaddr < deflimit then
	write(listing,symbolptr(defaddr)^);
      writeln(listing);
    end; {printprocboundary}

  begin {decodestuff}
 1: case decodestate of
      consts:
	  begin getinstruction;
	    if (PC=MODULEPC)  { MODULE BODY ADDRESS } then
		begin decodestate := code; decode;
		 if (rangetype = norange) or
		    ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
		    ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange))
		    then printprocboundary;
		end
	    else { check for dc.w even,0 or 1}
	       if (not odd(instr.lb) and (instr.rb<2)) then
	       begin defineword; decodestate := phdr; end

	    else if (instr.w = 20217) {JMP long abs}
	     or (instr.w = 24576) {BRA 16 bit} then
	      decode
	    else defineword;
	  end;
      phdr:begin getinstruction;
	     if (instr.w = 20054) {LINK A6}
	       or (instr.w = 18446) {LINK.L A6}
	       or (instr.w = 20033) {TRAP #1}
	       or (PC=MODULEPC) {MODULE BODY ADDRESS } then
		begin decodestate := code; decode;
		 if (rangetype = norange) or
		    ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
		    ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange))
		    then printprocboundary;
		end
	      else if (instr.w = 20217) {JMP long abs}
		      or (instr.w = 24576) {BRA 16 bit} then
		      begin decode; decodestate:=consts; end
		   else
		   begin defineword;
		     if not (not odd(instr.lb) and (instr.rb<2)) then decodestate := consts;
		   end;
	   end;

abscode,
      code:     begin
		getinstruction;
		decode;
		if decodestate <> abscode then
		  if instr.w = 20062 {UNLK A6} then decodestate := endofproc
		  else if instr.w = 20219 {JMP pc indexed} then
		    begin oldstate := code; decodestate := startcase end;
		end;
      startcase:
	begin
	  tablePC := PC;
	  definecaseword;
	  casecodestart:=ext.wordext+PC;
	  decodestate := casetable;
	end;
      casetable:
	begin
	  if PC = casecodestart
	  then begin decodestate := oldstate; goto 1 end
	  else
	    begin definecaseword;
	      if not fortranflag then
		begin
		  temp:=ext.wordext+tablePC;
		  if temp<casecodestart then casecodestart := temp;
		end;
	    end;
	end;
      endofproc:
	begin getinstruction; decode;
	  if (instr.w = 20085 {RTS} )
	      or (instr.w div 8 = 2522 {JMP (An)} ) then
	    decodestate := consts;
	end;
      end; {case}
  end; {decodestuff}

begin {listinstruction}
  decodestuff;
  bytesleft := instrsize; firstline := true;
  if (rangetype = norange) or
     ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
     ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange)) then
   repeat
    list;
    if firstline then write(listing,PC:8,' ')

    else write(listing,'':9  {17}  );
    printinstrword;
    if bytesleft>0 then printinstrword
    else
      if firstline then write(listing,'':5);
    if firstline then
      begin writeln(listing,'':9,instrbuf); firstline := false end
    else writeln(listing);
   until bytesleft = 0;
  PC:=PC + instrsize;
end; {listinstruction}

procedure getcodeblocks;
var junkint: integer;
    pclimit: integer;
    textstep: addrec;
    textrecctr: {shortint} INTEGER {SFB};
begin
 with newmods^,directory.drp^ do
   begin
   textstep.a:=directory.a+sizeof(moduledirectory);
   junkint:=strlen(textstep.syp^);
   textstep.a := textstep.a+junkint+2-ord(odd(junkint));
   if executable then textstep.a := textstep.a + textstep.gvp^.short;
   textrecctr:=textrecords;
   while textrecctr > 0 do with textstep.tdp^ do
     begin
     textrecctr:=textrecctr-1;
     list; writeln(listing,'TEXT RECORD #',
     textrecords-textrecctr, '  of ''', fdirectory^[vmodnum].dtid, ''':');
     list; writeln(listing,'  TEXT start block ',textstart:4,
		      '       Size ',textsize,' bytes');
     list; writeln(listing,'  REF  start block ',refstart:4,
		      '       Size ',refsize,' bytes');
     textstep.a :=textstep.a+sizeof(textdescriptor);
     PC := 0;
     loadgvr := textstep.gvp;
     gvrstring(textstep.gvp,PC,false,false);
     gbytes(inbuf.a,textsize);
     readblocks(filefib.fbp^, inbuf.p^,textsize,fileblock+textstart);
     codeindex:=0;  codecount:=textsize;
     gbytes(refptr.a,refsize);
     readblocks(filefib.fbp^,refptr.p^,refsize,fileblock+refstart);

     refgvr:=refptr;
     reflim:=refptr.a+refsize;
     refloc:=PC;        nextref;
     pclimit := PC + textsize;

     list; writeln(listing,'  LOAD address     ',gvaluestring);
     listln;
     while PC < pclimit do listinstruction;
     listln; listln;
     lowheap := inbuf;
     end;
   end; {with newmods^,directory^}
end; {getcodeblocks}

procedure listdefs;
var
  len,val:      integer;
  lim,p1:       addrec;
begin
prepunassem;
with newmods^ do
  begin
  list; writeln(listing,'  DEF table of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  p1 := defaddr;
  lim.a := p1.a + defsize;
  while p1.a < lim.a do
    begin
    len:=strlen(p1.syp^);
    list; write(listing,'':5,p1.syp^,'':(30-len));
    p1.a := p1.a + len+2-ord(odd(len));
    val := 0;
    gvrstring(p1.gvp,val,false,false);
    writeln(listing,gvaluestring);
    end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure listexts;
var
  i:            integer;
  p1:           addrec;
begin
prepunassem;
with newmods^ do
  begin
  list; writeln(listing,'  EXT table of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  for i:=2 to listsize-1 do if listaddr^[i] <> 0 then
    begin
      p1.a := extaddr.a + listaddr^[i];
      list; writeln(listing,'':5,p1.syp^);
    end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure listtext;
const pagesize = pageblocks * blocksize;
var
  textbuf,ptr:  addrec;
  i,j,pages:    integer;
  readsize:     integer;
  linestart:    boolean;

  procedure dochar(c: char);
  begin
  if linestart then list;
  linestart := (c = eol);
  if linestart then writeln(listing) else write(listing, c);
end;

begin
prepunassem;
gbytes(textbuf.a, pagesize);
with newmods^, directory.drp^ do
  begin
  list; writeln(listing,'  DEFINE SOURCE of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  pages := (sourcesize + (pagesize-1)) div pagesize;
  for i := 0 to pages-1 do
   begin
   readsize := sourcesize - i*pagesize;                         { scs 1/17/83 }
   if readsize > pagesize then readsize := pagesize;            { scs 1/17/83 }
   readblocks(filefib.fbp^,textbuf.p^,readsize,                 { scs 1/17/83 }
					   fileblock+sourceblock+i*pageblocks);
   ptr := textbuf;      linestart := true;
   repeat
     case ptr.cp^ of
       chr(etx),
       nullchar:  ptr.a := textbuf.a + pagesize;
      otherwise dochar(ptr.cp^);
      end;
     ptr.a := ptr.a + 1;
   until ptr.a >= textbuf.a + pagesize;
   if not linestart then dochar(eol);
   end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure disassemble;
begin
prepunassem;
nilgvr := NIL;
getcodeblocks;
newmods := modsave;
lowheap := infost;
end;

procedure getbounds;
begin
  lastline := -1;
  fgotoxy(output, 0,13);
  write('lower bound? ');
  if readint(lowrange) then
       begin
       write('upper bound? ');
       if not readint(highrange) then
	  highrange := maxint;
       end
  else begin
       lowrange := minint;
       highrange := maxint;
       end;
end;

begin {unassemble}
  fortranflag := false;
  decodestate := notype;        dumped := false;
  repeat
    fgotoxy(output, 0,2);
    writeln('Q  Quit',cteos);
    writeln('S  Stop unassembling');
    writeln('T  print import Text');
    writeln('E  print Ext table');
    writeln('D  print Def table');
    writeln('A  unassemble all (Assembler conventions)');
    writeln('C  unassemble all (Compiler  conventions)');
    writeln('P  PC   range     (Assembler conventions)');
    writeln('L  Line range     (Compiler  conventions)', cteos);
    getcommandchar('unassemble option?',commandchar);
    if commandchar <> ' ' then
     case commandchar of
      'S':  decodestate := quittype;
      'Q':  begin
	    decodestate := quittype;
	    quit;
	    end;
      'A':  begin rangetype := norange; decodestate := abscode; disassemble; end;
      'C':  begin rangetype := norange; decodestate := consts; disassemble; end;
      'P':  begin rangetype := pcrange; decodestate := abscode; getbounds; disassemble; end;
      'L':  begin rangetype := linerange; decodestate := consts; getbounds; disassemble; end;
      'T':  listtext;
      'D':  listdefs;
      'E':  listexts;
      otherwise dobeep;
      end;
  until decodestate = quittype;
end; {unassemble}


procedure makenewgvr(var oldptr: addrec;
			   modptr: moddescptr);

var  refsize:   shortint;
     lastptr,
     firstptr,
     vptr,
     gptr:      addrec;

  procedure runlist(var oldptr: addrec; modptr: moddescptr; sub: boolean);
  var done:     boolean;
      defptr:   addrec;

    procedure addref(add: shortint; sub: boolean);
    var iptr,jptr,tp:   addrec;
	notdone,
	notcancels:     boolean;
    begin
    if add = 0 then
      if sub then vptr.vep^.value  := vptr.vep^.value - modptr^.relocdelta
	     else vptr.vep^.value  := vptr.vep^.value + modptr^.relocdelta
    else if add = 1 then
      if sub then vptr.vep^.value  := vptr.vep^.value - modptr^.globaldelta
	     else vptr.vep^.value  := vptr.vep^.value + modptr^.globaldelta;

    iptr := lastptr; notdone := true; notcancels := true;
    while (iptr.a > firstptr.a) and notdone do
      begin
      iptr.a := iptr.a - sizeof(referenceptr);
      with iptr.rpp^ do
	if adr <= add then
	  begin
	  if adr = add then notcancels := (op = subit) = sub;
	  iptr.a := iptr.a + sizeof(referenceptr);
	  notdone := false;
	  end;
      end;

    if notcancels then
      begin
      gbytes(jptr.a, sizeof(referenceptr));
      lastptr := lowheap;
      while jptr.a > iptr.a do
	begin
	tp.a := jptr.a - sizeof(referenceptr);
	jptr.rpp^ := tp.rpp^;
	jptr := tp;
	end;
      with iptr.rpp^ do
	begin adr := add; last := false;
	if sub then op := subit else op := addit;
	end;
      end
    else
      begin
      tp.a := iptr.a - sizeof(referenceptr);
      while iptr.a < lastptr.a do
	begin
	tp.rpp^ := iptr.rpp^;
	tp := iptr;
	iptr.a := iptr.a + sizeof(referenceptr);
	end;
      lastptr.a := lastptr.a - sizeof(referenceptr);
      lowheap := lastptr;
      end;
    end;

  begin {runlist}
  with oldptr.gvp^ do
    begin
    if longoffset then oldptr.a := oldptr.a+sizeof(generalvalue, true)
			else oldptr.a := oldptr.a+sizeof(generalvalue, false);
    if valueextend then
      begin
      if sub then vptr.vep^.value := vptr.vep^.value - oldptr.vep^.value
	     else vptr.vep^.value := vptr.vep^.value + oldptr.vep^.value;
      oldptr.a := oldptr.a + sizeof(valueextension, sint);
      end;
    if primarytype <> absolute then
      begin
      if modptr = NIL then
	begin
	modptr := newmods;      done := false;
	repeat
	with modptr^ do
	  if patchmod then modptr := link
	  else if oldptr.a < defaddr.a then modptr := link
	  else if oldptr.a > defaddr.a + defsize then modptr := link
	  else done := true;
	until done;
	end;
      case primarytype of
       relocatable:      addref(0, sub);
       global:           addref(1, sub);
       general:
	begin
	done := false;
	repeat with oldptr.rpp^ do
	  begin
	  defptr := modptr^.extaddr.ptp^[adr];
	  if modptr^.unresbits.bmp^[adr] then
	    addref(defptr.rp.adr, sub <> (op = subit))
	  else
	    begin
	    defptr.a := defptr.a + strlen(defptr.syp^) + 2
		     - ord(odd(strlen(defptr.syp^)));
	    runlist(defptr, NIL, sub <> (op = subit));
	    end;
	  oldptr.a := oldptr.a + sizeof(referenceptr);
	  done := last;
	  end;
	until done;
	end; {general}
       end; {case}
      end; {primarytype <> absolute}
    end; {with}
  end; {runlist}

begin {makenewgvr}
  gbytes(gptr.a, sizeof(generalvalue));
  gptr.gvp^ := oldptr.gvp^;
  with gptr.gvp^ do
    begin
    if not longoffset then
      lowheap.a := lowheap.a -
      (sizeof(generalvalue) - sizeof(generalvalue, false));
    gbytes(vptr.a, sizeof(valueextension, sint));
    vptr.vep^.value := 0;
    valueextend := true;
    end;

  firstptr := lowheap;  lastptr := firstptr;

  runlist(oldptr, modptr, false);
  with gptr.gvp^ do
    begin
    refsize := lastptr.a - firstptr.a;
    if refsize = 0 then primarytype := absolute
    else
      begin
      if refsize = sizeof(referenceptr) then with firstptr.rpp^ do
	if adr <= 1 then if op = addit then
	  begin
	  if adr = 0 then primarytype := relocatable
		     else primarytype := global;
	  lastptr := firstptr;
	  lowheap := lastptr;
	  refsize := 0;
	  end;
      if refsize > 0 then
	begin
	firstptr.a := lastptr.a - sizeof(referenceptr);
	firstptr.rpp^.last := true;
	end;
      end;
    short := lastptr.a - gptr.a;        {even if it is long variety}
    end;
end;


procedure compressgvr(gvptr: addrec);
var vptr:   addrec;
begin
with gvptr.gvp^ do if valueextend then
  begin
  if longoffset then vptr.a := gvptr.a + sizeof(generalvalue, true)
		else vptr.a := gvptr.a + sizeof(generalvalue, false);
  with vptr.vep^ do
   if value = 0 then
    begin
    lowheap.a := lowheap.a - sizeof(valueextension, sint);
    fastmove(point(vptr.a + sizeof(valueextension, sint)), vptr.p,
	     lowheap.a - vptr.a);
    valueextend := false; short := short - sizeof(valueextension, sint);
    end;
  end;
end;

procedure rsolve;
var modptr, lastptr, nextptr: moddescptr;
    mrbase,mgbase:    integer;
    sp:         addrec;
    len:        shortint;
    i:          shortint;

begin
  modptr := newmods; lastptr := NIL; {reverse the pointers}
  while modptr <> NIL do with modptr^ do
    begin nextptr := link;      link := lastptr;
	  lastptr := modptr;    modptr := nextptr;
    end;
  newmods := lastptr;

  startgvr.p := NIL;    startgvrmod := NIL;
  modptr := newmods;    totalpatchspace := 0;
  forwardpatches:=NIL;  backwardpatches:=NIL;
  mrbase := startreloc; mgbase := startglobal;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      patchbase := mrbase;
      mrbase := mrbase + patchsize;
      totalpatchspace := totalpatchspace + patchsize;
      if forwardpatches = NIL then forwardpatches := modptr
      else lastptr^.patchlink := modptr;
      lastptr := modptr;
      end
    else with directory.drp^ do
      begin
      relocbase := mrbase;    relocdelta :=  mrbase - relocatablebase;
      mrbase := mrbase + relocatablesize + ord(odd(relocatablesize));
      globase := mgbase;      globaldelta := mgbase - globalbase;
      mgbase := mgbase - globalsize      - ord(odd(globalsize));

      gbytes(unresbits.a, ((extsize div 4 + 15) div 16)*2);
      for i := 2 to extsize div 4 - 1 do unresbits.bmp^[i] := false;
      unresbits.bmp^[0] := true;        unresbits.bmp^[1] := true;
      extaddr.ptp^[0].rp.w := 0;
      extaddr.ptp^[1].rp.w := 4;

      sp := directory;
      sp.a := sp.a+sizeof(moduledirectory);

      if newmodname.syp = NIL then newmodname := sp;
      if startgvr.p = NIL then
	if executable then
	  begin
	  startgvrmod := modptr;
	  startgvr.a := sp.a+strlen(sp.syp^)+2-ord(odd(strlen(sp.syp^)));
	  end;
      end;
    modptr := link;
    end;
  totalreloc :=  mrbase - startreloc;
  totalglobal := startglobal - mgbase;

end; {rsolve}


procedure mergeexts;

var ilist:      addrec;
    slist:      sortlistptr;
    sptr:       addrec;
    listlen:    shortint;
    sortlen:    shortint;
    minindex:   shortint;
    modptr:     moddescptr;
    len,
    i:          integer;
    done:       boolean;
    strptr,
    newstrptr:  addrec;

begin
  slist := lowheap.slp;  listlen := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if not patchmod then if not resolved then
      begin
      listlen := listlen + 1;
      gbytes(sptr.a, sizeof(sortdesc));
      with sptr.sdp^ do
	begin
	modp := modptr;
	N := 0;
	end;
      end;
    modptr := link;
    end;

  gbytes(ilist.a, listlen * sizeof(shortint));
  for i := 1 to listlen do ilist.ilp^[i] := i-1;
  sortlen := listlen;
  gbytes(newexttable, 8);
  newextsize := 8;

  while listlen > 0 do
    begin
    while sortlen > 0 do with slist^[ilist.ilp^[sortlen]], modp^ do
      begin
      done := false;
      repeat
       if N >= listsize then
	 begin
	 listlen := listlen - 1;
	 for i := sortlen to listlen do ilist.ilp^[i] := ilist.ilp^[i+1];
	 done := true;
	 end
       else if listaddr^[N] = 0 then N := N + 1
       else
	 begin
	 ext := symbolptr(extaddr.a + listaddr^[N]);
	 i := sortlen;  minindex := ilist.ilp^[i];
	 repeat
	   if i >= listlen then done := true
	   else if ext^ <= slist^[ilist.ilp^[i+1]].ext^ then done := true
	   else begin ilist.ilp^[i] := ilist.ilp^[i+1]; i := i + 1; end;
	 until done;
	 ilist.ilp^[i] := minindex;
	 end;
      until done;
      sortlen := sortlen - 1;
      end;
    if listlen > 0 then
      begin
      strptr.syp := slist^[ilist.ilp^[1]].ext;
      len := strlen(strptr.syp^) + 4 - strlen(strptr.syp^) mod 4;
      gbytes(newstrptr.a, len);
      fastmove(strptr.p, newstrptr.p, len);
      i := 1; done := false;
      repeat with slist^[ilist.ilp^[i]], modp^ do
	if ext^ = newstrptr.syp^ then
	  begin
	  wordrecptr(ext)^.w := newextsize;
	  unresbits.bmp^[listaddr^[N] div 4] := true;
	  N := N + 1;
	  i := i + 1; done := i > listlen;
	  end
	else done := true;
      until done;
      sortlen := i-1;
      newextsize := newextsize + len;
      end;
    end;

  if newextsize <= 8 then newextsize := 0;

end;

function gvrequal(a,b: addrec; offset: integer): boolean;
var      boff,
	 aoff:  integer;
	 b0:    gvrptr;
begin
gvrequal := false;
b0 := b.gvp;
with a.gvp^ do
  if primarytype = b0^.primarytype then
    begin
    if longoffset     then a.a := a.a + 4
		      else a.a := a.a + 2;
    if b0^.longoffset then b.a := b.a + 4
		      else b.a := b.a + 2;
    if valueextend then
      begin
      aoff := a.vep^.value;
      a.a := a.a + sizeof(valueextension, sint);
      end
    else aoff := 0;
    if b0^.valueextend then
      begin
      boff := b.vep^.value;
      b.a := b.a + sizeof(valueextension, sint);
      end
    else boff := 0;
    if aoff + offset = boff then
      if primarytype = general then
	begin
	while (a.rpp^.w
		   = b.rpp^.w)
	      and (a.rpp^.last = false) do
	  begin
	  a.a := a.a + sizeof(referenceptr);
	  b.a :=  b.a + sizeof(referenceptr);
	  end;
	gvrequal := a.rpp^.w = b.rpp^.w;
	end
      else gvrequal := true;
    end;
end;

procedure makedir;

var  modptr:            moddescptr;
     newtextrec,
     lasttextrec:       addrec;
     len:               shortint;
     extblocks,
     newtextrecs,
     movebytes,
     textrecs :         integer;
     index,
     newptr:            address;
     tempdirptr,
     oldindex,
     oldptr,
     ptr:               addrec;


  procedure mergetext;
  var  merged:  boolean;
       lastptr,
       newptr:  addrec;
  begin
   if newtextrec.tdp^.textsize = 0 then lowheap := newtextrec
   else
    begin
    if lasttextrec.tdp <> NIL then
      begin
      lastptr.a := lasttextrec.a + sizeof(textdescriptor);
      newptr.a  := newtextrec.a  + sizeof(textdescriptor);
      merged := gvrequal(lastptr, newptr, lasttextrec.tdp^.textsize );
      end
    else merged := false;

    if merged then
      begin
      lasttextrec.tdp^.textsize := lasttextrec.tdp^.textsize + newtextrec.tdp^.textsize;
      lowheap := newtextrec;
      end
    else
      begin newtextrecs := newtextrecs + 1;
      lasttextrec := newtextrec;
      end;
    end;
  end;

begin {makedir}
  gbytes(tempdirptr.a, sizeof(moduledirectory));
  if newmodname.syp=NIL then
    begin gbytes(newmodname.a, 2);
    newmodname.syp^ := '';
    end
  else
    begin
    len := strlen(newmodname.syp^) + 2 - ord(odd(strlen(newmodname.syp^)));
    gbytes(index, len);
    fastmove(newmodname.p, point(index), len);
    end;

  if startgvr.p<>NIL then
    begin
    oldptr := startgvr;
    ptr := lowheap;     makenewgvr(oldptr, startgvrmod);
    compressgvr(ptr);
    end;

  lasttextrec.tdp := NIL;
  newtextrecs := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      gbytes(newtextrec.a, sizeof(textdescriptor));
      newtextrec.tdp^.textsize := patchsize;
      gbytes(oldptr.a, sizeof(generalvalue, false));
      with oldptr.gvp^ do
	begin
	primarytype := relocatable;     datasize := sint;
	patchable := false;             longoffset := false;
	if patchbase = 0 then begin valueextend := false; short := 2; end
	else begin
	     gbytes(newptr, sizeof(valueextension, sint));
	     veptr(newptr)^.value := patchbase;
	     valueextend := true;  short := 6;
	     end
	end;
      mergetext;
      end
    else with directory.drp^ do
      begin
      oldindex.a := directory.a + sizeof(moduledirectory);
      oldindex.a := oldindex.a + strlen(oldindex.syp^) + 2 -
		     ord(odd(strlen(oldindex.syp^)));
      if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
      textrecs := textrecords;
      while textrecs > 0 do with oldindex.tdp^ do
	begin
	gbytes(newtextrec.a, sizeof(textdescriptor));
	if odd(textsize) then textsize := textsize + 1;
	newtextrec.tdp^.textsize := textsize;
	oldindex.a := oldindex.a + sizeof(textdescriptor);
	ptr := lowheap; makenewgvr(oldindex, modptr);
	compressgvr(ptr);
	mergetext;
	textrecs := textrecs - 1;
	end;
      end;
    modptr := link;
    end;

  with tempdirptr.drp^ do
    begin
    date := todaysdate;
    revision := linkerdate;
    producer := 'L';
    systemid := 3;
    notice := copyright;
    directorysize := lowheap.a - tempdirptr.a;
   {modulesize := }
    executable := (startgvr.p <> NIL);
    relocatablesize := totalreloc;
    relocatablebase := startreloc;
    globalsize := totalglobal;
    globalbase := startglobal;
   {extblock :=}
   {extsize  :=}
   {defblock := }
   {defsize  := }
    sourceblock := 0;                   {implement later}
    sourcesize  := 0;
    textrecords := newtextrecs;

    nextblock := (directorysize +(blocksize-1)) div blocksize;

    extblock :=  nextblock;
    extsize  := newextsize;
    extblocks := (newextsize + (blocksize-1)) div blocksize;
    blockwrite(outfile,point(newexttable)^,extblocks,outblock+nextblock);
    nextblock := nextblock + extblocks;

    {lowheap.a := newdirectory.a + directorysize;
    fastmove(tempdirptr.p, newdirectory.p, directorysize);
    } newdirectory := tempdirptr;
    end;

end;

procedure mergedefs;

var slist:      sortlistptr;
    ilist:      addrec;
    listlen:    shortint;
    sortlen:    shortint;
    minindex:   shortint;
    modptr:     moddescptr;
    len,
    i:          integer;
    done:       boolean;
    strptr,
    newstrptr,
    sptr:       addrec;

    newdeftable: address;
    defblocks:  integer;
    c:          char;

begin
  slist := lowheap.slp;  listlen := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if not patchmod then if defsize > 0 then
      begin
      listlen := listlen + 1;
      gbytes(sptr.a, sizeof(sortdesc));
      with sptr.sdp^ do
	begin
	modp := modptr;
	def := defaddr;
	end;
      end;
    modptr := link;
    end;

  gbytes(ilist.a, listlen * sizeof(shortint));
  for i := 1 to listlen do ilist.ilp^[i] := i-1;
  sortlen := listlen;
  newdeftable := lowheap.a;

  while listlen > 0 do
    begin
    while sortlen > 0 do with slist^[ilist.ilp^[sortlen]], modp^ do
      begin
      done := false;
      repeat
       if def.a >= defaddr.a + defsize then
	 begin
	 listlen := listlen - 1;
	 for i := sortlen to listlen do ilist.ilp^[i] := ilist.ilp^[i+1];
	 done := true;
	 end
       else
	 begin
	 len := strlen(def.syp^) + 2 - ord(odd(strlen(def.syp^)));
	 with gvrptr(def.a+len)^ do
	   if patchable then def.a := def.a + len + short
	   else
	    begin
	    i := sortlen;  minindex := ilist.ilp^[i];
	    repeat
	     if i >= listlen then done := true
	     else if def.syp^ <= slist^[ilist.ilp^[i+1]].def.syp^ then done := true
	     else begin ilist.ilp^[i] := ilist.ilp^[i+1]; i := i + 1; end;
	    until done;
	    ilist.ilp^[i] := minindex;
	    end;
	 end
      until done;
      sortlen := sortlen - 1;
      end;
    if listlen > 0 then
      begin
      with slist^[ilist.ilp^[1]] do
	begin
	strptr := def;
	len := strlen(strptr.syp^) + 2 - ord(odd(strlen(strptr.syp^)));
	gbytes(newstrptr.a, len);
	fastmove(strptr.p, newstrptr.p, len);
	def.a := strptr.a + len;
	makenewgvr(def, modp);
	end;
      i := 2; done := false;
      repeat with slist^[ilist.ilp^[i]], modp^ do
	if i > listlen then done := true
	else if def.syp^ = newstrptr.syp^ then
	 begin
	   if printeron then
	     begin
	       list; writeln(listing,'duplicate symbol definition for:  ',
							  def.syp^);  {**!!!!*}
	     end
	   else
	     begin
	       errorline;
	       writeln('duplicate symbol:  ',def.syp^);
	       if streaming then escape(119);
	       write('Press ''C'' to continue, any other key to abort ',cteol);
	       read(keyboard,c);
	       if (c <> 'C') and (c <> 'c') then escape(119);
	       fgotoxy(output, 0, 22);
	       writeln(cteol);
	       write('LINKING ...', cteol);
	     end;
	   def.a := def.a + strlen(def.syp^) + 2 - ord(odd(strlen(def.syp^)));
	   def.a := def.a + def.gvp^.short;
	   i := i + 1;
	 end
	else done := true;
      until done;
      sortlen := i-1;
      end;
    end;

  with newdirectory.drp^ do
    begin
    defblock := nextblock;
    if defsout then defsize := lowheap.a - newdeftable
    else defsize := 0;
    defblocks := (defsize + (blocksize-1)) div blocksize;
    if defblocks > 0 then
     blockwrite(outfile,point(newdeftable)^,defblocks,outblock+nextblock);
    nextblock := nextblock + defblocks;
    end;
  lowheap.slp := slist;

end;

procedure copytext;

var patchptr:           patchdescptr;
    loadaddr,loadaddr0: address;
    modptr:             moddescptr;     {current module being loaded}
    gvrp:               gvrptr;
    patching,
    merging:            boolean;        {whether text records are combined}

    textbuffer,         {base of text record buffer}
    textbuftop,         {end  of text record buffer}
    textindex,          {pointer to next space available in text buffer}
    object,             {object in text record being modified by ref record}

    refbuffer,          {base of ref table buffer}
    refbuftop,          {end  of ref table buffer}
    outrefindex,        {pointer to next space available in ref buffer}
    inrefindex,         {pointer to next record in ref buffer to process}

    newptr,            {base of new gvr on heap}
    valptr,             {value extension in new gvr on heap}

    oldindex,           {pointer to old text descriptors}
    newindex:           {pointer to new text descriptors}
		addrec;

    vevalue,
    newbytes,           {size of new gvr on heap}
    offsetbytes,        {distance from last object referenced by new refs}
    oldtextrec,         {text records left to process from old module}

    textbufblocks,      {maximum blocks allocated for text buffer}
    textinblock,        {file relative block index into old text}
    textinsize,         {number of bytes left to read from old text}
    textoutblock,       {file relative block index into new text}
    textoutsize,        {number of bytes processed into new text}

    refbufblocks,       {maximum blocks allocated for ref buffer}
    refinblock,         {file relative block index into old ref table}
    refinsize,          {number of bytes left to read from old ref}
    refoutblock,        {file relative block index into new ref table}
    refoutsize:         {number of bytes processed into new ref table}
		integer;

  procedure starttext;
  begin
  if not merging then with newindex.tdp^ do
    begin
    textstart := nextblock;     textoutblock := nextblock + outblock;
    nextblock := nextblock + (textsize + (blocksize - 1)) div blocksize;
    refoutblock := nextblock + outblock;

    textoutsize := 0;           textindex   := textbuffer;
    refoutsize := 0;            outrefindex := refbuffer;
    offsetbytes := 0;           object := textbuffer;

    valptr.a := newindex.a + sizeof(textdescriptor);
    patching := (valptr.gvp^.primarytype = relocatable) and (totalpatchspace > 0);
    if patching then
     if valptr.gvp^.valueextend then
      begin
      valptr.a := valptr.a + sizeof(generalvalue, false);
      loadaddr0 := valptr.vep^.value;
      end
     else loadaddr0 := 0;
     loadaddr := object.a - loadaddr0;
    end;
  end;

  procedure endtext;
  var lastblocks: integer;
      td: addrec;
      org: integer;
  begin
  with newindex.tdp^ do
    begin
    merging := (textoutsize < textsize);
    if not merging then
      begin
      if textindex.a > textbuffer.a then
	begin
	lastblocks := (textindex.a-textbuffer.a+(blocksize-1)) div blocksize;
	blockwrite(outfile, textbuffer.p^, lastblocks, textoutblock);
	end;
      if outrefindex.a > refbuffer.a then
	begin
	lastblocks := (outrefindex.a - refbuffer.a + (blocksize-1)) div blocksize;
	blockwrite(outfile, refbuffer.p^, lastblocks, refoutblock);
	end;
      refstart := nextblock;    refsize := refoutsize;
      nextblock := nextblock + (refoutsize + (blocksize - 1)) div blocksize;
      newindex.a := newindex.a + sizeof(textdescriptor);
      org := 0; gvrstring(newindex.gvp,org,false,true);
      if printeron then
       begin
       list; writeln(listing,
       '(load record:  size = ',textsize:1,', load address = ',gvaluestring, ')');
       end;
      end;
    end;
  end;

  procedure dumptext(writebytes: integer);
  var writeblocks:      integer;
  begin
    writeblocks := writebytes div blocksize;
    writebytes := writeblocks * blocksize;
    blockwrite(outfile, textbuffer.p^, writeblocks, textoutblock);
    textoutblock := textoutblock + writeblocks;
    textindex.a := textindex.a - writebytes;
    object.a := object.a - writebytes;
    loadaddr := loadaddr - writebytes;
    fastmove(point(textbuffer.a + writebytes), textbuffer.p,
	     textindex.a - textbuffer.a);
  end;

  procedure checktextbuf(obsize: integer);
  var readbytes, writebytes:      integer;
  begin
  while textindex.a < object.a + obsize do
    begin
    readbytes :=  textbuftop.a - textindex.a;
    if textinsize <= readbytes then readbytes := textinsize
    else
      begin
      if object.a < textindex.a then writebytes := object.a    - textbuffer.a
				else writebytes := textindex.a - textbuffer.a;
      if writebytes < readbytes then
	readbytes := readbytes - readbytes mod blocksize
      else begin dumptext(writebytes); readbytes := 0; end;
      end;
    if readbytes > 0 then
      begin
      readblocks(modptr^.filefib.fbp^, textindex.p^, readbytes, textinblock);
      textinblock := textinblock + readbytes div blocksize;
      textinsize := textinsize - readbytes;
      textindex.a := textindex.a + readbytes;
      end;
    end;
  end;

  procedure dumprefs;
  var writebytes, writeblocks:    integer;
  begin
    writeblocks := (outrefindex.a - refbuffer.a) div blocksize;
    writebytes := writeblocks * blocksize;
    blockwrite(outfile, refbuffer.p^, writeblocks, refoutblock);
    refoutblock := refoutblock + writeblocks;
    outrefindex.a := outrefindex.a - writebytes;
    fastmove(point(refbuffer.a + writebytes), refbuffer.p,
	     outrefindex.a - refbuffer.a);
  end;


  procedure  checkinref;
  const maxrefsize = 254;
  var  refinbytes, readbytes:   integer;
  begin
    refinbytes := refbuftop.a - inrefindex.a;
    if refinbytes < maxrefsize then
      begin
      if refinsize > 0 then
	repeat
	if outrefindex.a > refbuffer.a + blocksize then
	     readbytes := inrefindex.a - (outrefindex.a + blocksize)
	else readbytes := inrefindex.a - (refbuffer.a + (2 * blocksize));
	if refinsize <= readbytes then readbytes := refinsize
	else if outrefindex.a - refbuffer.a < readbytes then
	       readbytes := readbytes - readbytes mod blocksize
	     else begin dumprefs; readbytes := 0; end;
	if readbytes > 0 then
	  begin
	  fastmove(inrefindex.p, point(inrefindex.a - readbytes), refinbytes);
	  inrefindex.a := inrefindex.a - readbytes;
	  readblocks(modptr^.filefib.fbp^, point(inrefindex.a + refinbytes)^,
							readbytes, refinblock);
	  refinblock := refinblock + readbytes div blocksize;
	  refinsize := refinsize - readbytes;
	  end;
	until readbytes > 0;
      end;
  end;

  procedure putref;
  var newbytes: shortint;
      valptr:   addrec;
  begin
  compressgvr(newptr);
  with newptr.gvp^ do
    if longoffset then long := offsetbytes
    else if offsetbytes < 256 then short := offsetbytes
    else
      begin
      valptr.a := newptr.a + sizeof(generalvalue,false);
      moveright(valptr.p^, point(valptr.a + 2)^,
		lowheap.a - valptr.a);
      lowheap.a := lowheap.a + 2;
      longoffset := true;
      long := offsetbytes;
      end;
  offsetbytes := 0;
  newbytes := lowheap.a - newptr.a;
  if outrefindex.a + newbytes > inrefindex.a then dumprefs;
  fastmove(newptr.p, outrefindex.p, newbytes);
  outrefindex.a := outrefindex.a + newbytes;
  refoutsize := refoutsize + newbytes;
  lowheap := newptr;
  end; {putref}

  procedure patcherror(dsize: datatype);

    procedure printmessage(var f: text);
    var index: addrec;
    begin
    index.a := modptr^.directory.a+sizeof(moduledirectory);
    write(f, 'Can''t patch byte ',
    object.a - loadaddr - loadaddr0:1,
    ' in text record ',oldtextrec:1,
    ' of module ',index.syp^);
    end;

  begin
  errors := errors + 1;
  errorline; printmessage(output);
  if printeron then
    begin list;
    write(listing, '*** ERROR *** ');
    printmessage(listing); writeln(listing);
    end
  else escape(128);
  end;

  procedure makepatch;
  var r, rptr:     addrec;
      objectaddr:  address;
      patchaddr:   address;
      foundpatchmodptr,
      patchmodptr: moddescptr;
      foundlastpptr,
      lastpatchptr,
      patchptr:    patchdescptr;
      patchdelta,
      delta2,foundpatchdelta:  integer;
      patchstate: (nopatch,longpatch,shortpatch, oldpatch);
      backwardlist: boolean;
  begin
  objectaddr := object.a - loadaddr;
  with valptr.vep^ do
   value := value + object.sw^ + objectaddr;
  with newptr.gvp^ do
   begin
   patchable := false;
   if primarytype = absolute then primarytype := relocatable
   else
    begin
    if primarytype <> general then
      begin
      gbytes(rptr.a, sizeof(referenceptr));
      with rptr.rpp^ do
       begin adr := 0; op := addit; last := false; end;
      gbytes(rptr.a, sizeof(referenceptr));
      with rptr.rpp^ do
       begin adr := ord(primarytype)-1;
       op := addit; last := true; end;
      primarytype := general;  short := short + 4;
      end
    else
      begin
      rptr.a := valptr.a + sizeof(valueextension,sint);
      with rptr.rpp^ do
       if (adr=0) and (op=subit) then
	 if last then
	   begin
	   primarytype := absolute; lowheap := rptr;
	   short := short - 2;
	   end
	 else
	   begin
	   moveleft(point(rptr.a+2)^,rptr.p^,
	     short-(valptr.a-newptr.a)-6);
	   lowheap.a := lowheap.a - sizeof(referenceptr);
	   short := short - 2;
	   end
       else
	 begin
	 gbytes(r.a, sizeof(referenceptr));
	 moveright(rptr.p^,point(rptr.a+2)^,
	   short-(valptr.a-newptr.a)-4);
	 adr := 0; op := addit; last := false;
	 short := short + 2;
	 end;
      end;
    end;
   end;
  patchstate := nopatch;
  for backwardlist := false to true do
   begin
   if backwardlist then patchmodptr := backwardpatches
		   else patchmodptr := forwardpatches;
   while (patchmodptr <> NIL) and (patchstate < oldpatch) do
    with patchmodptr^ do
     begin
     patchaddr := patchbase;
     patchptr := patchlist;
     while (patchptr<>NIL) and (patchstate < oldpatch) do
      with patchptr^ do
       begin
       patchdelta := patchaddr-objectaddr;
       if (-32768<=patchdelta) and (patchdelta<32768)
	then if gvrequal(newptr,patchref,0)
	 then begin
	      object.sw^ := patchdelta;
	      lowheap := newptr;
	      patchstate := oldpatch;
	      end;
       if patchref.gvp^.datasize = sword then
	    patchaddr := patchaddr + 4
       else patchaddr := patchaddr + 6;
       lastpatchptr := patchptr;
       patchptr := patchlist;
       end;
     patchdelta := patchaddr-objectaddr;
     if (patchstate < shortpatch) then
      if (-32768<=patchdelta) and (patchdelta<32768) then
       begin
       if patchsize - (patchaddr - patchbase) >= 4 then
	if newptr.gvp^.primarytype = relocatable then
	 begin
	 delta2 := valptr.vep^.value - (patchaddr+2);
	 if (-32768 <= delta2) and (delta2 < 32768) then
	  if object.a + patchdelta >= textbuffer.a then
	   begin
	   patchstate := shortpatch;
	   foundpatchdelta := patchdelta;
	   foundlastpptr := lastpatchptr;
	   foundpatchmodptr := patchmodptr;
	   end;
	 end;
       if (patchstate < longpatch) and not backwardlist then
	if patchsize - (patchaddr - patchbase) >= 6 then
	 begin
	 patchstate := longpatch;
	 foundpatchdelta := patchdelta;
	 foundlastpptr := lastpatchptr;
	 foundpatchmodptr := patchmodptr;
	 end;
       end;
     patchmodptr := patchlink;
     end;
   end;
  if patchstate = nopatch then patcherror(newptr.gvp^.datasize)
  else if patchstate < oldpatch then
   with foundpatchmodptr^ do
    begin
    gbytes(r.a, sizeof(patchdescriptor));
    if patchlist = NIL then patchlist := r.pdp
    else foundlastpptr^.patchlist := r.pdp;
    with r.pdp^ do
     begin
     patchlist := NIL;
     patchref := newptr;
     if patchstate = longpatch then newptr.gvp^.datasize := sint
     else begin
	  newptr.gvp^.datasize := sword;
	  if foundpatchdelta < 0 then
	   begin
	   r.a := object.a + foundpatchdelta;
	   r.uw^.w := 24576 {BRA pc relative};
	   r.a := r.a + 2;
	   r.sw^ := delta2;
	   if printeron then
	    begin
	    list; write(listing, '(backward patch)  BRA ');
	    gvrp := patchref.gvp; vevalue := 0;
	    gvrstring(gvrp, vevalue, false, true);
	    writeln(listing, gvaluestring,
	     '':20-strlen(gvaluestring),
	     r.a-2-loadaddr:10);
	    end;
	   end;
	  end;
     end;
    object.sw^ := foundpatchdelta;
    end;
  end;

begin {procedure copytext}
  {estimate data structures at 3/2(totalpatchspace) + 1/4(workspace) }
  textbufblocks := ((highheap.a - lowheap.a) * 3  -
		     totalpatchspace         * 6  ) div (blocksize * 4);

  refbufblocks := textbufblocks div 4;
  if refbufblocks < 4 then refbufblocks := 4;

  textbufblocks := textbufblocks - refbufblocks;
  if textbufblocks < 3 then textbufblocks := 3;

  gbytes(textbuffer.a, textbufblocks * blocksize);
  textbuftop := lowheap;
  gbytes(refbuffer.a,  refbufblocks  * blocksize);
  refbuftop  := lowheap;

  newindex.a := newdirectory.a + sizeof(moduledirectory);
  newindex.a := newindex.a + strlen(newindex.syp^) + 2 -
		 ord(odd(strlen(newindex.syp^)));
  if newdirectory.drp^.executable then
    newindex.a := newindex.a + newindex.gvp^.short;

  merging := false;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      if printeron then
	begin
	list; writeln(listing, '(patch space)', patchsize:29,patchbase:10);
	end;
      starttext;
      patchptr := patchlist;
      while patchptr <> NIL do with patchptr^, patchref.gvp^ do
	begin
	if textbuftop.a - textindex.a < 6 then
	  dumptext(textindex.a - textbuffer.a);
	if printeron then
	  begin list;
	  gvrp := patchref.gvp; vevalue := 0;
	  gvrstring(gvrp, vevalue, false, true);
	  end;
	if valueextend then
	  begin
	  if longoffset then valptr.a := patchref.a +sizeof(generalvalue,true)
	  else valptr.a := patchref.a +sizeof(generalvalue,false);
	  vevalue := valptr.vep^.value;
	  end
	else vevalue := 0;
	if datasize = sword {PC relative branch} then
	  begin
	  if printeron then
	    writeln(listing, '  BRA ',gvaluestring,
	      '':26-strlen(gvaluestring), object.a-loadaddr:20);
	  object.uw^.w := 24576 {BRA pc relative};
	  object.a := object.a + 2;
	  object.sw^ := vevalue - (object.a - loadaddr);
	  object.a := object.a + 2;
	  offsetbytes := offsetbytes + 4;
	  end
	else {long absolute branch}
	  begin
	  if printeron then
	    writeln(listing, '  JMP ', gvaluestring,
	      '':26-strlen(gvaluestring), object.a-loadaddr:20);
	  object.uw^.w := 20217 {JMP long absolute};
	  object.a := object.a + 2;
	  object.si^ := vevalue;
	  object.a := object.a + 4;
	  gbytes(newptr.a, short);
	  fastmove(patchref.p, newptr.p, short);
	  if valueextend then
	    begin
	    valptr.a := newptr.a + (valptr.a - patchref.a);
	    valptr.vep^.value := 0;
	    end;
	  offsetbytes := offsetbytes + 2;
	  putref;
	  offsetbytes := 4;
	  end;
	textindex := object;
	patchptr := patchlist;
	end;
      object.a := textindex.a + patchsize - (object.a - loadaddr - patchbase);
      while textindex.a < object.a do
	begin
	if textindex.a >= textbuftop.a - 2 then
	  dumptext(textindex.a - textbuffer.a);
	textindex.sw^ := -1;
	textindex.a := textindex.a + 2;
	offsetbytes := offsetbytes + 2;
	end;
      textoutsize := textoutsize + patchsize;
      endtext;
      forwardpatches := patchlink;
      patchlink := backwardpatches;
      backwardpatches := modptr;
      end
    else with directory.drp^ do
      begin
      oldindex.a := directory.a + sizeof(moduledirectory);
      if printeron then
	begin
	list; writeln(listing, oldindex.syp^, '':32-strlen(oldindex.syp^),
		 relocatablesize:10,relocbase:10,
		 globalsize:10,     globase:10);
	end;
      oldindex.a := oldindex.a + strlen(oldindex.syp^) + 2 -
		     ord(odd(strlen(oldindex.syp^)));
      if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
      for oldtextrec := 1 to textrecords do
       begin
       if oldindex.tdp^.textsize > 0 then
	begin
	starttext;
	loadaddr0 := object.a - loadaddr;
	with oldindex.tdp^ do
	  begin
	  refinsize := refsize;
	  textinsize := textsize;
	  refinblock := fileblock+refstart;
	  textinblock := fileblock+textstart;
	  textoutsize := textoutsize + textsize;
	  end;

	inrefindex := refbuftop;

	while (refbuftop.a - inrefindex.a) + refinsize > 0 do
	  begin
	  checkinref;
	  newptr := lowheap;
	  with inrefindex.gvp^ do
	    if longoffset then
	      begin
	      newbytes := long;
	      valptr.a := newptr.a + sizeof(generalvalue, true);
	      end
	    else
	      begin
	      newbytes := short;
	      valptr.a := newptr.a + sizeof(generalvalue, false);
	      end;
	  object.a := object.a + newbytes;
	  offsetbytes := offsetbytes + newbytes;
	  makenewgvr(inrefindex, modptr);
	  with newptr.gvp^, valptr.vep^ do
	    begin
	    case datasize of   {$range off$}
	      sbyte:
		begin
		checktextbuf(sizeof(sbyterec));
		value         := value + object.sb^.sb;
		object.sb^.sb := value;
		value         := value - object.sb^.sb;
		end;
	      sword:
		begin
		checktextbuf(sizeof(shortint));
		value         := value + object.sw^;
		object.sw^    := value;
		value         := value - object.sw^;
		end;
	      sint:
		begin
		checktextbuf(sizeof(integer));
		object.si^ := object.si^ + value;
		value := 0;
		end;
	      ubyte:
		begin
		checktextbuf(sizeof(ubyterec));
		value         := value + object.ub^.ub;
		object.ub^.ub := value;
		value         := value - object.ub^.ub;
		end;
	      uword:
		begin
		checktextbuf(sizeof(wordrec));
		value         := value + object.uw^.w;
		object.uw^.w  := value;
		value         := value - object.uw^.w;
		end;        {$range on$}
	      otherwise escape(111);
	      end; {case datasize}
	    if primarytype = absolute then
	      begin
	      if value <> 0 then
		if patchable and patching then makepatch
		else patcherror(datasize);
		end
	    else if patching and patchable then makepatch
	    else putref;
	    end; {with gvrptr(newptr)^, valptr^}
	  end; {while there are any ref's }

	newbytes := textindex.a + textinsize  - object.a;
	offsetbytes := offsetbytes + newbytes;
	object.a := object.a + newbytes;
	checktextbuf(0);

	endtext;
	end;
       oldindex.a := oldindex.a + sizeof(textdescriptor);
       oldindex.a := oldindex.a + oldindex.gvp^.short;
       end; {for oldtextrec}
      end; {with directory^ do}
    modptr := link;
    end;
end; {copytext}

procedure printdirectentry(modnum: shortint; var entry: direntry);
begin
with entry do
  begin
  upc(dtid);
  list; write(listing, modnum:4,' ',dtid,
  dlastblk-dfirstblk:21-strlen(dtid),'  ');
  writedate(listing, daccess);
  writeln(listing, dfirstblk:7);
  end;
end;

procedure bootmod(modnum: shortint);
const sectorsize = 256;
var     buffer, bufptr, valptr, ptr, endrefs, mname,
	infostart:      addrec;
	object, recordnum:  integer;

procedure writesector(anyvar f: fib; anyvar obj: window; size,sector: integer);
begin
  call (f.am, addr(f), writebytes, obj, size, sector * sectorsize);
  if ioresult <> 0 then escape(114);
end;

begin
  infostart := lowheap;
  loadinfo(modnum,true, true);
  with newmods^,directory.drp^ do
    begin
    if extsize > 8 then escape(120);
    mname.a := directory.a + sizeof(moduledirectory);
    ptr.a := mname.a + strlen(mname.syp^) + 2 - ord(odd(strlen(mname.syp^)));
    if executable then with ptr.gvp^, fibp(addr(outfile))^ do
      begin
      if fstartaddress = 0 then
	if valueextend then
	  begin
	  valptr.a := ptr.a + sizeof(generalvalue,false);
	  fstartaddress := valptr.vep^.value;
	  end;
      ptr.a := ptr.a + short;
      end;
    recordnum := 0;
    while textrecords > 0 do with ptr.tdp^ do
      begin
      recordnum := recordnum + 1;
      if refsize > 0 then       {check to make sure code is "absolute"}
	begin
	gbytes(buffer.a, refsize);
	readblocks(filefib.fbp^,buffer.p^,refsize,fileblock+refstart);
	bufptr := buffer; endrefs.a := buffer.a + refsize;
	object := 0;
	while bufptr.a < endrefs.a do with bufptr.gvp^ do
	  begin
	  if longoffset then
	       begin object := object + long;
	       bufptr.a := bufptr.a + sizeof(generalvalue, true);
	       end
	  else begin object := object + short;
	       bufptr.a := bufptr.a + sizeof(generalvalue, false);
	       end;
	  if valueextend then
	    begin
	    errorline;
	    write  ('Can''t relocate byte ',object:1,
		    ' in record ',recordnum:1,
		    ' of module ',mname.syp^);
	    escape(128);
	    end;
	  if primarytype = general then
	    begin
	    while not bufptr.rpp^.last do
	      bufptr.a := bufptr.a + sizeof(referenceptr);
	    bufptr.a := bufptr.a + sizeof(referenceptr);
	    end;
	  end;
	lowheap := buffer;
	end;
      gbytes(buffer.a, sizeof(integer));
      ptr.a := ptr.a + sizeof(textdescriptor);
      with ptr.gvp^ do
	begin
	if valueextend then
	  begin
	  valptr.a := ptr.a + sizeof(generalvalue,false);
	  buffer.p^ := valptr.vep^.value;
	  end
	else buffer.p^ := 0;
	ptr.a := ptr.a + short;
	end;

      gbytes(bufptr.a, sizeof(integer));
      bufptr.p^ := textsize;

      gbytes(bufptr.a, textsize);
      readblocks(filefib.fbp^,bufptr.p^,textsize,fileblock+textstart);
      writesector(outfile, buffer.p^, textsize+2*sizeof(integer), outblock);
      outblock := outblock +
		(textsize + 2*sizeof(integer) + (sectorsize-1)) div sectorsize;
      lowheap := buffer;
      textrecords := textrecords - 1;
      end;
    end;
  lowheap := infostart;
  newmods := NIL;
end;

procedure copymodule(modnum: shortint);
const fosize = sizeof(addrec)+sizeof(fib,1);
      fsize  = fosize+ord(odd(fosize));
var startblock, numblocks, transblocks:  {shortint} INTEGER;       {SFB}
    copybuffer: addrec;
    bufblocks:  {shortint}  INTEGER;       {SFB}
begin
if booting then bootmod(modnum)
else if linking then begin
		     if loadfib.a >= highheap.a then
		       begin
		       fastmove(highheap.p, lowheap.p, fsize);
		       highheap.a := highheap.a + fsize;
		       lowheap.a := lowheap.a + fsize;
		       loadfib.a := loadfib.a - (highheap.a - lowheap.a);
		       end;
		     loadinfo(modnum, true, true)
		     end
else
  begin
  bufblocks := (highheap.a -lowheap.a) div blocksize;
  gbytes(copybuffer.a, bufblocks * blocksize);

  if outmodnum>=maxmodules then escape(127);
  outmodnum := outmodnum + 1;
  outdirectory.fdp^[outmodnum] := fdirectory^[modnum];
  with fdirectory^[modnum] do
    begin
    startblock := dfirstblk;      numblocks := dlastblk-startblock;
    end;
  with outdirectory.fdp^[outmodnum] do
    begin
    dfirstblk := outblock;        dlastblk := outblock + numblocks;
    end;
  while numblocks > 0 do
    begin
    if numblocks <= bufblocks then transblocks := numblocks
			      else transblocks := bufblocks;
    readblocks(loadfib.fbp^, copybuffer.p^, transblocks*blocksize, startblock);
    blockwrite(outfile, copybuffer.p^, transblocks, outblock);
    startblock := startblock + transblocks;
    outblock := outblock + transblocks;
    numblocks := numblocks - transblocks;
    end;
    lowheap := copybuffer;
    {if printeron then printdirectentry(outmodnum, outdirectory.fdp^[outmodnum]); }
  end;
end;

procedure writedirectory;
begin
  with newdirectory.drp^ do
  begin
    modulesize := nextblock * blocksize;
    blockwrite(outfile, newdirectory.drp^, extblock, outblock);
  end;

  if outmodnum>=maxmodules then escape(127);
  outmodnum := outmodnum + 1;
  with outdirectory.fdp^[outmodnum] do
    begin
    dfirstblk := outblock;
    outblock := outblock + nextblock;
    dlastblk := outblock;
    dfkind := codefile;
    moveleft(newmodname.syp^, dtid, sizeof(filname));
    if strlen(dtid) > fnlength then setstrlen(dtid, fnlength);
    dlastbyte := 256;
    daccess := todaysdate;
    end;
  {if printeron then printdirectentry(outmodnum, outdirectory.fdp^[outmodnum]); }
end;

procedure trim(var s: string);
var first, last: shortint;
begin
  last := strlen(s);
  while last > 0 do
    begin
    if s[last] = ' ' then
      begin last := last - 1; if last = 0 then s := ''; end
    else
      begin
      first := 1;  while s[first] = ' ' do first := first + 1;
      s := str(s, first, last - first + 1);  last := 0;
      end;
    end;
end;

procedure toggleprinter;
var newlistname: string80;
    fvid: vid;
    ftitle: fid;
    fsegs:  integer;
    fkind:  filekind;
begin
printeron := not printeron;
if printeron then
  begin
  fgotoxy(output, 13,3); write('     ',cteol);
  readln(newlistname);
  fixname(newlistname, textfile);
  if scantitle(newlistname, fvid, ftitle, fsegs, fkind) then ; { jws 3/2/84}
  if strlen(newlistname)>0 then
    begin
    listfilename := newlistname;
    if fsegs=0 then                                           { jws 3/2/84 }
	   sappend(newlistname, '[*]');
    pageeject;
    if (pagenum=0) and (linenum=0)
       then close(listing)
       else close(listing, 'lock');
    rewrite(listing, newlistname);
    pagenum := 0;       linenum := 0;
    printopen := ioresult = 0;
    printeron := printopen;
    if not printopen then escape(118);
    end
  else printeron := printopen;
  end;
end;

procedure copyon;
begin
 lowheap := infostart;
 linking := false;
end;

procedure closein;
begin
 if fdirectory <> NIL then
  begin
  if loadfib.a >= highheap.a then
    begin
    close(loadfib.php^);
    loadfib.a := loadfib.a - sizeof(addrec);
    loadfib := loadfib.arp^;
    end;
   highheap := highheap0; fdirectory := NIL;
   vmodnum := 0; verifying := false;
  end;
end;

procedure initlink;
begin
 linking := true;       defsout := true;
 infostart := lowheap;  newmodname.syp := NIL;
 startreloc := 0;       startglobal := 0;
 copyright := '';
end;

procedure link;
begin
 errors := 0;
 fgotoxy(output, 0,23); write('LINKING ...');
 rsolve;
 if printeron then
   begin
   list; writeln(listing, 'link map', 'Rsize':34, 'Rbase':10, 'Gsize':10, 'Gbase':10);
   list; writeln(listing, '------':42, '------':10, '------':10, '------':10);
   end;
 newdirectory := lowheap;
 mergeexts;
 makedir;        {also write new ext table, move down directory}
 mergedefs;
 copytext;
 writedirectory;

 if printeron then
   begin
   list; writeln(listing, '------':42,'------':20);
   list;
   if newmodname.syp = NIL then write(listing, '(no name)', '':32-9)
   else write(listing, newmodname.syp^, '':32-strlen(newmodname.syp^));
   writeln(listing, totalreloc:10, totalglobal:20);
   listln;
   end;
 closein;
 closefiles;
 lowheap := infostart; {release memory used by linker}
 linking := false;      newmods := NIL;
 if errors > 0 then escape(122);
end; {link}


procedure printdirectory;
var numfiles:   shortint;
    modnum:     shortint;
begin
 list; writeln(listing, 'FILE DIRECTORY OF:  ''', loadfib.fbp^.ftid, '''');
 listln;
 numfiles := fdirectory^[0].dnumfiles;
 for modnum := 1 to numfiles do
   printdirectentry(modnum, fdirectory^[modnum]);
 listln;
end;

procedure copyfile;
var modnum:     shortint;
begin
 for modnum := 1 to fdirectory^[0].dnumfiles do
  copymodule(modnum);
 closein;
end;

procedure verifynext;
begin
 if vmodnum < fdirectory^[0].dnumfiles then
  begin
  vmodnum := vmodnum + 1;
  upc(fdirectory^[vmodnum].dtid)
  end
 else
  begin
  vmodnum := 0;
  verifying := false;
  end;
end;

procedure verifymod;
begin
 vmodnum := 0;  verifying := true;
 verifynext;
end;

procedure xfer;
var modnum:     shortint;
begin
 if verifying then
  begin
  copymodule(vmodnum);
  verifynext;
  end
 else
  begin
  for modnum := 1 to fdirectory^[0].dnumfiles do
   with fdirectory^[modnum] do
    begin
    upc(dtid);
    if dtid = fdirectory^[vmodnum].dtid then
      copymodule(modnum);
    end;
  vmodnum := 0;
  end;
end;

procedure openin;
const fosize = sizeof(addrec)+sizeof(fib,1);
      fsize  = fosize+ord(odd(fosize));
begin
 closein;
 fgotoxy(output, 22,13); write(cteol);
 if strlen(infilename)=0 then   { if no name then get it }
 begin readln(infilename); fixname(infilename, codefile);
 end;
 if strlen(infilename) > 0 then
 begin
   openlinkfile(infilename);
   if fdirectory = NIL then
   begin errorline;
	 write('cannot open ''', infilename, ''', ');
	 ioerror;
   end
   else
   begin highheap.a := highheap.a - fsize;
	 lowheap.a := lowheap.a - fsize;
	 fastmove(lowheap.p, highheap.p, fsize);
	 loadfib.a := loadfib.a + (highheap.a - lowheap.a);
	 if fdirectory^[0].dnumfiles = 1 then vmodnum := 1
					 else verifymod;
    end;
  end;
end;    { openin }

procedure closeout;
begin
 closein;
 with outdirectory.fdp^[0] do
  begin
  deovblk := outblock;
  dnumfiles := outmodnum;
  outopen := false;     outmodnum := 0;
  lowheap := outdirectory;
  blockwrite(outfile, outdirectory.fdp^, outdirectsize, 0);
  close(outfile, 'lock');
  if ioresult <> 0 then escape(126);
  end;
end;

procedure openout(boot: boolean);
var i,j: integer;
    nul: string[1]; typestring: string[6];
    thirdparm: string[10];
begin
 thirdparm := 'shared';
 if linking then lowheap := infostart;
 linking := false;
 if outopen then
   begin
   close(outfile);
   lowheap := outdirectory;
   end;
 outopen := false;
 fgotoxy(output, 22,4); write(cteol);
 readln(outfilename);
 trim(outfilename);
 if strlen(outfilename) > 0 then
  begin
  nul := '';
  if boot then
   begin
   fixname(outfilename, sysfile);
   reset(outfile, outfilename); close(outfile, 'PURGE');
   typestring := '.SYSTM'; fmaketype(outfile, outfilename, thirdparm, typestring);
   outopen := (ioresult = 0);
   outblock := 0;
   end
  else
   begin
   fixname(outfilename, codefile);
   typestring := '.CODE'; fmaketype(outfile, outfilename, thirdparm, typestring);
   if ioresult = 0 then
    begin
    gbytes(outdirectory.a, outdirectsize*blocksize);
    with outdirectory.fdp^[0] do
      begin
      dfirstblk := 0; dlastblk := outdirectsize;
      dfkind := untypedfile {volume entry};
      moveleft(outfilename, dvid, sizeof(volname));
      if strlen(outfilename) > vnlength then setstrlen(dvid, vnlength);
      deovblk := outdirectsize; dnumfiles := 0;
      dloadtime := 0; dlastboot := todaysdate;
      end;
    outblock := outdirectsize;
    outopen := true;
    end;
   end;
  if outopen then booting := boot
  else
   begin
   booting := false;
   errorline;
   write('cannot open ''', outfilename, ''', ');
   ioerror;
   end;
  end;
end;    { openout }

procedure setmaxmodules;
var total, excess: integer;
begin
 fgotoxy(output, 30,6); write(cteol);
 if readint(maxmodules) then
   begin
   if maxmodules > 300000 then
     begin
     maxmodules := 38;
     escape(125);
     end;
   if maxmodules <= 0 then maxmodules := 0;
   outdirectsize := ((maxmodules+1)*entrysize+(blocksize-1)) div blocksize;
   maxmodules := outdirectsize*blocksize div entrysize - 1;
   end;
end;

procedure setreloc;
begin
 fgotoxy(output, 21,7); write(cteol);
 if readint(startreloc) then ;
end;

procedure setglobal;
begin
 fgotoxy(output, 21,8); write(cteol);
 if readint(startglobal) then ;
end;

procedure setcopyright;
begin
  fgotoxy(output, 0,12); write(cteol);
  fgotoxy(output, 22,11); write(cteol);
  readln(copyright);
end;

procedure makepatchspace;
var pmod:       addrec;
begin
 fgotoxy(output, 23,9); write(cteol);
 if readint(patchbytes) then
  if patchbytes > 0 then
   begin
   patchbytes := patchbytes + ord(odd(patchbytes));
   gbytes(pmod.a, sizeof(moduledescriptor,true));
   with pmod.mdp^ do
     begin
     patchmod := true;   patchsize := patchbytes;
     link := newmods;    newmods := pmod.mdp;
     patchlink := NIL;   patchlist := NIL;
     end;
   end;
end;

procedure setname;
var s: string80;
begin
 fgotoxy(output, 24,6); write(cteol);
 readln(s); trim(s);
 if strlen(s)=0 then newmodname.syp := NIL
 else
  begin
  upc(s);
  gbytes(newmodname.a, strlen(s)+2-ord(odd(strlen(s))));
  moveleft(s, newmodname.syp^, strlen(s)+1);
  end;
end;    {setname}

procedure openmod;
var s: string80;
    i: shortint;
begin
  verifying := false;   vmodnum := 0;
  fgotoxy(output, 18,18); write(cteol);
  readln(s); trim(s);
  if strlen(s) > 0 then
   begin
   upc(s);        i := 1;
   while (i <= fdirectory^[0].dnumfiles) and (vmodnum = 0) do
    with fdirectory^[i] do
     begin
     upc(dtid);
     if s = dtid then vmodnum := i
     else i:= i + 1;
     end;
   if vmodnum = 0 then
     begin
     errorline; write('module ''', s,''' not found in file');
     escape(123);
     end;
   end;
end;    {openmod}

procedure findmod(var s:filname; var n:shortint);
var i : integer;
begin
  if strlen(s)=0 then   { if no name given then get it }
  begin readln(s); trim(s); end;
  n:= 0;
  if strlen(s) > 0 then
  begin
    upc(s);        i := 1;
    while (i <= fdirectory^[0].dnumfiles) and (n = 0) do
      with fdirectory^[i] do
      begin
	upc(dtid);
	if s = dtid then n := i else i:= i + 1;
      end;
    if n = 0 then n:=-1;        { signal not found }
  end;
end;    { findmod }

procedure clear(N: shortint);
begin
  repeat writeln(cteol); n := n - 1; until n <= 0;
end;

procedure none;
begin write('(none)'); clear(1); end;

procedure doedit;
var
  firstmodname,untilmodname, oldvmodname : filname;
  firstmodnum, untilmodnum,  oldvmodnum  : integer;
  oldfilename: string80;
  modlist    : string255;
  assoc : boolean;
  lc    : string[4];
  tempf : filname;
  im    : shortint;

  procedure checkassoc;
  begin
    assoc:=assoc and (vmodnum>0);
    if assoc then
    begin firstmodname:=fdirectory^[vmodnum].dtid;
	  firstmodnum:=vmodnum;
	  assoc:=assoc and (firstmodnum<>untilmodnum);
    end;
  end;
  procedure outoforder;
  begin errorline; write('module ',tempf,' out of order'); dobeep;
  end;
  procedure mnotfound;
  begin errorline; write('module ',tempf,' not found'); dobeep;
  end;

begin   { doedit }
  untilmodname := '(end of file)';
  untilmodnum  := fdirectory^[0].dnumfiles+1;
  if vmodnum=0 then firstmodname:='(none)'
	       else firstmodname := fdirectory^[vmodnum].dtid;
  firstmodnum  := vmodnum;
  assoc := true;
  fgotoxy(output,0,2); write(cteos);
  repeat
    fgotoxy(output,0,2);
    writeln('S  Stop editing');
    clear(2);
    if firstmodnum>0 then
       writeln('C  Copy First module upto Until module',cteol)
    else clear(1);
    writeln('F  First module: ',firstmodname,cteol);
    writeln('U  Until module: ',untilmodname,cteol);
    clear(1);
    writeln('A  Append module(s)'); clear(5);
    fgotoxy(output,0,18);
    write('M  input Module:  ');
    if vmodnum = 0 then begin none; clear(3); end
    else
    begin
      writeln(fdirectory^[vmodnum].dtid,cteol);
      if booting then      lc := 'boot'
      else if linking then lc := 'link'
		      else lc := 'copy';
      writeln;
      writeln('T  Transfer (',lc,') module',cteol);
      writeln('<space> to continue verifying',cteol);
    end;
    getcommandchar('Edit option?',commandchar);
    case commandchar of
    'A':begin
	  oldfilename:= infilename;     { save current inputfile name }
	  oldvmodnum := vmodnum;        { same current module number & name }
	  oldvmodname := fdirectory^[vmodnum].dtid;
	  fgotoxy(output,0,13); write('        Input  file:  ',cteol);
	  setstrlen(infilename,0);
	  openin;       { get new input file }
	  if strlen(infilename)>0 then begin       { 3.0 BUG FIX -- 4/11/84 }
	    { get list of modules and copy them }
	    fgotoxy(output,0,10);
	    writeln('enter list of modules or = for all');
	    readln(modlist); trim(modlist); upc(modlist);
	    if modlist='=' then
	    begin { all modules }
	      for im:=1 to fdirectory^[0].dnumfiles do
	      begin
		fgotoxy(output,0,11); write(fdirectory^[im].dtid,cteol);
		copymodule(im);
	      end;
	    end
	    else
	    while strlen(modlist)>0 do
	    begin
	      im:=strpos(',',modlist);
	      if im=0 then im:=strlen(modlist)+1;
	      try
		if im>sizeof(tempf) then escape(129)
				   else tempf:=str(modlist,1,im-1);
		if im>strlen(modlist) then setstrlen(modlist,0)
				     else strdelete(modlist,1,im);
		if strlen(tempf)>0 then
		begin     { find the module and copy it }
		  findmod(tempf,vmodnum);
		  if vmodnum>0 then copymodule(vmodnum) else escape(123);
		  fgotoxy(output,0,11); write(modlist,cteol);
		end;
	      recover
	      begin
		im:=escapecode;  errorline;
		case im of
		  123: writeln('module ',tempf,' not found');
		  129: writeln('invalid module name');
		  otherwise escape(im)
		end; { case im }
		dobeep; setstrlen(modlist,0);     { zap module list to force exit }
	      end;{ end recover}
	    end;  {while list not empty}

	    if not streaming then                 { 3.0 bug fix -- 4/9/84 jws }
	      repeat getcommandchar('Append done, <space> to continue',commandchar);
	      until commandchar=' ';
	  end;                                    { 3.0 BUG FIX -- 4/11/84 }

	  infilename := oldfilename;
	  openin;       { reopen the old file & find old input module }
	  if oldvmodnum=0 then vmodnum:=0
	  else
	  begin
	    findmod(oldvmodname,vmodnum);
	    if (vmodnum<>oldvmodnum) then
	    begin errorline;
		  write('unable to find old input module ',oldvmodname);
		  vmodnum:=0; dobeep;
	    end;
	  end;
	end;
    'C':if (firstmodnum>0) and (firstmodnum<untilmodnum) then
	begin
	  for im:=firstmodnum to untilmodnum-1 do
	  begin fgotoxy(output,0,8);
		write('now copying ',fdirectory^[im].dtid,cteol);
		copymodule(im);
	  end;
	  if assoc then
	  begin
	    if untilmodnum>fdirectory^[0].dnumfiles
	       then begin vmodnum := 0;
			  firstmodname := '(none)';
		    end
	       else begin vmodnum := untilmodnum;
			  firstmodname := fdirectory^[vmodnum].dtid;
		    end;
	    firstmodnum  := vmodnum;
	    assoc:= assoc and (vmodnum>0);
	  end;
	end
	else dobeep;
    'F':begin
	  fgotoxy(output,17,6); write(cteol);
	  setstrlen(tempf,0); findmod(tempf,im);
	  case im of
	  -1: mnotfound;
	   0: { no module name given, so use default }
	      begin if (vmodnum>0) and (vmodnum<=untilmodnum) then
		begin firstmodname := fdirectory^[vmodnum].dtid;
		      firstmodnum  := vmodnum;
		      assoc := assoc and (vmodnum<untilmodnum);
		end
		else dobeep;
	     end;
	  otherwise     { found the module }
	    if im<=untilmodnum then
	    begin firstmodname := tempf; firstmodnum:=im; assoc:=false;
	    end
	    else outoforder;
	  end;  { case im }
	end;
    'M': if fdirectory<>NIL then
	 begin openmod;
	   if vmodnum>0 then begin        { 3.0 BUG # 57   4/10/84 }
	     assoc := assoc and (vmodnum<untilmodnum);
	     if assoc then
	     begin
	       firstmodname := fdirectory^[vmodnum].dtid;
	       firstmodnum  := vmodnum;
	     end;
	   end                            { 3.0 BUG # 57   4/10/84 }
	   else dobeep                    { 3.0 BUG # 57   4/10/84 }
	 end
	 else dobeep;
    'S':;
    'T': if vmodnum>0 then
	 begin xfer; checkassoc;
	 end
	 else dobeep;
    'U':begin
	  fgotoxy(output,17,7); write(cteol);
	  setstrlen(tempf,0); findmod(tempf,im);
	  case im of
	  -1: mnotfound;
	   0: { no module name given, so default }
	      begin untilmodname := '(end of file)';
		    untilmodnum  := fdirectory^[0].dnumfiles+1;
	      end;
	  otherwise     { found the module }
	      if im>=firstmodnum then
	      begin untilmodname := tempf; untilmodnum:=im;
	      end
	      else outoforder;
	      assoc := assoc and (im>firstmodnum);
	  end;  { case im }
	end;
    ' ': if vmodnum>0 then
	 begin verifynext; checkassoc;
	 end
	 else dobeep;
    otherwise dobeep
    end;
  until commandchar='S';
end;    {doedit}

procedure finishboot;
begin
close(outfile, 'LOCK');
if ioresult<>0 then escape(126);
outopen := false; booting := false;
outmodnum := 0;
end;

procedure menu;
var lc: string[4];
begin
 fgotoxy(output, 0,2); write('Q  Quit'); clear(1);

 write('P  Printout  ');
 if printopen then
   begin
   if printeron then write('ON   ')
		else write('OFF  ');
   write(listfilename);
   clear(1);
   end
 else none;

 if outmodnum > 0 then write('K  Keep o')
 else if (newmods = NIL) and not booting
		  then write('O       O')
		  else write('        o');
 write('utput file:  ');
 if outopen then writeln(outfilename,cteol)
	    else none;
 if outopen then
  begin
  if booting then write('B  finish Boot')
  else if newmods <> NIL then write('L  finish Linking')
  else if linking then write('C  Copy')
  else write('L  Link');
  write(cteol); fgotoxy(output, 40,5);
  if booting then      begin
		       writeln('BOOTING');
		       lc := 'boot';
		       end
  else if linking then begin
		       writeln('LINKING');
		       lc := 'link';
		       end
  else                 begin
		       writeln('COPYING');
		       lc := 'copy';
		       end;
  end
 else
  begin
   writeln('B  write to Boot disk',cteol);
   writeln('H  file Header maximum size:  ',maxmodules,cteol);
  end;

 if linking and outopen then
  begin
  write('N  Name of new module:  ');
  if newmodname.syp = NIL then none
  else writeln(newmodname.syp^,cteol);
  writeln('R  Relocation base:  ',startreloc:12,cteol);
  writeln('G  Global base:      ',startglobal:12,cteol);
  write  ('S  Space for patches:');
  if patchbytes > 0 then writeln(patchbytes:12)
  else clear(1);
  patchbytes := 0;
  write('D  output Def table?  ');
  if defsout then write('YES')
  else write('NO ');
  writeln(cteol);
  writeln('X  copyright notice:  ',copyright);
  end
 else clear(7);

 fgotoxy(output, 0,13);
 write('I       Input  file:  ');
 if fdirectory = NIL then
  begin none; clear(7); end
 else
  begin
  writeln(infilename,cteol);
  if outopen then writeln('E  Edit') else clear(1);
  writeln('F  list File directory');
  if outopen then writeln('A  ',lc,' All modules') else clear(1);
  write('V  Verify modules');
  if verifying then
    begin
    fgotoxy(output, 40,17); writeln('VERIFYING');
    end
  else clear(1);
  write('M  input Module:  ');
  if vmodnum = 0 then
    begin none; clear(3); end
  else
    begin
    writeln(fdirectory^[vmodnum].dtid,cteol);
    writeln('U  Unassemble object');
    if outopen then writeln('T  Transfer (',lc,') module')
    else clear(1);
    if verifying then writeln('<space> to continue verifying')
    else clear(1);
    end;
  end;
end; {menu}

procedure getcommand;
var err: string[80];
begin
  repeat
  try
  menu;
  getcommandchar('command?',commandchar);
  case commandchar of
   'A': if (fdirectory<>NIL) and  outopen then copyfile else dobeep;
   'B': if booting then finishboot
	else if outopen then dobeep
	else openout(true);
   'C': if outopen and linking and (newmods = NIL)
	and not booting then copyon else dobeep;
   'D': if linking and outopen
	then defsout := not defsout else dobeep;
   'E': if (fdirectory<>NIL) and outopen then doedit else dobeep;
   'F': if fdirectory<>NIL then printdirectory else dobeep;
   'G': if linking and outopen then setglobal else dobeep;
   'H': if outopen then dobeep else setmaxmodules;
   'I': begin setstrlen(infilename,0); openin; end;
   'K': if (outmodnum > 0) and not booting
	then closeout else dobeep;
   'L': if booting then dobeep
	else if newmods <> NIL then link
	else if outopen and not linking
	then initlink else dobeep;
   'M': if fdirectory<>NIL then openmod else dobeep;
   'N': if linking and outopen then setname else dobeep;
   'O': if (outmodnum = 0) and (newmods=NIL) and not booting
	then openout(false) else dobeep;
   'P': toggleprinter;
   'Q': quit;
   'R': if linking and outopen then setreloc else dobeep;
   'S': if linking and outopen then makepatchspace else dobeep;
   'T': if (vmodnum > 0) and outopen then xfer else dobeep;
   'U': if (vmodnum > 0) then unassemble else dobeep;
   'V': if fdirectory<>NIL then verifymod else dobeep;
   'X': if linking and outopen then setcopyright else dobeep;
   ' ': if verifying then verifynext;

  otherwise dobeep;
  end;

  recover
   begin
   if (escapecode <> -20) and (escapecode <> 123) and (escapecode<>128)
								then errorline;
   if escapecode=-10 then begin getioerrmsg(err, ires); writeln(err); end
   else case escapecode of
    110: write('symbols defined recursively');
    111: write('improper link info format');
    112: write('not enough memory');
    113: write('output file full');
    114: write('error writing to boot disk, ioresult = ',ires:1);
    116: write('''', infilename, ''' is not a code file');
    118: write('printer or list file not on line');
    119: write('duplicate symbol definition');
    120: write('module being booted has external references');
    121: write('unexpected end of code');
    122: write(errors:1, ' errors during linking',cteol);
    123,128,129: {error message already printed};
    124: write('integer required');
    125: write('integer too large');
    126: write('unable to close output, ioresult = ',ires:1);
    127: write('file header full');
    otherwise escape(escapecode);
    end; {case escapecode}
    if streaming then escape(-1);
    if (escapecode-100) in [12,16] then closein;
    if (escapecode-100) in [10..13,19,22,26,28] then
      begin
      if newmods <> NIL then begin closein; closefiles; end;
      linking := false;     newmods := NIL;
      if outopen then close(outfile);
      outopen := false;     outmodnum := 0;
      booting := false;
      lowheap := lowheap0;
      end;
   end; {recover}
  until commandchar = 'Q';
end {getcommand};


procedure wrapup;
begin
 pageeject;
 closein;
 closefiles;
 if (pagenum=0) and (linenum=0)
   then close(listing)
   else close(listing, 'lock');
end; {wrapup}

begin {program linker}
  with linkerdate do
    begin day := 28; year := 91; month := 10; end;
  sysdate(todaysdate);

  pagenum := 0;         linenum := 0;

  fgotoxy(output, 0,0);
  printheader(output);
  fgotoxy(output, 0, 22);
  writeln('Copyright Hewlett-Packard Company, 1982, 1991.');

  mark(lowheap.p); lowheap0 := lowheap;
  highheap.a := lowheap.a + memavail - 5000;
  release(highheap.p); highheap0 := highheap;

  listfilename := 'PRINTER:LINK.ASC';
  rewrite(listing, listfilename);
  printopen := ioresult = 0;
  printeron := false;

  patchbytes := 0;
  maxmodules := 38;     outdirectsize := 2;
  linking := false;     newmods := NIL;
  outopen := false;     outmodnum := 0;
  booting := false;     verifying := false;
  fdirectory := NIL;    vmodnum := 0;
  loadfib.php := NIL;

  try getcommand;

  recover begin
	  esccode := escapecode;
	  wrapup;
	  escape(esccode);
	  end;

  wrapup;

end.
@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 4890
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 4890
					       (*

 (c) Copyright Hewlett-Packard Company, 1985,1991.
All rights are reserved.  Copying or other
reproduction of this program except for archival
purposes is prohibited without the prior
written consent of Hewlett-Packard Company.


	    RESTRICTED RIGHTS LEGEND

Use, duplication, or disclosure by the Government
is subject to restrictions as set forth in
paragraph (b) (3) (B) of the Rights in Technical
Data and Computer Software clause in
DAR 7-104.9(a).

HEWLETT-PACKARD COMPANY
Fort Collins, Colorado                         *)


$MODCAL,debug off,iocheck off,range off,ovflcheck off$ $ref 60$
$ALLOW_PACKED ON$ {JWS 3/31/87}

program linker(input, output, keyboard);


import sysglobals,fs,loader,ldr,asm,sysdevs,ci,misc;


const   pagelines = 63;
	pageblocks = 2;
	entrysize = 26;

type    address = integer;
	point = ^integer;

var     keyboard:       text;
	todaysdate:     daterec;
	linkerdate:     daterec;
	tempstring:     string[12];
	gvaluestring:   string80;
	copyright,
	listfilename:   string80;
	listing:        text;
	pagenum,
	linenum:        shortint;
	linking,booting,
	outopen,
	verifying,defsout,
	printopen,
	printeron:      boolean;
	commandchar: char;
	startgvr:       addrec;
	startgvrmod:    moddescptr;
	modsave:        moddescptr;
	infost:         addrec;

	ires:   integer;        {saved ioresult}
	errors: integer;
	esccode: integer;
	lowheap0,highheap0: addrec;

	infilename:     string80;
	vmodnum:        shortint;

	{output file information: }
	outdirectory:   addrec;         {new library directory pointer}
	outfile:        phyle;          {file being written}
	firstoutblock,
	outblock:       integer;        {next block within library to write}
	nextblock:      integer;        {next block within module to write}
	outfilename:    string80;
	outmodnum:      integer;        {number of modules created so far}
	outdirectsize,
	maxmodules:     integer;

	{linker information:  }
	totalpatchspace: integer;       {bytes of patch space}
	patchbytes:     integer;
	backwardpatches,
	forwardpatches: moddescptr;
	newmodname:     addrec;         {new name for linked module}
	infostart:      addrec;         {pointer to bottom of linker memory}
	newexttable:    address;        {location of new EXT table}
	newextsize:     integer;        {size in bytes of EXT table}
	newdirectory:   addrec;         {pointer to new module directory}
	loadgvr:        gvrptr;
	modulepc:       integer;        { module body entry point }

procedure dobeep;
begin beep;if streaming then escape(-1); end;

procedure errorline;
begin ires := ioresult; fgotoxy(output, 0, 22); write(bellchar, cteol); end;

procedure ioerror;
begin write(' ioresult = ',ires:1); escape(123); end;

procedure getcommandchar(s:string80; var c:char);
begin
  fgotoxy(output,0,23); write(s,cteol);
  read(keyboard,c);
  fgotoxy(output,0,22); writeln(cteol);write(cteol);
  if (c>='a') and (c<='z') then c:= chr(ord(c)-32);
end;

procedure writedate(var f:  text;  date: daterec);
type months = packed array[0..35] of char;
const monthname = months['JanFebMarAprMayJunJulAugSepOctNovDec'];
var i,j: shortint;
begin
with date do
  begin
  {LAF 880101 added "mod 100" and removed test for "year<100"}
  if (month in [1..12]) and (day>0) then
    begin { Valid date }
    write(f, day:2, '-');
    j := (month - 1) * 3;
    for i := j to j+2 do write(f, monthname[i]);
    write(f, '-',year mod 100:2);
    end
  else write(f, '<no date>'); { Invalid date }
  end;
end; {datestring}

procedure gbytes(var p: integer; size: integer);
begin
 p := lowheap.a;        lowheap.a := lowheap.a + size;
 if lowheap.a > highheap.a then escape(112);
end;

procedure blockwrite(anyvar f: fib; anyvar obj: window; blocks,block: integer);
begin
  call (f.am, addr(f), writebytes, obj, blocks*fblksize, block*fblksize);
  if ioresult <> ord(inoerror) then escape(113);
end;

procedure readblocks(var f: fib; anyvar obj: window; size, block: integer);
begin
  call (f.am, addr(f), readbytes, obj, size, block*fblksize);
  if ioresult <> ord(inoerror) then escape(-10);
end;

procedure gvrstring(var gvp:gvrptr; var val:integer; pcrel,nores: boolean);

(*advances g past the GVR, adds any absolute part to VAL,
  and constructs a string representing the GVR in gvaluestring          *)

type
  rpp = ^referenceptr;
var
  Rcount:       shortint;
  done:         boolean;
  g:            gvrptr;
  i:            integer;

procedure sign(sub: boolean);
begin
 if sub then sappend(gvaluestring,'-')
 else if strlen(gvaluestring)>0 then sappend(gvaluestring,'+');
end;

begin {gvrstring}
 gvaluestring := '';       Rcount := 0;
 repeat
 if pcrel then g := loadgvr
	  else g := gvp;
 if g <> NIL then with g^ do
  begin
  if longoffset then
    g:=gvrptr(integer(g)+sizeof(generalvalue,true))
  else
    g:=gvrptr(integer(g)+sizeof(generalvalue,false));
  if valueextend then
    begin
    if not pcrel then val:= val + veptr(g)^.value;
    g:=gvrptr(integer(g)+sizeof(valueextension,sint));
    end;
  case primarytype of
   absolute: {no more value};
   relocatable: Rcount := Rcount + 1;
   global: begin sign(false); sappend(gvaluestring,'Gbase'); end;
   general:
    begin
    done := false;
    repeat with rpp(g)^ do
      begin
       if adr=0 then
	 if op=addit then Rcount := Rcount + 1
	 else Rcount := Rcount - 1
       else if adr=1 then
	 begin sign(op=subit); sappend(gvaluestring,'Gbase'); end
       else
	 begin sign(op=subit);
	 if newmods^.unresbits.bmp^[adr] or nores
	     then sappend(gvaluestring,symbolptr(newexttable+4*adr)^)
	     else sappend(gvaluestring,symbolptr(point(newexttable+4*adr)^)^);
	 end;
      done := last;
      g := gvrptr(integer(g)+sizeof(referenceptr));
      end;
    until done;
    end; {general}
   end; {primarytype cases}
  if not pcrel then gvp := g;
  end; {with g^}
 pcrel := not pcrel;
 until pcrel;
 while Rcount <> 0 do
  begin sign(Rcount<0); sappend(gvaluestring,'Rbase');
	if Rcount < 0 then Rcount := Rcount + 1
	else Rcount := Rcount - 1;
  end;
 if (val <> 0) or (strlen(gvaluestring)=0) then
  begin
  if val >= 0 then sign(false);
  strwrite(gvaluestring,strlen(gvaluestring)+1,i,val:1);
  end;
end; {gvrstring}


procedure printheader(var f: text);
var time: timerec;
begin
 write(f,'Librarian  [Rev.  3.25 ');
 if ioresult <> 0 then
   begin
   printopen := false;
   printeron := false;
   escape(118);
   end;
 writedate(f, linkerdate);
 write(f,']',' ':7);
 writedate(f, todaysdate);
 systime(time);
 with time do write(f, hour:4,':',minute:2,':',centisecond div 100:2);
 if pagenum > 0 then write(f,'page ':10,pagenum:1);
 writeln(f);
 writeln(f);
end;

procedure pageeject;
var i: integer;
begin
 if linenum > 0 then page(listing);
 linenum := 0;
end;

procedure list;
begin
  if linenum >= pagelines then pageeject;
  if linenum = 0 then
    begin
    pagenum := pagenum + 1;
    printheader(listing);
    linenum := linenum + 2;
    end;
  linenum := linenum + 1;
end;

procedure listln;
begin writeln(listing); linenum := linenum + 1;
end;

procedure quit;
var ch: char;
begin
  if (outopen and (outmodnum>0)) or
     (booting and (outblock>0)) then
  begin
  errorline;
  if booting then writeln('WARNING:  You didn''t finish booting')
  else writeln('WARNING:  You didn''t ''Keep'' the output file.');
  if streaming then escape(123)
  else
    begin
    write('Are you sure you want to quit?  (type Y if yes)  ');
    read(keyboard, ch);
    if (ch<>'y') and (ch<>'Y') then commandchar := ' ';
    end;
  end;
end;

function readint(var value: integer): boolean;
var s: string80;
    i: integer;
begin
  readln(s);
  strread(s,1,i,value);
  if ioresult<>ord(inoerror) then
    if i <= strlen(s) then escape(124);
  readint := ioresult=ord(inoerror);
end;

procedure unassemble;

type hex = 0..15;
     htoctyp = array[0..15] of char;
     decodestatetype = (consts,code,abscode,startcase,casetable,
			endofproc,quittype,notype,phdr);

const htoc = htoctyp['0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'];

var
  nilgvr:       gvrptr;
  dumped:       boolean;
  fortranflag:  boolean;
  rangetype: (norange, pcrange, linerange);
  lowrange, highrange, lastline: integer;
  decodestate,oldstate: decodestatetype;
  PC,tablePC,casecodestart: integer;
  codecount: integer; {bytes left in current inbuf}
  codeindex: integer; {next byte of code in inbuf}
  instrsize: 0..22;  {byte count of current instruction}
  refgvr: addrec;       reflim,refloc: address;
  inbuf,refptr: addrec;

procedure dumpmod (mp:moddescptr);
var junkint:    integer;
    producername: string[30];
    textstep: addrec;
    modulename: string255;      { rdq }
    def       : addrec;         { rdq }
    done      : boolean;        { rdq }

begin {dumpmod}
 dumped := true;
 with mp^,directory.drp^ do
  begin
  pageeject;
  textstep.a:=directory.a+sizeof(moduledirectory);
  list; write(listing,'MODULE    ');
  modulepc := -2;  { rdq }  { no module body }
  modulename := textstep.syp^; { rdq }
  if strlen(modulename) = 0 then write(listing,'(no name)')
  else
    begin
    write(listing,modulename);
    modulepc := -1;
    end;
  modulename := modulename+' '+modulename; { rdq } { make module entrypoint symbol }
  write(listing,'    Created ');
  writedate(listing, date); writeln(listing);
  list; write(listing,'NOTICE:  ');
  if strlen(notice)=0 then writeln(listing,'(none)')
		      else writeln(listing,notice);
  fortranflag := (producer = 'F');
  case producer of
    'M': producername := 'Modcal Compiler';
    'P': producername := 'Pascal Compiler';
    'L': producername := 'Librarian';
    'F': producername := 'FORTRAN Compiler';
    'B': producername := 'BASIC Compiler';
    'A': producername := 'Assembler';
    'C': producername := '''C'' Compiler';
    'D': producername := 'Ada Compiler';
    otherwise producername := '" "';
	      producername[2] := producer;
    end;
  list; write(listing,'  Produced by ', producername, ' of ');
  writedate(listing,revision); writeln(listing);
  if systemid = 0 then systemid := 1;
  list; writeln(listing,'  Revision number ',systemid:1);
  list; writeln(listing,'  Directory size ',directorysize:6,' bytes');
  list; writeln(listing,'  Module size    ',modulesize:6,' bytes');
  junkint:=strlen(textstep.syp^);
  textstep.a := textstep.a+junkint+2-ord(odd(junkint));
  if executable then
    begin
    startgvr := textstep;
    junkint := 0;
    modulepc := -2; { rdq executable so no 'module body' }
    gvrstring(textstep.gvp,junkint,false,false);
    list; writeln(listing,'  Execution address    ',gvaluestring);
    end
  else
    begin
    startgvr.gvp:=NIL;
    list; writeln(listing,'  Module NOT executable');
    end;
  list; writeln(listing,'  Code base      ',relocatablebase,
			'     Size ',relocatablesize,' bytes');
  list; writeln(listing,'  Global base    ',globalbase,
			'     Size ',globalsize,' bytes');
  if extsize <= 8 then extsize := 0;
  list; writeln(listing,'  EXT    block ',extblock:3,'     Size ',extsize,
	     ' bytes');
  list; writeln(listing,'  DEF    block ',defblock:3,'     Size ',defsize,
	     ' bytes');
  list;

  if (defsize>0) and (modulepc>-2) then       {RDQ}
  begin { find the module entry point }
    def:=defaddr;
    done:=false;
    REPEAT
      if def.a >= defaddr.a + defsize then done:=true
      else
      begin
	if def.syp^=modulename then
	begin { foundit now get its value }
	  done:=true;
	  def.a := def.a + strlen(def.syp^)+2-ord(odd(strlen(def.syp^)));
	  junkint:=0;
	  gvrstring(def.gvp,junkint,false,false);
	  strread(gvaluestring,7,junkint,modulepc);
	end
	else
	begin { advance to the next symbol }
	  def.a := def.a + strlen(def.syp^)+2-ord(odd(strlen(def.syp^)));
	  def.a := def.a + def.gvp^.short;
	end;
      end;
    UNTIL done;
  end;

if sourcesize <> 0 then
      writeln(listing,'  EXPORT block ',sourceblock:3,'     Size ',
	      sourcesize,' bytes')
  else
    writeln(listing,'  No EXPORT text');
  list; writeln(listing,'  There are ',textrecords,' TEXT records');
  listln; listln;
  end; {with mp^,directory^}
end; {dumpmod}

procedure prepunassem;
var i: integer;
begin
  modsave := newmods;
  newmods := NIL;
  infost  := lowheap;
  loadinfo(vmodnum, true, true);
  with newmods^,directory.drp^ do
   begin
   newexttable := extaddr.a;
   gbytes(unresbits.a, ((extsize div 4 + 15) div 16)*2);
   for i := 2 to extsize div 4 - 1 do unresbits.bmp^[i] := false;
   for i := 2 to listsize-1 do unresbits.bmp^[listaddr^[i] div 4] := true;
   end;
  if not dumped then dumpmod(newmods);
end;

procedure nextref;
begin
if refgvr.a < reflim then
  if refgvr.gvp^.longoffset then
    refloc:=refloc+refgvr.gvp^.long
  else
    refloc:=refloc+refgvr.gvp^.short;
end;

procedure listinstruction;
type
  regtype  = (D,A);
  regrange = 0..7;
  siz = (bytesiz,wordsiz,longsiz,invalid);
  opsizetype = array[bytesiz..longsiz] of string[3];
  exttype =
	packed record
	  case integer of
	    1: (uwordext: 0..65535);
	    2: (wordext: shortint);
	    3: (longext: integer);
	    4: (regclass: regtype;
		reg: regrange;
		long: boolean;
		scale : 0..3;
		case fullindex : boolean of
		  false: (case integer of
			   1: (byteext: -128..127);
			   2: (ubyteext: 0..255));
		  true:  (exbs : boolean;
			  exis : boolean;
			  exbdsize : 0..3;
			  expadbit : boolean;
			  exindirect : 0..7));
	    5: (mask: packed array [0..15] of boolean);
	    6: (bf_bit  : 0..1;
		bf_reg  : 0..7;
		bf_Do   : boolean;
		bf_offset : 0..31;
		bf_Dw   : boolean;
		bf_width  : 0..31);
	    7: (exDAbit1 : 0..1;
		exRn1  : 0..7;
		expad1 : 0..7;
		exDu1  : 0..7;
		expad2 : 0..7;
		exDc1  : 0..7;
		exDAbit2 : 0..1;
		exRn2  : 0..7;
		expad3 : 0..7;
		exDu2  : 0..7;
		expad4 : 0..7;
		exDc2  : 0..7);
	    8: (fopclas : 0..7;
		frx : 0..7;
		fry : 0..7;
		case integer of
		  0: (fextension : 0..127);
		  1: (fext : 0..15;
		      sincosreg : 0..7);
		  2: (Kfactor : -64..63);
		  3: (KDreg : 0..7;
		      zeros : 0..15));
	    end;


const       opsize = opsizetype['.b ','.w ','.l '];

var
  hexout: packed array[0..10,0..3] of hex;
  firstline: boolean;  { 1st line of current instruction? }
  bytesleft: 0..22;    { to be listed in current instr }
  instrbuf: string[255];{ alpha form of instruction }

  instr: packed record case integer of
	   1: (opcode: 0..15;
	       case integer of
		 1: (cond: 0..15;
		     displ: -128..127);
		 2: (reg1: regrange;
		     opmode: 0..7;
		     eamode: 0..7;
		     eareg: regrange);
		 3: (dummy: 0..7;
		     bit8: boolean;
		     size: siz;
		     fpredicate: 0..63)
	      );
	   3: (w: shortint);
	   4: (lb, rb: byte);
	   end; {instr}

  ext: exttype;
  procedure emitint(val: integer);
  var i: integer;
  begin
    strwrite(instrbuf, strlen(instrbuf)+1, i, val:1);
  end;

  procedure comma;
  begin  sappend(instrbuf, ','); end;

  procedure space;
  begin  sappend(instrbuf, ' '); end;

  procedure printinstrword;
  var k: integer;
  begin write(listing,' ');
    for k := 0 to 3 do
      write(listing,htoc[hexout[(instrsize-bytesleft) div 2,k]]);
    bytesleft := bytesleft-2;
  end;

  procedure getinstrbytes(size: shortint);
  begin
  if codecount < size then escape(121);
  moveleft(inbuf.stp^[codeindex],ext,size);
  moveleft(ext,hexout[instrsize div 2],size);
  instrsize := instrsize+size;
  codeindex := codeindex+size;
  codecount := codecount-size;
  end;

  procedure getinstruction;
  begin
  instrsize := 0;
  getinstrbytes(2);     instr.w := ext.wordext;
  end;

  procedure defineword;
  begin
  instrbuf := 'dc.w ';
  with instr do
    begin
    emitint(w);
    while strlen(instrbuf) < 11 do space;
    sappend(instrbuf,'   or dc.b ');
    emitint(lb); comma; emitint(rb);
    while strlen(instrbuf) < 30 do space;
    sappend(instrbuf,'   or dc.b ''  ''');
    if (lb >= 32) and (lb < 127) then instrbuf[43] := chr(lb);
    if (rb >= 32) and (rb < 127) then instrbuf[44] := chr(rb);
    end;
  end;

  procedure extend(size: integer; pcrel: boolean; fudge: integer);
    var offset, location, PCtemp: integer;
    begin
      location := PC+instrsize;
      if size = 1 then {byte extension}
	begin
	PCtemp := location + 1;
	size := 2;
	end
      else PCtemp := location;

      while (refgvr.a<reflim) and (refloc<PCtemp) do
	begin
	offset := 0;
	gvrstring(refgvr.gvp,offset,false,false);
	nextref;
	end;

      getinstrbytes(size);
      if odd(PCtemp)   then offset := ext.byteext
      else if size = 2 then offset := ext.wordext
		       else offset := ext.longext;
      if pcrel then offset := offset + location + fudge;
      if refloc=PCtemp then
	begin
	gvrstring(refgvr.gvp,offset,pcrel,false) ;
	nextref;
	end
      else
	gvrstring(nilgvr,offset,pcrel,false);
      sappend(instrbuf,gvaluestring);
    end;

  procedure unsigned_byte_extend;
    var offset, location, PCtemp: integer;
    begin
      location := PC+instrsize;
      PCtemp := location + 1;

      while (refgvr.a<reflim) and (refloc<PCtemp) do
	begin
	offset := 0;
	gvrstring(refgvr.gvp,offset,false,false);
	nextref;
	end;

      getinstrbytes(2);
      offset := ext.ubyteext;
      if refloc=PCtemp then
	begin
	gvrstring(refgvr.gvp,offset,false,false) ;
	nextref;
	end
      else
	gvrstring(nilgvr,offset,false,false);
      sappend(instrbuf,gvaluestring);
    end;

  procedure decode;
  label 1,2;
  type
    opndtype = (source,dest);
    regsymtype = array[regtype] of string[1];
    extsiztype = array[bytesiz..longsiz] of 1..4;
    arithoptype = array[8..13] of string[3];

    condcodetype = array[0..15] of string[2];

  const
    SP = 7;

    regsym = regsymtype['d','a'];
    extsize = extsiztype[1,2,4];

    condcode = condcodetype['t','f','hi','ls','cc','cs','ne','eq',
			    'vc','vs','pl','mi','ge','lt','gt','le'];
    arithop = arithoptype['or','sub','','cmp','and','add'];

  var
    tempint,I : integer;
    bf_reg : 0..7;
    bf_Do : boolean;
    bf_offset : 0..31;
    bf_Dw : boolean;
    bf_width : 0..32;

    procedure osize;
    var size: siz;
    begin size := instr.size;
    if size = invalid then goto 2;
    sappend(instrbuf, opsize[size])
    end;

    procedure emitdir(regclass: regtype; reg: regrange);
    begin if (regclass = A) and (reg = SP) then sappend(instrbuf,'sp')
	  else begin
	       sappend(instrbuf,regsym[regclass]);
	       setstrlen(instrbuf, strlen(instrbuf) + 1);
	       instrbuf[strlen(instrbuf)] := htoc[reg];
	       end;
    end;

    procedure emitardef(reg: regrange);
    begin sappend(instrbuf,'(');
	  emitdir(A,reg);
	  sappend(instrbuf,')');
    end;

    procedure emitardisp(reg: regrange);
    begin extend(2,false,0);
	  emitardef(reg);
    end;

    procedure emitpostincr(reg: regrange);
    begin emitardef(reg);
	  sappend(instrbuf, '+');
    end;

    procedure emitpredecr(reg: regrange);
    begin sappend(instrbuf, '-');
	  emitardef(reg);
    end;

    procedure emitindx(pcrel: boolean);
      var
	I : integer;
	saveext : exttype;
    begin
    moveleft(inbuf.stp^[codeindex],ext,2); { fake 'getinstrbytes(2)' }
    if not ext.fullindex then
      if ext.scale = 0 then
	begin
	extend(1,pcrel,0); sappend(instrbuf, '(');
	with instr, ext do
	  begin
	  if not pcrel then
	    begin emitdir(A, eareg); comma; end;
	  emitdir(regclass,reg);
	  if long then sappend(instrbuf,'.l)')
		  else sappend(instrbuf,'.w)');
	  end;
	end
      else
	begin
	sappend(instrbuf,'(');
	extend(1,pcrel,0);
	if pcrel then
	  sappend(instrbuf,',')
	else
	  strwrite(instrbuf,strlen(instrbuf)+1,I,',a',instr.eareg:1,',');
	emitdir(ext.regclass,ext.reg);
	if ext.long then sappend(instrbuf,'.l')
		    else sappend(instrbuf,'.w');
	case ext.scale of
	  1: sappend(instrbuf,'*2)');
	  2: sappend(instrbuf,'*4)');
	  3: sappend(instrbuf,'*8)');
	end;
	end
    else { fullindex }
      begin
      getinstrbytes(2);  { Now do this for real }
      if ext.exindirect <> 0 then sappend(instrbuf,'([')
			     else sappend(instrbuf,'(');
      saveext := ext;
      case saveext.exbdsize of
	0: goto 2;
	1: ;
	2: extend(2,pcrel and (not saveext.exbs),-2);
	3: extend(4,pcrel and (not saveext.exbs),-2);
      end;
      if not saveext.exbs then
	begin
	if not pcrel then
	  begin
	  if (instrbuf[strlen(instrbuf)] <> '(') and
	     (instrbuf[strlen(instrbuf)] <> '[') then
	    comma;
	  strwrite(instrbuf,strlen(instrbuf)+1,I,'a',instr.eareg:1);
	  end
	else if (saveext.exbdsize = 1) { suppress displacement ? } then
	  sappend(instrbuf,'PC');
	end
      else
	if pcrel then
	  begin
	  if (instrbuf[strlen(instrbuf)] <> '(') and
	     (instrbuf[strlen(instrbuf)] <> '[') then
	    comma;
	  sappend(instrbuf,'ZPC')
	  end;
      if saveext.exindirect in [5,6,7] then
	sappend(instrbuf,']');
      if not saveext.exis then
	begin
	if (instrbuf[strlen(instrbuf)] <> '(') and
	   (instrbuf[strlen(instrbuf)] <> '[') then
	  comma;
	emitdir(saveext.regclass,saveext.reg);
	if saveext.long then sappend(instrbuf,'.l')
			else sappend(instrbuf,'.w');
	case saveext.scale of
	  0: ;
	  1: sappend(instrbuf,'*2');
	  2: sappend(instrbuf,'*4');
	  3: sappend(instrbuf,'*8');
	end;
	end;
      if saveext.exindirect in [1,2,3] then
	sappend(instrbuf,']');
      case saveext.exindirect of
	0,1,4,5: ;
	2,6: begin
	     if (instrbuf[strlen(instrbuf)] <> '(') and
		(instrbuf[strlen(instrbuf)] <> '[') then
	       comma;
	     extend(2,false,0);
	     end;
	3,7: begin
	     if (instrbuf[strlen(instrbuf)] <> '(') and
		(instrbuf[strlen(instrbuf)] <> '[') then
	       comma;
	     extend(4,false,0);
	     end;
      end;
      sappend(instrbuf,')');
      end;
    end;

    procedure emitimm(val: integer);
    begin
      sappend(instrbuf,'#'); emitint(val);
    end;

    procedure immediate(fsize: siz);
    begin
      if fsize = invalid then goto 2;
      sappend(instrbuf,'#');
      extend(extsize[fsize],false,0);
    end; {immediate}

    procedure emitea(fsize: siz);
    begin
      with instr do
	case eamode of
      0: emitdir(D,eareg);
      1: emitdir(A,eareg);
      2: emitardef(eareg);
      3: emitpostincr(eareg);
      4: emitpredecr(eareg);
      5: emitardisp(eareg);
      6: emitindx(false);
      7: case eareg of
	0: extend(2,false,0);
	1: extend(4,false,0);
	2: extend(2,true,0);
	3: emitindx(true);
	4: immediate(fsize);
	5..7: goto 2;
	 end; {case eareg}
       end; {case eamode}
    end; {emitea}

    procedure opcode0;
      { bit, MOVEP, immediate, MOVES }

    type bitoptype = array[siz] of string[5];
	 immoptype = array[0..6] of string[4];
    const bitop = bitoptype['btst ','bchg ','bclr ','bset '];
	  immop = immoptype['ori','andi','subi','addi','','eori','cmpi'];
    var
      I : integer;
      regsave : 0..7;

    begin { opcode0 }
      with instr do
	if bit8 then
	  if eamode = 1 then
	    begin
	      if odd(opmode) then instrbuf := 'movep.l '
			     else instrbuf := 'movep.w ';
	      if opmode <= 5 then
		begin emitardisp(eareg);
		  comma; emitdir(D,reg1);
		end
	      else begin
		   emitdir(D,reg1);
		   comma; emitardisp(eareg);
		   end;
	    end
	  else begin {dynamic bit}
		 instrbuf := bitop[size];
		 emitdir(D,reg1);
		 comma; emitea(bytesiz);
	       end
	else if reg1=4 then
	  begin instrbuf := bitop[size];
	    immediate(bytesiz); comma;
	    emitea(bytesiz {invalid});
	  end
	else { NOT bit8 } if ord(size) = 3 then
	  if (reg1 > 4) {bit 11 on} then
	    if (eamode = 7) and (eareg = 4) then {cas2}
	      begin
	      case reg1 of
		5: instrbuf := 'cas2.b ';
		6: instrbuf := 'cas2.w ';
		7: instrbuf := 'cas2.l ';
	      otherwise ;
	      end;
	      getinstrbytes(4);
	      strwrite(instrbuf,strlen(instrbuf),I,
				' d',ext.exDc1:1,':d',ext.exDc2:1,
				',d',ext.exDu1:1,':d',ext.exDu2:1,',(');
	      if ext.exDAbit1 = 0 then sappend(instrbuf,'d ')
				  else sappend(instrbuf,'a ');
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exRn1:1,'):(');
	      if ext.exDAbit2 = 0 then sappend(instrbuf,'d ')
				  else sappend(instrbuf,'a ');
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exRn2:1,')');
	      end
	    else {cas}
	      begin
	      case reg1 of
		5: instrbuf := 'cas.b d ';
		6: instrbuf := 'cas.w d ';
		7: instrbuf := 'cas.l d ';
		otherwise ;
	      end;
	      getinstrbytes(2);
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exDc1:1,',d',
						   ext.exDu1:1,',');
	      emitea(bytesiz);
	      end
	  else if reg1 < 3 then {chk2 cmp2}
	    begin
	    getinstrbytes(2);
	    if ext.long then instrbuf := 'chk2'
			else instrbuf := 'cmp2';
	    case reg1 of
	      0: sappend(instrbuf,'.b ');
	      1: sappend(instrbuf,'.w ');
	      2: sappend(instrbuf,'.l ');
	    end;
	    regsave := ext.reg;
	    if ext.regclass = D then
	      begin
	      emitea(bytesiz);
	      strwrite(instrbuf,strlen(instrbuf)+1,I,',d',regsave:1);
	      end
	    else
	      begin
	      emitea(bytesiz);
	      strwrite(instrbuf,strlen(instrbuf)+1,I,',a',regsave:1);
	      end;
	    end
	  else if eamode <= 1 then
	    begin
	    if eamode = 0 then instrbuf := 'rtm d '
			  else instrbuf := 'rtm a ';
	    strwrite(instrbuf,strlen(instrbuf),I,eareg:1);
	    end
	  else
	    begin
	    instrbuf := 'callm ';
	    sappend(instrbuf,'#');
	    unsigned_byte_extend;
	    comma;
	    emitea(bytesiz);
	    end
	else { ord(size) <> 3 }
	  begin
	  if reg1=7 then
	    begin { moves }
	    instrbuf:='moves'; osize;
	    getinstrbytes(2);
	    if ext.long then
	      begin emitdir(ext.regclass,ext.reg); comma; emitea(size);
	      end
	    else
	      begin emitea(size); comma; emitdir(ext.regclass,ext.reg);
	      end;
	    end
	  else
	    begin
	    instrbuf := immop[reg1];
	    if (eamode=7) and (eareg=4) then
		 begin
		 space; immediate(wordsiz); comma;
		 if size = bytesiz then sappend(instrbuf, 'ccr')
				   else sappend(instrbuf, 'sr');
		 end
	    else begin
		 osize; immediate(size); comma; emitea(size);
		 end;
	    end;
	  end;
    end; {opcode0}

    procedure move;
    { opcodes 1..3: move byte,long,word }
    var lsize: siz;
    begin
      with instr do
	begin
	  case opcode of
	 1: lsize := bytesiz;
	 2: lsize := longsiz;
	 3: lsize := wordsiz;
	  end;
	  instrbuf := 'move';
	  if opmode=1 then sappend(instrbuf,'a');
	  sappend(instrbuf,opsize[lsize]);
	  emitea(lsize); comma;
	  if (opmode=7) and (reg1>1) then goto 2;
	  {kluge to make emitea emit destination}
	  eamode := opmode; eareg := reg1;
	  emitea(lsize  {invalid});
	end;
    end; {move}

    procedure opcode4;
    type miscoptype = array[0..7] of string[5];
	 unoptype = array[0..5] of string[4];
    const predecr = 4; { eamode for predecrement }
	 miscop =
	  miscoptype['reset','nop','stop','rte','rtd','rts','trapv','rtr'];
	 unop = unoptype['negx', 'clr', 'neg', 'not', '', 'tst'];
    var   regstring: string80;
	  I : integer;
	  Dl, Dh : shortint;
	  variantrec : packed record case boolean of
			 true: (w1,w2: shortint);
			 false: (i : integer);
		       end;

      procedure emitreglist
	(optype: opndtype; predecr: boolean; var regstring: string80);
	{ emit register list to 'regstring' according to mask }
      type
	regmasksymtype = array[0..15] of string[2];
      const
	regmasksym = regmasksymtype
	  ['d0','d1','d2','d3','d4','d5','d6','d7',
	   'a0','a1','a2','a3','a4','a5','a6','a7'];
      var
	state: (start,         {waiting for a '1'}
		open,          {have seen a lone '1'}
		cont);         {at least two consecutive '1's}
	j,k,bitcount: integer;

	procedure transition(b: boolean);
	var states: shortint;
	begin
	  if b then
	     if optype = source then states := 6 else states := 5;
	  case state of
	start: if b then
		 begin state := open;
		 sappend(regstring,regmasksym[bitcount]);
		 end;
	open : if b then
		 begin state := cont;
		 sappend(regstring,'-');
		 end
	       else begin state := start;
		    sappend(regstring,'/');
		    end;
	cont : if not b then
		 begin state := start;
		 sappend(regstring,regmasksym[bitcount-1]);
		 sappend(regstring,'/');
		 end;
	  end; {case}
	end; {transition}

      begin {emitreglist}
	getinstrbytes(2);
	if ext.wordext = 0 then regstring := '(none) '
	else
	  begin
	  state := start;
	  bitcount := 0; regstring := '';
	  if not predecr then
	    for j := 1 downto 0 do
	      begin
		for k := 7 downto 0 do
		  begin transition(ext.mask[k+j*8]);
		    bitcount := bitcount+1;
		  end;
		transition(false);
	      end
	  else
	    for j := 0 to 1 do
	      begin
		for k := 0 to 7 do
		  begin transition(ext.mask[k+j*8]);
		    bitcount := bitcount+1;
		  end;
		transition(false);
	      end;
	  end;
	if optype = source then
	  regstring[strlen(regstring)] := ','
	else setstrlen(regstring, strlen(regstring)-1);
      end; {emitreglist}

    procedure emitunop;
    begin with instr do
     begin
     instrbuf := unop[reg1]; osize;
     emitea(size {invalid});
     end;
    end;

    procedure emitsreg;
    begin
      with ext do
      begin
	if (scale <> 0) or (fullindex) then goto 2;
	if not long then
	begin
	  if byteext=0 then sappend(instrbuf,'sfc')
	  else if byteext=1 then sappend(instrbuf,'dfc')
	  else if byteext = 2 then sappend(instrbuf,'cacr')
	  else if byteext = 3 then sappend(instrbuf,'tc') { JWH 12/22/89 }
	  else if byteext = 4 then sappend(instrbuf,'itt0') { JWH 12/22/89 }
	  else if byteext = 5 then sappend(instrbuf,'itt1') { JWH 12/22/89 }
	  else if byteext = 6 then sappend(instrbuf,'dtt0') { JWH 12/22/89 }
	  else if byteext = 7 then sappend(instrbuf,'dtt1') { JWH 12/22/89 }
	       else goto 2;
	end
	else
	begin
	  if byteext=0 then sappend(instrbuf,'usp')
	  else if byteext=1 then sappend(instrbuf,'vbr')
	  else if byteext = 2 then sappend(instrbuf,'caar')
	  else if byteext = 3 then sappend(instrbuf,'msp')
	  else if byteext = 4 then sappend(instrbuf,'isp')
	  else if byteext = 5 then sappend(instrbuf,'mmusr') { JWH 12/22/89 }
	  else if byteext = 6 then sappend(instrbuf,'urp') { JWH 12/22/89 }
	  else if byteext = 7 then sappend(instrbuf,'srp') { JWH 12/22/89 }
	       else goto 2;
	end;
      end;
    end;

    procedure jmpstates;
    begin with instr do
      case eamode of
	2,5,6:;
	7:  if eareg>3 then goto 2;
	otherwise goto 2;
	end;
    end;

    begin {opcode4}
      with instr do
	if bit8 then
	  if ord(size) = 2 then
	    begin
	    instrbuf := 'chk ';
	     emitea(wordsiz); comma;
	     emitdir(D,reg1);
	     end
	  else if ord(size) = 0 then
	    begin
	    instrbuf := 'chk.l ';
	    emitea(longsiz);
	    comma;
	    emitdir(D,reg1);
	    end
	  else if eamode = 0 then
	    begin
	    instrbuf := 'extb.l ';
	    emitdir(D,eareg);
	    end
	  else
	    begin
	    instrbuf := 'lea ';
	    emitea(invalid); comma;
	    emitdir(A,reg1);
	    end
	else { NOT bit8 }
	  case reg1 of
	    0: if size=invalid then
		 begin instrbuf := 'move sr,'; emitea(wordsiz);
		 end
	       else emitunop;
	    1: if size=invalid then
		 begin instrbuf := 'move ccr,'; emitea(wordsiz);
		 end
	       else emitunop;
	       2: if size = invalid then
		 begin instrbuf := 'move ';
		 emitea(wordsiz);
		 sappend(instrbuf, ',ccr');
		 end
	       else emitunop;
	    3: if size = invalid then
		 begin instrbuf := 'move ';
		 emitea(wordsiz);
		 sappend(instrbuf, ',sr');
		 end
	       else emitunop;
	    4: case ord(size) of
		 0: if eamode = 1 then
		   begin
		   instrbuf := 'link.l ';
		   emitdir(A,eareg);
		   comma;
		   immediate(longsiz);
		   end
		 else
		   begin
		   instrbuf := 'nbcd ';
		   emitea(bytesiz {invalid});
		   end;
		 1: if eamode = 0 then
		      begin instrbuf := 'swap '; emitdir(D,eareg);
		      end
		    else if eamode = 1 then
		      begin
		      instrbuf := 'bkpt # ';
		      strwrite(instrbuf,strlen(instrbuf),I,eareg:1);
		      end
		    else
		      begin instrbuf := 'pea '; emitea(invalid);
		      end;
	       2,3: if eamode = 0 then
		      begin instrbuf := 'ext';
		      sappend(instrbuf,opsize[pred(size)]);
		      emitdir(D,eareg);
		      end
		    else
		      begin
		      instrbuf := 'movem';
		      sappend(instrbuf,opsize[pred(size)]);
		      emitreglist(source,eamode=predecr,regstring);
		      sappend(instrbuf,regstring);
		      emitea(invalid);
		      end;
		 end; {case size}
	    5: if instr.w = 19196 {hex('4AFC')} then
		 instrbuf := 'illegal'
	       else if size = invalid then
		  begin instrbuf := 'tas ';
		  emitea(bytesiz {invalid});
		  end
	       else emitunop;
	    6: if size<longsiz then
		 begin
		 getinstrbytes(2);
		 if size = bytesiz then
		   if ext.long then instrbuf := 'muls.l '
				else instrbuf := 'mulu.l '
		 else
		   begin
		   if ext.long then instrbuf := 'divs'
				else instrbuf := 'divu';
		   if ext.scale = 2 then sappend(instrbuf,'.l ')
		   else if ext.reg = ext.byteext then sappend(instrbuf,'.l ')
						 else sappend(instrbuf,'l.l ');
		   end;
		 Dl := ext.reg;
		 if (ext.scale = 2) or
		    ((Dl <> ext.byteext) and (size <> bytesiz)) then
		   Dh := ext.byteext
		 else
		   Dh := -1;
		 emitea(longsiz);
		 comma;
		 if (Dh >= 0) and (Dh <= 7) then
		   begin
		   emitdir(D,Dh);
		   sappend(instrbuf,':');
		   end;
		 emitdir(D,Dl);
		 end
	       else
		 begin instrbuf := 'movem';
		 sappend(instrbuf,opsize[pred(size)]);
		 emitreglist(dest,false,regstring);
		 emitea(invalid); comma;
		 sappend(instrbuf,regstring);
		 end;
	    7: if ord(size) = 2 then
		 begin instrbuf := 'jsr ';
		 jmpstates;
		 emitea(invalid);
		 end
	       else if ord(size) = 3 then
		 begin instrbuf := 'jmp ';
		 jmpstates;
		 emitea(invalid);
		 end
	       else
		 case eamode of
		   0,1:
		      begin instrbuf := 'trap ';
		      emitimm(eareg+8*eamode);
		      if eareg + 8*eamode = 9 then
			begin
			comma; immediate(wordsiz);
			comma; extend(4,true,0);
			end
		      else
		      if eareg + 8*eamode = 1 then
			begin
			sappend(instrbuf,',# ');
			getinstrbytes(2);
			if ext.wordext > 0 then
			  begin
			  variantrec.w1 := ext.wordext;
			  getinstrbytes(2);
			  variantrec.w2 := ext.wordext;
			  variantrec.i := -(variantrec.i - 1073741824);
			  strwrite(instrbuf,strlen(instrbuf),I,variantrec.i:1)
			  end
			else
			  strwrite(instrbuf,strlen(instrbuf),I,ext.wordext:1);
			end
		      else
		      if eareg + 8*eamode = 0 then
			begin
			comma; getinstrbytes(2);
			lastline := ext.uwordext;
			emitimm(lastline);
			while strlen(instrbuf) < 20 do space;
			sappend(instrbuf, 'COMPILED LINE NUMBER ');
			emitint(lastline);
			end;
		      end;
		   2: begin instrbuf := 'link ';
			emitdir(A,eareg); comma;
			immediate(wordsiz);
		      end;
		   3: begin instrbuf := 'unlk '; emitdir(A,eareg);
		      end;
		   4,5:
		      begin instrbuf := 'move ';
			if eamode = 5 then sappend(instrbuf,'usp,');
			emitdir(A,eareg);
			if eamode = 4 then sappend(instrbuf,',usp');
		      end;
		   6: begin
		      instrbuf := miscop[eareg];
		      if (eareg=2) or (eareg=4) then {stop}{rtd}
			  begin space; immediate(wordsiz);
			  end;
		      end;
		   7: begin     { movec }
			if ord(size)<>1 then goto 2;
			instrbuf := 'movec ';
			getinstrbytes(2);
			if eareg=2 then
			begin
			emitsreg; comma; emitdir(ext.regclass,ext.reg);
			end
			else
			  if eareg=3 then
			  begin
			  emitdir(ext.regclass,ext.reg); comma; emitsreg;
			  end
			  else goto 2;
		      end;
		  end; {case eamode}
	    end; {case reg1}
    end; {opcode4}

    procedure quick;
    begin
    with instr do if reg1 = 0 then emitimm(8)
			      else emitimm(reg1);
    comma;
    end;

    procedure shift;
    type
      shiftoptype = array[0..7] of string[4];
    const
      shiftop =
	shiftoptype['asr','lsr','roxr','ror','asl','lsl','roxl','rol'];
    begin
      with instr do
	if size = invalid then
	  begin instrbuf := shiftop[4*ord(bit8)+reg1];
	  space; emitea(bytesiz {invalid});
	  end
	else
	  begin
	  instrbuf := shiftop[4*ord(bit8)+eamode mod 4];
	  osize;
	  if eamode div 4 = 1 then
	    begin
	    emitdir(D,reg1);
	    comma;
	    end
	  else quick;
	  emitdir(D,eareg);
	  end;
    end; {shift}

  procedure mc68881;
    var
      I,j,k : integer;
      saveext : exttype;

    procedure emitfdir(reg: regrange);
      begin
      sappend(instrbuf,'fp ');
      instrbuf[strlen(instrbuf)] := htoc[reg];
      end;

    procedure emitfea(size: integer);
      type
	hexarray = array[0..15] of char;
      const
	hex = hexarray['0','1','2','3','4','5','6','7','8','9',
		       'a','b','c','d','e','f'];
      var
	j,l : integer;
	variantrec : packed record case integer of
		       0: (i: integer);
		       1: (h: packed array[1..24] of 0..15);
		       2: (i1,i2,i3: integer);
		       3: (r : longreal);
		     end;
      begin
      if (instr.eamode = 7) and (instr.eareg = 4) then { Immediate }
	case size of
	  0: {L} immediate(longsiz);
	  1: {S} begin
		 sappend(instrbuf,'#');
		 getinstrbytes(4);
		 variantrec.i := ext.longext;
		 sappend(instrbuf,'$');
		 for j := 1 to 8 do
		   strwrite(instrbuf,strlen(instrbuf)+1,I,hex[variantrec.h[j]]);
		 end;
	  2,3: {X,P}
		begin
		sappend(instrbuf,'#');
		getinstrbytes(4);
		variantrec.i1 := ext.longext;
		getinstrbytes(4);
		variantrec.i2 := ext.longext;
		getinstrbytes(4);
		variantrec.i3 := ext.longext;
		sappend(instrbuf,'$');
		for j := 1 to 24 do
		  strwrite(instrbuf,strlen(instrbuf)+1,I,hex[variantrec.h[j]]);
		end;
	  4: {W} immediate(wordsiz);
	  5: {D} begin
		 sappend(instrbuf,'#');
		 getinstrbytes(4);
		 variantrec.i1 := ext.longext;
		 getinstrbytes(4);
		 variantrec.i2 := ext.longext;
		 try
		   if variantrec.r > 0 then
		     strwrite(instrbuf,strlen(instrbuf)+1,i,variantrec.r:21)
		   else
		     strwrite(instrbuf,strlen(instrbuf)+1,i,variantrec.r:22)
		 recover
		   if escapecode = -18 { bad arg in real/BCD conversion} then
		     begin
		     sappend(instrbuf,'$');
		     for j := 1 to 16 do
		       strwrite(instrbuf,strlen(instrbuf)+1,i,hex[variantrec.h[j]]);
		     end
		   else
		     escape(escapecode);
		 end;
	  6: {B} immediate(bytesiz);
	  otherwise goto 2;
	end {case}
      else
	emitea(bytesiz);
      end;

    procedure dumpfregbits(reglist : byte; zfirst : boolean);
      type
	string1 = string[1];
      var
	variantrec : packed record case boolean of
		       true: (b: byte);
		       false:(a: packed array[0..7] of boolean);
		     end;
	regnum, bitnum, lastbit : integer;

      function makestring(c: char): string1;
	var
	  s: string1;
	begin
	setstrlen(s,1);
	s[1] := c;
	makestring := s;
	end;

      procedure hithit; forward;

      procedure hitmiss; forward;

      procedure hithithit;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then
	    hithithit
	  else
	    begin
	    sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum-1)));
	    hitmiss;
	    end
	else
	  sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum-1)));
	end;

      procedure misshit;
	begin
	sappend(instrbuf,'/fp' + makestring(chr(ord('0')+regnum)));
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then hithit
				  else hitmiss;
	end;

      procedure hitmiss;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then misshit
				  else hitmiss;
	end;

      procedure hithit;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if (bitnum = lastbit) then
	  begin
	  sappend(instrbuf,'-fp' + makestring(chr(ord('0')+regnum-1)));
	  end
	else if not variantrec.a[bitnum] then
	  begin
	  sappend(instrbuf,'-fp' + makestring(chr(ord('0')+regnum-1)));
	  hitmiss;
	  end
	else
	  begin
	  sappend(instrbuf,'-');
	  hithithit;
	  end;
	end;

      procedure firsthit;
	begin
	sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum)));
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then hithit
				  else hitmiss;
	end;

      procedure firstmiss;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then firsthit
				  else firstmiss;
	end;

      begin
      variantrec.b := reglist;
      if zfirst then
	begin
	bitnum := 0;
	lastbit := 8;
	end
      else
	begin
	bitnum := 7;
	lastbit := -1;
	end;
      regnum := 0;
      if variantrec.a[bitnum] then firsthit
			      else firstmiss;
      end;

    procedure appendfloatsize(size : integer);
      begin
      case size of
	0: sappend(instrbuf,'.l ');
	1: sappend(instrbuf,'.s ');
	2: sappend(instrbuf,'.x ');
	3,7: sappend(instrbuf,'.p ');
	4: sappend(instrbuf,'.w ');
	5: sappend(instrbuf,'.d ');
	6: sappend(instrbuf,'.b ');
	otherwise goto 2;
      end; {case}
      end;

    procedure appendfloatcondition(predicate : integer);
      begin
      case predicate of
	0:  sappend(instrbuf,'f');
	1:  sappend(instrbuf,'eq');
	2:  sappend(instrbuf,'ogt');
	3:  sappend(instrbuf,'oge');
	4:  sappend(instrbuf,'olt');
	5:  sappend(instrbuf,'ole');
	6:  sappend(instrbuf,'ogl');
	7:  sappend(instrbuf,'or');
	8:  sappend(instrbuf,'un');
	9:  sappend(instrbuf,'ueq');
	10: sappend(instrbuf,'ugt');
	11: sappend(instrbuf,'uge');
	12: sappend(instrbuf,'ult');
	13: sappend(instrbuf,'ule');
	14: sappend(instrbuf,'neq');
	15: sappend(instrbuf,'t');
	16: sappend(instrbuf,'sf');
	17: sappend(instrbuf,'seq');
	18: sappend(instrbuf,'gt');
	19: sappend(instrbuf,'ge');
	20: sappend(instrbuf,'lt');
	21: sappend(instrbuf,'le');
	22: sappend(instrbuf,'gl');
	23: sappend(instrbuf,'leg');
	24: sappend(instrbuf,'nleg');
	25: sappend(instrbuf,'ngl');
	26: sappend(instrbuf,'nle');
	27: sappend(instrbuf,'nlt');
	28: sappend(instrbuf,'nge');
	29: sappend(instrbuf,'ngt');
	30: sappend(instrbuf,'sne');
	31: sappend(instrbuf,'st');
	otherwise goto 2;
      end;
      end;

    begin { mc68881 }
    with instr do
      begin
      if opmode = 0 then
	begin
	getinstrbytes(2);
	if ext.fopclas >= 6 then { FMOVEM }
	  begin
	  instrbuf := 'fmovem ';
	  if ext.fopclas = 6 then { move to FP data registers }
	    begin
	    saveext := ext;
	    emitea(bytesiz);
	    comma;
	    if saveext.frx = 6 then { D reg }
	      emitdir(D,saveext.KDreg)
	    else if saveext.frx = 4 then { register mask }
	      dumpfregbits(saveext.ubyteext,true)
	    else goto 2;
	    end
	  else { move from FP data registers }
	    begin
	    if (ext.frx = 2) or (ext.frx = 6) then
	      emitdir(D,ext.KDreg)
	    else if (ext.frx = 0) or (ext.frx = 4) then
	      if ext.frx = 0 then dumpfregbits(ext.ubyteext,false)
			     else dumpfregbits(ext.ubyteext,true)
	    else goto 2;
	    comma;
	    emitea(bytesiz);
	    end;
	  end
	else if ext.fopclas >= 4 then { FMOVE sysreg }
	  begin
	  if ext.frx in [1,2,4] then
	    instrbuf := 'fmove '
	  else
	    instrbuf := 'fmovem ';
	  if ext.fopclas = 4 then { move to sysregs }
	    begin
	    saveext := ext;
	    emitea(longsiz);
	    case saveext.frx of
	      0: sappend(instrbuf,',-');
	      1: sappend(instrbuf,',fpiaddr');
	      2: sappend(instrbuf,',fpstatus');
	      3: sappend(instrbuf,',fpstatus/fpiaddr');
	      4: sappend(instrbuf,',fpcontrol');
	      5: sappend(instrbuf,',fpcontrol/fpiaddr');
	      6: sappend(instrbuf,',fpcontrol/fpstatus');
	      7: sappend(instrbuf,',fpcontrol/fpstatus/fpiaddr');
	    end; {case}
	    end
	  else { move from sysregs }
	    begin
	    case ext.frx of
	      0: escape(0);
	      1: sappend(instrbuf,'fpiaddr,');
	      2: sappend(instrbuf,'fpstatus,');
	      3: sappend(instrbuf,'fpstatus/fpiaddr,');
	      4: sappend(instrbuf,'fpcontrol,');
	      5: sappend(instrbuf,'fpcontrol/fpiaddr,');
	      6: sappend(instrbuf,'fpcontrol/fpstatus,');
	      7: sappend(instrbuf,'fpcontrol/fpstatus/fpiaddr,');
	    end; {case}
	    emitea(bytesiz);
	    end;
	  end
	else if (ext.fopclas = 2) and (ext.frx = 7) then { FMOVECR }
	  begin
	  instrbuf := 'fmovecr # ';
	  strwrite(instrbuf,strlen(instrbuf),I,ext.fextension:1,',');
	  emitfdir(ext.fry);
	  end
	else { general }
	  begin
	  case ext.fextension of
	    0: instrbuf := 'fmove';
	    1: instrbuf := 'fint';
	    2: instrbuf := 'fsinh';
	    3: instrbuf := 'fintrz';    (* LAF 861204 *)
	    4: instrbuf := 'fsqrt';
	    6: instrbuf := 'flognp1';
	    8: instrbuf := 'fetoxm1';
	    9: instrbuf := 'ftanh';
	    10:instrbuf := 'fatan';
	    12:instrbuf := 'fasin';
	    13:instrbuf := 'fatanh';
	    14:instrbuf := 'fsin';
	    15:instrbuf := 'ftan';
	    16:instrbuf := 'fetox';
	    17:instrbuf := 'ftwotox';
	    18:instrbuf := 'ftentox';
	    20:instrbuf := 'flogn';
	    21:instrbuf := 'flog10';
	    22:instrbuf := 'flog2';
	    24:instrbuf := 'fabs';
	    25:instrbuf := 'fcosh';
	    26:instrbuf := 'fneg';
	    28:instrbuf := 'facos';
	    29:instrbuf := 'fcos';
	    30:instrbuf := 'fgetexp';
	    31:instrbuf := 'fgetman';
	    32:instrbuf := 'fdiv';
	    33:instrbuf := 'fmod';
	    34:instrbuf := 'fadd';
	    35:instrbuf := 'fmul';
	    36:instrbuf := 'fsgldiv';
	    37:instrbuf := 'frem';
	    38:instrbuf := 'fscale';
	    39:instrbuf := 'fsglmul';
	    40:instrbuf := 'fsub';
	    48..55:instrbuf := 'fsincos';
	    56:instrbuf := 'fcmp';
	    58:instrbuf := 'ftst';
	    64:instrbuf := 'fsmove';  { JWH 12/21/89 }
	    65:instrbuf := 'fssqrt';  { JWH 12/21/89 }
	    68:instrbuf := 'fdmove';  { JWH 12/21/89 }
	    69:instrbuf := 'fdsqrt';  { JWH 12/21/89 }
	    88:instrbuf := 'fsabs';  { JWH 12/21/89 }
	    90:instrbuf := 'fsneg';  { JWH 12/21/89 }
	    92:instrbuf := 'fdabs';  { JWH 12/21/89 }
	    94:instrbuf := 'fdneg';  { JWH 12/21/89 }
	    96:instrbuf := 'fsdiv';  { JWH 12/21/89 }
	    98:instrbuf := 'fsadd';  { JWH 12/21/89 }
	    99:instrbuf := 'fsmul';  { JWH 12/21/89 }
	    100:instrbuf := 'fddiv';  { JWH 12/21/89 }
	    102:instrbuf := 'fdadd';  { JWH 12/21/89 }
	    103:instrbuf := 'fdmul';  { JWH 12/21/89 }
	    104:instrbuf := 'fssub';  { JWH 12/21/89 }
	    108:instrbuf := 'fdsub';  { JWH 12/21/89 }
	    otherwise ;
	  end; {case}
	  if ext.fopclas = 0 then { source is Freg }
	    begin
	    sappend(instrbuf,' ');
	    emitfdir(ext.frx);
	    if (ext.fextension = 58 {FTST}) or ((ext.frx = ext.fry) and
	       (ext.fextension <> 0 {FMOVE}) and (ext.fextension < 32)) then
	      { Do not display second op for FTST or "single op" instructions }
	    else
	      begin
	      comma;
	      if ext.fext = 6 then { FSINCOS }
		begin
		emitfdir(ext.sincosreg);
		sappend(instrbuf,':');
		end;
	      emitfdir(ext.fry);
	      end;
	    end
	  else if ext.fopclas = 2 then { source is <ea> }
	    begin
	    appendfloatsize(ext.frx);
	    saveext := ext;
	    emitfea(saveext.frx);
	    if  saveext.fextension <> 58 {FTST} then
	      begin
	      comma;
	      if saveext.fext = 6 then { FSINCOS }
		begin
		emitfdir(saveext.sincosreg);
		sappend(instrbuf,':');
		end;
	      emitfdir(saveext.fry);
	      end;
	    end
	  else if ext.fopclas = 3 then { dest is <ea> }
	    begin { FMOVE from MC68881 }
	    instrbuf := 'fmove';
	    appendfloatsize(ext.frx);
	    emitfdir(ext.fry);
	    comma;
	    saveext := ext;
	    emitea(bytesiz);
	    if saveext.frx = 3 {size P} then
	      strwrite(instrbuf,strlen(instrbuf)+1,I,'{#',saveext.Kfactor:1,'}')
	    else if saveext.frx = 7 {size P} then
	      strwrite(instrbuf,strlen(instrbuf)+1,I,'{d',saveext.KDreg:1,'}');
	    end
	  else goto 2;
	  end;
	end
      else
	case opmode of
	  1: { FScc, FDBcc, FTRAPcc }
	     begin
	     if eamode = 1 then
	       instrbuf := 'fdb'
	     else if (eamode = 7) and (eareg = 4) then
	       instrbuf := 'ftrap'      (* LAF 861204 *)
	     else if (eamode = 7) and ((eareg = 2) or (eareg = 3)) then
	       instrbuf := 'ftrap'      (* LAF 861204 *)
	     else
	       instrbuf := 'fs';
	     getinstrbytes(2);
	     appendfloatcondition(ext.ubyteext);
	     if eamode = 1 then
	       begin
	       if instrbuf = 'fdbf' then
		 instrbuf := 'fdbra '
	       else
		  sappend(instrbuf,' ');
	       emitdir(D,eareg);
	       comma;
	       extend(2,true,0);
	       end
	     else if (eamode = 7) and (eareg = 4) then
	       { FTcc }
	     else if (eamode = 7) and (eareg = 2) then
	       begin { FTPcc.W }
	       sappend(instrbuf,'.w ');
	       immediate(wordsiz);
	       end
	     else if (eamode = 7) and (eareg = 3) then
	       begin { FTPcc.L }
	       sappend(instrbuf,'.l ');
	       immediate(longsiz);
	       end
	     else
	       begin
	       sappend(instrbuf,' ');
	       emitea(bytesiz);
	       end;
	     end;
	  2,3: { Revearse assemble FBF *+2 as FNOP }
	       begin
	       moveleft(inbuf.stp^[codeindex],ext,2);
	       if (instr.fpredicate = 0) and (opmode = 2) and
		  (ext.wordext = 0) then
		 begin { FNOP }
		 instrbuf := 'fnop';
		 getinstrbytes(2);
		 end
	       else
		 begin { FBcc }
		 if instr.fpredicate = 15 {FBT} then
		   instrbuf := 'fbra'
		 else
		   begin
		   instrbuf := 'fb';
		   appendfloatcondition(instr.fpredicate);
		   end;
		 if opmode = 3 then
		   begin
		   sappend(instrbuf,'.l ');
		   extend(4,true,0);
		   end
		 else
		   begin
		   sappend(instrbuf,' ');
		   extend(2,true,0);
		   end;
		 end;
	       end;
	  4,5: { FSAVE, FRESTORE }
	       begin
	       if opmode = 4 then
		 instrbuf := 'fsave '
	       else
		 instrbuf := 'frestore ';
	       emitea(bytesiz);
	       end;
	  otherwise goto 2;
	end {case};
      end {with instr};
    end; { mc68881 }

  { Added 12/22/89 JWH : }

  procedure move16; { Handle the '040 move16 instruction }
  LABEL 1;
  type move16_type =
	packed record
	  case integer of
	    1: (the_op : byte;
		which : 0..7;
		mode_16 : 0..3;
		reg_ax : regrange);
	    2: (w : shortint);
	end; { move16_type }
   type my_type = packed record
      case integer of
      1: ( nib1,nib2 : 0..15;
	byte_it : byte) ;
      2: (w : shortint);
     end; { my_type }
    var see_it : move16_type;
    var see_ex : my_type;
    begin
      { So far we've seen first 7 bits of instruction }
      see_it.w := instr.w; { see it as a move16 }
      instrbuf := 'move16 ';
      with see_it do
       begin
	if the_op <> 246 { hex('F6') } then
	  begin defineword; goto 1; end; { First 8 bits }
	if which > 1 then
	  begin defineword; goto 1; end; { First 11 bits }
	if which = 1 then { have post increment format }
	 begin
	  if mode_16 <> 0 then { gotta be for this format }
	     begin defineword; goto 1; end; { First 13 bits }
	  getinstrbytes(2);
	  if ext.exDAbit1 <> 1  then
	     begin defineword; goto 1; end; { First 17 bits }
	  see_ex.w := ext.wordext;
	  if ((see_ex.nib2 <> 0) or (see_ex.byte_it <> 0))  then
	     begin defineword; goto 1; end; { First 32 bits }
	  { Have a valid move16 of this format if we get this far }
	  emitpostincr(reg_ax);
	  comma;
	  emitpostincr(ext.exRn1);
	 end { which = 1 , post increment format }
	else  { which = 0, have absolute format }
	 begin
	  { Have a valid move16 of this format if we get here. }
	   case mode_16 of
	    0 : begin emitpostincr(reg_ax); comma; extend(4,false,0); end;
	    1 : begin extend(4,false,0); comma; emitpostincr(reg_ax); end;
	    2 : begin emitardef(reg_ax); comma; extend(4,false,0); end;
	    3 : begin extend(4,false,0); comma; emitardef(reg_ax); end;
	    otherwise ; { this really can't happen }
	   end; { case }
	 end; { which = 0, absolute format }
       end; { with see_it }
    1: end; { move16 }

    { Added 12/22/89 JWH : }


  procedure cinv_cpush; { Handle '040 CINV and CPUSH instructions }
  LABEL 1;
  type cache_40_type =
	packed record
	  case integer of
	    1: (the_op : byte;
		which_caches : 0..3;
		which_instr : 0..1;
		scope : 0..3;
		reg_ax : regrange);
	    2: (w : shortint);
	end; { cache_40_type }
    var see_it : cache_40_type;
    begin
    { Have seen the first seven bits of the instruction }
     see_it.w := instr.w; { see it as a cinv or cpush }
     with see_it do
      begin
       if the_op <> 244 { hex('F4') } then
	  begin defineword; goto 1; end; { Seen 8 bits now }
       if which_instr = 0 then
	begin { CINV }
	 case scope of
	  0 : begin defineword; goto 1; end; { ILLEGAL }
	  1 : instrbuf := 'cinvl ';
	  2 : instrbuf := 'cinvp ';
	  3 : instrbuf := 'cinva ';
	  otherwise ;
	 end; { case }
	 case which_caches of
	  0 : strappend(instrbuf,'NONE');  { NOOP, NOT ILLEGAL }
	  1 : strappend(instrbuf,'DC');
	  2 : strappend(instrbuf,'IC');
	  3 : strappend(instrbuf,'DC/IC');
	  otherwise ;
	 end; { case }
	 if ((scope = 1) or (scope = 2)) then { CINVL or CINVP .. }
	  begin { get the reg ... }
	    comma; emitardef(reg_ax);
	  end; { CINVL or CINVP }
	end { CINV }
       else
	begin { CPUSH }
	 case scope of
	  0 : begin defineword; goto 1; end; { ILLEGAL }
	  1 : instrbuf := 'cpushl ';
	  2 : instrbuf := 'cpushp ';
	  3 : instrbuf := 'cpusha ';
	  otherwise ;
	 end; { case }
	 case which_caches of
	  0 : strappend(instrbuf,'NONE'); { NOOP, NOT ILLEGAL }
	  1 : strappend(instrbuf,'DC');
	  2 : strappend(instrbuf,'IC');
	  3 : strappend(instrbuf,'DC/IC');
	  otherwise ;
	 end; { case }
	 if ((scope = 1) or (scope = 2)) then { CPUSHL or CPUSHP .. }
	  begin { get the register ... }
	    comma; emitardef(reg_ax);
	  end; { CPUSHL or CPUSHP }
	end; { CPUSH }
      end; { with see_it }
      1 :
    end; { cinv_cpush }

  begin {decode}
    with instr do
      case opcode of
	0: opcode0;
	1,2,3: move;
	4: opcode4;
	5: if size = invalid then
	     begin
	     if eamode = 1 then
	       begin
	       instrbuf := 'db';
	       if cond = 1 then sappend(instrbuf,'ra')
	       else sappend(instrbuf,condcode[cond]);
	       space; emitdir(D, eareg);
	       comma; extend(2,true,0);
	       end
	     else if (eamode < 7) or ((eamode = 7) and (eareg <= 1)) then
	       begin
	       instrbuf := 's';
	       sappend(instrbuf,condcode[cond]);
	       space; emitea(bytesiz {invalid});
	       end
	     else { trapcc }
	       begin
	       case cond of
		 0: instrbuf := 'trapt';
		 1: instrbuf := 'trapf';
		 2: instrbuf := 'traphi';
		 3: instrbuf := 'trapls';
		 4: instrbuf := 'trapcc';
		 5: instrbuf := 'trapcs';
		 6: instrbuf := 'trapne';
		 7: instrbuf := 'trapeq';
		 8: instrbuf := 'trapvc';
		 9: instrbuf := 'trapvs';
		 10:instrbuf := 'trappl';
		 11:instrbuf := 'trapmi';
		 12:instrbuf := 'trapge';
		 13:instrbuf := 'traplt';
		 14:instrbuf := 'trapgt';
		 15:instrbuf := 'traple';
	       end;
	       if eareg = 2 then { .w }
		 begin
		 sappend(instrbuf,'.w ');
		 immediate(wordsiz);
		 end
	       else if eareg = 3 then { .l }
		 begin
		 sappend(instrbuf,'.l ');
		 immediate(longsiz);
		 end;
	       end;
	     end
	   else
	     begin
	     if bit8 then instrbuf := 'subq'
	     else instrbuf := 'addq';
	     osize; quick;
	     emitea(size {invalid});
	     end;
	6: begin instrbuf := 'b';
	     if cond = 0 then sappend(instrbuf,'ra')
	     else if cond = 1 then sappend(instrbuf,'sr')
			      else sappend(instrbuf,condcode[cond]);

	     if displ = -1 then { 32 bit displ }
	       begin
	       sappend(instrbuf,'.l ');
	       extend(4,true,0);
	       end
	     else if displ = 0 then
	       begin
	       sappend(instrbuf,'.w ');
	       extend(2,true,0);
	       end
	     else
	       begin sappend(instrbuf,'.s ');
	       ext.longext := pc + 2 + displ;
	       tempint := ext.longext;
	       gvrstring(nilgvr,tempint,true,false);
	       sappend(instrbuf,gvaluestring);
	       end;
	   end;
	7: begin instrbuf := 'moveq ';
	     emitimm(displ); comma;
	     emitdir(D,reg1);
	   end;



8,9,11,12,13: begin
	   instrbuf := arithop[opcode];
	   if size=invalid then
	    begin
	    if odd(opcode) then
	     begin
	     sappend(instrbuf,'a');
	     if bit8 then
		  begin
		  sappend(instrbuf, opsize[longsiz]);
		  emitea(longsiz);
		  end
	     else begin
		  sappend(instrbuf,opsize[wordsiz]);
		  emitea(wordsiz);
		  end;
	     comma; emitdir(A,reg1);
	     end
	    else
	     begin
	     if opcode = 8 then instrbuf := 'div'
			   else instrbuf := 'mul';
	     if bit8 then sappend(instrbuf,'s ')
		     else sappend(instrbuf,'u ');
	     emitea(wordsiz); comma; emitdir(D,reg1);
	     end
	    end
	   else if (not bit8) or (eamode > 1) or (opcode = 11) then
	     begin
	     if opcode = 11 then
	      if bit8 then
	       if eamode = 1 then
		 begin
		 sappend(instrbuf,'m'); osize;
		 emitpostincr(eareg); comma; emitpostincr(reg1);
		 goto 1;
		 end
	       else instrbuf := 'eor';
	     osize;
	     if bit8 then begin emitdir(D,reg1); comma; emitea(size);
			  end
		     else begin emitea(size); comma; emitdir(D,reg1);
			  end;
	     end
	   else
	     begin
	     if odd(opcode) then begin sappend(instrbuf,'x'); osize; end
	     else if opcode = 8 then
	       if size = bytesiz then instrbuf := 'sbcd '
	       else if size = wordsiz then instrbuf := 'pack '
	       else { size = longsiz }     instrbuf := 'unpk '
	     else if size = bytesiz then instrbuf := 'abcd '
	     else begin
		  instrbuf := 'exg ';
		  if eamode = 0 then
		    begin emitdir(D,reg1); comma; emitdir(D,eareg) end
		  else if opmode = 5 then
		    begin emitdir(A,reg1); comma; emitdir(A,eareg) end
		  else
		    begin emitdir(D,reg1); comma; emitdir(A,eareg) end;
		  goto 1;
		  end;
	     if eamode = 0 then
		  begin emitdir(D,eareg); comma; emitdir(D,reg1);
		  end
	     else begin emitpredecr(eareg); comma; emitpredecr(reg1);
		  end;
	     if (opcode = 8) and (size >= wordsiz) then { pack unpk }
	       begin
	       comma;
	       immediate(wordsiz);
	       end;
	     end;
	   end;
       14:
	 if (ord(size) = 3) and (reg1 >= 4) then { bit field op }
	   begin
	   case cond of
	     8: instrbuf := 'bftst ';
	     9: instrbuf := 'bfextu ';
	     10: instrbuf := 'bfchg ';
	     11: instrbuf := 'bfexts ';
	     12: instrbuf := 'bfclr ';
	     13: instrbuf := 'bfffo ';
	     14: instrbuf := 'bfset ';
	     15: instrbuf := 'bfins ';
	   end;
	   getinstrbytes(2);
	   bf_reg := ext.bf_reg;
	   bf_Do := ext.bf_Do;
	   bf_offset := ext.bf_offset;
	   bf_Dw := ext.bf_Dw;
	   bf_width := ext.bf_width;
	   if cond = 15 then
	     begin
	     emitdir(D,bf_reg);
	     comma;
	     end;
	   emitea(bytesiz);
	   sappend(instrbuf,'{');
	   if bf_Do then
	     sappend(instrbuf,'d');
	   strwrite(instrbuf,strlen(instrbuf)+1,I,bf_offset:1);
	   sappend(instrbuf,':');
	   if bf_Dw then
	     strwrite(instrbuf,strlen(instrbuf)+1,I,'d',bf_width:1)
	   else
	     begin
	     if bf_width = 0 then
	       bf_width := 32;
	     strwrite(instrbuf,strlen(instrbuf)+1,I,bf_width:1);
	     end;
	   sappend(instrbuf,'}');
	   if cond in [9,11,13] then
	     begin
	     comma;
	     emitdir(D,bf_reg);
	     end;
	   end
	 else
	   shift;
	 15: if reg1 = 1 then mc68881
	      { Next two lines JWH 12/22/89 : }
	      else if reg1 = 2 then cinv_cpush
	      else if ((reg1 = 3) and (instr.opmode = 0)) then move16
	     else goto 2;
	otherwise goto 2;
	end; {case}
       goto 1;
      2: begin defineword;
	   if decodestate <> abscode then decodestate := consts;
	 end;
    1: end; {decode}

  procedure definecaseword;
  var savepc: integer;
  begin
  instrsize := 0;
  instrbuf := 'case jump   ';
  savepc := pc; pc := tablepc;
  extend(2, true,0);
  pc := savepc;
  end;

  procedure decodestuff;
  label 1;
  var temp: integer;

    procedure printprocboundary;
    label 1;
    var  defaddr,deflimit,len,gvrbase: integer;
	 veloc:  addrec;
    begin
      defaddr:=newmods^.defaddr.a;
      deflimit:=defaddr+newmods^.defsize;
      while defaddr < deflimit do
	begin
	  len:=strlen(symbolptr(defaddr)^);
	  len:=len+2-ord(odd(len));
	  gvrbase:=defaddr+len;
	  with gvrptr(gvrbase)^ do
	    if primarytype = loadgvr^.primarytype then
	      begin
	      veloc.a:=gvrbase+sizeof(generalvalue,false);
	      if veloc.vep^.value = PC then goto 1;
	      end;
	  defaddr:=defaddr+len+ord(symtableptr(defaddr)^[len+1]);
	end;
	listln;
1:    list;
      if MODULEPC = PC then write(listing,'- * module body * -')
		       else write(listing,'- - - - - - - - - -');
      write(listing,' - - - - - - - - - - - - - - - -  ');
      if defaddr < deflimit then
	write(listing,symbolptr(defaddr)^);
      writeln(listing);
    end; {printprocboundary}

  begin {decodestuff}
 1: case decodestate of
      consts:
	  begin getinstruction;
	    if (PC=MODULEPC)  { MODULE BODY ADDRESS } then
		begin decodestate := code; decode;
		 if (rangetype = norange) or
		    ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
		    ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange))
		    then printprocboundary;
		end
	    else { check for dc.w even,0 or 1}
	       if (not odd(instr.lb) and (instr.rb<2)) then
	       begin defineword; decodestate := phdr; end

	    else if (instr.w = 20217) {JMP long abs}
	     or (instr.w = 24576) {BRA 16 bit} then
	      decode
	    else defineword;
	  end;
      phdr:begin getinstruction;
	     if (instr.w = 20054) {LINK A6}
	       or (instr.w = 18446) {LINK.L A6}
	       or (instr.w = 20033) {TRAP #1}
	       or (PC=MODULEPC) {MODULE BODY ADDRESS } then
		begin decodestate := code; decode;
		 if (rangetype = norange) or
		    ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
		    ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange))
		    then printprocboundary;
		end
	      else if (instr.w = 20217) {JMP long abs}
		      or (instr.w = 24576) {BRA 16 bit} then
		      begin decode; decodestate:=consts; end
		   else
		   begin defineword;
		     if not (not odd(instr.lb) and (instr.rb<2)) then decodestate := consts;
		   end;
	   end;

abscode,
      code:     begin
		getinstruction;
		decode;
		if decodestate <> abscode then
		  if instr.w = 20062 {UNLK A6} then decodestate := endofproc
		  else if instr.w = 20219 {JMP pc indexed} then
		    begin oldstate := code; decodestate := startcase end;
		end;
      startcase:
	begin
	  tablePC := PC;
	  definecaseword;
	  casecodestart:=ext.wordext+PC;
	  decodestate := casetable;
	end;
      casetable:
	begin
	  if PC = casecodestart
	  then begin decodestate := oldstate; goto 1 end
	  else
	    begin definecaseword;
	      if not fortranflag then
		begin
		  temp:=ext.wordext+tablePC;
		  if temp<casecodestart then casecodestart := temp;
		end;
	    end;
	end;
      endofproc:
	begin getinstruction; decode;
	  if (instr.w = 20085 {RTS} )
	      or (instr.w div 8 = 2522 {JMP (An)} ) then
	    decodestate := consts;
	end;
      end; {case}
  end; {decodestuff}

begin {listinstruction}
  decodestuff;
  bytesleft := instrsize; firstline := true;
  if (rangetype = norange) or
     ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
     ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange)) then
   repeat
    list;
    if firstline then write(listing,PC:8,' ')

    else write(listing,'':9  {17}  );
    printinstrword;
    if bytesleft>0 then printinstrword
    else
      if firstline then write(listing,'':5);
    if firstline then
      begin writeln(listing,'':9,instrbuf); firstline := false end
    else writeln(listing);
   until bytesleft = 0;
  PC:=PC + instrsize;
end; {listinstruction}

procedure getcodeblocks;
var junkint: integer;
    pclimit: integer;
    textstep: addrec;
    textrecctr: {shortint} INTEGER {SFB};
begin
 with newmods^,directory.drp^ do
   begin
   textstep.a:=directory.a+sizeof(moduledirectory);
   junkint:=strlen(textstep.syp^);
   textstep.a := textstep.a+junkint+2-ord(odd(junkint));
   if executable then textstep.a := textstep.a + textstep.gvp^.short;
   textrecctr:=textrecords;
   while textrecctr > 0 do with textstep.tdp^ do
     begin
     textrecctr:=textrecctr-1;
     list; writeln(listing,'TEXT RECORD #',
     textrecords-textrecctr, '  of ''', fdirectory^[vmodnum].dtid, ''':');
     list; writeln(listing,'  TEXT start block ',textstart:4,
		      '       Size ',textsize,' bytes');
     list; writeln(listing,'  REF  start block ',refstart:4,
		      '       Size ',refsize,' bytes');
     textstep.a :=textstep.a+sizeof(textdescriptor);
     PC := 0;
     loadgvr := textstep.gvp;
     gvrstring(textstep.gvp,PC,false,false);
     gbytes(inbuf.a,textsize);
     readblocks(filefib.fbp^, inbuf.p^,textsize,fileblock+textstart);
     codeindex:=0;  codecount:=textsize;
     gbytes(refptr.a,refsize);
     readblocks(filefib.fbp^,refptr.p^,refsize,fileblock+refstart);

     refgvr:=refptr;
     reflim:=refptr.a+refsize;
     refloc:=PC;        nextref;
     pclimit := PC + textsize;

     list; writeln(listing,'  LOAD address     ',gvaluestring);
     listln;
     while PC < pclimit do listinstruction;
     listln; listln;
     lowheap := inbuf;
     end;
   end; {with newmods^,directory^}
end; {getcodeblocks}

procedure listdefs;
var
  len,val:      integer;
  lim,p1:       addrec;
begin
prepunassem;
with newmods^ do
  begin
  list; writeln(listing,'  DEF table of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  p1 := defaddr;
  lim.a := p1.a + defsize;
  while p1.a < lim.a do
    begin
    len:=strlen(p1.syp^);
    list; write(listing,'':5,p1.syp^,'':(30-len));
    p1.a := p1.a + len+2-ord(odd(len));
    val := 0;
    gvrstring(p1.gvp,val,false,false);
    writeln(listing,gvaluestring);
    end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure listexts;
var
  i:            integer;
  p1:           addrec;
begin
prepunassem;
with newmods^ do
  begin
  list; writeln(listing,'  EXT table of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  for i:=2 to listsize-1 do if listaddr^[i] <> 0 then
    begin
      p1.a := extaddr.a + listaddr^[i];
      list; writeln(listing,'':5,p1.syp^);
    end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure listtext;
const pagesize = pageblocks * blocksize;
var
  textbuf,ptr:  addrec;
  i,j,pages:    integer;
  readsize:     integer;
  linestart:    boolean;

  procedure dochar(c: char);
  begin
  if linestart then list;
  linestart := (c = eol);
  if linestart then writeln(listing) else write(listing, c);
end;

begin
prepunassem;
gbytes(textbuf.a, pagesize);
with newmods^, directory.drp^ do
  begin
  list; writeln(listing,'  DEFINE SOURCE of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  pages := (sourcesize + (pagesize-1)) div pagesize;
  for i := 0 to pages-1 do
   begin
   readsize := sourcesize - i*pagesize;                         { scs 1/17/83 }
   if readsize > pagesize then readsize := pagesize;            { scs 1/17/83 }
   readblocks(filefib.fbp^,textbuf.p^,readsize,                 { scs 1/17/83 }
					   fileblock+sourceblock+i*pageblocks);
   ptr := textbuf;      linestart := true;
   repeat
     case ptr.cp^ of
       chr(etx),
       nullchar:  ptr.a := textbuf.a + pagesize;
      otherwise dochar(ptr.cp^);
      end;
     ptr.a := ptr.a + 1;
   until ptr.a >= textbuf.a + pagesize;
   if not linestart then dochar(eol);
   end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure disassemble;
begin
prepunassem;
nilgvr := NIL;
getcodeblocks;
newmods := modsave;
lowheap := infost;
end;

procedure getbounds;
begin
  lastline := -1;
  fgotoxy(output, 0,13);
  write('lower bound? ');
  if readint(lowrange) then
       begin
       write('upper bound? ');
       if not readint(highrange) then
	  highrange := maxint;
       end
  else begin
       lowrange := minint;
       highrange := maxint;
       end;
end;

begin {unassemble}
  fortranflag := false;
  decodestate := notype;        dumped := false;
  repeat
    fgotoxy(output, 0,2);
    writeln('Q  Quit',cteos);
    writeln('S  Stop unassembling');
    writeln('T  print import Text');
    writeln('E  print Ext table');
    writeln('D  print Def table');
    writeln('A  unassemble all (Assembler conventions)');
    writeln('C  unassemble all (Compiler  conventions)');
    writeln('P  PC   range     (Assembler conventions)');
    writeln('L  Line range     (Compiler  conventions)', cteos);
    getcommandchar('unassemble option?',commandchar);
    if commandchar <> ' ' then
     case commandchar of
      'S':  decodestate := quittype;
      'Q':  begin
	    decodestate := quittype;
	    quit;
	    end;
      'A':  begin rangetype := norange; decodestate := abscode; disassemble; end;
      'C':  begin rangetype := norange; decodestate := consts; disassemble; end;
      'P':  begin rangetype := pcrange; decodestate := abscode; getbounds; disassemble; end;
      'L':  begin rangetype := linerange; decodestate := consts; getbounds; disassemble; end;
      'T':  listtext;
      'D':  listdefs;
      'E':  listexts;
      otherwise dobeep;
      end;
  until decodestate = quittype;
end; {unassemble}


procedure makenewgvr(var oldptr: addrec;
			   modptr: moddescptr);

var  refsize:   shortint;
     lastptr,
     firstptr,
     vptr,
     gptr:      addrec;

  procedure runlist(var oldptr: addrec; modptr: moddescptr; sub: boolean);
  var done:     boolean;
      defptr:   addrec;

    procedure addref(add: shortint; sub: boolean);
    var iptr,jptr,tp:   addrec;
	notdone,
	notcancels:     boolean;
    begin
    if add = 0 then
      if sub then vptr.vep^.value  := vptr.vep^.value - modptr^.relocdelta
	     else vptr.vep^.value  := vptr.vep^.value + modptr^.relocdelta
    else if add = 1 then
      if sub then vptr.vep^.value  := vptr.vep^.value - modptr^.globaldelta
	     else vptr.vep^.value  := vptr.vep^.value + modptr^.globaldelta;

    iptr := lastptr; notdone := true; notcancels := true;
    while (iptr.a > firstptr.a) and notdone do
      begin
      iptr.a := iptr.a - sizeof(referenceptr);
      with iptr.rpp^ do
	if adr <= add then
	  begin
	  if adr = add then notcancels := (op = subit) = sub;
	  iptr.a := iptr.a + sizeof(referenceptr);
	  notdone := false;
	  end;
      end;

    if notcancels then
      begin
      gbytes(jptr.a, sizeof(referenceptr));
      lastptr := lowheap;
      while jptr.a > iptr.a do
	begin
	tp.a := jptr.a - sizeof(referenceptr);
	jptr.rpp^ := tp.rpp^;
	jptr := tp;
	end;
      with iptr.rpp^ do
	begin adr := add; last := false;
	if sub then op := subit else op := addit;
	end;
      end
    else
      begin
      tp.a := iptr.a - sizeof(referenceptr);
      while iptr.a < lastptr.a do
	begin
	tp.rpp^ := iptr.rpp^;
	tp := iptr;
	iptr.a := iptr.a + sizeof(referenceptr);
	end;
      lastptr.a := lastptr.a - sizeof(referenceptr);
      lowheap := lastptr;
      end;
    end;

  begin {runlist}
  with oldptr.gvp^ do
    begin
    if longoffset then oldptr.a := oldptr.a+sizeof(generalvalue, true)
			else oldptr.a := oldptr.a+sizeof(generalvalue, false);
    if valueextend then
      begin
      if sub then vptr.vep^.value := vptr.vep^.value - oldptr.vep^.value
	     else vptr.vep^.value := vptr.vep^.value + oldptr.vep^.value;
      oldptr.a := oldptr.a + sizeof(valueextension, sint);
      end;
    if primarytype <> absolute then
      begin
      if modptr = NIL then
	begin
	modptr := newmods;      done := false;
	repeat
	with modptr^ do
	  if patchmod then modptr := link
	  else if oldptr.a < defaddr.a then modptr := link
	  else if oldptr.a > defaddr.a + defsize then modptr := link
	  else done := true;
	until done;
	end;
      case primarytype of
       relocatable:      addref(0, sub);
       global:           addref(1, sub);
       general:
	begin
	done := false;
	repeat with oldptr.rpp^ do
	  begin
	  defptr := modptr^.extaddr.ptp^[adr];
	  if modptr^.unresbits.bmp^[adr] then
	    addref(defptr.rp.adr, sub <> (op = subit))
	  else
	    begin
	    defptr.a := defptr.a + strlen(defptr.syp^) + 2
		     - ord(odd(strlen(defptr.syp^)));
	    runlist(defptr, NIL, sub <> (op = subit));
	    end;
	  oldptr.a := oldptr.a + sizeof(referenceptr);
	  done := last;
	  end;
	until done;
	end; {general}
       end; {case}
      end; {primarytype <> absolute}
    end; {with}
  end; {runlist}

begin {makenewgvr}
  gbytes(gptr.a, sizeof(generalvalue));
  gptr.gvp^ := oldptr.gvp^;
  with gptr.gvp^ do
    begin
    if not longoffset then
      lowheap.a := lowheap.a -
      (sizeof(generalvalue) - sizeof(generalvalue, false));
    gbytes(vptr.a, sizeof(valueextension, sint));
    vptr.vep^.value := 0;
    valueextend := true;
    end;

  firstptr := lowheap;  lastptr := firstptr;

  runlist(oldptr, modptr, false);
  with gptr.gvp^ do
    begin
    refsize := lastptr.a - firstptr.a;
    if refsize = 0 then primarytype := absolute
    else
      begin
      if refsize = sizeof(referenceptr) then with firstptr.rpp^ do
	if adr <= 1 then if op = addit then
	  begin
	  if adr = 0 then primarytype := relocatable
		     else primarytype := global;
	  lastptr := firstptr;
	  lowheap := lastptr;
	  refsize := 0;
	  end;
      if refsize > 0 then
	begin
	firstptr.a := lastptr.a - sizeof(referenceptr);
	firstptr.rpp^.last := true;
	end;
      end;
    short := lastptr.a - gptr.a;        {even if it is long variety}
    end;
end;


procedure compressgvr(gvptr: addrec);
var vptr:   addrec;
begin
with gvptr.gvp^ do if valueextend then
  begin
  if longoffset then vptr.a := gvptr.a + sizeof(generalvalue, true)
		else vptr.a := gvptr.a + sizeof(generalvalue, false);
  with vptr.vep^ do
   if value = 0 then
    begin
    lowheap.a := lowheap.a - sizeof(valueextension, sint);
    fastmove(point(vptr.a + sizeof(valueextension, sint)), vptr.p,
	     lowheap.a - vptr.a);
    valueextend := false; short := short - sizeof(valueextension, sint);
    end;
  end;
end;

procedure rsolve;
var modptr, lastptr, nextptr: moddescptr;
    mrbase,mgbase:    integer;
    sp:         addrec;
    len:        shortint;
    i:          shortint;

begin
  modptr := newmods; lastptr := NIL; {reverse the pointers}
  while modptr <> NIL do with modptr^ do
    begin nextptr := link;      link := lastptr;
	  lastptr := modptr;    modptr := nextptr;
    end;
  newmods := lastptr;

  startgvr.p := NIL;    startgvrmod := NIL;
  modptr := newmods;    totalpatchspace := 0;
  forwardpatches:=NIL;  backwardpatches:=NIL;
  mrbase := startreloc; mgbase := startglobal;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      patchbase := mrbase;
      mrbase := mrbase + patchsize;
      totalpatchspace := totalpatchspace + patchsize;
      if forwardpatches = NIL then forwardpatches := modptr
      else lastptr^.patchlink := modptr;
      lastptr := modptr;
      end
    else with directory.drp^ do
      begin
      relocbase := mrbase;    relocdelta :=  mrbase - relocatablebase;
      mrbase := mrbase + relocatablesize + ord(odd(relocatablesize));
      globase := mgbase;      globaldelta := mgbase - globalbase;
      mgbase := mgbase - globalsize      - ord(odd(globalsize));

      gbytes(unresbits.a, ((extsize div 4 + 15) div 16)*2);
      for i := 2 to extsize div 4 - 1 do unresbits.bmp^[i] := false;
      unresbits.bmp^[0] := true;        unresbits.bmp^[1] := true;
      extaddr.ptp^[0].rp.w := 0;
      extaddr.ptp^[1].rp.w := 4;

      sp := directory;
      sp.a := sp.a+sizeof(moduledirectory);

      if newmodname.syp = NIL then newmodname := sp;
      if startgvr.p = NIL then
	if executable then
	  begin
	  startgvrmod := modptr;
	  startgvr.a := sp.a+strlen(sp.syp^)+2-ord(odd(strlen(sp.syp^)));
	  end;
      end;
    modptr := link;
    end;
  totalreloc :=  mrbase - startreloc;
  totalglobal := startglobal - mgbase;

end; {rsolve}


procedure mergeexts;

var ilist:      addrec;
    slist:      sortlistptr;
    sptr:       addrec;
    listlen:    shortint;
    sortlen:    shortint;
    minindex:   shortint;
    modptr:     moddescptr;
    len,
    i:          integer;
    done:       boolean;
    strptr,
    newstrptr:  addrec;

begin
  slist := lowheap.slp;  listlen := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if not patchmod then if not resolved then
      begin
      listlen := listlen + 1;
      gbytes(sptr.a, sizeof(sortdesc));
      with sptr.sdp^ do
	begin
	modp := modptr;
	N := 0;
	end;
      end;
    modptr := link;
    end;

  gbytes(ilist.a, listlen * sizeof(shortint));
  for i := 1 to listlen do ilist.ilp^[i] := i-1;
  sortlen := listlen;
  gbytes(newexttable, 8);
  newextsize := 8;

  while listlen > 0 do
    begin
    while sortlen > 0 do with slist^[ilist.ilp^[sortlen]], modp^ do
      begin
      done := false;
      repeat
       if N >= listsize then
	 begin
	 listlen := listlen - 1;
	 for i := sortlen to listlen do ilist.ilp^[i] := ilist.ilp^[i+1];
	 done := true;
	 end
       else if listaddr^[N] = 0 then N := N + 1
       else
	 begin
	 ext := symbolptr(extaddr.a + listaddr^[N]);
	 i := sortlen;  minindex := ilist.ilp^[i];
	 repeat
	   if i >= listlen then done := true
	   else if ext^ <= slist^[ilist.ilp^[i+1]].ext^ then done := true
	   else begin ilist.ilp^[i] := ilist.ilp^[i+1]; i := i + 1; end;
	 until done;
	 ilist.ilp^[i] := minindex;
	 end;
      until done;
      sortlen := sortlen - 1;
      end;
    if listlen > 0 then
      begin
      strptr.syp := slist^[ilist.ilp^[1]].ext;
      len := strlen(strptr.syp^) + 4 - strlen(strptr.syp^) mod 4;
      gbytes(newstrptr.a, len);
      fastmove(strptr.p, newstrptr.p, len);
      i := 1; done := false;
      repeat with slist^[ilist.ilp^[i]], modp^ do
	if ext^ = newstrptr.syp^ then
	  begin
	  wordrecptr(ext)^.w := newextsize;
	  unresbits.bmp^[listaddr^[N] div 4] := true;
	  N := N + 1;
	  i := i + 1; done := i > listlen;
	  end
	else done := true;
      until done;
      sortlen := i-1;
      newextsize := newextsize + len;
      end;
    end;

  if newextsize <= 8 then newextsize := 0;

end;

function gvrequal(a,b: addrec; offset: integer): boolean;
var      boff,
	 aoff:  integer;
	 b0:    gvrptr;
begin
gvrequal := false;
b0 := b.gvp;
with a.gvp^ do
  if primarytype = b0^.primarytype then
    begin
    if longoffset     then a.a := a.a + 4
		      else a.a := a.a + 2;
    if b0^.longoffset then b.a := b.a + 4
		      else b.a := b.a + 2;
    if valueextend then
      begin
      aoff := a.vep^.value;
      a.a := a.a + sizeof(valueextension, sint);
      end
    else aoff := 0;
    if b0^.valueextend then
      begin
      boff := b.vep^.value;
      b.a := b.a + sizeof(valueextension, sint);
      end
    else boff := 0;
    if aoff + offset = boff then
      if primarytype = general then
	begin
	while (a.rpp^.w
		   = b.rpp^.w)
	      and (a.rpp^.last = false) do
	  begin
	  a.a := a.a + sizeof(referenceptr);
	  b.a :=  b.a + sizeof(referenceptr);
	  end;
	gvrequal := a.rpp^.w = b.rpp^.w;
	end
      else gvrequal := true;
    end;
end;

procedure makedir;

var  modptr:            moddescptr;
     newtextrec,
     lasttextrec:       addrec;
     len:               shortint;
     extblocks,
     newtextrecs,
     movebytes,
     textrecs :         integer;
     index,
     newptr:            address;
     tempdirptr,
     oldindex,
     oldptr,
     ptr:               addrec;


  procedure mergetext;
  var  merged:  boolean;
       lastptr,
       newptr:  addrec;
  begin
   if newtextrec.tdp^.textsize = 0 then lowheap := newtextrec
   else
    begin
    if lasttextrec.tdp <> NIL then
      begin
      lastptr.a := lasttextrec.a + sizeof(textdescriptor);
      newptr.a  := newtextrec.a  + sizeof(textdescriptor);
      merged := gvrequal(lastptr, newptr, lasttextrec.tdp^.textsize );
      end
    else merged := false;

    if merged then
      begin
      lasttextrec.tdp^.textsize := lasttextrec.tdp^.textsize + newtextrec.tdp^.textsize;
      lowheap := newtextrec;
      end
    else
      begin newtextrecs := newtextrecs + 1;
      lasttextrec := newtextrec;
      end;
    end;
  end;

begin {makedir}
  gbytes(tempdirptr.a, sizeof(moduledirectory));
  if newmodname.syp=NIL then
    begin gbytes(newmodname.a, 2);
    newmodname.syp^ := '';
    end
  else
    begin
    len := strlen(newmodname.syp^) + 2 - ord(odd(strlen(newmodname.syp^)));
    gbytes(index, len);
    fastmove(newmodname.p, point(index), len);
    end;

  if startgvr.p<>NIL then
    begin
    oldptr := startgvr;
    ptr := lowheap;     makenewgvr(oldptr, startgvrmod);
    compressgvr(ptr);
    end;

  lasttextrec.tdp := NIL;
  newtextrecs := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      gbytes(newtextrec.a, sizeof(textdescriptor));
      newtextrec.tdp^.textsize := patchsize;
      gbytes(oldptr.a, sizeof(generalvalue, false));
      with oldptr.gvp^ do
	begin
	primarytype := relocatable;     datasize := sint;
	patchable := false;             longoffset := false;
	if patchbase = 0 then begin valueextend := false; short := 2; end
	else begin
	     gbytes(newptr, sizeof(valueextension, sint));
	     veptr(newptr)^.value := patchbase;
	     valueextend := true;  short := 6;
	     end
	end;
      mergetext;
      end
    else with directory.drp^ do
      begin
      oldindex.a := directory.a + sizeof(moduledirectory);
      oldindex.a := oldindex.a + strlen(oldindex.syp^) + 2 -
		     ord(odd(strlen(oldindex.syp^)));
      if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
      textrecs := textrecords;
      while textrecs > 0 do with oldindex.tdp^ do
	begin
	gbytes(newtextrec.a, sizeof(textdescriptor));
	if odd(textsize) then textsize := textsize + 1;
	newtextrec.tdp^.textsize := textsize;
	oldindex.a := oldindex.a + sizeof(textdescriptor);
	ptr := lowheap; makenewgvr(oldindex, modptr);
	compressgvr(ptr);
	mergetext;
	textrecs := textrecs - 1;
	end;
      end;
    modptr := link;
    end;

  with tempdirptr.drp^ do
    begin
    date := todaysdate;
    revision := linkerdate;
    producer := 'L';
    systemid := 3;
    notice := copyright;
    directorysize := lowheap.a - tempdirptr.a;
   {modulesize := }
    executable := (startgvr.p <> NIL);
    relocatablesize := totalreloc;
    relocatablebase := startreloc;
    globalsize := totalglobal;
    globalbase := startglobal;
   {extblock :=}
   {extsize  :=}
   {defblock := }
   {defsize  := }
    sourceblock := 0;                   {implement later}
    sourcesize  := 0;
    textrecords := newtextrecs;

    nextblock := (directorysize +(blocksize-1)) div blocksize;

    extblock :=  nextblock;
    extsize  := newextsize;
    extblocks := (newextsize + (blocksize-1)) div blocksize;
    blockwrite(outfile,point(newexttable)^,extblocks,outblock+nextblock);
    nextblock := nextblock + extblocks;

    {lowheap.a := newdirectory.a + directorysize;
    fastmove(tempdirptr.p, newdirectory.p, directorysize);
    } newdirectory := tempdirptr;
    end;

end;

procedure mergedefs;

var slist:      sortlistptr;
    ilist:      addrec;
    listlen:    shortint;
    sortlen:    shortint;
    minindex:   shortint;
    modptr:     moddescptr;
    len,
    i:          integer;
    done:       boolean;
    strptr,
    newstrptr,
    sptr:       addrec;

    newdeftable: address;
    defblocks:  integer;
    c:          char;

begin
  slist := lowheap.slp;  listlen := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if not patchmod then if defsize > 0 then
      begin
      listlen := listlen + 1;
      gbytes(sptr.a, sizeof(sortdesc));
      with sptr.sdp^ do
	begin
	modp := modptr;
	def := defaddr;
	end;
      end;
    modptr := link;
    end;

  gbytes(ilist.a, listlen * sizeof(shortint));
  for i := 1 to listlen do ilist.ilp^[i] := i-1;
  sortlen := listlen;
  newdeftable := lowheap.a;

  while listlen > 0 do
    begin
    while sortlen > 0 do with slist^[ilist.ilp^[sortlen]], modp^ do
      begin
      done := false;
      repeat
       if def.a >= defaddr.a + defsize then
	 begin
	 listlen := listlen - 1;
	 for i := sortlen to listlen do ilist.ilp^[i] := ilist.ilp^[i+1];
	 done := true;
	 end
       else
	 begin
	 len := strlen(def.syp^) + 2 - ord(odd(strlen(def.syp^)));
	 with gvrptr(def.a+len)^ do
	   if patchable then def.a := def.a + len + short
	   else
	    begin
	    i := sortlen;  minindex := ilist.ilp^[i];
	    repeat
	     if i >= listlen then done := true
	     else if def.syp^ <= slist^[ilist.ilp^[i+1]].def.syp^ then done := true
	     else begin ilist.ilp^[i] := ilist.ilp^[i+1]; i := i + 1; end;
	    until done;
	    ilist.ilp^[i] := minindex;
	    end;
	 end
      until done;
      sortlen := sortlen - 1;
      end;
    if listlen > 0 then
      begin
      with slist^[ilist.ilp^[1]] do
	begin
	strptr := def;
	len := strlen(strptr.syp^) + 2 - ord(odd(strlen(strptr.syp^)));
	gbytes(newstrptr.a, len);
	fastmove(strptr.p, newstrptr.p, len);
	def.a := strptr.a + len;
	makenewgvr(def, modp);
	end;
      i := 2; done := false;
      repeat with slist^[ilist.ilp^[i]], modp^ do
	if i > listlen then done := true
	else if def.syp^ = newstrptr.syp^ then
	 begin
	   if printeron then
	     begin
	       list; writeln(listing,'duplicate symbol definition for:  ',
							  def.syp^);  {**!!!!*}
	     end
	   else
	     begin
	       errorline;
	       writeln('duplicate symbol:  ',def.syp^);
	       if streaming then escape(119);
	       write('Press ''C'' to continue, any other key to abort ',cteol);
	       read(keyboard,c);
	       if (c <> 'C') and (c <> 'c') then escape(119);
	       fgotoxy(output, 0, 22);
	       writeln(cteol);
	       write('LINKING ...', cteol);
	     end;
	   def.a := def.a + strlen(def.syp^) + 2 - ord(odd(strlen(def.syp^)));
	   def.a := def.a + def.gvp^.short;
	   i := i + 1;
	 end
	else done := true;
      until done;
      sortlen := i-1;
      end;
    end;

  with newdirectory.drp^ do
    begin
    defblock := nextblock;
    if defsout then defsize := lowheap.a - newdeftable
    else defsize := 0;
    defblocks := (defsize + (blocksize-1)) div blocksize;
    if defblocks > 0 then
     blockwrite(outfile,point(newdeftable)^,defblocks,outblock+nextblock);
    nextblock := nextblock + defblocks;
    end;
  lowheap.slp := slist;

end;

procedure copytext;

var patchptr:           patchdescptr;
    loadaddr,loadaddr0: address;
    modptr:             moddescptr;     {current module being loaded}
    gvrp:               gvrptr;
    patching,
    merging:            boolean;        {whether text records are combined}

    textbuffer,         {base of text record buffer}
    textbuftop,         {end  of text record buffer}
    textindex,          {pointer to next space available in text buffer}
    object,             {object in text record being modified by ref record}

    refbuffer,          {base of ref table buffer}
    refbuftop,          {end  of ref table buffer}
    outrefindex,        {pointer to next space available in ref buffer}
    inrefindex,         {pointer to next record in ref buffer to process}

    newptr,            {base of new gvr on heap}
    valptr,             {value extension in new gvr on heap}

    oldindex,           {pointer to old text descriptors}
    newindex:           {pointer to new text descriptors}
		addrec;

    vevalue,
    newbytes,           {size of new gvr on heap}
    offsetbytes,        {distance from last object referenced by new refs}
    oldtextrec,         {text records left to process from old module}

    textbufblocks,      {maximum blocks allocated for text buffer}
    textinblock,        {file relative block index into old text}
    textinsize,         {number of bytes left to read from old text}
    textoutblock,       {file relative block index into new text}
    textoutsize,        {number of bytes processed into new text}

    refbufblocks,       {maximum blocks allocated for ref buffer}
    refinblock,         {file relative block index into old ref table}
    refinsize,          {number of bytes left to read from old ref}
    refoutblock,        {file relative block index into new ref table}
    refoutsize:         {number of bytes processed into new ref table}
		integer;

  procedure starttext;
  begin
  if not merging then with newindex.tdp^ do
    begin
    textstart := nextblock;     textoutblock := nextblock + outblock;
    nextblock := nextblock + (textsize + (blocksize - 1)) div blocksize;
    refoutblock := nextblock + outblock;

    textoutsize := 0;           textindex   := textbuffer;
    refoutsize := 0;            outrefindex := refbuffer;
    offsetbytes := 0;           object := textbuffer;

    valptr.a := newindex.a + sizeof(textdescriptor);
    patching := (valptr.gvp^.primarytype = relocatable) and (totalpatchspace > 0);
    if patching then
     if valptr.gvp^.valueextend then
      begin
      valptr.a := valptr.a + sizeof(generalvalue, false);
      loadaddr0 := valptr.vep^.value;
      end
     else loadaddr0 := 0;
     loadaddr := object.a - loadaddr0;
    end;
  end;

  procedure endtext;
  var lastblocks: integer;
      td: addrec;
      org: integer;
  begin
  with newindex.tdp^ do
    begin
    merging := (textoutsize < textsize);
    if not merging then
      begin
      if textindex.a > textbuffer.a then
	begin
	lastblocks := (textindex.a-textbuffer.a+(blocksize-1)) div blocksize;
	blockwrite(outfile, textbuffer.p^, lastblocks, textoutblock);
	end;
      if outrefindex.a > refbuffer.a then
	begin
	lastblocks := (outrefindex.a - refbuffer.a + (blocksize-1)) div blocksize;
	blockwrite(outfile, refbuffer.p^, lastblocks, refoutblock);
	end;
      refstart := nextblock;    refsize := refoutsize;
      nextblock := nextblock + (refoutsize + (blocksize - 1)) div blocksize;
      newindex.a := newindex.a + sizeof(textdescriptor);
      org := 0; gvrstring(newindex.gvp,org,false,true);
      if printeron then
       begin
       list; writeln(listing,
       '(load record:  size = ',textsize:1,', load address = ',gvaluestring, ')');
       end;
      end;
    end;
  end;

  procedure dumptext(writebytes: integer);
  var writeblocks:      integer;
  begin
    writeblocks := writebytes div blocksize;
    writebytes := writeblocks * blocksize;
    blockwrite(outfile, textbuffer.p^, writeblocks, textoutblock);
    textoutblock := textoutblock + writeblocks;
    textindex.a := textindex.a - writebytes;
    object.a := object.a - writebytes;
    loadaddr := loadaddr - writebytes;
    fastmove(point(textbuffer.a + writebytes), textbuffer.p,
	     textindex.a - textbuffer.a);
  end;

  procedure checktextbuf(obsize: integer);
  var readbytes, writebytes:      integer;
  begin
  while textindex.a < object.a + obsize do
    begin
    readbytes :=  textbuftop.a - textindex.a;
    if textinsize <= readbytes then readbytes := textinsize
    else
      begin
      if object.a < textindex.a then writebytes := object.a    - textbuffer.a
				else writebytes := textindex.a - textbuffer.a;
      if writebytes < readbytes then
	readbytes := readbytes - readbytes mod blocksize
      else begin dumptext(writebytes); readbytes := 0; end;
      end;
    if readbytes > 0 then
      begin
      readblocks(modptr^.filefib.fbp^, textindex.p^, readbytes, textinblock);
      textinblock := textinblock + readbytes div blocksize;
      textinsize := textinsize - readbytes;
      textindex.a := textindex.a + readbytes;
      end;
    end;
  end;

  procedure dumprefs;
  var writebytes, writeblocks:    integer;
  begin
    writeblocks := (outrefindex.a - refbuffer.a) div blocksize;
    writebytes := writeblocks * blocksize;
    blockwrite(outfile, refbuffer.p^, writeblocks, refoutblock);
    refoutblock := refoutblock + writeblocks;
    outrefindex.a := outrefindex.a - writebytes;
    fastmove(point(refbuffer.a + writebytes), refbuffer.p,
	     outrefindex.a - refbuffer.a);
  end;


  procedure  checkinref;
  const maxrefsize = 254;
  var  refinbytes, readbytes:   integer;
  begin
    refinbytes := refbuftop.a - inrefindex.a;
    if refinbytes < maxrefsize then
      begin
      if refinsize > 0 then
	repeat
	if outrefindex.a > refbuffer.a + blocksize then
	     readbytes := inrefindex.a - (outrefindex.a + blocksize)
	else readbytes := inrefindex.a - (refbuffer.a + (2 * blocksize));
	if refinsize <= readbytes then readbytes := refinsize
	else if outrefindex.a - refbuffer.a < readbytes then
	       readbytes := readbytes - readbytes mod blocksize
	     else begin dumprefs; readbytes := 0; end;
	if readbytes > 0 then
	  begin
	  fastmove(inrefindex.p, point(inrefindex.a - readbytes), refinbytes);
	  inrefindex.a := inrefindex.a - readbytes;
	  readblocks(modptr^.filefib.fbp^, point(inrefindex.a + refinbytes)^,
							readbytes, refinblock);
	  refinblock := refinblock + readbytes div blocksize;
	  refinsize := refinsize - readbytes;
	  end;
	until readbytes > 0;
      end;
  end;

  procedure putref;
  var newbytes: shortint;
      valptr:   addrec;
  begin
  compressgvr(newptr);
  with newptr.gvp^ do
    if longoffset then long := offsetbytes
    else if offsetbytes < 256 then short := offsetbytes
    else
      begin
      valptr.a := newptr.a + sizeof(generalvalue,false);
      moveright(valptr.p^, point(valptr.a + 2)^,
		lowheap.a - valptr.a);
      lowheap.a := lowheap.a + 2;
      longoffset := true;
      long := offsetbytes;
      end;
  offsetbytes := 0;
  newbytes := lowheap.a - newptr.a;
  if outrefindex.a + newbytes > inrefindex.a then dumprefs;
  fastmove(newptr.p, outrefindex.p, newbytes);
  outrefindex.a := outrefindex.a + newbytes;
  refoutsize := refoutsize + newbytes;
  lowheap := newptr;
  end; {putref}

  procedure patcherror(dsize: datatype);

    procedure printmessage(var f: text);
    var index: addrec;
    begin
    index.a := modptr^.directory.a+sizeof(moduledirectory);
    write(f, 'Can''t patch byte ',
    object.a - loadaddr - loadaddr0:1,
    ' in text record ',oldtextrec:1,
    ' of module ',index.syp^);
    end;

  begin
  errors := errors + 1;
  errorline; printmessage(output);
  if printeron then
    begin list;
    write(listing, '*** ERROR *** ');
    printmessage(listing); writeln(listing);
    end
  else escape(128);
  end;

  procedure makepatch;
  var r, rptr:     addrec;
      objectaddr:  address;
      patchaddr:   address;
      foundpatchmodptr,
      patchmodptr: moddescptr;
      foundlastpptr,
      lastpatchptr,
      patchptr:    patchdescptr;
      patchdelta,
      delta2,foundpatchdelta:  integer;
      patchstate: (nopatch,longpatch,shortpatch, oldpatch);
      backwardlist: boolean;
  begin
  objectaddr := object.a - loadaddr;
  with valptr.vep^ do
   value := value + object.sw^ + objectaddr;
  with newptr.gvp^ do
   begin
   patchable := false;
   if primarytype = absolute then primarytype := relocatable
   else
    begin
    if primarytype <> general then
      begin
      gbytes(rptr.a, sizeof(referenceptr));
      with rptr.rpp^ do
       begin adr := 0; op := addit; last := false; end;
      gbytes(rptr.a, sizeof(referenceptr));
      with rptr.rpp^ do
       begin adr := ord(primarytype)-1;
       op := addit; last := true; end;
      primarytype := general;  short := short + 4;
      end
    else
      begin
      rptr.a := valptr.a + sizeof(valueextension,sint);
      with rptr.rpp^ do
       if (adr=0) and (op=subit) then
	 if last then
	   begin
	   primarytype := absolute; lowheap := rptr;
	   short := short - 2;
	   end
	 else
	   begin
	   moveleft(point(rptr.a+2)^,rptr.p^,
	     short-(valptr.a-newptr.a)-6);
	   lowheap.a := lowheap.a - sizeof(referenceptr);
	   short := short - 2;
	   end
       else
	 begin
	 gbytes(r.a, sizeof(referenceptr));
	 moveright(rptr.p^,point(rptr.a+2)^,
	   short-(valptr.a-newptr.a)-4);
	 adr := 0; op := addit; last := false;
	 short := short + 2;
	 end;
      end;
    end;
   end;
  patchstate := nopatch;
  for backwardlist := false to true do
   begin
   if backwardlist then patchmodptr := backwardpatches
		   else patchmodptr := forwardpatches;
   while (patchmodptr <> NIL) and (patchstate < oldpatch) do
    with patchmodptr^ do
     begin
     patchaddr := patchbase;
     patchptr := patchlist;
     while (patchptr<>NIL) and (patchstate < oldpatch) do
      with patchptr^ do
       begin
       patchdelta := patchaddr-objectaddr;
       if (-32768<=patchdelta) and (patchdelta<32768)
	then if gvrequal(newptr,patchref,0)
	 then begin
	      object.sw^ := patchdelta;
	      lowheap := newptr;
	      patchstate := oldpatch;
	      end;
       if patchref.gvp^.datasize = sword then
	    patchaddr := patchaddr + 4
       else patchaddr := patchaddr + 6;
       lastpatchptr := patchptr;
       patchptr := patchlist;
       end;
     patchdelta := patchaddr-objectaddr;
     if (patchstate < shortpatch) then
      if (-32768<=patchdelta) and (patchdelta<32768) then
       begin
       if patchsize - (patchaddr - patchbase) >= 4 then
	if newptr.gvp^.primarytype = relocatable then
	 begin
	 delta2 := valptr.vep^.value - (patchaddr+2);
	 if (-32768 <= delta2) and (delta2 < 32768) then
	  if object.a + patchdelta >= textbuffer.a then
	   begin
	   patchstate := shortpatch;
	   foundpatchdelta := patchdelta;
	   foundlastpptr := lastpatchptr;
	   foundpatchmodptr := patchmodptr;
	   end;
	 end;
       if (patchstate < longpatch) and not backwardlist then
	if patchsize - (patchaddr - patchbase) >= 6 then
	 begin
	 patchstate := longpatch;
	 foundpatchdelta := patchdelta;
	 foundlastpptr := lastpatchptr;
	 foundpatchmodptr := patchmodptr;
	 end;
       end;
     patchmodptr := patchlink;
     end;
   end;
  if patchstate = nopatch then patcherror(newptr.gvp^.datasize)
  else if patchstate < oldpatch then
   with foundpatchmodptr^ do
    begin
    gbytes(r.a, sizeof(patchdescriptor));
    if patchlist = NIL then patchlist := r.pdp
    else foundlastpptr^.patchlist := r.pdp;
    with r.pdp^ do
     begin
     patchlist := NIL;
     patchref := newptr;
     if patchstate = longpatch then newptr.gvp^.datasize := sint
     else begin
	  newptr.gvp^.datasize := sword;
	  if foundpatchdelta < 0 then
	   begin
	   r.a := object.a + foundpatchdelta;
	   r.uw^.w := 24576 {BRA pc relative};
	   r.a := r.a + 2;
	   r.sw^ := delta2;
	   if printeron then
	    begin
	    list; write(listing, '(backward patch)  BRA ');
	    gvrp := patchref.gvp; vevalue := 0;
	    gvrstring(gvrp, vevalue, false, true);
	    writeln(listing, gvaluestring,
	     '':20-strlen(gvaluestring),
	     r.a-2-loadaddr:10);
	    end;
	   end;
	  end;
     end;
    object.sw^ := foundpatchdelta;
    end;
  end;

begin {procedure copytext}
  {estimate data structures at 3/2(totalpatchspace) + 1/4(workspace) }
  textbufblocks := ((highheap.a - lowheap.a) * 3  -
		     totalpatchspace         * 6  ) div (blocksize * 4);

  refbufblocks := textbufblocks div 4;
  if refbufblocks < 4 then refbufblocks := 4;

  textbufblocks := textbufblocks - refbufblocks;
  if textbufblocks < 3 then textbufblocks := 3;

  gbytes(textbuffer.a, textbufblocks * blocksize);
  textbuftop := lowheap;
  gbytes(refbuffer.a,  refbufblocks  * blocksize);
  refbuftop  := lowheap;

  newindex.a := newdirectory.a + sizeof(moduledirectory);
  newindex.a := newindex.a + strlen(newindex.syp^) + 2 -
		 ord(odd(strlen(newindex.syp^)));
  if newdirectory.drp^.executable then
    newindex.a := newindex.a + newindex.gvp^.short;

  merging := false;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      if printeron then
	begin
	list; writeln(listing, '(patch space)', patchsize:29,patchbase:10);
	end;
      starttext;
      patchptr := patchlist;
      while patchptr <> NIL do with patchptr^, patchref.gvp^ do
	begin
	if textbuftop.a - textindex.a < 6 then
	  dumptext(textindex.a - textbuffer.a);
	if printeron then
	  begin list;
	  gvrp := patchref.gvp; vevalue := 0;
	  gvrstring(gvrp, vevalue, false, true);
	  end;
	if valueextend then
	  begin
	  if longoffset then valptr.a := patchref.a +sizeof(generalvalue,true)
	  else valptr.a := patchref.a +sizeof(generalvalue,false);
	  vevalue := valptr.vep^.value;
	  end
	else vevalue := 0;
	if datasize = sword {PC relative branch} then
	  begin
	  if printeron then
	    writeln(listing, '  BRA ',gvaluestring,
	      '':26-strlen(gvaluestring), object.a-loadaddr:20);
	  object.uw^.w := 24576 {BRA pc relative};
	  object.a := object.a + 2;
	  object.sw^ := vevalue - (object.a - loadaddr);
	  object.a := object.a + 2;
	  offsetbytes := offsetbytes + 4;
	  end
	else {long absolute branch}
	  begin
	  if printeron then
	    writeln(listing, '  JMP ', gvaluestring,
	      '':26-strlen(gvaluestring), object.a-loadaddr:20);
	  object.uw^.w := 20217 {JMP long absolute};
	  object.a := object.a + 2;
	  object.si^ := vevalue;
	  object.a := object.a + 4;
	  gbytes(newptr.a, short);
	  fastmove(patchref.p, newptr.p, short);
	  if valueextend then
	    begin
	    valptr.a := newptr.a + (valptr.a - patchref.a);
	    valptr.vep^.value := 0;
	    end;
	  offsetbytes := offsetbytes + 2;
	  putref;
	  offsetbytes := 4;
	  end;
	textindex := object;
	patchptr := patchlist;
	end;
      object.a := textindex.a + patchsize - (object.a - loadaddr - patchbase);
      while textindex.a < object.a do
	begin
	if textindex.a >= textbuftop.a - 2 then
	  dumptext(textindex.a - textbuffer.a);
	textindex.sw^ := -1;
	textindex.a := textindex.a + 2;
	offsetbytes := offsetbytes + 2;
	end;
      textoutsize := textoutsize + patchsize;
      endtext;
      forwardpatches := patchlink;
      patchlink := backwardpatches;
      backwardpatches := modptr;
      end
    else with directory.drp^ do
      begin
      oldindex.a := directory.a + sizeof(moduledirectory);
      if printeron then
	begin
	list; writeln(listing, oldindex.syp^, '':32-strlen(oldindex.syp^),
		 relocatablesize:10,relocbase:10,
		 globalsize:10,     globase:10);
	end;
      oldindex.a := oldindex.a + strlen(oldindex.syp^) + 2 -
		     ord(odd(strlen(oldindex.syp^)));
      if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
      for oldtextrec := 1 to textrecords do
       begin
       if oldindex.tdp^.textsize > 0 then
	begin
	starttext;
	loadaddr0 := object.a - loadaddr;
	with oldindex.tdp^ do
	  begin
	  refinsize := refsize;
	  textinsize := textsize;
	  refinblock := fileblock+refstart;
	  textinblock := fileblock+textstart;
	  textoutsize := textoutsize + textsize;
	  end;

	inrefindex := refbuftop;

	while (refbuftop.a - inrefindex.a) + refinsize > 0 do
	  begin
	  checkinref;
	  newptr := lowheap;
	  with inrefindex.gvp^ do
	    if longoffset then
	      begin
	      newbytes := long;
	      valptr.a := newptr.a + sizeof(generalvalue, true);
	      end
	    else
	      begin
	      newbytes := short;
	      valptr.a := newptr.a + sizeof(generalvalue, false);
	      end;
	  object.a := object.a + newbytes;
	  offsetbytes := offsetbytes + newbytes;
	  makenewgvr(inrefindex, modptr);
	  with newptr.gvp^, valptr.vep^ do
	    begin
	    case datasize of   {$range off$}
	      sbyte:
		begin
		checktextbuf(sizeof(sbyterec));
		value         := value + object.sb^.sb;
		object.sb^.sb := value;
		value         := value - object.sb^.sb;
		end;
	      sword:
		begin
		checktextbuf(sizeof(shortint));
		value         := value + object.sw^;
		object.sw^    := value;
		value         := value - object.sw^;
		end;
	      sint:
		begin
		checktextbuf(sizeof(integer));
		object.si^ := object.si^ + value;
		value := 0;
		end;
	      ubyte:
		begin
		checktextbuf(sizeof(ubyterec));
		value         := value + object.ub^.ub;
		object.ub^.ub := value;
		value         := value - object.ub^.ub;
		end;
	      uword:
		begin
		checktextbuf(sizeof(wordrec));
		value         := value + object.uw^.w;
		object.uw^.w  := value;
		value         := value - object.uw^.w;
		end;        {$range on$}
	      otherwise escape(111);
	      end; {case datasize}
	    if primarytype = absolute then
	      begin
	      if value <> 0 then
		if patchable and patching then makepatch
		else patcherror(datasize);
		end
	    else if patching and patchable then makepatch
	    else putref;
	    end; {with gvrptr(newptr)^, valptr^}
	  end; {while there are any ref's }

	newbytes := textindex.a + textinsize  - object.a;
	offsetbytes := offsetbytes + newbytes;
	object.a := object.a + newbytes;
	checktextbuf(0);

	endtext;
	end;
       oldindex.a := oldindex.a + sizeof(textdescriptor);
       oldindex.a := oldindex.a + oldindex.gvp^.short;
       end; {for oldtextrec}
      end; {with directory^ do}
    modptr := link;
    end;
end; {copytext}

procedure printdirectentry(modnum: shortint; var entry: direntry);
begin
with entry do
  begin
  upc(dtid);
  list; write(listing, modnum:4,' ',dtid,
  dlastblk-dfirstblk:21-strlen(dtid),'  ');
  writedate(listing, daccess);
  writeln(listing, dfirstblk:7);
  end;
end;

procedure bootmod(modnum: shortint);
const sectorsize = 256;
var     buffer, bufptr, valptr, ptr, endrefs, mname,
	infostart:      addrec;
	object, recordnum:  integer;

procedure writesector(anyvar f: fib; anyvar obj: window; size,sector: integer);
begin
  call (f.am, addr(f), writebytes, obj, size, sector * sectorsize);
  if ioresult <> 0 then escape(114);
end;

begin
  infostart := lowheap;
  loadinfo(modnum,true, true);
  with newmods^,directory.drp^ do
    begin
    if extsize > 8 then escape(120);
    mname.a := directory.a + sizeof(moduledirectory);
    ptr.a := mname.a + strlen(mname.syp^) + 2 - ord(odd(strlen(mname.syp^)));
    if executable then with ptr.gvp^, fibp(addr(outfile))^ do
      begin
      if fstartaddress = 0 then
	if valueextend then
	  begin
	  valptr.a := ptr.a + sizeof(generalvalue,false);
	  fstartaddress := valptr.vep^.value;
	  end;
      ptr.a := ptr.a + short;
      end;
    recordnum := 0;
    while textrecords > 0 do with ptr.tdp^ do
      begin
      recordnum := recordnum + 1;
      if refsize > 0 then       {check to make sure code is "absolute"}
	begin
	gbytes(buffer.a, refsize);
	readblocks(filefib.fbp^,buffer.p^,refsize,fileblock+refstart);
	bufptr := buffer; endrefs.a := buffer.a + refsize;
	object := 0;
	while bufptr.a < endrefs.a do with bufptr.gvp^ do
	  begin
	  if longoffset then
	       begin object := object + long;
	       bufptr.a := bufptr.a + sizeof(generalvalue, true);
	       end
	  else begin object := object + short;
	       bufptr.a := bufptr.a + sizeof(generalvalue, false);
	       end;
	  if valueextend then
	    begin
	    errorline;
	    write  ('Can''t relocate byte ',object:1,
		    ' in record ',recordnum:1,
		    ' of module ',mname.syp^);
	    escape(128);
	    end;
	  if primarytype = general then
	    begin
	    while not bufptr.rpp^.last do
	      bufptr.a := bufptr.a + sizeof(referenceptr);
	    bufptr.a := bufptr.a + sizeof(referenceptr);
	    end;
	  end;
	lowheap := buffer;
	end;
      gbytes(buffer.a, sizeof(integer));
      ptr.a := ptr.a + sizeof(textdescriptor);
      with ptr.gvp^ do
	begin
	if valueextend then
	  begin
	  valptr.a := ptr.a + sizeof(generalvalue,false);
	  buffer.p^ := valptr.vep^.value;
	  end
	else buffer.p^ := 0;
	ptr.a := ptr.a + short;
	end;

      gbytes(bufptr.a, sizeof(integer));
      bufptr.p^ := textsize;

      gbytes(bufptr.a, textsize);
      readblocks(filefib.fbp^,bufptr.p^,textsize,fileblock+textstart);
      writesector(outfile, buffer.p^, textsize+2*sizeof(integer), outblock);
      outblock := outblock +
		(textsize + 2*sizeof(integer) + (sectorsize-1)) div sectorsize;
      lowheap := buffer;
      textrecords := textrecords - 1;
      end;
    end;
  lowheap := infostart;
  newmods := NIL;
end;

procedure copymodule(modnum: shortint);
const fosize = sizeof(addrec)+sizeof(fib,1);
      fsize  = fosize+ord(odd(fosize));
var startblock, numblocks, transblocks:  {shortint} INTEGER;       {SFB}
    copybuffer: addrec;
    bufblocks:  {shortint}  INTEGER;       {SFB}
begin
if booting then bootmod(modnum)
else if linking then begin
		     if loadfib.a >= highheap.a then
		       begin
		       fastmove(highheap.p, lowheap.p, fsize);
		       highheap.a := highheap.a + fsize;
		       lowheap.a := lowheap.a + fsize;
		       loadfib.a := loadfib.a - (highheap.a - lowheap.a);
		       end;
		     loadinfo(modnum, true, true)
		     end
else
  begin
  bufblocks := (highheap.a -lowheap.a) div blocksize;
  gbytes(copybuffer.a, bufblocks * blocksize);

  if outmodnum>=maxmodules then escape(127);
  outmodnum := outmodnum + 1;
  outdirectory.fdp^[outmodnum] := fdirectory^[modnum];
  with fdirectory^[modnum] do
    begin
    startblock := dfirstblk;      numblocks := dlastblk-startblock;
    end;
  with outdirectory.fdp^[outmodnum] do
    begin
    dfirstblk := outblock;        dlastblk := outblock + numblocks;
    end;
  while numblocks > 0 do
    begin
    if numblocks <= bufblocks then transblocks := numblocks
			      else transblocks := bufblocks;
    readblocks(loadfib.fbp^, copybuffer.p^, transblocks*blocksize, startblock);
    blockwrite(outfile, copybuffer.p^, transblocks, outblock);
    startblock := startblock + transblocks;
    outblock := outblock + transblocks;
    numblocks := numblocks - transblocks;
    end;
    lowheap := copybuffer;
    {if printeron then printdirectentry(outmodnum, outdirectory.fdp^[outmodnum]); }
  end;
end;

procedure writedirectory;
begin
  with newdirectory.drp^ do
  begin
    modulesize := nextblock * blocksize;
    blockwrite(outfile, newdirectory.drp^, extblock, outblock);
  end;

  if outmodnum>=maxmodules then escape(127);
  outmodnum := outmodnum + 1;
  with outdirectory.fdp^[outmodnum] do
    begin
    dfirstblk := outblock;
    outblock := outblock + nextblock;
    dlastblk := outblock;
    dfkind := codefile;
    moveleft(newmodname.syp^, dtid, sizeof(filname));
    if strlen(dtid) > fnlength then setstrlen(dtid, fnlength);
    dlastbyte := 256;
    daccess := todaysdate;
    end;
  {if printeron then printdirectentry(outmodnum, outdirectory.fdp^[outmodnum]); }
end;

procedure trim(var s: string);
var first, last: shortint;
begin
  last := strlen(s);
  while last > 0 do
    begin
    if s[last] = ' ' then
      begin last := last - 1; if last = 0 then s := ''; end
    else
      begin
      first := 1;  while s[first] = ' ' do first := first + 1;
      s := str(s, first, last - first + 1);  last := 0;
      end;
    end;
end;

procedure toggleprinter;
var newlistname: string80;
    fvid: vid;
    ftitle: fid;
    fsegs:  integer;
    fkind:  filekind;
begin
printeron := not printeron;
if printeron then
  begin
  fgotoxy(output, 13,3); write('     ',cteol);
  readln(newlistname);
  fixname(newlistname, textfile);
  if scantitle(newlistname, fvid, ftitle, fsegs, fkind) then ; { jws 3/2/84}
  if strlen(newlistname)>0 then
    begin
    listfilename := newlistname;
    if fsegs=0 then                                           { jws 3/2/84 }
	   sappend(newlistname, '[*]');
    pageeject;
    if (pagenum=0) and (linenum=0)
       then close(listing)
       else close(listing, 'lock');
    rewrite(listing, newlistname);
    pagenum := 0;       linenum := 0;
    printopen := ioresult = 0;
    printeron := printopen;
    if not printopen then escape(118);
    end
  else printeron := printopen;
  end;
end;

procedure copyon;
begin
 lowheap := infostart;
 linking := false;
end;

procedure closein;
begin
 if fdirectory <> NIL then
  begin
  if loadfib.a >= highheap.a then
    begin
    close(loadfib.php^);
    loadfib.a := loadfib.a - sizeof(addrec);
    loadfib := loadfib.arp^;
    end;
   highheap := highheap0; fdirectory := NIL;
   vmodnum := 0; verifying := false;
  end;
end;

procedure initlink;
begin
 linking := true;       defsout := true;
 infostart := lowheap;  newmodname.syp := NIL;
 startreloc := 0;       startglobal := 0;
 copyright := '';
end;

procedure link;
begin
 errors := 0;
 fgotoxy(output, 0,23); write('LINKING ...');
 rsolve;
 if printeron then
   begin
   list; writeln(listing, 'link map', 'Rsize':34, 'Rbase':10, 'Gsize':10, 'Gbase':10);
   list; writeln(listing, '------':42, '------':10, '------':10, '------':10);
   end;
 newdirectory := lowheap;
 mergeexts;
 makedir;        {also write new ext table, move down directory}
 mergedefs;
 copytext;
 writedirectory;

 if printeron then
   begin
   list; writeln(listing, '------':42,'------':20);
   list;
   if newmodname.syp = NIL then write(listing, '(no name)', '':32-9)
   else write(listing, newmodname.syp^, '':32-strlen(newmodname.syp^));
   writeln(listing, totalreloc:10, totalglobal:20);
   listln;
   end;
 closein;
 closefiles;
 lowheap := infostart; {release memory used by linker}
 linking := false;      newmods := NIL;
 if errors > 0 then escape(122);
end; {link}


procedure printdirectory;
var numfiles:   shortint;
    modnum:     shortint;
begin
 list; writeln(listing, 'FILE DIRECTORY OF:  ''', loadfib.fbp^.ftid, '''');
 listln;
 numfiles := fdirectory^[0].dnumfiles;
 for modnum := 1 to numfiles do
   printdirectentry(modnum, fdirectory^[modnum]);
 listln;
end;

procedure copyfile;
var modnum:     shortint;
begin
 for modnum := 1 to fdirectory^[0].dnumfiles do
  copymodule(modnum);
 closein;
end;

procedure verifynext;
begin
 if vmodnum < fdirectory^[0].dnumfiles then
  begin
  vmodnum := vmodnum + 1;
  upc(fdirectory^[vmodnum].dtid)
  end
 else
  begin
  vmodnum := 0;
  verifying := false;
  end;
end;

procedure verifymod;
begin
 vmodnum := 0;  verifying := true;
 verifynext;
end;

procedure xfer;
var modnum:     shortint;
begin
 if verifying then
  begin
  copymodule(vmodnum);
  verifynext;
  end
 else
  begin
  for modnum := 1 to fdirectory^[0].dnumfiles do
   with fdirectory^[modnum] do
    begin
    upc(dtid);
    if dtid = fdirectory^[vmodnum].dtid then
      copymodule(modnum);
    end;
  vmodnum := 0;
  end;
end;

procedure openin;
const fosize = sizeof(addrec)+sizeof(fib,1);
      fsize  = fosize+ord(odd(fosize));
begin
 closein;
 fgotoxy(output, 22,13); write(cteol);
 if strlen(infilename)=0 then   { if no name then get it }
 begin readln(infilename); fixname(infilename, codefile);
 end;
 if strlen(infilename) > 0 then
 begin
   openlinkfile(infilename);
   if fdirectory = NIL then
   begin errorline;
	 write('cannot open ''', infilename, ''', ');
	 ioerror;
   end
   else
   begin highheap.a := highheap.a - fsize;
	 lowheap.a := lowheap.a - fsize;
	 fastmove(lowheap.p, highheap.p, fsize);
	 loadfib.a := loadfib.a + (highheap.a - lowheap.a);
	 if fdirectory^[0].dnumfiles = 1 then vmodnum := 1
					 else verifymod;
    end;
  end;
end;    { openin }

procedure closeout;
begin
 closein;
 with outdirectory.fdp^[0] do
  begin
  deovblk := outblock;
  dnumfiles := outmodnum;
  outopen := false;     outmodnum := 0;
  lowheap := outdirectory;
  blockwrite(outfile, outdirectory.fdp^, outdirectsize, 0);
  close(outfile, 'lock');
  if ioresult <> 0 then escape(126);
  end;
end;

procedure openout(boot: boolean);
var i,j: integer;
    nul: string[1]; typestring: string[6];
    thirdparm: string[10];
begin
 thirdparm := 'shared';
 if linking then lowheap := infostart;
 linking := false;
 if outopen then
   begin
   close(outfile);
   lowheap := outdirectory;
   end;
 outopen := false;
 fgotoxy(output, 22,4); write(cteol);
 readln(outfilename);
 trim(outfilename);
 if strlen(outfilename) > 0 then
  begin
  nul := '';
  if boot then
   begin
   fixname(outfilename, sysfile);
   reset(outfile, outfilename); close(outfile, 'PURGE');
   typestring := '.SYSTM'; fmaketype(outfile, outfilename, thirdparm, typestring);
   outopen := (ioresult = 0);
   outblock := 0;
   end
  else
   begin
   fixname(outfilename, codefile);
   typestring := '.CODE'; fmaketype(outfile, outfilename, thirdparm, typestring);
   if ioresult = 0 then
    begin
    gbytes(outdirectory.a, outdirectsize*blocksize);
    with outdirectory.fdp^[0] do
      begin
      dfirstblk := 0; dlastblk := outdirectsize;
      dfkind := untypedfile {volume entry};
      moveleft(outfilename, dvid, sizeof(volname));
      if strlen(outfilename) > vnlength then setstrlen(dvid, vnlength);
      deovblk := outdirectsize; dnumfiles := 0;
      dloadtime := 0; dlastboot := todaysdate;
      end;
    outblock := outdirectsize;
    outopen := true;
    end;
   end;
  if outopen then booting := boot
  else
   begin
   booting := false;
   errorline;
   write('cannot open ''', outfilename, ''', ');
   ioerror;
   end;
  end;
end;    { openout }

procedure setmaxmodules;
var total, excess: integer;
begin
 fgotoxy(output, 30,6); write(cteol);
 if readint(maxmodules) then
   begin
   if maxmodules > 300000 then
     begin
     maxmodules := 38;
     escape(125);
     end;
   if maxmodules <= 0 then maxmodules := 0;
   outdirectsize := ((maxmodules+1)*entrysize+(blocksize-1)) div blocksize;
   maxmodules := outdirectsize*blocksize div entrysize - 1;
   end;
end;

procedure setreloc;
begin
 fgotoxy(output, 21,7); write(cteol);
 if readint(startreloc) then ;
end;

procedure setglobal;
begin
 fgotoxy(output, 21,8); write(cteol);
 if readint(startglobal) then ;
end;

procedure setcopyright;
begin
  fgotoxy(output, 0,12); write(cteol);
  fgotoxy(output, 22,11); write(cteol);
  readln(copyright);
end;

procedure makepatchspace;
var pmod:       addrec;
begin
 fgotoxy(output, 23,9); write(cteol);
 if readint(patchbytes) then
  if patchbytes > 0 then
   begin
   patchbytes := patchbytes + ord(odd(patchbytes));
   gbytes(pmod.a, sizeof(moduledescriptor,true));
   with pmod.mdp^ do
     begin
     patchmod := true;   patchsize := patchbytes;
     link := newmods;    newmods := pmod.mdp;
     patchlink := NIL;   patchlist := NIL;
     end;
   end;
end;

procedure setname;
var s: string80;
begin
 fgotoxy(output, 24,6); write(cteol);
 readln(s); trim(s);
 if strlen(s)=0 then newmodname.syp := NIL
 else
  begin
  upc(s);
  gbytes(newmodname.a, strlen(s)+2-ord(odd(strlen(s))));
  moveleft(s, newmodname.syp^, strlen(s)+1);
  end;
end;    {setname}

procedure openmod;
var s: string80;
    i: shortint;
begin
  verifying := false;   vmodnum := 0;
  fgotoxy(output, 18,18); write(cteol);
  readln(s); trim(s);
  if strlen(s) > 0 then
   begin
   upc(s);        i := 1;
   while (i <= fdirectory^[0].dnumfiles) and (vmodnum = 0) do
    with fdirectory^[i] do
     begin
     upc(dtid);
     if s = dtid then vmodnum := i
     else i:= i + 1;
     end;
   if vmodnum = 0 then
     begin
     errorline; write('module ''', s,''' not found in file');
     escape(123);
     end;
   end;
end;    {openmod}

procedure findmod(var s:filname; var n:shortint);
var i : integer;
begin
  if strlen(s)=0 then   { if no name given then get it }
  begin readln(s); trim(s); end;
  n:= 0;
  if strlen(s) > 0 then
  begin
    upc(s);        i := 1;
    while (i <= fdirectory^[0].dnumfiles) and (n = 0) do
      with fdirectory^[i] do
      begin
	upc(dtid);
	if s = dtid then n := i else i:= i + 1;
      end;
    if n = 0 then n:=-1;        { signal not found }
  end;
end;    { findmod }

procedure clear(N: shortint);
begin
  repeat writeln(cteol); n := n - 1; until n <= 0;
end;

procedure none;
begin write('(none)'); clear(1); end;

procedure doedit;
var
  firstmodname,untilmodname, oldvmodname : filname;
  firstmodnum, untilmodnum,  oldvmodnum  : integer;
  oldfilename: string80;
  modlist    : string255;
  assoc : boolean;
  lc    : string[4];
  tempf : filname;
  im    : shortint;

  procedure checkassoc;
  begin
    assoc:=assoc and (vmodnum>0);
    if assoc then
    begin firstmodname:=fdirectory^[vmodnum].dtid;
	  firstmodnum:=vmodnum;
	  assoc:=assoc and (firstmodnum<>untilmodnum);
    end;
  end;
  procedure outoforder;
  begin errorline; write('module ',tempf,' out of order'); dobeep;
  end;
  procedure mnotfound;
  begin errorline; write('module ',tempf,' not found'); dobeep;
  end;

begin   { doedit }
  untilmodname := '(end of file)';
  untilmodnum  := fdirectory^[0].dnumfiles+1;
  if vmodnum=0 then firstmodname:='(none)'
	       else firstmodname := fdirectory^[vmodnum].dtid;
  firstmodnum  := vmodnum;
  assoc := true;
  fgotoxy(output,0,2); write(cteos);
  repeat
    fgotoxy(output,0,2);
    writeln('S  Stop editing');
    clear(2);
    if firstmodnum>0 then
       writeln('C  Copy First module upto Until module',cteol)
    else clear(1);
    writeln('F  First module: ',firstmodname,cteol);
    writeln('U  Until module: ',untilmodname,cteol);
    clear(1);
    writeln('A  Append module(s)'); clear(5);
    fgotoxy(output,0,18);
    write('M  input Module:  ');
    if vmodnum = 0 then begin none; clear(3); end
    else
    begin
      writeln(fdirectory^[vmodnum].dtid,cteol);
      if booting then      lc := 'boot'
      else if linking then lc := 'link'
		      else lc := 'copy';
      writeln;
      writeln('T  Transfer (',lc,') module',cteol);
      writeln('<space> to continue verifying',cteol);
    end;
    getcommandchar('Edit option?',commandchar);
    case commandchar of
    'A':begin
	  oldfilename:= infilename;     { save current inputfile name }
	  oldvmodnum := vmodnum;        { same current module number & name }
	  oldvmodname := fdirectory^[vmodnum].dtid;
	  fgotoxy(output,0,13); write('        Input  file:  ',cteol);
	  setstrlen(infilename,0);
	  openin;       { get new input file }
	  if strlen(infilename)>0 then begin       { 3.0 BUG FIX -- 4/11/84 }
	    { get list of modules and copy them }
	    fgotoxy(output,0,10);
	    writeln('enter list of modules or = for all');
	    readln(modlist); trim(modlist); upc(modlist);
	    if modlist='=' then
	    begin { all modules }
	      for im:=1 to fdirectory^[0].dnumfiles do
	      begin
		fgotoxy(output,0,11); write(fdirectory^[im].dtid,cteol);
		copymodule(im);
	      end;
	    end
	    else
	    while strlen(modlist)>0 do
	    begin
	      im:=strpos(',',modlist);
	      if im=0 then im:=strlen(modlist)+1;
	      try
		if im>sizeof(tempf) then escape(129)
				   else tempf:=str(modlist,1,im-1);
		if im>strlen(modlist) then setstrlen(modlist,0)
				     else strdelete(modlist,1,im);
		if strlen(tempf)>0 then
		begin     { find the module and copy it }
		  findmod(tempf,vmodnum);
		  if vmodnum>0 then copymodule(vmodnum) else escape(123);
		  fgotoxy(output,0,11); write(modlist,cteol);
		end;
	      recover
	      begin
		im:=escapecode;  errorline;
		case im of
		  123: writeln('module ',tempf,' not found');
		  129: writeln('invalid module name');
		  otherwise escape(im)
		end; { case im }
		dobeep; setstrlen(modlist,0);     { zap module list to force exit }
	      end;{ end recover}
	    end;  {while list not empty}

	    if not streaming then                 { 3.0 bug fix -- 4/9/84 jws }
	      repeat getcommandchar('Append done, <space> to continue',commandchar);
	      until commandchar=' ';
	  end;                                    { 3.0 BUG FIX -- 4/11/84 }

	  infilename := oldfilename;
	  openin;       { reopen the old file & find old input module }
	  if oldvmodnum=0 then vmodnum:=0
	  else
	  begin
	    findmod(oldvmodname,vmodnum);
	    if (vmodnum<>oldvmodnum) then
	    begin errorline;
		  write('unable to find old input module ',oldvmodname);
		  vmodnum:=0; dobeep;
	    end;
	  end;
	end;
    'C':if (firstmodnum>0) and (firstmodnum<untilmodnum) then
	begin
	  for im:=firstmodnum to untilmodnum-1 do
	  begin fgotoxy(output,0,8);
		write('now copying ',fdirectory^[im].dtid,cteol);
		copymodule(im);
	  end;
	  if assoc then
	  begin
	    if untilmodnum>fdirectory^[0].dnumfiles
	       then begin vmodnum := 0;
			  firstmodname := '(none)';
		    end
	       else begin vmodnum := untilmodnum;
			  firstmodname := fdirectory^[vmodnum].dtid;
		    end;
	    firstmodnum  := vmodnum;
	    assoc:= assoc and (vmodnum>0);
	  end;
	end
	else dobeep;
    'F':begin
	  fgotoxy(output,17,6); write(cteol);
	  setstrlen(tempf,0); findmod(tempf,im);
	  case im of
	  -1: mnotfound;
	   0: { no module name given, so use default }
	      begin if (vmodnum>0) and (vmodnum<=untilmodnum) then
		begin firstmodname := fdirectory^[vmodnum].dtid;
		      firstmodnum  := vmodnum;
		      assoc := assoc and (vmodnum<untilmodnum);
		end
		else dobeep;
	     end;
	  otherwise     { found the module }
	    if im<=untilmodnum then
	    begin firstmodname := tempf; firstmodnum:=im; assoc:=false;
	    end
	    else outoforder;
	  end;  { case im }
	end;
    'M': if fdirectory<>NIL then
	 begin openmod;
	   if vmodnum>0 then begin        { 3.0 BUG # 57   4/10/84 }
	     assoc := assoc and (vmodnum<untilmodnum);
	     if assoc then
	     begin
	       firstmodname := fdirectory^[vmodnum].dtid;
	       firstmodnum  := vmodnum;
	     end;
	   end                            { 3.0 BUG # 57   4/10/84 }
	   else dobeep                    { 3.0 BUG # 57   4/10/84 }
	 end
	 else dobeep;
    'S':;
    'T': if vmodnum>0 then
	 begin xfer; checkassoc;
	 end
	 else dobeep;
    'U':begin
	  fgotoxy(output,17,7); write(cteol);
	  setstrlen(tempf,0); findmod(tempf,im);
	  case im of
	  -1: mnotfound;
	   0: { no module name given, so default }
	      begin untilmodname := '(end of file)';
		    untilmodnum  := fdirectory^[0].dnumfiles+1;
	      end;
	  otherwise     { found the module }
	      if im>=firstmodnum then
	      begin untilmodname := tempf; untilmodnum:=im;
	      end
	      else outoforder;
	      assoc := assoc and (im>firstmodnum);
	  end;  { case im }
	end;
    ' ': if vmodnum>0 then
	 begin verifynext; checkassoc;
	 end
	 else dobeep;
    otherwise dobeep
    end;
  until commandchar='S';
end;    {doedit}

procedure finishboot;
begin
close(outfile, 'LOCK');
if ioresult<>0 then escape(126);
outopen := false; booting := false;
outmodnum := 0;
end;

procedure menu;
var lc: string[4];
begin
 fgotoxy(output, 0,2); write('Q  Quit'); clear(1);

 write('P  Printout  ');
 if printopen then
   begin
   if printeron then write('ON   ')
		else write('OFF  ');
   write(listfilename);
   clear(1);
   end
 else none;

 if outmodnum > 0 then write('K  Keep o')
 else if (newmods = NIL) and not booting
		  then write('O       O')
		  else write('        o');
 write('utput file:  ');
 if outopen then writeln(outfilename,cteol)
	    else none;
 if outopen then
  begin
  if booting then write('B  finish Boot')
  else if newmods <> NIL then write('L  finish Linking')
  else if linking then write('C  Copy')
  else write('L  Link');
  write(cteol); fgotoxy(output, 40,5);
  if booting then      begin
		       writeln('BOOTING');
		       lc := 'boot';
		       end
  else if linking then begin
		       writeln('LINKING');
		       lc := 'link';
		       end
  else                 begin
		       writeln('COPYING');
		       lc := 'copy';
		       end;
  end
 else
  begin
   writeln('B  write to Boot disk',cteol);
   writeln('H  file Header maximum size:  ',maxmodules,cteol);
  end;

 if linking and outopen then
  begin
  write('N  Name of new module:  ');
  if newmodname.syp = NIL then none
  else writeln(newmodname.syp^,cteol);
  writeln('R  Relocation base:  ',startreloc:12,cteol);
  writeln('G  Global base:      ',startglobal:12,cteol);
  write  ('S  Space for patches:');
  if patchbytes > 0 then writeln(patchbytes:12)
  else clear(1);
  patchbytes := 0;
  write('D  output Def table?  ');
  if defsout then write('YES')
  else write('NO ');
  writeln(cteol);
  writeln('X  copyright notice:  ',copyright);
  end
 else clear(7);

 fgotoxy(output, 0,13);
 write('I       Input  file:  ');
 if fdirectory = NIL then
  begin none; clear(7); end
 else
  begin
  writeln(infilename,cteol);
  if outopen then writeln('E  Edit') else clear(1);
  writeln('F  list File directory');
  if outopen then writeln('A  ',lc,' All modules') else clear(1);
  write('V  Verify modules');
  if verifying then
    begin
    fgotoxy(output, 40,17); writeln('VERIFYING');
    end
  else clear(1);
  write('M  input Module:  ');
  if vmodnum = 0 then
    begin none; clear(3); end
  else
    begin
    writeln(fdirectory^[vmodnum].dtid,cteol);
    writeln('U  Unassemble object');
    if outopen then writeln('T  Transfer (',lc,') module')
    else clear(1);
    if verifying then writeln('<space> to continue verifying')
    else clear(1);
    end;
  end;
end; {menu}

procedure getcommand;
var err: string[80];
begin
  repeat
  try
  menu;
  getcommandchar('command?',commandchar);
  case commandchar of
   'A': if (fdirectory<>NIL) and  outopen then copyfile else dobeep;
   'B': if booting then finishboot
	else if outopen then dobeep
	else openout(true);
   'C': if outopen and linking and (newmods = NIL)
	and not booting then copyon else dobeep;
   'D': if linking and outopen
	then defsout := not defsout else dobeep;
   'E': if (fdirectory<>NIL) and outopen then doedit else dobeep;
   'F': if fdirectory<>NIL then printdirectory else dobeep;
   'G': if linking and outopen then setglobal else dobeep;
   'H': if outopen then dobeep else setmaxmodules;
   'I': begin setstrlen(infilename,0); openin; end;
   'K': if (outmodnum > 0) and not booting
	then closeout else dobeep;
   'L': if booting then dobeep
	else if newmods <> NIL then link
	else if outopen and not linking
	then initlink else dobeep;
   'M': if fdirectory<>NIL then openmod else dobeep;
   'N': if linking and outopen then setname else dobeep;
   'O': if (outmodnum = 0) and (newmods=NIL) and not booting
	then openout(false) else dobeep;
   'P': toggleprinter;
   'Q': quit;
   'R': if linking and outopen then setreloc else dobeep;
   'S': if linking and outopen then makepatchspace else dobeep;
   'T': if (vmodnum > 0) and outopen then xfer else dobeep;
   'U': if (vmodnum > 0) then unassemble else dobeep;
   'V': if fdirectory<>NIL then verifymod else dobeep;
   'X': if linking and outopen then setcopyright else dobeep;
   ' ': if verifying then verifynext;

  otherwise dobeep;
  end;

  recover
   begin
   if (escapecode <> -20) and (escapecode <> 123) and (escapecode<>128)
								then errorline;
   if escapecode=-10 then begin getioerrmsg(err, ires); writeln(err); end
   else case escapecode of
    110: write('symbols defined recursively');
    111: write('improper link info format');
    112: write('not enough memory');
    113: write('output file full');
    114: write('error writing to boot disk, ioresult = ',ires:1);
    116: write('''', infilename, ''' is not a code file');
    118: write('printer or list file not on line');
    119: write('duplicate symbol definition');
    120: write('module being booted has external references');
    121: write('unexpected end of code');
    122: write(errors:1, ' errors during linking',cteol);
    123,128,129: {error message already printed};
    124: write('integer required');
    125: write('integer too large');
    126: write('unable to close output, ioresult = ',ires:1);
    127: write('file header full');
    otherwise escape(escapecode);
    end; {case escapecode}
    if streaming then escape(-1);
    if (escapecode-100) in [12,16] then closein;
    if (escapecode-100) in [10..13,19,22,26,28] then
      begin
      if newmods <> NIL then begin closein; closefiles; end;
      linking := false;     newmods := NIL;
      if outopen then close(outfile);
      outopen := false;     outmodnum := 0;
      booting := false;
      lowheap := lowheap0;
      end;
   end; {recover}
  until commandchar = 'Q';
end {getcommand};


procedure wrapup;
begin
 pageeject;
 closein;
 closefiles;
 if (pagenum=0) and (linenum=0)
   then close(listing)
   else close(listing, 'lock');
end; {wrapup}

begin {program linker}
  with linkerdate do
    begin day := 28; year := 91; month := 10; end;
  sysdate(todaysdate);

  pagenum := 0;         linenum := 0;

  fgotoxy(output, 0,0);
  printheader(output);
  fgotoxy(output, 0, 22);
  writeln('Copyright Hewlett-Packard Company, 1982, 1991.');

  mark(lowheap.p); lowheap0 := lowheap;
  highheap.a := lowheap.a + memavail - 5000;
  release(highheap.p); highheap0 := highheap;

  listfilename := 'PRINTER:LINK.ASC';
  rewrite(listing, listfilename);
  printopen := ioresult = 0;
  printeron := false;

  patchbytes := 0;
  maxmodules := 38;     outdirectsize := 2;
  linking := false;     newmods := NIL;
  outopen := false;     outmodnum := 0;
  booting := false;     verifying := false;
  fdirectory := NIL;    vmodnum := 0;
  loadfib.php := NIL;

  try getcommand;

  recover begin
	  esccode := escapecode;
	  wrapup;
	  escape(esccode);
	  end;

  wrapup;

end.
@


55.2
log
@
pws2rcs automatic delta on Mon Nov  4 13:45:04 MST 1991
@
text
@@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.25A ');
d4853 1
a4853 1
    begin day := 12; year := 91; month := 08; end;
@


54.3
log
@
pws2rcs automatic delta on Wed Aug 21 12:27:56 MDT 1991
@
text
@@


54.2
log
@
pws2rcs automatic delta on Wed Aug 21 09:35:48 MDT 1991
@
text
@d1 4890
@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@a0 4890
					       (*

 (c) Copyright Hewlett-Packard Company, 1985,1991.
All rights are reserved.  Copying or other
reproduction of this program except for archival
purposes is prohibited without the prior
written consent of Hewlett-Packard Company.


	    RESTRICTED RIGHTS LEGEND

Use, duplication, or disclosure by the Government
is subject to restrictions as set forth in
paragraph (b) (3) (B) of the Rights in Technical
Data and Computer Software clause in
DAR 7-104.9(a).

HEWLETT-PACKARD COMPANY
Fort Collins, Colorado                         *)


$MODCAL,debug off,iocheck off,range off,ovflcheck off$ $ref 60$
$ALLOW_PACKED ON$ {JWS 3/31/87}

program linker(input, output, keyboard);


import sysglobals,fs,loader,ldr,asm,sysdevs,ci,misc;


const   pagelines = 63;
	pageblocks = 2;
	entrysize = 26;

type    address = integer;
	point = ^integer;

var     keyboard:       text;
	todaysdate:     daterec;
	linkerdate:     daterec;
	tempstring:     string[12];
	gvaluestring:   string80;
	copyright,
	listfilename:   string80;
	listing:        text;
	pagenum,
	linenum:        shortint;
	linking,booting,
	outopen,
	verifying,defsout,
	printopen,
	printeron:      boolean;
	commandchar: char;
	startgvr:       addrec;
	startgvrmod:    moddescptr;
	modsave:        moddescptr;
	infost:         addrec;

	ires:   integer;        {saved ioresult}
	errors: integer;
	esccode: integer;
	lowheap0,highheap0: addrec;

	infilename:     string80;
	vmodnum:        shortint;

	{output file information: }
	outdirectory:   addrec;         {new library directory pointer}
	outfile:        phyle;          {file being written}
	firstoutblock,
	outblock:       integer;        {next block within library to write}
	nextblock:      integer;        {next block within module to write}
	outfilename:    string80;
	outmodnum:      integer;        {number of modules created so far}
	outdirectsize,
	maxmodules:     integer;

	{linker information:  }
	totalpatchspace: integer;       {bytes of patch space}
	patchbytes:     integer;
	backwardpatches,
	forwardpatches: moddescptr;
	newmodname:     addrec;         {new name for linked module}
	infostart:      addrec;         {pointer to bottom of linker memory}
	newexttable:    address;        {location of new EXT table}
	newextsize:     integer;        {size in bytes of EXT table}
	newdirectory:   addrec;         {pointer to new module directory}
	loadgvr:        gvrptr;
	modulepc:       integer;        { module body entry point }

procedure dobeep;
begin beep;if streaming then escape(-1); end;

procedure errorline;
begin ires := ioresult; fgotoxy(output, 0, 22); write(bellchar, cteol); end;

procedure ioerror;
begin write(' ioresult = ',ires:1); escape(123); end;

procedure getcommandchar(s:string80; var c:char);
begin
  fgotoxy(output,0,23); write(s,cteol);
  read(keyboard,c);
  fgotoxy(output,0,22); writeln(cteol);write(cteol);
  if (c>='a') and (c<='z') then c:= chr(ord(c)-32);
end;

procedure writedate(var f:  text;  date: daterec);
type months = packed array[0..35] of char;
const monthname = months['JanFebMarAprMayJunJulAugSepOctNovDec'];
var i,j: shortint;
begin
with date do
  begin
  {LAF 880101 added "mod 100" and removed test for "year<100"}
  if (month in [1..12]) and (day>0) then
    begin { Valid date }
    write(f, day:2, '-');
    j := (month - 1) * 3;
    for i := j to j+2 do write(f, monthname[i]);
    write(f, '-',year mod 100:2);
    end
  else write(f, '<no date>'); { Invalid date }
  end;
end; {datestring}

procedure gbytes(var p: integer; size: integer);
begin
 p := lowheap.a;        lowheap.a := lowheap.a + size;
 if lowheap.a > highheap.a then escape(112);
end;

procedure blockwrite(anyvar f: fib; anyvar obj: window; blocks,block: integer);
begin
  call (f.am, addr(f), writebytes, obj, blocks*fblksize, block*fblksize);
  if ioresult <> ord(inoerror) then escape(113);
end;

procedure readblocks(var f: fib; anyvar obj: window; size, block: integer);
begin
  call (f.am, addr(f), readbytes, obj, size, block*fblksize);
  if ioresult <> ord(inoerror) then escape(-10);
end;

procedure gvrstring(var gvp:gvrptr; var val:integer; pcrel,nores: boolean);

(*advances g past the GVR, adds any absolute part to VAL,
  and constructs a string representing the GVR in gvaluestring          *)

type
  rpp = ^referenceptr;
var
  Rcount:       shortint;
  done:         boolean;
  g:            gvrptr;
  i:            integer;

procedure sign(sub: boolean);
begin
 if sub then sappend(gvaluestring,'-')
 else if strlen(gvaluestring)>0 then sappend(gvaluestring,'+');
end;

begin {gvrstring}
 gvaluestring := '';       Rcount := 0;
 repeat
 if pcrel then g := loadgvr
	  else g := gvp;
 if g <> NIL then with g^ do
  begin
  if longoffset then
    g:=gvrptr(integer(g)+sizeof(generalvalue,true))
  else
    g:=gvrptr(integer(g)+sizeof(generalvalue,false));
  if valueextend then
    begin
    if not pcrel then val:= val + veptr(g)^.value;
    g:=gvrptr(integer(g)+sizeof(valueextension,sint));
    end;
  case primarytype of
   absolute: {no more value};
   relocatable: Rcount := Rcount + 1;
   global: begin sign(false); sappend(gvaluestring,'Gbase'); end;
   general:
    begin
    done := false;
    repeat with rpp(g)^ do
      begin
       if adr=0 then
	 if op=addit then Rcount := Rcount + 1
	 else Rcount := Rcount - 1
       else if adr=1 then
	 begin sign(op=subit); sappend(gvaluestring,'Gbase'); end
       else
	 begin sign(op=subit);
	 if newmods^.unresbits.bmp^[adr] or nores
	     then sappend(gvaluestring,symbolptr(newexttable+4*adr)^)
	     else sappend(gvaluestring,symbolptr(point(newexttable+4*adr)^)^);
	 end;
      done := last;
      g := gvrptr(integer(g)+sizeof(referenceptr));
      end;
    until done;
    end; {general}
   end; {primarytype cases}
  if not pcrel then gvp := g;
  end; {with g^}
 pcrel := not pcrel;
 until pcrel;
 while Rcount <> 0 do
  begin sign(Rcount<0); sappend(gvaluestring,'Rbase');
	if Rcount < 0 then Rcount := Rcount + 1
	else Rcount := Rcount - 1;
  end;
 if (val <> 0) or (strlen(gvaluestring)=0) then
  begin
  if val >= 0 then sign(false);
  strwrite(gvaluestring,strlen(gvaluestring)+1,i,val:1);
  end;
end; {gvrstring}


procedure printheader(var f: text);
var time: timerec;
begin
 write(f,'Librarian  [Rev.  3.24 ');
 if ioresult <> 0 then
   begin
   printopen := false;
   printeron := false;
   escape(118);
   end;
 writedate(f, linkerdate);
 write(f,']',' ':7);
 writedate(f, todaysdate);
 systime(time);
 with time do write(f, hour:4,':',minute:2,':',centisecond div 100:2);
 if pagenum > 0 then write(f,'page ':10,pagenum:1);
 writeln(f);
 writeln(f);
end;

procedure pageeject;
var i: integer;
begin
 if linenum > 0 then page(listing);
 linenum := 0;
end;

procedure list;
begin
  if linenum >= pagelines then pageeject;
  if linenum = 0 then
    begin
    pagenum := pagenum + 1;
    printheader(listing);
    linenum := linenum + 2;
    end;
  linenum := linenum + 1;
end;

procedure listln;
begin writeln(listing); linenum := linenum + 1;
end;

procedure quit;
var ch: char;
begin
  if (outopen and (outmodnum>0)) or
     (booting and (outblock>0)) then
  begin
  errorline;
  if booting then writeln('WARNING:  You didn''t finish booting')
  else writeln('WARNING:  You didn''t ''Keep'' the output file.');
  if streaming then escape(123)
  else
    begin
    write('Are you sure you want to quit?  (type Y if yes)  ');
    read(keyboard, ch);
    if (ch<>'y') and (ch<>'Y') then commandchar := ' ';
    end;
  end;
end;

function readint(var value: integer): boolean;
var s: string80;
    i: integer;
begin
  readln(s);
  strread(s,1,i,value);
  if ioresult<>ord(inoerror) then
    if i <= strlen(s) then escape(124);
  readint := ioresult=ord(inoerror);
end;

procedure unassemble;

type hex = 0..15;
     htoctyp = array[0..15] of char;
     decodestatetype = (consts,code,abscode,startcase,casetable,
			endofproc,quittype,notype,phdr);

const htoc = htoctyp['0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'];

var
  nilgvr:       gvrptr;
  dumped:       boolean;
  fortranflag:  boolean;
  rangetype: (norange, pcrange, linerange);
  lowrange, highrange, lastline: integer;
  decodestate,oldstate: decodestatetype;
  PC,tablePC,casecodestart: integer;
  codecount: integer; {bytes left in current inbuf}
  codeindex: integer; {next byte of code in inbuf}
  instrsize: 0..22;  {byte count of current instruction}
  refgvr: addrec;       reflim,refloc: address;
  inbuf,refptr: addrec;

procedure dumpmod (mp:moddescptr);
var junkint:    integer;
    producername: string[30];
    textstep: addrec;
    modulename: string255;      { rdq }
    def       : addrec;         { rdq }
    done      : boolean;        { rdq }

begin {dumpmod}
 dumped := true;
 with mp^,directory.drp^ do
  begin
  pageeject;
  textstep.a:=directory.a+sizeof(moduledirectory);
  list; write(listing,'MODULE    ');
  modulepc := -2;  { rdq }  { no module body }
  modulename := textstep.syp^; { rdq }
  if strlen(modulename) = 0 then write(listing,'(no name)')
  else
    begin
    write(listing,modulename);
    modulepc := -1;
    end;
  modulename := modulename+' '+modulename; { rdq } { make module entrypoint symbol }
  write(listing,'    Created ');
  writedate(listing, date); writeln(listing);
  list; write(listing,'NOTICE:  ');
  if strlen(notice)=0 then writeln(listing,'(none)')
		      else writeln(listing,notice);
  fortranflag := (producer = 'F');
  case producer of
    'M': producername := 'Modcal Compiler';
    'P': producername := 'Pascal Compiler';
    'L': producername := 'Librarian';
    'F': producername := 'FORTRAN Compiler';
    'B': producername := 'BASIC Compiler';
    'A': producername := 'Assembler';
    'C': producername := '''C'' Compiler';
    'D': producername := 'Ada Compiler';
    otherwise producername := '" "';
	      producername[2] := producer;
    end;
  list; write(listing,'  Produced by ', producername, ' of ');
  writedate(listing,revision); writeln(listing);
  if systemid = 0 then systemid := 1;
  list; writeln(listing,'  Revision number ',systemid:1);
  list; writeln(listing,'  Directory size ',directorysize:6,' bytes');
  list; writeln(listing,'  Module size    ',modulesize:6,' bytes');
  junkint:=strlen(textstep.syp^);
  textstep.a := textstep.a+junkint+2-ord(odd(junkint));
  if executable then
    begin
    startgvr := textstep;
    junkint := 0;
    modulepc := -2; { rdq executable so no 'module body' }
    gvrstring(textstep.gvp,junkint,false,false);
    list; writeln(listing,'  Execution address    ',gvaluestring);
    end
  else
    begin
    startgvr.gvp:=NIL;
    list; writeln(listing,'  Module NOT executable');
    end;
  list; writeln(listing,'  Code base      ',relocatablebase,
			'     Size ',relocatablesize,' bytes');
  list; writeln(listing,'  Global base    ',globalbase,
			'     Size ',globalsize,' bytes');
  if extsize <= 8 then extsize := 0;
  list; writeln(listing,'  EXT    block ',extblock:3,'     Size ',extsize,
	     ' bytes');
  list; writeln(listing,'  DEF    block ',defblock:3,'     Size ',defsize,
	     ' bytes');
  list;

  if (defsize>0) and (modulepc>-2) then       {RDQ}
  begin { find the module entry point }
    def:=defaddr;
    done:=false;
    REPEAT
      if def.a >= defaddr.a + defsize then done:=true
      else
      begin
	if def.syp^=modulename then
	begin { foundit now get its value }
	  done:=true;
	  def.a := def.a + strlen(def.syp^)+2-ord(odd(strlen(def.syp^)));
	  junkint:=0;
	  gvrstring(def.gvp,junkint,false,false);
	  strread(gvaluestring,7,junkint,modulepc);
	end
	else
	begin { advance to the next symbol }
	  def.a := def.a + strlen(def.syp^)+2-ord(odd(strlen(def.syp^)));
	  def.a := def.a + def.gvp^.short;
	end;
      end;
    UNTIL done;
  end;

if sourcesize <> 0 then
      writeln(listing,'  EXPORT block ',sourceblock:3,'     Size ',
	      sourcesize,' bytes')
  else
    writeln(listing,'  No EXPORT text');
  list; writeln(listing,'  There are ',textrecords,' TEXT records');
  listln; listln;
  end; {with mp^,directory^}
end; {dumpmod}

procedure prepunassem;
var i: integer;
begin
  modsave := newmods;
  newmods := NIL;
  infost  := lowheap;
  loadinfo(vmodnum, true, true);
  with newmods^,directory.drp^ do
   begin
   newexttable := extaddr.a;
   gbytes(unresbits.a, ((extsize div 4 + 15) div 16)*2);
   for i := 2 to extsize div 4 - 1 do unresbits.bmp^[i] := false;
   for i := 2 to listsize-1 do unresbits.bmp^[listaddr^[i] div 4] := true;
   end;
  if not dumped then dumpmod(newmods);
end;

procedure nextref;
begin
if refgvr.a < reflim then
  if refgvr.gvp^.longoffset then
    refloc:=refloc+refgvr.gvp^.long
  else
    refloc:=refloc+refgvr.gvp^.short;
end;

procedure listinstruction;
type
  regtype  = (D,A);
  regrange = 0..7;
  siz = (bytesiz,wordsiz,longsiz,invalid);
  opsizetype = array[bytesiz..longsiz] of string[3];
  exttype =
	packed record
	  case integer of
	    1: (uwordext: 0..65535);
	    2: (wordext: shortint);
	    3: (longext: integer);
	    4: (regclass: regtype;
		reg: regrange;
		long: boolean;
		scale : 0..3;
		case fullindex : boolean of
		  false: (case integer of
			   1: (byteext: -128..127);
			   2: (ubyteext: 0..255));
		  true:  (exbs : boolean;
			  exis : boolean;
			  exbdsize : 0..3;
			  expadbit : boolean;
			  exindirect : 0..7));
	    5: (mask: packed array [0..15] of boolean);
	    6: (bf_bit  : 0..1;
		bf_reg  : 0..7;
		bf_Do   : boolean;
		bf_offset : 0..31;
		bf_Dw   : boolean;
		bf_width  : 0..31);
	    7: (exDAbit1 : 0..1;
		exRn1  : 0..7;
		expad1 : 0..7;
		exDu1  : 0..7;
		expad2 : 0..7;
		exDc1  : 0..7;
		exDAbit2 : 0..1;
		exRn2  : 0..7;
		expad3 : 0..7;
		exDu2  : 0..7;
		expad4 : 0..7;
		exDc2  : 0..7);
	    8: (fopclas : 0..7;
		frx : 0..7;
		fry : 0..7;
		case integer of
		  0: (fextension : 0..127);
		  1: (fext : 0..15;
		      sincosreg : 0..7);
		  2: (Kfactor : -64..63);
		  3: (KDreg : 0..7;
		      zeros : 0..15));
	    end;


const       opsize = opsizetype['.b ','.w ','.l '];

var
  hexout: packed array[0..10,0..3] of hex;
  firstline: boolean;  { 1st line of current instruction? }
  bytesleft: 0..22;    { to be listed in current instr }
  instrbuf: string[255];{ alpha form of instruction }

  instr: packed record case integer of
	   1: (opcode: 0..15;
	       case integer of
		 1: (cond: 0..15;
		     displ: -128..127);
		 2: (reg1: regrange;
		     opmode: 0..7;
		     eamode: 0..7;
		     eareg: regrange);
		 3: (dummy: 0..7;
		     bit8: boolean;
		     size: siz;
		     fpredicate: 0..63)
	      );
	   3: (w: shortint);
	   4: (lb, rb: byte);
	   end; {instr}

  ext: exttype;
  procedure emitint(val: integer);
  var i: integer;
  begin
    strwrite(instrbuf, strlen(instrbuf)+1, i, val:1);
  end;

  procedure comma;
  begin  sappend(instrbuf, ','); end;

  procedure space;
  begin  sappend(instrbuf, ' '); end;

  procedure printinstrword;
  var k: integer;
  begin write(listing,' ');
    for k := 0 to 3 do
      write(listing,htoc[hexout[(instrsize-bytesleft) div 2,k]]);
    bytesleft := bytesleft-2;
  end;

  procedure getinstrbytes(size: shortint);
  begin
  if codecount < size then escape(121);
  moveleft(inbuf.stp^[codeindex],ext,size);
  moveleft(ext,hexout[instrsize div 2],size);
  instrsize := instrsize+size;
  codeindex := codeindex+size;
  codecount := codecount-size;
  end;

  procedure getinstruction;
  begin
  instrsize := 0;
  getinstrbytes(2);     instr.w := ext.wordext;
  end;

  procedure defineword;
  begin
  instrbuf := 'dc.w ';
  with instr do
    begin
    emitint(w);
    while strlen(instrbuf) < 11 do space;
    sappend(instrbuf,'   or dc.b ');
    emitint(lb); comma; emitint(rb);
    while strlen(instrbuf) < 30 do space;
    sappend(instrbuf,'   or dc.b ''  ''');
    if (lb >= 32) and (lb < 127) then instrbuf[43] := chr(lb);
    if (rb >= 32) and (rb < 127) then instrbuf[44] := chr(rb);
    end;
  end;

  procedure extend(size: integer; pcrel: boolean; fudge: integer);
    var offset, location, PCtemp: integer;
    begin
      location := PC+instrsize;
      if size = 1 then {byte extension}
	begin
	PCtemp := location + 1;
	size := 2;
	end
      else PCtemp := location;

      while (refgvr.a<reflim) and (refloc<PCtemp) do
	begin
	offset := 0;
	gvrstring(refgvr.gvp,offset,false,false);
	nextref;
	end;

      getinstrbytes(size);
      if odd(PCtemp)   then offset := ext.byteext
      else if size = 2 then offset := ext.wordext
		       else offset := ext.longext;
      if pcrel then offset := offset + location + fudge;
      if refloc=PCtemp then
	begin
	gvrstring(refgvr.gvp,offset,pcrel,false) ;
	nextref;
	end
      else
	gvrstring(nilgvr,offset,pcrel,false);
      sappend(instrbuf,gvaluestring);
    end;

  procedure unsigned_byte_extend;
    var offset, location, PCtemp: integer;
    begin
      location := PC+instrsize;
      PCtemp := location + 1;

      while (refgvr.a<reflim) and (refloc<PCtemp) do
	begin
	offset := 0;
	gvrstring(refgvr.gvp,offset,false,false);
	nextref;
	end;

      getinstrbytes(2);
      offset := ext.ubyteext;
      if refloc=PCtemp then
	begin
	gvrstring(refgvr.gvp,offset,false,false) ;
	nextref;
	end
      else
	gvrstring(nilgvr,offset,false,false);
      sappend(instrbuf,gvaluestring);
    end;

  procedure decode;
  label 1,2;
  type
    opndtype = (source,dest);
    regsymtype = array[regtype] of string[1];
    extsiztype = array[bytesiz..longsiz] of 1..4;
    arithoptype = array[8..13] of string[3];

    condcodetype = array[0..15] of string[2];

  const
    SP = 7;

    regsym = regsymtype['d','a'];
    extsize = extsiztype[1,2,4];

    condcode = condcodetype['t','f','hi','ls','cc','cs','ne','eq',
			    'vc','vs','pl','mi','ge','lt','gt','le'];
    arithop = arithoptype['or','sub','','cmp','and','add'];

  var
    tempint,I : integer;
    bf_reg : 0..7;
    bf_Do : boolean;
    bf_offset : 0..31;
    bf_Dw : boolean;
    bf_width : 0..32;

    procedure osize;
    var size: siz;
    begin size := instr.size;
    if size = invalid then goto 2;
    sappend(instrbuf, opsize[size])
    end;

    procedure emitdir(regclass: regtype; reg: regrange);
    begin if (regclass = A) and (reg = SP) then sappend(instrbuf,'sp')
	  else begin
	       sappend(instrbuf,regsym[regclass]);
	       setstrlen(instrbuf, strlen(instrbuf) + 1);
	       instrbuf[strlen(instrbuf)] := htoc[reg];
	       end;
    end;

    procedure emitardef(reg: regrange);
    begin sappend(instrbuf,'(');
	  emitdir(A,reg);
	  sappend(instrbuf,')');
    end;

    procedure emitardisp(reg: regrange);
    begin extend(2,false,0);
	  emitardef(reg);
    end;

    procedure emitpostincr(reg: regrange);
    begin emitardef(reg);
	  sappend(instrbuf, '+');
    end;

    procedure emitpredecr(reg: regrange);
    begin sappend(instrbuf, '-');
	  emitardef(reg);
    end;

    procedure emitindx(pcrel: boolean);
      var
	I : integer;
	saveext : exttype;
    begin
    moveleft(inbuf.stp^[codeindex],ext,2); { fake 'getinstrbytes(2)' }
    if not ext.fullindex then
      if ext.scale = 0 then
	begin
	extend(1,pcrel,0); sappend(instrbuf, '(');
	with instr, ext do
	  begin
	  if not pcrel then
	    begin emitdir(A, eareg); comma; end;
	  emitdir(regclass,reg);
	  if long then sappend(instrbuf,'.l)')
		  else sappend(instrbuf,'.w)');
	  end;
	end
      else
	begin
	sappend(instrbuf,'(');
	extend(1,pcrel,0);
	if pcrel then
	  sappend(instrbuf,',')
	else
	  strwrite(instrbuf,strlen(instrbuf)+1,I,',a',instr.eareg:1,',');
	emitdir(ext.regclass,ext.reg);
	if ext.long then sappend(instrbuf,'.l')
		    else sappend(instrbuf,'.w');
	case ext.scale of
	  1: sappend(instrbuf,'*2)');
	  2: sappend(instrbuf,'*4)');
	  3: sappend(instrbuf,'*8)');
	end;
	end
    else { fullindex }
      begin
      getinstrbytes(2);  { Now do this for real }
      if ext.exindirect <> 0 then sappend(instrbuf,'([')
			     else sappend(instrbuf,'(');
      saveext := ext;
      case saveext.exbdsize of
	0: goto 2;
	1: ;
	2: extend(2,pcrel and (not saveext.exbs),-2);
	3: extend(4,pcrel and (not saveext.exbs),-2);
      end;
      if not saveext.exbs then
	begin
	if not pcrel then
	  begin
	  if (instrbuf[strlen(instrbuf)] <> '(') and
	     (instrbuf[strlen(instrbuf)] <> '[') then
	    comma;
	  strwrite(instrbuf,strlen(instrbuf)+1,I,'a',instr.eareg:1);
	  end
	else if (saveext.exbdsize = 1) { suppress displacement ? } then
	  sappend(instrbuf,'PC');
	end
      else
	if pcrel then
	  begin
	  if (instrbuf[strlen(instrbuf)] <> '(') and
	     (instrbuf[strlen(instrbuf)] <> '[') then
	    comma;
	  sappend(instrbuf,'ZPC')
	  end;
      if saveext.exindirect in [5,6,7] then
	sappend(instrbuf,']');
      if not saveext.exis then
	begin
	if (instrbuf[strlen(instrbuf)] <> '(') and
	   (instrbuf[strlen(instrbuf)] <> '[') then
	  comma;
	emitdir(saveext.regclass,saveext.reg);
	if saveext.long then sappend(instrbuf,'.l')
			else sappend(instrbuf,'.w');
	case saveext.scale of
	  0: ;
	  1: sappend(instrbuf,'*2');
	  2: sappend(instrbuf,'*4');
	  3: sappend(instrbuf,'*8');
	end;
	end;
      if saveext.exindirect in [1,2,3] then
	sappend(instrbuf,']');
      case saveext.exindirect of
	0,1,4,5: ;
	2,6: begin
	     if (instrbuf[strlen(instrbuf)] <> '(') and
		(instrbuf[strlen(instrbuf)] <> '[') then
	       comma;
	     extend(2,false,0);
	     end;
	3,7: begin
	     if (instrbuf[strlen(instrbuf)] <> '(') and
		(instrbuf[strlen(instrbuf)] <> '[') then
	       comma;
	     extend(4,false,0);
	     end;
      end;
      sappend(instrbuf,')');
      end;
    end;

    procedure emitimm(val: integer);
    begin
      sappend(instrbuf,'#'); emitint(val);
    end;

    procedure immediate(fsize: siz);
    begin
      if fsize = invalid then goto 2;
      sappend(instrbuf,'#');
      extend(extsize[fsize],false,0);
    end; {immediate}

    procedure emitea(fsize: siz);
    begin
      with instr do
	case eamode of
      0: emitdir(D,eareg);
      1: emitdir(A,eareg);
      2: emitardef(eareg);
      3: emitpostincr(eareg);
      4: emitpredecr(eareg);
      5: emitardisp(eareg);
      6: emitindx(false);
      7: case eareg of
	0: extend(2,false,0);
	1: extend(4,false,0);
	2: extend(2,true,0);
	3: emitindx(true);
	4: immediate(fsize);
	5..7: goto 2;
	 end; {case eareg}
       end; {case eamode}
    end; {emitea}

    procedure opcode0;
      { bit, MOVEP, immediate, MOVES }

    type bitoptype = array[siz] of string[5];
	 immoptype = array[0..6] of string[4];
    const bitop = bitoptype['btst ','bchg ','bclr ','bset '];
	  immop = immoptype['ori','andi','subi','addi','','eori','cmpi'];
    var
      I : integer;
      regsave : 0..7;

    begin { opcode0 }
      with instr do
	if bit8 then
	  if eamode = 1 then
	    begin
	      if odd(opmode) then instrbuf := 'movep.l '
			     else instrbuf := 'movep.w ';
	      if opmode <= 5 then
		begin emitardisp(eareg);
		  comma; emitdir(D,reg1);
		end
	      else begin
		   emitdir(D,reg1);
		   comma; emitardisp(eareg);
		   end;
	    end
	  else begin {dynamic bit}
		 instrbuf := bitop[size];
		 emitdir(D,reg1);
		 comma; emitea(bytesiz);
	       end
	else if reg1=4 then
	  begin instrbuf := bitop[size];
	    immediate(bytesiz); comma;
	    emitea(bytesiz {invalid});
	  end
	else { NOT bit8 } if ord(size) = 3 then
	  if (reg1 > 4) {bit 11 on} then
	    if (eamode = 7) and (eareg = 4) then {cas2}
	      begin
	      case reg1 of
		5: instrbuf := 'cas2.b ';
		6: instrbuf := 'cas2.w ';
		7: instrbuf := 'cas2.l ';
	      otherwise ;
	      end;
	      getinstrbytes(4);
	      strwrite(instrbuf,strlen(instrbuf),I,
				' d',ext.exDc1:1,':d',ext.exDc2:1,
				',d',ext.exDu1:1,':d',ext.exDu2:1,',(');
	      if ext.exDAbit1 = 0 then sappend(instrbuf,'d ')
				  else sappend(instrbuf,'a ');
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exRn1:1,'):(');
	      if ext.exDAbit2 = 0 then sappend(instrbuf,'d ')
				  else sappend(instrbuf,'a ');
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exRn2:1,')');
	      end
	    else {cas}
	      begin
	      case reg1 of
		5: instrbuf := 'cas.b d ';
		6: instrbuf := 'cas.w d ';
		7: instrbuf := 'cas.l d ';
		otherwise ;
	      end;
	      getinstrbytes(2);
	      strwrite(instrbuf,strlen(instrbuf),I,ext.exDc1:1,',d',
						   ext.exDu1:1,',');
	      emitea(bytesiz);
	      end
	  else if reg1 < 3 then {chk2 cmp2}
	    begin
	    getinstrbytes(2);
	    if ext.long then instrbuf := 'chk2'
			else instrbuf := 'cmp2';
	    case reg1 of
	      0: sappend(instrbuf,'.b ');
	      1: sappend(instrbuf,'.w ');
	      2: sappend(instrbuf,'.l ');
	    end;
	    regsave := ext.reg;
	    if ext.regclass = D then
	      begin
	      emitea(bytesiz);
	      strwrite(instrbuf,strlen(instrbuf)+1,I,',d',regsave:1);
	      end
	    else
	      begin
	      emitea(bytesiz);
	      strwrite(instrbuf,strlen(instrbuf)+1,I,',a',regsave:1);
	      end;
	    end
	  else if eamode <= 1 then
	    begin
	    if eamode = 0 then instrbuf := 'rtm d '
			  else instrbuf := 'rtm a ';
	    strwrite(instrbuf,strlen(instrbuf),I,eareg:1);
	    end
	  else
	    begin
	    instrbuf := 'callm ';
	    sappend(instrbuf,'#');
	    unsigned_byte_extend;
	    comma;
	    emitea(bytesiz);
	    end
	else { ord(size) <> 3 }
	  begin
	  if reg1=7 then
	    begin { moves }
	    instrbuf:='moves'; osize;
	    getinstrbytes(2);
	    if ext.long then
	      begin emitdir(ext.regclass,ext.reg); comma; emitea(size);
	      end
	    else
	      begin emitea(size); comma; emitdir(ext.regclass,ext.reg);
	      end;
	    end
	  else
	    begin
	    instrbuf := immop[reg1];
	    if (eamode=7) and (eareg=4) then
		 begin
		 space; immediate(wordsiz); comma;
		 if size = bytesiz then sappend(instrbuf, 'ccr')
				   else sappend(instrbuf, 'sr');
		 end
	    else begin
		 osize; immediate(size); comma; emitea(size);
		 end;
	    end;
	  end;
    end; {opcode0}

    procedure move;
    { opcodes 1..3: move byte,long,word }
    var lsize: siz;
    begin
      with instr do
	begin
	  case opcode of
	 1: lsize := bytesiz;
	 2: lsize := longsiz;
	 3: lsize := wordsiz;
	  end;
	  instrbuf := 'move';
	  if opmode=1 then sappend(instrbuf,'a');
	  sappend(instrbuf,opsize[lsize]);
	  emitea(lsize); comma;
	  if (opmode=7) and (reg1>1) then goto 2;
	  {kluge to make emitea emit destination}
	  eamode := opmode; eareg := reg1;
	  emitea(lsize  {invalid});
	end;
    end; {move}

    procedure opcode4;
    type miscoptype = array[0..7] of string[5];
	 unoptype = array[0..5] of string[4];
    const predecr = 4; { eamode for predecrement }
	 miscop =
	  miscoptype['reset','nop','stop','rte','rtd','rts','trapv','rtr'];
	 unop = unoptype['negx', 'clr', 'neg', 'not', '', 'tst'];
    var   regstring: string80;
	  I : integer;
	  Dl, Dh : shortint;
	  variantrec : packed record case boolean of
			 true: (w1,w2: shortint);
			 false: (i : integer);
		       end;

      procedure emitreglist
	(optype: opndtype; predecr: boolean; var regstring: string80);
	{ emit register list to 'regstring' according to mask }
      type
	regmasksymtype = array[0..15] of string[2];
      const
	regmasksym = regmasksymtype
	  ['d0','d1','d2','d3','d4','d5','d6','d7',
	   'a0','a1','a2','a3','a4','a5','a6','a7'];
      var
	state: (start,         {waiting for a '1'}
		open,          {have seen a lone '1'}
		cont);         {at least two consecutive '1's}
	j,k,bitcount: integer;

	procedure transition(b: boolean);
	var states: shortint;
	begin
	  if b then
	     if optype = source then states := 6 else states := 5;
	  case state of
	start: if b then
		 begin state := open;
		 sappend(regstring,regmasksym[bitcount]);
		 end;
	open : if b then
		 begin state := cont;
		 sappend(regstring,'-');
		 end
	       else begin state := start;
		    sappend(regstring,'/');
		    end;
	cont : if not b then
		 begin state := start;
		 sappend(regstring,regmasksym[bitcount-1]);
		 sappend(regstring,'/');
		 end;
	  end; {case}
	end; {transition}

      begin {emitreglist}
	getinstrbytes(2);
	if ext.wordext = 0 then regstring := '(none) '
	else
	  begin
	  state := start;
	  bitcount := 0; regstring := '';
	  if not predecr then
	    for j := 1 downto 0 do
	      begin
		for k := 7 downto 0 do
		  begin transition(ext.mask[k+j*8]);
		    bitcount := bitcount+1;
		  end;
		transition(false);
	      end
	  else
	    for j := 0 to 1 do
	      begin
		for k := 0 to 7 do
		  begin transition(ext.mask[k+j*8]);
		    bitcount := bitcount+1;
		  end;
		transition(false);
	      end;
	  end;
	if optype = source then
	  regstring[strlen(regstring)] := ','
	else setstrlen(regstring, strlen(regstring)-1);
      end; {emitreglist}

    procedure emitunop;
    begin with instr do
     begin
     instrbuf := unop[reg1]; osize;
     emitea(size {invalid});
     end;
    end;

    procedure emitsreg;
    begin
      with ext do
      begin
	if (scale <> 0) or (fullindex) then goto 2;
	if not long then
	begin
	  if byteext=0 then sappend(instrbuf,'sfc')
	  else if byteext=1 then sappend(instrbuf,'dfc')
	  else if byteext = 2 then sappend(instrbuf,'cacr')
	  else if byteext = 3 then sappend(instrbuf,'tc') { JWH 12/22/89 }
	  else if byteext = 4 then sappend(instrbuf,'itt0') { JWH 12/22/89 }
	  else if byteext = 5 then sappend(instrbuf,'itt1') { JWH 12/22/89 }
	  else if byteext = 6 then sappend(instrbuf,'dtt0') { JWH 12/22/89 }
	  else if byteext = 7 then sappend(instrbuf,'dtt1') { JWH 12/22/89 }
	       else goto 2;
	end
	else
	begin
	  if byteext=0 then sappend(instrbuf,'usp')
	  else if byteext=1 then sappend(instrbuf,'vbr')
	  else if byteext = 2 then sappend(instrbuf,'caar')
	  else if byteext = 3 then sappend(instrbuf,'msp')
	  else if byteext = 4 then sappend(instrbuf,'isp')
	  else if byteext = 5 then sappend(instrbuf,'mmusr') { JWH 12/22/89 }
	  else if byteext = 6 then sappend(instrbuf,'urp') { JWH 12/22/89 }
	  else if byteext = 7 then sappend(instrbuf,'srp') { JWH 12/22/89 }
	       else goto 2;
	end;
      end;
    end;

    procedure jmpstates;
    begin with instr do
      case eamode of
	2,5,6:;
	7:  if eareg>3 then goto 2;
	otherwise goto 2;
	end;
    end;

    begin {opcode4}
      with instr do
	if bit8 then
	  if ord(size) = 2 then
	    begin
	    instrbuf := 'chk ';
	     emitea(wordsiz); comma;
	     emitdir(D,reg1);
	     end
	  else if ord(size) = 0 then
	    begin
	    instrbuf := 'chk.l ';
	    emitea(longsiz);
	    comma;
	    emitdir(D,reg1);
	    end
	  else if eamode = 0 then
	    begin
	    instrbuf := 'extb.l ';
	    emitdir(D,eareg);
	    end
	  else
	    begin
	    instrbuf := 'lea ';
	    emitea(invalid); comma;
	    emitdir(A,reg1);
	    end
	else { NOT bit8 }
	  case reg1 of
	    0: if size=invalid then
		 begin instrbuf := 'move sr,'; emitea(wordsiz);
		 end
	       else emitunop;
	    1: if size=invalid then
		 begin instrbuf := 'move ccr,'; emitea(wordsiz);
		 end
	       else emitunop;
	       2: if size = invalid then
		 begin instrbuf := 'move ';
		 emitea(wordsiz);
		 sappend(instrbuf, ',ccr');
		 end
	       else emitunop;
	    3: if size = invalid then
		 begin instrbuf := 'move ';
		 emitea(wordsiz);
		 sappend(instrbuf, ',sr');
		 end
	       else emitunop;
	    4: case ord(size) of
		 0: if eamode = 1 then
		   begin
		   instrbuf := 'link.l ';
		   emitdir(A,eareg);
		   comma;
		   immediate(longsiz);
		   end
		 else
		   begin
		   instrbuf := 'nbcd ';
		   emitea(bytesiz {invalid});
		   end;
		 1: if eamode = 0 then
		      begin instrbuf := 'swap '; emitdir(D,eareg);
		      end
		    else if eamode = 1 then
		      begin
		      instrbuf := 'bkpt # ';
		      strwrite(instrbuf,strlen(instrbuf),I,eareg:1);
		      end
		    else
		      begin instrbuf := 'pea '; emitea(invalid);
		      end;
	       2,3: if eamode = 0 then
		      begin instrbuf := 'ext';
		      sappend(instrbuf,opsize[pred(size)]);
		      emitdir(D,eareg);
		      end
		    else
		      begin
		      instrbuf := 'movem';
		      sappend(instrbuf,opsize[pred(size)]);
		      emitreglist(source,eamode=predecr,regstring);
		      sappend(instrbuf,regstring);
		      emitea(invalid);
		      end;
		 end; {case size}
	    5: if instr.w = 19196 {hex('4AFC')} then
		 instrbuf := 'illegal'
	       else if size = invalid then
		  begin instrbuf := 'tas ';
		  emitea(bytesiz {invalid});
		  end
	       else emitunop;
	    6: if size<longsiz then
		 begin
		 getinstrbytes(2);
		 if size = bytesiz then
		   if ext.long then instrbuf := 'muls.l '
				else instrbuf := 'mulu.l '
		 else
		   begin
		   if ext.long then instrbuf := 'divs'
				else instrbuf := 'divu';
		   if ext.scale = 2 then sappend(instrbuf,'.l ')
		   else if ext.reg = ext.byteext then sappend(instrbuf,'.l ')
						 else sappend(instrbuf,'l.l ');
		   end;
		 Dl := ext.reg;
		 if (ext.scale = 2) or
		    ((Dl <> ext.byteext) and (size <> bytesiz)) then
		   Dh := ext.byteext
		 else
		   Dh := -1;
		 emitea(longsiz);
		 comma;
		 if (Dh >= 0) and (Dh <= 7) then
		   begin
		   emitdir(D,Dh);
		   sappend(instrbuf,':');
		   end;
		 emitdir(D,Dl);
		 end
	       else
		 begin instrbuf := 'movem';
		 sappend(instrbuf,opsize[pred(size)]);
		 emitreglist(dest,false,regstring);
		 emitea(invalid); comma;
		 sappend(instrbuf,regstring);
		 end;
	    7: if ord(size) = 2 then
		 begin instrbuf := 'jsr ';
		 jmpstates;
		 emitea(invalid);
		 end
	       else if ord(size) = 3 then
		 begin instrbuf := 'jmp ';
		 jmpstates;
		 emitea(invalid);
		 end
	       else
		 case eamode of
		   0,1:
		      begin instrbuf := 'trap ';
		      emitimm(eareg+8*eamode);
		      if eareg + 8*eamode = 9 then
			begin
			comma; immediate(wordsiz);
			comma; extend(4,true,0);
			end
		      else
		      if eareg + 8*eamode = 1 then
			begin
			sappend(instrbuf,',# ');
			getinstrbytes(2);
			if ext.wordext > 0 then
			  begin
			  variantrec.w1 := ext.wordext;
			  getinstrbytes(2);
			  variantrec.w2 := ext.wordext;
			  variantrec.i := -(variantrec.i - 1073741824);
			  strwrite(instrbuf,strlen(instrbuf),I,variantrec.i:1)
			  end
			else
			  strwrite(instrbuf,strlen(instrbuf),I,ext.wordext:1);
			end
		      else
		      if eareg + 8*eamode = 0 then
			begin
			comma; getinstrbytes(2);
			lastline := ext.uwordext;
			emitimm(lastline);
			while strlen(instrbuf) < 20 do space;
			sappend(instrbuf, 'COMPILED LINE NUMBER ');
			emitint(lastline);
			end;
		      end;
		   2: begin instrbuf := 'link ';
			emitdir(A,eareg); comma;
			immediate(wordsiz);
		      end;
		   3: begin instrbuf := 'unlk '; emitdir(A,eareg);
		      end;
		   4,5:
		      begin instrbuf := 'move ';
			if eamode = 5 then sappend(instrbuf,'usp,');
			emitdir(A,eareg);
			if eamode = 4 then sappend(instrbuf,',usp');
		      end;
		   6: begin
		      instrbuf := miscop[eareg];
		      if (eareg=2) or (eareg=4) then {stop}{rtd}
			  begin space; immediate(wordsiz);
			  end;
		      end;
		   7: begin     { movec }
			if ord(size)<>1 then goto 2;
			instrbuf := 'movec ';
			getinstrbytes(2);
			if eareg=2 then
			begin
			emitsreg; comma; emitdir(ext.regclass,ext.reg);
			end
			else
			  if eareg=3 then
			  begin
			  emitdir(ext.regclass,ext.reg); comma; emitsreg;
			  end
			  else goto 2;
		      end;
		  end; {case eamode}
	    end; {case reg1}
    end; {opcode4}

    procedure quick;
    begin
    with instr do if reg1 = 0 then emitimm(8)
			      else emitimm(reg1);
    comma;
    end;

    procedure shift;
    type
      shiftoptype = array[0..7] of string[4];
    const
      shiftop =
	shiftoptype['asr','lsr','roxr','ror','asl','lsl','roxl','rol'];
    begin
      with instr do
	if size = invalid then
	  begin instrbuf := shiftop[4*ord(bit8)+reg1];
	  space; emitea(bytesiz {invalid});
	  end
	else
	  begin
	  instrbuf := shiftop[4*ord(bit8)+eamode mod 4];
	  osize;
	  if eamode div 4 = 1 then
	    begin
	    emitdir(D,reg1);
	    comma;
	    end
	  else quick;
	  emitdir(D,eareg);
	  end;
    end; {shift}

  procedure mc68881;
    var
      I,j,k : integer;
      saveext : exttype;

    procedure emitfdir(reg: regrange);
      begin
      sappend(instrbuf,'fp ');
      instrbuf[strlen(instrbuf)] := htoc[reg];
      end;

    procedure emitfea(size: integer);
      type
	hexarray = array[0..15] of char;
      const
	hex = hexarray['0','1','2','3','4','5','6','7','8','9',
		       'a','b','c','d','e','f'];
      var
	j,l : integer;
	variantrec : packed record case integer of
		       0: (i: integer);
		       1: (h: packed array[1..24] of 0..15);
		       2: (i1,i2,i3: integer);
		       3: (r : longreal);
		     end;
      begin
      if (instr.eamode = 7) and (instr.eareg = 4) then { Immediate }
	case size of
	  0: {L} immediate(longsiz);
	  1: {S} begin
		 sappend(instrbuf,'#');
		 getinstrbytes(4);
		 variantrec.i := ext.longext;
		 sappend(instrbuf,'$');
		 for j := 1 to 8 do
		   strwrite(instrbuf,strlen(instrbuf)+1,I,hex[variantrec.h[j]]);
		 end;
	  2,3: {X,P}
		begin
		sappend(instrbuf,'#');
		getinstrbytes(4);
		variantrec.i1 := ext.longext;
		getinstrbytes(4);
		variantrec.i2 := ext.longext;
		getinstrbytes(4);
		variantrec.i3 := ext.longext;
		sappend(instrbuf,'$');
		for j := 1 to 24 do
		  strwrite(instrbuf,strlen(instrbuf)+1,I,hex[variantrec.h[j]]);
		end;
	  4: {W} immediate(wordsiz);
	  5: {D} begin
		 sappend(instrbuf,'#');
		 getinstrbytes(4);
		 variantrec.i1 := ext.longext;
		 getinstrbytes(4);
		 variantrec.i2 := ext.longext;
		 try
		   if variantrec.r > 0 then
		     strwrite(instrbuf,strlen(instrbuf)+1,i,variantrec.r:21)
		   else
		     strwrite(instrbuf,strlen(instrbuf)+1,i,variantrec.r:22)
		 recover
		   if escapecode = -18 { bad arg in real/BCD conversion} then
		     begin
		     sappend(instrbuf,'$');
		     for j := 1 to 16 do
		       strwrite(instrbuf,strlen(instrbuf)+1,i,hex[variantrec.h[j]]);
		     end
		   else
		     escape(escapecode);
		 end;
	  6: {B} immediate(bytesiz);
	  otherwise goto 2;
	end {case}
      else
	emitea(bytesiz);
      end;

    procedure dumpfregbits(reglist : byte; zfirst : boolean);
      type
	string1 = string[1];
      var
	variantrec : packed record case boolean of
		       true: (b: byte);
		       false:(a: packed array[0..7] of boolean);
		     end;
	regnum, bitnum, lastbit : integer;

      function makestring(c: char): string1;
	var
	  s: string1;
	begin
	setstrlen(s,1);
	s[1] := c;
	makestring := s;
	end;

      procedure hithit; forward;

      procedure hitmiss; forward;

      procedure hithithit;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then
	    hithithit
	  else
	    begin
	    sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum-1)));
	    hitmiss;
	    end
	else
	  sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum-1)));
	end;

      procedure misshit;
	begin
	sappend(instrbuf,'/fp' + makestring(chr(ord('0')+regnum)));
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then hithit
				  else hitmiss;
	end;

      procedure hitmiss;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then misshit
				  else hitmiss;
	end;

      procedure hithit;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if (bitnum = lastbit) then
	  begin
	  sappend(instrbuf,'-fp' + makestring(chr(ord('0')+regnum-1)));
	  end
	else if not variantrec.a[bitnum] then
	  begin
	  sappend(instrbuf,'-fp' + makestring(chr(ord('0')+regnum-1)));
	  hitmiss;
	  end
	else
	  begin
	  sappend(instrbuf,'-');
	  hithithit;
	  end;
	end;

      procedure firsthit;
	begin
	sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum)));
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then hithit
				  else hitmiss;
	end;

      procedure firstmiss;
	begin
	if zfirst then bitnum := bitnum + 1
		  else bitnum := bitnum - 1;
	regnum := regnum + 1;
	if bitnum <> lastbit then
	  if variantrec.a[bitnum] then firsthit
				  else firstmiss;
	end;

      begin
      variantrec.b := reglist;
      if zfirst then
	begin
	bitnum := 0;
	lastbit := 8;
	end
      else
	begin
	bitnum := 7;
	lastbit := -1;
	end;
      regnum := 0;
      if variantrec.a[bitnum] then firsthit
			      else firstmiss;
      end;

    procedure appendfloatsize(size : integer);
      begin
      case size of
	0: sappend(instrbuf,'.l ');
	1: sappend(instrbuf,'.s ');
	2: sappend(instrbuf,'.x ');
	3,7: sappend(instrbuf,'.p ');
	4: sappend(instrbuf,'.w ');
	5: sappend(instrbuf,'.d ');
	6: sappend(instrbuf,'.b ');
	otherwise goto 2;
      end; {case}
      end;

    procedure appendfloatcondition(predicate : integer);
      begin
      case predicate of
	0:  sappend(instrbuf,'f');
	1:  sappend(instrbuf,'eq');
	2:  sappend(instrbuf,'ogt');
	3:  sappend(instrbuf,'oge');
	4:  sappend(instrbuf,'olt');
	5:  sappend(instrbuf,'ole');
	6:  sappend(instrbuf,'ogl');
	7:  sappend(instrbuf,'or');
	8:  sappend(instrbuf,'un');
	9:  sappend(instrbuf,'ueq');
	10: sappend(instrbuf,'ugt');
	11: sappend(instrbuf,'uge');
	12: sappend(instrbuf,'ult');
	13: sappend(instrbuf,'ule');
	14: sappend(instrbuf,'neq');
	15: sappend(instrbuf,'t');
	16: sappend(instrbuf,'sf');
	17: sappend(instrbuf,'seq');
	18: sappend(instrbuf,'gt');
	19: sappend(instrbuf,'ge');
	20: sappend(instrbuf,'lt');
	21: sappend(instrbuf,'le');
	22: sappend(instrbuf,'gl');
	23: sappend(instrbuf,'leg');
	24: sappend(instrbuf,'nleg');
	25: sappend(instrbuf,'ngl');
	26: sappend(instrbuf,'nle');
	27: sappend(instrbuf,'nlt');
	28: sappend(instrbuf,'nge');
	29: sappend(instrbuf,'ngt');
	30: sappend(instrbuf,'sne');
	31: sappend(instrbuf,'st');
	otherwise goto 2;
      end;
      end;

    begin { mc68881 }
    with instr do
      begin
      if opmode = 0 then
	begin
	getinstrbytes(2);
	if ext.fopclas >= 6 then { FMOVEM }
	  begin
	  instrbuf := 'fmovem ';
	  if ext.fopclas = 6 then { move to FP data registers }
	    begin
	    saveext := ext;
	    emitea(bytesiz);
	    comma;
	    if saveext.frx = 6 then { D reg }
	      emitdir(D,saveext.KDreg)
	    else if saveext.frx = 4 then { register mask }
	      dumpfregbits(saveext.ubyteext,true)
	    else goto 2;
	    end
	  else { move from FP data registers }
	    begin
	    if (ext.frx = 2) or (ext.frx = 6) then
	      emitdir(D,ext.KDreg)
	    else if (ext.frx = 0) or (ext.frx = 4) then
	      if ext.frx = 0 then dumpfregbits(ext.ubyteext,false)
			     else dumpfregbits(ext.ubyteext,true)
	    else goto 2;
	    comma;
	    emitea(bytesiz);
	    end;
	  end
	else if ext.fopclas >= 4 then { FMOVE sysreg }
	  begin
	  if ext.frx in [1,2,4] then
	    instrbuf := 'fmove '
	  else
	    instrbuf := 'fmovem ';
	  if ext.fopclas = 4 then { move to sysregs }
	    begin
	    saveext := ext;
	    emitea(longsiz);
	    case saveext.frx of
	      0: sappend(instrbuf,',-');
	      1: sappend(instrbuf,',fpiaddr');
	      2: sappend(instrbuf,',fpstatus');
	      3: sappend(instrbuf,',fpstatus/fpiaddr');
	      4: sappend(instrbuf,',fpcontrol');
	      5: sappend(instrbuf,',fpcontrol/fpiaddr');
	      6: sappend(instrbuf,',fpcontrol/fpstatus');
	      7: sappend(instrbuf,',fpcontrol/fpstatus/fpiaddr');
	    end; {case}
	    end
	  else { move from sysregs }
	    begin
	    case ext.frx of
	      0: escape(0);
	      1: sappend(instrbuf,'fpiaddr,');
	      2: sappend(instrbuf,'fpstatus,');
	      3: sappend(instrbuf,'fpstatus/fpiaddr,');
	      4: sappend(instrbuf,'fpcontrol,');
	      5: sappend(instrbuf,'fpcontrol/fpiaddr,');
	      6: sappend(instrbuf,'fpcontrol/fpstatus,');
	      7: sappend(instrbuf,'fpcontrol/fpstatus/fpiaddr,');
	    end; {case}
	    emitea(bytesiz);
	    end;
	  end
	else if (ext.fopclas = 2) and (ext.frx = 7) then { FMOVECR }
	  begin
	  instrbuf := 'fmovecr # ';
	  strwrite(instrbuf,strlen(instrbuf),I,ext.fextension:1,',');
	  emitfdir(ext.fry);
	  end
	else { general }
	  begin
	  case ext.fextension of
	    0: instrbuf := 'fmove';
	    1: instrbuf := 'fint';
	    2: instrbuf := 'fsinh';
	    3: instrbuf := 'fintrz';    (* LAF 861204 *)
	    4: instrbuf := 'fsqrt';
	    6: instrbuf := 'flognp1';
	    8: instrbuf := 'fetoxm1';
	    9: instrbuf := 'ftanh';
	    10:instrbuf := 'fatan';
	    12:instrbuf := 'fasin';
	    13:instrbuf := 'fatanh';
	    14:instrbuf := 'fsin';
	    15:instrbuf := 'ftan';
	    16:instrbuf := 'fetox';
	    17:instrbuf := 'ftwotox';
	    18:instrbuf := 'ftentox';
	    20:instrbuf := 'flogn';
	    21:instrbuf := 'flog10';
	    22:instrbuf := 'flog2';
	    24:instrbuf := 'fabs';
	    25:instrbuf := 'fcosh';
	    26:instrbuf := 'fneg';
	    28:instrbuf := 'facos';
	    29:instrbuf := 'fcos';
	    30:instrbuf := 'fgetexp';
	    31:instrbuf := 'fgetman';
	    32:instrbuf := 'fdiv';
	    33:instrbuf := 'fmod';
	    34:instrbuf := 'fadd';
	    35:instrbuf := 'fmul';
	    36:instrbuf := 'fsgldiv';
	    37:instrbuf := 'frem';
	    38:instrbuf := 'fscale';
	    39:instrbuf := 'fsglmul';
	    40:instrbuf := 'fsub';
	    48..55:instrbuf := 'fsincos';
	    56:instrbuf := 'fcmp';
	    58:instrbuf := 'ftst';
	    64:instrbuf := 'fsmove';  { JWH 12/21/89 }
	    65:instrbuf := 'fssqrt';  { JWH 12/21/89 }
	    68:instrbuf := 'fdmove';  { JWH 12/21/89 }
	    69:instrbuf := 'fdsqrt';  { JWH 12/21/89 }
	    88:instrbuf := 'fsabs';  { JWH 12/21/89 }
	    90:instrbuf := 'fsneg';  { JWH 12/21/89 }
	    92:instrbuf := 'fdabs';  { JWH 12/21/89 }
	    94:instrbuf := 'fdneg';  { JWH 12/21/89 }
	    96:instrbuf := 'fsdiv';  { JWH 12/21/89 }
	    98:instrbuf := 'fsadd';  { JWH 12/21/89 }
	    99:instrbuf := 'fsmul';  { JWH 12/21/89 }
	    100:instrbuf := 'fddiv';  { JWH 12/21/89 }
	    102:instrbuf := 'fdadd';  { JWH 12/21/89 }
	    103:instrbuf := 'fdmul';  { JWH 12/21/89 }
	    104:instrbuf := 'fssub';  { JWH 12/21/89 }
	    108:instrbuf := 'fdsub';  { JWH 12/21/89 }
	    otherwise ;
	  end; {case}
	  if ext.fopclas = 0 then { source is Freg }
	    begin
	    sappend(instrbuf,' ');
	    emitfdir(ext.frx);
	    if (ext.fextension = 58 {FTST}) or ((ext.frx = ext.fry) and
	       (ext.fextension <> 0 {FMOVE}) and (ext.fextension < 32)) then
	      { Do not display second op for FTST or "single op" instructions }
	    else
	      begin
	      comma;
	      if ext.fext = 6 then { FSINCOS }
		begin
		emitfdir(ext.sincosreg);
		sappend(instrbuf,':');
		end;
	      emitfdir(ext.fry);
	      end;
	    end
	  else if ext.fopclas = 2 then { source is <ea> }
	    begin
	    appendfloatsize(ext.frx);
	    saveext := ext;
	    emitfea(saveext.frx);
	    if  saveext.fextension <> 58 {FTST} then
	      begin
	      comma;
	      if saveext.fext = 6 then { FSINCOS }
		begin
		emitfdir(saveext.sincosreg);
		sappend(instrbuf,':');
		end;
	      emitfdir(saveext.fry);
	      end;
	    end
	  else if ext.fopclas = 3 then { dest is <ea> }
	    begin { FMOVE from MC68881 }
	    instrbuf := 'fmove';
	    appendfloatsize(ext.frx);
	    emitfdir(ext.fry);
	    comma;
	    saveext := ext;
	    emitea(bytesiz);
	    if saveext.frx = 3 {size P} then
	      strwrite(instrbuf,strlen(instrbuf)+1,I,'{#',saveext.Kfactor:1,'}')
	    else if saveext.frx = 7 {size P} then
	      strwrite(instrbuf,strlen(instrbuf)+1,I,'{d',saveext.KDreg:1,'}');
	    end
	  else goto 2;
	  end;
	end
      else
	case opmode of
	  1: { FScc, FDBcc, FTRAPcc }
	     begin
	     if eamode = 1 then
	       instrbuf := 'fdb'
	     else if (eamode = 7) and (eareg = 4) then
	       instrbuf := 'ftrap'      (* LAF 861204 *)
	     else if (eamode = 7) and ((eareg = 2) or (eareg = 3)) then
	       instrbuf := 'ftrap'      (* LAF 861204 *)
	     else
	       instrbuf := 'fs';
	     getinstrbytes(2);
	     appendfloatcondition(ext.ubyteext);
	     if eamode = 1 then
	       begin
	       if instrbuf = 'fdbf' then
		 instrbuf := 'fdbra '
	       else
		  sappend(instrbuf,' ');
	       emitdir(D,eareg);
	       comma;
	       extend(2,true,0);
	       end
	     else if (eamode = 7) and (eareg = 4) then
	       { FTcc }
	     else if (eamode = 7) and (eareg = 2) then
	       begin { FTPcc.W }
	       sappend(instrbuf,'.w ');
	       immediate(wordsiz);
	       end
	     else if (eamode = 7) and (eareg = 3) then
	       begin { FTPcc.L }
	       sappend(instrbuf,'.l ');
	       immediate(longsiz);
	       end
	     else
	       begin
	       sappend(instrbuf,' ');
	       emitea(bytesiz);
	       end;
	     end;
	  2,3: { Revearse assemble FBF *+2 as FNOP }
	       begin
	       moveleft(inbuf.stp^[codeindex],ext,2);
	       if (instr.fpredicate = 0) and (opmode = 2) and
		  (ext.wordext = 0) then
		 begin { FNOP }
		 instrbuf := 'fnop';
		 getinstrbytes(2);
		 end
	       else
		 begin { FBcc }
		 if instr.fpredicate = 15 {FBT} then
		   instrbuf := 'fbra'
		 else
		   begin
		   instrbuf := 'fb';
		   appendfloatcondition(instr.fpredicate);
		   end;
		 if opmode = 3 then
		   begin
		   sappend(instrbuf,'.l ');
		   extend(4,true,0);
		   end
		 else
		   begin
		   sappend(instrbuf,' ');
		   extend(2,true,0);
		   end;
		 end;
	       end;
	  4,5: { FSAVE, FRESTORE }
	       begin
	       if opmode = 4 then
		 instrbuf := 'fsave '
	       else
		 instrbuf := 'frestore ';
	       emitea(bytesiz);
	       end;
	  otherwise goto 2;
	end {case};
      end {with instr};
    end; { mc68881 }

  { Added 12/22/89 JWH : }

  procedure move16; { Handle the '040 move16 instruction }
  LABEL 1;
  type move16_type =
	packed record
	  case integer of
	    1: (the_op : byte;
		which : 0..7;
		mode_16 : 0..3;
		reg_ax : regrange);
	    2: (w : shortint);
	end; { move16_type }
   type my_type = packed record
      case integer of
      1: ( nib1,nib2 : 0..15;
	byte_it : byte) ;
      2: (w : shortint);
     end; { my_type }
    var see_it : move16_type;
    var see_ex : my_type;
    begin
      { So far we've seen first 7 bits of instruction }
      see_it.w := instr.w; { see it as a move16 }
      instrbuf := 'move16 ';
      with see_it do
       begin
	if the_op <> 246 { hex('F6') } then
	  begin defineword; goto 1; end; { First 8 bits }
	if which > 1 then
	  begin defineword; goto 1; end; { First 11 bits }
	if which = 1 then { have post increment format }
	 begin
	  if mode_16 <> 0 then { gotta be for this format }
	     begin defineword; goto 1; end; { First 13 bits }
	  getinstrbytes(2);
	  if ext.exDAbit1 <> 1  then
	     begin defineword; goto 1; end; { First 17 bits }
	  see_ex.w := ext.wordext;
	  if ((see_ex.nib2 <> 0) or (see_ex.byte_it <> 0))  then
	     begin defineword; goto 1; end; { First 32 bits }
	  { Have a valid move16 of this format if we get this far }
	  emitpostincr(reg_ax);
	  comma;
	  emitpostincr(ext.exRn1);
	 end { which = 1 , post increment format }
	else  { which = 0, have absolute format }
	 begin
	  { Have a valid move16 of this format if we get here. }
	   case mode_16 of
	    0 : begin emitpostincr(reg_ax); comma; extend(4,false,0); end;
	    1 : begin extend(4,false,0); comma; emitpostincr(reg_ax); end;
	    2 : begin emitardef(reg_ax); comma; extend(4,false,0); end;
	    3 : begin extend(4,false,0); comma; emitardef(reg_ax); end;
	    otherwise ; { this really can't happen }
	   end; { case }
	 end; { which = 0, absolute format }
       end; { with see_it }
    1: end; { move16 }

    { Added 12/22/89 JWH : }


  procedure cinv_cpush; { Handle '040 CINV and CPUSH instructions }
  LABEL 1;
  type cache_40_type =
	packed record
	  case integer of
	    1: (the_op : byte;
		which_caches : 0..3;
		which_instr : 0..1;
		scope : 0..3;
		reg_ax : regrange);
	    2: (w : shortint);
	end; { cache_40_type }
    var see_it : cache_40_type;
    begin
    { Have seen the first seven bits of the instruction }
     see_it.w := instr.w; { see it as a cinv or cpush }
     with see_it do
      begin
       if the_op <> 244 { hex('F4') } then
	  begin defineword; goto 1; end; { Seen 8 bits now }
       if which_instr = 0 then
	begin { CINV }
	 case scope of
	  0 : begin defineword; goto 1; end; { ILLEGAL }
	  1 : instrbuf := 'cinvl ';
	  2 : instrbuf := 'cinvp ';
	  3 : instrbuf := 'cinva ';
	  otherwise ;
	 end; { case }
	 case which_caches of
	  0 : strappend(instrbuf,'NONE');  { NOOP, NOT ILLEGAL }
	  1 : strappend(instrbuf,'DC');
	  2 : strappend(instrbuf,'IC');
	  3 : strappend(instrbuf,'DC/IC');
	  otherwise ;
	 end; { case }
	 if ((scope = 1) or (scope = 2)) then { CINVL or CINVP .. }
	  begin { get the reg ... }
	    comma; emitardef(reg_ax);
	  end; { CINVL or CINVP }
	end { CINV }
       else
	begin { CPUSH }
	 case scope of
	  0 : begin defineword; goto 1; end; { ILLEGAL }
	  1 : instrbuf := 'cpushl ';
	  2 : instrbuf := 'cpushp ';
	  3 : instrbuf := 'cpusha ';
	  otherwise ;
	 end; { case }
	 case which_caches of
	  0 : strappend(instrbuf,'NONE'); { NOOP, NOT ILLEGAL }
	  1 : strappend(instrbuf,'DC');
	  2 : strappend(instrbuf,'IC');
	  3 : strappend(instrbuf,'DC/IC');
	  otherwise ;
	 end; { case }
	 if ((scope = 1) or (scope = 2)) then { CPUSHL or CPUSHP .. }
	  begin { get the register ... }
	    comma; emitardef(reg_ax);
	  end; { CPUSHL or CPUSHP }
	end; { CPUSH }
      end; { with see_it }
      1 :
    end; { cinv_cpush }

  begin {decode}
    with instr do
      case opcode of
	0: opcode0;
	1,2,3: move;
	4: opcode4;
	5: if size = invalid then
	     begin
	     if eamode = 1 then
	       begin
	       instrbuf := 'db';
	       if cond = 1 then sappend(instrbuf,'ra')
	       else sappend(instrbuf,condcode[cond]);
	       space; emitdir(D, eareg);
	       comma; extend(2,true,0);
	       end
	     else if (eamode < 7) or ((eamode = 7) and (eareg <= 1)) then
	       begin
	       instrbuf := 's';
	       sappend(instrbuf,condcode[cond]);
	       space; emitea(bytesiz {invalid});
	       end
	     else { trapcc }
	       begin
	       case cond of
		 0: instrbuf := 'trapt';
		 1: instrbuf := 'trapf';
		 2: instrbuf := 'traphi';
		 3: instrbuf := 'trapls';
		 4: instrbuf := 'trapcc';
		 5: instrbuf := 'trapcs';
		 6: instrbuf := 'trapne';
		 7: instrbuf := 'trapeq';
		 8: instrbuf := 'trapvc';
		 9: instrbuf := 'trapvs';
		 10:instrbuf := 'trappl';
		 11:instrbuf := 'trapmi';
		 12:instrbuf := 'trapge';
		 13:instrbuf := 'traplt';
		 14:instrbuf := 'trapgt';
		 15:instrbuf := 'traple';
	       end;
	       if eareg = 2 then { .w }
		 begin
		 sappend(instrbuf,'.w ');
		 immediate(wordsiz);
		 end
	       else if eareg = 3 then { .l }
		 begin
		 sappend(instrbuf,'.l ');
		 immediate(longsiz);
		 end;
	       end;
	     end
	   else
	     begin
	     if bit8 then instrbuf := 'subq'
	     else instrbuf := 'addq';
	     osize; quick;
	     emitea(size {invalid});
	     end;
	6: begin instrbuf := 'b';
	     if cond = 0 then sappend(instrbuf,'ra')
	     else if cond = 1 then sappend(instrbuf,'sr')
			      else sappend(instrbuf,condcode[cond]);

	     if displ = -1 then { 32 bit displ }
	       begin
	       sappend(instrbuf,'.l ');
	       extend(4,true,0);
	       end
	     else if displ = 0 then
	       begin
	       sappend(instrbuf,'.w ');
	       extend(2,true,0);
	       end
	     else
	       begin sappend(instrbuf,'.s ');
	       ext.longext := pc + 2 + displ;
	       tempint := ext.longext;
	       gvrstring(nilgvr,tempint,true,false);
	       sappend(instrbuf,gvaluestring);
	       end;
	   end;
	7: begin instrbuf := 'moveq ';
	     emitimm(displ); comma;
	     emitdir(D,reg1);
	   end;



8,9,11,12,13: begin
	   instrbuf := arithop[opcode];
	   if size=invalid then
	    begin
	    if odd(opcode) then
	     begin
	     sappend(instrbuf,'a');
	     if bit8 then
		  begin
		  sappend(instrbuf, opsize[longsiz]);
		  emitea(longsiz);
		  end
	     else begin
		  sappend(instrbuf,opsize[wordsiz]);
		  emitea(wordsiz);
		  end;
	     comma; emitdir(A,reg1);
	     end
	    else
	     begin
	     if opcode = 8 then instrbuf := 'div'
			   else instrbuf := 'mul';
	     if bit8 then sappend(instrbuf,'s ')
		     else sappend(instrbuf,'u ');
	     emitea(wordsiz); comma; emitdir(D,reg1);
	     end
	    end
	   else if (not bit8) or (eamode > 1) or (opcode = 11) then
	     begin
	     if opcode = 11 then
	      if bit8 then
	       if eamode = 1 then
		 begin
		 sappend(instrbuf,'m'); osize;
		 emitpostincr(eareg); comma; emitpostincr(reg1);
		 goto 1;
		 end
	       else instrbuf := 'eor';
	     osize;
	     if bit8 then begin emitdir(D,reg1); comma; emitea(size);
			  end
		     else begin emitea(size); comma; emitdir(D,reg1);
			  end;
	     end
	   else
	     begin
	     if odd(opcode) then begin sappend(instrbuf,'x'); osize; end
	     else if opcode = 8 then
	       if size = bytesiz then instrbuf := 'sbcd '
	       else if size = wordsiz then instrbuf := 'pack '
	       else { size = longsiz }     instrbuf := 'unpk '
	     else if size = bytesiz then instrbuf := 'abcd '
	     else begin
		  instrbuf := 'exg ';
		  if eamode = 0 then
		    begin emitdir(D,reg1); comma; emitdir(D,eareg) end
		  else if opmode = 5 then
		    begin emitdir(A,reg1); comma; emitdir(A,eareg) end
		  else
		    begin emitdir(D,reg1); comma; emitdir(A,eareg) end;
		  goto 1;
		  end;
	     if eamode = 0 then
		  begin emitdir(D,eareg); comma; emitdir(D,reg1);
		  end
	     else begin emitpredecr(eareg); comma; emitpredecr(reg1);
		  end;
	     if (opcode = 8) and (size >= wordsiz) then { pack unpk }
	       begin
	       comma;
	       immediate(wordsiz);
	       end;
	     end;
	   end;
       14:
	 if (ord(size) = 3) and (reg1 >= 4) then { bit field op }
	   begin
	   case cond of
	     8: instrbuf := 'bftst ';
	     9: instrbuf := 'bfextu ';
	     10: instrbuf := 'bfchg ';
	     11: instrbuf := 'bfexts ';
	     12: instrbuf := 'bfclr ';
	     13: instrbuf := 'bfffo ';
	     14: instrbuf := 'bfset ';
	     15: instrbuf := 'bfins ';
	   end;
	   getinstrbytes(2);
	   bf_reg := ext.bf_reg;
	   bf_Do := ext.bf_Do;
	   bf_offset := ext.bf_offset;
	   bf_Dw := ext.bf_Dw;
	   bf_width := ext.bf_width;
	   if cond = 15 then
	     begin
	     emitdir(D,bf_reg);
	     comma;
	     end;
	   emitea(bytesiz);
	   sappend(instrbuf,'{');
	   if bf_Do then
	     sappend(instrbuf,'d');
	   strwrite(instrbuf,strlen(instrbuf)+1,I,bf_offset:1);
	   sappend(instrbuf,':');
	   if bf_Dw then
	     strwrite(instrbuf,strlen(instrbuf)+1,I,'d',bf_width:1)
	   else
	     begin
	     if bf_width = 0 then
	       bf_width := 32;
	     strwrite(instrbuf,strlen(instrbuf)+1,I,bf_width:1);
	     end;
	   sappend(instrbuf,'}');
	   if cond in [9,11,13] then
	     begin
	     comma;
	     emitdir(D,bf_reg);
	     end;
	   end
	 else
	   shift;
	 15: if reg1 = 1 then mc68881
	      { Next two lines JWH 12/22/89 : }
	      else if reg1 = 2 then cinv_cpush
	      else if ((reg1 = 3) and (instr.opmode = 0)) then move16
	     else goto 2;
	otherwise goto 2;
	end; {case}
       goto 1;
      2: begin defineword;
	   if decodestate <> abscode then decodestate := consts;
	 end;
    1: end; {decode}

  procedure definecaseword;
  var savepc: integer;
  begin
  instrsize := 0;
  instrbuf := 'case jump   ';
  savepc := pc; pc := tablepc;
  extend(2, true,0);
  pc := savepc;
  end;

  procedure decodestuff;
  label 1;
  var temp: integer;

    procedure printprocboundary;
    label 1;
    var  defaddr,deflimit,len,gvrbase: integer;
	 veloc:  addrec;
    begin
      defaddr:=newmods^.defaddr.a;
      deflimit:=defaddr+newmods^.defsize;
      while defaddr < deflimit do
	begin
	  len:=strlen(symbolptr(defaddr)^);
	  len:=len+2-ord(odd(len));
	  gvrbase:=defaddr+len;
	  with gvrptr(gvrbase)^ do
	    if primarytype = loadgvr^.primarytype then
	      begin
	      veloc.a:=gvrbase+sizeof(generalvalue,false);
	      if veloc.vep^.value = PC then goto 1;
	      end;
	  defaddr:=defaddr+len+ord(symtableptr(defaddr)^[len+1]);
	end;
	listln;
1:    list;
      if MODULEPC = PC then write(listing,'- * module body * -')
		       else write(listing,'- - - - - - - - - -');
      write(listing,' - - - - - - - - - - - - - - - -  ');
      if defaddr < deflimit then
	write(listing,symbolptr(defaddr)^);
      writeln(listing);
    end; {printprocboundary}

  begin {decodestuff}
 1: case decodestate of
      consts:
	  begin getinstruction;
	    if (PC=MODULEPC)  { MODULE BODY ADDRESS } then
		begin decodestate := code; decode;
		 if (rangetype = norange) or
		    ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
		    ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange))
		    then printprocboundary;
		end
	    else { check for dc.w even,0 or 1}
	       if (not odd(instr.lb) and (instr.rb<2)) then
	       begin defineword; decodestate := phdr; end

	    else if (instr.w = 20217) {JMP long abs}
	     or (instr.w = 24576) {BRA 16 bit} then
	      decode
	    else defineword;
	  end;
      phdr:begin getinstruction;
	     if (instr.w = 20054) {LINK A6}
	       or (instr.w = 18446) {LINK.L A6}
	       or (instr.w = 20033) {TRAP #1}
	       or (PC=MODULEPC) {MODULE BODY ADDRESS } then
		begin decodestate := code; decode;
		 if (rangetype = norange) or
		    ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
		    ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange))
		    then printprocboundary;
		end
	      else if (instr.w = 20217) {JMP long abs}
		      or (instr.w = 24576) {BRA 16 bit} then
		      begin decode; decodestate:=consts; end
		   else
		   begin defineword;
		     if not (not odd(instr.lb) and (instr.rb<2)) then decodestate := consts;
		   end;
	   end;

abscode,
      code:     begin
		getinstruction;
		decode;
		if decodestate <> abscode then
		  if instr.w = 20062 {UNLK A6} then decodestate := endofproc
		  else if instr.w = 20219 {JMP pc indexed} then
		    begin oldstate := code; decodestate := startcase end;
		end;
      startcase:
	begin
	  tablePC := PC;
	  definecaseword;
	  casecodestart:=ext.wordext+PC;
	  decodestate := casetable;
	end;
      casetable:
	begin
	  if PC = casecodestart
	  then begin decodestate := oldstate; goto 1 end
	  else
	    begin definecaseword;
	      if not fortranflag then
		begin
		  temp:=ext.wordext+tablePC;
		  if temp<casecodestart then casecodestart := temp;
		end;
	    end;
	end;
      endofproc:
	begin getinstruction; decode;
	  if (instr.w = 20085 {RTS} )
	      or (instr.w div 8 = 2522 {JMP (An)} ) then
	    decodestate := consts;
	end;
      end; {case}
  end; {decodestuff}

begin {listinstruction}
  decodestuff;
  bytesleft := instrsize; firstline := true;
  if (rangetype = norange) or
     ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or
     ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange)) then
   repeat
    list;
    if firstline then write(listing,PC:8,' ')

    else write(listing,'':9  {17}  );
    printinstrword;
    if bytesleft>0 then printinstrword
    else
      if firstline then write(listing,'':5);
    if firstline then
      begin writeln(listing,'':9,instrbuf); firstline := false end
    else writeln(listing);
   until bytesleft = 0;
  PC:=PC + instrsize;
end; {listinstruction}

procedure getcodeblocks;
var junkint: integer;
    pclimit: integer;
    textstep: addrec;
    textrecctr: {shortint} INTEGER {SFB};
begin
 with newmods^,directory.drp^ do
   begin
   textstep.a:=directory.a+sizeof(moduledirectory);
   junkint:=strlen(textstep.syp^);
   textstep.a := textstep.a+junkint+2-ord(odd(junkint));
   if executable then textstep.a := textstep.a + textstep.gvp^.short;
   textrecctr:=textrecords;
   while textrecctr > 0 do with textstep.tdp^ do
     begin
     textrecctr:=textrecctr-1;
     list; writeln(listing,'TEXT RECORD #',
     textrecords-textrecctr, '  of ''', fdirectory^[vmodnum].dtid, ''':');
     list; writeln(listing,'  TEXT start block ',textstart:4,
		      '       Size ',textsize,' bytes');
     list; writeln(listing,'  REF  start block ',refstart:4,
		      '       Size ',refsize,' bytes');
     textstep.a :=textstep.a+sizeof(textdescriptor);
     PC := 0;
     loadgvr := textstep.gvp;
     gvrstring(textstep.gvp,PC,false,false);
     gbytes(inbuf.a,textsize);
     readblocks(filefib.fbp^, inbuf.p^,textsize,fileblock+textstart);
     codeindex:=0;  codecount:=textsize;
     gbytes(refptr.a,refsize);
     readblocks(filefib.fbp^,refptr.p^,refsize,fileblock+refstart);

     refgvr:=refptr;
     reflim:=refptr.a+refsize;
     refloc:=PC;        nextref;
     pclimit := PC + textsize;

     list; writeln(listing,'  LOAD address     ',gvaluestring);
     listln;
     while PC < pclimit do listinstruction;
     listln; listln;
     lowheap := inbuf;
     end;
   end; {with newmods^,directory^}
end; {getcodeblocks}

procedure listdefs;
var
  len,val:      integer;
  lim,p1:       addrec;
begin
prepunassem;
with newmods^ do
  begin
  list; writeln(listing,'  DEF table of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  p1 := defaddr;
  lim.a := p1.a + defsize;
  while p1.a < lim.a do
    begin
    len:=strlen(p1.syp^);
    list; write(listing,'':5,p1.syp^,'':(30-len));
    p1.a := p1.a + len+2-ord(odd(len));
    val := 0;
    gvrstring(p1.gvp,val,false,false);
    writeln(listing,gvaluestring);
    end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure listexts;
var
  i:            integer;
  p1:           addrec;
begin
prepunassem;
with newmods^ do
  begin
  list; writeln(listing,'  EXT table of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  for i:=2 to listsize-1 do if listaddr^[i] <> 0 then
    begin
      p1.a := extaddr.a + listaddr^[i];
      list; writeln(listing,'':5,p1.syp^);
    end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure listtext;
const pagesize = pageblocks * blocksize;
var
  textbuf,ptr:  addrec;
  i,j,pages:    integer;
  readsize:     integer;
  linestart:    boolean;

  procedure dochar(c: char);
  begin
  if linestart then list;
  linestart := (c = eol);
  if linestart then writeln(listing) else write(listing, c);
end;

begin
prepunassem;
gbytes(textbuf.a, pagesize);
with newmods^, directory.drp^ do
  begin
  list; writeln(listing,'  DEFINE SOURCE of ''',
	fdirectory^[vmodnum].dtid, ''':');
  listln;
  pages := (sourcesize + (pagesize-1)) div pagesize;
  for i := 0 to pages-1 do
   begin
   readsize := sourcesize - i*pagesize;                         { scs 1/17/83 }
   if readsize > pagesize then readsize := pagesize;            { scs 1/17/83 }
   readblocks(filefib.fbp^,textbuf.p^,readsize,                 { scs 1/17/83 }
					   fileblock+sourceblock+i*pageblocks);
   ptr := textbuf;      linestart := true;
   repeat
     case ptr.cp^ of
       chr(etx),
       nullchar:  ptr.a := textbuf.a + pagesize;
      otherwise dochar(ptr.cp^);
      end;
     ptr.a := ptr.a + 1;
   until ptr.a >= textbuf.a + pagesize;
   if not linestart then dochar(eol);
   end;
  end;
listln;
newmods := modsave;
lowheap := infost;
end;

procedure disassemble;
begin
prepunassem;
nilgvr := NIL;
getcodeblocks;
newmods := modsave;
lowheap := infost;
end;

procedure getbounds;
begin
  lastline := -1;
  fgotoxy(output, 0,13);
  write('lower bound? ');
  if readint(lowrange) then
       begin
       write('upper bound? ');
       if not readint(highrange) then
	  highrange := maxint;
       end
  else begin
       lowrange := minint;
       highrange := maxint;
       end;
end;

begin {unassemble}
  fortranflag := false;
  decodestate := notype;        dumped := false;
  repeat
    fgotoxy(output, 0,2);
    writeln('Q  Quit',cteos);
    writeln('S  Stop unassembling');
    writeln('T  print import Text');
    writeln('E  print Ext table');
    writeln('D  print Def table');
    writeln('A  unassemble all (Assembler conventions)');
    writeln('C  unassemble all (Compiler  conventions)');
    writeln('P  PC   range     (Assembler conventions)');
    writeln('L  Line range     (Compiler  conventions)', cteos);
    getcommandchar('unassemble option?',commandchar);
    if commandchar <> ' ' then
     case commandchar of
      'S':  decodestate := quittype;
      'Q':  begin
	    decodestate := quittype;
	    quit;
	    end;
      'A':  begin rangetype := norange; decodestate := abscode; disassemble; end;
      'C':  begin rangetype := norange; decodestate := consts; disassemble; end;
      'P':  begin rangetype := pcrange; decodestate := abscode; getbounds; disassemble; end;
      'L':  begin rangetype := linerange; decodestate := consts; getbounds; disassemble; end;
      'T':  listtext;
      'D':  listdefs;
      'E':  listexts;
      otherwise dobeep;
      end;
  until decodestate = quittype;
end; {unassemble}


procedure makenewgvr(var oldptr: addrec;
			   modptr: moddescptr);

var  refsize:   shortint;
     lastptr,
     firstptr,
     vptr,
     gptr:      addrec;

  procedure runlist(var oldptr: addrec; modptr: moddescptr; sub: boolean);
  var done:     boolean;
      defptr:   addrec;

    procedure addref(add: shortint; sub: boolean);
    var iptr,jptr,tp:   addrec;
	notdone,
	notcancels:     boolean;
    begin
    if add = 0 then
      if sub then vptr.vep^.value  := vptr.vep^.value - modptr^.relocdelta
	     else vptr.vep^.value  := vptr.vep^.value + modptr^.relocdelta
    else if add = 1 then
      if sub then vptr.vep^.value  := vptr.vep^.value - modptr^.globaldelta
	     else vptr.vep^.value  := vptr.vep^.value + modptr^.globaldelta;

    iptr := lastptr; notdone := true; notcancels := true;
    while (iptr.a > firstptr.a) and notdone do
      begin
      iptr.a := iptr.a - sizeof(referenceptr);
      with iptr.rpp^ do
	if adr <= add then
	  begin
	  if adr = add then notcancels := (op = subit) = sub;
	  iptr.a := iptr.a + sizeof(referenceptr);
	  notdone := false;
	  end;
      end;

    if notcancels then
      begin
      gbytes(jptr.a, sizeof(referenceptr));
      lastptr := lowheap;
      while jptr.a > iptr.a do
	begin
	tp.a := jptr.a - sizeof(referenceptr);
	jptr.rpp^ := tp.rpp^;
	jptr := tp;
	end;
      with iptr.rpp^ do
	begin adr := add; last := false;
	if sub then op := subit else op := addit;
	end;
      end
    else
      begin
      tp.a := iptr.a - sizeof(referenceptr);
      while iptr.a < lastptr.a do
	begin
	tp.rpp^ := iptr.rpp^;
	tp := iptr;
	iptr.a := iptr.a + sizeof(referenceptr);
	end;
      lastptr.a := lastptr.a - sizeof(referenceptr);
      lowheap := lastptr;
      end;
    end;

  begin {runlist}
  with oldptr.gvp^ do
    begin
    if longoffset then oldptr.a := oldptr.a+sizeof(generalvalue, true)
			else oldptr.a := oldptr.a+sizeof(generalvalue, false);
    if valueextend then
      begin
      if sub then vptr.vep^.value := vptr.vep^.value - oldptr.vep^.value
	     else vptr.vep^.value := vptr.vep^.value + oldptr.vep^.value;
      oldptr.a := oldptr.a + sizeof(valueextension, sint);
      end;
    if primarytype <> absolute then
      begin
      if modptr = NIL then
	begin
	modptr := newmods;      done := false;
	repeat
	with modptr^ do
	  if patchmod then modptr := link
	  else if oldptr.a < defaddr.a then modptr := link
	  else if oldptr.a > defaddr.a + defsize then modptr := link
	  else done := true;
	until done;
	end;
      case primarytype of
       relocatable:      addref(0, sub);
       global:           addref(1, sub);
       general:
	begin
	done := false;
	repeat with oldptr.rpp^ do
	  begin
	  defptr := modptr^.extaddr.ptp^[adr];
	  if modptr^.unresbits.bmp^[adr] then
	    addref(defptr.rp.adr, sub <> (op = subit))
	  else
	    begin
	    defptr.a := defptr.a + strlen(defptr.syp^) + 2
		     - ord(odd(strlen(defptr.syp^)));
	    runlist(defptr, NIL, sub <> (op = subit));
	    end;
	  oldptr.a := oldptr.a + sizeof(referenceptr);
	  done := last;
	  end;
	until done;
	end; {general}
       end; {case}
      end; {primarytype <> absolute}
    end; {with}
  end; {runlist}

begin {makenewgvr}
  gbytes(gptr.a, sizeof(generalvalue));
  gptr.gvp^ := oldptr.gvp^;
  with gptr.gvp^ do
    begin
    if not longoffset then
      lowheap.a := lowheap.a -
      (sizeof(generalvalue) - sizeof(generalvalue, false));
    gbytes(vptr.a, sizeof(valueextension, sint));
    vptr.vep^.value := 0;
    valueextend := true;
    end;

  firstptr := lowheap;  lastptr := firstptr;

  runlist(oldptr, modptr, false);
  with gptr.gvp^ do
    begin
    refsize := lastptr.a - firstptr.a;
    if refsize = 0 then primarytype := absolute
    else
      begin
      if refsize = sizeof(referenceptr) then with firstptr.rpp^ do
	if adr <= 1 then if op = addit then
	  begin
	  if adr = 0 then primarytype := relocatable
		     else primarytype := global;
	  lastptr := firstptr;
	  lowheap := lastptr;
	  refsize := 0;
	  end;
      if refsize > 0 then
	begin
	firstptr.a := lastptr.a - sizeof(referenceptr);
	firstptr.rpp^.last := true;
	end;
      end;
    short := lastptr.a - gptr.a;        {even if it is long variety}
    end;
end;


procedure compressgvr(gvptr: addrec);
var vptr:   addrec;
begin
with gvptr.gvp^ do if valueextend then
  begin
  if longoffset then vptr.a := gvptr.a + sizeof(generalvalue, true)
		else vptr.a := gvptr.a + sizeof(generalvalue, false);
  with vptr.vep^ do
   if value = 0 then
    begin
    lowheap.a := lowheap.a - sizeof(valueextension, sint);
    fastmove(point(vptr.a + sizeof(valueextension, sint)), vptr.p,
	     lowheap.a - vptr.a);
    valueextend := false; short := short - sizeof(valueextension, sint);
    end;
  end;
end;

procedure rsolve;
var modptr, lastptr, nextptr: moddescptr;
    mrbase,mgbase:    integer;
    sp:         addrec;
    len:        shortint;
    i:          shortint;

begin
  modptr := newmods; lastptr := NIL; {reverse the pointers}
  while modptr <> NIL do with modptr^ do
    begin nextptr := link;      link := lastptr;
	  lastptr := modptr;    modptr := nextptr;
    end;
  newmods := lastptr;

  startgvr.p := NIL;    startgvrmod := NIL;
  modptr := newmods;    totalpatchspace := 0;
  forwardpatches:=NIL;  backwardpatches:=NIL;
  mrbase := startreloc; mgbase := startglobal;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      patchbase := mrbase;
      mrbase := mrbase + patchsize;
      totalpatchspace := totalpatchspace + patchsize;
      if forwardpatches = NIL then forwardpatches := modptr
      else lastptr^.patchlink := modptr;
      lastptr := modptr;
      end
    else with directory.drp^ do
      begin
      relocbase := mrbase;    relocdelta :=  mrbase - relocatablebase;
      mrbase := mrbase + relocatablesize + ord(odd(relocatablesize));
      globase := mgbase;      globaldelta := mgbase - globalbase;
      mgbase := mgbase - globalsize      - ord(odd(globalsize));

      gbytes(unresbits.a, ((extsize div 4 + 15) div 16)*2);
      for i := 2 to extsize div 4 - 1 do unresbits.bmp^[i] := false;
      unresbits.bmp^[0] := true;        unresbits.bmp^[1] := true;
      extaddr.ptp^[0].rp.w := 0;
      extaddr.ptp^[1].rp.w := 4;

      sp := directory;
      sp.a := sp.a+sizeof(moduledirectory);

      if newmodname.syp = NIL then newmodname := sp;
      if startgvr.p = NIL then
	if executable then
	  begin
	  startgvrmod := modptr;
	  startgvr.a := sp.a+strlen(sp.syp^)+2-ord(odd(strlen(sp.syp^)));
	  end;
      end;
    modptr := link;
    end;
  totalreloc :=  mrbase - startreloc;
  totalglobal := startglobal - mgbase;

end; {rsolve}


procedure mergeexts;

var ilist:      addrec;
    slist:      sortlistptr;
    sptr:       addrec;
    listlen:    shortint;
    sortlen:    shortint;
    minindex:   shortint;
    modptr:     moddescptr;
    len,
    i:          integer;
    done:       boolean;
    strptr,
    newstrptr:  addrec;

begin
  slist := lowheap.slp;  listlen := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if not patchmod then if not resolved then
      begin
      listlen := listlen + 1;
      gbytes(sptr.a, sizeof(sortdesc));
      with sptr.sdp^ do
	begin
	modp := modptr;
	N := 0;
	end;
      end;
    modptr := link;
    end;

  gbytes(ilist.a, listlen * sizeof(shortint));
  for i := 1 to listlen do ilist.ilp^[i] := i-1;
  sortlen := listlen;
  gbytes(newexttable, 8);
  newextsize := 8;

  while listlen > 0 do
    begin
    while sortlen > 0 do with slist^[ilist.ilp^[sortlen]], modp^ do
      begin
      done := false;
      repeat
       if N >= listsize then
	 begin
	 listlen := listlen - 1;
	 for i := sortlen to listlen do ilist.ilp^[i] := ilist.ilp^[i+1];
	 done := true;
	 end
       else if listaddr^[N] = 0 then N := N + 1
       else
	 begin
	 ext := symbolptr(extaddr.a + listaddr^[N]);
	 i := sortlen;  minindex := ilist.ilp^[i];
	 repeat
	   if i >= listlen then done := true
	   else if ext^ <= slist^[ilist.ilp^[i+1]].ext^ then done := true
	   else begin ilist.ilp^[i] := ilist.ilp^[i+1]; i := i + 1; end;
	 until done;
	 ilist.ilp^[i] := minindex;
	 end;
      until done;
      sortlen := sortlen - 1;
      end;
    if listlen > 0 then
      begin
      strptr.syp := slist^[ilist.ilp^[1]].ext;
      len := strlen(strptr.syp^) + 4 - strlen(strptr.syp^) mod 4;
      gbytes(newstrptr.a, len);
      fastmove(strptr.p, newstrptr.p, len);
      i := 1; done := false;
      repeat with slist^[ilist.ilp^[i]], modp^ do
	if ext^ = newstrptr.syp^ then
	  begin
	  wordrecptr(ext)^.w := newextsize;
	  unresbits.bmp^[listaddr^[N] div 4] := true;
	  N := N + 1;
	  i := i + 1; done := i > listlen;
	  end
	else done := true;
      until done;
      sortlen := i-1;
      newextsize := newextsize + len;
      end;
    end;

  if newextsize <= 8 then newextsize := 0;

end;

function gvrequal(a,b: addrec; offset: integer): boolean;
var      boff,
	 aoff:  integer;
	 b0:    gvrptr;
begin
gvrequal := false;
b0 := b.gvp;
with a.gvp^ do
  if primarytype = b0^.primarytype then
    begin
    if longoffset     then a.a := a.a + 4
		      else a.a := a.a + 2;
    if b0^.longoffset then b.a := b.a + 4
		      else b.a := b.a + 2;
    if valueextend then
      begin
      aoff := a.vep^.value;
      a.a := a.a + sizeof(valueextension, sint);
      end
    else aoff := 0;
    if b0^.valueextend then
      begin
      boff := b.vep^.value;
      b.a := b.a + sizeof(valueextension, sint);
      end
    else boff := 0;
    if aoff + offset = boff then
      if primarytype = general then
	begin
	while (a.rpp^.w
		   = b.rpp^.w)
	      and (a.rpp^.last = false) do
	  begin
	  a.a := a.a + sizeof(referenceptr);
	  b.a :=  b.a + sizeof(referenceptr);
	  end;
	gvrequal := a.rpp^.w = b.rpp^.w;
	end
      else gvrequal := true;
    end;
end;

procedure makedir;

var  modptr:            moddescptr;
     newtextrec,
     lasttextrec:       addrec;
     len:               shortint;
     extblocks,
     newtextrecs,
     movebytes,
     textrecs :         integer;
     index,
     newptr:            address;
     tempdirptr,
     oldindex,
     oldptr,
     ptr:               addrec;


  procedure mergetext;
  var  merged:  boolean;
       lastptr,
       newptr:  addrec;
  begin
   if newtextrec.tdp^.textsize = 0 then lowheap := newtextrec
   else
    begin
    if lasttextrec.tdp <> NIL then
      begin
      lastptr.a := lasttextrec.a + sizeof(textdescriptor);
      newptr.a  := newtextrec.a  + sizeof(textdescriptor);
      merged := gvrequal(lastptr, newptr, lasttextrec.tdp^.textsize );
      end
    else merged := false;

    if merged then
      begin
      lasttextrec.tdp^.textsize := lasttextrec.tdp^.textsize + newtextrec.tdp^.textsize;
      lowheap := newtextrec;
      end
    else
      begin newtextrecs := newtextrecs + 1;
      lasttextrec := newtextrec;
      end;
    end;
  end;

begin {makedir}
  gbytes(tempdirptr.a, sizeof(moduledirectory));
  if newmodname.syp=NIL then
    begin gbytes(newmodname.a, 2);
    newmodname.syp^ := '';
    end
  else
    begin
    len := strlen(newmodname.syp^) + 2 - ord(odd(strlen(newmodname.syp^)));
    gbytes(index, len);
    fastmove(newmodname.p, point(index), len);
    end;

  if startgvr.p<>NIL then
    begin
    oldptr := startgvr;
    ptr := lowheap;     makenewgvr(oldptr, startgvrmod);
    compressgvr(ptr);
    end;

  lasttextrec.tdp := NIL;
  newtextrecs := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      gbytes(newtextrec.a, sizeof(textdescriptor));
      newtextrec.tdp^.textsize := patchsize;
      gbytes(oldptr.a, sizeof(generalvalue, false));
      with oldptr.gvp^ do
	begin
	primarytype := relocatable;     datasize := sint;
	patchable := false;             longoffset := false;
	if patchbase = 0 then begin valueextend := false; short := 2; end
	else begin
	     gbytes(newptr, sizeof(valueextension, sint));
	     veptr(newptr)^.value := patchbase;
	     valueextend := true;  short := 6;
	     end
	end;
      mergetext;
      end
    else with directory.drp^ do
      begin
      oldindex.a := directory.a + sizeof(moduledirectory);
      oldindex.a := oldindex.a + strlen(oldindex.syp^) + 2 -
		     ord(odd(strlen(oldindex.syp^)));
      if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
      textrecs := textrecords;
      while textrecs > 0 do with oldindex.tdp^ do
	begin
	gbytes(newtextrec.a, sizeof(textdescriptor));
	if odd(textsize) then textsize := textsize + 1;
	newtextrec.tdp^.textsize := textsize;
	oldindex.a := oldindex.a + sizeof(textdescriptor);
	ptr := lowheap; makenewgvr(oldindex, modptr);
	compressgvr(ptr);
	mergetext;
	textrecs := textrecs - 1;
	end;
      end;
    modptr := link;
    end;

  with tempdirptr.drp^ do
    begin
    date := todaysdate;
    revision := linkerdate;
    producer := 'L';
    systemid := 3;
    notice := copyright;
    directorysize := lowheap.a - tempdirptr.a;
   {modulesize := }
    executable := (startgvr.p <> NIL);
    relocatablesize := totalreloc;
    relocatablebase := startreloc;
    globalsize := totalglobal;
    globalbase := startglobal;
   {extblock :=}
   {extsize  :=}
   {defblock := }
   {defsize  := }
    sourceblock := 0;                   {implement later}
    sourcesize  := 0;
    textrecords := newtextrecs;

    nextblock := (directorysize +(blocksize-1)) div blocksize;

    extblock :=  nextblock;
    extsize  := newextsize;
    extblocks := (newextsize + (blocksize-1)) div blocksize;
    blockwrite(outfile,point(newexttable)^,extblocks,outblock+nextblock);
    nextblock := nextblock + extblocks;

    {lowheap.a := newdirectory.a + directorysize;
    fastmove(tempdirptr.p, newdirectory.p, directorysize);
    } newdirectory := tempdirptr;
    end;

end;

procedure mergedefs;

var slist:      sortlistptr;
    ilist:      addrec;
    listlen:    shortint;
    sortlen:    shortint;
    minindex:   shortint;
    modptr:     moddescptr;
    len,
    i:          integer;
    done:       boolean;
    strptr,
    newstrptr,
    sptr:       addrec;

    newdeftable: address;
    defblocks:  integer;
    c:          char;

begin
  slist := lowheap.slp;  listlen := 0;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if not patchmod then if defsize > 0 then
      begin
      listlen := listlen + 1;
      gbytes(sptr.a, sizeof(sortdesc));
      with sptr.sdp^ do
	begin
	modp := modptr;
	def := defaddr;
	end;
      end;
    modptr := link;
    end;

  gbytes(ilist.a, listlen * sizeof(shortint));
  for i := 1 to listlen do ilist.ilp^[i] := i-1;
  sortlen := listlen;
  newdeftable := lowheap.a;

  while listlen > 0 do
    begin
    while sortlen > 0 do with slist^[ilist.ilp^[sortlen]], modp^ do
      begin
      done := false;
      repeat
       if def.a >= defaddr.a + defsize then
	 begin
	 listlen := listlen - 1;
	 for i := sortlen to listlen do ilist.ilp^[i] := ilist.ilp^[i+1];
	 done := true;
	 end
       else
	 begin
	 len := strlen(def.syp^) + 2 - ord(odd(strlen(def.syp^)));
	 with gvrptr(def.a+len)^ do
	   if patchable then def.a := def.a + len + short
	   else
	    begin
	    i := sortlen;  minindex := ilist.ilp^[i];
	    repeat
	     if i >= listlen then done := true
	     else if def.syp^ <= slist^[ilist.ilp^[i+1]].def.syp^ then done := true
	     else begin ilist.ilp^[i] := ilist.ilp^[i+1]; i := i + 1; end;
	    until done;
	    ilist.ilp^[i] := minindex;
	    end;
	 end
      until done;
      sortlen := sortlen - 1;
      end;
    if listlen > 0 then
      begin
      with slist^[ilist.ilp^[1]] do
	begin
	strptr := def;
	len := strlen(strptr.syp^) + 2 - ord(odd(strlen(strptr.syp^)));
	gbytes(newstrptr.a, len);
	fastmove(strptr.p, newstrptr.p, len);
	def.a := strptr.a + len;
	makenewgvr(def, modp);
	end;
      i := 2; done := false;
      repeat with slist^[ilist.ilp^[i]], modp^ do
	if i > listlen then done := true
	else if def.syp^ = newstrptr.syp^ then
	 begin
	   if printeron then
	     begin
	       list; writeln(listing,'duplicate symbol definition for:  ',
							  def.syp^);  {**!!!!*}
	     end
	   else
	     begin
	       errorline;
	       writeln('duplicate symbol:  ',def.syp^);
	       if streaming then escape(119);
	       write('Press ''C'' to continue, any other key to abort ',cteol);
	       read(keyboard,c);
	       if (c <> 'C') and (c <> 'c') then escape(119);
	       fgotoxy(output, 0, 22);
	       writeln(cteol);
	       write('LINKING ...', cteol);
	     end;
	   def.a := def.a + strlen(def.syp^) + 2 - ord(odd(strlen(def.syp^)));
	   def.a := def.a + def.gvp^.short;
	   i := i + 1;
	 end
	else done := true;
      until done;
      sortlen := i-1;
      end;
    end;

  with newdirectory.drp^ do
    begin
    defblock := nextblock;
    if defsout then defsize := lowheap.a - newdeftable
    else defsize := 0;
    defblocks := (defsize + (blocksize-1)) div blocksize;
    if defblocks > 0 then
     blockwrite(outfile,point(newdeftable)^,defblocks,outblock+nextblock);
    nextblock := nextblock + defblocks;
    end;
  lowheap.slp := slist;

end;

procedure copytext;

var patchptr:           patchdescptr;
    loadaddr,loadaddr0: address;
    modptr:             moddescptr;     {current module being loaded}
    gvrp:               gvrptr;
    patching,
    merging:            boolean;        {whether text records are combined}

    textbuffer,         {base of text record buffer}
    textbuftop,         {end  of text record buffer}
    textindex,          {pointer to next space available in text buffer}
    object,             {object in text record being modified by ref record}

    refbuffer,          {base of ref table buffer}
    refbuftop,          {end  of ref table buffer}
    outrefindex,        {pointer to next space available in ref buffer}
    inrefindex,         {pointer to next record in ref buffer to process}

    newptr,            {base of new gvr on heap}
    valptr,             {value extension in new gvr on heap}

    oldindex,           {pointer to old text descriptors}
    newindex:           {pointer to new text descriptors}
		addrec;

    vevalue,
    newbytes,           {size of new gvr on heap}
    offsetbytes,        {distance from last object referenced by new refs}
    oldtextrec,         {text records left to process from old module}

    textbufblocks,      {maximum blocks allocated for text buffer}
    textinblock,        {file relative block index into old text}
    textinsize,         {number of bytes left to read from old text}
    textoutblock,       {file relative block index into new text}
    textoutsize,        {number of bytes processed into new text}

    refbufblocks,       {maximum blocks allocated for ref buffer}
    refinblock,         {file relative block index into old ref table}
    refinsize,          {number of bytes left to read from old ref}
    refoutblock,        {file relative block index into new ref table}
    refoutsize:         {number of bytes processed into new ref table}
		integer;

  procedure starttext;
  begin
  if not merging then with newindex.tdp^ do
    begin
    textstart := nextblock;     textoutblock := nextblock + outblock;
    nextblock := nextblock + (textsize + (blocksize - 1)) div blocksize;
    refoutblock := nextblock + outblock;

    textoutsize := 0;           textindex   := textbuffer;
    refoutsize := 0;            outrefindex := refbuffer;
    offsetbytes := 0;           object := textbuffer;

    valptr.a := newindex.a + sizeof(textdescriptor);
    patching := (valptr.gvp^.primarytype = relocatable) and (totalpatchspace > 0);
    if patching then
     if valptr.gvp^.valueextend then
      begin
      valptr.a := valptr.a + sizeof(generalvalue, false);
      loadaddr0 := valptr.vep^.value;
      end
     else loadaddr0 := 0;
     loadaddr := object.a - loadaddr0;
    end;
  end;

  procedure endtext;
  var lastblocks: integer;
      td: addrec;
      org: integer;
  begin
  with newindex.tdp^ do
    begin
    merging := (textoutsize < textsize);
    if not merging then
      begin
      if textindex.a > textbuffer.a then
	begin
	lastblocks := (textindex.a-textbuffer.a+(blocksize-1)) div blocksize;
	blockwrite(outfile, textbuffer.p^, lastblocks, textoutblock);
	end;
      if outrefindex.a > refbuffer.a then
	begin
	lastblocks := (outrefindex.a - refbuffer.a + (blocksize-1)) div blocksize;
	blockwrite(outfile, refbuffer.p^, lastblocks, refoutblock);
	end;
      refstart := nextblock;    refsize := refoutsize;
      nextblock := nextblock + (refoutsize + (blocksize - 1)) div blocksize;
      newindex.a := newindex.a + sizeof(textdescriptor);
      org := 0; gvrstring(newindex.gvp,org,false,true);
      if printeron then
       begin
       list; writeln(listing,
       '(load record:  size = ',textsize:1,', load address = ',gvaluestring, ')');
       end;
      end;
    end;
  end;

  procedure dumptext(writebytes: integer);
  var writeblocks:      integer;
  begin
    writeblocks := writebytes div blocksize;
    writebytes := writeblocks * blocksize;
    blockwrite(outfile, textbuffer.p^, writeblocks, textoutblock);
    textoutblock := textoutblock + writeblocks;
    textindex.a := textindex.a - writebytes;
    object.a := object.a - writebytes;
    loadaddr := loadaddr - writebytes;
    fastmove(point(textbuffer.a + writebytes), textbuffer.p,
	     textindex.a - textbuffer.a);
  end;

  procedure checktextbuf(obsize: integer);
  var readbytes, writebytes:      integer;
  begin
  while textindex.a < object.a + obsize do
    begin
    readbytes :=  textbuftop.a - textindex.a;
    if textinsize <= readbytes then readbytes := textinsize
    else
      begin
      if object.a < textindex.a then writebytes := object.a    - textbuffer.a
				else writebytes := textindex.a - textbuffer.a;
      if writebytes < readbytes then
	readbytes := readbytes - readbytes mod blocksize
      else begin dumptext(writebytes); readbytes := 0; end;
      end;
    if readbytes > 0 then
      begin
      readblocks(modptr^.filefib.fbp^, textindex.p^, readbytes, textinblock);
      textinblock := textinblock + readbytes div blocksize;
      textinsize := textinsize - readbytes;
      textindex.a := textindex.a + readbytes;
      end;
    end;
  end;

  procedure dumprefs;
  var writebytes, writeblocks:    integer;
  begin
    writeblocks := (outrefindex.a - refbuffer.a) div blocksize;
    writebytes := writeblocks * blocksize;
    blockwrite(outfile, refbuffer.p^, writeblocks, refoutblock);
    refoutblock := refoutblock + writeblocks;
    outrefindex.a := outrefindex.a - writebytes;
    fastmove(point(refbuffer.a + writebytes), refbuffer.p,
	     outrefindex.a - refbuffer.a);
  end;


  procedure  checkinref;
  const maxrefsize = 254;
  var  refinbytes, readbytes:   integer;
  begin
    refinbytes := refbuftop.a - inrefindex.a;
    if refinbytes < maxrefsize then
      begin
      if refinsize > 0 then
	repeat
	if outrefindex.a > refbuffer.a + blocksize then
	     readbytes := inrefindex.a - (outrefindex.a + blocksize)
	else readbytes := inrefindex.a - (refbuffer.a + (2 * blocksize));
	if refinsize <= readbytes then readbytes := refinsize
	else if outrefindex.a - refbuffer.a < readbytes then
	       readbytes := readbytes - readbytes mod blocksize
	     else begin dumprefs; readbytes := 0; end;
	if readbytes > 0 then
	  begin
	  fastmove(inrefindex.p, point(inrefindex.a - readbytes), refinbytes);
	  inrefindex.a := inrefindex.a - readbytes;
	  readblocks(modptr^.filefib.fbp^, point(inrefindex.a + refinbytes)^,
							readbytes, refinblock);
	  refinblock := refinblock + readbytes div blocksize;
	  refinsize := refinsize - readbytes;
	  end;
	until readbytes > 0;
      end;
  end;

  procedure putref;
  var newbytes: shortint;
      valptr:   addrec;
  begin
  compressgvr(newptr);
  with newptr.gvp^ do
    if longoffset then long := offsetbytes
    else if offsetbytes < 256 then short := offsetbytes
    else
      begin
      valptr.a := newptr.a + sizeof(generalvalue,false);
      moveright(valptr.p^, point(valptr.a + 2)^,
		lowheap.a - valptr.a);
      lowheap.a := lowheap.a + 2;
      longoffset := true;
      long := offsetbytes;
      end;
  offsetbytes := 0;
  newbytes := lowheap.a - newptr.a;
  if outrefindex.a + newbytes > inrefindex.a then dumprefs;
  fastmove(newptr.p, outrefindex.p, newbytes);
  outrefindex.a := outrefindex.a + newbytes;
  refoutsize := refoutsize + newbytes;
  lowheap := newptr;
  end; {putref}

  procedure patcherror(dsize: datatype);

    procedure printmessage(var f: text);
    var index: addrec;
    begin
    index.a := modptr^.directory.a+sizeof(moduledirectory);
    write(f, 'Can''t patch byte ',
    object.a - loadaddr - loadaddr0:1,
    ' in text record ',oldtextrec:1,
    ' of module ',index.syp^);
    end;

  begin
  errors := errors + 1;
  errorline; printmessage(output);
  if printeron then
    begin list;
    write(listing, '*** ERROR *** ');
    printmessage(listing); writeln(listing);
    end
  else escape(128);
  end;

  procedure makepatch;
  var r, rptr:     addrec;
      objectaddr:  address;
      patchaddr:   address;
      foundpatchmodptr,
      patchmodptr: moddescptr;
      foundlastpptr,
      lastpatchptr,
      patchptr:    patchdescptr;
      patchdelta,
      delta2,foundpatchdelta:  integer;
      patchstate: (nopatch,longpatch,shortpatch, oldpatch);
      backwardlist: boolean;
  begin
  objectaddr := object.a - loadaddr;
  with valptr.vep^ do
   value := value + object.sw^ + objectaddr;
  with newptr.gvp^ do
   begin
   patchable := false;
   if primarytype = absolute then primarytype := relocatable
   else
    begin
    if primarytype <> general then
      begin
      gbytes(rptr.a, sizeof(referenceptr));
      with rptr.rpp^ do
       begin adr := 0; op := addit; last := false; end;
      gbytes(rptr.a, sizeof(referenceptr));
      with rptr.rpp^ do
       begin adr := ord(primarytype)-1;
       op := addit; last := true; end;
      primarytype := general;  short := short + 4;
      end
    else
      begin
      rptr.a := valptr.a + sizeof(valueextension,sint);
      with rptr.rpp^ do
       if (adr=0) and (op=subit) then
	 if last then
	   begin
	   primarytype := absolute; lowheap := rptr;
	   short := short - 2;
	   end
	 else
	   begin
	   moveleft(point(rptr.a+2)^,rptr.p^,
	     short-(valptr.a-newptr.a)-6);
	   lowheap.a := lowheap.a - sizeof(referenceptr);
	   short := short - 2;
	   end
       else
	 begin
	 gbytes(r.a, sizeof(referenceptr));
	 moveright(rptr.p^,point(rptr.a+2)^,
	   short-(valptr.a-newptr.a)-4);
	 adr := 0; op := addit; last := false;
	 short := short + 2;
	 end;
      end;
    end;
   end;
  patchstate := nopatch;
  for backwardlist := false to true do
   begin
   if backwardlist then patchmodptr := backwardpatches
		   else patchmodptr := forwardpatches;
   while (patchmodptr <> NIL) and (patchstate < oldpatch) do
    with patchmodptr^ do
     begin
     patchaddr := patchbase;
     patchptr := patchlist;
     while (patchptr<>NIL) and (patchstate < oldpatch) do
      with patchptr^ do
       begin
       patchdelta := patchaddr-objectaddr;
       if (-32768<=patchdelta) and (patchdelta<32768)
	then if gvrequal(newptr,patchref,0)
	 then begin
	      object.sw^ := patchdelta;
	      lowheap := newptr;
	      patchstate := oldpatch;
	      end;
       if patchref.gvp^.datasize = sword then
	    patchaddr := patchaddr + 4
       else patchaddr := patchaddr + 6;
       lastpatchptr := patchptr;
       patchptr := patchlist;
       end;
     patchdelta := patchaddr-objectaddr;
     if (patchstate < shortpatch) then
      if (-32768<=patchdelta) and (patchdelta<32768) then
       begin
       if patchsize - (patchaddr - patchbase) >= 4 then
	if newptr.gvp^.primarytype = relocatable then
	 begin
	 delta2 := valptr.vep^.value - (patchaddr+2);
	 if (-32768 <= delta2) and (delta2 < 32768) then
	  if object.a + patchdelta >= textbuffer.a then
	   begin
	   patchstate := shortpatch;
	   foundpatchdelta := patchdelta;
	   foundlastpptr := lastpatchptr;
	   foundpatchmodptr := patchmodptr;
	   end;
	 end;
       if (patchstate < longpatch) and not backwardlist then
	if patchsize - (patchaddr - patchbase) >= 6 then
	 begin
	 patchstate := longpatch;
	 foundpatchdelta := patchdelta;
	 foundlastpptr := lastpatchptr;
	 foundpatchmodptr := patchmodptr;
	 end;
       end;
     patchmodptr := patchlink;
     end;
   end;
  if patchstate = nopatch then patcherror(newptr.gvp^.datasize)
  else if patchstate < oldpatch then
   with foundpatchmodptr^ do
    begin
    gbytes(r.a, sizeof(patchdescriptor));
    if patchlist = NIL then patchlist := r.pdp
    else foundlastpptr^.patchlist := r.pdp;
    with r.pdp^ do
     begin
     patchlist := NIL;
     patchref := newptr;
     if patchstate = longpatch then newptr.gvp^.datasize := sint
     else begin
	  newptr.gvp^.datasize := sword;
	  if foundpatchdelta < 0 then
	   begin
	   r.a := object.a + foundpatchdelta;
	   r.uw^.w := 24576 {BRA pc relative};
	   r.a := r.a + 2;
	   r.sw^ := delta2;
	   if printeron then
	    begin
	    list; write(listing, '(backward patch)  BRA ');
	    gvrp := patchref.gvp; vevalue := 0;
	    gvrstring(gvrp, vevalue, false, true);
	    writeln(listing, gvaluestring,
	     '':20-strlen(gvaluestring),
	     r.a-2-loadaddr:10);
	    end;
	   end;
	  end;
     end;
    object.sw^ := foundpatchdelta;
    end;
  end;

begin {procedure copytext}
  {estimate data structures at 3/2(totalpatchspace) + 1/4(workspace) }
  textbufblocks := ((highheap.a - lowheap.a) * 3  -
		     totalpatchspace         * 6  ) div (blocksize * 4);

  refbufblocks := textbufblocks div 4;
  if refbufblocks < 4 then refbufblocks := 4;

  textbufblocks := textbufblocks - refbufblocks;
  if textbufblocks < 3 then textbufblocks := 3;

  gbytes(textbuffer.a, textbufblocks * blocksize);
  textbuftop := lowheap;
  gbytes(refbuffer.a,  refbufblocks  * blocksize);
  refbuftop  := lowheap;

  newindex.a := newdirectory.a + sizeof(moduledirectory);
  newindex.a := newindex.a + strlen(newindex.syp^) + 2 -
		 ord(odd(strlen(newindex.syp^)));
  if newdirectory.drp^.executable then
    newindex.a := newindex.a + newindex.gvp^.short;

  merging := false;
  modptr := newmods;
  while modptr <> NIL do with modptr^ do
    begin
    if patchmod then
      begin
      if printeron then
	begin
	list; writeln(listing, '(patch space)', patchsize:29,patchbase:10);
	end;
      starttext;
      patchptr := patchlist;
      while patchptr <> NIL do with patchptr^, patchref.gvp^ do
	begin
	if textbuftop.a - textindex.a < 6 then
	  dumptext(textindex.a - textbuffer.a);
	if printeron then
	  begin list;
	  gvrp := patchref.gvp; vevalue := 0;
	  gvrstring(gvrp, vevalue, false, true);
	  end;
	if valueextend then
	  begin
	  if longoffset then valptr.a := patchref.a +sizeof(generalvalue,true)
	  else valptr.a := patchref.a +sizeof(generalvalue,false);
	  vevalue := valptr.vep^.value;
	  end
	else vevalue := 0;
	if datasize = sword {PC relative branch} then
	  begin
	  if printeron then
	    writeln(listing, '  BRA ',gvaluestring,
	      '':26-strlen(gvaluestring), object.a-loadaddr:20);
	  object.uw^.w := 24576 {BRA pc relative};
	  object.a := object.a + 2;
	  object.sw^ := vevalue - (object.a - loadaddr);
	  object.a := object.a + 2;
	  offsetbytes := offsetbytes + 4;
	  end
	else {long absolute branch}
	  begin
	  if printeron then
	    writeln(listing, '  JMP ', gvaluestring,
	      '':26-strlen(gvaluestring), object.a-loadaddr:20);
	  object.uw^.w := 20217 {JMP long absolute};
	  object.a := object.a + 2;
	  object.si^ := vevalue;
	  object.a := object.a + 4;
	  gbytes(newptr.a, short);
	  fastmove(patchref.p, newptr.p, short);
	  if valueextend then
	    begin
	    valptr.a := newptr.a + (valptr.a - patchref.a);
	    valptr.vep^.value := 0;
	    end;
	  offsetbytes := offsetbytes + 2;
	  putref;
	  offsetbytes := 4;
	  end;
	textindex := object;
	patchptr := patchlist;
	end;
      object.a := textindex.a + patchsize - (object.a - loadaddr - patchbase);
      while textindex.a < object.a do
	begin
	if textindex.a >= textbuftop.a - 2 then
	  dumptext(textindex.a - textbuffer.a);
	textindex.sw^ := -1;
	textindex.a := textindex.a + 2;
	offsetbytes := offsetbytes + 2;
	end;
      textoutsize := textoutsize + patchsize;
      endtext;
      forwardpatches := patchlink;
      patchlink := backwardpatches;
      backwardpatches := modptr;
      end
    else with directory.drp^ do
      begin
      oldindex.a := directory.a + sizeof(moduledirectory);
      if printeron then
	begin
	list; writeln(listing, oldindex.syp^, '':32-strlen(oldindex.syp^),
		 relocatablesize:10,relocbase:10,
		 globalsize:10,     globase:10);
	end;
      oldindex.a := oldindex.a + strlen(oldindex.syp^) + 2 -
		     ord(odd(strlen(oldindex.syp^)));
      if executable then oldindex.a := oldindex.a + oldindex.gvp^.short;
      for oldtextrec := 1 to textrecords do
       begin
       if oldindex.tdp^.textsize > 0 then
	begin
	starttext;
	loadaddr0 := object.a - loadaddr;
	with oldindex.tdp^ do
	  begin
	  refinsize := refsize;
	  textinsize := textsize;
	  refinblock := fileblock+refstart;
	  textinblock := fileblock+textstart;
	  textoutsize := textoutsize + textsize;
	  end;

	inrefindex := refbuftop;

	while (refbuftop.a - inrefindex.a) + refinsize > 0 do
	  begin
	  checkinref;
	  newptr := lowheap;
	  with inrefindex.gvp^ do
	    if longoffset then
	      begin
	      newbytes := long;
	      valptr.a := newptr.a + sizeof(generalvalue, true);
	      end
	    else
	      begin
	      newbytes := short;
	      valptr.a := newptr.a + sizeof(generalvalue, false);
	      end;
	  object.a := object.a + newbytes;
	  offsetbytes := offsetbytes + newbytes;
	  makenewgvr(inrefindex, modptr);
	  with newptr.gvp^, valptr.vep^ do
	    begin
	    case datasize of   {$range off$}
	      sbyte:
		begin
		checktextbuf(sizeof(sbyterec));
		value         := value + object.sb^.sb;
		object.sb^.sb := value;
		value         := value - object.sb^.sb;
		end;
	      sword:
		begin
		checktextbuf(sizeof(shortint));
		value         := value + object.sw^;
		object.sw^    := value;
		value         := value - object.sw^;
		end;
	      sint:
		begin
		checktextbuf(sizeof(integer));
		object.si^ := object.si^ + value;
		value := 0;
		end;
	      ubyte:
		begin
		checktextbuf(sizeof(ubyterec));
		value         := value + object.ub^.ub;
		object.ub^.ub := value;
		value         := value - object.ub^.ub;
		end;
	      uword:
		begin
		checktextbuf(sizeof(wordrec));
		value         := value + object.uw^.w;
		object.uw^.w  := value;
		value         := value - object.uw^.w;
		end;        {$range on$}
	      otherwise escape(111);
	      end; {case datasize}
	    if primarytype = absolute then
	      begin
	      if value <> 0 then
		if patchable and patching then makepatch
		else patcherror(datasize);
		end
	    else if patching and patchable then makepatch
	    else putref;
	    end; {with gvrptr(newptr)^, valptr^}
	  end; {while there are any ref's }

	newbytes := textindex.a + textinsize  - object.a;
	offsetbytes := offsetbytes + newbytes;
	object.a := object.a + newbytes;
	checktextbuf(0);

	endtext;
	end;
       oldindex.a := oldindex.a + sizeof(textdescriptor);
       oldindex.a := oldindex.a + oldindex.gvp^.short;
       end; {for oldtextrec}
      end; {with directory^ do}
    modptr := link;
    end;
end; {copytext}

procedure printdirectentry(modnum: shortint; var entry: direntry);
begin
with entry do
  begin
  upc(dtid);
  list; write(listing, modnum:4,' ',dtid,
  dlastblk-dfirstblk:21-strlen(dtid),'  ');
  writedate(listing, daccess);
  writeln(listing, dfirstblk:7);
  end;
end;

procedure bootmod(modnum: shortint);
const sectorsize = 256;
var     buffer, bufptr, valptr, ptr, endrefs, mname,
	infostart:      addrec;
	object, recordnum:  integer;

procedure writesector(anyvar f: fib; anyvar obj: window; size,sector: integer);
begin
  call (f.am, addr(f), writebytes, obj, size, sector * sectorsize);
  if ioresult <> 0 then escape(114);
end;

begin
  infostart := lowheap;
  loadinfo(modnum,true, true);
  with newmods^,directory.drp^ do
    begin
    if extsize > 8 then escape(120);
    mname.a := directory.a + sizeof(moduledirectory);
    ptr.a := mname.a + strlen(mname.syp^) + 2 - ord(odd(strlen(mname.syp^)));
    if executable then with ptr.gvp^, fibp(addr(outfile))^ do
      begin
      if fstartaddress = 0 then
	if valueextend then
	  begin
	  valptr.a := ptr.a + sizeof(generalvalue,false);
	  fstartaddress := valptr.vep^.value;
	  end;
      ptr.a := ptr.a + short;
      end;
    recordnum := 0;
    while textrecords > 0 do with ptr.tdp^ do
      begin
      recordnum := recordnum + 1;
      if refsize > 0 then       {check to make sure code is "absolute"}
	begin
	gbytes(buffer.a, refsize);
	readblocks(filefib.fbp^,buffer.p^,refsize,fileblock+refstart);
	bufptr := buffer; endrefs.a := buffer.a + refsize;
	object := 0;
	while bufptr.a < endrefs.a do with bufptr.gvp^ do
	  begin
	  if longoffset then
	       begin object := object + long;
	       bufptr.a := bufptr.a + sizeof(generalvalue, true);
	       end
	  else begin object := object + short;
	       bufptr.a := bufptr.a + sizeof(generalvalue, false);
	       end;
	  if valueextend then
	    begin
	    errorline;
	    write  ('Can''t relocate byte ',object:1,
		    ' in record ',recordnum:1,
		    ' of module ',mname.syp^);
	    escape(128);
	    end;
	  if primarytype = general then
	    begin
	    while not bufptr.rpp^.last do
	      bufptr.a := bufptr.a + sizeof(referenceptr);
	    bufptr.a := bufptr.a + sizeof(referenceptr);
	    end;
	  end;
	lowheap := buffer;
	end;
      gbytes(buffer.a, sizeof(integer));
      ptr.a := ptr.a + sizeof(textdescriptor);
      with ptr.gvp^ do
	begin
	if valueextend then
	  begin
	  valptr.a := ptr.a + sizeof(generalvalue,false);
	  buffer.p^ := valptr.vep^.value;
	  end
	else buffer.p^ := 0;
	ptr.a := ptr.a + short;
	end;

      gbytes(bufptr.a, sizeof(integer));
      bufptr.p^ := textsize;

      gbytes(bufptr.a, textsize);
      readblocks(filefib.fbp^,bufptr.p^,textsize,fileblock+textstart);
      writesector(outfile, buffer.p^, textsize+2*sizeof(integer), outblock);
      outblock := outblock +
		(textsize + 2*sizeof(integer) + (sectorsize-1)) div sectorsize;
      lowheap := buffer;
      textrecords := textrecords - 1;
      end;
    end;
  lowheap := infostart;
  newmods := NIL;
end;

procedure copymodule(modnum: shortint);
const fosize = sizeof(addrec)+sizeof(fib,1);
      fsize  = fosize+ord(odd(fosize));
var startblock, numblocks, transblocks:  {shortint} INTEGER;       {SFB}
    copybuffer: addrec;
    bufblocks:  {shortint}  INTEGER;       {SFB}
begin
if booting then bootmod(modnum)
else if linking then begin
		     if loadfib.a >= highheap.a then
		       begin
		       fastmove(highheap.p, lowheap.p, fsize);
		       highheap.a := highheap.a + fsize;
		       lowheap.a := lowheap.a + fsize;
		       loadfib.a := loadfib.a - (highheap.a - lowheap.a);
		       end;
		     loadinfo(modnum, true, true)
		     end
else
  begin
  bufblocks := (highheap.a -lowheap.a) div blocksize;
  gbytes(copybuffer.a, bufblocks * blocksize);

  if outmodnum>=maxmodules then escape(127);
  outmodnum := outmodnum + 1;
  outdirectory.fdp^[outmodnum] := fdirectory^[modnum];
  with fdirectory^[modnum] do
    begin
    startblock := dfirstblk;      numblocks := dlastblk-startblock;
    end;
  with outdirectory.fdp^[outmodnum] do
    begin
    dfirstblk := outblock;        dlastblk := outblock + numblocks;
    end;
  while numblocks > 0 do
    begin
    if numblocks <= bufblocks then transblocks := numblocks
			      else transblocks := bufblocks;
    readblocks(loadfib.fbp^, copybuffer.p^, transblocks*blocksize, startblock);
    blockwrite(outfile, copybuffer.p^, transblocks, outblock);
    startblock := startblock + transblocks;
    outblock := outblock + transblocks;
    numblocks := numblocks - transblocks;
    end;
    lowheap := copybuffer;
    {if printeron then printdirectentry(outmodnum, outdirectory.fdp^[outmodnum]); }
  end;
end;

procedure writedirectory;
begin
  with newdirectory.drp^ do
  begin
    modulesize := nextblock * blocksize;
    blockwrite(outfile, newdirectory.drp^, extblock, outblock);
  end;

  if outmodnum>=maxmodules then escape(127);
  outmodnum := outmodnum + 1;
  with outdirectory.fdp^[outmodnum] do
    begin
    dfirstblk := outblock;
    outblock := outblock + nextblock;
    dlastblk := outblock;
    dfkind := codefile;
    moveleft(newmodname.syp^, dtid, sizeof(filname));
    if strlen(dtid) > fnlength then setstrlen(dtid, fnlength);
    dlastbyte := 256;
    daccess := todaysdate;
    end;
  {if printeron then printdirectentry(outmodnum, outdirectory.fdp^[outmodnum]); }
end;

procedure trim(var s: string);
var first, last: shortint;
begin
  last := strlen(s);
  while last > 0 do
    begin
    if s[last] = ' ' then
      begin last := last - 1; if last = 0 then s := ''; end
    else
      begin
      first := 1;  while s[first] = ' ' do first := first + 1;
      s := str(s, first, last - first + 1);  last := 0;
      end;
    end;
end;

procedure toggleprinter;
var newlistname: string80;
    fvid: vid;
    ftitle: fid;
    fsegs:  integer;
    fkind:  filekind;
begin
printeron := not printeron;
if printeron then
  begin
  fgotoxy(output, 13,3); write('     ',cteol);
  readln(newlistname);
  fixname(newlistname, textfile);
  if scantitle(newlistname, fvid, ftitle, fsegs, fkind) then ; { jws 3/2/84}
  if strlen(newlistname)>0 then
    begin
    listfilename := newlistname;
    if fsegs=0 then                                           { jws 3/2/84 }
	   sappend(newlistname, '[*]');
    pageeject;
    if (pagenum=0) and (linenum=0)
       then close(listing)
       else close(listing, 'lock');
    rewrite(listing, newlistname);
    pagenum := 0;       linenum := 0;
    printopen := ioresult = 0;
    printeron := printopen;
    if not printopen then escape(118);
    end
  else printeron := printopen;
  end;
end;

procedure copyon;
begin
 lowheap := infostart;
 linking := false;
end;

procedure closein;
begin
 if fdirectory <> NIL then
  begin
  if loadfib.a >= highheap.a then
    begin
    close(loadfib.php^);
    loadfib.a := loadfib.a - sizeof(addrec);
    loadfib := loadfib.arp^;
    end;
   highheap := highheap0; fdirectory := NIL;
   vmodnum := 0; verifying := false;
  end;
end;

procedure initlink;
begin
 linking := true;       defsout := true;
 infostart := lowheap;  newmodname.syp := NIL;
 startreloc := 0;       startglobal := 0;
 copyright := '';
end;

procedure link;
begin
 errors := 0;
 fgotoxy(output, 0,23); write('LINKING ...');
 rsolve;
 if printeron then
   begin
   list; writeln(listing, 'link map', 'Rsize':34, 'Rbase':10, 'Gsize':10, 'Gbase':10);
   list; writeln(listing, '------':42, '------':10, '------':10, '------':10);
   end;
 newdirectory := lowheap;
 mergeexts;
 makedir;        {also write new ext table, move down directory}
 mergedefs;
 copytext;
 writedirectory;

 if printeron then
   begin
   list; writeln(listing, '------':42,'------':20);
   list;
   if newmodname.syp = NIL then write(listing, '(no name)', '':32-9)
   else write(listing, newmodname.syp^, '':32-strlen(newmodname.syp^));
   writeln(listing, totalreloc:10, totalglobal:20);
   listln;
   end;
 closein;
 closefiles;
 lowheap := infostart; {release memory used by linker}
 linking := false;      newmods := NIL;
 if errors > 0 then escape(122);
end; {link}


procedure printdirectory;
var numfiles:   shortint;
    modnum:     shortint;
begin
 list; writeln(listing, 'FILE DIRECTORY OF:  ''', loadfib.fbp^.ftid, '''');
 listln;
 numfiles := fdirectory^[0].dnumfiles;
 for modnum := 1 to numfiles do
   printdirectentry(modnum, fdirectory^[modnum]);
 listln;
end;

procedure copyfile;
var modnum:     shortint;
begin
 for modnum := 1 to fdirectory^[0].dnumfiles do
  copymodule(modnum);
 closein;
end;

procedure verifynext;
begin
 if vmodnum < fdirectory^[0].dnumfiles then
  begin
  vmodnum := vmodnum + 1;
  upc(fdirectory^[vmodnum].dtid)
  end
 else
  begin
  vmodnum := 0;
  verifying := false;
  end;
end;

procedure verifymod;
begin
 vmodnum := 0;  verifying := true;
 verifynext;
end;

procedure xfer;
var modnum:     shortint;
begin
 if verifying then
  begin
  copymodule(vmodnum);
  verifynext;
  end
 else
  begin
  for modnum := 1 to fdirectory^[0].dnumfiles do
   with fdirectory^[modnum] do
    begin
    upc(dtid);
    if dtid = fdirectory^[vmodnum].dtid then
      copymodule(modnum);
    end;
  vmodnum := 0;
  end;
end;

procedure openin;
const fosize = sizeof(addrec)+sizeof(fib,1);
      fsize  = fosize+ord(odd(fosize));
begin
 closein;
 fgotoxy(output, 22,13); write(cteol);
 if strlen(infilename)=0 then   { if no name then get it }
 begin readln(infilename); fixname(infilename, codefile);
 end;
 if strlen(infilename) > 0 then
 begin
   openlinkfile(infilename);
   if fdirectory = NIL then
   begin errorline;
	 write('cannot open ''', infilename, ''', ');
	 ioerror;
   end
   else
   begin highheap.a := highheap.a - fsize;
	 lowheap.a := lowheap.a - fsize;
	 fastmove(lowheap.p, highheap.p, fsize);
	 loadfib.a := loadfib.a + (highheap.a - lowheap.a);
	 if fdirectory^[0].dnumfiles = 1 then vmodnum := 1
					 else verifymod;
    end;
  end;
end;    { openin }

procedure closeout;
begin
 closein;
 with outdirectory.fdp^[0] do
  begin
  deovblk := outblock;
  dnumfiles := outmodnum;
  outopen := false;     outmodnum := 0;
  lowheap := outdirectory;
  blockwrite(outfile, outdirectory.fdp^, outdirectsize, 0);
  close(outfile, 'lock');
  if ioresult <> 0 then escape(126);
  end;
end;

procedure openout(boot: boolean);
var i,j: integer;
    nul: string[1]; typestring: string[6];
    thirdparm: string[10];
begin
 thirdparm := 'shared';
 if linking then lowheap := infostart;
 linking := false;
 if outopen then
   begin
   close(outfile);
   lowheap := outdirectory;
   end;
 outopen := false;
 fgotoxy(output, 22,4); write(cteol);
 readln(outfilename);
 trim(outfilename);
 if strlen(outfilename) > 0 then
  begin
  nul := '';
  if boot then
   begin
   fixname(outfilename, sysfile);
   reset(outfile, outfilename); close(outfile, 'PURGE');
   typestring := '.SYSTM'; fmaketype(outfile, outfilename, thirdparm, typestring);
   outopen := (ioresult = 0);
   outblock := 0;
   end
  else
   begin
   fixname(outfilename, codefile);
   typestring := '.CODE'; fmaketype(outfile, outfilename, thirdparm, typestring);
   if ioresult = 0 then
    begin
    gbytes(outdirectory.a, outdirectsize*blocksize);
    with outdirectory.fdp^[0] do
      begin
      dfirstblk := 0; dlastblk := outdirectsize;
      dfkind := untypedfile {volume entry};
      moveleft(outfilename, dvid, sizeof(volname));
      if strlen(outfilename) > vnlength then setstrlen(dvid, vnlength);
      deovblk := outdirectsize; dnumfiles := 0;
      dloadtime := 0; dlastboot := todaysdate;
      end;
    outblock := outdirectsize;
    outopen := true;
    end;
   end;
  if outopen then booting := boot
  else
   begin
   booting := false;
   errorline;
   write('cannot open ''', outfilename, ''', ');
   ioerror;
   end;
  end;
end;    { openout }

procedure setmaxmodules;
var total, excess: integer;
begin
 fgotoxy(output, 30,6); write(cteol);
 if readint(maxmodules) then
   begin
   if maxmodules > 300000 then
     begin
     maxmodules := 38;
     escape(125);
     end;
   if maxmodules <= 0 then maxmodules := 0;
   outdirectsize := ((maxmodules+1)*entrysize+(blocksize-1)) div blocksize;
   maxmodules := outdirectsize*blocksize div entrysize - 1;
   end;
end;

procedure setreloc;
begin
 fgotoxy(output, 21,7); write(cteol);
 if readint(startreloc) then ;
end;

procedure setglobal;
begin
 fgotoxy(output, 21,8); write(cteol);
 if readint(startglobal) then ;
end;

procedure setcopyright;
begin
  fgotoxy(output, 0,12); write(cteol);
  fgotoxy(output, 22,11); write(cteol);
  readln(copyright);
end;

procedure makepatchspace;
var pmod:       addrec;
begin
 fgotoxy(output, 23,9); write(cteol);
 if readint(patchbytes) then
  if patchbytes > 0 then
   begin
   patchbytes := patchbytes + ord(odd(patchbytes));
   gbytes(pmod.a, sizeof(moduledescriptor,true));
   with pmod.mdp^ do
     begin
     patchmod := true;   patchsize := patchbytes;
     link := newmods;    newmods := pmod.mdp;
     patchlink := NIL;   patchlist := NIL;
     end;
   end;
end;

procedure setname;
var s: string80;
begin
 fgotoxy(output, 24,6); write(cteol);
 readln(s); trim(s);
 if strlen(s)=0 then newmodname.syp := NIL
 else
  begin
  upc(s);
  gbytes(newmodname.a, strlen(s)+2-ord(odd(strlen(s))));
  moveleft(s, newmodname.syp^, strlen(s)+1);
  end;
end;    {setname}

procedure openmod;
var s: string80;
    i: shortint;
begin
  verifying := false;   vmodnum := 0;
  fgotoxy(output, 18,18); write(cteol);
  readln(s); trim(s);
  if strlen(s) > 0 then
   begin
   upc(s);        i := 1;
   while (i <= fdirectory^[0].dnumfiles) and (vmodnum = 0) do
    with fdirectory^[i] do
     begin
     upc(dtid);
     if s = dtid then vmodnum := i
     else i:= i + 1;
     end;
   if vmodnum = 0 then
     begin
     errorline; write('module ''', s,''' not found in file');
     escape(123);
     end;
   end;
end;    {openmod}

procedure findmod(var s:filname; var n:shortint);
var i : integer;
begin
  if strlen(s)=0 then   { if no name given then get it }
  begin readln(s); trim(s); end;
  n:= 0;
  if strlen(s) > 0 then
  begin
    upc(s);        i := 1;
    while (i <= fdirectory^[0].dnumfiles) and (n = 0) do
      with fdirectory^[i] do
      begin
	upc(dtid);
	if s = dtid then n := i else i:= i + 1;
      end;
    if n = 0 then n:=-1;        { signal not found }
  end;
end;    { findmod }

procedure clear(N: shortint);
begin
  repeat writeln(cteol); n := n - 1; until n <= 0;
end;

procedure none;
begin write('(none)'); clear(1); end;

procedure doedit;
var
  firstmodname,untilmodname, oldvmodname : filname;
  firstmodnum, untilmodnum,  oldvmodnum  : integer;
  oldfilename: string80;
  modlist    : string255;
  assoc : boolean;
  lc    : string[4];
  tempf : filname;
  im    : shortint;

  procedure checkassoc;
  begin
    assoc:=assoc and (vmodnum>0);
    if assoc then
    begin firstmodname:=fdirectory^[vmodnum].dtid;
	  firstmodnum:=vmodnum;
	  assoc:=assoc and (firstmodnum<>untilmodnum);
    end;
  end;
  procedure outoforder;
  begin errorline; write('module ',tempf,' out of order'); dobeep;
  end;
  procedure mnotfound;
  begin errorline; write('module ',tempf,' not found'); dobeep;
  end;

begin   { doedit }
  untilmodname := '(end of file)';
  untilmodnum  := fdirectory^[0].dnumfiles+1;
  if vmodnum=0 then firstmodname:='(none)'
	       else firstmodname := fdirectory^[vmodnum].dtid;
  firstmodnum  := vmodnum;
  assoc := true;
  fgotoxy(output,0,2); write(cteos);
  repeat
    fgotoxy(output,0,2);
    writeln('S  Stop editing');
    clear(2);
    if firstmodnum>0 then
       writeln('C  Copy First module upto Until module',cteol)
    else clear(1);
    writeln('F  First module: ',firstmodname,cteol);
    writeln('U  Until module: ',untilmodname,cteol);
    clear(1);
    writeln('A  Append module(s)'); clear(5);
    fgotoxy(output,0,18);
    write('M  input Module:  ');
    if vmodnum = 0 then begin none; clear(3); end
    else
    begin
      writeln(fdirectory^[vmodnum].dtid,cteol);
      if booting then      lc := 'boot'
      else if linking then lc := 'link'
		      else lc := 'copy';
      writeln;
      writeln('T  Transfer (',lc,') module',cteol);
      writeln('<space> to continue verifying',cteol);
    end;
    getcommandchar('Edit option?',commandchar);
    case commandchar of
    'A':begin
	  oldfilename:= infilename;     { save current inputfile name }
	  oldvmodnum := vmodnum;        { same current module number & name }
	  oldvmodname := fdirectory^[vmodnum].dtid;
	  fgotoxy(output,0,13); write('        Input  file:  ',cteol);
	  setstrlen(infilename,0);
	  openin;       { get new input file }
	  if strlen(infilename)>0 then begin       { 3.0 BUG FIX -- 4/11/84 }
	    { get list of modules and copy them }
	    fgotoxy(output,0,10);
	    writeln('enter list of modules or = for all');
	    readln(modlist); trim(modlist); upc(modlist);
	    if modlist='=' then
	    begin { all modules }
	      for im:=1 to fdirectory^[0].dnumfiles do
	      begin
		fgotoxy(output,0,11); write(fdirectory^[im].dtid,cteol);
		copymodule(im);
	      end;
	    end
	    else
	    while strlen(modlist)>0 do
	    begin
	      im:=strpos(',',modlist);
	      if im=0 then im:=strlen(modlist)+1;
	      try
		if im>sizeof(tempf) then escape(129)
				   else tempf:=str(modlist,1,im-1);
		if im>strlen(modlist) then setstrlen(modlist,0)
				     else strdelete(modlist,1,im);
		if strlen(tempf)>0 then
		begin     { find the module and copy it }
		  findmod(tempf,vmodnum);
		  if vmodnum>0 then copymodule(vmodnum) else escape(123);
		  fgotoxy(output,0,11); write(modlist,cteol);
		end;
	      recover
	      begin
		im:=escapecode;  errorline;
		case im of
		  123: writeln('module ',tempf,' not found');
		  129: writeln('invalid module name');
		  otherwise escape(im)
		end; { case im }
		dobeep; setstrlen(modlist,0);     { zap module list to force exit }
	      end;{ end recover}
	    end;  {while list not empty}

	    if not streaming then                 { 3.0 bug fix -- 4/9/84 jws }
	      repeat getcommandchar('Append done, <space> to continue',commandchar);
	      until commandchar=' ';
	  end;                                    { 3.0 BUG FIX -- 4/11/84 }

	  infilename := oldfilename;
	  openin;       { reopen the old file & find old input module }
	  if oldvmodnum=0 then vmodnum:=0
	  else
	  begin
	    findmod(oldvmodname,vmodnum);
	    if (vmodnum<>oldvmodnum) then
	    begin errorline;
		  write('unable to find old input module ',oldvmodname);
		  vmodnum:=0; dobeep;
	    end;
	  end;
	end;
    'C':if (firstmodnum>0) and (firstmodnum<untilmodnum) then
	begin
	  for im:=firstmodnum to untilmodnum-1 do
	  begin fgotoxy(output,0,8);
		write('now copying ',fdirectory^[im].dtid,cteol);
		copymodule(im);
	  end;
	  if assoc then
	  begin
	    if untilmodnum>fdirectory^[0].dnumfiles
	       then begin vmodnum := 0;
			  firstmodname := '(none)';
		    end
	       else begin vmodnum := untilmodnum;
			  firstmodname := fdirectory^[vmodnum].dtid;
		    end;
	    firstmodnum  := vmodnum;
	    assoc:= assoc and (vmodnum>0);
	  end;
	end
	else dobeep;
    'F':begin
	  fgotoxy(output,17,6); write(cteol);
	  setstrlen(tempf,0); findmod(tempf,im);
	  case im of
	  -1: mnotfound;
	   0: { no module name given, so use default }
	      begin if (vmodnum>0) and (vmodnum<=untilmodnum) then
		begin firstmodname := fdirectory^[vmodnum].dtid;
		      firstmodnum  := vmodnum;
		      assoc := assoc and (vmodnum<untilmodnum);
		end
		else dobeep;
	     end;
	  otherwise     { found the module }
	    if im<=untilmodnum then
	    begin firstmodname := tempf; firstmodnum:=im; assoc:=false;
	    end
	    else outoforder;
	  end;  { case im }
	end;
    'M': if fdirectory<>NIL then
	 begin openmod;
	   if vmodnum>0 then begin        { 3.0 BUG # 57   4/10/84 }
	     assoc := assoc and (vmodnum<untilmodnum);
	     if assoc then
	     begin
	       firstmodname := fdirectory^[vmodnum].dtid;
	       firstmodnum  := vmodnum;
	     end;
	   end                            { 3.0 BUG # 57   4/10/84 }
	   else dobeep                    { 3.0 BUG # 57   4/10/84 }
	 end
	 else dobeep;
    'S':;
    'T': if vmodnum>0 then
	 begin xfer; checkassoc;
	 end
	 else dobeep;
    'U':begin
	  fgotoxy(output,17,7); write(cteol);
	  setstrlen(tempf,0); findmod(tempf,im);
	  case im of
	  -1: mnotfound;
	   0: { no module name given, so default }
	      begin untilmodname := '(end of file)';
		    untilmodnum  := fdirectory^[0].dnumfiles+1;
	      end;
	  otherwise     { found the module }
	      if im>=firstmodnum then
	      begin untilmodname := tempf; untilmodnum:=im;
	      end
	      else outoforder;
	      assoc := assoc and (im>firstmodnum);
	  end;  { case im }
	end;
    ' ': if vmodnum>0 then
	 begin verifynext; checkassoc;
	 end
	 else dobeep;
    otherwise dobeep
    end;
  until commandchar='S';
end;    {doedit}

procedure finishboot;
begin
close(outfile, 'LOCK');
if ioresult<>0 then escape(126);
outopen := false; booting := false;
outmodnum := 0;
end;

procedure menu;
var lc: string[4];
begin
 fgotoxy(output, 0,2); write('Q  Quit'); clear(1);

 write('P  Printout  ');
 if printopen then
   begin
   if printeron then write('ON   ')
		else write('OFF  ');
   write(listfilename);
   clear(1);
   end
 else none;

 if outmodnum > 0 then write('K  Keep o')
 else if (newmods = NIL) and not booting
		  then write('O       O')
		  else write('        o');
 write('utput file:  ');
 if outopen then writeln(outfilename,cteol)
	    else none;
 if outopen then
  begin
  if booting then write('B  finish Boot')
  else if newmods <> NIL then write('L  finish Linking')
  else if linking then write('C  Copy')
  else write('L  Link');
  write(cteol); fgotoxy(output, 40,5);
  if booting then      begin
		       writeln('BOOTING');
		       lc := 'boot';
		       end
  else if linking then begin
		       writeln('LINKING');
		       lc := 'link';
		       end
  else                 begin
		       writeln('COPYING');
		       lc := 'copy';
		       end;
  end
 else
  begin
   writeln('B  write to Boot disk',cteol);
   writeln('H  file Header maximum size:  ',maxmodules,cteol);
  end;

 if linking and outopen then
  begin
  write('N  Name of new module:  ');
  if newmodname.syp = NIL then none
  else writeln(newmodname.syp^,cteol);
  writeln('R  Relocation base:  ',startreloc:12,cteol);
  writeln('G  Global base:      ',startglobal:12,cteol);
  write  ('S  Space for patches:');
  if patchbytes > 0 then writeln(patchbytes:12)
  else clear(1);
  patchbytes := 0;
  write('D  output Def table?  ');
  if defsout then write('YES')
  else write('NO ');
  writeln(cteol);
  writeln('X  copyright notice:  ',copyright);
  end
 else clear(7);

 fgotoxy(output, 0,13);
 write('I       Input  file:  ');
 if fdirectory = NIL then
  begin none; clear(7); end
 else
  begin
  writeln(infilename,cteol);
  if outopen then writeln('E  Edit') else clear(1);
  writeln('F  list File directory');
  if outopen then writeln('A  ',lc,' All modules') else clear(1);
  write('V  Verify modules');
  if verifying then
    begin
    fgotoxy(output, 40,17); writeln('VERIFYING');
    end
  else clear(1);
  write('M  input Module:  ');
  if vmodnum = 0 then
    begin none; clear(3); end
  else
    begin
    writeln(fdirectory^[vmodnum].dtid,cteol);
    writeln('U  Unassemble object');
    if outopen then writeln('T  Transfer (',lc,') module')
    else clear(1);
    if verifying then writeln('<space> to continue verifying')
    else clear(1);
    end;
  end;
end; {menu}

procedure getcommand;
var err: string[80];
begin
  repeat
  try
  menu;
  getcommandchar('command?',commandchar);
  case commandchar of
   'A': if (fdirectory<>NIL) and  outopen then copyfile else dobeep;
   'B': if booting then finishboot
	else if outopen then dobeep
	else openout(true);
   'C': if outopen and linking and (newmods = NIL)
	and not booting then copyon else dobeep;
   'D': if linking and outopen
	then defsout := not defsout else dobeep;
   'E': if (fdirectory<>NIL) and outopen then doedit else dobeep;
   'F': if fdirectory<>NIL then printdirectory else dobeep;
   'G': if linking and outopen then setglobal else dobeep;
   'H': if outopen then dobeep else setmaxmodules;
   'I': begin setstrlen(infilename,0); openin; end;
   'K': if (outmodnum > 0) and not booting
	then closeout else dobeep;
   'L': if booting then dobeep
	else if newmods <> NIL then link
	else if outopen and not linking
	then initlink else dobeep;
   'M': if fdirectory<>NIL then openmod else dobeep;
   'N': if linking and outopen then setname else dobeep;
   'O': if (outmodnum = 0) and (newmods=NIL) and not booting
	then openout(false) else dobeep;
   'P': toggleprinter;
   'Q': quit;
   'R': if linking and outopen then setreloc else dobeep;
   'S': if linking and outopen then makepatchspace else dobeep;
   'T': if (vmodnum > 0) and outopen then xfer else dobeep;
   'U': if (vmodnum > 0) then unassemble else dobeep;
   'V': if fdirectory<>NIL then verifymod else dobeep;
   'X': if linking and outopen then setcopyright else dobeep;
   ' ': if verifying then verifynext;

  otherwise dobeep;
  end;

  recover
   begin
   if (escapecode <> -20) and (escapecode <> 123) and (escapecode<>128)
								then errorline;
   if escapecode=-10 then begin getioerrmsg(err, ires); writeln(err); end
   else case escapecode of
    110: write('symbols defined recursively');
    111: write('improper link info format');
    112: write('not enough memory');
    113: write('output file full');
    114: write('error writing to boot disk, ioresult = ',ires:1);
    116: write('''', infilename, ''' is not a code file');
    118: write('printer or list file not on line');
    119: write('duplicate symbol definition');
    120: write('module being booted has external references');
    121: write('unexpected end of code');
    122: write(errors:1, ' errors during linking',cteol);
    123,128,129: {error message already printed};
    124: write('integer required');
    125: write('integer too large');
    126: write('unable to close output, ioresult = ',ires:1);
    127: write('file header full');
    otherwise escape(escapecode);
    end; {case escapecode}
    if streaming then escape(-1);
    if (escapecode-100) in [12,16] then closein;
    if (escapecode-100) in [10..13,19,22,26,28] then
      begin
      if newmods <> NIL then begin closein; closefiles; end;
      linking := false;     newmods := NIL;
      if outopen then close(outfile);
      outopen := false;     outmodnum := 0;
      booting := false;
      lowheap := lowheap0;
      end;
   end; {recover}
  until commandchar = 'Q';
end {getcommand};


procedure wrapup;
begin
 pageeject;
 closein;
 closefiles;
 if (pagenum=0) and (linenum=0)
   then close(listing)
   else close(listing, 'lock');
end; {wrapup}

begin {program linker}
  with linkerdate do
    begin day := 16; year := 91; month := 3; end;
  sysdate(todaysdate);

  pagenum := 0;         linenum := 0;

  fgotoxy(output, 0,0);
  printheader(output);
  fgotoxy(output, 0, 22);
  writeln('Copyright Hewlett-Packard Company, 1982, 1991.');

  mark(lowheap.p); lowheap0 := lowheap;
  highheap.a := lowheap.a + memavail - 5000;
  release(highheap.p); highheap0 := highheap;

  listfilename := 'PRINTER:LINK.ASC';
  rewrite(listing, listfilename);
  printopen := ioresult = 0;
  printeron := false;

  patchbytes := 0;
  maxmodules := 38;     outdirectsize := 2;
  linking := false;     newmods := NIL;
  outopen := false;     outmodnum := 0;
  booting := false;     verifying := false;
  fdirectory := NIL;    vmodnum := 0;
  loadfib.php := NIL;

  try getcommand;

  recover begin
	  esccode := escapecode;
	  wrapup;
	  escape(esccode);
	  end;

  wrapup;

end.
@


53.3
log
@
pws2rcs automatic delta on Mon Mar 18 13:19:08 MST 1991
@
text
@@


53.2
log
@Updated copyright message.
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.24B ');
d4853 1
a4853 1
    begin day := 10; year := 91; month := 3; end;
@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@d3 1
a3 1
 (c) Copyright Hewlett-Packard Company, 1985,1990.
d4861 1
a4861 1
  writeln('Copyright Hewlett-Packard Company, 1982, 1990.');
@


52.2
log
@
pws2rcs automatic delta on Mon Mar 11 16:41:32 MST 1991
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.24A ');
d4853 1
a4853 1
    begin day := 16; year := 91; month := 02; end;
@


51.2
log
@
pws2rcs automatic delta on Mon Feb 18 20:38:36 MST 1991
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.24d ');
d4853 1
a4853 1
    begin day := 28; year := 91; month := 1; end;
@


50.2
log
@
pws2rcs automatic delta on Wed Jan 30 09:08:19 MST 1991
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.24c ');
d4853 1
a4853 1
    begin day := 25; year := 90; month := 10; end;
@


49.2
log
@
pws2rcs automatic delta on Mon Oct 29 14:00:44 MST 1990
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.24b ');
d4853 1
a4853 1
    begin day := 13; year := 90; month := 08; end;
@


48.2
log
@
pws2rcs automatic delta on Tue Aug 14 09:29:26 MDT 1990
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.24a ');
d4853 1
a4853 1
    begin day := 23; year := 90; month := 07; end;
@


47.2
log
@
pws2rcs automatic delta on Tue Jul 24 14:47:20 MDT 1990
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23 ');
d4853 1
a4853 1
    begin day := 03; year := 90; month := 05; end;
@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.2
log
@
pws2rcs automatic delta on Fri May  4 14:44:01 MDT 1990
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23C ');
d4853 1
a4853 1
    begin day := 18; year := 90; month := 04; end;
@


44.2
log
@
pws2rcs automatic delta on Thu Apr 19 13:13:04 MDT 1990
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23B ');
d4853 1
a4853 1
    begin day := 31; year := 90; month := 03; end;
@


43.3
log
@
pws2rcs automatic delta on Sun Apr  1 16:13:30 MDT 1990
@
text
@@


43.2
log
@Fixed copyright dates.
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23A ');
d4853 1
a4853 1
    begin day := 16; year := 90; month := 3; end;
@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@d3 1
a3 1
 (c) Copyright Hewlett-Packard Company, 1985,1989.
d4861 1
a4861 1
  writeln('Copyright Hewlett-Packard Company, 1982, 1989.');
@


42.2
log
@
pws2rcs automatic delta on Mon Mar 19 16:00:53 MST 1990
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23e ');
d4853 1
a4853 1
    begin day := 19; year := 90; month := 01; end;
@


41.5
log
@
pws2rcs automatic delta on Sat Jan 20 16:32:46 MST 1990
@
text
@@


41.4
log
@

           More cleanup ... JWH 12/26/89.
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23d ');
d4853 1
a4853 1
    begin day := 19; year := 89; month := 12; end;
@


41.3
log
@


              Tightened up the move16 and cinv_cpush routines.

               JWH 12/26/89.
@
text
@d1940 1
a1940 1
	if the_op <> hex('F6') then
d1994 1
a1994 1
       if the_op <> hex('F4') then
@


41.2
log
@

        Added disassembly capability for the new '040 instructions
     move16, cinv and cpush, as well as disassembly capability for
     the new movec registers and the explicitly forced single
     and double precision rounding floating point instructions.

     JWH 12/26/89.
@
text
@d1926 6
d1933 1
d1935 2
a1937 1
      see_it.w := instr.w; { see it as a move16 }
d1940 4
d1947 1
a1947 1
	     begin defineword; goto 1; end;
d1949 6
a1954 2
	  { if ext.exDAbit1 <> 1  gotta be for this format
	     goto 1; }  { ?????????????????????????? }
d1961 1
d1990 1
d1994 2
d1997 1
a1997 1
	begin { CINV } { Check these out .... <<<============= }
d1999 1
a1999 1
	  0 : begin defineword; goto 1; end; { ILLEGAL ??? }
d2006 1
a2006 1
	  0 : begin defineword; goto 1; end; { ILLEGAL ??? }
d2020 1
a2020 1
	  0 : begin defineword; goto 1; end; { ILLEGAL ??? }
d2027 1
a2027 1
	  0 : begin defineword; goto 1; end; { ILLEGAL ??? }
@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@d1115 5
d1129 3
d1760 16
d1913 109
d2235 3
@


40.2
log
@
pws2rcs automatic delta on Thu Dec 21 14:54:59 MST 1989
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23c ');
d4697 1
a4697 1
    begin day := 27; year := 89; month := 09; end;
@


39.2
log
@
pws2rcs automatic delta on Thu Sep 28 17:16:32 MDT 1989
@
text
@@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23b ');
d4697 1
a4697 1
    begin day := 25; year := 89; month := 9; end;
@


38.2
log
@
pws2rcs automatic delta on Tue Sep 26 14:31:31 MDT 1989
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.23a ');
d4697 1
a4697 1
    begin day := 25; year := 89; month := 08; end;
@


37.2
log
@
pws2rcs automatic delta on Mon Aug 28 12:16:08 MDT 1989
@
text
@@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.3a ');
d4697 1
a4697 1
    begin day := 11; year := 89; month := 05; end;
@


36.3
log
@
pws2rcs automatic delta on Fri May 12 09:00:42 MDT 1989
@
text
@@


36.2
log
@
pws2rcs automatic delta on Thu May 11 11:32:36 MDT 1989
@
text
@d4697 1
a4697 1
    begin day := 10; year := 89; month := 05; end;
@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.22 ');
d4697 1
a4697 1
    begin day := 20; year := 89; month := 01; end;
@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.2
log
@
pws2rcs automatic delta on Fri Jan 20 16:16:31 MST 1989
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.22D ');
d4697 1
a4697 1
    begin day := 12; year := 89; month := 01; end;
@


32.3
log
@
pws2rcs automatic delta on Fri Jan 13 11:19:22 MST 1989
@
text
@@


32.2
log
@Fix copyright messages

@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.22C ');
d4697 1
a4697 1
    begin day := 06; year := 89; month := 01; end;
@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@d3 1
a3 1
 (c) Copyright Hewlett-Packard Company, 1985.
d4705 1
a4705 1
  writeln('Copyright Hewlett-Packard Company, 1982, 1987.');
@


31.2
log
@
pws2rcs automatic delta on Mon Jan  9 11:50:34 MST 1989
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.22B ');
d4697 1
a4697 1
    begin day := 12; year := 88; month := 12; end;
@


30.3
log
@
pws2rcs automatic delta on Wed Dec 14 13:22:28 MST 1988
@
text
@@


30.2
log
@SYSDATE fixes one more time.
The auto synch for clock fix did not work on the LIBRARIAN.  This is
because 'ed' was used to merge changes and the LIBRARIANs size blew out
its internal buffer. 'ex' should have been used here.
QUIST DEW 12/12/88
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2 ');
d4697 1
a4697 1
    begin day := 29; year := 87; month := 8; end;
@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@d115 2
a116 2
  if (month in [1..12]) and (day>0)
  and (year<100) then
d121 1
a121 1
    write(f, '-',year:2);
d226 1
a226 1
 write(f,'Librarian  [Rev.  3.22A ');
d4697 1
a4697 1
    begin day := 07; year := 88; month := 12; end;
@


29.2
log
@
pws2rcs automatic delta on Thu Dec  8 15:31:09 MST 1988
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.22b ');
d4697 1
a4697 1
    begin day := 27; year := 88; month := 10; end;
@


28.2
log
@
ipws2rcs automatic delta on Mon Oct 31 10:34:17 MST 1988
:w
:q
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.3a ');
d4697 1
a4697 1
    begin day := 4; year := 88; month := 10; end;
@


27.2
log
@pws2rcs automatic delta on Wed Oct  5 17:32:00 MDT 1988

@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2 ');
d4697 1
a4697 1
    begin day := 29; year := 87; month := 8; end;
@


26.6
log
@
Comment from auto synch of clock fix:
date: 88/03/18 10:21:06;  author: quist;  state: Exp;  lines added/del: 2/2
Pws2unix automatic delta on Fri Mar 18 09:13:54 MST 1988
@
text
@@


26.5
log
@
Comment from auto synch of clock fix:
date: 88/03/09 09:07:02;  author: quist;  state: Exp;  lines added/del: 2/2
Pws2unix automatic delta on Wed Mar 9 08:03:11 MST 1988
@
text
@@


26.4
log
@
Comment from auto synch of clock fix:
date: 88/03/02 17:28:56;  author: quist;  state: Exp;  lines added/del: 5/5
SYSDATE fixes, RDQ
@
text
@@


26.3
log
@
Comment from auto synch of clock fix:
date: 88/03/02 09:48:24;  author: bayes;  state: Exp;  lines added/del: 0/0
Automatic bump of revision number for PWS version 3.2Y
@
text
@@


26.2
log
@
Comment from auto synch of clock fix:
date: 88/03/01 10:09:08;  author: bayes;  state: Exp;  lines added/del: 2/2
Pws2unix automatic delta on Tue Mar 1 09:01:42 MST 1988
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@@


23.2
log
@Pws2unix automatic delta on Sun Aug 30 14:43:47 MDT 1987
@
text
@@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2P ');
d4697 1
a4697 1
    begin day := 25; year := 87; month := 8; end;
@


22.2
log
@Pws2unix automatic delta on Tue Aug 25 18:23:33 MDT 1987
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2N ');
d4697 1
a4697 1
    begin day := 14; year := 87; month := 8; end;
d4705 1
a4705 1
  writeln('Copyright 1985 Hewlett-Packard Company.');
@


21.2
log
@Pws2unix automatic delta on Sat Aug 15 16:14:36 MDT 1987
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2M ');
d4697 1
a4697 1
    begin day := 11; year := 87; month := 8; end;
@


20.2
log
@Pws2unix automatic delta on Wed Aug 12 09:47:30 MDT 1987
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2L ');
d4697 1
a4697 1
    begin day := 28; year := 87; month := 7; end;
@


19.2
log
@Pws2unix automatic delta on Wed Jul 29 17:29:01 MDT 1987
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2K ');
d4697 1
a4697 1
    begin day := 30; year := 87; month := 5; end;
@


18.2
log
@Pws2unix automatic delta on Sun May 31 14:33:16 MDT 1987
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2J ');
d4697 1
a4697 1
    begin day := 18; year := 87; month := 5; end;
@


17.2
log
@Pws2unix automatic delta on Wed May 20 09:57:02 MDT 1987
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2I ');
d4697 1
a4697 1
    begin day := 24; year := 87; month := 4; end;
@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.2
log
@Pws2unix automatic delta on Fri Apr 24 18:41:36 MDT 1987
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2H ');
d4697 1
a4697 1
    begin day := 11; year := 87; month := 4; end;
@


14.3
log
@Pws2unix automatic delta on Sun Apr 12 17:10:24 MDT 1987
@
text
@@


14.2
log
@changed unassembler "*sneq" to "*sne" to match released 68881 manual
@
text
@d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2G ');
d4697 1
a4697 1
    begin day := 31; year := 87; month := 3; end;
@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@d1631 1
a1631 1
	30: sappend(instrbuf,'sneq');
@


13.3
log
@Pws2unix automatic delta on Wed Apr  1 08:30:27 MST 1987
@
text
@@


13.2
log
@Fixed >16Mbyte Librarian Transfer problem (see eof on first transfer)
@
text
@d23 1
d226 1
a226 1
 write(f,'Librarian  [Rev.  3.2F ');
d4697 1
a4697 1
    begin day := 27; year := 87; month := 2; end;
@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@d2258 1
a2258 1
    textrecctr: shortint;
d3817 1
a3817 1
var startblock, numblocks, transblocks:        shortint;
d3819 1
a3819 1
    bufblocks:  shortint;
@


12.2
log
@Pws2unix automatic delta on Sat Feb 28 15:17:33 MST 1987
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2E ');
d4696 1
a4696 1
    begin day := 30; year := 87; month := 1; end;
@


11.2
log
@Pws2unix automatic delta on Mon Feb  2 09:47:34 MST 1987
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2D ');
d4696 1
a4696 1
    begin day := 18; year := 87; month := 1; end;
@


10.2
log
@Pws2unix automatic delta on Sun Jan 18 18:33:43 MST 1987
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2C ');
d4696 1
a4696 1
    begin day := 22; year := 86; month := 12; end;
@


9.2
log
@Pws2unix automatic delta on Tue Dec 23 16:24:27 MST 1986
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2B ');
d4696 1
a4696 1
    begin day := 10; year := 86; month := 12; end;
@


8.3
log
@Pws2unix automatic delta on Fri Dec 12 09:42:40 MST 1986
@
text
@@


8.2
log
@Added fintrz and changed FTPcc and FTcc to FTRAPcc 
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.1 ');
d4696 1
a4696 1
    begin day := 26; year := 85; month := 8; end;
@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@d1716 1
d1810 1
a1810 1
	       instrbuf := 'ft'
d1812 1
a1812 1
	       instrbuf := 'ftp'
@


7.2
log
@Fix for PC+ displacement (full format)
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2l ');
d589 1
a589 1
  procedure extend(size: integer; pcrel: boolean);
d611 1
a611 1
      if pcrel then offset := offset + location;
d698 1
a698 1
    begin extend(2,false);
d721 1
a721 1
	extend(1,pcrel); sappend(instrbuf, '(');
d734 1
a734 1
	extend(1,pcrel);
d757 2
a758 2
	2: extend(2,pcrel and (not saveext.exbs));
	3: extend(4,pcrel and (not saveext.exbs));
d805 1
a805 1
	     extend(2,false);
d811 1
a811 1
	     extend(4,false);
d827 1
a827 1
      extend(extsize[fsize],false);
d842 3
a844 3
	0: extend(2,false);
	1: extend(4,false);
	2: extend(2,true);
d1285 1
a1285 1
			comma; extend(4,true);
d1824 1
a1824 1
	       extend(2,true);
d1865 1
a1865 1
		   extend(4,true);
d1870 1
a1870 1
		   extend(2,true);
d1901 1
a1901 1
	       comma; extend(2,true);
d1956 1
a1956 1
	       extend(4,true);
d1961 1
a1961 1
	       extend(2,true);
d2115 1
a2115 1
  extend(2, true);
d4695 1
a4695 1
    begin day := 10; year := 86; month := 11; end;
@


6.2
log
@Pws2unix automatic delta on Wed Nov 19 15:16:12 MST 1986
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2k ');
d4695 1
a4695 1
    begin day := 3; year := 86; month := 11; end;
@


5.2
log
@Pws2unix automatic delta on Tue Nov  4 11:36:56 MEZ 1986
@
text
@@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2j ');
d4695 1
a4695 1
    begin day := 23; year := 86; month := 10; end;
@


4.2
log
@Pws2unix automatic delta on Tue Oct 28 10:57:29 MEZ 1986
@
text
@@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2i ');
d4695 1
a4695 1
    begin day := 26; year := 86; month := 9; end;
@


3.2
log
@Pws2unix automatic delta on Tue Sep 30 13:50:02 MEZ 1986
@
text
@@


3.1
log
@Auto bump revision for PAWS 3.2h
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2h ');
d4695 1
a4695 1
    begin day := 28; year := 86; month := 8; end;
@


2.4
log
@Pws2unix automatic delta on Mon Sep  1 08:51:28 MEZ 1986
@
text
@@


2.3
log
@Pws2unix automatic delta on Wed Aug 20 10:48:54 MEZ 1986
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2g ');
d4695 1
a4695 1
    begin day := 19; year := 86; month := 8; end;
@


2.2
log
@Pws2unix automatic delta on Tue Aug 19 10:31:55 MEZ 1986
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2f ');
d4695 1
a4695 1
    begin day := 18; year := 86; month := 8; end;
@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2e ');
d4695 1
a4695 1
    begin day := 29; year := 86; month := 7; end;
@


1.3
log
@Pws2unix automatic delta on Wed Jul 30 09:07:03 MEZ 1986
@
text
@@


1.2
log
@Pws2unix automatic delta on Tue Jul 15 16:35:26 MEZ 1986
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.2d ');
d4695 1
a4695 1
    begin day := 14; year := 86; month := 7; end;
@


1.1
log
@Initial revision
@
text
@d225 1
a225 1
 write(f,'Librarian  [Rev.  3.1b ');
d4695 1
a4695 1
    begin day := 12; year := 86; month := 6; end;
@
