special
if handled by hand-written code.
expargs
holds the names of arguments (fields) known to be
expressions, and which therefore need to be simplified recursively.
<*>= [D->] global records, rules, special, expargs, simp_name link commafy procedure main(args) every special | expargs := set() every records | rules := table() simp_name := "simfun" if args[1] == "-s" then simp_name := args[2] lex() P_Spec() every r := !records & not(member(special, r.name)) do { if not always_matches(r, !rules[r.name]) then put(rules[r.name], Rule(App(r.name, ignoredargs(r.args)), "e")) # default rule emit_tests(r) } return end
Definesexpargs
,main
,records
,rules
,simp_name
,special
(links are to index).
<*>+= [<-D->] procedure always_matches(r, rule) local lhs lhs := rule.lhs l := []; every !lhs.args do put(l, "dummy") return r.name == lhs.fun & *matching_conditions(lhs, l) = 0 end
Definesalways_matches
(links are to index).
To test a possibility, we first simplify expression arguments, then check each rule in turn. If we ever get to a rule that always matches, we win. If we every run out of rules, we lose.
<*>+= [<-D->] procedure emit_tests(r) local sargs, sa, before_if iwrite(0, image(r.name), " : {") # case label <emit simplifying assignments, makingsargs
name simplifiedr.args
> if member(expargs, !r.args) then {<emit assignment makinge
its simplified version>} before_if := "" while x := get(rules[r.name]) do { c := matching_conditions(x.lhs, sargs) if *c = 0 then {<emit last case and return>} else {<emit this case>} before_if := "} else " } stop("This can't happen -- ran out of rules before finding one that always matched") end
Definesemit_tests
(links are to index).
<emit assignment makinge
its simplified version>= (<-U) <makec
a list of conditions required to re-usee
> if *c > 0 then { write(" if not (", commaseparate(c), ") then") write(" e := ", r.name, "(", commaseparate(sargs), ")") }
<makec
a list of conditions required to re-usee
>= (<-U) c := [] every i := 1 to *r.args & member(expargs, r.args[i]) do put(c, sargs[i] || " === e." || r.args[i])
<emit this case>= (<-U) iwrite(2, before_if, "if (", commaseparate(c), ") then {") write_binding_assignments(x.lhs, sargs, 4) every o := !x.code & *o > 0 do iwrite(4, o)
<emit last case and return>= (<-U) iwrite(2, before_if, "{") write_binding_assignments(x.lhs, sargs, 4) every o := !x.code & *o > 0 do iwrite(4, o) iwrite(2, "}") iwrite(0, "}") write(&errout, "Warning: ", 0 < *rules[r.name], " extra rules for ", r.name) return
<emit simplifying assignments, makingsargs
name simplifiedr.args
>= (<-U) sargs := [] every a := !r.args do if member(expargs, a) then { sa := "_a" || *sargs iwrite(2, sa, " := ", simp_name, "(e.", a, ")") put(sargs, sa) } else put(sargs, "e." || a)
We discover binding assignments by a tree walk.
<*>+= [<-D->] procedure write_binding_assignments(lhs, sargs, indent) type(lhs) == "App" | stop("Left-hand side of rule must be an application") every i := 1 to *sargs do bind_arg(lhs.args[i], sargs[i], indent) return end
Defineswrite_binding_assignments
(links are to index).
<*>+= [<-D->] procedure bind_arg(lhs, e, indent) local sargs l := [] while type(lhs) == "Binding" do { put(l, lhs.id) lhs := lhs.exp } if *l > 0 then {put(l, e); iwrite(indent, commaseparate(l, " := "))} case type(lhs) of { "App" : { r := records[lhs.fun] *r.args = *lhs.args | stop("This can't happen -- args") sargs := []; every put(sargs, e || "." || !r.args) write_binding_assignments(lhs, sargs, indent) } "string" : if lhs ~== "_" then iwrite(indent, lhs, " := ", e) "integer" : &null default : stop("impossible lhs") } return end
Definesbind_arg
(links are to index).
A similar walk suffices to recover matching conditions.
<*>+= [<-D->] procedure matching_conditions(lhs, sargs, conds) /conds := [] type(lhs) == "App" | stop("Left-hand side of rule must be an application") every i := 1 to *sargs do add_conditions(lhs.args[i], sargs[i], conds) return conds end
Definesmatching_conditions
(links are to index).
<*>+= [<-D->] procedure add_conditions(lhs, e, conds) local sargs static intlets, uppernum initial { intlets := 'IJKLMN'; uppernum := &ucase ++ &digits } while type(lhs) == "Binding" do lhs := lhs.exp case type(lhs) of { "App" : { put(conds, "type(" || e || ") == " || image(lhs.fun)) r := records[lhs.fun] sargs := []; every put(sargs, e || "." || !r.args) matching_conditions(lhs, sargs, conds) } "string" : if lhs ? (any(intlets), tab(many(uppernum)), pos(0)) then put(conds, "type(" || e || ") == " || image("integer")) "integer" : put(conds, e || " === " || lhs) default : stop("impossible lhs") } return end
Definesadd_conditions
(links are to index).
<*>+= [<-D->] procedure newrule(lhs, code) type(lhs) == "App" | error("must be an application on lhs") every put(rules[lhs.fun], Rule(App(lhs.fun, insert_comments(lhs.args)), code)) return end
Definesnewrule
(links are to index).
We automatically insert Gcommented
into nested applications, so that
Gcommented
never prevents anything from matching.
<*>+= [<-D->] procedure insert_comments(e, i) case type(e) of { "list" : { /i := 1 if i <= *e then every l := insert_comments(e, i+1) & x := insert_comments(e[i]) do { push(l, x); suspend copy(l); pop(l) } else suspend [] } "Binding" : suspend Binding(e.id, insert_comments(e.exp)) "App" : { suspend App(e.fun, insert_comments(e.args)) suspend App("Gcommented", [App(e.fun, insert_comments(e.args)), "_"]) } "string" | "integer" : suspend e default : impossible("bad type in insert_comments: ", image(e)) } end
Definesinsert_comments
(links are to index).
We make ignored arguments in the default rule.
<*>+= [<-D->] procedure ignoredargs(args) l := [] every i := 1 to *args do put(l, "_") return l end
Definesignoredargs
(links are to index).
<*>+= [<-D->] record App(fun, args) record Binding(id, exp)
DefinesApp
,Binding
(links are to index).
Each record type has a list of arguments. A rule has a matching expression on the left and code on the right.
<*>+= [<-D->] record Record(name, args) record Rule(lhs, code)
DefinesRecord
,Rule
(links are to index).
<productions>= (U->) Spec : {Directive} "%%" {Rule}; Directive: Record | "special" ( "hoist" {Ident} "." | "simplify" {Ident} "." /* every insert(special, !ii2) */ ) | "expargs" {Ident} "." /* every insert(expargs, !ii2) */ ; Rule: Exp {CODE} /* newrule(ii1, ii2) */; Exp : Ident ( "as" Exp /* Binding(&null, ii2) */ | "(" Args ")" /* App(&null, ii2) */ | /* &null */ ) /* <attach identifierii1
to remainderii2
> */ | INT ; Args: [ Exp {"," Exp} /* push(ii2, ii1) */] /* \ii1 | [] */; Record: "record" Ident "(" [Ident {"," Ident} /* push(ii2, ii1) */] ")" /* records[ii2] := Record(ii2, \ii4 | []); rules[ii2] := [] */ ; Ident : IDENT | "_";
<attach identifierii1
to remainderii2
>= (<-U) case type(ii2) of { "Binding" : {ii2.id := ii1; ii2 } "App" : {ii2.fun := ii1; checkapp(ii2) } "null" : { ii1 } default : stop("impossible goo") }
<*>+= [<-D->] procedure checkapp(a) if /records[a.fun] then error("Record type ", a.fun, " not known") else if *records[a.fun].args ~= *a.args then error(a.fun, " takes ", *records[a.fun].args, " arguments") else return a end
Definescheckapp
(links are to index).
<grammar>= %term INT %term IDENT %term CODE %% <productions>
token
describes the category of the token, and tval
is its value.
token == tval
except for integers and identifiers.
file
and line
describe the source file and line number from which
the token came.
<*>+= [<-D->] global token, tval, file, line
Definesfile
,line
,token
,tval
(links are to index).
There are three special tokens.
<*>+= [<-D->] global EOF, IDENT, INT, CODE
DefinesCODE
,EOF
,IDENT
,INT
(links are to index).
<initialize tokens
>= (U->)
CODE := " code "
EOF := " end of file "
IDENT := " identifier "
INT := " integer "
<*>+= [<-D->]
procedure scantokens(eol)
static alphanum, hexdigits, multichar
initial {
alphanum := &letters ++ &digits ++ '_'
hexdigits := &digits ++ 'abcdefABCDEF'
multichar := set(["->", "%%"])
<initialize tokens
>
}
if pos(1) & tab(many(' \t')) then {
tval := tab(0)
return token := CODE
} else if {white(); not pos(0)} then {
thispos := &pos
if ="#" then tab(0) & fail
else if tval := integer(((="0x" & "16r") || tab(many(hexdigits))) |
((="-" | "") || tab(many(&digits)))) then {
token := INT
} else if tval := (any(&letters), tab(many(alphanum))) then {
token := reserved(tval) | IDENT
} else if tval := ="->" then {
white()
tval := tab(0)
token := CODE
} else if tval := =!multichar then {
token := tval
} else {
token := tval := move(1)
}
return token
}
end
Definesscantokens
(links are to index).
<*>+= [<-D->] procedure white() suspend tab(many(' \t')) end
Defineswhite
(links are to index).
<*>+= [<-D] procedure iwrite(indent, L[]) return write!(push(L,left("", indent))) end procedure iwrites(indent, L[]) return writes!(push(L,left("", indent))) end
Definesiwrite
,iwrites
(links are to index).
ii1
to remainder ii2
>: U1, D2
e
its simplified version>: U1, D2
sargs
name simplified r.args
>: U1, D2
tokens
>: D1, U2
c
a list of conditions required to re-use e
>: U1, D2