{$Y-,W-} program basref; (* BASREF: A Pascal cross reference generator using a binary tree. Adapted from "Algorithms + Data Structures = Programs", by Niklaus Wirth (pp. 206-210). BASREF produces a cross reference listing of BASIC 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. RT-11 usage RUN DEV:BASREF -option source dest where option = L (list source + xref) or X (list only xref, default); source = source ascii file; dest = output list file. Version 1.5 - 14 Mar 84 Keith Buckley (from B.Heidebrecht's PASREF) *) const charsperword = 12; {length of words} numbsperline = 10; {numbers per line} digitspernum = 6; {digits per number} nl = chr(10); ff = chr(12); nul = chr(0); version = '1.5'; type alfa = array [1..charsperword] of char; string =array [1..20] 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, paren,getnextchar : boolean; ch: char; lst, infile: text; da,ti:string; function length(src:string):integer; external; procedure date(var dat:string); external; procedure time(var tim:string); external; procedure rerun; external; 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 if not eof(infile) then begin read(infile,ncl); if ncl=0 then done := true else if printsource then begin write(lst, nl, ncl:digitspernum, ' '); if ch = ff then write(lst, ff) end end end {NEXTLINE}; procedure nextchar; {get next input character} begin if not eof(infile) then 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 begin write(lst,ch); if eoln(infile) then write(lst,chr(13)) end; if (ch >= 'a') and (ch <= 'z') then ch := chr(ord(ch)-32) {convert to upper case} end 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='(') or(ch='%') or (ch='$') or (ch='#') then specialchar := false end {SPECIALCHAR}; function reservedword (length: integer): boolean; {determine if word is a BASIC reserved word} const rwrange = 263; 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','O','N','T','O','A','S','P','I','G','O','F','N', 'E','N','D','F','O','R','D','I','M','L','E','T','R','E','M','D','E','F', 'L','E','N','(','S','T','E','P','S','Q','R','(','T','A','B','(', 'P','O','S','(','A','B','S','(','A','T','N','(','C','O','S','(', 'E','X','P','(','I','N','T','(','S','Y','S','(', 'L','O','G','(','R','N','D','(','S','G','N','(','S','I','N','(', 'A','S','C','(','B','I','N','(','O','C','T','(','V','A','L','(', 'D','A','T','A','T','H','E','N','N','E','X','T','K','I','L','L', 'N','A','M','E','O','P','E','N','F','I','L','E','L','I','N','E', 'R','E','A','D','S','T','O','P','C','L','K','$','D','A','T','$','C','H','R','$','(', 'S','E','G','$','(','S','T','R','$','(','T','R','M','$','(', 'C','H','A','I','N','C','L','O','S','E','G','O','S','U','B', 'U','S','I','N','G','R','E','S','E','T', 'I','N','P','U','T','P','R','I','N','T', 'C','O','M','M','O','N', 'L','I','N','P','U','T','R','E','T','U','R','N','O','U','T','P','U','T', 'L','O','G','1','0','(', 'O','V','E','R','L','A','Y','R','E','S','T','O','R','E', 'R','A','N','D','O','M','I','Z','E'); {length = 0,1,2, 3, 4, 5, 6, 7, 8, 9, 10,11,12} startrsw = rwindex (0,0,0, 14,32,156,211,241,255,255,264); numberrsw = lntable (0,0,7, 6, 31,11, 5, 2, 0, 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 initfiles; {initialize files} var i: integer; ch: char; begin {initfiles} printsource := false; { X default } if argc<>4 then begin writeln('BASREF (Version ',version,')'); writeln('Default input ext .BAS, output ext .CRF'); writeln; writeln('For cross reference only -[x] source dest'); writeln('For listing with xref -L source dest'); writeln; rerun end; 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; i := i + 1 end {loop} end; reset(infile, argv[2]@,"BAS"); rewrite(lst, argv[3]@,"CRF",2) end {INITFILES}; begin {main program} initfiles; date(da); time(ti); writeln(lst,'BASREF (Version ',version,') -- ',argv[2]@:length(argv[2]@),' --',da:10,ti:11); done := false; root := nil; nextline; getnextchar := true; repeat if getnextchar then nextchar; getnextchar := true; if (((ch>='A') and (ch<='Z')) or ((ch>='#') and (ch<='%'))) then begin k := 0; nsave := ncl; idx := blanks; paren:=false; repeat if k < charsperword then {save character} begin k := k+1; idx[k] := ch end; nextchar; if ch='(' then begin k:=k+1; idx[k]:= ch; paren:=true end; until endofline or paren or done or specialchar; if not reservedword(k) then search(root) end; {check for quote or comment} if (idx='REM ') or (idx='DATA ') then begin idx := blanks; repeat nextchar until endofline end; if ch = '''' then skip1('''') else if ch = '"' then skip1('"') else if ch = '[' then skip1(']') until done; if printsource then writeln(lst,nl,ff) ; printtree(root); writeln(lst,ff); writeln(output,'end BASREF') end.