global defs, ifile, in, limit, tswitch, prompt

record nonterm(name)
record charset(chars)
record query(name)

procedure main(x)
   local line, plist
   plist := [define,generate,grammar,source,comment,prompter,error]
   defs := table()
   defs["lb"] := [["<"]]
   defs["rb"] := [[">"]]
   defs["vb"] := [["|"]]
   defs["nl"] := [["\n"]]
   defs[""] := [[""]]
   defs["&lcase"] := [[charset(&lcase)]]
   defs["&ucase"] := [[charset(&ucase)]]
   defs["&digit"] := [[charset('0123456789')]]
   i := 0
   while i < *x do {
      s := x[i +:= 1] | break
      case s of {
         "-t":   tswitch := 1
         "-l":   limit := integer(x[i +:= 1]) | stop("usage: [-t] [-l n]")
         default:   stop("usage: [-t] [-l n]")
         }
      }
   ifile := [&input]
   prompt := ""
   test := ["<a>::=1|2|3","<a>10","->","<b>::=<a>|<a><a>|<b><b>","<b>5",
      "<c>::=<b><b><b>","<c>100","<b>100"]
   every line := !test do {
      (!plist)(line)
      collect()
      every write(&collections)
      write("----------")
      }
end

procedure comment(line)
   if line[1] == "#" then return
end

procedure define(line)
   return line ?
      defs[(="<",tab(find(">::=")))] := (move(4),alts(tab(0)))
end

procedure defnon(sym)
   if sym ? {
      ="'" &
      chars := cset(tab(-1)) &
      ="'"
      }
   then return charset(chars)
   else if sym ? {
      ="?" &
      name := tab(0)
      }
   then return query(name)
   else return nonterm(sym)
end

procedure error(line)
   write("*** erroneous line:  ",line)
   return
end

procedure gener(goal)
   local pending, genstr, symbol
   repeat {
      pending := [nonterm(goal)]
      genstr := ""
      while symbol := get(pending) do {
         if \tswitch then write(genstr,symimage(symbol),listimage(pending))
         case type(symbol) of {
            "string":   genstr ||:= symbol
            "charset":  genstr ||:= ?symbol.chars
	    "query":    {
               writes("*** supply string for ",symbol.name,"  ")
               genstr ||:= read() | {
                  write("*** no value for query to ",symbol.name)
                  suspend genstr
                  break next
                  }
               }
            "nonterm":  {
               pending := ?\defs[symbol.name] ||| pending | {
                  write("*** undefined nonterminal:  <",symbol.name,">")
                  suspend genstr
                  break next
                  }
               if *pending > \limit then {
                  write("*** excessive symbols remaining")
                  suspend genstr
                  break next
                  }
               }
            }
         }
      suspend genstr
      }
end

procedure generate(line)
   local goal, count
   if line ? {
      ="<" &
      goal := tab(upto('>')) \ 1 &
      move(1) &
      count := (pos(0) & 1) | integer(tab(0))
      }
   then {
      every write(gener(goal)) \ count
      return
      }
   else fail
end

procedure getrhs(a)
   local rhs
   rhs := ""
   every rhs ||:= sform(!a) || "|"
   return rhs[1:-1]
end

procedure grammar(line)
   local file, out
   if line ? {
      name := tab(find("->")) &
      move(2) &
      file := tab(0) &
      out := if *file = 0 then &output else {
         open(file,"w") | {
            write("*** cannot open ",file)
            fail
            }
         }
      }
   then {
      (*name = 0) | (name[1] == "<" & name[-1] == ">") | fail
      pwrite(name,out)
      if *file ~= 0 then close(out)
      return
      }
   else fail
end

procedure listimage(a)
   local s, x
   s := ""
   every x := !a do
      s ||:= symimage(x)
   return s
end

procedure alts(defn)
   local alist
   alist := []
   defn ? while put(alist,syms(tab(many(~'|')))) do move(1)
   return alist
end

procedure prompter(line)
   if line[1] == "=" then {
      prompt := line[2:0]
      return
      }
end

procedure pwrite(name,ofile)
   local nt, a
   static builtin
   initial builtin := ["lb","rb","vb","nl","","&lcase","&ucase","&digit"]
   if *name = 0 then {
      a := sort(defs)
      every nt := !a do {
         if nt[1] == !builtin then next
         write(ofile,"<",nt[1],">::=",getrhs(nt[2]))
         }
      }
   else write(ofile,name,"::=",getrhs(\defs[name[2:-1]])) |
      write("*** undefined nonterminal:  ",name)
end

procedure sform(alt)
   local s, x
   s := ""
   every x := !alt do
      s ||:= case type(x) of {
         "string":  x
         "nonterm": "<" || x.name || ">"
         "charset": "<'" || x.chars || "'>"
         }
   return s
end

procedure source(line)
   return line ? (="@" & push(ifile,in) & {
      in := open(file := tab(0)) | {
         write("*** cannot open ",file)
         fail
         }
      })
end

procedure symimage(x)
   return case type(x) of {
      "string":   x
      "nonterm":  "<" || x.name || ">"
      "charset":  "<'" || x.chars || "'>"
      }
end

procedure syms(alt)
   local slist
   slist := []
   alt ? while put(slist,tab(many(~'<')) |
      defnon(2(="<",tab(upto('>')),move(1))))
   return slist
end