%$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 ""') 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 . ...')\; 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,'> execute next line'); writeln(tty,'> 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,''); 15B: WRITELN(TTY,''); 33B: WRITELN(TTY,''); 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\.