Trailing-Edge
-
PDP-10 Archives
-
decuslib10-07
-
43,50433/debug.pas
There are 4 other files named debug.pas in the archive. Click here to see a list.
%$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)
E ump 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 NG 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');
1)
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 %CAS DR + 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,'Illega 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 %pag )
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
iteln(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\.