diff options
Diffstat (limited to 'tests/general/gc2.icn')
| -rw-r--r-- | tests/general/gc2.icn | 222 |
1 files changed, 222 insertions, 0 deletions
diff --git a/tests/general/gc2.icn b/tests/general/gc2.icn new file mode 100644 index 0000000..e89902c --- /dev/null +++ b/tests/general/gc2.icn @@ -0,0 +1,222 @@ +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 + |