{$T-,W-} program pasref; {************************************************* * * * PASREF: * * A Pascal cross reference generator * * using a binary tree. Adapted from * * "Algorithms + Data Structures = Programs", * * by Niklaus Wirth (pp. 206-210). * * * * PASREF produces a cross reference listing of * * Pascal source programs on a destination file. * * Before generating the references, lower case * * letters are mapped into upper case. A source * * file listing with line numbers is optional. * * For very large programs, it may be necessary * * to increase the heap size. A heap size of * * 70000 (octal) bytes should be sufficient for * * programs of about 2000 lines or more. * * * * RSX-11 usage: * * PASREF -option source dest * * where option = L (list source + xref) * * or X (list only xref, default); * * source = source ascii file; * * dest = output list file. * * * * Version 2D - 24 Jan 79 * * Bill Heidebrecht * * TRW Systems * * One Space Park * * Redondo Beach, CA 90278 * * * *************************************************} const charsperword = 12; {length of words} numbsperline = 12; {numbers per line} digitspernum = 6; {digits per number} cr = chr(13); nl = chr(10); ff = chr(12); nul = chr(0); type alfa = array [1..charsperword] of char; wordref = @word; itemref = @item; word = record key: alfa; first, last: itemref; left, right: wordref end; item = record lno: integer; next: itemref end; compare = (lt, eq, gt); const blanks = alfa(' ',' ',' ',' ',' ',' ',' ',' ', ' ',' ',' ',' '); var root: wordref; k: integer; ncl, nsave: integer; {current line number} idx: alfa; endofline, done, printsource, getnextchar, ok: boolean; ch: char; lst, infile: text; function match (w: wordref): compare; {compare two character strings} var i: integer; different: boolean; b: alfa; begin match := eq; different := false; b := w@.key; i := 0; repeat i := i+1; if idx[i] <> b[i] then begin different := true; if idx[i] > b[i] then match := gt else match := lt end; until different or (i>=charsperword) end {MATCH}; procedure search (var w1: wordref); {tree search and insertion} var w: wordref; x: itemref; begin w := w1; if w = nil then begin {insert new identifier into tree} new(w); new(x); with w@ do begin key := idx; left := nil; right := nil; first := x; last := x end; x@.lno := nsave; x@.next := nil; w1 := w end else begin case match(w) of lt: search(w@.left); gt: search(w@.right); eq: begin {add reference to existing list} new(x); x@.lno := nsave; x@.next := nil; w@.last@.next := x; w@.last := x end end {case} end end {SEARCH}; procedure printtree (w2: wordref); {print a tree or subtree} var w: wordref; procedure printword (w1: wordref); {print a word and its references} var l, lineno: integer; x: itemref; wa: word; begin wa := w1@; write(lst,' ',wa.key); x := wa.first; l := 0; repeat if l = numbsperline then begin {start new line} l := 0; writeln(lst); write(lst,' ':13) end; l := l+1; lineno := x@.lno; write(lst,lineno:digitspernum); x := x@.next until x = nil; writeln(lst) end {PRINTWORD}; begin {PRINTTREE} w := w2; if w <> nil then begin printtree(w@.left); printword(w); printtree(w@.right) end end {PRINTTREE}; procedure nextline; {start printing next line} begin ncl := ncl +1; if printsource then begin writeln(lst); write(lst,ncl:digitspernum, ' '); if ch = ff then write(lst, ff) end end {NEXTLINE}; procedure nextchar; {get next input character} begin ch := infile@; get(infile); if eof(infile) then begin done := true; ch := nl end; endofline := (ch = nl) or (ch = ff); if endofline then nextline else begin if printsource then write(lst,ch); if (ch >= 'a') and (ch <= 'z') then ch := chr(ord(ch)-32) {convert to upper case} end end {NEXTCHAR}; function specialchar: boolean; {determine if character is a separator} begin specialchar := false; if (ch<'0') or (ch>'Z') then specialchar := true else if (ch>'9') and (ch<'A') then specialchar := true; if ch='_' then specialchar := false end {SPECIALCHAR}; function reservedword (length: integer): boolean; {determine if word is a PASCAL reserved word} const rwrange = 157; type rword = array [0..rwrange] of char; rwindex = array [0..10] of 0..rwrange; lntable = array [0..charsperword] of integer; const rswords = rword ( 'I','F','D','O','I','N','T','O','O','F','O','R', 'E','N','D','F','O','R','S','E','T','V','A','R','D','I','V', 'M','O','D','A','N','D','N','O','T', 'T','H','E','N','E','L','S','E','C','A','S','E', 'L','O','O','P','E','X','I','T','W','I','T','H', 'T','Y','P','E','F','I','L','E','G','O','T','O', 'B','E','G','I','N','W','H','I','L','E','U','N','T','I','L', 'A','R','R','A','Y','C','O','N','S','T','L','A','B','E','L', 'R','E','P','E','A','T','R','E','C','O','R','D', 'D','O','W','N','T','O','P','A','C','K','E','D', 'F','O','R','W','A','R','D','P','R','O','G','R','A','M', 'F','U','N','C','T','I','O','N', 'P','R','O','C','E','D','U','R','E'); {length = 0,1,2, 3, 4, 5, 6, 7, 8, 9, 10,11,12} startrsw = rwindex (0,0,0,12,36,72,102,126,140,148,157); numberrsw = lntable (0,0,6, 8, 9, 6, 4, 2, 1, 1, 0,0,0); var i, k, m, n: integer; equl: boolean; begin n := numberrsw[length]; if n = 0 then reservedword := false else begin k := startrsw[length]; m := 0; repeat equl := true; m := m+1; for i := 1 to length do begin if idx[i] <> rswords[k] then equl := false; k := k+1 end; until equl or (m = n); reservedword := equl end end {RESERVEDWORD}; procedure skip1 (endchar: char); {scan to end of string or comment} begin repeat nextchar until (ch = endchar) or done end {SKIP1}; procedure skip2; {scan to end of ( *-* ) comment} begin nextchar; repeat while (ch <> '*') and not done do nextchar; if not done then nextchar; until (ch = ')') or done end {SKIP2}; procedure initfiles; {initialize files} var i: integer; ch: char; procedure help; begin if ok then begin writeln(output, '*** Try again:'); writeln(output, ' PASREF -[L,X] source dest'); ok := false end end {help}; begin {initfiles} ok := true; printsource := false; { X default } if argv[1]@[0] = '-' then { get option from command line: } begin i := 1; loop ch := argv[1]@[i]; exit if ch = nul; if (ch='l') or (ch='L') then printsource := true else if (ch='x') or (ch='X') then printsource := false else help; i := i + 1 end {loop} end; if argv[2]@[0] = nul then help else reset(infile, argv[2]@); if argv[3]@[0] = nul then help else rewrite(lst, argv[3]@, 2) end {INITFILES}; begin {main program} initfiles; if ok then begin done := false; root := nil; ncl := 0; nextline; getnextchar := true; repeat if getnextchar then nextchar; getnextchar := true; if (ch>='A') and (ch<='Z') then begin k := 0; nsave := ncl; idx := blanks; repeat if k < charsperword then {save character} begin k := k+1; idx[k] := ch end; nextchar until endofline or done or specialchar; if not reservedword(k) then search(root) end; {check for quote or comment} if ch = '''' then skip1('''') else if ch = '{' then skip1('}') else if ch = '"' then skip1('"') else if ch = '(' then begin nextchar; if ch = '*' then skip2 else getnextchar := false end until done; if printsource then write(lst,cr,ff) ; printtree(root); writeln(lst,' '); writeln(output,'end PASREF') end { if ok } end.