  %$C-,M-,D-\
program debug,debug;
include 'pasprm.pas';
  %***********************************************************
   *							     *
   *			 PASCAL-DDT PROGRAM		     *
   *			 ******************		     *
   *							     *
   *	   VERSION OF 25/06/75				     *
   *							     *
   *	   AUTHOR: PETER PUTFARKEN			     *
   *	   INSTITUT FUER INFORMATIK,  D - 2 HAMBURG 13	     *
   *	   SCHLUETERSTRASSE 70  /  GERMANY		     *
   **********************************************************\

(* local change history

	prehistory	map lower case to upper, as in compiler
	1	fix writefieldlist so it doesn't assume variant
		descriptors are sorted by VARVAL.  (They aren't.)
	2	FIX LINEINTERVAL TO SET UP GPAGE.  NEEDED BY STOPSEARCH
	3	detect uninitialized pointers, as well as NIL
	4	fix writefieldlist to print tagid if not packed
	5	do mark and release, for efficiency
		clear string to NIL each entry, in case user did release
		  since he might have overwritten the old place
	6	Type out ASCII using ^ for ctl char's
	7	Add support for multiple modules
	8	Get rid of NEW by passing pointers from outside
	9	Fix CHARPTR to detect subranges of CHAR
	10	output sets of char with new char translation
	11	take care of new types LABELT and PARAM
        12      Change the output file from TTY to Dump_file.  Keep all program
                error reports to file TTY
        13      Add a stack-dump command. Procedures used to impliment this are
                  ONE_VAR_OUT,SECTION_OUT,OUT,STACK_OUT.
        14      Impliment a command to move about the stack by adding a         
                  parameter to the OPEN command.
        15      Add the ability to kill all stops. eg. STOP NOT ALL.
        16      Reformat the output from TRACEOUT so that it is easier to read
        17      Rewrite WriteStructure to print identical contiguous array     
                  elements once only, with the range of indeces it is the value
                  of.
        18      Add an optional parameter to TRACE to specify how far down
                  to trace the stack.
	19	Merge the new code with my current release, and clean up
		  ill-structured code (parameters passed as global variables).
	20	Old tops-10 edit 13, to recover partially typed lines
	21	Add access to source files
	22	Prevent HELP END from proceeding!
		QUIT command
		SHOW command to set number of lines to show
	23	let you use command names are variables
	24	internal files
	25	Hex and Octal printout
	26	Make E=, i.e. abbreviations of END, work
	27	Handle page marks correctly
*)

CONST
  STOPMAX = 20;
  BUFFMAX = 120;
  BITMAX = 36;
  STRGLGTH = 120;
  OFFSET = 40B;
  Blank=' ';
  fnamesize = 170;
  cachesize = 20;
  numpredec = 15;
TYPE
  HALFWORD = 0..777777B;
  ACRANGE = 0..15; BIT = 0..1;
  LINEELEM = PACKED RECORD
		      CASE INTEGER OF
			   1: (CODE:0..677B; AC:ACRANGE; IB:BIT; INXR:ACRANGE; ADP:^LINEELEM);
			   2: (CONSTANT1: INTEGER;
			       DB2: HALFWORD; ABSLINE: HALFWORD)
		    END;
  PAGEELEM = PACKED RECORD
			   INSTR: 0..677B; AC: ACRANGE; DUMMYBIT: BIT; INXREG: ACRANGE; PAGPTR: ^PAGEELEM;
			      LASTLINE: HALFWORD; LASTSTOP: ^LINEELEM
		    END;

(* 26 - print constants of all types *)
  CSP = ^CONSTNT;
  CSTCLASS = (INT,REEL,PSET,STRD,STRG);
  CONSTNT = RECORD
		  SELFCSP: CSP; NOCODE: BOOLEAN;
		  CASE CCLASS: CSTCLASS OF
		       INT : (INTVAL: INTEGER; INTVAL1:INTEGER %TO ACCESS SECOND WORD OF PVAL\ );
		       REEL: (RVAL: REAL);
		       PSET: (PVAL: SET OF 0..71);
		       STRD,
		       STRG: (SLGTH: 0..STRGLGTH;
			      SVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR)
		END;
  STRINGTYP = PACKED ARRAY [1:STRGLGTH] OF CHAR;
  VALU = RECORD
	   CASE INTEGER OF
		1: (IVAL: INTEGER);
		2: (RVAL: REAL);
		3: (VALP: CSP)
	 END;
(* 24 - internal files *)
  BITS5 = 0..37B; BITS6 = 0..77B; BITS7 = 0..177B;
  STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,TAGFWITHID,TAGFWITHOUTID,VARIANT);
(* 13 - add Stack dump *)
  Formset = Set of Structform;
  DECLKIND = (STANDARD,DECLARED);
  STP = ^STRUCTURE; CTP = ^IDENTIFIER;
  STRUCTURE = PACKED RECORD
		       SELFSTP: STP; SIZE: HALFWORD;
		       NOCODE: BOOLEAN;
		       BITSIZE: 0..36;
(* 24 - internal files *)
		       HASFILE: BOOLEAN;
		       CASE FORM: STRUCTFORM OF
			    SCALAR:	(CASE SCALKIND: DECLKIND OF
					      DECLARED: (DB0:BITS5; FCONST: CTP));
			    SUBRANGE:	(DB1:BITS6; RANGETYPE: STP; MIN,MAX: VALU);
			    POINTER:	(DB2:BITS6; ELTYPE: STP);
			    POWER:	(DB3:BITS6; ELSET: STP);
			    ARRAYS:	(ARRAYPF: BOOLEAN; DB4:BITS5; ARRAYBPADDR: HALFWORD;
					 AELTYPE,INXTYPE: STP);
			    RECORDS:	(RECORDPF:BOOLEAN; DB41:BITS5;
					 FSTFLD: CTP; RECVAR: STP);
			    FILES:	(DB6: BITS5; FILEPF: BOOLEAN; FILTYPE: STP);
			    TAGFWITHID,
			    TAGFWITHOUTID: (DB7:BITS6; FSTVAR: STP;
					    CASE BOOLEAN OF
					    TRUE: (TAGFIELDP: CTP);
					    FALSE: (TAGFIELDTYPE: STP));
			    VARIANT:	(DB9: BITS6; NXTVAR,SUBVAR: STP; FIRSTFIELD: CTP; VARVAL: VALU)
		     END;
  (* ALFA = PACKED ARRAY[1..ALFALENG] OF CHAR; *)
  LEVRANGE = 0..8;
(* 11 - new types *)
  IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELT,PARAMS);
  IDKIND = (ACTUAL,FORMAL);
  PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
  IDENTIFIER = PACKED RECORD
			NAME: ALFA; LLINK, RLINK: CTP;
			IDTYPE: STP; NEXT: CTP;
			SELFCTP: CTP; NOCODE: BOOLEAN;
			CASE KLASS: IDCLASS OF
			     KONST: (VALUES: VALU);
			     VARS:  (VKIND: IDKIND; VLEV: LEVRANGE;
				     CHANNEL: 0..15; VDUMMY: 0..31B; VADDR: HALFWORD);
			     FIELD: (PACKF: PACKKIND; FDUMMY: 0..7777B;
				     FLDADDR: HALFWORD);
			     PROC,
			     FUNC:  (CASE PFDECKIND: DECLKIND OF
					  STANDARD: (KEY: 1..44);
					  DECLARED: (PFLEV: LEVRANGE; PFADDR: HALFWORD))
		      END;
  ACR = ^ AKTIVIERUNGSRECORD;
  AKTIVIERUNGSRECORD = ARRAY [0..0] OF INTEGER;
  ATTRKIND = (CST,VARBL,EXPR);
  ATTR = RECORD
	   TYPTR: STP;
	   CASE KIND: ATTRKIND OF
		CST:  (CVAL: VALU);
		VARBL:(PACKFG: BOOLEAN;
		       GADDR: HALFWORD; GBITCOUNT: 0:BITMAX)
	 END;
  LEFTORRIGHT=(LEFT,RIGHT);
  debptr=^debugentry;
  DEBUGENTRY = RECORD
(* 7 - mult. modules *)
		 nextdeb: debptr;
		 LASTPAGEELEM: PAGEELEM;
		 GLOBALIDTREE: CTP;
		 STANDARDIDTREE: CTP;
		 INTPTR: STP;
		 REALPTR: STP;
		 CHARPTR: STP;
		 modname: alfa;
(* 21 - source files *)
		 fname: packed array[1..fnamesize]of char
	       END;
  STATUSKIND = (INITK, STOPK, DDTK, RUNTMERRK);
  DEBUGSTATUS = PACKED RECORD
			 DD: 0:177777B;
			 KIND: STATUSKIND;
			 RETURNADDR: HALFWORD
		       END;
  DYNENTRY = RECORD
	       REGISTRS: ACR;	      % 140B \
	       STOPPY: INTEGER;       % 141B \
	       ENTRYPTR: debptr; % 142B \
	       STACKBOTTOM: ACR;      % 143B \
	       STATUS: DEBUGSTATUS;    % 144B \
	       dum1,dum2:integer;  {Not sure why this space is here}
	       compbasis: integer;  {Saved ac 16 to see if at same level}
	       chklevcall: integer  {pushj p, to routine to check level}
	     END;
(* 8 - get rid of NEW *)
  ptstringtyp = ^ stringtyp;
  sys = (STOPSY, typesy, findsy, TRACESY, stepsy, ENDSY, NOTSY, LISTSY, EOLSY,
	 ambig, IDENT, INTCONST, STRINGCONST, CHARCONST, REALCONST, LBRACK, 
	 RBRACK, COMMA, PERIOD, star, ARROW, PLUS, MINUS, SLASHSY, BECOMES, 
	 EQSY, OPENSY, STACKDUMPSY, ALLSY, OTHERSY, COMMENT, HELPSY, quitsy,
	 showsy, termsy);
  setofsys = set of sys;
(* 25 - Hex and Octal printout *)
  printtype = (decimal,octal,hex);

VAR
(* 12 - Change TTY to Dumpfile *)
  Dump_file:Text;  {this file is used for the stackdump command, when it
		    is given a file name as an argument.  this file is
		    open only during execution of the command.}
(* 21 - source file access *)
  source: text;  {this is the current source file}
(* 18 - Add depth argument to trace *)
{Note: all_blank and depth_limit are local variables used in command
 parsing.  Do not refer to depth_limit as a global, but pass down its
 value if you want it.}
  All_Blank:Boolean;
  depth_limit:Integer;
(* 15 - Add STOP NOT ALL *)
  Null_lineelem_Ptr:^Lineelem;
  BASIS: ACR;
  CH: CHAR;
  ID: ALFA;
  VAL: VALU;
(* 8 - get rid of NEW *)
  strinit: Boolean;
  LGTH: INTEGER;
(* 7 - mult. modules *)
  I, J, K, CHCNT, LEFTSPACE: INTEGER;
  SY: sys;
(* 22 - better parsing for reserved words *)
  predec: array[1..numpredec] of alfa;
  predectran: array[1..numpredec] of sys;
(* 22 - prevent HELP END from proceeding *)
  proceed: Boolean;  {Command sets this to cause exit from PASDDT}
(* 20 - save state of tty for tops-10 *)
  oldeoln: char;
  BUFFER: PACKED ARRAY[1:BUFFMAX] OF CHAR;
  BUFFLNG: 0:BUFFMAX; 
  GPAGE: INTEGER;     %CURRENT PAGENUMBER\
  STOPTABLE: ARRAY[1..STOPMAX] OF RECORD
(* 7 - multiple modules *)
				    modentry: debugentry;
				    THISLINE, PAGE: INTEGER;
				    ORIGINALCONT: LINEELEM;
				    THISADDR: ^LINEELEM
				  END;
  STOPNR: 0..STOPMAX;
  ENTRY1: DEBUGENTRY;
(* 7 - entry2 now passed as arg *)
  POINTERCV: PACKED RECORD
		       CASE INTEGER OF
			       0:(ADDR: HALFWORD);
				1:(ENTPTR2: ^DYNENTRY);
				2:(STRINGPTR: ^STRINGTYP);
(* 7 - mult modules *)
				3:(entptr1: debptr);
			        4:(valu: ^integer)
			END;
    curent: debptr;  %This is used to check whether the currently
		open module is the one where the current break is.  If
		not, all the user can look at are global variables.
		This is actually the nextdeb field from entry1 of
		the broken module.  The nextdeb field is used to test
		for equality, since it is different for each debugentry\
    sourceent: debptr;  %This plays the same role for the source file
		mechanism.  this is the nextdeb field of the currently
		open file\
  stepmode:Boolean;
  ACCUS: ACR;
  LADDR: HALFWORD;
  DIGITS, LETTERSDIGITSORLEFTARROW: SET OF CHAR;
  NL: BOOLEAN;
  NULLPTR: ACR;
  GATTR: ATTR;
(* 10 - array for new char translation *)
  setmap: array[0..177B] of integer;
(* 4 - place to save NEW value *)
(* 8 - get rid of NEW *)
  Call_Basis:Acr;	{Basis of currently open stack level.}
  Call_Address:HalfWord;
  Pos_in_Stack:Integer; {Stack level (small integer) currently open}
  No_of_Calls:Integer;  {Largest stack level active}
{Sourcefile line number stuff}
  stline,stpage:Integer;
  dotline,dotpage:Integer;  {Current page/line}
  searchstring:stringtyp;  {Previous arg from FIND}
  searchlength:Integer;
  linecache:array[0..cachesize] of  {cache of info about positions in file}
	record
	nextdeb:debptr;   {Copy of sourceent when entry was made.  Used
			   to verify that this entry is for the right file}
	cpage:integer;    {source page for this entry - zero this to
			   invalidate the entry}
	cline:integer;	  {source line for this entry}
	cposition:integer; {byte position in the file, for setpos}
	end;
(* 22 *)
  showlines:integer;      {Number of lines to show in showcontext}
(* 25 - Hex and Octal printout *)
  printradix: printtype;     {Radix to print scalars}
                                          
  (******************************************************************************************************)

  INITPROCEDURE;
   BEGIN
    DIGITS :=['0'..'9'];
    LETTERSDIGITSORLEFTARROW:=['A'..'Z','0'..'9', '_'];
(* 8 - get rid of NEW *)
    strinit := false;
    showlines := 3;
   END;

 initprocedure;
  begin
  predec[1] := 'ALL       ';  predectran[1] := allsy;
  predec[2] := 'END       ';  predectran[2] := endsy;
  predec[3] := 'FIND      ';  predectran[3] := findsy;
  predec[4] := 'HELP      ';  predectran[4] := helpsy;
  predec[5] := 'LIST      ';  predectran[5] := listsy;
  predec[6] := 'NOT       ';  predectran[6] := notsy;
  predec[7] := 'OPEN      ';  predectran[7] := opensy;
  predec[8] := 'QUIT      ';  predectran[8] := quitsy;
  predec[9] := 'SHOW      ';  predectran[9] := showsy;
  predec[10]:= 'STACKDUMP ';  predectran[10]:= stackdumpsy;
  predec[11]:= 'STEP      ';  predectran[11] := stepsy;
  predec[12]:= 'STOP      ';  predectran[12]:= stopsy;
  predec[13]:= 'TERMS     ';  predectran[13] := termsy;
  predec[14]:= 'TRACE     ';  predectran[14]:= tracesy;
  predec[15]:= 'TYPE      ';  predectran[15]:= typesy;
  end;

(* 10 - new output for characters in sets *)
initprocedure %char mapping for set of char output\  ;
	begin
	setmap[0B] := 30B;	setmap[1B] := 11B;	setmap[2B] := 40B;	setmap[3B] := 41B;
	setmap[4B] := 42B;	setmap[5B] := 43B;	setmap[6B] := 44B;	setmap[7B] := 45B;
	setmap[10B] := 46B;	setmap[11B] := 47B;	setmap[12B] := 50B;	setmap[13B] := 51B;
	setmap[14B] := 52B;	setmap[15B] := 53B;	setmap[16B] := 54B;	setmap[17B] := 55B;
	setmap[20B] := 56B;	setmap[21B] := 57B;	setmap[22B] := 60B;	setmap[23B] := 61B;
	setmap[24B] := 62B;	setmap[25B] := 63B;	setmap[26B] := 64B;	setmap[27B] := 65B;
	setmap[30B] := 66B;	setmap[31B] := 67B;	setmap[32B] := 70B;	setmap[33B] := 71B;
	setmap[34B] := 72B;	setmap[35B] := 73B;	setmap[36B] := 74B;	setmap[37B] := 75B;
	setmap[40B] := 76B;	setmap[41B] := 77B;	setmap[42B] := 100B;	setmap[43B] := 101B;
	setmap[44B] := 102B;	setmap[45B] := 103B;	setmap[46B] := 104B;	setmap[47B] := 105B;
	setmap[50B] := 106B;	setmap[51B] := 107B;	setmap[52B] := 110B;	setmap[53B] := 111B;
	setmap[54B] := 112B;	setmap[55B] := 113B;	setmap[56B] := 114B;	setmap[57B] := 115B;
	setmap[60B] := 116B;	setmap[61B] := 117B;	setmap[62B] := 120B;	setmap[63B] := 121B;
	setmap[64B] := 122B;	setmap[65B] := 123B;	setmap[66B] := 124B;	setmap[67B] := 125B;
	setmap[70B] := 126B;	setmap[71B] := 127B;	setmap[72B] := 130B;	setmap[73B] := 131B;
	setmap[74B] := 132B;	setmap[75B] := 133B;	setmap[76B] := 134B;	setmap[77B] := 135B;
	setmap[100B] := 136B;	setmap[101B] := 137B;	setmap[102B] := 140B;	setmap[103B] := 173B;
	setmap[104B] := 174B;	setmap[105B] := 175B;	setmap[106B] := 176B;	setmap[107B] := 177B;
	end;
(* 13 - add stack dump *)
Procedure Analys(Var F:file);Extern;

procedure totyp (s:string; l:integer); extern;

function isDisk(var F:file):Boolean;extern;

procedure debnam(var f:file; s:string); extern;


(* 7 - mult. modules *)
procedure quit; extern;
function magic(basis:acr):integer; extern;

(* 25 - Hex and Octal printout *)
function hexlen(hexnum:integer): integer;
    (* find length of number in hex chars  *)
var len: integer;
    cvthex: record
	       case boolean of
		   true: (int:integer);
		   false: (hex:packed array[1..9] of 0..15)
	       end;
begin
    cvthex.int := hexnum;
    len := 9;
    while ((cvthex.hex[10-len] = 0) and (len > 1)) do len := len - 1;
    hexlen := len
end;

(* 25 - Hex and Octal printout *)
function octlen(octnum:integer): integer;
    (* find length of number in octal chars  *)
var len: integer;
    cvtoct: record
		case boolean of
		    true: (int:integer);
		    false: (oct:packed array[1..12] of 0..7)
	        end;
begin
    cvtoct.int := octnum;
    len := 12;
    while ((cvtoct.oct[13-len] = 0) and (len > 1)) do len := len - 1;
    octlen := len
end;

(* 7 - pass entry2 now so it doesn't have to be in 140 *)
(* 8 - get rid of NEW *)
  PROCEDURE DEBUG(VAR ENTRY2:DYNENTRY; STRING:CSP; STRINGPTR,STRINGINDEX: STP);

    procedure opensource(var f:text; var m:debugentry);
{Open the source file whose name is specified in the debugentry. 
 Note that error recovery is used when the file is openned.
 If there is a problem, the user is asked for a new source file name, which is
 stored in debugentry, so he doesn't have to be asked again next time.}
	var i:integer;lptr:debptr;
     begin
      loop
	if tops10
	  then begin
	  debnam(f,m.fname);
	  reset(f,'',true,0,40000B,4000B)
	  end
	 else reset(f,m.fname,true,0,0,30B);
	exit if isDisk(f) and not eof(f);
	if not eof(f)
	  then writeln(tty,'? Source file must be on disk')
	  else analys(f);
	writeln(tty,'> Please specify a different file name for ',
		m.modname,', or "NUL:" to ignore');
	write(tty,'*');readln(tty); read(tty,m.fname);
{Now that we have reset the name, we have to find the master record that
 it came from, since what we were passed is entry1, which is only a copy
 of the "real" record.  This is in case we come back to the same module
 later, we want to use the new name the user just gave us.}
	lptr := entry2.entryptr;
	while lptr^.nextdeb <> m.nextdeb do
	  lptr := lptr^.nextdeb;
	lptr^.fname := m.fname;
{Also, we have to invalidate any cache entries for this file, since it
 now refers to something else}
	for i := 1 to cachesize do
	  with linecache[i] do
	    if nextdeb = m.nextdeb
	      then cpage := 0;
        end;
     sourceent := m.nextdeb;
     dotline := 1; dotpage := 1;
     end;

    procedure checksource(var f:text; var m:debugentry);
	begin
	if sourceent # m.nextdeb
	  then opensource(f,m)
	end;

    procedure findpgln (var f:text; page,line:integer);

      label 666;
      var i,curpage,curline:integer;
          curSOSnum,SOSnum:packed array[1..5]of char;
	  bestind,bestpage,bestline,bestpos:integer;

      begin
{First try to come as near as possible using cache}
	{Can always start at beginning!}
      bestpage := 1; bestline := 1;  bestpos := 0; bestind := 0;

(*DEBUGGING CODE
for i := 1 to 10 do with linecache[i] do
writeln(tty,i:2,':',cline:0,'/',cpage:0,',',cposition:0);
END DEBUGGING *)

      for i := 1 to cachesize do
	with linecache[i] do
	  if nextdeb = sourceent
	    then if (cpage < page)   {cache loc <= requested}
		    or ((cpage = page) and (cline <= line))
	      then if (cpage > bestpage)    {cache loc > best seen}
		      or ((cpage = bestpage) and (cline > bestline))
		then begin   {Found better candidate: use it}
	        bestpage := cpage;
		bestline := cline;
		bestpos := cposition;
		bestind := i
		end;

(* DEBUGGING CODE
if bestind <> 0 then
writeln(tty,'Cache hit, entry ',bestind:0,', page=',bestpage:0,', line=',bestline:0,', pos=',bestpos:0);
END DEBUGGING *)

{Now move this entry to the top of cache}
      if bestind > 2  {Needs movement}
	then begin
	linecache[0] := linecache[bestind];  {save best one}
	for i := bestind downto 2 do    {move others down}
	  linecache[i] := linecache[i-1];
	linecache[1] := linecache[0];    {put best in top position}
	end;
{Now go to best starting position}
      setpos(f,bestpos);
{And move forward if needed}
{After this loop we are on the first char of the requested page.
 Note that we are following the convention that the page mark at
 the beginning of a page is line N+1 of the previous page.}
      curline := bestline;
      for curpage := bestpage+1 to page do
	  begin
(* 27 *)
	  repeat
	    if f^ = chr(14B)
	      then curline := 1
	      else curline := curline+1;
	    readln(f);
	   until eof(f) or (curline = 1);
	  if eof(f)
	    then begin line := 1; page := curpage; goto 666 end;
(* 27 *)
	  end;
{We have now found page}
      getlinenr(f,curSOSnum);
      if curSOSnum = '-----'  {File not SOS numbered}
	then for curline := curline+1 to line do
	    begin
(* 27 *)
	    if (f^ = chr(14B)) or eof(f)
	      then begin readln(f); page := page + 1; line := 1; goto 666 end;
	    readln(f)
	    end
	else begin
	if (line > 99999) or (line < 0)
	  then SOSnum := 'AAAAA'   {something bigger than any legal number}
	  else for i := 0 to 4 do
	    begin
	    SOSnum[5-i] := chr((line mod 10) + 60B);
	    line := line div 10
	    end;
	while (curSOSnum < SOSnum) do
	  begin
(* 27 *)
	  if (f^ = chr(14B)) or eof(f)
	    then begin line := 1; page := page + 1; goto 666 end;
	  readln(f);
	  getlinenr(f,curSOSnum)	  
	  end;
	if curSOSnum = '     '
	  then line := 1
	  else begin
	  line := 0;
	  for i := 1 to 5 do
	    line := line*10 + (ord(curSOSnum[i]) - 60B)
	  end
	end;
{We found the thing we wanted exactly, so put it in the cache if not there}
      if not eof(f) and ((line <> bestline) or (page <> bestpage))
	then begin

(* DEBUGGING CODE
writeln(tty,'Entering in cache: page=',page:0,', line=',line:0,', pos=',curpos(f)-1);
END DEBUGGING *)

	for i := cachesize downto 2 do   {make space for new entry}
	  linecache[i] := linecache[i-1];
	with linecache[1] do   {now make it entry 1}
	  begin
	  nextdeb := sourceent;
	  cpage := page; cline := line;
	  if curSOSnum <> '-----'
	    then cposition := curpos(f) - 7
	    else cposition := curpos(f) - 1
	  end
	end;
666:  if not eof(f)
	then begin dotline := line; dotpage := page end
      end;

    procedure stsearch(st:stringtyp;len:integer;line,page:integer);
{Assumes the file is positioned to the first character to be searched for
 Things are left pointing to the start of text on the last line searched 
  (or EOF).}
	var 
	    tstring,ahead,seen:array[1..strglgth]of char;
	    lastpos,target,aheadpt:integer;cur:char;
	    curSOSnum:packed array[1..5]of char;
      begin
{Start by skipping a line, since search is never supposed to stay on
 the existing line.}
      for target := 1 to len do
	if (st[target] >= 'a') and (st[target] <= 'z')
	  then tstring[target] := chr(ord(st[target]) - 40B)
	  else tstring[target] := st[target];
(* 27 *)
      if (source^ = chr(14B)) or eof(source)
	then begin page := page + 1; line := 1; end
	else line := line + 1;
      readln(source);
(* 27 *)
{Our normal logic requires us to check if a line is a page mark
 before advancing over it, so as to advance the page number.
 However for this routine that is hard to do because we don't
 go to a new line until EOLN, and at that point we no longer
 know whether we have a page mark (since text lines ending in
 FF are not page marks according to the compiler).  The solution
 is to make sure that this never happens.  I.e. skip page marks
 before entering this code and whenever they are detected.  This
 is fine, since a page mark will never match any search string}
      while (source^ = chr(14B)) and not eof(source) do
	begin
	readln(source);
	page := page+1; line := 1
	end;
      if (source^ >= 'a') and (source^ <= 'z')
	then source^ := chr(ord(source^) - 40B);
      lastpos := curpos(source)-1;
      aheadpt := 0;
      loop
	target := 1;
	loop
	  if aheadpt <= 0
	    then begin
	    cur := source^;
	    if eoln(source)
	      then begin
	      readln(source);
	      line := line + 1;
(* 27 *)
	      while (source^ = chr(14B)) and not eof(source) do
		begin readln(source); line := 1; page := page + 1 end;
	      lastpos := curpos(source) - 1
	      end
	      else get(source);
	    if (source^ >= 'a') and (source^ <= 'z')
	      then source^ := chr(ord(source^) - 40B);
	    end
	   else begin cur := ahead[aheadpt]; aheadpt := aheadpt - 1 end;
	  seen[target] := cur;
	  exit if (cur <> tstring[target]) or (target = len);
	  target := target+1
	  end;
	exit if eof(source) or (cur = tstring[target]);
        for target := target downto 2 do
	  begin
	  aheadpt := aheadpt + 1;
	  ahead[aheadpt] := seen[target]
	  end;
	end;
      getlinenr(source,curSOSnum);
      if curSOSnum <> '-----'
	then if curSOSnum = '     '
	  then line := 1
	  else begin
	  line := 0;
	  for i := 1 to 5 do
	    line := line*10 + (ord(curSOSnum[i]) - 60B)
	  end;
      if not eof(source)
	then begin
	setpos(source,lastpos);
        dotline := line; dotpage := page;
	end
      end;
	    
    procedure showstcontext(gotstring:Boolean;repcount:integer);
	var r,line,page:integer;SOSnum:packed array[1..5]of char;
      begin
      page := dotpage;
      findpgln(source,dotpage,dotline);      
      if gotstring
	then begin
	searchstring := string^.sval;
	searchlength := stringindex^.max.ival
	end;
      for r := 1 to repcount do
	stsearch(searchstring,searchlength,dotline,dotpage);
      if (page <> dotpage) and not eof(source)
	then writeln(tty,'Page ',dotpage:0);
      line := dotline; page := dotpage;
      for i := 0 to showlines-1 do
	begin
	if eof(source)
	  then goto 1;
	getlinenr(source,SOSnum);
(* 27 *)
	if source^ = chr(14B)
	  then begin 
	  line := 1;
	  page := page + 1;
	  writeln(tty,'Page ',page:0);
	  readln(source)
	  end
         else begin
	  if SOSnum = '-----'
	    then write(tty,line:0,'	')
	    else write(tty,SOSnum,'	');
	  while not eoln(source) do
	    begin
	    write(tty,source^);
	    get(source)
	    end;
	  writeln(tty);
	  line := line+1;
	  readln(source);
	  end
	end;
1:
      end;

    procedure showcontext(page,line:integer);
	var i:integer; SOSnum:packed array[1..5]of char;
      begin
      if page <= 0
	then page := 1;
      if line <= 0
	then line := 1;
      findpgln(source,page,line);
      page := dotpage; line := dotline;
(* 22 - allow user to set the number of lines to show *)
      for i := 0 to showlines-1 do
	begin
	if eof(source)
	  then goto 1;
	getlinenr(source,SOSnum);
(* 27 *)
	if source^ = chr(14B)
	  then begin 
	  line := 1;
	  page := page + 1;
	  writeln(tty,'Page ',page:0);
	  readln(source)
	  end
         else begin
	  if SOSnum = '-----'
	    then write(tty,line:0,'	')
	    else write(tty,SOSnum,'	');
	  while not eoln(source) do
	    begin
	    write(tty,source^);
	    get(source)
	    end;
	  writeln(tty);
	  line := line+1;
	  readln(source);
	  end
	end;
1:
      end;

    PROCEDURE ERROR;
     BEGIN
      WRITE(TTY, '> ', '^ ':CHCNT+1 );
      GATTR.TYPTR := NIL
     END;

    function endOK:Boolean;
      begin
      endOK := true;
      if sy <> eolsy
	then begin
	error;
	writeln(tty,'Junk after end of command');
	endOK := false
	end
      end;

    PROCEDURE NEWLINE(var outfile:text);
     BEGIN
      WRITELN(outfile);
      WRITE(outfile,'> ',' ':LEFTSPACE);
      CHCNT := LEFTSPACE
     END;

    FUNCTION LENGTH(FVAL: INTEGER): INTEGER;
    VAR
      E, H: INTEGER;
     BEGIN
       IF FVAL < 0
       THEN
	 BEGIN
	  E := 1; FVAL := -FVAL
	 END
       ELSE E := 0;
      H := 1;
       REPEAT
	E := E + 1; H := H * 10
       UNTIL (FVAL < H) OR (E = 12);
      LENGTH := E
     END;

    PROCEDURE INSYMBOL;
    CONST
      MAXEXP = 35;
    VAR
      J,IVAL,SCALE,EXP: INTEGER;
      RVAL,R,FAC: REAL;
      STRINGTOOLONG, SIGN: BOOLEAN;

      PROCEDURE NEXTCH;
       BEGIN
	 IF EOLN(TTY)
	 THEN CH:=' '
	 ELSE READ(TTY,CH);
        IF ORD(CH) >= 140B THEN CH := CHR(ORD(CH)-40B);
	CHCNT := CHCNT + 1
       END;
      PROCEDURE NEXTCHSTR;
       BEGIN
	 IF EOLN(TTY)
	 THEN CH:=' '
	 ELSE READ(TTY,CH);
	CHCNT := CHCNT + 1
       END;
     BEGIN
      WHILE NOT EOLN(TTY) AND (CH=' ') DO NEXTCH;
       CASE CH OF
	' ': SY := EOLSY; 
	';','!': SY := COMMENT; 
	'A','B','C','D','E','F','G','H','I','J','K','L','M',
	'N','O','P','Q','R','S','T','U','V','W','X','Y',
	'Z':
	     BEGIN
	      ID := '          '; I := 0;
	       REPEAT
		 IF I < ALFALENG
		 THEN
		   BEGIN
		    I := I + 1;
		    ID[I] := CH
		   END;
		NEXTCH
	       UNTIL NOT ( CH IN LETTERSDIGITSORLEFTARROW );
	      SY := IDENT; 
             END;              ;
	'0','1','2','3','4','5','6','7','8',
	'9':
	     BEGIN
	      IVAL := 0; SY := INTCONST; 
	       REPEAT
		IVAL := 10*IVAL + ORD(CH)-ORD('0');
		NEXTCH
	       UNTIL NOT (CH IN DIGITS);
	      SCALE := 0;
	       IF CH = '.'
	       THEN
		 BEGIN
		  NEXTCH;
		   IF CH = '.'
		   THEN CH := ':'
		   ELSE
		     BEGIN
		      RVAL := IVAL; SY := REALCONST; 
		       IF  NOT (CH IN DIGITS)
		       THEN
			 BEGIN
			  ERROR; WRITELN(TTY,'Digit must follow')
			 END
		       ELSE
			 REPEAT
			  RVAL := 10.0*RVAL + (ORD(CH) - ORD('0'));
			  SCALE := SCALE - 1; NEXTCH
			 UNTIL	NOT (CH IN DIGITS)
		     END
		 END;
	       IF CH = 'E'
	       THEN
		 BEGIN
		   IF SCALE = 0
		   THEN
		     BEGIN
		      RVAL := IVAL; SY := REALCONST; 
		     END;
		  NEXTCH;
		  SIGN :=  CH = '-' ;
		   IF (CH = '+') OR SIGN
		   THEN NEXTCH;
		  EXP := 0;
		   IF  NOT (CH IN DIGITS)
		   THEN
		     BEGIN
		      ERROR; WRITELN(TTY,'Digit must follow')
		     END
		   ELSE
		     REPEAT
		      EXP := 10*EXP + ORD(CH) - ORD('0');
		      NEXTCH
		     UNTIL  NOT (CH IN DIGITS);
		   IF SIGN
		   THEN SCALE := SCALE - EXP
		   ELSE SCALE := SCALE + EXP;
		   IF ABS(SCALE + LENGTH(IVAL) - 1) > MAXEXP
		   THEN
		     BEGIN
		       BEGIN
			ERROR; WRITELN(TTY,'Exponent too large')
		       END;
		      SCALE := 0
		     END
		 END;
	       IF SCALE # 0
	       THEN
		 BEGIN
		  R := 1.0;   %NOTE POSSIBLE OVERFLOW OR UNDERFLOW\
		   IF SCALE < 0
		   THEN
		     BEGIN
		      FAC := 0.1; SCALE := -SCALE
		     END
		   ELSE FAC := 10.0;
		   REPEAT
		     IF ODD(SCALE)
		     THEN R := R*FAC;
		    FAC := SQR(FAC); SCALE := SCALE DIV 2
		   UNTIL SCALE = 0;   %NOW R = 10^SCALE\
		  RVAL := RVAL*R
		 END;
	       IF SY = INTCONST
	       THEN VAL.IVAL := IVAL
	       ELSE VAL.RVAL := RVAL
	     END;
	'=':
	     BEGIN
	      SY := EQSY; NEXTCH
	     END;
	':':
	     BEGIN
	      NEXTCH;
	       IF  CH = '='
	       THEN
		 BEGIN
		  SY := BECOMES; NEXTCH
		 END
	       ELSE SY := OTHERSY
	     END;
	'''':
	      BEGIN
	       LGTH := 0; STRINGTOOLONG := FALSE;
(* 8 - get rid of NEW *)
	       if not strinit then
		begin strinit := true;
		  WITH  STRINGINDEX^ DO
		   BEGIN SIZE := 1; BITSIZE := 7;  form := subrange;
		   RANGETYPE := ENTRY1.INTPTR; MIN.IVAL := 1
		   END;
		  WITH STRINGPTR^ DO
		   BEGIN BITSIZE := BITMAX; AELTYPE := ENTRY1.CHARPTR; form := arrays;
		   INXTYPE := STRINGINDEX; ARRAYPF := TRUE
		   END;
(* 26 - strings *)
		  string^.cclass := strg
		END;
		REPEAT
		  REPEAT
		   NEXTCHSTR;
		    IF LGTH < STRGLGTH
		    THEN
		      BEGIN
		       LGTH := LGTH + 1; STRING^.SVAL[LGTH] := CH
		      END
		    ELSE STRINGTOOLONG := TRUE
		  UNTIL EOLN(TTY) OR (CH = '''');
		  IF STRINGTOOLONG
		  THEN
		    BEGIN
		     ERROR;
		     WRITELN(TTY,'String constant is too long')
		    END;
		  IF CH # ''''
		  THEN
		    BEGIN
		     ERROR; WRITELN(TTY,'String constant contains "<CR><LF>"')
		    END
		  ELSE NEXTCH
		UNTIL CH # '''';
	       LGTH := LGTH - 1;   %NOW LGTH = NR OF CHARS IN STRING\
		IF LGTH = 1
		THEN
		  BEGIN
		   SY := CHARCONST; VAL.IVAL := ORD(STRING^.SVAL[1]);
		   STRINGINDEX^.MAX.IVAL := 1;
		   STRINGPTR^.SIZE := 1;		   
		  END
		ELSE
		 BEGIN SY := STRINGCONST; 
		  STRINGINDEX^.MAX.IVAL := LGTH;
		  STRINGPTR^.SIZE := (LGTH + 4) DIV 5;
(* 26 - strings *)
		  string^.slgth := lgth;
		  val.valp := string
		 END
	      END;
	'/':
	     BEGIN
	      SY := SLASHSY; NEXTCH
	     END;
	'[':
	     BEGIN
	      SY := LBRACK; NEXTCH
	     END;
	']':
	     BEGIN
	      SY := RBRACK; NEXTCH
	     END;
	'.':
	     BEGIN
	      SY := PERIOD; NEXTCH
	     END;
	'*':
	     BEGIN
	      SY := STAR; NEXTCH
	     END;
	'^':
	     BEGIN
	      SY := ARROW; NEXTCH
	     END;
	',':
	     BEGIN
	      SY := COMMA;  NEXTCH
	     END;
	'+':
	     BEGIN
	      SY := PLUS;   NEXTCH
	     END;
	'-':
	     BEGIN
	      SY := MINUS;  NEXTCH
	     END;
	OTHERS: SY := OTHERSY
       END;
     END %INSYMBOL\;

procedure command(legal:setofsys);
  var i,j,k:integer;
  begin
  if sy = ident
    then begin
    i := 0;  {which command matches match}
    for j := 1 to numpredec do
      if predectran[j] in legal
        then begin
        for k := 1 to 10 do
          if predec[j,k] <> id[k]
            then goto 1;
1:      if k > 10  {exact match}
          then i := j
        else if id[k] = ' '   {abbreviation}
          then if i = 0
	         then i := j  {unique abbrev}
	         else i := -1 {ambiguous abbrev}
        end;
    if i > 0  {unique abbrev}
      then sy := predectran[i]
    else if i < 0  {ambig}
      then sy := ambig
    end;
  end;

    FUNCTION ACRPOINT(FINT:INTEGER;LLEFT:LEFTORRIGHT): ACR;
      %CONVERTS INTEGER TO ACR-POINTER\
    VAR
      ACR_INT: PACKED RECORD
			CASE BOOLEAN OF
			     FALSE:(LINT: INTEGER);
			     TRUE: (LACR,LACL: ACR)
		      END;
     BEGIN
      WITH ACR_INT DO
       BEGIN
	LINT := FINT;
	 IF LLEFT=LEFT
	 THEN ACRPOINT := LACL
	 ELSE ACRPOINT := LACR
       END
     END;

    FUNCTION CTPOINT(FINT:INTEGER;LLEFT:LEFTORRIGHT): CTP;
      %CONVERTS INTEGER TO CT-POINTER\
    VAR
      CTP_INT: PACKED RECORD
			CASE BOOLEAN OF
			     FALSE:(LINT: INTEGER);
			     TRUE: (LCPR,LCPL: CTP)
		      END;
     BEGIN
      WITH CTP_INT DO
       BEGIN
	LINT := FINT;
	 IF LLEFT=LEFT
	 THEN CTPOINT:=LCPL
	 ELSE CTPOINT:=LCPR
       END
     END;

    PROCEDURE TESTGLOBALBASIS(SIDE:LEFTORRIGHT);
     BEGIN
(* 7 - more than one module *)
	%This routine sees whether we should use the global symbol
	 table.  Two checks are needed.  If the currently open
	 module is not the one where the break is, then none of
	 its locals are accessible and only the global symbol table
	 should be used.  If it is the right module, we need only
	 see if the basis is at the bottom of the stack\
      IF (ENTRY1.NEXTDEB # CURENT) AND (SIDE=RIGHT)
	then basis := nullptr
        ELSE IF BASIS = ENTRY2.STACKBOTTOM THEN BASIS := NULLPTR
     END;

    FUNCTION IDTREE: CTP;
      %POINTS TO THE IDTREE OF THE PROCEDURE, TO WHICH BASIS POINTS\
    VAR
      I: INTEGER;
      LACR: ACR;
     BEGIN
       IF BASIS = NULLPTR
       THEN IDTREE := ENTRY1.GLOBALIDTREE
       ELSE
	 BEGIN
	  LACR := ACRPOINT ( BASIS^[0] - 1, RIGHT );
	  I := LACR^[0];
%I is now a "pushj p,proc".  However if proc is a parameter it is
 "pushj p,0(1)".  We next check for that, and call MAGIC.  You don't
 want to know how MAGI~CC works, but it returns the address of the
 routine called by the pushj\
	  if (i mod 1000000B)=0
	    then i:=magic(basis);
	   REPEAT
	    I := I - 1;
	    LACR := ACRPOINT ( I, RIGHT)
	   UNTIL LACR^[0] >= 0 %HRR BASIS,-1(BASIS)\;
	  IDTREE := CTPOINT( LACR^[0], RIGHT )
	 END
     END;

    PROCEDURE FIRSTBASIS(SIDE:LEFTORRIGHT);
      %GENERATES BASISPOINTER TO 'AKTIVIERUNGSRECORD' OF UNDERBREAKED PROCEDURE\
     BEGIN
(* 14 - impliment the ability to move about the stack *)
      BASIS := Call_Basis;                          
      TESTGLOBALBASIS(SIDE)
     END;

    PROCEDURE SUCCBASIS(SIDE: LEFTORRIGHT);
      %GENERATES BASISPOINTER TO 'AKTIVIERUNGSR.'
       OF STATIC/DYNAMIC HIGHER PROCEDURE)\
	%SIDE:  RIGHT FOR STATIC LINK
		LEFT FOR DYNAMIC LINK\
     BEGIN
      BASIS := ACRPOINT( BASIS^[0-1], SIDE );
      TESTGLOBALBASIS(SIDE)
     END;

    PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
     BEGIN
      WHILE FCP # NIL DO WITH FCP^ DO
       BEGIN
	 IF NAME = ID
	 THEN GOTO 1;
	 IF NAME < ID
	 THEN FCP := RLINK
	 ELSE FCP := LLINK
       END;
1:
      FCP1 := FCP
     END %SEARCHSECTION\;

    PROCEDURE SEARCHID(VAR FCP: CTP);
    VAR
      LCP: CTP;
     BEGIN
      FIRSTBASIS(RIGHT);
       LOOP
	SEARCHSECTION( IDTREE, LCP );
	 IF LCP # NIL
	 THEN GOTO 1
       EXIT IF BASIS = NULLPTR;
	SUCCBASIS ( RIGHT%=STATIC\ )
       END;
      SEARCHSECTION( ENTRY1.STANDARDIDTREE, LCP );
1:
      FCP := LCP
     END;

    FUNCTION CHARPTR(FSP: STP): BOOLEAN;
(* 9 - make it detect subranges *)
     BEGIN
     charptr := false;
     if fsp # nil
       then if fsp^.form = subrange
	      then charptr := fsp^.rangetype = entry1.charptr
	      else charptr := fsp = entry1.charptr
     END;

    PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
      %GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE\
      %ASSUME (FSP # NIL) AND (FSP^.FORM <= SUBRANGE) AND (FSP # INTPTR)
       AND  NOT COMPTYPES(REALPTR,FSP)\
     BEGIN
      WITH FSP^ DO
       IF FORM = SUBRANGE
       THEN
	 BEGIN
	  FMIN := MIN.IVAL; FMAX := MAX.IVAL
	 END
       ELSE
	 BEGIN
	  FMIN := 0;
	   IF CHARPTR(FSP)
	   THEN FMAX := 177B
	   ELSE
	     IF FCONST # NIL
	     THEN FMAX := FCONST^.VALUES.IVAL
	     ELSE FMAX := 0
	 END
     END %GETBOUNDS\ ;

    FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
      %DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE\
    VAR
      NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
     BEGIN
       IF FSP1 = FSP2
       THEN COMPTYPES := TRUE
       ELSE
	 IF (FSP1 # NIL) AND (FSP2 # NIL)
	 THEN
	   IF FSP1^.FORM = FSP2^.FORM
	   THEN
	     CASE FSP1^.FORM OF
	      SCALAR:	COMPTYPES := FALSE;
		     % IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
		      NOT RECOGNIZED TO BE COMPATIBLE\
	      SUBRANGE: COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE);
	      POINTER:	COMPTYPES := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE);
	      POWER:	COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
	      ARRAYS:
		      BEGIN
		       GETBOUNDS (FSP1^.INXTYPE,LMIN,LMAX);
		       I := LMAX-LMIN;
		       GETBOUNDS (FSP2^.INXTYPE,LMIN,LMAX);
		       COMPTYPES := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE)
		       AND (FSP1^.ARRAYPF = FSP2^.ARRAYPF) AND ( I = LMAX - LMIN )
		      END;
		     %ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
		      BE COMPATIBLE. MAY GIVE TROUBLE FOR ENT OF STRINGCONSTANTS
		      -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
		      BE THE SAME\
	      RECORDS:
		       BEGIN
			NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE;
			WHILE (NXT1 # NIL) AND (NXT2 # NIL) DO
			 BEGIN
			  COMP := COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE) AND COMP;
			  NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
			 END;
			COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
			AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL)
		       END;
		      %IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
		       IF NO VARIANTS OCCUR\
	      FILES:  COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE)
	     END %CASE\
	   ELSE %FSP1^.FORM # FSP2^.FORM\
	     IF FSP1^.FORM = SUBRANGE
	     THEN COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2)
	     ELSE
	       IF FSP2^.FORM = SUBRANGE
	       THEN COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE)
	       ELSE COMPTYPES := FALSE
	 ELSE COMPTYPES := TRUE
     END %COMPTYPES\ ;

    FUNCTION NEXTBYTE(FBITSIZE: INTEGER ): INTEGER;
    VAR
      LVAL,J: INTEGER;
      BYTE_INT: PACKED RECORD
			 CASE BOOLEAN OF
			      FALSE: (BITS: PACKED ARRAY[1..36] OF BIT );
			      TRUE : (INTCONST: INTEGER)
		       END;
     BEGIN
      WITH GATTR DO
       BEGIN
	LVAL := 0;
        If packfg
          Then begin
                 IF FBITSIZE + GBITCOUNT  >  BITMAX
                  THEN
                   BEGIN
                    GADDR := GADDR + 1;
                    GBITCOUNT := 0
                   END;
                 WITH BYTE_INT DO
                  BEGIN
                   INTCONST := BASIS^[GADDR];
                   FOR J := GBITCOUNT + 1  TO GBITCOUNT + FBITSIZE DO
                   LVAL := LVAL*2 + BITS[J]
                  END;
                 GBITCOUNT := GBITCOUNT + FBITSIZE;
               end
          Else begin
                 Lval := basis^[gaddr];
                 gaddr := gaddr + 1;
               end;
       END %WITH GATR\;
      NEXTBYTE := LVAL;
     END %NEXTBYTE\;

    PROCEDURE PUTNEXTBYTE( FBITSIZE, FVAL: INTEGER );
    VAR
      J: INTEGER;
      INT_BYTE: PACKED RECORD
			 CASE BOOLEAN OF
			      FALSE: (BITS: PACKED ARRAY[1:36] OF BIT);
			      TRUE:  (INTCONST: INTEGER)
		       END;
     BEGIN
      WITH GATTR, INT_BYTE DO
       BEGIN
	 IF FBITSIZE + GBITCOUNT > BITMAX
	 THEN
	   BEGIN
	    INTCONST := BASIS^[GADDR+1];
	    GBITCOUNT := 0
	   END
	 ELSE INTCONST := BASIS^[GADDR];
	FOR J := GBITCOUNT + FBITSIZE  DOWNTO  GBITCOUNT+ 1  DO
	 BEGIN
	  BITS[J] := FVAL MOD 2;
	  FVAL := FVAL DIV 2
	 END;
	BASIS^[GADDR] := INTCONST
       END
     END;

    PROCEDURE GETFIELD( FCP:CTP );
    VAR  BYTEPTRCHANGE:  PACKED RECORD
			       CASE BOOLEAN OF
				    FALSE: (BYTEPTRCONST: INTEGER);
				    TRUE:  (SBITS,PBITS: 0..BITMAX;
					    IBIT, DUMMYBIT: BIT;
					    IREG: ACRANGE;
					    RELADDR: HALFWORD)
			     END;
	BEGIN
			   WITH FCP^, GATTR DO
			    BEGIN
			      IF KLASS # FIELD
			      THEN WRITELN(TTY,'!Error in getfield');
			      CASE PACKF OF
			       NOTPACK,
			       HWORDL: BEGIN GADDR := GADDR + FLDADDR; GBITCOUNT := 0 END;
			       HWORDR:
				       BEGIN
					GADDR := GADDR + FLDADDR;
					GBITCOUNT := 18
				       END;
			       PACKK: WITH BYTEPTRCHANGE DO
				      BEGIN
				       BYTEPTRCONST := BASIS^[FLDADDR];
					IF (IREG # 1) OR (IBIT = 1)
					THEN WRITELN(TTY,'!Error in getfield(illegal bytepointer');
				       GADDR := GADDR + RELADDR;
				       GBITCOUNT := BITMAX - SBITS -PBITS;
				      END
			      END %CASE\;
			     PACKFG := PACKF # NOTPACK;
			     TYPTR := IDTYPE
			    END %WITH\
	END %GETFIELD\;

    PROCEDURE WRITESCALAR(var outfile:text;FVAL:INTEGER; FSP: STP);
    VAR
      LCP: CTP; LENG: INTEGER;
      LVALU: VALU;
     BEGIN
       IF FSP # NIL
       THEN WITH FSP^ DO
	 CASE FORM OF
	  SCALAR:
		  IF SCALKIND=STANDARD
		  THEN
		    IF FSP=ENTRY1.INTPTR
		    THEN
		      BEGIN
(* 25 - Hex and Octal printout *)
			  if printradix = hex
			      then begin
				       leng := hexlen(fval);
				       write(outfile,'"',fval:leng:h);
				       leng := leng + 1
				   end
			      else if printradix = octal
				  then begin
					   leng := octlen(fval);
					   write (outfile, fval:leng:o,'B');
					   leng := leng + 1
				       end
				  else begin
				       LENG := LENGTH(FVAL); WRITE(outfile, FVAL:LENG)
				       end
		      END
		    ELSE
		      IF FSP=ENTRY1.REALPTR
		      THEN WITH LVALU DO
			BEGIN
			 IVAL := FVAL;
			 WRITE(outfile, RVAL); LENG := 16
			END
		      ELSE %==>CHARPTR\
(* 6 - print ctl char's right *)
			if fval < 40B
			  then begin write(outfile,'''^',chr(fval+100b),''''); leng := 4 end
			  else begin write(outfile,'''', chr(fval),''''); leng := 3 end
		  ELSE %SCALKIND==>DECLARED\
		    BEGIN
		     LCP := FCONST;
		      IF FVAL >= 0
		      THEN  WHILE LCP^.VALUES.IVAL > FVAL DO LCP := LCP^.NEXT;
		     WITH LCP^ DO
		      IF VALUES.IVAL # FVAL
		      THEN
			BEGIN
			 LENG := LENGTH(FVAL); WRITE(outfile,FVAL:LENG, '(Out of range)'); LENG := LENG + 14
			END
		      ELSE
			BEGIN
			 FOR LENG := 10 DOWNTO 1 DO
			  IF NAME[LENG] # ' '
			  THEN GOTO 1;
1:
			 WRITE(outfile,NAME:LENG)
			END
		    END;
	  SUBRANGE:
		    BEGIN
		     WRITESCALAR(outfile,FVAL,RANGETYPE); LENG := 0
		    END;
	  POINTER:
		   IF FVAL = ORD(NIL)
		   THEN
		     BEGIN
		      WRITE(outfile,'NIL'); LENG := 3
		     END
		   ELSE
		     BEGIN
		      WRITE(outfile,FVAL:6:O,'B'); LENG:=7
		     END;
	  OTHERS: WRITE(TTY,'!Err in writescalar')
	 END %CASE\;
      CHCNT := CHCNT + LENG
     END;

    PROCEDURE WRITESTRUCTURE(var outfile:text; FSP: STP );
    VAR
      INX : INTEGER;
      LMIN, LMAX, LENG, LSPACE: INTEGER;
      LADDR: HALFWORD;
      NOCOMMA: BOOLEAN;
      SETWANDEL: RECORD
		   CASE BOOLEAN OF
			FALSE: (CONST1: INTEGER; CONST2: INTEGER);
			TRUE:  (MASK: SET OF 0..71)
		 END;
(* 17 - Print multiple array elements on a line *)
      Oattr: Attr;
      Lasteq: Boolean ;
      Nexteq: Boolean ;
      Currcompo: Integer;

      PROCEDURE WRITEFIELDLIST(var outfile:text;FPACK: BOOLEAN; FNEXTFLD: CTP; FRECVAR: STP);
      VAR
	LSP: STP; J: INTEGER;
	LATTR : ATTR;
	VARFLAG: BOOLEAN;
       BEGIN
	LATTR := GATTR;
	WHILE FNEXTFLD # NIL DO  WITH FNEXTFLD^ DO
	 BEGIN
	  NEWLINE(outfile);
	  WRITE(outfile,NAME,': '); CHCNT := CHCNT + 12;
	  NL := TRUE;
	  GETFIELD(FNEXTFLD);
	  WRITESTRUCTURE(outfile,IDTYPE);
	  GATTR := LATTR;
	  FNEXTFLD := FNEXTFLD^.NEXT
	 END;
	 IF FRECVAR # NIL
	 THEN
	   IF FRECVAR^.FORM = TAGFWITHID
	   THEN
	     BEGIN
	      WITH FRECVAR^.TAGFIELDP^ DO
	       BEGIN
		NEWLINE(outfile);
		WRITE(outfile,NAME, ': '); CHCNT := CHCNT + 12;
		GETFIELD( FRECVAR^.TAGFIELDP );
(* 4 - add code here so it works for packed records, too !!*)
		IF FPACK
		THEN J:=NEXTBYTE(IDTYPE^.BITSIZE)
		ELSE
		  BEGIN
		   J := BASIS^[GATTR.GADDR]
		  END;
		WRITESCALAR(outfile, J, IDTYPE);
		GATTR:=LATTR;
	       END;
	      LSP := FRECVAR^.FSTVAR;
	       LOOP
		VARFLAG := LSP # NIL;
(* 1 - removed test for varflag being in order, as it isn't, in general *)
		IF NOT VARFLAG

		 THEN
		  BEGIN
		   WRITE(TTY,'No fields for this variant'); GOTO 1
		  END
	       EXIT IF LSP^.VARVAL.IVAL = J;
		LSP := LSP^.NXTVAR
	       END %LOOP\;
	      WITH LSP^ DO
		 BEGIN
		   IF FORM # VARIANT
		   THEN
		     BEGIN
		      WRITE(TTY,'Err in wrfldlst'); GOTO 1
		     END;
		  GATTR := LATTR;
		  WRITEFIELDLIST(outfile, FPACK, FIRSTFIELD, SUBVAR )
		 END;
1:
	     END
       END;

     BEGIN
      %WRITESTRUCTURE\
       IF FSP # NIL
       THEN WITH FSP^, GATTR DO
	 CASE FORM OF
	  SCALAR,
	  SUBRANGE,
	  POINTER:
		   BEGIN
                    I := NEXTBYTE(FSP^.BITSIZE);
		    WRITESCALAR(outfile,I,FSP)
		   END;
	  POWER:
		 BEGIN
		  NOCOMMA := TRUE; WRITE(outfile, '['); LENG := 1;
		  WITH SETWANDEL DO
		   BEGIN
		    CONST1 := BASIS^[GADDR]; CONST2 := BASIS^[GADDR+1]; GADDR := GADDR + 2;
		    FOR INX := 0 TO 71 DO
		     IF INX IN MASK
		     THEN
		       BEGIN
			 IF NOCOMMA
			 THEN NOCOMMA := FALSE
			 ELSE WRITE(outfile,',');
			LENG := LENG + 1;
			 IF CHARPTR(ELSET)
(* 10 - use new char mapping *)
			 then i := setmap[inx]
			 ELSE I := INX;
			WRITESCALAR(outfile,I,ELSET)
		       END
		   END %WITH SETWANDEL\;
		  WRITE(outfile,']' ); CHCNT := CHCNT + LENG
		 END %POWER\;
	  ARRAYS:
		  BEGIN
		   GETBOUNDS(INXTYPE, LMIN, LMAX );
		   GBITCOUNT := 0;
		    IF CHARPTR(AELTYPE) AND ARRAYPF
		    THEN %STRING\
		      BEGIN
		       LENG := LMAX - LMIN + 1 ;
		       POINTERCV.ADDR := GADDR;
(* 6 - print char's right for ctl char *)
                       write (outfile, '''');
		       for inx := 1 to leng do
			 if ord(pointercv.stringptr^[inx]) < 40b
                           then begin write(outfile,'^',chr(ord(pointercv.stringptr^[inx])+100b)); chcnt := chcnt+1 end
                           else write (outfile,pointercv.stringptr^[inx]);
                       write (outfile, '''');
		       GADDR  :=  GADDR  +  ( LENG-1 ) DIV 5 ;
		       CHCNT := CHCNT + LENG + 2
		      END %STRING\
		    ELSE
(* 17 - rewrite array printouts *)
                     BEGIN
		      PACKFG:=ARRAYPF;
		      LASTEQ:=FALSE;
		      FOR INX:= LMIN TO LMAX DO
		       BEGIN
			IF INX=LMAX
			THEN NEXTEQ:=FALSE
			ELSE
                	 IF AELTYPE^.FORM <= POINTER
			 THEN
			   BEGIN
			    OATTR:=GATTR;
        		    CURRCOMPO:=NEXTBYTE(AELTYPE^.BITSIZE);
			    NEXTEQ:=CURRCOMPO = NEXTBYTE(AELTYPE^.BITSIZE);
			    GATTR:=OATTR;
			   END
			 ELSE
			   BEGIN
			    NEXTEQ:=TRUE;I:=0;
			     LOOP
			      NEXTEQ:=(BASIS^[GADDR+I] = BASIS^[GADDR+AELTYPE^.SIZE+I]);
			     EXIT IF NOT NEXTEQ OR (I = AELTYPE^.SIZE-1);
			      I:=I+1;
			     END;
			   END (* FORM>POINTER *);
			IF NOT(LASTEQ AND NEXTEQ)
			THEN
			 BEGIN
			  IF NL
			  THEN NEWLINE(outfile)
			  ELSE NL:=TRUE;
                          WRITE(outfile,'['); WRITESCALAR(outfile,INX,INXTYPE);
                          WRITE(outfile,']'); CHCNT:=CHCNT+2;
			 END;
			IF NOT NEXTEQ
			THEN
			 BEGIN
                          WRITE(outfile,'=');CHCNT:=CHCNT+1;
			  LEFTSPACE:=LEFTSPACE + 3;
			  NL:=TRUE;
			  WRITESTRUCTURE(outfile,AELTYPE);
			  LEFTSPACE:=LEFTSPACE - 3;
                         END 
			ELSE
			 BEGIN
			  IF NOT LASTEQ
			  THEN
			   BEGIN
                            WRITE(outfile,'..');
			    CHCNT:=CHCNT+2;
			    NL:=FALSE;
			   END;
			  IF AELTYPE^.FORM <= POINTER
			  THEN CURRCOMPO:=NEXTBYTE(AELTYPE^.BITSIZE)
                          ELSE GADDR:=GADDR+AELTYPE^.SIZE;    
			 END (* NEXTEQ *);
			LASTEQ:=NEXTEQ;
		       END (* FOR *);
		     END (* NOT STRING *);
		    IF ARRAYPF
		    THEN
		      BEGIN
		       GADDR := GADDR + 1; GBITCOUNT := 0
		      END
		  END %ARRAYS\;
	  RECORDS:
		   BEGIN
		    WRITE(outfile,'RECORD');
		    LSPACE := LEFTSPACE; LEFTSPACE := CHCNT + 1;
		    LADDR := GADDR;
		    WRITEFIELDLIST(outfile,RECORDPF,FSTFLD,RECVAR);
		    GADDR := LADDR + SIZE; GBITCOUNT := 0;
		    LEFTSPACE := LEFTSPACE - 1; NEWLINE(outfile);
		    WRITE(outfile,'END');
		    LEFTSPACE := LSPACE
		   END;
	  FILES:   WRITE(outfile,'!File')
	 END %CASE FORM\
     END %WRITESTRUCTURE\;

    PROCEDURE SIMPLEFACTOR; FORWARD;

    PROCEDURE SELECTOR;
    VAR
      LCP: CTP;
      LMIN, LMAX: INTEGER;
      LATTR: ATTR;
      INDEX, I, INDEXOFFSET, BYTESINWORD: INTEGER;
     BEGIN
      WHILE SY IN [LBRACK,ARROW,PERIOD] DO  WITH GATTR DO
       CASE SY OF
	LBRACK:
		BEGIN
		  REPEAT
		    IF TYPTR # NIL
		    THEN
		      IF TYPTR^.FORM # ARRAYS
		      THEN
			BEGIN
			 ERROR; WRITELN(TTY,'Type of variable is not array')
			END;
		   INSYMBOL;
		    IF NOT (SY IN [ IDENT, INTCONST, PLUS, MINUS, CHARCONST ] )
		    THEN
		      BEGIN
		       ERROR; WRITELN(TTY,'Illegal symbol')
		      END;
		    IF TYPTR # NIL
		    THEN
		      BEGIN
		       LATTR := GATTR;
		       SIMPLEFACTOR;
			IF COMPTYPES( GATTR.TYPTR, LATTR.TYPTR^.INXTYPE )
			THEN WITH GATTR DO
			  BEGIN
			    IF KIND = CST
			    THEN INDEX := CVAL.IVAL
			    ELSE
			      IF PACKFG
			      THEN INDEX := NEXTBYTE(TYPTR^.BITSIZE)
			      ELSE INDEX := BASIS^[GADDR];
			   GATTR := LATTR
			  END
			ELSE
			  BEGIN
			   ERROR; WRITELN(TTY,'Index-type is not compatible with declaration')
			  END
		      END %TYPTR # NIL\;
		    IF TYPTR # NIL
		    THEN WITH TYPTR^ DO
		      BEGIN
		       GETBOUNDS(INXTYPE, LMIN, LMAX );
			INDEXOFFSET := INDEX - LMIN;
			IF INDEXOFFSET < 0
			THEN I := - INDEXOFFSET
			ELSE
			  IF INDEX > LMAX
			  THEN I:= INDEX - LMAX
			  ELSE GOTO 1;
		       ERROR; WRITE(TTY,'array-index by ', I:LENGTH(I),' ');
			IF INDEXOFFSET < 0
			THEN WRITELN(TTY, 'less than low bound')
			ELSE WRITELN(TTY,'greater than high bound');
1:
			IF  ARRAYPF
			THEN
			  BEGIN
			   PACKFG := TRUE;
			   BYTESINWORD := BITMAX DIV AELTYPE^.BITSIZE; I := INDEXOFFSET MOD BYTESINWORD;
			   GADDR := GADDR + (INDEXOFFSET DIV BYTESINWORD);
			    IF INDEXOFFSET < 0
			    THEN
			      BEGIN
			       GADDR := GADDR-1;
			       GBITCOUNT := (BYTESINWORD + I) * AELTYPE^.BITSIZE
			      END
			    ELSE GBITCOUNT := I * AELTYPE^.BITSIZE
			  END
			ELSE GADDR := GADDR + (AELTYPE^.SIZE * INDEXOFFSET);
		       TYPTR := AELTYPE
		      END %TYPTR # NIL\
		  UNTIL SY # COMMA;
		  IF SY = RBRACK
		  THEN INSYMBOL
		  ELSE
		    BEGIN
		     ERROR; WRITELN(TTY,'"]" expected')
		    END;
		END;
	PERIOD:
		BEGIN
		  IF TYPTR # NIL
		  THEN
		    IF TYPTR^.FORM # RECORDS
		    THEN
		      BEGIN
		       ERROR; WRITELN(TTY,'Type of variable is not record')
		      END;
		 INSYMBOL;
		  IF SY = IDENT
		  THEN
		    BEGIN
		      IF TYPTR # NIL
		      THEN
			BEGIN
			 SEARCHSECTION(TYPTR^.FSTFLD, LCP);
			  IF LCP = NIL
			  THEN
			    BEGIN
			     ERROR;
			     WRITELN(TTY,'No such field in this record')
			    END
			  ELSE GETFIELD(LCP)
			END %TYPTR # NIL\;
		     INSYMBOL
		    END
		  ELSE
		    BEGIN
		     ERROR;
		     WRITELN(TTY,'Identifier expected')
		    END
		END %PERIOD\;
	ARROW:
	       BEGIN
		INSYMBOL;
		 IF TYPTR # NIL
		 THEN
		   CASE TYPTR^.FORM OF
		    POINTER:
			     BEGIN
			       IF PACKFG
			       THEN GADDR := NEXTBYTE(18)
			       ELSE GADDR := BASIS^[GADDR];
			       IF GADDR = ORD(NIL)
			       THEN
				 BEGIN
				  ERROR; WRITELN(TTY,'Pointer is NIL')
				 END
(* 3 - detect uninitialized pointers *)
			       ELSE IF GADDR = 0
			       THEN
				 BEGIN
				 ERROR; WRITELN(TTY,'Uninitialized pointer')
				 END
			       ELSE TYPTR := TYPTR^.ELTYPE
			     END;
		    FILES:
			   BEGIN
			    GADDR := BASIS^[GADDR];
			    TYPTR := TYPTR^.FILTYPE
			   END;
		    OTHERS:
			    BEGIN
			     ERROR;
			     WRITELN(TTY,'Type of variable must be file or pointer')
			    END
		   END %CASE FORM\;
		PACKFG := FALSE; GBITCOUNT := 0
	       END %ARROW\
       END %CASE\
     END %SELECTOR\;

    PROCEDURE VARIABLE;
    VAR
      LCP: CTP;

     BEGIN
      %VARIABLE\
      SEARCHID(LCP);
       IF LCP = NIL
       THEN
	 BEGIN
	  ERROR; WRITELN(TTY,'not found')
	 END
       ELSE
	 BEGIN
	  WITH LCP^, GATTR  DO
	   CASE KLASS OF
	    TYPES,PARAMS:
		   BEGIN
		    ERROR; WRITELN(TTY,'!type')
		   END;
	    KONST:
		   BEGIN
		    KIND := CST; CVAL := VALUES;
		    TYPTR := IDTYPE
		   END;
	    VARS:
		  BEGIN
		   KIND := VARBL;
		   GADDR := VADDR + ORD(BASIS); BASIS := NULLPTR;
		   GBITCOUNT := 0;
		    IF VKIND = FORMAL
		    THEN   GADDR := BASIS^[GADDR];
		   TYPTR := IDTYPE; PACKFG := FALSE;
		   SELECTOR
		  END;
	    FIELD: %WRITE(TTY,'Not implemented; Try <record>.<field> ...')\;
	    PROC:
		  BEGIN
		   ERROR; WRITELN(TTY,'!Procedure')
		  END;
	    FUNC:
		  BEGIN
		   ERROR; WRITELN(TTY,'!Function')
		  END
	   END %CASE CLASS\
	 END
     END %VARIABLE\;

    PROCEDURE SIMPLEFACTOR;  (* UNSIGNED AND SIGNED CONSTANTS AND VARIABLES *)
    VAR
      SIGNED : BOOLEAN ;
     BEGIN
       IF SY = IDENT
       THEN
	 BEGIN
	  INSYMBOL; VARIABLE
	 END
       ELSE WITH GATTR DO
	 BEGIN
	  KIND := CST; CVAL := VAL;
	   CASE SY OF
	    INTCONST:
		      BEGIN
		       TYPTR := ENTRY1.INTPTR; INSYMBOL
		      END;
	    REALCONST:
		       BEGIN
			TYPTR := ENTRY1.REALPTR; INSYMBOL
		       END;
	    CHARCONST:
		       BEGIN
			TYPTR := ENTRY1.CHARPTR; INSYMBOL
		       END;
	    STRINGCONST:
			 BEGIN
			  TYPTR := STRINGPTR;
			  INSYMBOL
			 END;
	    PLUS,
	    MINUS:
		   BEGIN
		    SIGNED := SY=MINUS ;
		    INSYMBOL; SIMPLEFACTOR;
		     IF NOT ( COMPTYPES(TYPTR,ENTRY1.INTPTR) OR COMPTYPES(TYPTR,ENTRY1.REALPTR) )
		     THEN
		       BEGIN
			ERROR; WRITELN(TTY,'No sign allowed here')
		       END
		     ELSE
		       IF SIGNED
		       THEN
			 IF KIND=CST
			 THEN CVAL.IVAL := -CVAL.IVAL
			 ELSE
			   BEGIN
			    ERROR; WRITELN(TTY,'Signed variables not implemented')
			   END
		   END %MINUS\
	   END %CASE\
	 END %WITH GATTR\
     END  (* SIMPLEFACTOR *);

    PROCEDURE ASSIGNMENT;
    VAR
      LATTR: ATTR;
      LSP: STP;
      BYTE:  INTEGER;
(* 26 - handle all constants *)
      cbasis: acr;
     BEGIN
       IF GATTR.KIND # VARBL
       THEN
	 BEGIN
	  ERROR; WRITELN(TTY,'Assignment allowed to variables only')
	 END
       ELSE
	 BEGIN
	  LATTR := GATTR;
	  SIMPLEFACTOR;
	   IF ENDOK
	   THEN
	     IF COMPTYPES( LATTR.TYPTR, GATTR.TYPTR )
	     THEN
	       BEGIN
		 IF LATTR.PACKFG
		 THEN
		   BEGIN
		    WITH GATTR DO
		     IF KIND = CST
		     THEN BYTE := CVAL.IVAL
		     ELSE
		       IF PACKFG
		       THEN BYTE := NEXTBYTE( TYPTR^.BITSIZE )
		       ELSE BYTE := BASIS^[ GADDR ] ;
		    GATTR := LATTR;
		    PUTNEXTBYTE( GATTR.TYPTR^.BITSIZE, BYTE )
		   END (* IF PACKFG *)
		 ELSE
		   IF GATTR.KIND = CST
(* 26 - handle constants of all types *)
		   THEN if gattr.typtr^.form = arrays  {must be string}
			   then begin
			    cbasis := acrpoint(ord(gattr.cval.valp)+4,right);
			    for i := 0 to (4+gattr.cval.valp^.slgth)div 5 do
			      basis^[lattr.gaddr+i] := cbasis^[i]
			    end
		   	   ELSE BASIS^[LATTR.GADDR] := GATTR.CVAL.IVAL
		   ELSE
		     IF GATTR.PACKFG
		     THEN BASIS^[LATTR.GADDR] := NEXTBYTE( GATTR.TYPTR^.BITSIZE )
		     ELSE FOR I := 0 TO LATTR.TYPTR^.SIZE - 1  DO
		      BASIS^[LATTR.GADDR + I ] := BASIS^[ GATTR.GADDR + I ]
	       END (* IF COMPTYPES *)
	     ELSE
	       BEGIN
		ERROR; WRITELN(TTY, 'Type-conflict in assignment' )
	       END
	 END (*  KIND=VARIABLE	*)
     END (* ASSIGNMENT *) ;


(* 7 - multiple modules *)
    FUNCTION STOPSEARCH(FLINE:HALFWORD;MODULE:DEBPTR):INTEGER;
     BEGIN
      FOR I := 1 TO STOPMAX DO WITH STOPTABLE[I] DO
(* 7 - multiple modules *)
       IF (PAGE=GPAGE) AND (THISLINE=FLINE) AND (MODENTRY.NEXTDEB=MODULE)
       THEN
	 BEGIN
	  STOPSEARCH := I;
	  GOTO 1%EXIT\
	 END;
      STOPSEARCH := 0; %NOT FOUND\
1:
     END;

    FUNCTION PAGEVALUE(FPAGER: PAGEELEM): INTEGER;
     BEGIN
      WITH FPAGER DO  PAGEVALUE := AC*16 + INXREG
     END;

(* 7 - multiple modules *)
    FUNCTION LINEVALUE ( VAR FLINER: LINEELEM; FLINE: INTEGER; MODULE:DEBPTR) : INTEGER;
     BEGIN
      WHILE FLINER.CODE = 260B%PUSHJ\ DO
       BEGIN
(* 7 - multiple modules *)
	I := STOPSEARCH( FLINE , MODULE);
	 IF I = 0
	 THEN
	   BEGIN
	    WRITELN(TTY,'> Stop table destroyed'); LINEVALUE := -1; GOTO 1
	   END;
	FLINER.CONSTANT1 := STOPTABLE[I] . ORIGINALCONT . CONSTANT1
       END %PUSHJ\;
      WITH FLINER DO
       IF CODE = 1%one-word LUUO\
       THEN  LINEVALUE := FLINE - ( AC + 16*INXR )
       ELSE %2\
	 BEGIN
	   IF CODE # 2%two-word LUUO\
	   THEN
	     BEGIN
	      WRITELN(TTY,'> Internal confusion: bad instruction in line-chain. Lastline=',FLINE:5);
	      LINEVALUE := -1; GOTO 1
	     END;
	   IF ABSLINE = 777777B
	   THEN LINEVALUE := -1
	   ELSE LINEVALUE := ABSLINE
	 END;
1:
     END %LINEVALUE\ ;

(* 7 - allow multiple modules *)
    function strlen(s:alfa):integer;
	var i:integer;
      begin
      i:=0;
      if s[10]#' '
        then i:=10
	else while s[i+1]#' '
          do i := i+1;
      strlen:=i
      end;

    FUNCTION GETLINPAG(var linenr,gpage,defpage:integer;follow:setofsys): 
	BOOLEAN;
	  %READS LINENUMBER AND PAGENUMBER\
       BEGIN
	GETLINPAG := FALSE;
	if sy = star
	  then begin
	  insymbol;
	  if sy in follow
	    then begin
	    linenr := dotline;
	    gpage := dotpage;
	    getlinpag := true
	    end
	   else begin error; writeln(tty,'Junk after line number') end
	  end
	ELSE IF SY # INTCONST
	 THEN begin error; WRITELN(TTY,'Not a line number') end
	 ELSE
	   BEGIN
	    LINENR := VAL.IVAL; GPAGE := defpage%DEFAULT\;
	    INSYMBOL;
	     IF SY = SLASHSY
	     THEN
	       BEGIN
		INSYMBOL;
		 IF SY # INTCONST
		 THEN
		  begin error; WRITELN(TTY,'Illegal page number') end
		 ELSE
		   BEGIN
		    GPAGE := VAL.IVAL; INSYMBOL
		   END
	       END;
	     IF not (SY in follow)
	     THEN begin error; WRITELN(TTY,'Junk after linenumber') end
	     ELSE GETLINPAG := TRUE
	   END
       END;

    procedure findout;
{Here when a FIND command is found}
	  var repcount:integer;
	begin
	repcount := 1;
	if sy = intconst
	  then begin 
	  repcount := val.ival;
	  insymbol
	  end;
	if sy = eolsy
	  then showstcontext(false,repcount)
	else if (sy = stringconst) or (sy = charconst)
	  then begin
	  insymbol;
	  if endOK
	    then showstcontext(true,repcount)
	  end
	else begin error; writeln(tty,'> Expecting ''target string''') end
	end;

    procedure typeout;
{Here when a TYPE command is found}
	  var stpage,stline,endpage,endline:integer;
	      i,j:integer; SOSend,SOSnum:packed array[1..5]of char;
	begin
	if not getlinpag(stline,stpage,dotpage,[eolsy,star,intconst])
	  then goto 666;
	if sy = eolsy
	  then begin endline := stline; endpage := stpage end
	  else if not getlinpag(endline,endpage,stpage,[eolsy])
	    then goto 666;
	if (endpage < stpage) or ((endpage = stpage) and (endline < stline))
	  then begin writeln(tty,'> Order of lines reversed?'); goto 666 end;
{stpage/stline and endpage/endline are now set up.  Do the typeout.}
        findpgln(source,stpage,stline);
	stpage := dotpage; stline := dotline;
	getlinenr(source,SOSnum);
	if SOSnum = '-----'
	  then 
{code for non-SOS files}
	  while (stpage < endpage) or
	        ((stpage = endpage) and (stline <= endline)) do
	    begin
	    if eof(source)
	      then goto 666;
	    if source^ = chr(14B)
	      then begin
	      stline := 1;
	      stpage := stpage + 1;
	      writeln(tty,'Page ',stpage:0);
	      readln(source)
	      end
	     else begin
	      write(tty,stline:0,'	');
	      while not eoln(source) do
	        begin
	        write(tty,source^);
	        get(source)
	        end;
	      writeln(tty);
	      stline := stline+1;
	      readln(source);
	      end
	    end
	  else begin
{Code for SOS files}
	  j := endline;
	  if (endline > 99999)
	    then SOSend := 'AAAAA'   {something bigger than any legal number}
	    else for i := 0 to 4 do
	      begin
	      SOSend[5-i] := chr((j mod 10) + 60B);
	      j := j div 10
	      end;
	  while (stpage < endpage) or
	        ((stpage = endpage) and (SOSnum <= SOSend)) do
	    begin
	    if eof(source)
	      then goto 666;
	    if source^ = chr(14B)
	      then begin
	      stpage := stpage + 1;
	      writeln(tty,'Page ',stpage:0);
	      readln(source)
	      end
	     else begin
	      write(tty,SOSnum,'	');
	      while not eoln(source) do
	        begin
	        write(tty,source^);
	        get(source)
	        end;
	      writeln(tty);
	      readln(source);
	      end;
	    getlinenr(source,SOSnum);
	    end;
	  end;
666:
	end;

{The compiler produces a linked list of line page entries, each of which
 points to a linked list of line number entries.  These are interspersed
 with code, where they show up as no-ops.  In order to implement
 single-stepping, we want to turn them from no-ops into LUUO's.  An
 LUUO causes execution of the instruction in location 41.  Normally we
 make this a no-op.  To do single-stepping, we just put a pushj to the
 debugger in location 41.  This extremely elegant suggestion is due to
 John Hall of Rutgers University.  It is probably slightly slower to
 execute an LUUO with location 41 than having real no-ops inline.  
 However we don't expect it to be more than about one instruction worth
 of time.  We don't know of any other way of doing single-stepping that
 doesn't run into problems of trying to trace into runtime procedures,
 Fortran subroutines, etc.
   This procedure traces down the list of line numbers turning all of
 the no-ops into LUUO's.  Different LUUO's are used for one-word and
 two-word line number entries, although at the moment no distinction is
 made in their processing.}
    PROCEDURE makeluuos;
    VAR
      lentry1:debugentry;
      PAGER: PAGEELEM; LINEPT: ^LINEELEM;
      LADDR: HALFWORD;
     BEGIN
     if tops10 then protection(false);
     lentry1 := entry2.entryptr^;	%first module\
     loop	%search modules\
      PAGER := LENTRY1.LASTPAGEELEM;	%first page in module\
       	  LOOP	%search pages\
	   LADDR := ORD ( PAGER.PAGPTR )
       	  EXIT IF LADDR = 0;		%laddr=0 on dummy page 0\
	   linept := pager.laststop;
	 	loop    %search lines\
	  	 laddr := ord (linept);
	 	exit if laddr = 0;
	  	 with linept^ do
	    	 if code = 320B%jump\
	           then code := 1%LUUO\
{Note: 334B is a two-word line number.  We leave the second word alone.
 It is already a no-op.  If we replaced it with another LUUO, we would
 get two breaks for that line when single-stepping.}
	    	 else if code = 334B%skipa\
	           then code := 2%LUUO\
	    	 %else already LUUO, nothing\;
	  	 linept := linept^.adp
	 	end;  %search lines\
	   pager := pager.pagptr^
 	  END %page loop\;
      laddr := ord(lentry1.nextdeb);
     exit if laddr = 0;
      lentry1 := lentry1.nextdeb^
     end; %module loop\
     if tops10 then protection(true)
     end; %makeluuos\

    PROCEDURE BREAKPOINT;
    VAR
      LINENR: INTEGER;
      PAGER: PAGEELEM;	LLE: LINEELEM;
      LLINE,LPAGE: INTEGER;
      OLDLINE: INTEGER;
      OLDADDR: ^LINEELEM;
      CHANGEPTR: ^LINEELEM;


     BEGIN
      %BREAKPOINT\
       command([listsy,notsy]);
       CASE SY OF
	LISTSY:
		BEGIN
		 INSYMBOL;
		  if endok
		    THEN FOR I := 1 TO STOPMAX DO  WITH STOPTABLE[I] DO
(* 7 - multiple modules *)
		    IF PAGE > 0
		    THEN WRITELN(TTY,'> ', modentry.modname:strlen(modentry.modname),
				     ':', THISLINE:length(thisline),
				     '/', PAGE:LENGTH(PAGE))
		END;
	NOTSY:
	       BEGIN
		INSYMBOL;
		command([allsy]);
(* 15 - Add STOP NOT ALL *)
                If sy = Allsy
                  Then begin
		  insymbol;
		  if endOK
		    then
                    For I:= 1 to Stopmax do
                      If (StopTable[I].Thisaddr # Nil) and
                         (StopTable[I].Thisaddr # Nil)    
                        then
                        BEGIN
                          Stoptable[I].page:=0;
                          if tops10 then Protection(False);
                          Stoptable[I].Thisaddr^.constant1 :=  Stoptable[I].Originalcont.Constant1;
                          if tops10 then Protection(True);
                          Stoptable[I].Thisaddr := Nil;
                        END
                        else (* null statement *)
		  end
                  Else
                      IF GETLINPAG(linenr,gpage,dotpage,[eolsy])
                        THEN
                          BEGIN
(* 7 - multiple modules *)
                            I:=STOPSEARCH(LINENR,ENTRY1.NEXTDEB);
                            IF I = 0
                            THEN WRITELN(tty, '> ? No such stop')
                            ELSE WITH STOPTABLE[I] DO
                              BEGIN
                                PAGE := 0;
                                if tops10 then PROTECTION(FALSE);
                                THISADDR^.CONSTANT1 := ORIGINALCONT.CONSTANT1;
                                if tops10 then PROTECTION(TRUE);
                                THISADDR := NIL
                              END
                          END
	       END;
	INTCONST,STAR:
(* 7 - multiple modules *)
		      IF GETLINPAG(linenr,gpage,dotpage,[eolsy])  
			AND  ( STOPSEARCH(LINENR,ENTRY1.NEXTDEB) = 0 
					%A NEW STOP\ )
		      THEN
			BEGIN
		STOPNR := 1;
		WHILE STOPTABLE[STOPNR].PAGE # 0 DO  STOPNR := STOPNR + 1;
		IF STOPNR > STOPMAX THEN WRITELN(TTY,'> Too many stops')
		ELSE
		BEGIN
			 %EXECUTE STOP\
			 %1.STEP: SEARCH PAGE\
			 PAGER := ENTRY1.LASTPAGEELEM;
			 LPAGE := PAGEVALUE(PAGER);
			  IF LPAGE < GPAGE
			  THEN WRITELN(TTY,'> Pagenumber too large')
			  ELSE
			    BEGIN
			     WHILE  LPAGE > GPAGE  DO
			      BEGIN
			       PAGER := PAGER.PAGPTR^;
			       LPAGE := PAGEVALUE(PAGER)
			      END;
			      IF LPAGE # GPAGE
			      THEN
				BEGIN
				 WRITELN(TTY,'> Can''t stop on this page'); GOTO 1
				END;
			     WITH LLE, PAGER DO
			      BEGIN
			       LLINE := LASTLINE; ADP := LASTSTOP
			      END;
			      IF LLINE < LINENR
			      THEN WRITELN(TTY,'> Linenumber too large')
			      ELSE
				BEGIN
				 WHILE LLINE > LINENR DO
				  BEGIN
				   OLDLINE := LLINE; OLDADDR := LLE.ADP;
				   LLE := LLE.ADP^;
(* 7 - multiple modules *)
				   LLINE := LINEVALUE ( LLE, LLINE ,ENTRY1.NEXTDEB)
				  END;
				  IF LLINE # LINENR
				  THEN
				    BEGIN
				     WRITE(TTY,'> Next possible: ',OLDLINE:LENGTH(OLDLINE),' (Y or N)? ');
				     READLN(TTY);
				     INSYMBOL;
				     IF (SY = IDENT) AND ((ID = 'Y         ')
						     OR   (ID = 'YES       '))
					THEN
				     ELSE IF (SY = IDENT) AND ((ID = 'N         ')
						     OR   (ID = 'NO        '))
				      THEN GOTO 1
				     ELSE BEGIN
					writeln(tty,'> NO assumed');
					goto 1
					end;
				     LLE.ADP := OLDADDR; LLINE := OLDLINE
				    END;
				 CHANGEPTR := LLE.ADP;
				 WITH STOPTABLE[STOPNR] DO
				  BEGIN
(* 7 - mult modules *)
				   modentry := entry1;
				   THISLINE := LLINE;  PAGE := GPAGE;
				   ORIGINALCONT := CHANGEPTR^;
				   THISADDR := CHANGEPTR
				  END;
				 if  tops10 then PROTECTION(FALSE);
				 CHANGEPTR^.CONSTANT1 := ENTRY2.STOPPY;
				 if tops10 then PROTECTION(TRUE)
				END
			    END
			END;
1:
		  END %INTCONST\;
	OTHERS: begin error; WRITELN(TTY,'> Expecting legal option of STOP command') end
       END %CASE\
     END %BREAKPOINT\;


    PROCEDURE LINEINTERVAL(FADDR: HALFWORD; VAR LIN1,LIN2,PAG: INTEGER; var lentry1:debugentry);
    VAR
      PAGER: PAGEELEM; LINER: LINEELEM;
      LADDR: HALFWORD;
     BEGIN
     lentry1 := entry2.entryptr^;	%first module\
     loop	%search modules\
      PAGER := LENTRY1.LASTPAGEELEM;	%first page in module\
      if faddr <= ord(pager.laststop)	%see if above this module\
       then
       LOOP	%no - search pages\
	LADDR := ORD ( PAGER.PAGPTR )
       EXIT IF LADDR <= FADDR;		%laddr=0 on dummy page 0\
	PAGER := PAGER.PAGPTR^
       END
       else laddr := 0;			%above this module - laddr=0 mean fail\
      pointercv.entptr1 := lentry1.nextdeb;
     exit if (laddr # 0) or (pointercv.addr = 0);  %found or tried last module\
      lentry1 := lentry1.nextdeb^
     end;
      LINER.ADP := PAGER.LASTSTOP;
      PAG := PAGEVALUE(PAGER); LIN2 := PAGER.LASTLINE; GPAGE:=PAG;
      LIN1 := LIN2;
       LOOP
	LADDR := ORD ( LINER.ADP ) ;
	LINER := LINER.ADP^
       EXIT IF LADDR <= FADDR;
	LIN2 := LIN1;
	LIN1 := LINEVALUE(LINER,LIN2,LENTRY1.NEXTDEB)
       END;
       IF LADDR = FADDR {If exact match, only give him one}
	 THEN LIN2 := LIN1;
       IF LIN1<0
       THEN LIN1 := 0
	END %LINEINTERVAL\;

    PROCEDURE STOPMESSAGE(FADDR: HALFWORD);
  VAR LIN1, LIN2, PAG: INTEGER;
(* 7 - multiple modules *)
	BEGIN   %NB - will reset ENTRY1 to module found in LINEINTERVAL\
	LINEINTERVAL(FADDR,LIN1,LIN2,PAG,ENTRY1);
        WRITE(TTY, '> Stop in ',entry1.modname:strlen(entry1.modname),':',
			   LIN1:LENGTH(LIN1), '/', PAG:LENGTH(PAG));
        if lin2 <> lin1
	  then write(tty,':',LIN2:LENGTH(LIN2) );
	writeln(tty);
	checksource(source,entry1);
	curent := entry1.nextdeb;
	showcontext(pag,lin1)
     END %STOPMESSAGE\ ;

(* 16 - Reformat output from traceout *)     
    PROCEDURE TRACEOUT(var outfile:text;trace_limit:integer);
    VAR I: Integer;
        LCP: CTP;
	LADDR: HALFWORD;
	LIN1, LIN2, PAG: INTEGER;
(* 7 - multiple modules *)
	lentry1:debugentry;
(* 18 - Add depth argument to trace *) 
        depth : integer;
     BEGIN	%NB - will not reset global ENTRY1\
       FIRSTBASIS(LEFT);
       LEFTSPACE := 0;
(* 14 - impliment the ability to move about the stack *)
       LADDR:=Call_Address;                         
(* 18 - Add depth argument to trace *) 
       depth := pos_in_stack;
       If trace_limit <= depth
         Then  Begin
                 WRITE(outfile,'>   Depth  Module Name  Subprogram  Page    Line');
                 Newline(outfile);
                 LOOP
                   LCP := IDTREE;
                   Write(outfile,depth:6,'   ');
                   LINEINTERVAL (  LADDR, LIN1,  LIN2, PAG, LENTRY1);
(* 18 - Add depth argument to trace *) 
                  EXIT IF (BASIS = NULLPTR) or (depth = trace_limit);
                   If Lcp = Nil
		     then
                       WRITE(outfile,Lentry1.modname,'   ','Local D-? ','  ',Pag:3,'   ',Lin1:5)
                     else
                       WRITE(outfile,Lentry1.modname,'   ',LCP^.NEXT^.NAME,'  ',Pag:3,'   ',Lin1:5);
                   Newline(outfile);
                   depth := depth - 1;
                   LADDR:=ORD(ACRPOINT(BASIS^[0]-1,RIGHT));
                   SUCCBASIS( LEFT%=DYNAMIC\ )
                 END;
                 If (basis = nullptr) or (depth = 0)
		   then WRITE(outfile,Lentry1.modname,'   MAIN        ',Pag:3,'   ',Lin1:5)
		   else if lcp = nil
                     then WRITE(outfile,Lentry1.modname,'   ','Local D-? ','  ',Pag:3,'   ',Lin1:5)
                   else WRITE(outfile,Lentry1.modname,'   ',LCP^.NEXT^.NAME,'  ',Pag:3,'   ',Lin1:5);
                 newline(outfile);
               End 
         Else  write (outfile, '>');
       newline(outfile);
       IF no_of_calls = 0
         THEN
           write (outfile, 'No subprograms called')
         ELSE
           IF no_of_calls = 1
             THEN
               write (outfile, 'One subprogram called') 
             ELSE
               write (outfile, no_of_calls, ' subprograms called');
      END %TRACEOUT\;

(* 7 - multiple modules *)
    procedure setmod;
      var
        lentry1:debugentry;
        Pag,Lin1,Lin2:Integer;
      BEGIN
          BEGIN
(* 14 - impliment the ability to move about the stack *)
            if sy = intconst
              then
              BEGIN
                if Val.Ival > No_of_calls
                  then
                  BEGIN
                    Error;
                    Writeln(tty,'The stack is ',No_of_calls +1:0,' deep');
                    Insymbol;
                  END
                  Else
                  BEGIN
                    Basis:=Acrpoint(Accus^[0+16B],Right);
                    Call_Address:=Entry2.Status.ReturnAddr;
                    For I:= 1 to No_of_calls - Val.Ival do
                    BEGIN
                      Call_Address:=Ord(Acrpoint(Basis^[0]-1,Right));
                      Succbasis(Left);
                    END;
                    Call_Basis:=Basis;
                    Lineinterval(Call_Address,Lin1,Lin2,Pag,Entry1);
		    checksource(source,entry1);
                    Curent:=Entry1.Nextdeb;
                    Pos_in_Stack:=Val.Ival;
                    Insymbol;
                  END;
              END;
            if (sy # ident) and (sy # Eolsy)
              then writeln(tty, '> Module name expected')
              else
                if sy = ident
                  Then
                  BEGIN
                    Pointercv.addr:=0;
                    lentry1 := entry2.entryptr^;
                    while (lentry1.modname # id) and (lentry1.nextdeb # pointercv.entptr1) do
                      lentry1 := lentry1.nextdeb^;
                    if lentry1.modname = id
                      then begin entry1:=lentry1; 
				checksource(source,entry1) end
                      else writeln(tty,'> Requested module not found');
                  END;
          END;
     END;

(* 7 - largely rewritten because of multiple modules and passing entry2*)
    PROCEDURE INIT;
     BEGIN
      pointercv.addr := 0;
      if entry2.entryptr # pointercv.entptr1
	then
	  begin
	  entry1 := entry2.entryptr^;
	  while entry1.nextdeb # pointercv.entptr1 do
	    entry1 := entry1.nextdeb^;  %main prog is end of list\
	  end
	else
	  begin
	  writeln (tty, '> No modules compiled with /DEBUG');
	  quit
	  end;
      Nullptr:=Acrpoint(0,Right);
      curent := entry1.nextdeb;
      ACCUS := ENTRY2.REGISTRS;
(* 14 - impliment the ability to move about the stack *)
      Call_Address := Entry2.Status.ReturnAddr;
      Call_Basis := Acrpoint(Accus^[0+16B],Right);
      Basis := Call_Basis;                   
      TestGlobalBasis(Left);
      No_of_Calls:=0;
      While Basis # Nullptr do
      BEGIN
        No_of_Calls := No_of_Calls + 1;
        SuccBasis(Left);
      END;
      Pos_in_Stack:=No_of_Calls;
     END;
 
(* 13 - add stackdump *)
    PROCEDURE ONE_VAR_OUT(var outfile:text;LCP:CTP);
    Var
     Lbasis:Acr;
     BEGIN
      Lbasis:=Basis;
      WITH LCP^,GATTR DO
       BEGIN
	KIND:=VARBL;
        GADDR:=VADDR+ORD(BASIS);
        Basis:=Nullptr; 
	GBITCOUNT:=0;
        IF VKIND=FORMAL
	THEN
	GADDR:=NULLPTR^[GADDR];
	TYPTR:=IDTYPE;
	PACKFG:=FALSE;
        WRITE(outfile,NAME,' = ');
	CHCNT:=CHCNT+1;
	IF IDTYPE^.FORM > POWER
	THEN
	 BEGIN
	  NL:=TRUE;
	  LEFTSPACE:=2;
	 END;
	WRITESTRUCTURE(outfile,IDTYPE);
	IF IDTYPE^.FORM >= POWER
	THEN
	 BEGIN
	  LEFTSPACE:=0;
	  NEWLINE(outfile);
	 END;
	NEWLINE(outfile);
       END (* WITH *);
       Basis:=Lbasis
     END (* ONE_VAR_OUT *);                                                    


    PROCEDURE SECTION_OUT(var outfile:text;LCP:CTP;FFORMSET:FORMSET);
     BEGIN
      WITH LCP^ DO
       BEGIN
	IF LLINK<>NIL
	THEN
	SECTION_OUT(outfile,LLINK,FFORMSET);
	IF (KLASS=VARS) AND (IDTYPE^.FORM IN FFORMSET)
	THEN
	ONE_VAR_OUT(outfile,LCP);
	IF RLINK<>NIL
	THEN
	SECTION_OUT(outfile,RLINK,FFORMSET);
       END (* WITH *);
     END (* SECTION_OUT *);


    PROCEDURE STACK_OUT(var outfile:text;s_dump_limit:integer);
    VAR
      TREEPNT:CTP;
      Laddr:Halfword;
      Lin1,Lin2,Pag:Integer;
      Save_entry1:Debugentry;
      Depth  :  integer;
     BEGIN
      Save_entry1:=Entry1;
      CHCNT:=0;
      depth := pos_in_stack;
      FIRSTBASIS(Left);
      Laddr:=Call_Address;                 
      IF s_dump_limit <= depth
        THEN
          LOOP
           Lineinterval(Laddr,Lin1,Lin2,Pag,Entry1);
           TREEPNT:=IDTREE;
           IF (TREEPNT # NIL)
            Then
             Begin
               IF BASIS=NULLPTR
               THEN
               WRITE(outfile,'  MAIN')
               ELSE
                Begin;
                 IF TREEPNT^.NEXT^.KLASS = FUNC
                   THEN WRITE(outfile,'FUNCTION ')
                   ELSE WRITE(outfile,'PROCEDURE ');
                 Write(outfile,Treepnt^.Next^.Name:Strlen(Treepnt^.Next^.Name));
                End;
               Write(outfile,' In module ',Entry1.modname);
               Newline(outfile);
               SECTION_OUT(outfile,TREEPNT,[SCALAR,SUBRANGE,POINTER]);
               Newline(outfile);
               SECTION_OUT(outfile,TREEPNT,[POWER,ARRAYS,RECORDS]);
             End
             Else
               WRITE(outfile,' THERE IS NO INFORMATION ABOUT THIS PART OF THE PROGRAMM ( LOCAL D- ??)');         
           Newline(outfile);
          EXIT IF (BASIS=NULLPTR) or (s_dump_limit = depth);
           Laddr:=Ord(Acrpoint(Basis^[0]-1,right));
           SUCCBASIS(Left);
           depth := depth - 1;
          END; (* LOOP *) 
       Entry1:=Save_Entry1;
       Writeln(outfile);
     END (* ALL_VAR_OUT *);
 
     PROCEDURE Heap_out;

       LABEL
         1;

       TYPE
         alloc_head = Packed record
                        var_type : STP;
                        next     : ^alloc_head;
                      END;

       VAR
         rec  :  Packed record
                   Case integer of
                     1:(int  :  integer);
                     2:(  d  :  halfword;
                        ptr  :  ^alloc_head);
                 End;
         heap_bttm : integer;
         prev_rec  : integer;
       BEGIN
         mark (heap_bttm);
         rec.int := heap_bttm;
         prev_rec := 0;
         While  rec.ptr # nil do
           Begin
             If (ord (rec.ptr) < heap_bttm) or
                (ord (rec.ptr) < prev_rec)
               Then
                 Goto 1 
               Else
                 If (ord( rec.ptr^.var_type) < ord (nil)) or
                    (ord( rec.ptr^.var_type) >= ord (entry2.stackbottom))
                  Then
1:                  Begin
                      newline(ttyoutput);
                      newline(ttyoutput);
                      write (tty, 'Heap chain shattered.  Abandoning HEAP DUMP.');
                      rec.ptr := nil;
                    End 
                  Else
                    Begin
                      newline(ttyoutput);
                      write (tty, ord (rec.ptr) + 1:6:O, 'B^=');
                      If rec.ptr^.var_type = nil
                        Then 
                          Begin
                            newline(ttyoutput);
                            write (tty,'Type of variable no known.');
                          End 
                        Else
                          Begin
                            With gattr do
                              Begin
                                NL := true;
                                typtr := rec.ptr^.var_type;
                                kind := varbl;
                                packfg := false;
                                gaddr := ord (rec.ptr) + 1;
                                gbitcount := 0;
                              End;
                            writestructure (ttyoutput,rec.ptr^.var_type);
                          End; (* type pointer ok *)
                      prev_rec := ord (rec.ptr); 
                      rec.ptr := rec.ptr^.next;
                    End; (* rec ok *)
           End; (* While *)
       End; (* Heap_out *)

procedure help;
  begin
  command([termsy]);
  if sy = termsy
      then begin
  writeln(tty,'> The following terms are used in the command summary:');
  writeln(tty,'>');
  writeln(tty,'>  depth: number as shown in TRACE.');
  writeln(tty,'>  depth-cutoff: don''t show anything for depth numbers less than');
  writeln(tty,'>	    this.  See TRACE for depth numbers. If omitted, show all.');
  writeln(tty,'>  file-name: any file name, must be in ''''.  If omitted, use terminal.');
  writeln(tty,'>  line-no:  123/45 - line 123 on page 45');
  writeln(tty,'>            123    - line 123 on current page');
  writeln(tty,'>	    *      - current page and line');
  writeln(tty,'>                (use * = to see what current line/page is)');
  writeln(tty,'>  module-name: as shown in TRACE.  Usually name of the .REL file');
  writeln(tty,'>  repeat: number of occurences to find with single command');
  writeln(tty,'>  string: piece of text to look for, in quotes.  If omitted,');
  writeln(tty,'>	Previous string is reused.');
  writeln(tty,'>  value: any constant or pascal variable.');
  writeln(tty,'>  var: any legal pascal variable. Allows subscripts and dots');
  writeln(tty,'>  depth: number as shown in TRACE.');
      end
    else begin
  writeln(tty,'> The following commands are implemented: [] means optional');
  writeln(tty,'>');
  writeln(tty,'>	END			end debugging - continue the program');
  writeln(tty,'>	FIND [repeat] [''string''] find string in source file');
  writeln(tty,'>	HELP [TERMS]		TERMS for defn''s of terms');
  writeln(tty,'>	STOP line-no		puts break point at that line');
  writeln(tty,'>	STOP NOT line-no	remove a specific break');
  writeln(tty,'>	STOP NOT ALL		remove all break points');
  writeln(tty,'>	STOP LIST		list all break points');
  writeln(tty,'>	TRACE [depth-cutoff]	show active procedures');
  writeln(tty,'>	TYPE line-no [line-no]	show lines from source file');
  writeln(tty,'>	var = [O | H]		show value of variable (octal or hex)');
  writeln(tty,'>	var := value		set variable');
  writeln(tty,'>	STACKDUMP [depth-cutoff] [file-name]  show all var''s - to file');
(* 22 - show command *)
  writeln(tty,'>	SHOW number		set number of lines to show at breaks');
(* 22 - quit command *)	
  writeln(tty,'>	QUIT			exit, closing open files');
  writeln(tty,'>    Single stepping mode - recognized by the "S>" prompt');
  writeln(tty,'>	STEP		enter step mode and do one line');
  writeln(tty,'>	<cr>		execute next line');
  writeln(tty,'>	<esc>		continue pgm until it exits current proc');
  writeln(tty,'>	END		leave step mode and continue program');
  writeln(tty,'>      [Other commands are still legal in step mode]');
  writeln(tty,'>    Don''t worry if you don''t understand this one:');
  writeln(tty,'>	OPEN [depth] [module-name]  set context');
      end
  end;

   BEGIN
    (* *** DEBUG *** *)
(* 4 - be sure we don't affect NEW alloc *)
(* 8 - get rid of NEW *)
    INIT;
    LADDR := ENTRY2.STATUS.RETURNADDR;
     CASE ENTRY2.STATUS.KIND  OF
(* 7 - multiple modules *)
      INITK:  begin  
	      makeluuos;  {Replace jump and skipa with LUUO's}
	      stepmode := false;
	      lineinterval(laddr,i,stline,stpage,entry1);
	      laddr := 0; entry2.status.returnaddr := 0;
	      WRITELN(TTY, '> Stop at main BEGIN - module ',
			        entry1.modname:strlen(entry1.modname),
				' open at ',stline:0,'/',stpage:0) ;
	      opensource(source,entry1);
	      showcontext(stpage,stline)
	      end;
      STOPK:
	     BEGIN
	      FOR I := STOPMAX DOWNTO 0 DO
	       IF  ORD ( STOPTABLE[I].THISADDR ) = LADDR
	       THEN GOTO 1;
1:
	      WRITELN(TTY);
	       IF I > 0
	       THEN WITH STOPTABLE[I] DO
(* 7 - multiple modules *)
		begin
		entry1:=modentry;
		checksource(source,entry1);
		curent := entry1.nextdeb;
		WRITELN(TTY,'> Stop at ', entry1.modname:strlen(entry1.modname), ':',
			    THISLINE:LENGTH(THISLINE), '/', PAGE:LENGTH(PAGE));
		showcontext(page,thisline)
		end
	       ELSE STOPMESSAGE(LADDR)
	     END;
      DDTK:
	    BEGIN
	     WRITELN(TTY, '> Stop by DDT command');
	     STOPMESSAGE(LADDR)
	    END;
      RUNTMERRK:
		 BEGIN
		  WRITELN(TTY);
		  WRITELN(TTY,'> Stop by runtime error');
		  STOPMESSAGE(LADDR)
		 END
     END %CASE\;
    BUFFLNG := 0;
    WHILE NOT EOLN(TTY) DO
     BEGIN
      BUFFLNG := BUFFLNG + 1;
      %READ ( TTY, BUFFER[BUFFLNG] )\ BUFFER[BUFFLNG] := TTY^; GET(TTY)
     END;
(* 20 - save EOLN info *)
    OLDEOLN := TTY^;
(* 22 - prevent HELP END from proceeding *)
    PROCEED := FALSE;  {proceed is set by END and STEP - exits this loop}
     REPEAT
      IF STEPMODE
	THEN WRITE(TTY,'S> ')
	ELSE WRITE(TTY,'>> '); 
      READLN(TTY);
      CHCNT := 1;  {0 would be for prompt '> ', so '>> ' needs 1}
      IF EOLN(TTY)
       THEN CH := ' '
        ELSE BEGIN
	READ(TTY,CH);
	IF ORD(CH) >= 140B THEN CH := CHR(ORD(CH)-40B);
	END;
      INSYMBOL;
      COMMAND([typesy,quitsy,showsy,findsy,stopsy,tracesy,endsy,stepsy,
		opensy,helpsy,stackdumpsy]);
       CASE SY OF
	typesy: begin
		insymbol;
	        IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		  then goto 2;
		typeout 
		end;
(* 22 - quit *)
	quitsy: begin 
		insymbol;
		IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		  then goto 2;
		if endOK
		  then quit
		end;
(* 22 - show *)
	showsy: begin
		insymbol;
		IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		  then goto 2;
		if sy = intconst
		  then begin
		  insymbol;
		  if endok
		    then showlines := val.ival
		  end
		 else begin error; writeln(tty,'Number expected') end
		end;
	findsy: 
		begin
		insymbol;
		IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		  then goto 2;
		findout
		end;
	star:   begin
		insymbol;
		if sy <> eqsy
		  then begin error; writeln(tty,'> Unrecognized command') end
		  else writeln(tty,'> ',dotline:0,'/',dotpage:0)
		end;
	STOPSY:
		BEGIN
		 INSYMBOL;
		 IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		   then goto 2;
		 BREAKPOINT
		END;
        TRACESY:Begin
	      depth_limit := 0;
              insymbol;
	      IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		then goto 2;
	      IF sy = intconst
                THEN
                  BEGIN
		    depth_limit := val.ival;
                    insymbol;
                  END;
	      if endok
                then TRACEOUT(ttyoutput,depth_limit);
              Writeln(tty);
              End;
	AMBIG:	begin
		insymbol;
		if sy in [lbrack,arrow,period,eqsy,becomes]
		  then goto 2;
		error;
		writeln(tty,'Ambiguous abbreviation')
		end;
	IDENT:
		       BEGIN
			INSYMBOL;
2:
			 IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
			 THEN
			   BEGIN
			    NULLPTR := ACRPOINT(0,RIGHT);
			    VARIABLE;
			     CASE SY OF
			      EQSY: BEGIN
(* 25 - Hex and Octal printout *)
				    printradix := decimal;
				    insymbol;
				    if sy = ident
					then if id = 'H         '
					    then begin
						 printradix := hex;
					         insymbol
						 end
					    else if id = 'O         '
						then begin
					             printradix := octal;
					             insymbol
						     end;
				    if endok
				    then WITH GATTR DO
				    IF TYPTR # NIL
				    THEN
				      BEGIN
				       WRITE(TTY,'> ');
				       CHCNT := 0; LEFTSPACE := 0;  NL := FALSE;
					IF KIND = CST
(* 26 - print constants of all types *)
					THEN if typtr^.form = arrays
					      then begin
					       write(ttyoutput,cval.valp^.sval:cval.valp^.slgth);
					       chcnt := chcnt+cval.valp^.slgth
					       end
					      else WRITESCALAR(ttyoutput,CVAL.IVAL,TYPTR)
					ELSE WRITESTRUCTURE(ttyoutput, TYPTR );
				       WRITELN(TTY)
				      END;
(* 25 - Hex and Octal printout *)
				    printradix := decimal
				    end;
			      BECOMES:
				       BEGIN
					INSYMBOL; ASSIGNMENT
				       END;
			      OTHERS:
				      BEGIN
				       ERROR; WRITELN(tty, '"=" or ":=" expected')
				      END
			     END
			   END
			 ELSE begin
			   error;
			   WRITELN(tty,'Unrecognized command - Type HELP for help.')
			   end
		       END;
	ENDSY: begin
	       insymbol;
(* 26 - make E= work *)
	       IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		  then goto 2;
	       if endOK
		 then begin
	         stepmode := false;
	         pointercv.addr := 41B;  {Make the LUUO's noop's}
	         pointercv.valu^ := 300000000000B; {CAI - a no-op}
(* 22 - prevent HELP END from proceeding *)
	         proceed := true;
		 end
	       end;
        STEPSY:begin
	       insymbol;
	       IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		 then goto 2;
	       if endOK
		 then begin
	         stepmode := true;
	         pointercv.addr := 41B;  {Make it be a break}
	         pointercv.valu^ := entry2.stoppy;
(* 22 - prevent HELP END from proceeding *)
	         proceed := true;
		 end
	       end;
        EOLSY: if stepmode
		 then begin  {This is a step command in STEP mode}
(* 22 *)
		 proceed := true;
		 pointercv.addr := 41B;
		 if tty^ = chr(33B)  {if altmode, continue until exit this routine}
		   then begin
		   writeln(tty);
		     {Save AC(16) for comparison of level}
		   entry2.compbasis := accus^[0+16B];
		     {Set up special LUUO handler that compares levels}
		   pointercv.valu^ := entry2.chklevcall;
		   end
		 else pointercv.valu^ := entry2.stoppy; {normal break}
	         end;
	opensy: 
		begin
		insymbol;
		IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		  then goto 2;
		setmod
		end;
(* 13 - Add stack dump *)
	helpsy: 
		begin
		insymbol;
		IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		  then goto 2;
		help
		end;
        stackdumpsy:
            Begin 
              For I:=1 to strglgth do string^.sval[I]:=Blank;
              insymbol;
	      IF SY IN [LBRACK,ARROW,PERIOD, EQSY,BECOMES]
		then goto 2;
	      depth_limit := 0;
              IF sy = intconst
                THEN
                  BEGIN
                    depth_limit := val.ival;
                    insymbol;
                  END;
	      if (sy = stringconst) or (sy = charconst)
		then insymbol;
	      if endOK
	      then begin
              All_Blank:=True;
              For I:=1 to strglgth do
                All_Blank:=All_blank and (string^.sval[I] = Blank);
              If All_Blank
               Then
                Begin
                  Traceout(ttyoutput,depth_limit);
		  Newline(ttyoutput);
		  Stack_Out(ttyoutput,depth_limit);
                End
	       Else
		Begin
                Rewrite(Dump_File,string^.sval);
                If Not(Eof(Dump_file))
                 Then
                  Begin
                    Error;
                    Analys(Dump_file);
                  End 
                 Else
                  Begin
                    Traceout(Dump_file,depth_limit);
                    Newline(Dump_file);
                    Stack_out(Dump_file,depth_limit);
                  End;
		Close(Dump_file)
		end
		End
            End;
	OTHERS: WRITELN(tty,'> No such command.  Type HELP for help');
       END %CASE\
(* 22 - prevent HELP END from proceeding *)
     UNTIL PROCEED;
     IF (ENTRY2.STATUS.KIND = RUNTMERRK) AND NOT TOPS10
       THEN WRITELN(tty,'> WARNING: Continuing after an error -- Do not trust results!');
     IF (ENTRY2.STATUS.KIND = RUNTMERRK) AND TOPS10
     THEN WRITELN(tty,'> Cannot continue')
     ELSE
       BEGIN
(* 20 - be sure he gets the same EOLN as was there at the start *)
	 if not tops10 
	   then  {for tops-20, nothing needs to be done}
	 else IF (BUFFLNG = 0) AND ((TTY^ = CHR(15B)) OR (OLDEOLN <> CHR(15B)))
	   THEN BEGIN  {We at least as many char's as we can}
	   IF (OLDEOLN <> CHR(15B)) AND (TTY^ = CHR(15B))
   	     THEN GET(TTY);  {We have 2 char's (CRLF) - need one only}
	   TTY^ := OLDEOLN   {restore EOLN to saved one}
	   END
	  ELSE BEGIN
	    WRITE  (TTY, '> Input deleted: ');
	    FOR I := 1 TO BUFFLNG DO
	      IF ORD(BUFFER[I]) < 40B
		THEN WRITE(TTY,'^',CHR(ORD(BUFFER[I])+100B))
		ELSE WRITE(TTY,BUFFER[I]);
	    CASE ORD(OLDEOLN) OF
	      12B: WRITELN(TTY,'<LF>');
	      15B: WRITELN(TTY,'<CR>');
	      33B: WRITELN(TTY,'<ESC>');
	      OTHERS: WRITELN(TTY,'^',CHR(ORD(OLDEOLN)+100B));
	      END;
	    WRITE  (TTY, '> Type it again: ');
	    READLN(TTY)
	   END;
       END;
(* 4 - be sure we don't affect NEW alloc *)
(* 8 - get rid of NEW *)
   END %DEBUG\.

