#	IPXREF
#
#	Create Icon program cross-reference
#
#	Allan J. Anderson
#
#	Last modified 4/29/86 by Ralph E. Griswold
#

global resword, linenum, letters, digits, var, buffer, qflag, f, fflag, xflag
global inmaxcol, inlmarg, inchunk, localvar, lin

record procrec(pname,begline,lastline)

procedure main(a)
   local word, w2, p, prec, i, L, ln
   initial {
      resword := ["break","by","case","default","do","dynamic","else",
         "end","every","fail","global","if","initial","link",
         "local","next","not","of","procedure",
         "record","repeat","return","static","suspend","then",
         "to","until","while"]
      linenum := 0
      var := table()		# var[variable[proc]] is list of line numbers
      prec := []		# list of procedure records
      localvar := []		# list of local variables of current routine
      buffer := []		# a put-back buffer for getword
      proc := "global"
      letters := &lcase ++ &ucase ++ '_'
      digits := '1234567890'
      }
   i := 0
   while p := a[i +:= 1] do
      case p of {
         "-q":  qflag := 1
         "-x":  xflag := 1
         "-w":  inmaxcol := integer(a[i +:= 1])
         "-l":  inlmarg := integer(a[i +:= 1])
         "-c":  inchunk := integer(a[i +:= 1])
         default:  if f := open(p,"r") then fflag := 1
            else stop("usage:  [-q -x -w -l -c] file")
            }
   while word := getword() do
      if word == "link" then {
         buffer := []
         lin := ""
         next
         }
      else if word == "procedure" then {
         put(prec,procrec("",linenum,0))
         proc := getword() | break
         p := pull(prec)
         p.pname := proc
         put(prec,p)
         }
      else if word == ("global" | "link" | "record") then {
         word := getword() | break
         addword(word,"global",linenum)
         while (w2 := getword()) == "," do {
            if Find(word,resword) then break
            word := getword() | break
            addword(word,"global",linenum)
            }
         put(buffer,w2)
         }
      else if word == ("local" | "dynamic" | "static") then {
         word := getword() | break
         put(localvar,word)
         addword(word,proc,linenum)
         while (w2 := getword()) == "," do {
            if Find(word,resword) then break
            word := getword() | break
            put(localvar,word)
            addword(word,proc,linenum)
            }
         put(buffer,w2)
         }
      else if word == "end" then {
         proc := "global"
         localvar := []
         p := pull(prec)
         p.lastline := linenum
         put(prec,p)
         }
      else if Find(word,resword) then 
         next
      else {
         ln := linenum
         if (w2 := getword()) == "(" then
            word ||:= " *"			# special mark for procedures
         else
            put(buffer,w2)			# put back w2
         addword(word,proc,ln)
         }
   every write(!format(var))
   write("\n\nprocedures:\tlines:\n")
   L := []
   every p := !prec do
      put(L,left(p.pname,16," ") || p.begline || "-" || p.lastline)
   every write(!(sort(L)))
end

procedure addword(word,proc,lineno)
   if any(letters,word) | \xflag then {
      /var[word] := table()
      if /var[word]["global"] | Find(word,\localvar) then {
         /(var[word])[proc] := [word,proc]
         put((var[word])[proc],lineno)
         }
      else {
         /var[word]["global"] := [word,"global"]
         put((var[word])["global"],lineno)
         }
      }
end

procedure getword()
   local j, c
   static i, nonwhite
   nonwhite := ~' \t\n'
   repeat {
      if *buffer > 0 then return get(buffer)
      if /lin | i = *lin + 1 then
         if lin := myread() then {
            i := 1
            linenum +:= 1
            }
         else fail
      if i := upto(nonwhite,lin,i) then {   # skip white space
         j := i
         if lin[i] == ("'" | '"') then {   # don't xref quoted words
            if /qflag then {
               c := lin[i]
               i +:= 1
               repeat
                  if i := upto(c ++ '\\',lin,i) + 1 then
                     if lin[i - 1] == c then break
                     else i +:= 1
                  else {
                     i := 1
                     linenum +:= 1
                     lin := myread() | fail
                     }
               }
            else i +:= 1
            }
         else if lin[i] == "#" then {	# don't xref comments; get next line
            i := *lin + 1
            }
         else if i := many(letters ++ digits,lin,i) then
            return lin[j:i]
         else {
            i +:= 1
            return lin[i - 1]
            }
         }
      else
         i := *lin + 1
   }	   # repeat
end

procedure format(T)
   local V, block, n, L, lin, maxcol, lmargin, chunk, col
   initial {
      maxcol := \inmaxcol | 80
      lmargin := \inlmarg | 40
      chunk := \inchunk | 4
      }
   L := []
   col := lmargin
   every V := !T do
      every block := !V do {
         lin := left(block[1],16," ") || left(block[2],lmargin - 16," ")
         every lin ||:= center(block[3 to *block],chunk," ") do {
            col +:= chunk
            if col >= maxcol - chunk then {
               lin ||:= "\n\t\t\t\t\t"
               col := lmargin
               }
            }
         if col = lmargin then lin := lin[1:-6] # came out exactly even
         put(L,lin)
         col := lmargin
         }
   L := sort(L)
   push(L,"variable\tprocedure\t\tline numbers\n")
   return L
end

procedure Find(w,L)
   every if w == !L then return
end

procedure myread()
   if \fflag then return read(f) else return read()
end