Path: utzoo!utgpu!jarvis.csri.toronto.edu!mailrus!tut.cis.ohio-state.edu!ucbvax!astroatc.UUCP!tenaglia
From: tenaglia@astroatc.UUCP (Chris Tenaglia)
Newsgroups: comp.lang.icon
Subject: (none)
Message-ID: <8908051346.AA04910@astroatc.UUCP>
Date: 5 Aug 89 13:46:58 GMT
Sender: daemon@ucbvax.BERKELEY.EDU
Distribution: inet
Organization: The Internet
Lines: 382

Dear Icon-Group,

  This is a rather long goody. Its an icon program pretty printer.
  I integrated it with the ipxref crossreference program as well.
  The program itself is written to be printed by itself. It you'd
  like to keep neat listings of iconware, you'll like this one.
  You may even customize it to have your company/school header or
  whatever. It's over 350 lines long, I hope your mail utility
  has a more filter. Good Luck!

Yours truly,

Chris Tenaglia
Astronautics Corporation of America
4115 N. Teutonia Avenue
Milwaukee, Wi 53209 USA
(414) 447-8200 X-421

#TITLE FANCY LISTER OF ICONWARE
#SUB MAIN LINE
#EJECT
#################################################################
#                                                               #
# ILIST.ICN             11/26/88              BY CHRIS TENAGLIA #
#                                                               #
#        THIS PROGRAM MAKES NICE LIST FILES OF ICONWARE         #
#                                                               #
# LISTER DIRECTIVES    DESCRIPTION                              #
#  #TITLE text.....     SET MAIN TITLE INFORMATION              #
#  #SUB text.......     SET SUBTITLE INFORMATION                #
#  #EJECT               EJECT PAGE                              #
#                                                               #
# CROSSREFERENCE OF PROCEDURES REQUIRES THAT ALL PROCEDURES BE  #
# DECLARED STARTING IN COLUMN 1.   THIS PROGRAM WAS WRITTEN TO  #
# DEMONSTRATE ITS USE. IPXREF FROM THE IPL WAS ADDED AS AN OP-  #
# OPTION TO PROVIDE A DETAILED CROSSREFERENCE AT THE END.       #
# USAGE : ICONX ILIST [-V] FILE[.ICN] [OUTPUT]                  #
#                                                               #
#################################################################
global in,out,pgnum,lnum,lcnt,tline,subline,option,source
global resword, linenum, letters, digits, var, buffer, qflag, f, fflag, xflag
global inmaxcol, inlmarg, inchunk, localvar, lin

record procrec(pname,begline,lastline)

procedure main(param)
  init(param)
  pgnum    := 0
  lnum     := 0
  lcnt     := 0              
  tline    := ""             
  subline  := ""
  xpage    := table()
  xline    := table()

  every line := !in do
    {
    lnum +:= 1
    if (i := match("procedure ",line)) then
      {
      name        := line[i:upto('(',line,i)]
      xpage[name] := pgnum
      xline[name] := lnum
      }
    if (temp := title(line)) then
      {
      tline := temp
      next
      }
    if (temp := subtitle(line)) then
      {
      subline := temp
      next
      }
    if match("#eject",map(line)) then
      {
      header()
      next
      }
    if lcnt > 55 then header()
    write(out,ing(line))
    lcnt +:= 1
    }
  close(in)
  subline := "***** CROSSREFERENCE ***** "
  header()
  write(out,left("\nPROCEDURE NAME",32),right("PAGE",8),right("LINE",8))
  xref1 := sort(xpage,2)
  xref2 := sort(xline,2)
  every i := 1 to *xref1 do
    {
    proc := xref1[i]
    page := xref2[i]
    text := left(page[1],32) || right(proc[2],8) || right(page[2],8)
    write(out,text)
    }
  write(out,left("\nPROCEDURE NAME",32),right("PAGE",8),right("LINE",8))
  xref1 := sort(xpage,1)
  xref2 := sort(xline,1)
  every i := 1 to *xref1 do
    {
    proc := xref1[i]
    page := xref2[i]
    text := left(proc[1],32) || right(proc[2],8) || right(page[2],8)
    write(out,text)
    }
  if option == "-v" then ipxref([source])
  close(out)
  write("\nProcess Completed !")
end
                      
#SUB HANDY SUBROUTINES SECTION
#EJECT
#################################################################
#                                                               #
# THIS ROUTINE RECOGNIZES AND RETURNS A TITLE IF ANY            #
#                                                               #
#################################################################
procedure title(line)
  if (i := match("#title ",map(line))) then return line[i:0]
end

#################################################################
#                                                               #
# THIS ROUTINE RECOGNIZES AND RETURNS A SUBTITLE IF ANY         #
#                                                               #
#################################################################
procedure subtitle(line)
  if (i := match("#sub ",map(line))) then return line[i:0]
end

#################################################################
#                                                               #
# THIS ROUTINE SPECIALLY FORMATS THE LINE                       #
#                                                               #
#################################################################
procedure ing(line)                      
  return (right(lnum,6) || " : " || line)
end

#################################################################
#                                                               #
# THIS ROUTINE OUTPUTS THE HEADER                               #
#                                                               #
#################################################################
procedure header()
  pgnum +:= 1
  write(out,"\f")                                 
  id := "<> ICON LISTER " || &host || " " || &dateline
  id ||:= " Page " || pgnum || " <>\n"
  write(out,center(id,79))
  write(out,center("<< "||tline||" >>",79))
  write(out,center("< "||subline||" >",79),"\n")
  lcnt   := 1
end

#EJECT
#################################################################
#                                                               #
# THIS ROUTINE PERFORMS THE INITIAL SET UP AND OPENS FILES      #
#                                                               #
#################################################################
procedure init(param)
  option := ""
  parx   := 0
  if param[1] == "-v" then {option := param[1];parx+:=1}
  if not(source := param[(parx+:=1)]) then
    {
    writes("Source >")
    source := read()
    }
  if not(find(".icn",map(source))) then source ||:= ".icn"
  (in := open(source)) | stop("Can't open ",source)

  if not(target := param[(parx+:=1)]) then
    target := source[1:find(".",source)] || ".lis"
  (out := open(target,"w")) | stop("Can't open ",target)

  a      := "\e[1m"
  c      := "\e[2J\e[H"      
  z      := "\e[0m\n"
  top    := list()
  put(top, (c || a || center("< Nice ICON Lister >",79) || z))
  put(top, (a || center( (&host || " " || &dateline) ,79) || z))
  q := center(("Reading " || source || " | Writing " || target),79)
  b := (a || q || z)
  put(top, b)
  put(top, (repl("-",80) || z))
  every write(!top)
end

#	IPXREF
#
#	Create Icon program cross-reference
#
#	Allan J. Anderson
#
#	Last modified 4/29/86 by Ralph E. Griswold
#
procedure ipxref(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
   header()
   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(out,!format(var))
   write(out,"\n\nprocedures:\tlines:\n")
   L := []
   every p := !prec do
      put(L,left(p.pname,16," ") || p.begline || "-" || p.lastline)
   every write(out,!(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