[net.sources] pascref.p

grunwald@uiucdcsb.UUCP (01/23/85)

(*$b9	-- block buffering *)
program pascref(input, output);
 
(* pascref - cross reference pascal programs.                        *)
(*                                                                   *)
(* original program (named xref).                                    *)
(*    - n. wirth 71/01/15, 74/05/07, 75/07/02, 76/02/10.             *)
(*      (see chapter 4 in "algorithms + data structures = programs") *)
(* use better sort, case statement in scanner, procedure map,        *)
(* control statement processing.                                     *)
(*    - a. mickel 75/12/08.                                          *)
(* use ring structure for references.                                *)
(*    - r. cichelli 76/11/14.                                        *)
(* process line numbers.                                             *)
(*    - d. laliberte 78/03/15.                                       *)
(* process compiler titles, different print densities,               *)
(* use value part, sort correctly, add nesting levels.               *)
(*   - j. strait 78/12/28.                                           *)
(* fix nesting-level indicators, handle percent in 64-char set.      *)
(*   - j.f. miner 1982-01-06                                         *)
(* Port pascref to the UCB UNIX enviornment. Removed the pagination  *)
(* routines. added new options (tab size), made it be able to deal   *)
(* with tabs (cntrl-i) as far as knowing how wide a page is	     *)
(*   - d. c. grunwald sometime in late '82			     *)
(* Extended port to UNIX:					     *)
(*	get file names from command line or use stdin		     *)
(*	handle path pascal keywords				     *)
(*	avoid duplicating line references if the last reference is   *)
(*	  to the same line					     *)
(*	allow people to pascref large files which have been split    *)
(*	up for editing and still make sense of error messages from   *)
(*	compilers (added: filename, fileline, filehead, etc)	     *)
(*   - d. c. grunwald 3/5/83					     *)
(*                                                                   *)
 
const
    p = 32749;			(*size of hash table*)
    nk = 43;			(*no. of keywords*)
    kln = 15;			(*keylength*)
    llinmax = 120;		(*maximum input line length*)
    lloutmax = 132;		(*maximum output line length*)
    maxn = 100000;		(*max no. of lines*)
    dgpn = 6;			(*no. of digits per number*)
    stars = ' *****';
    tab = '	';
    deftab = 8;	(* default number of columns a tab is worth	*)

    fnamesize = 20;	(* maximum name of a file passed via command line *)
    dispfnsize = 15;	(* part of the filename that we display *)
    eject = 12;		(* form feed or newpage to do a page eject *)


type
    index = 0..p;
    alfa = packed array [1..kln] of char;
    ref = ^ item;
    word = 
	record 
	    key: alfa;
	    last: ref
	end;
    item = packed 
	record 
	    lno: 0..maxn;
	    next: ref
	end;
    nestkind = (nestbegin, nestopen, nestclose, nestclear, nestnull);
    procref = ^ proc;		(*procedure or function reference*)
    proc = packed 
	record 
	    name: alfa;
	    lno: 0..maxn;
	    next: procref
	end;
    filepnt = ^filetype;
    filetype = record
	name	: array[1..fnamesize] of char;
	length	: integer;
	starting: integer;	(* starting/end lines for this file	*)
	ending	: integer;
	next	: filepnt;
	end;

 
var
    i,j: index;
    k: integer;
    c00: char;
    ln: integer;		(*current line number*)
    llout: integer;		(*line length for output*)
    llin: integer;		(*line length for input*)
    ccount: integer;		(*character count in line*)
    nopl: integer;		(*no. of line-numbers per line*)
    empty: alfa;
    id: alfa;
    t: array [index] of word;	(*hash table*)
    keyindex: 0..nk;
    key: array [0..nk] of 
	record 
	    k: alfa;
	    nestchange: nestkind
	end;
    inbody: boolean;
    nesting, nestingatbol: 0..maxint;
    nestcount: 0..llinmax;	(* highest element of nest being used *)
    nest: array [1..llinmax] of nestbegin..nestclear;
    procorfunc, paginating  : boolean;
    firstproc, procptr: procref; (*pointers to chain of procedures*)

(*	added for UCB port					*)
    tabinc: integer;		(* specifies how many chars a tab is	*)

    filehead 	: filepnt;
    fpnt	: filepnt;
    multifile	: boolean;	(* is there more than stdin to process? *)
    filename	: array[1..dispfnsize] of char; (* name to display for file *)
    fileline	: integer;	(* line number for the current file	*)
 
    procedure dovalue;

    var
	i: integer;
	pnt: integer;

	procedure add(s: alfa; n: nestkind);
	var
	    i: integer;
	begin
	    for i := 1 to kln do 
		if s[i] = ' ' then 
		    key[pnt].k[i] := c00
		else 
		    key[pnt].k[i] := s[i];
	    key[pnt].nestchange := n;
	    pnt := pnt + 1
	end; (* add *)

    begin (* dovalue *)
	c00 := chr(0);
	for i := 1 to kln do 
	    empty[i] := c00;
	for i := 1 to p do begin
	    t[i].key := empty;
	    t[i].last := nil
	end (* for *);
	pnt := 0;	(* start adding items to the 'key' array	*)
	add(empty, nestnull);
	add('and            ', nestnull);
	add('array          ', nestnull);
	add('begin          ', nestbegin);
	add('boolean        ', nestnull);
	add('case           ', nestopen);
	add('char           ', nestnull);
	add('const          ', nestnull);
	add('div            ', nestnull);
	add('do             ', nestnull);
	add('downto         ', nestnull);
	add('else           ', nestnull);
	add('end            ', nestclose);
	add('entry          ', nestnull);
	add('false          ', nestnull);
	add('file           ', nestnull);
	add('for            ', nestnull);
	add('function       ', nestclear);
	add('if             ', nestnull);
	add('in             ', nestnull);
	add('integer        ', nestnull);
	add('mod            ', nestnull);
	add('nil            ', nestnull);
	add('not            ', nestnull);
	add('object         ', nestnull);
	add('of             ', nestnull);
	add('or             ', nestnull);
	add('packed         ', nestnull);
	add('path           ', nestbegin);
	add('procedure      ', nestclear);
	add('process        ', nestclear);
	add('program        ', nestclear);
	add('real           ', nestnull);
	add('record         ', nestnull);
	add('repeat         ', nestopen);
	add('set            ', nestnull);
	add('then           ', nestnull);
	add('to             ', nestnull);
	add('true           ', nestnull);
	add('type           ', nestnull);
	add('until          ', nestclose);
	add('var            ', nestnull);
	add('while          ', nestnull);
	add('with           ', nestnull);

	llin := llinmax;
	llout := lloutmax;
	procorfunc := true;
	nesting := 0;
	inbody := false;
	ccount := 0;
	ln := 0
    end; (* procedure dovalue *)
 
    procedure classify;
    var
	i, j, k: integer;
    begin
	i := 1;
	j := nk;				(*binary search*)
	keyindex := 0;
	repeat
	    k := (i + j) div 2;
	    if key[k].k <= id then 
		i := k + 1
	    else 
		j := k - 1
	until i > j;
	if key[j].k = id then 
	    keyindex := j
    end; (*classify*)
 
    procedure advance;

    var
	t : integer;

	function tabcount: integer;
	(*	tabcount figures out how many spaces to add for the tab	*)
	(* 	character assuming tabstops every tabinc spots and	*)
	(*	that ccount contains the current column count		*)
	begin
	    if ccount = 0 then 
		tabcount := tabinc		(* avoid division by zero *)
	    else 
		tabcount := tabinc - ccount mod tabinc
	end; (* tabcount *)

    begin
	if not eoln then begin
	    if input^ = tab then begin	(* compensate for tab characters  *)
		t := tabcount;
		if t > 0 then write(' ':t);
		ccount := ccount + t
	    end else begin
		ccount := ccount + 1;
		write(input^)
	    end;
	    get(input);
	    if ccount >= llin then 
		while not eoln(input) do begin
		    if input^ = tab then begin
			t := tabcount;
			if t > 0 then write(' ':t);
			ccount := ccount + tabcount
		    end else begin
			ccount := ccount + 1;
			write(input^)
		    end;
		    get(input)
		end (* while *)
	end
    end; (*advance*)
 
    procedure newline;
 
    begin
	ccount := 0;
	nestcount := 0;
	nestingatbol := nesting;
	if ln < maxn then begin
	    ln := ln + 1;
	    fileline := fileline + 1;

(*	removed the code to manage the compiler title as well as code	*)
(*	concerned with pagination (this would be done by lpr handler)	*)

	    write(ln: 6, ' ')
	end else begin
	    writeln(stars, ' text too long', stars);
	    halt;
	end
    end; (*newline*)
 
    procedure search;				(*modulo p hash search*)
    var
	h, d: integer;
	x, y: ref;
	f: boolean;
    begin
	h := 0;
	for i := 1 to kln do
	    h := (h + ord(id[i]))*2;
	h := abs(h) mod p;
	f := false;
	d := 1;
	repeat
	    if t[h].key = id then begin (*found*)
		f := true;
		y := t[h].last;
		if ( y^.lno <> ln) then begin
		    new(x);
		    x^.lno := ln;
		    x^.next := y^.next;
		    y^.next := x;
		    t[h].last := x
		    end
	    end else if t[h].key = empty then begin (*new entry*)
		new(x);
		x^.lno := ln;
		f := true;
		t[h].key := id;
		t[h].last := x;
		x^.next := x
	    end else begin (*collision*)
		h := h + d;
		d := d + 2;
		if h >= p then 
		    h := h - p;
		if d = p then begin
		    writeln;
		    writeln(stars, ' table full', stars);
		    halt;
		end
	    end
	until f
    end; (*search*)
 
    procedure sort(min, max: integer);
 
(* quicksort with bounded recursion depth *)
(* requires min <= max *)
 
    var
	low, high: integer;
	midkey: alfa;
	temp: word;
 
    begin
	repeat (*pick split point*)
	    midkey := t[(min + max) div 2].key;
	    low := min;
	    high := max;
	    repeat (*partition*)
		while t[low].key < midkey do 
		    low := low + 1;
		while t[high].key > midkey do 
		    high := high - 1;
		if low <= high then begin
		    temp := t[low];
		    t[low] := t[high];
		    t[high] := temp;
		    low := low + 1;
		    high := high - 1
		end
	    until low > high;
 
	    (*recursively sort shorter sub-segment*)
	    if high - min < max - low then begin
		if min < high then 
		    sort(min, high);
		min := low
	    end else begin
		if low < max then 
		    sort(low, max);
		max := high
	    end
	until max <= min
    end; (*sort*)
 
 
    procedure noteproc;		(*note instance of procedure or function*)
    var
	p: procref;
    begin
	procorfunc := false;
	new(p);
	procptr^.next := p;
	p^.name := id;
	p^.lno := ln;
	p^.next := nil;
	procptr := p
    end; (*noteproc*)
 
    procedure printword(w: word);
    var
	l: integer;
	x, y: ref;
	k: alfa;
    begin
	k := w.key;
	l := kln;
	while k[l] = c00 do begin
	    k[l] := ' ';
	    l := l - 1
	end;
	write(' ', k);
	x := w.last^.next;
	y := x;
	l := 0;
	repeat
	    if l = nopl then begin
		l := 0;
		writeln;
		write(' ': kln + 1)
	    end;
	    l := l + 1;
	    write(x^.lno: dgpn);
	    x := x^.next
	until x = y;
	writeln
    end; (*printword*)
 
    procedure printtable;
    var
	i, m: integer;
    begin
	m := 0;					(*compress table*)
	for i := 0 to p - 1 do 
	    if t[i].key <> empty then begin
		t[m] := t[i];
		m := m + 1
	    end;
	if m > 0 then 
	    sort(0, m - 1);
	nopl := (llout - kln - 1) div dgpn;
	writeln(' cross reference of identifiers,',
		' label declarations and goto statements:');
	writeln;
	for i := 0 to m - 1 do 
	    printword(t[i])
    end; (*printtable*)
 
    procedure printprocs;
    var
	n: alfa;
	l: integer;
    begin
	writeln; writeln;
	writeln(' list of procedures and functions:');
	writeln;
	procptr := firstproc^.next;
	while procptr <> nil do 
	    with procptr^ do begin
		n := name;
		l := kln;
		while n[l] = c00 do begin
		    n[l] := ' ';
		    l := l - 1
		end;
		writeln(n: 24, lno: 10);
		procptr := next
	    end
    end; (*printprocs*)

    procedure printfiles(f : filepnt);
    begin
	writeln('File':dispfnsize+5,'Goes from line':20,'To Line':20);
	writeln;
	while( f <> nil ) do begin
	    writeln(f^.name:dispfnsize+5,f^.starting:20,f^.ending:20);
	    f := f^.next;
	    end;
    end (* procedure printfiles *);

    procedure initialize;
    var
	optstr: array [1..fnamesize] of char;
	i: integer;
	p : filepnt;
	files : integer;
 
    begin

(*	check for options passed from the command line			*)

	paginating := true;
	tabinc := deftab;
	multifile := false;
	filehead := nil;
	p := nil;
	files := 0;

	for i := 1 to argc - 1 do begin
	    argv(i, optstr);			(* get the next arg *)
	    if (optstr[1] = '-') then begin
		if (optstr[2] = 't') then
		    tabinc := ord( optstr[3] ) - ord('0')
		else if (optstr[2] = 'e') then
		    paginating := false
		end
	    else begin (* must be a file name, right? *)
		files := files + 1;
		if ( p = nil ) then begin (* first file name? *)
		    new(p);
		    filehead := p;
		    end
		else begin
		    new(p^.next);
		    p := p^.next;
		    end;
		with p^ do begin
		    name := optstr;	(* save the file name for reset *)
		    next := nil;
		    length := fnamesize;
		    while( (length > 1) and (optstr[length] = ' ') ) do
			length := length - 1;
		    end;
		end;
	end (* for *);

	if files > 1 then multifile := true;

	new(procptr);
	firstproc := procptr;
	procptr^.next := nil;
    end; (*initialize*)
 
    procedure scanandlistinput;
    var
	i: 1..llinmax;
	nc, nclast: nestkind;
	filelinecount : integer;

    begin
	filelinecount := 1;
	while not eof(input) do begin
	    newline;
	    while not eoln(input) do 
		if input^ in [tab, ' '..'~'] then 
		    case input^ of
			'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', '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
				k := 0;
				id := empty;
				repeat
				    if k < kln then begin
					k := k + 1;
					id[k] := input^
				    end;
				    advance
				until not (input^ in ['a'..'z', 'A'..'Z', '0'..'9']);
				classify;
				if keyindex = 0 then begin
				    search;
				    if procorfunc then 
					noteproc
				end else begin
				    nc := key[keyindex].nestchange;
				    case nc of
					nestbegin:
					    begin
						nesting := nesting + 1;
						inbody := true
					    end;
					nestopen:
					    if inbody then 
						nesting := nesting + 1
					    else 
						nc := nestnull;
					nestclose:
					    if inbody then 
						nesting := nesting - 1
					    else 
						nc := nestnull;
					nestclear:
					    begin
						procorfunc := true;
						inbody := false;
						if nesting = 0 then 
						    nc := nestnull
						else 
						    nesting := 0
					    end;
					nestnull:
					    null
				    end;
				    if nc <> nestnull then begin
					nestcount := nestcount + 1;
					nest[nestcount] := nc
				    end
				end
			    end;
			'0', '1', '2', '3', '4', '5', '6',
			'7', '8', '9':
			    repeat
				advance
			    until not (input^ in ['b', 'e', '0'..'9']);
			'''':
			    begin (*string*)
				repeat
				    advance
				until (input^ = '''') or eoln(input);
				if not eoln(input) then 
				    advance
			    end;
			'{':
			    begin (*comment*)
				repeat
				    advance;
				    while eoln(input) do begin
					writeln;
					get(input);
					newline
				    end
				until input^ = '}';
				advance
			    end;
			'(':
			    begin
				advance;
				if input^ = '*' then begin (*comment*)
				    advance;
				    repeat
					while input^ <> '*' do begin
					    if eoln(input) then begin
						get(input);
						writeln;
						newline
					    end else 
						advance
					end;
					advance
				    until input^ = ')';
				    advance
				end
			    end;
			'+', '-', '*', '/', ')', '$', '=',
			' ', ',', '.', '[', ']', '"', '!',
			'&', '#', '?', '<', '>', '@', '\',
			'^', ';', ':', tab, '%', '_', '`',
			'|', '~':
			    advance
		    end (*case*);
	    if (llout = lloutmax) and (nestcount > 0) then begin
		if ccount >= 100 then 
		    write(' ':2)
		else 
		    write(' ': 100 - ccount);
		nesting := nestingatbol;
		nclast := nestnull;
		if nest[1] = nestclose then 
		    write(' ');
		for i := 1 to nestcount do begin
		    nc := nest[i];
		    case nc of
			nestbegin, nestopen:
			    begin
				nesting := nesting + 1;
				write('[', nesting: 1)
			    end;
			nestclose: begin
			    if nesting = 0 then 
				write('*]')
			    else begin
				if not (nclast in [nestbegin, nestopen]) then 
				    write(nesting: 1);
				write(']');
				nesting := nesting - 1
				end;
			    end;
			nestclear:
			    begin
				write(' * ');
				nesting := 0
			    end
		    end;
		    nclast := nc
		end (* for *);
		writeln;
		filelinecount := filelinecount + 1;
		readln;
		end (* then begin *)

	    else if multifile then begin
		if (filelinecount >= 10) then begin
		    if ccount >= 100 then
			write(' ':2)
		    else
			write(' ': 100 - ccount);
		    write(' ':3);
		    write(' ', fileline:5,' ', filename:dispfnsize);
		    filelinecount := 0;
		    end;
		writeln;
		filelinecount := filelinecount + 1;
		readln;
		end

	    else begin
		writeln;
		filelinecount := filelinecount + 1;
		readln;
	    end (* if *);
	end (* while not eof *)
    end; (*scanandlistinput*)
 
begin (*crossref*)

    dovalue;			(* simulate the value clause *)

    initialize;

    if ( filehead = nil ) then begin 	(* read fron stdin *)
	scanandlistinput;
	if paginating then writeln(chr(eject));
	printtable;
	if paginating then writeln(chr(eject));
	printprocs
	end
    else if (filehead <> nil) then begin (* read from command line files *)
	fpnt := filehead;
	while( fpnt <> nil ) do begin
	    with fpnt^ do begin
		reset(input,name);
		for i := 1 to dispfnsize do filename[i] := ' ';
		if (length <= dispfnsize) then
		    for i := 1 to 10 do filename[i] := name[i]
(*
 *	if the entire filename can not be displayed, display the last
 *	part of it -- this is to allow reasonable renderings of things like
 *	/usr/woof/gronk/test.p
 *)
		else begin
		    i := length; j := dispfnsize;
		    while ( j > 0 ) do begin
			filename[j] := name[i];
			i := i-1; j := j-1;
			end;
		    end;
		end;
	    fileline := 0;
	    fpnt^.starting := ln;
	    scanandlistinput;
	    fpnt^.ending := ln;
	    fpnt := fpnt^.next;
	    if paginating then writeln(chr(eject));
	    end (* while *);

	printtable;
	if paginating then writeln(chr(eject));
	printprocs;
	if paginating then writeln(chr(eject));
	printfiles(filehead);
	end;
end.