$debug$ $ sysprog, partial_eval $ program crefprog(input, output); const { linesperpage = 139; } maxnamelen = 30; type str255 = string[255]; occurptr = ^occur; occur = record next : occurptr; lnum : integer; fnum : integer; defn : boolean; end; kinds = (k_normal, k_proc, k_var, k_const, k_type, k_strlit, k_extproc, k_kw, k_prockw, k_varkw, k_constkw, k_typekw, k_beginkw); nodeptr = ^node; node = record left, right : nodeptr; name : string[maxnamelen]; first : occurptr; kind : kinds; end; var f : text; fn : string[120]; fnum : integer; buf, name : str255; good : boolean; i, j : integer; lnum : integer; np, base : nodeptr; op : occurptr; curkind, section : kinds; paren : integer; brace : integer; procedure lookup(var name : str255; var np : nodeptr); var npp : ^nodeptr; begin if strlen(name) > maxnamelen then setstrlen(name, maxnamelen); npp := addr(base); while (npp^ <> nil) and (npp^^.name <> name) do begin if name < npp^^.name then npp := addr(npp^^.left) else npp := addr(npp^^.right); end; if (npp^ = nil) then begin new(np); npp^ := np; np^.name := name; np^.first := nil; np^.left := nil; np^.right := nil; np^.kind := k_normal; end else np := npp^; end; procedure kw(name : str255; kind : kinds); var np : nodeptr; begin lookup(name, np); np^.kind := kind; end; procedure cref(np : nodeptr; kind : kinds); var op : occurptr; begin new(op); op^.next := np^.first; np^.first := op; op^.lnum := lnum; op^.fnum := fnum; op^.defn := (kind in [k_var, k_type, k_const, k_proc]); if op^.defn or (kind = k_strlit) or ((kind = k_extproc) and (np^.kind = k_normal)) then np^.kind := kind; end; procedure traverse(np : nodeptr); var op : occurptr; i : integer; begin if (np <> nil) then begin traverse(np^.left); if np^.kind < k_kw then begin case np^.kind of k_var: write(f, 'V:'); k_type: write(f, 'T:'); k_const: write(f, 'C:'); k_proc: write(f, 'P:'); k_strlit: write(f, 'S:'); k_extproc: write(f, 'E:'); k_normal: write(f, 'X:'); end; write(f, np^.name); i := 0; op := np^.first; while op <> nil do begin if i = 0 then begin writeln(f); write(f, ' '); i := 5; end; write(f, ' ', op^.lnum:1, '/', op^.fnum:1); if op^.defn then write(f, '*'); i := i - 1; op := op^.next; end; writeln(f); end; traverse(np^.right); end; end; begin base := nil; fnum := 0; kw('procedure', k_prockw); kw('function', k_prockw); kw('var', k_varkw); kw('record', k_varkw); kw('type', k_typekw); kw('const', k_constkw); kw('begin', k_beginkw); kw('end', k_kw); kw('do', k_kw); kw('for', k_kw); kw('to', k_kw); kw('while', k_kw); kw('repeat', k_kw); kw('until', k_kw); kw('if', k_kw); kw('then', k_kw); kw('else', k_kw); kw('case', k_kw); kw('of', k_kw); kw('div', k_kw); kw('mod', k_kw); kw('nil', k_kw); kw('not', k_kw); kw('and', k_kw); kw('or', k_kw); kw('with', k_kw); kw('array', k_kw); kw('integer', k_kw); kw('char', k_kw); kw('boolean', k_kw); kw('true', k_kw); kw('false', k_kw); writeln; writeln('Pascal Cross Reference Utility'); writeln; repeat fnum := fnum + 1; write('Name of cross-reference file #', fnum:1, '? '); readln(fn); good := true; if (fn <> '') then begin try reset(f, fn); recover if escapecode <> -10 then escape(escapecode) else begin good := false; writeln('Can''t read file!'); end; end else good := false; if good then begin lnum := 0; section := k_normal; curkind := k_normal; paren := 0; while not eof(f) do begin lnum := lnum + 1; readln(f, buf); strappend(buf, #0); i := 1; while (buf[i] = ' ') do i := i + 1; repeat while not (buf[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', #0]) do begin case buf[i] of ':', '=': if brace = 0 then curkind := k_normal; ';': if brace = 0 then curkind := section; '''': if brace = 0 then begin i := i + 1; j := i; while ((buf[i] <> '''') or (buf[i+1] = '''')) and (buf[i] <> #0) do begin if (buf[i] = '''') then i := i + 2 else i := i + 1; end; if (buf[i] = #0) then i := i - 1; name := '''' + str(buf, j, i-j) + ''''; lookup(name, np); cref(np, k_strlit); end; '(': if brace = 0 then if (buf[i+1] = '*') then begin brace := 1; i := i + 1; end else begin paren := paren + 1; curkind := k_normal; end; ')': if brace = 0 then paren := paren - 1; '*': if (buf[i+1] = ')') then begin brace := 0; i := i + 1; end; '{': brace := 1; '}': brace := 0; otherwise ; end; i := i + 1; end; if (buf[i] <> #0) then begin j := i; if (buf[i] in ['0'..'9']) and (i > 1) and (buf[i-1] = '-') then j := j - 1; while (buf[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_']) do i := i + 1; if brace = 0 then begin name := str(buf, j, i-j); for j := 1 to strlen(name) do if (buf[j] in ['A'..'Z']) then buf[j] := chr(ord(buf[j]) + 32); while (buf[i] = ' ') do i := i + 1; lookup(name, np); case np^.kind of k_varkw: if paren = 0 then begin section := k_var; curkind := section; end; k_typekw: begin section := k_type; curkind := section; end; k_constkw: begin section := k_const; curkind := section; end; k_prockw: begin section := k_normal; curkind := k_proc; end; k_beginkw: begin section := k_normal; curkind := k_normal; end; k_kw: ; otherwise if (curkind = k_normal) and (buf[i] = '(') then cref(np, k_extproc) else cref(np, curkind); end; end; end; until buf[i] = #0; end; if paren <> 0 then writeln('Warning: ending paren count = ', paren:1); close(f); end; until fn = ''; writeln; repeat write('Output file name: '); readln(fn); until fn <> ''; rewrite(f, fn); traverse(base); close(f, 'save'); end.