Return to t-ll.dat CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / icon / libtest

BSD 4.3

#	RSG(1)
#
#	Random sentence generation
#
#	Ralph E. Griswold
#
#	Last modified 8/11/84
#

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

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

procedure main(x)
   local line, plist, i, s
					# procedures to try on input lines
   plist := [define,generate,grammar,source,comment,prompter,error]
   defs := table()			# table of definitions
   defs["lb"] := [["<"]]		# built-in definitions
   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 {			# process options
      s := x[i +:= 1] | break
      case s of {
         "-t":   tswitch := 1
         "-l":   limit := integer(x[i +:= 1]) | Usage()
         "-s":   &random := integer(x[i +:= 1]) | Usage()
         default:   Usage()
         }
      }
   ifile := [&input]			# stack of input files
   prompt := ""
   while in := pop(ifile) do {		# process all files
      repeat {
         if *prompt ~= 0 then writes(prompt)
         line := read(in) | break
         while line[-1] == "\\" do line := line[1:-1] || read(in) | break
         (!plist)(line)
         }
      close(in)
      }
end

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

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

#  define nonterminal
#
procedure defnon(sym)
   local chars, name
   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

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

#  generate sentences
#
procedure gener(goal)
   local pending, genstr, symbol
   repeat {
      pending := [nonterm(goal)]
      genstr := ""
      while symbol := get(pending) do {
         if \tswitch then
            write(&errout,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(&errout,"*** no value for query to ",symbol.name)
                  suspend genstr
                  break next
                  }
               }
            "nonterm":  {
               pending := ?\defs[symbol.name] ||| pending | {
                  write(&errout,"*** undefined nonterminal:  <",symbol.name,">")
                  suspend genstr
                  break next
                  }
               if *pending > \limit then {
                  write(&errout,"*** excessive symbols remaining")
                  suspend genstr
                  break next
                  }
               }
            }
         }
      suspend genstr
      }
end

#  look for generation specification
#
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

#  get right hand side of production
#
procedure getrhs(a)
   local rhs
   rhs := ""
   every rhs ||:= listimage(!a) || "|"
   return rhs[1:-1]
end

#  look for request to write out grammar
#
procedure grammar(line)
   local file, out, name
   if line ? {
      name := tab(find("->")) &
      move(2) &
      file := tab(0) &
      out := if *file = 0 then &output else {
         open(file,"w") | {
            write(&errout,"*** 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

#  produce image of list of grammar symbols
#
procedure listimage(a)
   local s, x
   s := ""
   every x := !a do
      s ||:= symimage(x)
   return s
end

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

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

#  write out grammar
#
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

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

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

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

#  stop noting incorrect usage
#
procedure Usage()
   stop("usage:  [-t] [-l n] [-s n]")
end

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.