#===================================================================== lex.icn #line 9 "lex.nw" global token, tval, file, line #line 13 "lex.nw" global EOF, IDENT, INT, CODELINE, CASELINE, NEWLINE, WHITESPACE, lexstate #line 23 "lex.nw" global SEMANTICS, IDENT, STARTSEM, ENDSEM, succptr procedure scantokens(eol) static alpha, alphanum, multichar initial { alpha := &letters ++ '_.' alphanum := alpha ++ &digits multichar := set(["<=", ">=", "!=", ">>", "<<", "=>", "..."]) /lexstate := "INITIAL" #line 15 "lex.nw" CASELINE := " case ... of " CODELINE := " code line " EOF := " end of file " IDENT := " identifier " INT := " integer " NEWLINE := " newline " WHITESPACE := " white space " #line 32 "lex.nw" } if \eol then return possible_newline() case lexstate of { "INITIAL" | "CASEPAT" : { #line 143 "lex.nw" if tval := white() then # don't backtrack past white() if token := possible_whitespace() then return token if {not pos(0)} then { thispos := &pos if ="#" then { tab(0) & (token := possible_newline() | fail) } else if tval := (hexint() | octalint() | binaryint() | decimalint()) then { token := INT } else if tval := (any(alpha), tab(many(alphanum))) then { token := 1(reserved(tval), ignore_newlines()) | IDENT } else if tval := =!multichar then { token := tval #line 175 "lex.nw" case tval of { "=>" : if lexstate == "CASEPAT" then lexstate := "CASEARM" } #line 157 "lex.nw" } else if token := ="\"" then { delim := move(-1) # recover quote tval := "" while =delim do { # turn 'don''t into "don't" tval ||:= tab(upto(delim) | 0) =delim | error("unclosed ", delim) } } else if token := ="'" then { # character constant tval := charconst() ="'" | error("character constant too large (or unclosed single quote)") } else { token := tval := move(1) if token == ("{"|".") then ignore_newlines() } return token } return possible_newline() #line 35 "lex.nw" } #line 63 "lex.nw" "CODE": { if (optwhite(), ="match ", optwhite(), (="[", optwhite(), any(&letters), succptr := tab(many(alphanum)), optwhite(), ="]", optwhite()) | (succptr := &null), tval := tab(find(" to")), =" to", optwhite(), pos(0)) then { lexstate := "CASEPAT" return CASELINE } else if optwhite() & ="match " & tval := tab(find(" to")) & =" to" & optwhite() & pos(0) then { impossible("bogus code in lex") lexstate := "CASEPAT" return CASELINE } else { # warning message for ill-formed case? tval := tab(0) return CODELINE } } #line 92 "lex.nw" "CASEARM": { if optwhite() & tval := (="|" | 1(=("else" | "endmatch"), white() | pos(0))) then { lexstate := case tval of { "|" : "CASEPAT" ; "else" : "CASEARM" ; "endmatch" : "CODE" } return token := tval } else { tval := tab(0) return CODELINE } } #line 37 "lex.nw" } end #line 109 "lex.nw" global NEWLINEVISION procedure see_newline() if token == (IDENT|"address") then NEWLINEVISION := 1 return NEWLINEVISION end procedure ignore_newlines() return NEWLINEVISION := &null end procedure possible_newline() if \NEWLINEVISION then { NEWLINEVISION := &null return NEWLINE } return possible_whitespace() end #line 128 "lex.nw" global WHITESPACEVISION procedure see_whitespace() WHITESPACEVISION := 1 return WHITESPACEVISION end procedure ignore_whitespace() return WHITESPACEVISION := &null end procedure possible_whitespace() if \WHITESPACEVISION then { return WHITESPACE } end #line 179 "lex.nw" procedure optwhite() suspend white() | "" end procedure white() suspend tab(many(' \t')) end #line 189 "lex.nw" procedure hexint() static hexdigits initial hexdigits := &digits ++ 'abcdefABCDEF' suspend ="0x" & integer("16r" || tab(many(hexdigits))) end #line 195 "lex.nw" procedure octalint() static octaldigits initial octaldigits := '01234567' suspend ="0" & integer("8r" || tab(many(octaldigits))) end #line 201 "lex.nw" procedure binaryint() static binarydigits initial binarydigits := '01' suspend ="0b" & integer("2r" || tab(many(binarydigits))) end #line 207 "lex.nw" procedure decimalint() static decimaldigits initial decimaldigits := &digits suspend integer(tab(many(&digits))) end #line 213 "lex.nw" procedure codelex(in) lexstate := "CODE" return lex(in) end #line 220 "lex.nw" procedure charconst() local ns, c return if ="\\" then { #line 226 "lex.nw" c := map(move(1)) | fail # backslash newline fails case c of { "b": "\b" "d": "\d" "e": "\e" "f": "\f" "l": "\n" "n": "\n" "r": "\r" "t": "\t" "v": "\v" "'": "'" "\"": "\"" "\\" : "\\" "x": hexchar() !"01234567": octcode() default: error("bad backslash escape \\", c, tab(0)) } #line 223 "lex.nw" } else move(1) end #line 245 "lex.nw" procedure hexcode() local i, s static hdigits initial hdigits := ~'0123456789ABCDEFabcdef' move(i := 2 | 1) ? s := tab(upto(hdigits) | 0) move(*s - i) return char("16r" || s) end #line 255 "lex.nw" procedure octcode() local i, s static odigits initial odigits := ~'01234567' move(-1) move(i := 3 | 2 | 1) ? s := tab(upto(odigits) | 0) move(*s - i) if s > 377 then { # back off if too large s := s[1:3] move(-1) } return char("8r" || s) end #==================================================================== Cexp.icn #line 7 "Cexp.nw" procedure prettyC(e, precedence, associativity, nohex) #line 74 "Cexp.nw" local leadingsign #line 149 "Cexp.nw" local save_pc_override #line 284 "Cexp.nw" static na_count #line 9 "Cexp.nw" initial { #line 357 "Cexp.nw" ops := ["N", ["low"], "L", [";"], "L", [","], "R", ["=", "+=", "-=", "*=", "/=", "%=", "&=", "^=", "|=", ">>=", "<<="], "R", [":?"], "L", ["||"], "L", ["&&"], "L", ["|"], "L", ["^"], "L", ["&"], "L", ["==", "!="], "L", ["<=", "<", ">=", ">"], "L", [">>", "<<"], "L", ["+", "-"], "L", ["%", "/", "*"], "R", ["!", "~", "++", "--", "cast", "sizeof"], "L", [".", "->", "app"], "N", ["high"] ] Cprec := table([]) # missed lookups break arithmetic comparisons Cassoc := table() every i := 1 to *ops by 2 do { every Cprec[!ops[i+1]] := i Cassoc[i] := ops[i] } #line 9 "Cexp.nw" } /precedence := 0 /associativity := "L" return case type(e) of { #line 19 "Cexp.nw" "list" : commaseparate(maplist2(prettyC, e, Cprec[","]), ", $o") "set" : commaseparate(maplist2(prettyC, sort(e), Cprec["&&"]), " && $o") "eqn" : { o := Cop(e.op) Cbracket(prettyC(e.left, Cprec[o]) || " " || o || " $o" || prettyC(e.right, Cprec[o]), "==", precedence) } "table" : { # standard normal form #line 36 "Cexp.nw" { s := ""; leadingsign := "" #line 44 "Cexp.nw" every e[k := 1 ~=== key(e)] > 0 do { s ||:= leadingsign s ||:= (1 ~= abs(e[k])) || "*" # print coefficient if not 1 s ||:= prettyC(k, Cprec["*"]) leadingsign := " + $o" } if e[1] > 0 then s ||:= leadingsign || string(e[1]) #line 39 "Cexp.nw" leadingsign := " - $o" #line 52 "Cexp.nw" every e[k := 1 ~=== key(e)] < 0 do { s ||:= leadingsign s ||:= (1 ~= abs(e[k])) || "*" # print coefficient if not 1 s ||:= prettyC(k, Cprec["*"]) } if e[1] < 0 then s ||:= leadingsign || string(-e[1]) #line 41 "Cexp.nw" s := if s == "" then "0" else Cbracket(s, "+", precedence) } #line 27 "Cexp.nw" "$t${" || s || "$}$b" } "string" : e "literal" : list_to_string(e.s) "integer" : if e > max_decimal then "0x" || hexstring(e) else string(e) #line 76 "Cexp.nw" "Eorb" : { s := prettyC(e.x, Cprec["|"], "L") t := prettyC(e.y, Cprec["|"], "R") Cbracket(s || " | $o" || t, "|", precedence) } "Eand" : { s := prettyC(e.x, Cprec["&&"], "L") t := prettyC(e.y, Cprec["&&"], "R") Cbracket(s || " && $o" || t, "&&", precedence) } #line 85 "Cexp.nw" "Eslice" : { s := prettyC(super_simplify(Eshift(e.x, -e.lo)), Cprec["&"], "L") Cbracket(s || " & " || mask(e.n), "&", precedence) } "Eshift" : { s := prettyC(e.x, Cprec["<<"]) s ||:= if e.n < 0 then (" >> " || -e.n) else (" << " || e.n) Cbracket(s, "<<", precedence) } #line 94 "Cexp.nw" "Enarrowu" : prettyC(e.x, precedence, associativity) # checked, so must be identity "Enarrows" : prettyC(super_simplify(Eslice(e.x, 0, e.n)), precedence, associativity) "Ewiden" : "sign_extend($t${$o" || prettyC(e.x) || ", $o" || e.n || "$}$b)" #line 98 "Cexp.nw" "Ediv" : { s := prettyC(e.x, Cprec["/"]) s := "((int)" || s || ")" # temporary hack to fix a bug s ||:= " / " || e.n Cbracket(s, "/", precedence) } "Emod" : { s := prettyC(e.x, Cprec["%"]) s ||:= " % " || e.n Cbracket(s, "%", precedence) } #line 110 "Cexp.nw" "Semit" : if *e.x = 0 then "{/*emit epsilon*/}" else { s := if *e.x > 1 then "$t${{ $c" else "" #line 141 "Cexp.nw" if *e.x > 1 & emitterstyle == "direct" & expwalk(e.x[2:0], equals_pc) then { s ||:= "unsigned ENCODE_pc = cur_pc(); $c" save_pc_override := pc_override pc_override := "ENCODE_pc" } #line 114 "Cexp.nw" s ||:= commaseparate(maplist(prettyC, e.x), " $c") #line 147 "Cexp.nw" pc_override := save_pc_override #line 116 "Cexp.nw" s || if *e.x > 1 then " $b$c}$}" else "" } "Stoken" : case emitterstyle of { "direct" : { #line 125 "Cexp.nw" s := emittername || "$t(" || prettyC(e.x, Cprec[","]) || ", $o" || e.n || ")" Cbracket("$c" || s, "app", precedence) || ";$b" #line 120 "Cexp.nw" } "closure": { #line 130 "Cexp.nw" o := if e.offset > 0 then " + " || e.offset else "" s := "emitter$t(_c->loc.dest_block, $o_c->loc.dest_lc" || o || ", $o" || prettyC(e.x, Cprec[","]) || ", $o" || e.n || ")" Cbracket("$c" || s, "app", precedence) || ";$b" #line 121 "Cexp.nw" } } | impossible("emitter style") #line 151 "Cexp.nw" "Epc" : \pc_override | "cur_pc()" "Epc_known" : "cur_pc_known()" #line 154 "Cexp.nw" "Eclosure_loc" : "_c->loc" "Eclosure_addr" : "_c->v.a" || e.n "Eclosure_val" : "_c->v.u" || e.n #line 161 "Cexp.nw" "Efitsu" : { s := "(unsigned)(" || prettyC(e.x) || ") < " || tworaised(e.n) Cbracket(s, "<", precedence) } "Efitss" : { s := "(unsigned)(" || prettyC(addconst(e.x, 2^(e.n-1))) || ") < " || tworaised(e.n) Cbracket(s, "<", precedence) } #line 169 "Cexp.nw" "Eforce" | "Eforceable" : { (if type(e.x) == "Eclosure_loc" then "pc_" else "") || "location" || (if type(e) == "Eforceable" then "_known" else "") || "$t${(" || prettyC(e.x) || ")$}$b" } #line 176 "Cexp.nw" "Enot" : { s := "!" || prettyC(e.x, Cprec["!"]) Cbracket(s, "!", precedence) } #line 180 "Cexp.nw" "Enosimp" : prettyC(e.x, precedence, associativity) #line 182 "Cexp.nw" "Sstmts" : "$t${{ $c" || commaseparate(maplist2(prettyC, e.x), " $c") || " $b$c}$}" #line 184 "Cexp.nw" "Gcall" : { l := []; every put(l, prettyC(!e.args)) Cnoreserve(e.name) || "(" || commaseparate(l) || ")" } #line 188 "Cexp.nw" "Einstance_input" : { s := prettyC(e.x, Cprec["."]) || ".u." || e.cons.name || "." || e.name Cbracket(s, ".", precedence) } "Einstance_tagged" : { s := prettyC(e.x, Cprec["="]) || ".tag == " || e.cons.name || "_TAG" Cbracket(s, "==", precedence) } #line 200 "Cexp.nw" "Sif" : { preif := "" s := "" every a := !e.arms do { s ||:= preif || Ctest(a.guard) || Carm(a.x) preif := "$celse " } "${" || s || "$}" } #line 209 "Cexp.nw" "Efail" : error("Generate-time operation failed: ", e.msg) #line 221 "Cexp.nw" "Stagcase" : { s := "switch (" || prettyC(e.x, Cprec["."]) || ".tag) {$t${" every c := kept_constructors(e.type) do s ||:= "$ccase " || c.name || "_TAG: $t$c${" || prettyC(e.arms[c]) || " $cbreak;$}$b" s || "$cdefault: assert(0);$}$b$c} /* " || Cuncomment(prettyC(e.x)) || " */" } #line 241 "Cexp.nw" "Sfail" : { s := "fail($t${" || image(escape_dollars(e.fmt)) every a := e.a1 | e.a2 | e.a3 do s ||:= ", $o" || prettyC(\a, Cprec[","]) s ||:= "$}$b);" Cbracket(s, "app", precedence) } "Sepsilon" : "{/* skip */}" #line 249 "Cexp.nw" "Sclosure" : prettyC(\e.creation) | impossible("creating closure") #line 251 "Cexp.nw" "Glines" : { s := ""; every s ||:= prettyC(!e.x) || "\n"; s } "Gresynch" : "$n#line " || e.line || " " || image(\e.file | "generated-code") #line 254 "Cexp.nw" "Gblock" : { s := "{ ${$t$c" every s ||:= prettyC(!e.decls) || ";$n" s ||:= commaseparate(maplist(prettyC, e.stmts), "$c") s || "$b $c}$}" } "Gdecl" : { s := "${" || prettyC(\e.type | infer_C_type(e.init)) s ||:= " " || e.name s ||:= " = $t$c" || prettyC(\e.init) || "$b" s || "$}" } #line 273 "Cexp.nw" "Gdeclnamearray" : { /na_count := 0 /e.na.codename := "MATCH_name_" || e.na.field.field.name || "_" || (na_count +:= 1) /e.na.storageclass := "static" s := e.na.storageclass || " char *" || e.na.codename || "[] = {" s ||:= "${$t" every i := 0 to e.na.hi - 1 do s ||:= " $c" || escape_dollars(image(\e.na.tbl[i]|0)) || "," s || "$b $c$}}" } #line 286 "Cexp.nw" "Gsetname" : "char *" || e.lhs || " = ${$t$o" || case type(e.name) of { "string" : image(e.name) "namearray" : e.name.codename || "[" || prettyC(e.name.field) || "]" default : impossible("type of node name field") } || "$b$}" #line 292 "Cexp.nw" "Gcase" : { s := "switch (" || prettyC(e.x) || ") {$t${ " every s ||:= prettyC(!e.arms) s || "$cdefault: assert(0);$}$b$c} /* " || Cuncomment(prettyC(e.x)) || " */" } "Gcasearm" : { s := "$n" every i := 1 to *e.tags by 2 do { if e.tags[i] + 1 = e.tags[i+1] then s ||:= "$ocase " || e.tags[i] || ": " else every s ||:= "$ocase " || (e.tags[i] to (e.tags[i+1]-1)) || ": " } s ||:= "$t$c${" || prettyC(e.x) || "$cbreak;$}$b" } #line 307 "Cexp.nw" "Ginrange" : { x := prettyC(e.x, Cprec["<"]) if e.lo + 1 = e.hi then { Cbracket(x || " == " || e.lo, "==", Cprec["&&"]) } else { c1 := Cbracket(e.lo || " <= " || x, "<=", Cprec["&&"]) c2 := Cbracket(x || " < " || e.hi, "<", Cprec["&&"]) Cbracket(c1 || " && " || c2, "&&", precedence) } } "Gsetname" : "${" || e.lhs || " = $t$o" || case type(e.name) of { "string" : image(e.name) "namearray" : e.name.codename || "[" || e.name.field.name || "]" default : impossible("type of node name field") } || ";$b$}" "Gasgn" : "${" || prettyC(e.lhs) || " = $t$o" || prettyC(e.x, Cprec["="]) || ";$b$}" #line 323 "Cexp.nw" "Gnomatch" : "assert(0); /* no match */$n" "Tunsigned" : unsigned_type(e.width) "Tsigned" : signed_type(e.width) "Gcomment" : "/* " || Cuncomment(e.s) || " */" "Gcommented" : prettyC(e.e, precedence, associativity, nohex) || " /* " || Cuncomment(e.comment) || " */" #line 347 "Cexp.nw" "absolute_field" : prettyC(super_simplify(afieldexp(e)), precedence, associativity, nohex) #line 14 "Cexp.nw" default : impossible("Bad code to prettyC") } end #line 158 "Cexp.nw" global pc_override #line 211 "Cexp.nw" procedure Ctest(guard) return if guard_always_satisfied(guard) then "" else "if $t${(" || prettyC(guard) || ")$}$b " end #line 216 "Cexp.nw" procedure Carm(e) return if type(e) == ("Gblock"|"Sstmts") then prettyC(e) || " " else "$t$c${" || prettyC(e) || "$}$b " end #line 230 "Cexp.nw" procedure Cuncomment(s) r := "" s ? { while r ||:= tab(upto('/*')) do if ="/*" then r ||:= "--" else if ="*/" then r ||:= "--" else r ||:= move(1) return r || tab(0) } end #line 265 "Cexp.nw" procedure infer_C_type(value) if /value then impossible("variable with no type and no value") return case type(value) of { "Ewiden" : Tsigned(value.n) default : Tunsigned(wordsize) } end #line 331 "Cexp.nw" procedure unsigned_type(width) return "unsigned" || unsigned_width_comment(width) end procedure signed_type(width) return "int" || signed_width_comment(width) end procedure unsigned_width_comment(width) return if \width < wordsize then " /* [0.." || (2^width-1) || "] */" else "" end procedure signed_width_comment(width) return if \width < wordsize then " /* [" || -(2^(width-1)) || ".." || (2^(width-1)-1) || "] */" else "" end #line 350 "Cexp.nw" global Cprec, Cassoc procedure Cbracket(s, op, p, a) /a := "L" return "${" || (if Cprec[op] > p | (Cprec[op] = p & Cassoc[p] == a) then s else "(" || s || ")") || "$}" end #line 384 "Cexp.nw" procedure Cop(op) return if op == "=" then "==" else op end #line 388 "Cexp.nw" procedure Cnoreserve(word) static reserved initial reserved := set([ "asm", "auto", "break", "case", "char", "const", "continue", "default", "double", "do", "else", "enum", "extern", "float", "for", "goto", "if", "int", "long", "register", "return", "short", "signed", "sizeof", "static", "struct", "switch", "typedef", "union", "unsigned", "void", "volatile", "while"]) return if member(reserved, word) then Cnoreserve(word||"_") else word end #line 399 "Cexp.nw" procedure hexstring(i,n) local s if i = 0 then s := "0" else { s := "" while i ~= 0 do { s := "0123456789abcdef"[iand(i,15) + 1] || s i := ishift(i,-4) } } if \n > *s then s := right(s,n,"0") return s end #line 415 "Cexp.nw" procedure Generate_C() pretty := prettyC hex_prefix := "0x" gen_outer_decls := [] gen_file_header := ["#include \n", "#define sign_extend(N,SIZE) ", # no newline after #define "(((int)((N) << (sizeof(unsigned)*8-(SIZE)))) >> (sizeof(unsigned)*8-(SIZE)))" ] fetchtab["type"] := "unsigned char *"; fetchtab["add"] := "((%a) + %o)" fetchtab["integer"] := "(unsigned)(%a)" # fetchtab[8] := "(unsigned)*(unsigned char *) (%a+%o/8)" # fetchtab[16] := "(unsigned)*(unsigned short *)(%a+%o/16)" # fetchtab[32] := "(unsigned)*(unsigned *) (%a+%o/32)" end #line 434 "Cexp.nw" procedure c_function_declaration(pp, returntype, name, args, indirect) emit_template(pp, if \indirectname then "indirect-proto.t" else "direct-proto.t", "return", returntype, "name", name, "args", args) return end #=================================================================== M3exp.icn #line 7 "M3exp.nw" procedure prettyM3(e, precedence, associativity, nohex) #line 74 "M3exp.nw" local leadingsign #line 208 "M3exp.nw" static na_count #line 9 "M3exp.nw" initial { #line 259 "M3exp.nw" ops := ["N", ["low"], "L", [";"], "L", [","], "L", ["OR"], "L", ["AND"], "L", ["NOT"], "L", ["<=", "<", ">=", ">", "=", "#", "IN"], "L", ["+", "-", "&"], "L", ["MOD", "DIV", "*", "/"], "L", ["^"], "L", ["app"], "L", ["."], "N", ["high"] ] M3prec := table([]) # missed lookups break arithmetic comparisons M3assoc := table() every i := 1 to *ops by 2 do { every M3prec[!ops[i+1]] := i M3assoc[i] := ops[i] } #line 9 "M3exp.nw" } /precedence := 0 /associativity := "L" return case type(e) of { #line 20 "M3exp.nw" "list" : commaseparate(maplist2(prettyM3, e, M3prec[","]), ", $o") "set" : commaseparate(maplist2(prettyM3, sort(e), M3prec["AND"]), " AND $o") "eqn" : { o := M3op(e.op) M3bracket(prettyM3(e.left, M3prec[o]) || " " || o || " $o" || prettyM3(e.right, M3prec[o]), "=", precedence) } "table" : { # standard normal form #line 37 "M3exp.nw" { s := ""; leadingsign := "" #line 45 "M3exp.nw" every e[k := 1 ~=== key(e)] > 0 do { s ||:= leadingsign s ||:= (1 ~= abs(e[k])) || "*" # print coefficient if not 1 s ||:= prettyM3(k, M3prec["*"]) leadingsign := " + $o" } if e[1] > 0 then s ||:= leadingsign || string(e[1]) #line 40 "M3exp.nw" leadingsign := " - $o" #line 53 "M3exp.nw" every e[k := 1 ~=== key(e)] < 0 do { s ||:= leadingsign s ||:= (1 ~= abs(e[k])) || "*" # print coefficient if not 1 s ||:= prettyM3(k, M3prec["*"]) } if e[1] < 0 then s ||:= leadingsign || string(-e[1]) #line 42 "M3exp.nw" s := if s == "" then "0" else M3bracket(s, "+", precedence) } #line 28 "M3exp.nw" "$t${" || s || "$}$b" } "string" : if e == "$pc" then "$$pc" else e "literal" : list_to_string(e.s) "integer" : string(e) #line 76 "M3exp.nw" "Eorb" : "Word.Or(${$t$c" || prettyM3(e.x) || ", $c" || prettyM3(e.y) || "$b$})" "Eand" : { s := prettyM3(e.x, M3prec["AND"], "L") t := prettyM3(e.y, M3prec["AND"], "R") M3bracket(s || " AND $o" || t, "AND", precedence) } #line 82 "M3exp.nw" "Eslice" : "Word.Extract(${$t$c" || prettyM3(e.x) || ", $c" || e.lo || ", " || e.n || "$b$})" "Eshift" : "Word.Shift(${$t$c" || prettyM3(e.x) || ", $c" || e.n || "$b$})" #line 86 "M3exp.nw" "Enarrowu" : prettyM3(e.x, precedence, associativity) # checked, so must be identity "Enarrows" : prettyM3(super_simplify(Eslice(e.x, 0, e.n)), precedence, associativity) "Ewiden" : "Word.Insert(${$t$c" || prettyM3(e.x) || ", $cMATCH_bits[" || prettyM3(super_simplify(Eslice(e.x, e.n-1, 1))) || "], $c" || e.n || ", $cWord.Size - " || e.n || "$b$})" #line 93 "M3exp.nw" "Ediv" : { s := prettyM3(e.x, M3prec["DIV"]) s ||:= " DIV " || e.n M3bracket(s, "DIV", precedence) } "Emod" : { s := prettyM3(e.x, M3prec["MOD"]) s ||:= " MOD " || e.n M3bracket(s, "MOD", precedence) } #line 102 "M3exp.nw" "Semit" : { s := emittername || "$t(" || prettyM3(e.x, M3prec[","]) || ", $o" || e.n || ");$b" M3bracket("$c" || s, "app", precedence) } #line 107 "M3exp.nw" "Efitsu" : "Word.LT(${$t$c" || prettyM3(e.x) || ", $c" || (2^e.n) || "$b$})" "Efitss" : "Word.LT(${$t$c" || prettyM3(addconst(e.x, 2^(e.n-1))) || ", $c" || (2^e.n) || "$b$})" #line 111 "M3exp.nw" "Eforce" | "Eforceable" : { z := if type(e) == "Eforceable" then "_known" else "" case s := prettyM3(e.x) of { "$$pc" : "RBlocks.cur_pc" || z || "()" "_c->loc" : "RBlocks.pc_location" || z || "(_c.loc)" default : "RBlocks.location" || z || "$t${(" || s || ")$}$b" } } #line 120 "M3exp.nw" "Enot" : { s := "NOT " || prettyM3(e.x, M3prec["NOT"]) M3bracket(s, "NOT", precedence) } #line 124 "M3exp.nw" "Enosimp" : prettyM3(e.x, precedence, associativity) #line 126 "M3exp.nw" "Sstmts" : "${" || commaseparate(maplist2(prettyM3, e.x), " $c") || "$}" #line 128 "M3exp.nw" "Gcall" : { l := []; every put(l, prettyM3(!e.args)) M3noreserve(e.name) || "(" || commaseparate(l) || ")" } "Einstance_input" : { s := "NARROW(" || prettyM3(e.x) || ", Encode." || e.cons.name || "Instance)." || e.name M3bracket(s, ".", precedence) } "Einstance_tagged" : { s := "ISTYPE(" || prettyM3(e.x) || ", Encode." || e.cons.name || "Instance)" M3bracket(s, "app", precedence) } #line 145 "M3exp.nw" "Sif" : { ifword := "IF " s := "" every a := !e.arms do { s ||:= ifword || M3test(a.guard) || "$t$c" || prettyM3(a.x) || "$b" ifword := "$cELSIF " } "${" || s || " $cEND;$}" } #line 154 "M3exp.nw" "Efail" : error("Generate-time operation failed: ", e.msg) #line 161 "M3exp.nw" "Stagcase" : { s := "TYPECASE " || prettyM3(e.x) || " OF$t${" every c := kept_constructors(e.type) do s ||:= "$n| Encode." || c.name || "Instance => $o$t${" || prettyM3(e.arms[c]) || "$}$b" s || "$nELSE <* ASSERT FALSE *>$}$b$nEND; (* " || prettyM3(e.x) || "*)" } #line 168 "M3exp.nw" "Sfail" : { s := "fail($t${" || image(escape_dollars(e.fmt)) every a := e.a1 | e.a2 | e.a3 do s ||:= ", $o" || prettyM3(\a, M3prec[","]) s ||:= "$}$b);" M3bracket(s, "app", precedence) } "Sepsilon" : "(* skip *)" #line 176 "M3exp.nw" "Sclosure" : prettyM3(\e.creation) | impossible("creating closure") #line 178 "M3exp.nw" "Glines" : { s := ""; every s ||:= prettyM3(!e.x) || "\n"; s } "Gresynch" : "<* LINE " || e.line || " " || image(\e.file | "generated-code") || "*>" #line 181 "M3exp.nw" "Gblock" : { s := "${" every s ||:= prettyM3(!e.decls) || ";$n" if *e.decls > 0 then s ||:= "BEGIN ${$t$c" s ||:= commaseparate(maplist(prettyM3, e.stmts), "$c") if *e.decls > 0 then s ||:= "$b$cEND$}" s || "$}" } "Gdecl" : { s := "VAR ${" || e.name s ||:= " : " || prettyM3(\e.type) s ||:= " := $t$c" || prettyM3(\e.init) || "$b" s || "$}" } #line 196 "M3exp.nw" "Gdeclnamearray" : { /na_count := 0 /e.na.codename := "MATCH_name_" || e.na.field.field.name || "_" || (na_count +:= 1) s := "CONST ${" || e.na.codename || " = ARRAY [0.." || (e.na.hi - 1) || "] OF TEXT {" s ||:= "${$t" every i := 0 to e.na.hi - 1 do { s ||:= " $c" || (image(\e.na.tbl[i])|"NIL") if i < e.na.hi - 1 then s ||:= "," } s || "$b$c$}}" } #line 210 "M3exp.nw" "Gcase" : { s := "CASE ${" || prettyM3(e.x) || "$} OF " every s ||:= prettyM3(!e.arms) "${" || s || "$nEND; (* CASE ${" || prettyM3(e.x) || "$} *)$}" } "Gcasearm" : { s := "$n| $t" every i := 1 to *e.tags by 2 do { if i > 1 then s ||:= ", $o" s ||:= if e.tags[i] + 1 = e.tags[i+1] then e.tags[i] else e.tags[i] || ".." || (e.tags[i+1]-1) } s ||:= " => " || "$t$c" || prettyM3(e.x) "${" || s || "$b$b$}" } #line 224 "M3exp.nw" "Ginrange" : { x := prettyM3(e.x, M3prec["<"]) if e.lo + 1 = e.hi then { M3bracket(x || " = " || e.lo, "=", M3prec["AND"]) } else { c1 := M3bracket(e.lo || " <= " || x, "<=", M3prec["AND"]) c2 := M3bracket(x || " < " || e.hi, "<", M3prec["AND"]) M3bracket(c1 || " AND " || c2, "AND", precedence) } } "Gsetname" : "${VAR " || e.lhs || " := $t$o" || case type(e.name) of { "string" : image(e.name) "namearray" : e.name.codename || "[" || prettyM3(e.name.field) || "]" default : impossible("type of node name field") } || "$b$}" "Gasgn" : "${" || e.lhs || " := $t$o" || prettyM3(e.x, M3prec["="]) || ";$b$}" "Gcomment" : "(* " || e.s || " *)" "Gcommented" : prettyM3(e.e, precedence, associativity, nohex) || " (* " || e.comment || " *)" #line 243 "M3exp.nw" "Gnomatch" : "<* ASSERT FALSE *> (* no match *)" "Tunsigned" : if \e.width < wordsize then "[0.." || (2^e.width-1) || "]" else "Word.T" #line 249 "M3exp.nw" "absolute_field" : prettyM3(super_simplify(afieldexp(e)), precedence, associativity, nohex) #line 14 "M3exp.nw" default : impossible("Bad code to prettyM3") } end #line 156 "M3exp.nw" procedure M3test(guard) return if guard_always_satisfied(guard) then "TRUE THEN " else "$t${" || prettyM3(guard) || "$}$b THEN " end #line 252 "M3exp.nw" global M3prec, M3assoc procedure M3bracket(s, op, p, a) /a := "L" return "${" || (if M3prec[op] > p | (M3prec[op] = p & M3assoc[p] == a) then s else "(" || s || ")") || "$}" end #line 281 "M3exp.nw" procedure M3op(op) return if op == "!=" then "#" else op end #line 285 "M3exp.nw" procedure M3noreserve(word) static reserved initial reserved := set([ "AND", "ANY", "ARRAY", "AS", "BEGIN", "BITS", "BRANDED", "BY", "CASE", "CONST", "DIV", "DO", "ELSE", "ELSIF", "END", "EVAL", "EXCEPT", "EXCEPTION", "EXIT", "EXPORTS", "FINALLY", "FOR", "FROM", "GENERIC", "IF", "IMPORT", "IN", "INTERFACE", "LOCK", "LOOP", "METHODS", "MOD", "MODULE", "NOT", "OBJECT", "OF", "OR", "OVERRIDES", "PROCEDURE", "RAISE", "RAISES", "READONLY", "RECORD", "REF", "REPEAT", "RETURN", "REVEAL", "ROOT", "SET", "THEN", "TO", "TRY", "TYPE", "TYPECASE", "UNSAFE", "UNTIL", "UNTRACED", "VALUE", "VAR", "WHILE", "WITH"]) return if member(reserved, word) then M3noreserve(word||"_") else word end #line 301 "M3exp.nw" procedure Generate_M3() eqntoC := eqntoM3 pretty := prettyM3 gen_outer_decls := [literal( "CONST MATCH_bits = ARRAY [0..1] OF Word.T {0, Word.Not(0)}")] gen_file_header := "" fetchtab["type"] := "ADDRESS" fetchtab["add"] := "LOOPHOLE(%a+%o, Word.T)" fetchtab["pc"] := "%a" # fetchtab[8] := "LOOPHOLE(%a+(%o/ADRSIZE(CHAR)), UNTRACED REF [0..255])^" # fetchtab[16] := "LOOPHOLE(%a+(%o/ADRSIZE(CHAR)), UNTRACED REF [0..65535])^" # fetchtab[32] := "LOOPHOLE(%a+(%o/ADRSIZE(CHAR)), UNTRACED REF INTEGER)^" end #================================================================= Iconexp.icn #line 7 "Iconexp.nw" procedure prettyIcon(e, precedence, associativity, nohex) #line 75 "Iconexp.nw" local leadingsign #line 149 "Iconexp.nw" local save_pc_override #line 257 "Iconexp.nw" static na_count #line 9 "Iconexp.nw" initial { #line 303 "Iconexp.nw" ops := ["N", ["low"], "L", [","], "L", ["&"], "L", ["?"], "L", [":=","<-",":=:","<->"], "L", ["to"], "L", ["|"], "L", ["<","<=","=",">=",">","~=","<<","<<=","==",">>=",">>","~==","===","~==="], "L", ["||","|||"], "L", ["++","--"], "L", ["+","-"], "L", ["*","/","%","**"], "L", ["^"], "L", ["\\","@","!"], "N", ["not"], "N", ["app"], "N", ["high"] ] Iconprec := table([]) # missed lookups break arithmetic comparisons Iconassoc := table() every i := 1 to *ops by 2 do { every Iconprec[!ops[i+1]] := i Iconassoc[i] := ops[i] } #line 9 "Iconexp.nw" } /precedence := 0 /associativity := "L" return case type(e) of { #line 19 "Iconexp.nw" "Gcomment" : "# " || e.s || "\n" "list" : commaseparate(maplist2(prettyIcon, e, Iconprec[","]), ", $o") "set" : commaseparate(maplist2(prettyIcon, sort(e), Iconprec["&"]), " & $o") "eqn" : { o := Iconop(e.op) Iconbracket(prettyIcon(e.left, Iconprec[o]) || " " || o || " $o" || prettyIcon(e.right, Iconprec[o]), "=", precedence) } "table" : { # standard normal form #line 37 "Iconexp.nw" { s := ""; leadingsign := "" #line 45 "Iconexp.nw" every e[k := 1 ~=== key(e)] > 0 do { s ||:= leadingsign s ||:= (1 ~= abs(e[k])) || "*" # print coefficient if not 1 s ||:= prettyIcon(k, Iconprec["*"]) leadingsign := " + $o" } if e[1] > 0 then s ||:= leadingsign || string(e[1]) #line 40 "Iconexp.nw" leadingsign := " - $o" #line 53 "Iconexp.nw" every e[k := 1 ~=== key(e)] < 0 do { s ||:= leadingsign s ||:= (1 ~= abs(e[k])) || "*" # print coefficient if not 1 s ||:= prettyIcon(k, Iconprec["*"]) } if e[1] < 0 then s ||:= leadingsign || string(-e[1]) #line 42 "Iconexp.nw" s := if s == "" then "0" else Iconbracket(s, "+", precedence) } #line 28 "Iconexp.nw" "$t${" || s || "$}$b" } "string" : e "literal" : list_to_string(e.s) "integer" : if e > max_decimal then "16r" || hexstring(e) else string(e) #line 77 "Iconexp.nw" "Eorb" : { s := prettyIcon(e.x, Iconprec[","], "L") t := prettyIcon(e.y, Iconprec[","], "R") "ior(" || s || ", $o" || t || ")" } "Eand" : { s := prettyIcon(e.x, Iconprec["&"], "L") t := prettyIcon(e.y, Iconprec["&"], "R") Iconbracket(s || " & $o" || t, "&", precedence) } #line 86 "Iconexp.nw" "Eslice" : { s := prettyIcon(super_simplify(Eshift(e.x, -e.lo)), Iconprec[","], "L") "iand(" || s || ", " || mask(e.n) || ")" } "Eshift" : { "ishift(" || prettyIcon(e.x, Iconprec[","]) || ", " || e.n || ")" } #line 91 "Iconexp.nw" "Enarrowu" : prettyIcon(e.x, precedence, associativity) # checked, so must be identity "Enarrows" : prettyIcon(super_simplify(Eslice(e.x, 0, e.n)), precedence, associativity) "Ewiden" : "sign_extend($t${$o" || prettyIcon(e.x) || ", $o" || e.n || "$}$b)" #line 95 "Iconexp.nw" "Ediv" : { s := prettyIcon(e.x, Iconprec["/"]) s := "integer(" || s || ")" s ||:= " / " || e.n Iconbracket(s, "/", precedence) } "Emod" : { s := prettyIcon(e.x, Iconprec["%"]) s ||:= " % " || e.n Iconbracket(s, "%", precedence) } #line 107 "Iconexp.nw" "Semit" : if *e.x = 0 then "{ \"emit epsilon\" }" else { s := if *e.x > 1 then "$t${{ $c" else "" #line 141 "Iconexp.nw" if *e.x > 1 & emitterstyle == "direct" & expwalk(e.x[2:0], equals_pc) then { s ||:= "ENCODE_pc = cur_pc(); $c" save_pc_override := pc_override pc_override := "ENCODE_pc" } #line 111 "Iconexp.nw" s ||:= commaseparate(maplist(prettyIcon, e.x), " $n") #line 147 "Iconexp.nw" pc_override := save_pc_override #line 113 "Iconexp.nw" s || if *e.x > 1 then " $b$c}$}" else "" } "Stoken" : case emitterstyle of { "direct" : { #line 122 "Iconexp.nw" if e.n = 1 then s := "_result ||:= char(" || prettyIcon(e.x, Iconprec[","]) || ")" else error("Internal limitation: Can't emit other than 1-byte tokens when generating Icon code") #line 117 "Iconexp.nw" } "closure": { #line 129 "Iconexp.nw" error("Internal limitation: No closure support in Icon emitter") o := if e.offset > 0 then " + " || e.offset else "" s := "emitter$t(_c->loc.dest_block, $o_c->loc.dest_lc" || o || ", $o" || prettyIcon(e.x, Iconprec[","]) || ", $o" || e.n || ")" Iconbracket("$c" || s, "app", precedence) || ";$b" #line 118 "Iconexp.nw" } } | impossible("emitter style") #line 151 "Iconexp.nw" "Epc" : \pc_override | "cur_pc()" "Epc_known" : "cur_pc_known()" #line 154 "Iconexp.nw" "Eclosure_loc" : "_c.loc" "Eclosure_addr" : "_c.v.a" || e.n "Eclosure_val" : "_c.v.u" || e.n #line 161 "Iconexp.nw" "Efitsu" : prettyIcon(Ginrange(0, e.x, 2^e.n), precedence, associativity) "Efitss" : prettyIcon(Ginrange(-2^(e.n-1), e.x, 2^(e.n-1)), precedence,associativity) #line 164 "Iconexp.nw" "Eforce" | "Eforceable" : { error("no relocation support in Icon") (if type(e.x) == "Eclosure_loc" then "pc_" else "") || "location" || (if type(e) == "Eforceable" then "_known" else "") || "$t${(" || prettyIcon(e.x) || ")$}$b" } #line 172 "Iconexp.nw" "Enot" : { s := "not " || prettyIcon(e.x, Iconprec["not"]) Iconbracket(s, "not", precedence) } #line 176 "Iconexp.nw" "Enosimp" : prettyIcon(e.x, precedence, associativity) #line 178 "Iconexp.nw" "Sstmts" : "$t${{ $c" || commaseparate(maplist2(prettyIcon, e.x), " $n") || " $b$c}$}" #line 180 "Iconexp.nw" "Gcall" : { l := []; every put(l, prettyIcon(!e.args)) Cnoreserve(e.name) || "(" || commaseparate(l) || ")" } #line 184 "Iconexp.nw" "Einstance_input" : { s := prettyIcon(e.x, Iconprec["."]) || "." || e.name Iconbracket(s, ".", precedence) } "Einstance_tagged" : { s := "type(" || prettyIcon(e.x, Iconprec["."]) || " == " || image(e.cons.name) Iconbracket(s, "==", precedence) } #line 197 "Iconexp.nw" "Sif" : { preif := "" s := "" every a := !e.arms do { s ||:= preif || Icontest(a.guard) || Iconarm(a.x) preif := "$nelse " } "${" || s || "$}" } #line 206 "Iconexp.nw" "Efail" : error("Generate-time operation failed: ", e.msg) #line 218 "Iconexp.nw" "Stagcase" : { s := "case type(" || prettyIcon(e.x, Iconprec["."]) ||") of {$t${" every c := kept_constructors(e.type) do s ||:= "$n " || image(c.name) || " : {$t$c${" || prettyIcon(e.arms[c]) || " $c}$}$b" s || "$ndefault: &null+1$}$b$c} # " || prettyIcon(e.x) || "\n" } #line 225 "Iconexp.nw" "Sfail" : { s := "fail($t${" || image(escape_dollars(e.fmt)) every a := e.a1 | e.a2 | e.a3 do s ||:= ", $o" || prettyIcon(\a, Iconprec[","]) s ||:= "$}$b);" Iconbracket(s, "app", precedence) } "Sepsilon" : "{ \"skip\" }" #line 233 "Iconexp.nw" "Sclosure" : prettyIcon(\e.creation) | impossible("creating closure") #line 235 "Iconexp.nw" "Glines" : { s := ""; every s ||:= prettyIcon(!e.x) || "\n"; s } "Gresynch" : "$n#line " || e.line || " " || image(\e.file | "generated-code") #line 238 "Iconexp.nw" "Gblock" : { s := "{ ${$t$c" every s ||:= prettyIcon(!e.decls) || "$n" s ||:= commaseparate(maplist(prettyIcon, e.stmts), "$n") s || "$b $c}$}" } "Gdecl" : "${ " || e.name || " := $t$c" || prettyIcon(\e.init) || "$b$}" #line 245 "Iconexp.nw" "Gdeclnamearray" : { error("no name arrays in Icon") /na_count := 0 /e.na.codename := "MATCH_name_" || e.na.field.field.name || "_" || (na_count +:= 1) /e.na.storageclass := "static" s := e.na.storageclass || " char *" || e.na.codename || "[] = {" s ||:= "${$t" every i := 0 to e.na.hi - 1 do s ||:= " $c" || image(\e.na.tbl[i]|0) || "," s || "$b $c$}}" } #line 259 "Iconexp.nw" "Gsetname" : error("no name arrays in Icon") #line 261 "Iconexp.nw" "Gcase" : { s := "case " || prettyIcon(e.x) || " of {$t${ " every s ||:= prettyIcon(!e.arms) s || "$ndefault: &null+1$}$b$c} # " || prettyIcon(e.x) || "\n" } "Gcasearm" : { s := "$n" every i := 1 to *e.tags by 2 do { if e.tags[i] + 1 = e.tags[i+1] then s ||:= "$n " || e.tags[i] || ": " else { every s ||:= "$n " || (e.tags[i] to (e.tags[i+1]-1)) || " | " s ||:= "&fail : " } } s ||:= "{$t$c${" || prettyIcon(e.x) || " $}$b}" } #line 277 "Iconexp.nw" "Ginrange" : { x := prettyIcon(e.x, Iconprec["<"]) if e.lo + 1 = e.hi then { Iconbracket(x || " = " || e.lo, "=", precedence) } else { Iconbracket(e.lo || " <= " || x || " < " || e.hi, "=", precedence) } } "Gsetname" : error("no setname ion Icon") "Gasgn" : "${" || prettyIcon(e.lhs) || " := $t$o" || prettyIcon(e.x, Iconprec[":="]) || "$b$}" #line 287 "Iconexp.nw" "Gnomatch" : "&null+1 /* no match */$n" "Tunsigned" : error("no types in Icon") "Tsigned" : error("no types in Icon") #line 292 "Iconexp.nw" "absolute_field" : prettyIcon(super_simplify(Eslice(literal(wordname(e)), e.field.lo, fwidth(e.field))), precedence, associativity, nohex) #line 14 "Iconexp.nw" default : impossible("Bad code to prettyIcon") } end #line 158 "Iconexp.nw" global pc_override #line 208 "Iconexp.nw" procedure Icontest(guard) return if guard_always_satisfied(guard) then "" else "if $t${" || prettyIcon(guard) || " then$}$b " end #line 213 "Iconexp.nw" procedure Iconarm(e) return if type(e) == ("Gblock"|"Sstmts") then prettyIcon(e) || " " else "$t$c${" || prettyIcon(e) || "$}$b " end #line 296 "Iconexp.nw" global Iconprec, Iconassoc procedure Iconbracket(s, op, p, a) /a := "L" return "${" || (if Iconprec[op] > p | (Iconprec[op] = p & Iconassoc[p] == a) then s else "(" || s || ")") || "$}" end #line 329 "Iconexp.nw" procedure Iconop(op) return if op == "!=" then "~=" else op end #line 336 "Iconexp.nw" procedure Generate_Icon() pretty := prettyIcon hex_prefix := "16r" gen_outer_decls := [] gen_file_header := [] fetchtab["type"] := "bogus"; fetchtab["add"] := "((%a) + %o)" fetchtab["integer"] := "(bogus)(%a)" end #============================================================ constructors.icn #line 25 "constructors.nw" record constructor(name, opcode, operands, type, branches, rho, tag, original_name) record branch(eqns, soln, pat) record constype(name, members, used, ntags) #line 47 "constructors.nw" procedure note_constructor(opcode, operands, type, branches) local cons, template #line 250 "constructors.nw" if \type.used then error("You can't create new constructors of type ", type.name, "!\n\tThat name has already been used (on line", type.used, ")") #line 51 "constructors.nw" template := constemplate(type, opcode, operands, branches) every cons := explode(opcode, template, globals) do { if /constructors[cons.name] := cons then { verbose("New constructor ", cons.name) put(conslist, cons) insert(type.members, cons) #line 254 "constructors.nw" if /checked then { checked := 1 #line 259 "constructors.nw" every i := 1 to *cons.branches & b := cons.branches[i] do { u := copy(b.soln.used) every insert(u, pattern_free_variables(b.pat)) d := copy(b.soln.defined) every insert(d, key(cons.rho[1 to *cons.rho - 1]) | inputs_of(cons).name) every x := !(d--u--fresh_variables) do warning( if \cons.rho[1 to *cons.rho-1][x] then "opcode part" else if member(b.soln.defined, x) then "equation result" else "operand", " ", image(x), " not used in constructor ", cons.name, if (*cons.branches = 1) then "." else " in " || ordinal(i) || " branch.") } #line 257 "constructors.nw" } #line 58 "constructors.nw" } else if *crhs(constructors[cons.name]).disjuncts = 0 then { verbose("Replacing vacuous constructor ", cons.name) constructors[cons.name] := cons put(conslist, cons) insert(type.members, cons) #line 254 "constructors.nw" if /checked then { checked := 1 #line 259 "constructors.nw" every i := 1 to *cons.branches & b := cons.branches[i] do { u := copy(b.soln.used) every insert(u, pattern_free_variables(b.pat)) d := copy(b.soln.defined) every insert(d, key(cons.rho[1 to *cons.rho - 1]) | inputs_of(cons).name) every x := !(d--u--fresh_variables) do warning( if \cons.rho[1 to *cons.rho-1][x] then "opcode part" else if member(b.soln.defined, x) then "equation result" else "operand", " ", image(x), " not used in constructor ", cons.name, if (*cons.branches = 1) then "." else " in " || ordinal(i) || " branch.") } #line 257 "constructors.nw" } #line 64 "constructors.nw" } else if *crhs(cons).disjuncts = 0 then { verbose("Ignoring extra, vacuous constructor ", cons.name) } else { warning("Ignoring duplicate definition of constructor ", cons.name) # PPxwrite(PPnew(&errout), # "Keeping $t$o", ppexpimage(crhs(constructors[cons.name])), "$b$n", # "Discarding $t$o", ppexpimage(crhs(cons)), "$b") } } return end #line 88 "constructors.nw" procedure constemplate(type, opcode, operands, branches) local inputs, inputs_labs #line 112 "constructors.nw" inputs := set() every i := inputs_of_operands(operands) do if member(inputs, i.name) then error("Input named ", i.name, " is used twice in one constructor") else insert(inputs, i.name) #line 91 "constructors.nw" B := [] every b := !branches do { # b === [eqns, pat] #line 123 "constructors.nw" if \b[2] then { inputs_labs := copy(inputs) every labname := pattern_label_names(b[2]) do if member(inputs, labname) then error("label name ", labname, ": conflicts with constructor input name") else insert(inputs_labs, labname) } else { inputs_labs := inputs } #line 94 "constructors.nw" put(B, branch(b[1], inject_soln(solve(balance_eqns(b[1]), inputs_labs)), \b[2] | implicit_pattern(opcode, operands))) } return constructor(&null, &null, operands, type, B, &null, &null, &null) end #line 104 "constructors.nw" procedure instantiate_template(op, t, rho) /t.type.ntags := 0 t.type.ntags +:= 1 #line 275 "constructors.nw" if t.type.ntags >= 2^11 then impossible("Too many type tags --- change mclib.nw (struct instance), constructors.nw") #line 108 "constructors.nw" return constructor(iname(op), op, t.operands, t.type, t.branches, rho, t.type.ntags, iname(op, 1)) end #line 140 "constructors.nw" procedure explode(opcode, template, rho, frame) /frame := table() l := copy(opcode) if type(p := l[i := 1 to *l]) == "pattern" then { every l[i] := !p.disjuncts do { add_to_frame(p.name, pattern([l[i]], \l[i].name | p.name), frame) suspend explode(l, template, rho, frame) delete(frame, p.name) } } else if type(f := l[i := 1 to *l]) == "field" then { t := fieldname_table(f); #line 161 "constructors.nw" *\t > 0 | error("Can't use field `", f.name, "' in opcode without supplying field names") #line 151 "constructors.nw" every x := t[l[i] := key(t)] do { add_to_frame(f.name, inject(conspat(f, "=", x), x, &null), frame) suspend explode(l, template, rho, frame) delete(frame, f.name) } } else suspend instantiate_template(l, template, extendscope(rho, copy(frame))) end #line 185 "constructors.nw" procedure explode_names(opcode, rho) l := copy(opcode) if type(p := l[i := 1 to *l]) == "pattern" then { if l[i] := \lookup(p.name, \rho) then suspend explode_names(l) else every l[i] := !p.disjuncts do { suspend explode_names(l) } } else if type(f := l[i := 1 to *l]) == "field" then { t := fieldname_table(f); #line 161 "constructors.nw" *\t > 0 | error("Can't use field `", f.name, "' in opcode without supplying field names") #line 195 "constructors.nw" every x := t[l[i] := key(t)] do suspend explode_names(l) } else suspend iname(l) end #line 204 "constructors.nw" procedure implicit_pattern(opcode, operands) l := [] every op := !opcode do case type(op) of { "pattern" : put(l, Pident(\op.name)) | impossible("unnamed opcode pattern") "field" : put(l, Pident(op.name)) } every ipt := inputs_of_operands(operands) do if type(ipt.meaning) == ("field"|"integer"|"constype") then put(l, Pident(ipt.name)) *l > 0 | error("Cannot use implicit pattern with no patterns or fields on lhs (", expimage(opcode), ")") return Pand(l) end #line 222 "constructors.nw" procedure iname(opcode, nomap) local name name := "" every name ||:= opcode_component_name(!opcode) if \lowercons then name := map(name) return if /nomap then mapoutbadchars(name) else name end procedure opcode_component_name(op) return case type(op) of { "string" : op "disjunct" : { if *\op.name = 0 then impossible("disjunct with empty name") \op.name | "???unnamed disjunct???" } default : impossible("opcode component", image(op)) } end #line 241 "constructors.nw" procedure mapoutbadchars(name) static nonalnum, underscores initial { nonalnum := string(&ascii -- &letters -- &digits -- '_') underscores := repl("_", *nonalnum) } return map(name, nonalnum, underscores) end #line 288 "constructors.nw" procedure inputs_of(cons, t) suspend inputs_of_operands(cons.operands, t) end procedure inputs_of_operands(ops, t) type(ops) == "list" | impossible("inputs_of") suspend if \t then (type(i := !ops) == "input", type(i.meaning) == t, i) else (type(i := !ops) == "input", i) end #line 299 "constructors.nw" procedure input_named(cons, n) return if i := inputs_of(cons) & i.name == n then i end #line 307 "constructors.nw" procedure enforce_instance(ct) return instructionctype ~=== ct | impossible("instance of untyped constructor") end #line 311 "constructors.nw" procedure enforce_closure(ct) return instructionctype === ct | impossible("closure of typed constructor") end #line 320 "constructors.nw" procedure cons_named(s) return is_constructor(s, error) end procedure is_constructor(s, p) return \constructors[s | iname([s])] | (\p)(image(s), " is not a constructor name") end #line 327 "constructors.nw" procedure discard_cons_named(s) if member(constructors, s <- (s | iname([s]))) then delete(constructors, s) else warning("There is no constructor named ", s) return end #line 335 "constructors.nw" procedure ordinal(n) return case n of { 1 : "1st" 2 : "2nd" 3 : "3rd" default : n || "th" } end #line 358 "constructors.nw" procedure crhs(cons) local rho, labrho static cache initial cache := table() if /cache[cons] then { #line 368 "constructors.nw" rho := newscope(cons.rho) every ipt := inputs_of(cons) do case type(ipt.meaning) of { "constype" : add_to_rho(ipt.name, inject(consinput_pattern(ipt), &null, ipt), rho) "field" | "integer" : add_to_rho(ipt.name, inject(fieldinput_pattern(ipt), ipt.name, &null), rho) "string"| "null" : add_to_rho(ipt.name, inject(&null, ipt.name, &null), rho) default : impossible("input type") } p := &null every b := !cons.branches do { #line 406 "constructors.nw" push(rho, b.soln.answers) # answers already injected by inject_soln t := table() every n := pattern_label_names(b.pat) do t[n] := n push(rho, t) q := freshen_disjuncts(pnf(b.pat, rho)) pop(rho) pop(rho) every bind_condition(q, !b.soln.constraints) q := bind_and_remove_patlabel_names(q) #line 382 "constructors.nw" p := orp(\p, q) | q } cache[cons] := subst(eliminate_contradictions(p), "nonexistent variable", 0) # can't afford to simplify -- makes it too hard to solve eqns # subst eliminates bad tag conditions #line 363 "constructors.nw" PPxwrite(PPnew(\mdebug), "crhs for ", cons.name, " is ", ppexpimage(cache[cons])) } return cache[cons] end #line 418 "constructors.nw" procedure inject_soln(soln) every k := key(soln.answers) do if type(symtab[k]) == "field" then soln.answers[k] := inject(constraints2pattern(fieldbinding(symtab[k], soln.answers[k])), soln.answers[k], &null) return soln end #line 430 "constructors.nw" procedure consinput_pattern(ipt) type(ipt.meaning) == "constype" | impossible("non-constructor input") return subst(constype_pattern(ipt.meaning), ipt.meaning.name, ipt.name) end #line 438 "constructors.nw" procedure constype_pattern(constype) local cons, luid static cache, uid initial { cache := table(); uid := 0 } if /cache[constype] then { #line 454 "constructors.nw" p := &null uid +:= 1 # one uid per constype??? will fail with multiple args of some constype luid := uid every cons := kept_constructors(constype) do { t := table() # substitution table to get inputs from instance every ipt := inputs_of(cons) do { t[ipt.name] := Einstance_input(constype.name, cons, ipt.name) if type(ipt.meaning) == "string" then t[ipt.name] := Eforce(t[ipt.name]) # ???? could this be right? } q := freshen_disjuncts(subst_tab(crhs(cons), t, 1)) bind_condition(q, Einstance_tagged(constype.name, cons, luid)) p := orp(\p, q) | q } p := seqpx(latent_label2pattern(constype.name), p) # label will be used for binding instances later on! cache[constype] := p # can't afford to simplify -- makes it too hard to solve eqns #line 442 "constructors.nw" } return cache[constype] end #line 474 "constructors.nw" procedure fieldinput_pattern(ipt) type(symtab[ipt.name]) == "field" | impossible("input name is not field name") type(ipt.meaning) == ("field"|"integer") | impossible("non-field input") return constraints2pattern(fieldbinding(symtab[ipt.name], ipt.name)) end #line 486 "constructors.nw" procedure apply_constructor(cons, args, rho, free_env) local inputs, c, l pushtrace("APPCONS") inputs := []; every put(inputs, inputs_of(cons)) #line 653 "constructors.nw" *inputs = *args | error(cons.name, " expects ", *inputs, " arguments, but you gave ", *args) #line 491 "constructors.nw" t := argtable(inputs, args, rho, free_env) p := freshen_patlabels(subst_tab(crhs(cons), t, 1)) # can't afford to simplify every p.name | /(!p.disjuncts).name := cons.name # overwrite pattern name always, but only default disjuncts PPxwrite(PPnew(\mdebug), "applied ", cons.name, " to get ",ppexpimage(p)) poptrace() return p end #line 517 "constructors.nw" procedure app_to_instance(cons, args, rho, free_env) local inputs inputs := []; every put(inputs, inputs_of(cons)) #line 653 "constructors.nw" *inputs = *args | error(cons.name, " expects ", *inputs, " arguments, but you gave ", *args) #line 521 "constructors.nw" return Einstance(cons, argtable(inputs, args, rho, free_env)) end #line 527 "constructors.nw" procedure argtable(inputs, args, rho, free_env) t := table() every ipt := inputs[i := 1 to *args] do t[ipt.name] := case type(ipt.meaning) of { "constype" : #line 592 "constructors.nw" case type(x := untable(args[i])) of { "Papp" : impossible("Papp as constructor arg") "Eapp" : if c := cons_named(x.f) & c.type === ipt.meaning then app_to_instance(c, x.args, rho, free_env) else badarg(args, i, ipt, "constructor of type " || ipt.meaning.name || "; denotes " || c.type.name || ")") "string" : (if is_defined(x, rho) then if x := project(lookup(x, rho), "consop") then if type(x) == "input" then if x.meaning === ipt.meaning then ipt.name # stands for an instance, not a pattern else badarg(args, i, ipt, " constructor of type " || ipt.meaning.name || " (not " || x.meaning.name || ")") else impossible("consop projected into non-input") else if lookup(x, rho) === ipt.meaning then #line 623 "constructors.nw" if \free_env then 1(y := Ebinding_instance(x, ipt.meaning, table()), if (/free_env[x] := binding_instance(y, ipt.meaning)) | (type(free_env[x]) == "binding_instance", type(free_env[x].val) == "Ebinding_instance", free_env[x].type === free_env[x].val.type === y.type) then &null else error("Can't re-use ", x, "; already used as ", type(free_env[x]), "(", expimage(free_env[x]), ")", "\n --- new value as ", type(y), "(", expimage(y), ") no good")) else &fail #line 614 "constructors.nw" else &fail else #line 623 "constructors.nw" if \free_env then 1(y := Ebinding_instance(x, ipt.meaning, table()), if (/free_env[x] := binding_instance(y, ipt.meaning)) | (type(free_env[x]) == "binding_instance", type(free_env[x].val) == "Ebinding_instance", free_env[x].type === free_env[x].val.type === y.type) then &null else error("Can't re-use ", x, "; already used as ", type(free_env[x]), "(", expimage(free_env[x]), ")", "\n --- new value as ", type(y), "(", expimage(y), ") no good")) else &fail #line 618 "constructors.nw" ) | badarg(args, i, ipt, " constructor of type " || ipt.meaning.name) default : impossible("argument to constructor") } #line 532 "constructors.nw" "integer" : #line 576 "constructors.nw" Enarrows(super_simplify(gsubst(args[i], signed_arg_f, rho, free_env, args, i, ipt)), ipt.meaning) #line 533 "constructors.nw" "field" | "string" | "null" : #line 556 "constructors.nw" super_simplify(gsubst(args[i], unsigned_arg_f, rho, free_env, args, i, ipt)) #line 535 "constructors.nw" default : impossible("input type") } return t end #line 558 "constructors.nw" procedure unsigned_arg_f(e, rho, free_env, args, i, ipt) local fieldrho return case type(e) of { "string" : { fieldrho := fieldname_env_for_ipt(ipt) ||| rho (if is_defined(e, fieldrho) & type(lookup(e, fieldrho)) ~== "field" then project(lookup(e, fieldrho), "integer") else new_binding_instance(e, e, "integer", \free_env) ) | badarg(args, i, ipt, "integer or field") } "literal" : project(lookup(e.s, fieldname_env_for_ipt(ipt)), "integer") | badarg(args, i, ipt, "integer or field") "Eapp" : error("Constructor application not allowed; expected integer or field") } end #line 579 "constructors.nw" procedure signed_arg_f(e, rho, free_env, args, i, ipt) return case type(e) of { "string" : (if is_defined(e, rho) & type(lookup(e, rho)) ~== "field" then project(lookup(e, rho), "integer") else new_binding_instance(e, e, "integer", \free_env) ) | badarg(args, i, ipt, "integer or field") "literal" : badarg(args, i, ipt, "integer or field") "Eapp" : error("Constructor application not allowed; expected integer or field") } end #line 647 "constructors.nw" procedure badarg(args, i, ipt, expected) error(expimage(args[i]), " [", image(args[i]), "]", " (", ordinal(i), " arg ", ipt.name, ") ", "does not denote ", if any('aeiou', expected) then "an " else "a ", expected) end #line 662 "constructors.nw" procedure eliminate_instances(e) return gsubst(e, eliminate_instances_f) end #line 718 "constructors.nw" procedure eliminate_instances_f(e) return eliminate_binding_instance_vars(do_eliminate_instances_f(e)) end procedure do_eliminate_instances_f(e) local the_answer static issued_warning pushtrace("ELIMINATE") the_answer := case type(e) of { "Einstance_input" : unwind_instance_inputs(e) "Einstance_tagged" : { e.x := gsubst(e.x, do_eliminate_instances_f) # simplify children bottom-up case type(e.x) of { "Ebinding_instance" : 1 "binding_instance_var" : 1 "Einstance" : if e.cons === e.x.cons then 1 else 0 default : e # don't let gsubst continue; we did it already } } "latent_patlabel" : { e.instance := gsubst(e.instance, do_eliminate_instances_f) # simplify bottom-up case type(e.instance) of { "Ebinding_instance" : patlabel(e.instance.name, e.instance.name) "string" : e # no change "binding_instance_var" : e # as with string (but should it be patlabel?) "Einstance_input" : { #line 761 "constructors.nw" /issued_warning := 1 & warning("Yes, Virginia, there are latent labels of instance inputs: ", expimage(e)) e # change nothing #line 743 "constructors.nw" } "Einstance" : vanishing_latent_patlabel "Efail" : Efail("latent pattern label of " || e.instance.msg) default : impossible("type of latent pattern label") } } } | {poptrace(); fail} poptrace() return the_answer end #line 780 "constructors.nw" record binding_instance_var(s) procedure eliminate_binding_instance_vars(e) return gsubst(e, eliminate_binding_instance_vars_f) end procedure eliminate_binding_instance_vars_f(e) if type(e) == "binding_instance_var" then return e.s end #line 806 "constructors.nw" procedure unwind_instance_inputs(e, postfix_name) /postfix_name := "" type(e) == "Einstance_input" | impossible("unwinding ", expimage(e), " : ", type(e)) postfix_name := "." || e.cons.name || "." || e.name || postfix_name return case type(e.x) of { "Ebinding_instance" : binding_instance_var( binding_instance_input_name(e.x.name || postfix_name, e.x.vart)) "Einstance" : if e.x.cons === e.cons then e.x.argt[e.name] else Efail(expimage(e)) "Einstance_input" : case type(x := unwind_instance_inputs(e.x, postfix_name)) of { "binding_instance_var" : x default : { e := Einstance_input(x, e.cons, e.name) unwind_instance_inputs(e, postfix_name) | e # guaranteed to terminate } } } end #line 827 "constructors.nw" procedure binding_instance_input_name(name, vart) /vart[name] := fresh_variable(name) return vart[name] end #line 836 "constructors.nw" record Stagcase(x, type, arms) # CASE x : type OF arms END #line 844 "constructors.nw" procedure pattern_to_case(p) #line 1181 "constructors.nw" if *p.disjuncts = 0 then error("Output pattern for constructor ", cons.name, " can never match anything.\n", "\tCould you have written a bad conjunction?") #line 846 "constructors.nw" return do_pattern_to_case(freshen_disjuncts(p)) end #line 867 "constructors.nw" procedure do_pattern_to_case(p) local rep # representative tag condition if rep := tag_test_in_every_disjunct(p) then { s := Stagcase(rep.x, rep.cons.type, table()) every s.arms[kept_constructors(s.type)] := pattern([]) every d := !p.disjuncts do { if type(c := !d.conditions) == "Einstance_tagged" & c.uid = rep.uid & exps_eq(rep.x, c.x) then { delete(d.conditions, c) put((\s.arms[c.cons]).disjuncts, d) } else impossible("Mislaid a tag condition on ", expimage(rep.x)) } every c := key(s.arms) do s.arms[c] := do_pattern_to_case(s.arms[c]) return s } else if rep := tag_test_in_any_disjunct(p) then { PPxwrite(PPnew(&errout), "Can't eliminate tag condition on ", ppexpimage(rep.x), " $t$ofrom pattern $c", ppexpimage(p)) impossible("Report a bug in the toolkit") } else return simplify(p) end #line 891 "constructors.nw" procedure tag_test_in_any_disjunct(p) suspend type(rep := !\(!p.disjuncts).conditions) == "Einstance_tagged" & rep end #line 895 "constructors.nw" procedure tag_test_in_every_disjunct(p) every type(rep := !\p.disjuncts[1].conditions) == "Einstance_tagged" do if tag_test_not_in_disjunct(rep, !p.disjuncts) then &null else return rep fail end procedure tag_test_not_in_disjunct(rep, d) if type(c := !\d.conditions) == "Einstance_tagged" & c.uid = rep.uid & exps_eq(rep.x, c.x) then fail else return end #line 927 "constructors.nw" record Sstms(stmts) # statement sequence #line 952 "constructors.nw" procedure old_early_branch(arms, cknown, conds, fknown, fits, emit, closure) local fits_and_emit fits_and_emit := Sif([]) every c := !\fits do put(fits_and_emit.arms, Sguarded(Enot(c), widthfailure(c))) put(fits_and_emit.arms, Sguarded(1, emit)) return put(arms, Sguarded(Eand(cknown, conds), Sif([Sguarded(fknown, fits_and_emit), Sguarded(1, closure)]))) end procedure early_branch(arms, cknown, conds, emit) return put(arms, Sguarded(conjoin(cknown, conds), emit)) end #line 970 "constructors.nw" procedure conjoin(L[]) pushtrace("CONJ") x := do_conjoin(1, set(), L) poptrace() return x end #line 977 "constructors.nw" procedure do_conjoin(early, tested, rest) if e := get(rest) then case type(e) of { default : { e := super_simplify(e) if exps_eq(!tested, e) then { #write("TESTED ", expimage(e)) return do_conjoin(early, tested, rest) } else { #write("USING ", expimage(e)) insert(tested, e) return binary_conjunction(early, do_conjoin(e, tested, rest)) } } "set" : { every push(rest, !e) return do_conjoin(early, tested, rest) } } else return early end procedure binary_conjunction(x, y) return if x === 1 then y else if y === 1 then x else Eand(x, y) end #line 1020 "constructors.nw" procedure last_branch(arms, cknown, conds, fknown, fits_and_emit, uclosure, condfail, cclosure) every put(arms, Sguarded(cknown, Sif( [Sguarded(conds, Sif([Sguarded(fknown, fits_and_emit), Sguarded(1, uclosure)])), Sguarded(1, condfail)])) | Sguarded(1, cclosure)) return arms end #line 1031 "constructors.nw" procedure emitter_body(cons) s := [] every f := inputs_of(cons, "field").meaning & not member(unchecked_fields, f) & fwidth(f) < wordsize do put(s, Sguarded(Enot(Efitsu(literal(f.name), fwidth(f))), Sfail("field " || f.name || " does not fit in " || fwidth(f) || " unsigned bits"))) every f := symtab[inputs_of(cons, "integer").name] & not member(unchecked_fields, f) & fwidth(f) < wordsize do put(s, Sguarded(Enot(Efitss(literal(f.name), fwidth(f))), Sfail("field " || f.name || " does not fit in " || fwidth(f) || " signed bits"))) put(s, Sguarded(1, case_to_emitter(pattern_to_case( subst_tab(crhs(cons), parmtab(cons), 1)), cons))) return super_simplify(Sif(s)) end #line 1050 "constructors.nw" record Sfail(fmt, a1, a2, a3) #line 1055 "constructors.nw" procedure parmtab(cons) t := table() every ipt := inputs_of(cons) do t[ipt.name] := case type(ipt.meaning) of { "constype" : ipt.name # name stands for an instance "field" : ipt.name "integer" : Enarrows(ipt.name, ipt.meaning) "string" : Eforce(ipt.name) "null" : ipt.name default : impossible("input type") } return t end #line 1071 "constructors.nw" procedure case_to_emitter(p, cons) local cknown, conds, fknown, fits, condition_failure_msg case type(p) of { "Stagcase" : { every c := kept_constructors(p.type) do p.arms[c] := case_to_emitter(p.arms[c], cons) return p } "pattern" : { #line 1099 "constructors.nw" p := freshen_disjuncts(p) every add_fits_conditions_and_sanitize(p.disjuncts[1 to *p.disjuncts-1], cons) remove_duplicate_conditions(p, cons) if *p.disjuncts = 0 then { #line 1185 "constructors.nw" { /warned_no_disjuncts := table() if /warned_no_disjuncts[cons] := 1 then warning("constructor ", cons.name, " has an encoding with no matches -- maybe a bad address mode?") } #line 1104 "constructors.nw" return Sfail("impossible encoding (no disjuncts) --- perhaps a bad address mode?") } s := Sif([]) #line 1177 "constructors.nw" condition_failure_msg := if *p.disjuncts > 1 then "Can't decide on branch" else "Conditions not satisfied" #line 1108 "constructors.nw" while *p.disjuncts > 1 do { # early branches d := get(p.disjuncts) set_patlabel_offsets(d) d := gsubst(d, Epatlabel_to_Epc) conds := conditions_with_narrows_check(d.conditions, cons) cknown := known_conditions(conds) early_branch(s.arms, cknown, conds, disjunct_to_emission(d)) } #line 1117 "constructors.nw" if d := get(p.disjuncts) then { # last branch --- fits conditions not folded in! *p.disjuncts = 0 | impossible("bug in constructors") set_patlabel_offsets(d) d := gsubst(d, Epatlabel_to_Epc) conds := conditions_with_narrows_check(d.conditions, cons) cknown := known_conditions(conds) fknown := known_conditions(d.sequents) #line 1358 "constructors.nw" if type(cknown) == "set" then every ff := !fknown do if exps_eq(ff, !cknown) then delete(fknown, ff) if *fknown = 0 then fknown := 1 #line 1125 "constructors.nw" fits := fits_conditions_of(d, cons) sanitize_sequents(d, fits) fwe := Sif([]) every c := !\fits do put(fwe.arms, Sguarded(Enot(c), widthfailure(c))) put(fwe.arms, Sguarded(1, disjunct_to_emission(d))) last_branch (s.arms, cknown, conds, fknown, fwe, Sclosure(d), Sfail(condition_failure_msg || " for constructor " || cons.name), Sclosure(d, conds)) } return s #line 1079 "constructors.nw" } } end #line 1172 "constructors.nw" procedure Epatlabel_to_Epc(x) if type(x) == "Epatlabel" then return binop(the_global_pc, "+", x.l.offset) end #line 1191 "constructors.nw" global warned_no_disjuncts #line 1193 "constructors.nw" record Sclosure(disjunct, conditions, creation) #line 1199 "constructors.nw" procedure sanitize_sequents(d, fits) l := [] every put(l, sanitize_for_output(!d.sequents, fits)) d.sequents := l end #line 1208 "constructors.nw" procedure disjunct_to_emission(d, n) s := Semit([]) /n := 0 every seq := !d.sequents & type(seq) == "sequent" do { put(s.x, sequent_to_Stoken(seq, n)) n +:= s.x[-1].n } return s end #line 1218 "constructors.nw" procedure sequent_to_Stoken(s, offset) v := &null o := start_overlap_check() every c := !s.constraints & x := case type(c) of { "constraint": if c.lo + 1 = c.hi then { add_overlap_field(o, c.field) if 0 <= c.lo < 2^fwidth(c.field) then c.lo else { warning("Field value ", c.lo, " exceeds width of field ", c.field.name); Eslice(c.lo, 0, fwidth(c.field)) } } else if c.lo < c.hi then { warning("Field ", c.field.name, " is underconstrained by ", constraintimage(c), "; no value output") &fail } "fieldbinding": { add_overlap_field(o, c.field) if member(guaranteed_fields, c.field) # | not member(unchecked_fields, c.field) then c.code else Eslice(c.code, 0, fwidth(c.field)) } } & y := emitshift(x, c.field.lo) do v := Eorb(\v, y) | y return Stoken(\v | 0, if s.class.size % emit_unit_bits = 0 then s.class.size / emit_unit_bits else error("tokens are emitted in units of ", token_unit_bits, ", but some pattern is ", s.class.size, " bits wide"), offset) end #line 1253 "constructors.nw" record overlap_check(fields, loset, hiset) procedure start_overlap_check() return overlap_check(set(), set(), set()) end procedure add_overlap_field(o, f) if overlaps(o.loset, o.hiset, f.lo, f.hi) then { #line 1268 "constructors.nw" every g := !o.fields do if f.hi <= g.lo | g.hi <= f.lo then &null else error("Cannot use overlapping fields ", f.name, " and ", g.name, " in the same token") impossible("some fields overlap, but I can't tell which ones") #line 1261 "constructors.nw" } else { insert(o.fields, f) addinterval(o.loset, o.hiset, f.lo, f.hi) } return o end #line 1275 "constructors.nw" procedure emitshift(x, n) return if n = 0 then x else if \simplify_emits then Eshift(x, n) else Eshift(Enosimp(super_simplify(x)), n) end #line 1284 "constructors.nw" procedure remove_duplicate_conditions(p, cons) local l l := [] every i := *p.disjuncts to 1 by -1 do if j := 1 to i-1 & same_conditions(p.disjuncts[i].conditions, p.disjuncts[j].conditions) then #line 1297 "constructors.nw" warning("Pattern on right-hand side of constructor ", cons.name, " has redundant disjuncts ", expimage(p.disjuncts[j]), " and ", expimage(p.disjuncts[i]), ".\tI'll use the first one for encoding") #line 1291 "constructors.nw" else push(l, p.disjuncts[i]) if *l < *p.disjuncts then p.disjuncts := l return end #line 1301 "constructors.nw" procedure same_conditions(c1, c2) if /c1 & /c2 then return else if /c1 | /c2 then fail else if *c1 = *c2 then { c := copy(c1) every insert_condition(c, !c2) if *c > *c1 then fail else return } else fail end #line 1313 "constructors.nw" procedure widthfailure(c) c.n < wordsize | impossible("test to fit in word: ", expimage(c)) case type(c) of { "Efitsu" : {f := "0x%x"; s := "unsigned"} "Efitss" : {f := "%d"; s := "signed"} default : impossible("width condition") } return Sfail("`" || expimage(c.x) || "' = " || f || " won't fit in " || c.n || " " || s || " bits.", c.x) end #line 1328 "constructors.nw" procedure extract_conditions(d,cons) if *\d.conditions > 0 then { conds := d.conditions #line 1415 "constructors.nw" conds_narrows_ok := set() every ee := subterms_matching(conds,"Enarrowu") do if not known_to_fit(input_fitsu, ee.x,cons,ee.n) then insert_width_condition(conds_narrows_ok,Efitsu(ee.x,ee.n)) every ee := subterms_matching(conds,"Enarrows") do if not known_to_fit(input_fitss, ee.x,cons,ee.n) then insert_width_condition(conds_narrows_ok,Efitss(ee.x,ee.n)) #line 1331 "constructors.nw" = if *conds_narrows_ok > 0 then conds ++:= conds_narrows_ok cknown := known_conditions(d.conditions) } else conds := cknown := 1 fknown := known_conditions(d.sequents) #line 1358 "constructors.nw" if type(cknown) == "set" then every ff := !fknown do if exps_eq(ff, !cknown) then delete(fknown, ff) if *fknown = 0 then fknown := 1 #line 1339 "constructors.nw" #line 1365 "constructors.nw" fits := set() every ff := subterms_matching(d.sequents, "fieldbinding") & not member(unchecked_fields, ff.field) do if not known_to_fit(input_fitsu, ff.code,cons, fwidth(ff.field)) then insert_width_condition(fits, Efitsu(ff.code, fwidth(ff.field))) every ee := subterms_matching(d.sequents,"Enarrowu") do if not known_to_fit(input_fitsu, ee.x,cons,ee.n) then insert_width_condition(fits,Efitsu(ee.x,ee.n)) every ee := subterms_matching(d.sequents,"Enarrows") do if not known_to_fit(input_fitss, ee.x,cons,ee.n) then insert_width_condition(fits,Efitss(ee.x,ee.n)) #line 1340 "constructors.nw" return [ cknown, conds, fknown, fits] end #line 1345 "constructors.nw" procedure known_conditions(e) local known known := set() every ff := subterms_matching(e, "Eforce") & cc := super_simplify(Eforceable(ff.x)) do insert_condition(known, cc) if subterms_matching(e, "Epc") then insert_condition(known, Epc_known()) delete(known, 1) return if *known = 0 then 1 else known end #line 1381 "constructors.nw" procedure fits_conditions_of(d, cons) local fits, ff fits := set() every ff := subterms_matching(d.sequents, "fieldbinding") & not member(unchecked_fields, ff.field) do if not known_to_fit(input_fitsu, ff.code, cons, fwidth(ff.field)) then insert_width_condition(fits, Efitsu(ff.code, fwidth(ff.field))) return fits ++ narrows_ok_conditions(d.sequents, cons) end #line 1392 "constructors.nw" procedure add_fits_conditions_and_sanitize(d, cons) local fits fits := fits_conditions_of(d, cons) if *fits > 0 then { /d.conditions := set() every insert_condition(d.conditions, !fits) } sanitize_sequents(d, fits) return d end #line 1424 "constructors.nw" procedure narrows_ok_conditions(e, cons) local ok ok := set() every ee := subterms_matching(e, "Enarrowu") do if not known_to_fit(input_fitsu, ee.x, cons, ee.n) then insert_width_condition(ok, Efitsu(ee.x, ee.n)) every ee := subterms_matching(e, "Enarrows") do if not known_to_fit(input_fitss, ee.x, cons, ee.n) then insert_width_condition(ok, Efitss(ee.x, ee.n)) return ok end procedure conditions_with_narrows_check(conds, cons) if *\conds > 0 then { c := narrows_ok_conditions(conds, cons) return if *c > 0 then c ++ conds else conds } else return 1 end #line 1444 "constructors.nw" procedure insert_width_condition(fits, c) if (x := super_simplify(c)) === 0 then error(widthfailure(c).fmt) else insert_condition(fits, x) return end #line 1459 "constructors.nw" procedure known_to_fit(test, code, cons, width) return case type(code) of { "string" : test(code, cons, width) "Einstance_input" : known_to_fit(test, code.name, code.cons, width) } end #line 1466 "constructors.nw" procedure input_fitsu(name, cons, width) return width >= wordsize | ((ipt := inputs_of(cons)).name == name & case type(ipt.meaning) of { "field" : fwidth(ipt.meaning) <= width "integer" : ipt.meaning <= width }) end procedure input_fitss(name, cons, width) return width >= wordsize | ((ipt := inputs_of(cons)).name == name & case type(ipt.meaning) of { "integer" : ipt.meaning <= width "field" : fwidth(ipt.meaning) < width }) end #line 1501 "constructors.nw" procedure emit_instance_type(pp, ct, tagtype) local constructors # enforce_instance(ct) # now permitting instances of instructions even! constructors := [] every put(constructors, input_record_for(kept_constructors(ct))) emit_template(pp, "instance-type.t", "name", Cnoreserve(ct.name), "tagtype", \tagtype | "int", "constructors", constructors) return end #line 1517 "constructors.nw" procedure input_record_for(cons, struct_name) local pp, ipt pp := [] put(pp, "$nstruct {$t"); every ipt := inputs_of(cons) do ## emit bit fields case type(ipt.meaning) of { "field" : put(pp, "$nunsigned " || ipt.name || ":" || fwidth(ipt.meaning)||";") "integer" : put(pp, "$nint " || ipt.name || ":" || ipt.meaning ||";") } every ipt := inputs_of(cons) do ## emit other inputs case type(ipt.meaning) of { "null" : put(pp, "$nint " || ipt.name ||";") "string" : put(pp, "$nRAddr " || ipt.name ||";") "constype" : put(pp, "$n" || ipt.meaning.name || "_Instance " || ipt.name ||";") "field" | "integer" : &fail default : impossible("input meaning") } if not inputs_of(cons) then put(pp, "\nchar avoid_empty_structures;") put(pp, "$b$n} " || Cnoreserve(\struct_name | cons.name) || ";") return pp end #line 1543 "constructors.nw" procedure arg_decls(cons) l := [] every ipt := inputs_of(cons) do put(l, case type(ipt.meaning) of { "null" : "int" "string" : "RAddr" "constype" : ipt.meaning.name || "_Instance" "field" : unsigned_type(fwidth(ipt.meaning)) "integer" : "int" default : impossible("arg_decls input") } || " " || ipt.name) return if *l = 0 then "void" else commaseparate(l) end #line 1560 "constructors.nw" procedure emit_original_closure_functions(pp, cons, b) local suffix every cl := subterms_matching(b, "Sclosure") do emit_original_closure_function(pp, cons, cons.name || #line 1567 "constructors.nw" (if /suffix then (suffix := 1, "") else "_" || (suffix +:= 1)) #line 1563 "constructors.nw" , cl) return end #line 1584 "constructors.nw" procedure emit_original_closure_function(pp, cons, name, cl) local selections, selected, free, save, upc #line 1642 "constructors.nw" every selections | selected | free := set() every s := subterms_matching(cl.disjunct | \cl.conditions, "Einstance_input") do { insert(selections, s) insert(selected, s.x) } every insert(free, free_variables(cl.disjunct | \cl.conditions)) #line 1587 "constructors.nw" nt := closurenametab(selections ++ free -- selected) mt := meaningtab(nt, cons) emit_original_closure_typedef(pp, name, cons, mt) emit_original_closure_relocfn(pp, name, cons, mt) emit_original_closure_emitter(pp, name, cons, mt) emit_original_closure_function_def(pp, name, cl, nt) emit_closure_header_def(pp, name, name || "_app", cl) #line 1618 "constructors.nw" l := [] s := set() every e := key(nt) & not member(s, nt[e]) do { insert(s, nt[e]) put(l, "_c->v." || nt[e] || " = " || pretty(e) || ";$n") } s := &null # enable garbage collection #line 1600 "constructors.nw" upc := if subterms_matching(\cl.conditions | cl.disjunct, "Epc", "Epc_known") then 1 else 0 cl.creation := Sstmts([ literal(template_to_list("create-closure.t", "name", name, "save", l, "clofun", name || "_app")), disjunct_to_emission(place_holder(cl.disjunct))]) #line 1595 "constructors.nw" return end #line 1630 "constructors.nw" procedure emit_closure_header_def(pp, name, clofun, cl) local upc upc := if subterms_matching(\cl.conditions | cl.disjunct, "Epc", "Epc_known") then 1 else 0 emit_template(pp, "closure-header.t", "clofun", clofun, "name", name, "uses-pc", upc) return end #line 1650 "constructors.nw" procedure closurenametab(save) local namecounts, saved, name every namecounts | t := table() saved := set() every e := !save do if eprime := !saved & exps_eq(e, eprime) then t[e] := t[eprime] else { insert(saved, e) #line 1665 "constructors.nw" name := case type(e) of { "string" : e "Einstance_input" : e.name default : impossible("type of saved exp") } if /namecounts[name] then namecounts[name] := 1 else name ||:= "__" || (namecounts[name] +:= 1) #line 1660 "constructors.nw" t[e] := name } return t end #line 1679 "constructors.nw" procedure emit_original_closure_typedef(pp, name, cons, t) l := [] every fname := key(t) do put(l, case type(t[fname]) of { "null" : "$cint " || fname || ";" "string" : "$cRAddr " || fname || ";" "constype" : impossible("failed to eliminate an instance") }) every fname := key(t) do put(l, case type(t[fname]) of { "field" : "$cunsigned " || fname || ":" || fwidth(t[fname]) || ";" "integer" : "$cint " || fname || ":" || t[fname] || ";" }) emit_template(pp, "closure-type.t", "name", name, "decls", l) end #line 1702 "constructors.nw" procedure emit_original_closure_relocfn(pp, name, cons, t) local calls calls := [] every fname := key(t) & type(t[fname]) == "string" do put(calls, template_to_list("reloc-call.t", "irec", "v", "input", fname)) emit_template(pp, "constructor-labels.t", "ptrtype", name || "_Closure", "name", name, "calls", calls) return end #line 1714 "constructors.nw" procedure emit_original_closure_emitter(pp, name, cons, t) local calls calls := [] /closure_functions_emitters := table() every fname := key(t) do case type(t[fname]) of { "string" : put(calls, template_to_list("emitclo-call.t", "emit", "emit_addr", "input", fname)) "field" | "integer" : put(calls, template_to_list("emitclo-call.t", "emit", "emit_int ", "input", fname)) default : impossible("unknown type ", image(t[fname])) } emit_template(pp, "emitclo.t", "ptrtype", name || "_Closure", "name", name, "calls", calls) return end #line 1743 "constructors.nw" procedure emit_original_closure_function_def(pp, name, cl, t) local es, body initial closure_functions_bytecode := table() tt := copy(t) every k := key(t) do tt[k] := literal("_c->v." || tt[k]) tt[the_global_pc] := Eforce(Eclosure_loc()) PPxwrite(pp, "static void ", name, "_app (RClosure c,$o Emitter emitter,$o FailCont fail) {$t$n", name, "_Closure _c = (", name, "_Closure) c;$n") es := emitterstyle emitterstyle := "closure" PPxwrite(pp, pretty(body := super_simplify(Sif([Sguarded(subst_table_elements(cl.conditions, tt), disjunct_to_emission( subst_table_elements(cl.disjunct, tt))), ### disjunct_to_emission should be changed to include width conditions &c Sguarded(1, Sfail("Conditions not satisfied for constructor " || name))])))) emitterstyle := es closure_functions_bytecode[name || "_app"] := expbc(body) PPxwrite(pp, "$b$n}") end #line 1768 "constructors.nw" procedure find_input(name, cons) return input_named(cons, name) end #line 1772 "constructors.nw" procedure meaningtab(t, cons) u := table() every k := key(t) do (u[t[k]] := known_to_fit(find_input, k, cons).meaning) | impossible("unknown free variable ", k) return u end #line 1792 "constructors.nw" procedure uses_pc(x) static pccache initial pccache := table() if not member(pccache, x) then { pccache[x] := 0 type(x) == "constructor" | impossible("uses_pc") if pattern_label_names((!x.branches).pat) | uses_pc(constructors_applied_in((!x.branches).pat)) then return pccache[x] := 1 } return 0 < pccache[x] end #line 1812 "constructors.nw" procedure uses_reloc(x) static cache initial cache := table() if not member(cache, x) then { cache[x] := 0 case type(x) of { "constype" : if uses_reloc(kept_constructors(x)) then return cache[x] := 1 "constructor" : if inputs_of(x, "string") | uses_pc(x) | uses_reloc(inputs_of(x, "constype").meaning | constructors_applied_in((!x.branches).pat)) then return cache[x] := 1 default : impossible("uses_reloc") } } return 0 < cache[x] end #line 1861 "constructors.nw" procedure input_width_tests(cons) t := [] every i := inputs_of(cons) & case type(i.meaning) of { "integer" : { w := i.meaning; s := "signed"; c := Efitss(literal(i.name), w) } "field" : if member(unchecked_fields, i.meaning) then &fail else { w := fwidth(i.meaning); s := "unsigned" c := Efitsu(literal(i.name), w) } } do put(t, template_to_list("input-test.t", "name", i.name, "width", w, "signed", s, "condition", pretty(c))) return t end #line 1874 "constructors.nw" procedure emit_proc_declaration(pp, cons) if cons.type === instructionctype & /encode_as_data then emit_emitter_proto(pp, cons) else emit_create_instance_proto(pp, cons) return end #line 1882 "constructors.nw" procedure emit_create_instance_proto(pp, cons) c_function_declaration(pp, cons.type.name || "_Instance", Cnoreserve(cons.name), arg_decls(cons)) end #line 1887 "constructors.nw" procedure emit_create_instance_body(pp, cons) a := [] every i := inputs_of(cons).name do put(a, template_to_list("instance-assignment.t", "name", Cnoreserve(cons.name), "l", i, "r", i)) emit_template(pp, "create-instance-body.t", "safename", Cnoreserve(cons.name), "name", cons.name, "type", cons.type.name, "args", arg_decls(cons), "class", if \indirectname then "static " else "", "uses_pc", if uses_pc(cons) then 1 else 0, "input-tests", input_width_tests(cons), "assignments", a) return end #line 1902 "constructors.nw" procedure emit_emitter_proto(pp, cons) c_function_declaration(pp, "void", Cnoreserve(cons.name), arg_decls(cons)) return end procedure emit_emitter_body(pp, cons) b := emitter_body(cons) emit_closure_functions(pp, cons, b) emit_template(pp, "emitter-body.t", "safename", Cnoreserve(cons.name), "args", arg_decls(cons), "class", if \indirectname then "static " else "") PPxwrites(pp, pretty(b)) if \gen_counters then PPxwrites(pp, "$n", cons.name, "_ctr++;") PPxwrite(pp, "$b$n}") return end #line 1925 "constructors.nw" procedure emit_optimized_closure_functions(pp, cons, b) pushtrace("CLO") every cl := subterms_matching(b, "Sclosure") do emit_optimized_closure_function(pp, cons, cons.name, cl) poptrace() return end #line 1938 "constructors.nw" procedure emit_optimized_closure_function(pp, cons, name, cl) local selections, selected, free, save, upc, latevars, clo, subst, body latevars := set() every insert(latevars, inputs_of(cons, "string").name) body := super_simplify(Sif([Sguarded(cl.conditions, disjunct_to_emission(cl.disjunct)), ### disjunct_to_emission should be changed to include width conditions &c Sguarded(1, Sfail("Conditions not satisfied for unnamed constructor")) ])) p := hoist(pp, Elambda(sort(latevars), body), latevars) clo := p.e # is a closure clo := apply_subst(clo, p.sigma) free := set(); every insert(free, free_variables(clo)) free := sort(free) PPwrite(pp, "/****************") PPxwrite(pp, "CLOSURE IS:$t $o", ppexpimage(clo), "$b") PPwrite(pp, "****************/") #line 1964 "constructors.nw" l := [] every i := 1 to *clo.values do put(l, pretty(Gasgn(Eclosure_val(i), clo.values[i])) || "$n") every i := 1 to *clo.addresses do put(l, pretty(Gasgn(Eclosure_addr(i), clo.addresses[i])) || "$n") upc := if subterms_matching(\cl.conditions | cl.disjunct, "Epc", "Epc_known") then 1 else 0 cl.creation := Sstmts([ literal(template_to_list("create-closure.t", "name", clo.ty, "clofun", clo.fun, "uses-pc", upc, "save", l)), disjunct_to_emission(place_holder(cl.disjunct))]) #line 1957 "constructors.nw" return end #line 1977 "constructors.nw" record Elambda(formals, body) record hoisted(e, sigma) # pair containing exp, substitution record arrow(v, e) # part of a substitution procedure make_early(v, e, sigma) v := fresh_variable(v) return hoisted(v, push(sigma, arrow(v, e))) end procedure make_late(v, e, sigma) return hoisted(e, sigma) end procedure make_time(e, latevars) return if islate(e, latevars) then make_late else make_early end procedure islate(e, latevars) return case type(e) of { "string" : member(latevars, e) "list" : islate(!e, latevars) default : 1 } end #line 2001 "constructors.nw" record Eclosure(ty, fun, headertype, values, addresses) procedure hoist(pp, e, latevars) local body, sigma, sigma1, p, free, freeset, clo, clofun, closubst, early, late, hd local values, addresses x := case type(e) of { "string" : hoisted(e, []) "integer" : make_early("lit", e, []) "list" : hoistlist(pp, e, latevars) "Elambda" : { p := hoist(pp, e.body, set(e.formals)) body := p.e sigma := p.sigma #line 2061 "constructors.nw" every addresses | values := [] freeset := set() every v := free_variables(body) & not member(freeset, v) & x := apply_subst(v, sigma) do { insert(freeset, v) put(if is_address(x, e.formals) then addresses else values, v) } #line 2015 "constructors.nw" if \lateconst then { #line 2070 "constructors.nw" l := [] every f := !values do if x := constant(apply_subst(f, sigma)) then body := apply_subst(body, arrow(f, x)) else put(l, f) values := l #line 2017 "constructors.nw" } clo := fresh_variable("clo") #line 2078 "constructors.nw" closubst := [] every i := 1 to *values do put(closubst, arrow(values[i], Eclosure_val(i))) every i := 1 to *addresses do put(closubst, arrow(addresses[i], Eclosure_addr(i))) #line 2021 "constructors.nw" body := apply_subst(body, closubst) clotype := closure_type(pp, values, addresses) clofun := closure_function(pp, clotype, addresses, body) closure_functions_emitters[clofun] := clotype || "_emitclosure" hd := closure_header_type(pp, clofun, clotype, body) #line 2084 "constructors.nw" cloargs := [] every put(cloargs, apply_subst(!values, sigma)) #line 2028 "constructors.nw" p := hoistlist(pp, cloargs, latevars) make_time(p.e, latevars)("closure", Eclosure(clotype, clofun, hd, p.e, apply_subst(addresses, sigma)), p.sigma) } "Epc" | "Epc_known" : make_late("pc", e, []) #line 2087 "constructors.nw" "table" : { kl := []; every k := key(e) & e[k] ~= 0 do put(kl, k) hl := hoistlist(pp, kl, latevars) sigma := hl.sigma hl := hl.e if x := !hl & not islate(x, latevars) then { t := table(0) every k := kl[i := 1 to *kl] & x := hl[i] & not islate(x, latevars) do t[x] +:= e[k] early := make_early("sum", t, sigma) sigma := early.sigma early := early.e } else early := &null if islate(!hl, latevars) then { t := table(0) every k := kl[i := 1 to *kl] & x := hl[i] & islate(x, latevars) do t[x] +:= e[k] t[\early] +:= 1 make_late("sum", t, sigma) } else { make_early("sum", \early | 0, sigma) } } #line 2112 "constructors.nw" "Eorb" : { l := hoistlist(pp, flatten(e, "Eorb"), latevars) every early | late := [] every x := !l.e do put(if islate(x, latevars) then late else early, x) if *late > 0 then if *early = 0 then make_late("or", unflatten(late, Eorb, 0), l.sigma) else { early := make_early("or", unflatten(early, Eorb, 0), l.sigma) push(late, early.e) make_late("or", unflatten(late, Eorb, 0), early.sigma) } else make_early("or", unflatten(early, Eorb, 0), l.sigma) } #line 2128 "constructors.nw" "set" : { sigma := [] s := set() every x := !e do { p := hoist(pp, x, latevars) insert(s, p.e) sigma := compose(sigma, p.sigma) } hoisted(s, sigma) } #line 2142 "constructors.nw" "eqn" : { sigma := [] m := make_early _a0 := hoist(pp, e.left, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if \latezero & untable(e.right) === 0 then { _a2 := 0 m := make_late } else { _a2 := hoist(pp, e.right, latevars) sigma := compose(sigma, _a2.sigma) _a2 := _a2.e if islate(_a2, latevars) then m := make_late } if not (_a0 === e.left, _a2 === e.right) then e := eqn(_a0, e.op, _a2) m("eqn", e, sigma) } #line 2166 "constructors.nw" "Sguarded" : { p := if guard_always_satisfied(e.guard) then hoisted(1, []) else hoist(pp, e.guard, latevars) q := hoist(pp, e.x, latevars) hoisted(Sguarded(p.e, q.e), compose(p.sigma, q.sigma)) } "Sepsilon" : hoisted(e, []) #line 2178 "constructors.nw" "Sfail" : hoisted(e, []) #line 2188 "constructors.nw" "Stoken" : { p := hoist(pp, e.x, latevars) hoisted(Stoken(p.e, e.n, e.offset), p.sigma) } #line 2196 "constructors.nw" "Eforce" : { p := hoist(pp, e.x, latevars) hoisted(Eforce(p.e), p.sigma) } #line 2034 "constructors.nw" #line 1 "hoist.gen" "Gblock" : { sigma := [] m := make_early _a0 := hoist(pp, e.decls, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late _a1 := hoist(pp, e.stmts, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late if not (_a0 === e.decls, _a1 === e.stmts) then e := Gblock(_a0, _a1) m("Gblock", e, sigma) } "Gcall" : { sigma := [] m := make_early _a1 := hoist(pp, e.args, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late if not (_a1 === e.args) then e := Gcall(e.name, _a1) m("Gcall", e, sigma) } "Sstmts" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Sstmts(_a0) m("Sstmts", e, sigma) } "Gsetname" : { sigma := [] m := make_early m("Gsetname", e, sigma) } "Tsigned" : { sigma := [] m := make_early m("Tsigned", e, sigma) } "Gcommented" : { sigma := [] m := make_early m("Gcommented", e, sigma) } "Eclosure_loc" : { sigma := [] m := make_early m("Eclosure_loc", e, sigma) } "Eforceable" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Eforceable(_a0) m("Eforceable", e, sigma) } "Efitsu" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Efitsu(_a0, e.n) m("Efitsu", e, sigma) } "eqn" : { sigma := [] m := make_early _a0 := hoist(pp, e.left, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late _a2 := hoist(pp, e.right, latevars) sigma := compose(sigma, _a2.sigma) _a2 := _a2.e if islate(_a2, latevars) then m := make_late if not (_a0 === e.left, _a2 === e.right) then e := eqn(_a0, e.op, _a2) m("eqn", e, sigma) } "Eclosure_val" : { sigma := [] m := make_early m("Eclosure_val", e, sigma) } "Enarrowu" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Enarrowu(_a0, e.n) m("Enarrowu", e, sigma) } "Epatlabel" : { sigma := [] m := make_early m("Epatlabel", e, sigma) } "Gcasearm" : { sigma := [] m := make_early _a1 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late if not (_a1 === e.x) then e := Gcasearm(e.tags, _a1) m("Gcasearm", e, sigma) } "Gdecl" : { sigma := [] m := make_early _a2 := hoist(pp, e.init, latevars) sigma := compose(sigma, _a2.sigma) _a2 := _a2.e if islate(_a2, latevars) then m := make_late if not (_a2 === e.init) then e := Gdecl(e.name, e.type, _a2) m("Gdecl", e, sigma) } "Einstance_input" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Einstance_input(_a0, e.cons, e.name) m("Einstance_input", e, sigma) } "Gnomatch" : { sigma := [] m := make_early m("Gnomatch", e, sigma) } "Gasgn" : { sigma := [] m := make_early _a1 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late if not (_a1 === e.x) then e := Gasgn(e.lhs, _a1) m("Gasgn", e, sigma) } "Ebinding_instance" : { sigma := [] m := make_early m("Ebinding_instance", e, sigma) } "bogus" : { sigma := [] m := make_early m("bogus", e, sigma) } "ppspec" : { sigma := [] m := make_early m("ppspec", e, sigma) } "Einstance_tagged" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Einstance_tagged(_a0, e.cons, e.uid) m("Einstance_tagged", e, sigma) } "Eapp" : { sigma := [] m := make_early _a1 := hoist(pp, e.args, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late if not (_a1 === e.args) then e := Eapp(e.f, _a1) m("Eapp", e, sigma) } "Ewiden" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Ewiden(_a0, e.n) m("Ewiden", e, sigma) } "Eslice" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Eslice(_a0, e.lo, e.n) m("Eslice", e, sigma) } "Semit" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Semit(_a0) m("Semit", e, sigma) } "Gresynch" : { sigma := [] m := make_early m("Gresynch", e, sigma) } "Sclosure" : { sigma := [] m := make_early _a0 := hoist(pp, e.disjunct, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late _a1 := hoist(pp, e.conditions, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late _a2 := hoist(pp, e.creation, latevars) sigma := compose(sigma, _a2.sigma) _a2 := _a2.e if islate(_a2, latevars) then m := make_late if not (_a0 === e.disjunct, _a1 === e.conditions, _a2 === e.creation) then e := Sclosure(_a0, _a1, _a2) m("Sclosure", e, sigma) } "Eand" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late _a1 := hoist(pp, e.y, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late if not (_a0 === e.x, _a1 === e.y) then e := Eand(_a0, _a1) m("Eand", e, sigma) } "Efitss" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Efitss(_a0, e.n) m("Efitss", e, sigma) } "Sif" : { sigma := [] m := make_early _a0 := hoist(pp, e.arms, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.arms) then e := Sif(_a0) m("Sif", e, sigma) } "Eshift" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Eshift(_a0, e.n) m("Eshift", e, sigma) } "Elambda" : { sigma := [] m := make_early m("Elambda", e, sigma) } "Enarrows" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Enarrows(_a0, e.n) m("Enarrows", e, sigma) } "Enot" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Enot(_a0) m("Enot", e, sigma) } "Eclosure" : { sigma := [] m := make_early m("Eclosure", e, sigma) } "Ginrange" : { sigma := [] m := make_early _a1 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late if not (_a1 === e.x) then e := Ginrange(e.lo, _a1, e.hi) m("Ginrange", e, sigma) } "Eclosure_addr" : { sigma := [] m := make_early m("Eclosure_addr", e, sigma) } "Einstance" : { sigma := [] m := make_early m("Einstance", e, sigma) } "Gdeclnamearray" : { sigma := [] m := make_early m("Gdeclnamearray", e, sigma) } "Ediv" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Ediv(_a0, e.n) m("Ediv", e, sigma) } "Gcase" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late _a1 := hoist(pp, e.arms, latevars) sigma := compose(sigma, _a1.sigma) _a1 := _a1.e if islate(_a1, latevars) then m := make_late if not (_a0 === e.x, _a1 === e.arms) then e := Gcase(_a0, _a1) m("Gcase", e, sigma) } "Glines" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Glines(_a0) m("Glines", e, sigma) } "Emod" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Emod(_a0, e.n) m("Emod", e, sigma) } "Efail" : { sigma := [] m := make_early m("Efail", e, sigma) } "Tunsigned" : { sigma := [] m := make_early m("Tunsigned", e, sigma) } "Enosimp" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.x) then e := Enosimp(_a0) m("Enosimp", e, sigma) } "Stagcase" : { sigma := [] m := make_early _a0 := hoist(pp, e.x, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late _a2 := hoist(pp, e.arms, latevars) sigma := compose(sigma, _a2.sigma) _a2 := _a2.e if islate(_a2, latevars) then m := make_late if not (_a0 === e.x, _a2 === e.arms) then e := Stagcase(_a0, e.type, _a2) m("Stagcase", e, sigma) } "Sstms" : { sigma := [] m := make_early _a0 := hoist(pp, e.stmts, latevars) sigma := compose(sigma, _a0.sigma) _a0 := _a0.e if islate(_a0, latevars) then m := make_late if not (_a0 === e.stmts) then e := Sstms(_a0) m("Sstms", e, sigma) } #line 2035 "constructors.nw" default : impossible("hoisting ", image(type(e))) } ### PPxwrites(pp, "Hoisting ", ppexpimage(e), "$t$ngot $t${$o", ppexpimage(x.e), ### "$}$b$nwith") ### showsigma(pp, x.sigma) ### PPxwrite(pp, "$nso, when applied, have $t$o${", ### ppexpimage(apply_subst(x.e, x.sigma)), ### "$}$b$b$n") return x end #line 2050 "constructors.nw" procedure is_address(e, addressparms) return e === !addressparms | (type(e) == "Einstance_input", type(input_named(e.cons, e.name).meaning) == "string") end #line 2201 "constructors.nw" procedure hoistlist(pp, l, latevars) local sigma, newl, e sigma := [] newl := [] every e := !l do { p := hoist(pp, e, latevars) put(newl, p.e) sigma := compose(p.sigma, sigma) } return hoisted(newl, sigma) end #line 2218 "constructors.nw" procedure closure_type(pp, values, addresses) static closure_types local clname local calls # calls for the reloc function local scalls # calls for the serialization function initial { closure_types := set() /closure_functions_emitters := table() } clname := "O" || *addresses || "_" || *values if not member(closure_types, clname) then { insert(closure_types, clname) every calls | scalls | l := [] every i := 1 to *addresses do { put(l, " $cRAddr a" || i || ";") put(calls, template_to_list("reloc-call.t", "irec", "v", "input", "a" || i)) put(scalls, template_to_list("emitclo-call.t", "emit", "emit_addr", "input", "a" || i)) } every i := 1 to *values do { put(l, " $cunsigned u" || i || ";") put(scalls, template_to_list("emitclo-call.t", "emit", "emit_int ", "input", "u" || i)) } emit_template(pp, "closure-type.t", "name", clname, "decls", l) emit_template(pp, "constructor-labels.t", "ptrtype", clname || "_Closure", "name", clname, "calls", calls) emit_template(pp, "emitclo.t", "ptrtype", clname || "_Closure", "name", clname, "calls", scalls) } return clname end #line 2253 "constructors.nw" procedure compose(sigma1, sigma2) return if *sigma1 = 0 then sigma2 else if *sigma2 = 0 then sigma1 else push(sigma1, sigma2) end #line 2259 "constructors.nw" procedure apply_subst(e, sigma) return case type(sigma) of { "list" : { every s := !sigma do e := apply_subst(e, s) e } "arrow": subst(e, sigma.v, sigma.e) default : impossible("substitution") } end procedure apply_subst_list(e, sigma) every i := return case type(sigma) of { "list" : apply_subst_list(e, sigma, 1) "arrow": subst(e, s.v, s.e) default : impossible("substitution") } end #line 2278 "constructors.nw" procedure showsigma(pp, sigma) case type(sigma) of { "arrow" : PPxwrites(pp, "$t$n${", sigma.v, " --> ", ppexpimage(sigma.e), "$}$b") "list" : every showsigma(pp, !sigma) default : impossible("substitution") } return end #line 2288 "constructors.nw" global closure_functions_postfix, closure_functions_bytecode procedure emit_closure_functions_postfix(pp, interfacebasename) if *\closure_functions_postfix > 0 then { PPxwrite(pp, "/*****************************$t") every k := key(\closure_functions_postfix) do PPxwrite(pp, "${", k, " = $t$c", closure_functions_postfix[k], "$b$}") PPxwrite(pp, "$b$n****************/") } PPxwrites(pp, "ClosurePostfix ", mapoutbadchars(interfacebasename), "_clofuns[] = {$t") every k := key(\closure_functions_postfix) do PPxwrites(pp, "$n{ ", k, ", ", image(closure_functions_postfix[k]), " }, ") PPxwrites(pp, "$n{ (ApplyMethod) 0, (char *) 0 }") PPxwrite(pp, "$b$n};") return end #line 2305 "constructors.nw" procedure emit_closure_functions_bytecode(pp, interfacebasename) local total, bc total := 0 PPxwrites(pp, "ClosurePostfix ", mapoutbadchars(interfacebasename), "_clobytes[] = {$t") every k := key(\closure_functions_bytecode) do { bc := closure_functions_bytecode[k] PPxwrites(pp, "$n{ ", k, ", ", "/* ", *bc, " */ ", image(bc), " }, ") total +:= *bc } PPxwrites(pp, "$n{ (ApplyMethod) 0, (char *) 0 }") PPxwrite(pp, "$b$n};") PPxwrite(pp, "$n/* Bytecode total is ", total, " */") return end #line 2321 "constructors.nw" global closure_functions_emitters procedure emit_closure_functions_emitclosure_map(pp, interfacebasename) local ec PPxwrites(pp, "ClosureEmitter ", mapoutbadchars(interfacebasename), "_cloemitters[] = {$t") every k := key(\closure_functions_emitters) do { ec := closure_functions_emitters[k] PPxwrites(pp, "$n{ ", k, ", ", ec, " }, ") } PPxwrites(pp, "$n{ (ApplyMethod) 0, (void *) 0 /*type is a lie and a cheat*/ }") PPxwrite(pp, "$b$n};") return end #line 2335 "constructors.nw" procedure closure_function(pp, cloty, addresses, body) static cache, count local bodyimage, es, orig_body, bytecode initial { every closure_functions_postfix | closure_functions_bytecode | cache := table() count := 0 } tt := table() every i := 1 to *addresses do tt[addresses[i]] := Eclosure_addr(i) tt[the_global_pc] := Eforce(Eclosure_loc()) orig_body := body body := subst_table_elements(body, tt) bodyimage := expps(body) if /cache[bodyimage] then { cache[bodyimage] := "_clofun_" || (count +:= 1) closure_functions_postfix [cache[bodyimage]] := bodyimage closure_functions_bytecode[cache[bodyimage]] := expbc(body) verbose("New closure function for \n", bodyimage) PPxwrite(pp, "/* CLOSURE FUNCTION _clofun_", count, " is $t$n", bodyimage, "$b$n */") bytecode := expbc(body) || bc_halt() PPwrite(pp, "/* bytecode (", *bytecode, ") is ", image(bytecode), " */") #line 2361 "constructors.nw" es := emitterstyle emitterstyle := "closure" PPxwrite(pp, "static void _clofun_", count, "(RClosure c,$o Emitter emitter,$o FailCont fail) {$t$n", cloty, "_Closure _c = (", cloty, "_Closure) c;$n") PPxwrite(pp, pretty(body)) emitterstyle := es PPxwrite(pp, "$b$n}") #line 2357 "constructors.nw" } return cache[bodyimage] end #line 2374 "constructors.nw" procedure closure_header_type(pp, clofun, clotype, body) local upc static cache initial cache := table() if /cache[clofun] then { cache[clofun] := clofun || "_closure_header" upc := if subterms_matching(body, "Epc", "Epc_known") then 1 else 0 emit_template(pp, "closure-header.t", "clofun", clofun, "name", clotype, "uses-pc", upc) } return cache[clofun] end #=================================================================== tclos.icn #line 5 "tclos.nw" procedure emit_tokenized_closure_functions(pp, cons, b) pushtrace("TCLOS") every cl := subterms_matching(b, "Sclosure") do emit_tokenized_functions_of_closure(pp, cons, cons.name, cl) poptrace() return end #line 22 "tclos.nw" record closure_creation(alloc, emit) procedure emit_tokenized_functions_of_closure(pp, cons, name, cl) local latevars, offset latevars := set() every insert(latevars, inputs_of(cons, "string").name) cl.creation := closure_creation([], []) offset := 0 every s := !cl.disjunct.sequents & type(s) == "sequent" do { if subterms_matching(s, "Eforce") then # was member(latevars, free_variables(s)) emit_tokenized_closure_function(pp, cons, name, cl, latevars, s, offset) else put(cl.creation.emit, sequent_to_Stoken(s, offset)) offset := cl.creation.emit[-1].offset + cl.creation.emit[-1].n } cl.creation := Sstmts(put(cl.creation.alloc, Semit(cl.creation.emit))) return end #line 50 "tclos.nw" procedure emit_tokenized_closure_function(pp, cons, name, cl, latevars, seq, offset) local selections, selected, free, save, upc, clo, subst, body, lconds lconds := conditions_applying_to(\cl.conditions, seq) | &null if offset > 0 then { lconds := subst_for_pc(lconds, binop(the_global_pc, "-", offset)) seq := subst_for_pc(seq, binop(the_global_pc, "-", offset)) } body := super_simplify(Sif([Sguarded(lconds, Semit([sequent_to_Stoken(seq, 0)])), ### sequent_to_Stoken should be changed to include width conditions &c Sguarded(1, Sfail("Conditions not satisfied for unnamed constructor")) ])) p := hoist(pp, Elambda(sort(latevars), body), latevars) clo := p.e # is a closure clo := apply_subst(clo, p.sigma) free := set(); every insert(free, free_variables(clo)) free := sort(free) PPwrite(pp, "/****************") PPxwrite(pp, "CLOSURE IS:$t $o", ppexpimage(clo), "$b") PPwrite(pp, "****************/") #line 76 "tclos.nw" l := [] every i := 1 to *clo.values do put(l, pretty(Gasgn(Eclosure_val(i), clo.values[i])) || "$n") every i := 1 to *clo.addresses do put(l, pretty(Gasgn(Eclosure_addr(i), clo.addresses[i])) || "$n") upc := if subterms_matching(\lconds | seq, "Epc", "Epc_known") then 1 else 0 put(cl.creation.alloc, if offset = 0 then literal(template_to_list("create-closure.t", "name", clo.ty, "clofun", clo.fun, "uses-pc", upc, "save", l)) else literal(template_to_list("create-closure-at.t", "name", clo.ty, "clofun", clo.fun, "uses-pc", upc, "save", l, "offset", offset))) #line 94 "tclos.nw" d := disjunct_to_emission(place_holder(disjunct([seq])), offset) every put(cl.creation.emit, !d.x) #line 72 "tclos.nw" return end #line 101 "tclos.nw" procedure conditions_applying_to(conds, seq) local applying applying := copy(conds) every c := !applying & f := free_variable_set(c) do if member(f, free_variables(seq)) then &null else delete(applying, c) return if *applying = 0 then &null else applying end #line 109 "tclos.nw" procedure free_variable_set(x) s := set() every insert(s, free_variables(x)) return s end #================================================================= checker.icn #line 153 "checker.nw" global chkr_input_tbl global TESTLIMIT global zerotab procedure emit_checker(outfilename) local outfile, altoutfile, pp TESTLIMIT := 1024 zerotab := table(0) zerotab[1] := 0 verbose("Emitting checker program") if (/chkr_input_tbl) then chkr_input_tbl := table() if (/indirectname) then error("Interface name undefined. Checker requires ``-indirect'' option") outfile := openfile(outfilename || implementation_extension, "cw") | error("Could not open ", outfilename, " for writing") pp := PPnew(outfile) emit_template(pp, "checker.t", "interface", image(outfilename || interface_extension), "irname", indirectname) every cons := kept_constructors() do { write(\cdebug, "\nChecker for " || expimage(cons.name)) p := pattern_to_case(subst_tab(crhs(cons), parmtab(cons), 1)) chkr_input_tbl[cons.name] := generate_input_values(p, cons) } generate_checker(pp, outfilename, indirectname) PPxwrites(pp, "$b}$n") PPwrite(pp) # flush prettyprinter return end #line 188 "checker.nw" procedure generate_checker(pp, outfilename, indirectname) local cons, test, asmoutput, binoutput, outfile, app count := 0 asmoutput := [] binoutput := "" asmir := indirectname || "_asm" || "->" binir := indirectname || "_bin" || "->" outfile := openfile(outfilename || "_tmp_", "cw") | error("Could not open ", outfilename, " for writing") app := PPnew(outfile) every cons := kept_constructors() do if cons.type === instructionctype then every test := generate_tests(cons, 1, !chkr_input_tbl[cons.name], asmir) do { pexp := pretty(Gcall(cons.name, test)) asmoutput := "/* Pair " || string(count +:= 1) || ":" || pexp || " */\n" asmoutput ||:= asmir || pexp || ";\n" PPxwrite(app, asmoutput) binoutput := "/* Pair " || string(count) || ":" || pexp || " */\n" binoutput ||:= binir || pexp || ";\n" PPxwrite(pp, binoutput) } emit_template(pp, "inchecker.t") PPwrite(app) # flush assembly prettyprinter outfile := openfile(outfilename || "_tmp_", "r") | error("Could not open ", outfilename, " for reading") every line := !outfile do PPxwrite(pp, line) emit_template(pp, "afterchecker.t") remove(outfilename || "_tmp_") end #line 225 "checker.nw" procedure generate_tests(cons, idx, test_values, asmir) local i, rest write(\cdebug, "Generate tests for ", cons.name, " ", idx, " ", expimage(cons.operands[idx])) #line 375 "checker.nw" every k := key(test_values) do write(\cdebug, "test_values[", expimage(k), "] = ", expimage(test_values[k])) #line 230 "checker.nw" if idx > *cons.operands then suspend [] else if type(cons.operands[idx]) == "literal" then suspend generate_tests(cons, idx+1, test_values, asmir) else every rest := generate_tests(cons, idx+1, test_values, asmir) & i := tests_of(cons.operands[idx], test_values, asmir) do { push(rest, i) suspend rest pop(rest) } end #line 245 "checker.nw" procedure tests_of(input, tbl, asmir) local i, m, n if type(input) == "literal" then suspend "" else if type(input) == "input" then { case type(input.meaning) of { "integer" : { input := lookuptype(input.name, "field") #line 275 "checker.nw" inputs := \tbl[input.name] | \ error("No test values specified for `", input.name, "'") #line 253 "checker.nw" suspend tbl[input.name] } "string" : { #line 275 "checker.nw" inputs := \tbl[input.name] | \ error("No test values specified for `", input.name, "'") #line 257 "checker.nw" suspend if (input.meaning == "reloc" & integer(tbl[input.name])) then Gcall("unsigned_to_raddr", [tbl[input.name]]) else tbl[input.name] } "field" | "null" | "string" : { #line 275 "checker.nw" inputs := \tbl[input.name] | \ error("No test values specified for `", input.name, "'") #line 263 "checker.nw" suspend tbl[input.name] } "constype" : every m := kept_constructors(input.meaning) & i := generate_tests(m, 1, !chkr_input_tbl[m.name], asmir) do suspend Gcall(asmir || m.name, i) default : typeerror(input.meaning, "field, input, or constype", input.name) } } end #line 281 "checker.nw" procedure merge_chkr_tables(L) local t, k chkr_tbl := table() every t := !L do { every k := key(t) do { if /chkr_tbl[k] then chkr_tbl[k] := t[k] else warning("Checker inputs for ", k, " already defined. Using first set.") } } return chkr_tbl end #line 322 "checker.nw" procedure generate_input_values(p, cons) local d, conds, fits, test_values, test_sets, f, tmp, names test_sets := [] case type(p) of { "Stagcase" : { every c := kept_constructors(p.type) do test_sets |||:= generate_input_values(p.arms[c], cons) } "pattern" : { remove_duplicate_conditions(p, cons) while d := get(p.disjuncts) do { test_values := table() test_values[Epc] := Epc #line 349 "checker.nw" set_patlabel_offsets(d) d := gsubst(d, Epatlabel_to_Epc) ds_conds := extract_conditions(d, cons) conds := ds_conds[2] fits := ds_conds[4] sanitize_sequents(d, fits) #line 364 "checker.nw" every f := !fits do f.x := unforce(f.x) #line 379 "checker.nw" every i := inputs_of(cons) & type(i.meaning) == "null" do { write(\cdebug, "adding Efitsu(" || i.name || ", "|| wordsize || "), " || type(i.meaning)) constrained := &null every f := !fits & string(f.x) == i.name do constrained := 1 /constrained & insert(fits, Efitsu(i.name, wordsize)) # if (string(i.meaning) == "reloc") then { # if (type(conds) == "integer") then conds := set() # insert(conds, eqn(Emod(i.name, 4), "=", zerotab)) # } } #line 394 "checker.nw" every i := inputs_of(cons, "field") do insert(fits, Efitsu(i.name, fwidth(i.meaning))) every i := inputs_of(cons, "integer") do insert(fits, Efitss(i.name, i.meaning)) #line 407 "checker.nw" tmp := copy(fits) every f := !\fits & (type(f.x) == "Einstance_input") do delete(tmp, f) fits := tmp tmp := conds every c := !conds & subterms_matching(c, "Einstance_input") do delete(tmp, c) conds := tmp #line 371 "checker.nw" if (*fits > 0) then write(\cdebug, "Width constraints for " || cons.name) write(\cdebug, " " || expimage(fits)) write(\cdebug, print_conditions(conds)) #line 335 "checker.nw" #line 511 "checker.nw" every i := inputs_of(cons, "string") & i.meaning == "reloc" & test_values[i.name] := "reloc" n_tests := 0 #line 417 "checker.nw" every c := !conds do { if ( #line 424 "checker.nw" type(c) == "eqn" & c.op == "=" & ((v := integer(untableexp(c.right)) & (not integer(c.left)) & x := c.left) | (v := integer(untableexp(c.left)) & (not integer(c.right)) & x := c.right)) #line 418 "checker.nw" ) then { verbose("inserting test_values[" || expimage(x) || "] = " || v) test_values[x] := v } } #line 515 "checker.nw" while (*test_values > n_tests) do { n_tests := *test_values #line 522 "checker.nw" new_conds := set() every insert(new_conds, (simplify_conditions(conds, test_values))[2]) conds := new_conds #line 518 "checker.nw" #line 417 "checker.nw" every c := !conds do { if ( #line 424 "checker.nw" type(c) == "eqn" & c.op == "=" & ((v := integer(untableexp(c.right)) & (not integer(c.left)) & x := c.left) | (v := integer(untableexp(c.left)) & (not integer(c.right)) & x := c.right)) #line 418 "checker.nw" ) then { verbose("inserting test_values[" || expimage(x) || "] = " || v) test_values[x] := v } } #line 519 "checker.nw" } #line 336 "checker.nw" #line 441 "checker.nw" every (i := inputs_of(cons) & type(i.meaning) ~== "constype" & /test_values[i.name]) do { every f := !fits & string(f.x) == i.name do { unsatisfied := 1 count := 0 if (type(i.meaning) == "field" & #line 439 "checker.nw" names := \fieldname_table(i.meaning) #line 447 "checker.nw" ) then test_values[f.x] := ?names else test_values[f.x] := random_nbit_value(f) while (\unsatisfied & count < TESTLIMIT) do { verbose("Try " || expimage(f.x) || " = " || expimage(test_values[f.x])) #line 529 "checker.nw" unsatisfied := &null unknown := &null every l := simplify_conditions(conds, test_values) do { c := l[1] newc := l[2] if (type(newc) == "eqn") then { if (reduceable(newc)) then /unknown := [c] | push(unknown, c) else if (not tautology(newc)) then /unsatisfied := [c] | push(unsatisfied, c) } } #line 454 "checker.nw" if (\unsatisfied) then { slices := slices_of(f.x, unsatisfied) verbose("Slices are: ") every verbose(expimage(!slices)) test_values[f.x] := interleave_slices(random_nbit_value(f), slices) } count +:= 1 } if (count == TESTLIMIT) then { warning("Checker can't generate test values for " || i.name || print_conditions(unsatisfied, "not satisfied.")) } } } if (*test_values > 1) then write(\cdebug, "Tests " || (if (*p.disjuncts > 1) then " for disjunct:\n" || expimage(d) else ":")) every i := inputs_of(cons) & \test_values[i.name] do write(\cdebug, expimage(i.name) || " = " || expimage(test_values[i.name])) #line 529 "checker.nw" unsatisfied := &null unknown := &null every l := simplify_conditions(conds, test_values) do { c := l[1] newc := l[2] if (type(newc) == "eqn") then { if (reduceable(newc)) then /unknown := [c] | push(unknown, c) else if (not tautology(newc)) then /unsatisfied := [c] | push(unsatisfied, c) } } #line 476 "checker.nw" if (\unsatisfied) then { warning("Checker can't generate test values for disjunct:", "\n", expimage(d), print_conditions(unsatisfied, "not satisfied.")) } if (\unknown) then { warning("Test values for disjunct:", "\n", expimage(d), print_conditions(unknown, "may not be satisfied by test inputs.")) } #line 338 "checker.nw" put(test_sets, test_values) } } } return test_sets end #line 367 "checker.nw" procedure unforce(x) return if (type(x) == "Eforce") then x.x else x end #line 487 "checker.nw" procedure slices_of(v, conds) local s s := set() every c := !conds do if (type(c.left) == "Eslice" & (c.left.x := unforce(c.left.x)) == v) then insert(s,eqn(c.left, c.op, integer(untableexp(c.right)))) else if (type(c.right) == "Eslice" & (c.right.x := unforce(c.right.x)) == v) then insert(s, eqn(c.right, c.op, integer(untableexp(c.left)))) return s end #line 501 "checker.nw" procedure interleave_slices(result, slices) local e, mask every e := !slices & e.op == "=" do { mask := icom(ishift(2^(e.left.n)-1, e.left.lo)) result := ior(iand(result, mask), ishift(iand(e.right, 2^(e.left.n)-1), e.left.lo)) } return result end #line 542 "checker.nw" procedure print_conditions(conds, msg) local l l := [] (*conds == 0) & return "" every put(l, expimage(!conds)) return "Conditions " || (\msg | " ") || ":" || " " || commaseparate(l) end #line 556 "checker.nw" procedure random_nbit_value(f) local v return case type(f) of { "Efitsu": ?(2^(f.n)-1) "Efitss": { v := ?(2^(f.n-1)) if (?2 = 1) then -v else if (v = 2^(f.n-1)) then v - 1 else v } default : error("Invalid field-width constraint: ", expimage(f)) } end #line 573 "checker.nw" procedure simplify_conditions(conditions, values) local c, cp every c := !\conditions do { # write("==> " || image(type(c)) || "," || expimage(c)) cp := simplify(subst_tab(c, values)) # write("<== " || image(type(cp)) || "," || expimage(cp)) suspend [c, cp] } end #line 585 "checker.nw" procedure reduceable(c) return not integer(untableexp(c.left)) | not integer(untableexp(c.right)) end procedure tautology(c) local l,r if (l := integer(untableexp(c.left)) & r := integer(untableexp(c.right))) then return case c.op of { "=" : l = r ">=" : l >= r "<=" : l <= r "!=" : l ~= r "<" : l > r ">" : l < r default: error("Invalid operator " || c.op) } return end #===================================================================== exp.icn #line 20 "exp.nw" record Eorb(x, y) # Word.Or(x, y) record Eand(x, y) # x AND y -- short-circuit Boolean record Eslice(x, lo, n) # Word.Extract(x, lo, width) record Eshift(x, n) # Word.Shift(x, n) -- n>0 shifts left record Enarrowu(x, n) # narrow to n bits, unsigned, with check record Enarrows(x, n) # narrow to n bits, signed, with check record Ewiden(x, n) # sign-extend low n bits record Ediv(x, n) # x DIV y record Emod(x, n) # x MOD y record Efitsu(x, n) # unsigned value x fits in n bits record Efitss(x, n) # signed value x fits in n bits record Epatlabel(l) # reference to patlabel l record Eforce(x) # force relocatable x to an integer record Eforceable(x) # true iff relocatable x has known address record Epc() # start of pattern match or token emission record Epc_known() # predicate needed in encoding record Sstmts(x) # sequence of statements record Enot(x) # NOT x record Enosimp(x) # x, but suppress simplification record Semit(x) # emit list of Stoken record Stoken(x, n, offset) # emit x with width n (offset from beginning) # (offset >= 0 always) record Einstance(cons, argt) # cons applied to arguments in table argt record Einstance_input(x, cons, name) # input name from instance x of constructor cons record Einstance_tagged(x, cons, uid) # true iff instance x tagged as constructor cons record Ebinding_instance(name, type, vart) # binding instance of constructor-typed input # vart is table used to find fresh vars record Sif(arms) # list of Sguarded record Sguarded(guard, x) # if guard then x (in Sif) record Sepsilon() # empty statement record Efail(msg) # result of selecting from the wrong constructor record Eapp(f, args) # function application record Eclosure_loc() # location of a relocation closure record Eclosure_addr(n) # relocatable address in a relocation closure record Eclosure_val(n) # value in a relocation closure #line 62 "exp.nw" procedure exptypes() suspend "string" | "integer" | "table" | "Eorb" | "Eslice" | "Eshift" | "Enarrowu" | "Enarrows" | "Ewiden" | "Ediv" | "Emod" | "Einstance_input" | "Einstance" | "Ebinding_instance" | "Eapp" | "Eclosure_loc" | "Eclosure_addr" | "Eclosure_val" end #line 74 "exp.nw" record eqn(left, op, right) # equality or inequality #line 79 "exp.nw" procedure subterms_matching_f(e, types[]) return if type(e) == !types then e end procedure subterms_matching(e, types[]) suspend do_expwalk(e, subterms_matching_f, types) end #line 90 "exp.nw" procedure free_variables_f(e) return if type(e) == "string" then e end procedure free_variables(e) suspend expwalk(e, free_variables_f) end #line 101 "exp.nw" procedure exps_eq(e1, e2) if e1 === e2 then return e2 e1 := untableexp(e1) e2 := untableexp(e2) return case type(e1) == type(e2) of { #line 110 "exp.nw" "pattern" : fail "disjunct" : fail "adisjunct" : fail "sequent" : fail "patlabel" : e1 === e2 "latent_patlabel" : e1 === e2 ## ??? "dots_sequent" : fail "constraint" : fail "fieldbinding" : fail "field" : e1 === e2 "absolute_field" : exps_eq(e1.field, e2.field) & e1.offset = e2.offset #line 122 "exp.nw" "list" : if *e1 ~= *e2 then fail else { every i := 1 to *e1 do if not exps_eq(e1[i], e2[i]) then fail e1 } "eqn" : #line 191 "exp.nw" (e1.op == e2.op, exps_eq(e1.left, e2.left), exps_eq(e1.right, e2.right)) | (d1 := subtract(e1.left, e1.right), (e1.op == e2.op, exps_eq(d1, subtract(e2.left, e2.right))) | (e1.op == opposite_op(e2.op), exps_eq(d1, subtract(e2.right, e2.left)))) #line 129 "exp.nw" "table" : { if *e1 ~= *e2 then fail every k1 := key(e1) do if k2 := key(e2) & e2[k2] = e1[k1] & exps_eq(k1, k2) then &null else fail e2 } #line 136 "exp.nw" "set" : { if *e1 ~= *e2 then fail s := set() every x := !e1 do if exps_eq(x, y := !e2) then insert(s, y) else fail *s = *e2 } #line 146 "exp.nw" "Eorb" | "Eand" : exps_eq(e1.x, e2.x) & exps_eq(e1.y, e2.y) "Eslice" : e1.lo = e2.lo & e1.n = e2.n & exps_eq(e1.x, e2.x) "Eshift" | "Enarrowu" | "Enarrows" | "Ewiden" | "Ediv" | "Emod" | "Efitsu" | "Efitss" : e1.n = e2.n & exps_eq(e1.x, e2.x) "Epatlabel" : e1.l === e2.l "Eforce" | "Eforceable" | "Enot" | "Enosimp" | "Sstmts" | "Semit" : exps_eq(e1.x, e2.x) "Epc" | "Epc_known" : true "Stoken" : e1.offset = e1.offset & e1.n = e2.n & exps_eq(e1.x, e2.x) "Einstance_input" : e1.cons === e2.cons & e1.name == e2.name & exps_eq(e1.x, e2.x) "Einstance_tagged" : e1.cons === e2.cons & e1.uid = e2.uid & exps_eq(e1.x, e2.x) "Einstance" : impossible("escaping Einstance") "Ebinding_instance": impossible("escaping Ebinding_instance") #line 159 "exp.nw" "Sif" | "Sguarded" | "Stagcase" : fail #line 161 "exp.nw" "Glines" : fail "Gresynch" : fail "Gblock" : fail "Gdecl" : fail "Gcase" : fail "Gcasearm" : fail "Ginrange" : fail "Gsetname" : fail "Gnomatch" : fail "Gasgn" : fail "Tunsigned" : fail "Gcomment" : fail "Gcommented" : e1.comment == e2.comment & exps_eq(e1.e, e2.e) #line 175 "exp.nw" "string" : e1 == e2 "integer" : e1 = e2 #line 178 "exp.nw" "Eapp" : fail #line 180 "exp.nw" "Eclosure_loc" : e1 "Eclosure_addr" : e1.n = e2.n "Eclosure_val" : e1.n = e2.n #line 107 "exp.nw" } end #line 198 "exp.nw" procedure opposite_op(op) return case op of { "<" : ">" "<=" : ">=" ">" : "<" ">=" : "<=" "=" : "=" "!=" : "!=" } end #line 210 "exp.nw" procedure untableexp(e) local result if type(e) == "table" then { every k := key(e) & e[k] = 0 do delete(e, k) case *e of { 0: return 0 1: { k := key(e) if k === 1 then return e[k] else if e[k] = 1 then return k } } } return e end #line 230 "exp.nw" procedure subst_f(e, var, value) if type(e) === "string" then return if var == e then value else e end procedure subst(e, var, value) return if var === value then e # optimization else do_gsubst(e, subst_f, [var, value]) end #line 242 "exp.nw" procedure subst_tab_f(e, tbl, all) return if type(e) == "string" then \tbl[e] | if \all then error("variable ", image(e)," is unbound in table ", envimage(tbl, "substitions")) else e end procedure subst_tab(e, tbl, all) return do_gsubst(e, subst_tab_f, [tbl, all]) end #line 258 "exp.nw" procedure subst_table_elements_f(e, tbl) return \tbl[e] end procedure subst_table_elements(e, tbl) return do_gsubst(e, subst_table_elements_f, [tbl]) end #line 265 "exp.nw" procedure subst_for_pc_f(e, val) return if e === the_global_pc then val end procedure subst_for_pc(e, val) return do_gsubst(e, subst_for_pc_f, [val]) end #line 275 "exp.nw" procedure subst_values_in_table(t, var, value) return do_gsubst_values_in_table(t, subst_f, [var, value]) end procedure subst_tab_values_in_table(t, var, value) return do_gsubst_values_in_table(t, subst_tab_f, [var, value]) end procedure do_gsubst_values_in_table(t, f, closure) n := 0 u := table() every k := key(t) & x := do_gsubst(t[k], f, closure) do { u[k] := x if x ~=== t[k] then n +:= 1 } return if n > 0 then u else t end #line 298 "exp.nw" procedure dsubst(e, var, value) return destructive_subst(e, var, value, subst) end procedure dsubst_tab(e, tbl, all) return destructive_subst(e, tbl, all, subst_tab) end #line 305 "exp.nw" procedure destructive_subst(e, a2, a3, substitute) if type(e) == "eqn" then { e.left := destructive_subst(term2table(e.left), a2, a3, substitute) e.right := destructive_subst(term2table(e.right), a2, a3, substitute) } else { m := copy(e) every k := key(m) & mm := m[k] & kk := substitute(k, a2, a3) do { e[k] -:= mm if type(kk) ~== "table" then e[kk] +:= mm else every v := key(kk) do e[v] +:= kk[v] * mm } every k := key(e) & e[k] = 0 do delete(e, k) } return e end #line 336 "exp.nw" procedure simplify(e) local left, right return case type(e) of { $define simfun simplify #line 363 "exp.nw" "eqn" : { #line 448 "exp.nw" l := simfun(e.left) r := simfun(e.right) if exps_eq(l, r) then if e.left === 0 & e.right === 0 then e else eqn(0, e.op, 0) else if simfun === super_simplify & # not safe for decoding! see bugs{nnn} ( (type(l) == "Enarrows", type(r) == "Eslice", r.lo = 0) | (type(l) == "Eslice", type(r) == "Enarrows", l.lo = 0) ) & l.n = r.n & exps_eq(l.x, r.x) then simfun(Efitss(l.x, l.n)) else if e.left === l & e.right === r then e else eqn(l, e.op, r) #line 363 "exp.nw" } "pattern" : { #line 392 "exp.nw" l := []; every put(l, simfun(!e.disjuncts)) if lists_match(l, e.disjuncts) then e else pattern(l, e.name) #line 364 "exp.nw" } "disjunct" : { #line 395 "exp.nw" c := simfun(e.conditions) if member(\c, 0) then fail else { l := []; every put(l, vanishing_latent_patlabel ~=== simfun(!e.sequents)) if lists_match(l, e.sequents) then l := e.sequents if ss := !l & type(ss) == "sequent" & cc := !ss.constraints & type(cc) == "constraint" & cc.lo >= cc.hi then fail # this disjunct can't match -- eliminate it if c === e.conditions & l === e.sequents then e else disjunct(l, e.name, c) } #line 365 "exp.nw" } "adisjunct": { #line 407 "exp.nw" c := simfun(e.conditions) if member(\c, 0) then fail else { l := simfun(e.aconstraints) if cc := !l & type(cc) == "constraint" & cc.lo >= cc.hi then fail # this disjunct can't match -- eliminate it if c === e.conditions & l === e.aconstraints then e ### & a === e.answers then e else adisjunct(l, e.name, c, e.length, e.patlabelbindings) ### , a) } #line 366 "exp.nw" } "sequent" : if (l := simfun(e.constraints)) === e.constraints then e else sequent(l, e.class) "patlabel" : e "dots_sequent" : e "constraint" : e "fieldbinding" : if (x := simfun(e.code)) === e.code then e else fieldbinding(e.field, x) "absolute_field" : e # don't call super_simplify --- can't spot which fields are used any more! # change 50 "set" : { #line 417 "exp.nw" s := set() every x := simfun(!e) do { if type(x) == "eqn" then { if x.op == "=" & x.left === x.right then x := 1 else if x.op == "!=" & x.left === x.right then x := 0 } insert(s, x) } delete(s, 1) return if member(s, 0) then set([0]) else if sets_match(e, s) then e else if *s = 0 then &null else s #line 377 "exp.nw" } "table" : { #line 437 "exp.nw" m := copy(e) every k := key(e) do { m[k] -:= e[k] add_to_table(m, simfun(k), e[k]) } every k := key(m) & m[k] = 0 do delete(m, k) if *m > 1 then return if tables_match(m, e) then e else m else return if !m = 1 then key(m) else if key(m) === 1 then !m else m #line 378 "exp.nw" } "list" : {l := maplist(simfun, e); if lists_match(e, l) then e else l} "integer" | "string" : e "Einstance" : { #line 431 "exp.nw" every k := key(e.argt) do e.argt[k] := simfun(e.argt[k]) e #line 381 "exp.nw" } "Stagcase" : { #line 434 "exp.nw" every k := key(e.arms) do e.arms[k] := simfun(e.arms[k]) e #line 382 "exp.nw" } "Sif" : { #line 463 "exp.nw" a := simp_arms(e.arms, simfun) if *a = 0 then Sepsilon() else if *a = 1 & guard_always_satisfied(a[1].guard) then a[1].x else if a === (e.arms) then e else Sif(a) #line 383 "exp.nw" } "Enosimp" : e # suppresses simplification "Gcommented" : if (ee := simfun(e.e)) === e.e then e else Gcommented(ee, e.comment) "Gcomment" : e #line 341 "exp.nw" #line 1 "simp.gen" "Gblock" : { _a0 := simfun(e.decls) _a1 := simfun(e.stmts) if not (_a0 === e.decls, _a1 === e.stmts) then e := Gblock(_a0, _a1) { e } } "Gcall" : { _a1 := simfun(e.args) if not (_a1 === e.args) then e := Gcall(e.name, _a1) { e } } "Sstmts" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Sstmts(_a0) { l := _a0 case *l of { 0 : Sepsilon(); 1: l[1]; default : e } } } "Gsetname" : { { e } } "Tsigned" : { { e } } "Gcommented" : { { e } } "Eclosure_loc" : { { e } } "Eforceable" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Eforceable(_a0) if (type(_a0) == "integer") then { N := _a0 1 } else { e } } "Efitsu" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Efitsu(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 m := e.n if 0 <= N < 2^m then 1 else 0 } else if (type(_a0) == "Enarrowu") then { x := _a0.x n := _a0.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrowu") then { x := _a0.e.x n := _a0.e.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Enarrows") then { x := _a0.x n := _a0.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrows") then { x := _a0.e.x n := _a0.e.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Eslice") then { x := _a0.x lo := _a0.lo n := _a0.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eslice") then { x := _a0.e.x lo := _a0.e.lo n := _a0.e.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Einstance_input") then { y := _a0 m := e.n if known_to_fit(input_fitsu, y, &null, m) then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Einstance_input") then { y := _a0 m := e.n if known_to_fit(input_fitsu, y, &null, m) then 1 else e } else if (type(_a0) == "Eshift") then { x := _a0.x n := _a0.n m := e.n simfun(Efitsu(x, m-n)) } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eshift") then { x := _a0.e.x n := _a0.e.n m := e.n simfun(Efitsu(x, m-n)) } else if (type(e.n) == "integer") then { x := _a0 M := e.n if M >= wordsize then 1 else e } else { e } } "Epc" : { { e } } "eqn" : { _a0 := simfun(e.left) _a2 := simfun(e.right) if not (_a0 === e.left, _a2 === e.right) then e := eqn(_a0, e.op, _a2) { e } } "Eclosure_val" : { { e } } "Enarrowu" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Enarrowu(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 n := e.n if 0 <= N < 2^n then N else Efail(expimage(e)) } else { e } } "Epatlabel" : { { e } } "Gcasearm" : { _a1 := simfun(e.x) if not (_a1 === e.x) then e := Gcasearm(e.tags, _a1) { e } } "Gdecl" : { _a2 := simfun(e.init) if not (_a2 === e.init) then e := Gdecl(e.name, e.type, _a2) { e } } "Einstance_input" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Einstance_input(_a0, e.cons, e.name) { e } } "Gnomatch" : { { e } } "Gasgn" : { _a1 := simfun(e.x) if not (_a1 === e.x) then e := Gasgn(e.lhs, _a1) { e } } "Ebinding_instance" : { { e } } "bogus" : { { e } } "ppspec" : { { e } } "Einstance_tagged" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Einstance_tagged(_a0, e.cons, e.uid) { e } } "Eapp" : { _a1 := simfun(e.args) if not (_a1 === e.args) then e := Eapp(e.f, _a1) { e } } "Ewiden" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Ewiden(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 n := e.n if (iand(N,2^(n-1)) = 0) then iand(N,2^n-1) else ior(iand(2^wordsize-1,icom(2^n-1)),N) } else { e } } "Stoken" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Stoken(_a0, e.n, e.offset) { e } } "Eslice" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Eslice(_a0, e.lo, e.n) if (type(_a0) == "integer") then { N := _a0 lo := e.lo n := e.n iand(ishift(N, -lo), 2^n-1) } else { e } } "Semit" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Semit(_a0) { e } } "Gresynch" : { { e } } "Eand" : { _a0 := simfun(e.x) _a1 := simfun(e.y) if not (_a0 === e.x, _a1 === e.y) then e := Eand(_a0, _a1) if (_a0 === 1) then { x := _a1 x } else if (_a0 === 0) then { 0 } else if (_a1 === 1) then { x := _a0 x } else if (_a1 === 0) then { 0 } else { x := _a0 y := _a1 if type(x) == "set" & *x = 0 then y else if type(x) == "set" & *y = 0 then x else e } } "Eorb" : { _a0 := simfun(e.x) _a1 := simfun(e.y) if not (_a0 === e.x, _a1 === e.y) then e := Eorb(_a0, _a1) if (_a0 === 0) then { x := _a1 x } else if (_a1 === 0) then { x := _a0 x } else if (type(_a0) == "integer", type(_a1) == "integer") then { N := _a0 M := _a1 ior(N, M) } else if (type(_a0) == "Eorb", type(_a0.y) == "integer", type(_a1) == "integer") then { x := _a0.x N := _a0.y M := _a1 Eorb(x, ior(N, M)) } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eorb", type(_a0.e.y) == "integer", type(_a1) == "integer") then { x := _a0.e.x N := _a0.e.y M := _a1 Eorb(x, ior(N, M)) } else if (type(_a0) == "integer") then { N := _a0 x := _a1 Eorb(x, N) } else { e } } "Efitss" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Efitss(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 m := e.n if -(2^(m-1)) <= N < 2^(m-1) then 1 else 0 } else if (type(_a0) == "Enarrowu") then { x := _a0.x n := _a0.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrowu") then { x := _a0.e.x n := _a0.e.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Enarrows") then { x := _a0.x n := _a0.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrows") then { x := _a0.e.x n := _a0.e.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Eslice") then { x := _a0.x lo := _a0.lo n := _a0.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eslice") then { x := _a0.e.x lo := _a0.e.lo n := _a0.e.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Ewiden", type(_a0.x) == "Eslice") then { x := _a0.x.x lo := _a0.x.lo n := _a0.x.n m := _a0.n mm := e.n if n = m <= mm then 1 else if lo > 0 then simfun(Efitss(Ewiden(Eslice(x, 0, n+lo), m+lo), mm+lo)) else e } else if (type(_a0) == "Ewiden", type(_a0.x) == "Gcommented", type(_a0.x.e) == "Eslice") then { x := _a0.x.e.x lo := _a0.x.e.lo n := _a0.x.e.n m := _a0.n mm := e.n if n = m <= mm then 1 else if lo > 0 then simfun(Efitss(Ewiden(Eslice(x, 0, n+lo), m+lo), mm+lo)) else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Ewiden", type(_a0.e.x) == "Eslice") then { x := _a0.e.x.x lo := _a0.e.x.lo n := _a0.e.x.n m := _a0.e.n mm := e.n if n = m <= mm then 1 else if lo > 0 then simfun(Efitss(Ewiden(Eslice(x, 0, n+lo), m+lo), mm+lo)) else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Ewiden", type(_a0.e.x) == "Gcommented", type(_a0.e.x.e) == "Eslice") then { x := _a0.e.x.e.x lo := _a0.e.x.e.lo n := _a0.e.x.e.n m := _a0.e.n mm := e.n if n = m <= mm then 1 else if lo > 0 then simfun(Efitss(Ewiden(Eslice(x, 0, n+lo), m+lo), mm+lo)) else e } else if (type(_a0) == "Einstance_input") then { y := _a0 m := e.n if known_to_fit(input_fitss, y, &null, m) then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Einstance_input") then { y := _a0 m := e.n if known_to_fit(input_fitss, y, &null, m) then 1 else e } else if (type(_a0) == "Eshift") then { x := _a0.x n := _a0.n m := e.n simfun(Efitss(x, m-n)) } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eshift") then { x := _a0.e.x n := _a0.e.n m := e.n simfun(Efitss(x, m-n)) } else if (type(e.n) == "integer") then { x := _a0 M := e.n if M >= wordsize then 1 else e } else { e } } "Eshift" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Eshift(_a0, e.n) if (e.n === 0) then { x := _a0 x } else if (type(_a0) == "integer") then { N := _a0 n := e.n ishift(N, n) } else { e } } "Enarrows" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Enarrows(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 n := e.n if -(2^(n-1)) <= N < 2^(n-1) then iand(N,2^n-1) else Efail(expimage(e)) } else if (type(_a0) == "Ewiden") then { x := _a0.x n := _a0.n m := e.n if n = m then x else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Ewiden") then { x := _a0.e.x n := _a0.e.n m := e.n if n = m then x else e } else if (type(_a0) == "Enarrows") then { y := _a0 x := _a0.x n := _a0.n m := e.n if n = m then y else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrows") then { y := _a0 x := _a0.e.x n := _a0.e.n m := e.n if n = m then y else e } else { e } } "Enot" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Enot(_a0) if (type(_a0) == "integer") then { N := _a0 if N = 0 then 1 else 0 } else if (type(_a0) == "Enot") then { x := _a0.x x } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enot") then { x := _a0.e.x x } else { e } } "Ginrange" : { _a1 := simfun(e.x) if not (_a1 === e.x) then e := Ginrange(e.lo, _a1, e.hi) if (type(_a1) == "integer") then { lo := e.lo N := _a1 hi := e.hi if lo <= N < hi then 1 else 0 } else { e } } "Eclosure_addr" : { { e } } "Gdeclnamearray" : { { e } } "Ediv" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Ediv(_a0, e.n) { e } } "Gcase" : { _a0 := simfun(e.x) _a1 := simfun(e.arms) if not (_a0 === e.x, _a1 === e.arms) then e := Gcase(_a0, _a1) { e } } "Glines" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Glines(_a0) { e } } "Emod" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Emod(_a0, e.n) if (type(_a0) == "integer", type(e.n) == "integer") then { N := _a0 M := e.n {x := integer(N % M); while x < 0 do x +:= M; x} } else { e } } "Sepsilon" : { { e } } "Epc_known" : { { e } } "Efail" : { { e } } "Tunsigned" : { { e } } "Eforce" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Eforce(_a0) if (type(_a0) == "Eforce") then { x := _a0 x } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eforce") then { x := _a0 x } else if (type(_a0) == "integer") then { N := _a0 N } else { e } } "Sguarded" : { _a0 := simfun(e.guard) _a1 := simfun(e.x) if not (_a0 === e.guard, _a1 === e.x) then e := Sguarded(_a0, _a1) { e } } #line 342 "exp.nw" $undef simfun default : e } end #line 349 "exp.nw" procedure super_simplify(e) local left, right return case type(e) of { $define simfun super_simplify #line 363 "exp.nw" "eqn" : { #line 448 "exp.nw" l := simfun(e.left) r := simfun(e.right) if exps_eq(l, r) then if e.left === 0 & e.right === 0 then e else eqn(0, e.op, 0) else if simfun === super_simplify & # not safe for decoding! see bugs{nnn} ( (type(l) == "Enarrows", type(r) == "Eslice", r.lo = 0) | (type(l) == "Eslice", type(r) == "Enarrows", l.lo = 0) ) & l.n = r.n & exps_eq(l.x, r.x) then simfun(Efitss(l.x, l.n)) else if e.left === l & e.right === r then e else eqn(l, e.op, r) #line 363 "exp.nw" } "pattern" : { #line 392 "exp.nw" l := []; every put(l, simfun(!e.disjuncts)) if lists_match(l, e.disjuncts) then e else pattern(l, e.name) #line 364 "exp.nw" } "disjunct" : { #line 395 "exp.nw" c := simfun(e.conditions) if member(\c, 0) then fail else { l := []; every put(l, vanishing_latent_patlabel ~=== simfun(!e.sequents)) if lists_match(l, e.sequents) then l := e.sequents if ss := !l & type(ss) == "sequent" & cc := !ss.constraints & type(cc) == "constraint" & cc.lo >= cc.hi then fail # this disjunct can't match -- eliminate it if c === e.conditions & l === e.sequents then e else disjunct(l, e.name, c) } #line 365 "exp.nw" } "adisjunct": { #line 407 "exp.nw" c := simfun(e.conditions) if member(\c, 0) then fail else { l := simfun(e.aconstraints) if cc := !l & type(cc) == "constraint" & cc.lo >= cc.hi then fail # this disjunct can't match -- eliminate it if c === e.conditions & l === e.aconstraints then e ### & a === e.answers then e else adisjunct(l, e.name, c, e.length, e.patlabelbindings) ### , a) } #line 366 "exp.nw" } "sequent" : if (l := simfun(e.constraints)) === e.constraints then e else sequent(l, e.class) "patlabel" : e "dots_sequent" : e "constraint" : e "fieldbinding" : if (x := simfun(e.code)) === e.code then e else fieldbinding(e.field, x) "absolute_field" : e # don't call super_simplify --- can't spot which fields are used any more! # change 50 "set" : { #line 417 "exp.nw" s := set() every x := simfun(!e) do { if type(x) == "eqn" then { if x.op == "=" & x.left === x.right then x := 1 else if x.op == "!=" & x.left === x.right then x := 0 } insert(s, x) } delete(s, 1) return if member(s, 0) then set([0]) else if sets_match(e, s) then e else if *s = 0 then &null else s #line 377 "exp.nw" } "table" : { #line 437 "exp.nw" m := copy(e) every k := key(e) do { m[k] -:= e[k] add_to_table(m, simfun(k), e[k]) } every k := key(m) & m[k] = 0 do delete(m, k) if *m > 1 then return if tables_match(m, e) then e else m else return if !m = 1 then key(m) else if key(m) === 1 then !m else m #line 378 "exp.nw" } "list" : {l := maplist(simfun, e); if lists_match(e, l) then e else l} "integer" | "string" : e "Einstance" : { #line 431 "exp.nw" every k := key(e.argt) do e.argt[k] := simfun(e.argt[k]) e #line 381 "exp.nw" } "Stagcase" : { #line 434 "exp.nw" every k := key(e.arms) do e.arms[k] := simfun(e.arms[k]) e #line 382 "exp.nw" } "Sif" : { #line 463 "exp.nw" a := simp_arms(e.arms, simfun) if *a = 0 then Sepsilon() else if *a = 1 & guard_always_satisfied(a[1].guard) then a[1].x else if a === (e.arms) then e else Sif(a) #line 383 "exp.nw" } "Enosimp" : e # suppresses simplification "Gcommented" : if (ee := simfun(e.e)) === e.e then e else Gcommented(ee, e.comment) "Gcomment" : e #line 354 "exp.nw" #line 1 "supersimp.gen" "Gblock" : { _a0 := simfun(e.decls) _a1 := simfun(e.stmts) if not (_a0 === e.decls, _a1 === e.stmts) then e := Gblock(_a0, _a1) { e } } "Gcall" : { _a1 := simfun(e.args) if not (_a1 === e.args) then e := Gcall(e.name, _a1) { e } } "Sstmts" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Sstmts(_a0) { l := _a0 case *l of { 0 : Sepsilon(); 1: l[1]; default : e } } } "Gsetname" : { { e } } "Tsigned" : { { e } } "Gcommented" : { { e } } "Eclosure_loc" : { { e } } "Eforceable" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Eforceable(_a0) if (type(_a0) == "integer") then { N := _a0 1 } else { e } } "Efitsu" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Efitsu(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 m := e.n if 0 <= N < 2^m then 1 else 0 } else if (type(_a0) == "Enarrowu") then { x := _a0.x n := _a0.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrowu") then { x := _a0.e.x n := _a0.e.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Enarrows") then { x := _a0.x n := _a0.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrows") then { x := _a0.e.x n := _a0.e.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Eslice") then { x := _a0.x lo := _a0.lo n := _a0.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eslice") then { x := _a0.e.x lo := _a0.e.lo n := _a0.e.n m := e.n if n <= m then 1 else e } else if (type(_a0) == "Einstance_input") then { y := _a0 m := e.n if known_to_fit(input_fitsu, y, &null, m) then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Einstance_input") then { y := _a0 m := e.n if known_to_fit(input_fitsu, y, &null, m) then 1 else e } else if (type(_a0) == "Eshift") then { x := _a0.x n := _a0.n m := e.n simfun(Efitsu(x, m-n)) } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eshift") then { x := _a0.e.x n := _a0.e.n m := e.n simfun(Efitsu(x, m-n)) } else if (type(e.n) == "integer") then { x := _a0 M := e.n if M >= wordsize then 1 else e } else { e } } "Epc" : { { e } } "eqn" : { _a0 := simfun(e.left) _a2 := simfun(e.right) if not (_a0 === e.left, _a2 === e.right) then e := eqn(_a0, e.op, _a2) { e } } "Eclosure_val" : { { e } } "Enarrowu" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Enarrowu(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 n := e.n if 0 <= N < 2^n then N else Efail(expimage(e)) } else if (type(_a0) == "Eslice") then { y := _a0 x := _a0.x lo := _a0.lo n := _a0.n m := e.n if n <= m then y else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eslice") then { y := _a0 x := _a0.e.x lo := _a0.e.lo n := _a0.e.n m := e.n if n <= m then y else e } else if (type(e.n) == "integer") then { x := _a0 M := e.n if M >= wordsize then x else e } else { e } } "Epatlabel" : { { e } } "Gcasearm" : { _a1 := simfun(e.x) if not (_a1 === e.x) then e := Gcasearm(e.tags, _a1) { e } } "Gdecl" : { _a2 := simfun(e.init) if not (_a2 === e.init) then e := Gdecl(e.name, e.type, _a2) { e } } "Einstance_input" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Einstance_input(_a0, e.cons, e.name) { e } } "Gnomatch" : { { e } } "Gasgn" : { _a1 := simfun(e.x) if not (_a1 === e.x) then e := Gasgn(e.lhs, _a1) { e } } "Ebinding_instance" : { { e } } "bogus" : { { e } } "ppspec" : { { e } } "Einstance_tagged" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Einstance_tagged(_a0, e.cons, e.uid) { e } } "Eapp" : { _a1 := simfun(e.args) if not (_a1 === e.args) then e := Eapp(e.f, _a1) { e } } "Ewiden" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Ewiden(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 n := e.n if (iand(N,2^(n-1)) = 0) then iand(N,2^n-1) else ior(iand(2^wordsize-1,icom(2^n-1)),N) } else { x := _a0 n := e.n if n = wordsize then x else e } } "Stoken" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Stoken(_a0, e.n, e.offset) { e } } "Eslice" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Eslice(_a0, e.lo, e.n) if (type(_a0) == "integer") then { N := _a0 lo := e.lo n := e.n iand(ishift(N, -lo), 2^n-1) } else if (type(_a0) == "Eshift") then { x := _a0.x n := _a0.n m := e.lo k := e.n if m - n >= 0 then Eslice(x, m-n, k) else Eslice(Eshift(x, n-m), 0, k) } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eshift") then { x := _a0.e.x n := _a0.e.n m := e.lo k := e.n if m - n >= 0 then Eslice(x, m-n, k) else Eslice(Eshift(x, n-m), 0, k) } else if (type(_a0) == "Enarrowu", e.lo === 0) then { y := _a0 x := _a0.x n := _a0.n m := e.n if n <= m then y else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrowu", e.lo === 0) then { y := _a0 x := _a0.e.x n := _a0.e.n m := e.n if n <= m then y else e } else if (type(_a0) == "Enarrows", e.lo === 0) then { y := _a0 x := _a0.x n := _a0.n m := e.n if n <= m then y else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrows", e.lo === 0) then { y := _a0 x := _a0.e.x n := _a0.e.n m := e.n if n <= m then y else e } else if (type(_a0) == "Eslice") then { x := _a0.x l1 := _a0.lo n1 := _a0.n l2 := e.lo n2 := e.n if l2 >= n1 then 0 else Eslice(x, l1+l2, if n2 < n1-l2 then n2 else n1-l2) } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eslice") then { x := _a0.e.x l1 := _a0.e.lo n1 := _a0.e.n l2 := e.lo n2 := e.n if l2 >= n1 then 0 else Eslice(x, l1+l2, if n2 < n1-l2 then n2 else n1-l2) } else if (type(_a0) == "Einstance_input", e.lo === 0) then { y := _a0 x := _a0.x c := _a0.cons name := _a0.name n := e.n if ipt := inputs_of(c) & ipt.name == name & case type(ipt.meaning) of { "field" : fwidth(ipt.meaning) <= n } then y else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Einstance_input", e.lo === 0) then { y := _a0 x := _a0.e.x c := _a0.e.cons name := _a0.e.name n := e.n if ipt := inputs_of(c) & ipt.name == name & case type(ipt.meaning) of { "field" : fwidth(ipt.meaning) <= n } then y else e } else if (e.lo === 0) then { x := _a0 n := e.n if n = wordsize then x else e } else { e } } "Semit" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Semit(_a0) { e } } "Gresynch" : { { e } } "Eand" : { _a0 := simfun(e.x) _a1 := simfun(e.y) if not (_a0 === e.x, _a1 === e.y) then e := Eand(_a0, _a1) if (_a0 === 1) then { x := _a1 x } else if (_a0 === 0) then { 0 } else if (_a1 === 1) then { x := _a0 x } else if (_a1 === 0) then { 0 } else { x := _a0 y := _a1 if type(x) == "set" & *x = 0 then y else if type(x) == "set" & *y = 0 then x else e } } "Eorb" : { _a0 := simfun(e.x) _a1 := simfun(e.y) if not (_a0 === e.x, _a1 === e.y) then e := Eorb(_a0, _a1) if (_a0 === 0) then { x := _a1 x } else if (_a1 === 0) then { x := _a0 x } else if (type(_a0) == "integer", type(_a1) == "integer") then { N := _a0 M := _a1 ior(N, M) } else if (type(_a0) == "Eorb", type(_a0.y) == "integer", type(_a1) == "integer") then { x := _a0.x N := _a0.y M := _a1 Eorb(x, ior(N, M)) } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eorb", type(_a0.e.y) == "integer", type(_a1) == "integer") then { x := _a0.e.x N := _a0.e.y M := _a1 Eorb(x, ior(N, M)) } else if (type(_a0) == "integer") then { N := _a0 x := _a1 Eorb(x, N) } else { e } } "Efitss" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Efitss(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 m := e.n if -(2^(m-1)) <= N < 2^(m-1) then 1 else 0 } else if (type(_a0) == "Enarrowu") then { x := _a0.x n := _a0.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrowu") then { x := _a0.e.x n := _a0.e.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Enarrows") then { x := _a0.x n := _a0.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrows") then { x := _a0.e.x n := _a0.e.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Eslice") then { x := _a0.x lo := _a0.lo n := _a0.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eslice") then { x := _a0.e.x lo := _a0.e.lo n := _a0.e.n m := e.n if n < m then 1 else e } else if (type(_a0) == "Ewiden", type(_a0.x) == "Eslice") then { x := _a0.x.x lo := _a0.x.lo n := _a0.x.n m := _a0.n mm := e.n if n = m <= mm then 1 else if lo > 0 then simfun(Efitss(Ewiden(Eslice(x, 0, n+lo), m+lo), mm+lo)) else e } else if (type(_a0) == "Ewiden", type(_a0.x) == "Gcommented", type(_a0.x.e) == "Eslice") then { x := _a0.x.e.x lo := _a0.x.e.lo n := _a0.x.e.n m := _a0.n mm := e.n if n = m <= mm then 1 else if lo > 0 then simfun(Efitss(Ewiden(Eslice(x, 0, n+lo), m+lo), mm+lo)) else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Ewiden", type(_a0.e.x) == "Eslice") then { x := _a0.e.x.x lo := _a0.e.x.lo n := _a0.e.x.n m := _a0.e.n mm := e.n if n = m <= mm then 1 else if lo > 0 then simfun(Efitss(Ewiden(Eslice(x, 0, n+lo), m+lo), mm+lo)) else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Ewiden", type(_a0.e.x) == "Gcommented", type(_a0.e.x.e) == "Eslice") then { x := _a0.e.x.e.x lo := _a0.e.x.e.lo n := _a0.e.x.e.n m := _a0.e.n mm := e.n if n = m <= mm then 1 else if lo > 0 then simfun(Efitss(Ewiden(Eslice(x, 0, n+lo), m+lo), mm+lo)) else e } else if (type(_a0) == "Einstance_input") then { y := _a0 m := e.n if known_to_fit(input_fitss, y, &null, m) then 1 else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Einstance_input") then { y := _a0 m := e.n if known_to_fit(input_fitss, y, &null, m) then 1 else e } else if (type(_a0) == "Eshift") then { x := _a0.x n := _a0.n m := e.n simfun(Efitss(x, m-n)) } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eshift") then { x := _a0.e.x n := _a0.e.n m := e.n simfun(Efitss(x, m-n)) } else if (type(e.n) == "integer") then { x := _a0 M := e.n if M >= wordsize then 1 else e } else { e } } "Eshift" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Eshift(_a0, e.n) if (e.n === 0) then { x := _a0 x } else if (type(_a0) == "integer") then { N := _a0 n := e.n ishift(N, n) } else { e } } "Enarrows" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Enarrows(_a0, e.n) if (type(_a0) == "integer") then { N := _a0 n := e.n if -(2^(n-1)) <= N < 2^(n-1) then iand(N,2^n-1) else Efail(expimage(e)) } else if (type(_a0) == "Eslice") then { y := _a0 x := _a0.x lo := _a0.lo n := _a0.n m := e.n if n < m then y else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eslice") then { y := _a0 x := _a0.e.x lo := _a0.e.lo n := _a0.e.n m := e.n if n < m then y else e } else if (type(_a0) == "Ewiden") then { x := _a0.x n := _a0.n m := e.n if n = m then x else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Ewiden") then { x := _a0.e.x n := _a0.e.n m := e.n if n = m then x else e } else if (type(_a0) == "Enarrows") then { y := _a0 x := _a0.x n := _a0.n m := e.n if n = m then y else e } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enarrows") then { y := _a0 x := _a0.e.x n := _a0.e.n m := e.n if n = m then y else e } else if (type(e.n) == "integer") then { x := _a0 M := e.n if M >= wordsize then x else e } else { e } } "Enot" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Enot(_a0) if (type(_a0) == "integer") then { N := _a0 if N = 0 then 1 else 0 } else if (type(_a0) == "Enot") then { x := _a0.x x } else if (type(_a0) == "Gcommented", type(_a0.e) == "Enot") then { x := _a0.e.x x } else { e } } "Ginrange" : { _a1 := simfun(e.x) if not (_a1 === e.x) then e := Ginrange(e.lo, _a1, e.hi) if (type(_a1) == "integer") then { lo := e.lo N := _a1 hi := e.hi if lo <= N < hi then 1 else 0 } else { e } } "Eclosure_addr" : { { e } } "Gdeclnamearray" : { { e } } "Ediv" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Ediv(_a0, e.n) if (type(_a0) == "integer", type(e.n) == "integer") then { N := _a0 M := e.n if N > 0 then N / M else (N - M + 1) / M # force toward - infinity } else if (type(e.n) == "integer") then { x := _a0 N := e.n simfun(Eshift(x, - exactlog2(N))) | e } else { e } } "Gcase" : { _a0 := simfun(e.x) _a1 := simfun(e.arms) if not (_a0 === e.x, _a1 === e.arms) then e := Gcase(_a0, _a1) { e } } "Glines" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Glines(_a0) { e } } "Emod" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Emod(_a0, e.n) if (type(_a0) == "integer", type(e.n) == "integer") then { N := _a0 M := e.n {x := integer(N % M); while x < 0 do x +:= M; x} } else if (type(e.n) == "integer") then { x := _a0 N := e.n if x := strip_const_multiple_N(x, N) then simfun(Eslice(x, 0, exactlog2(N))) | Emod(x, N) else simfun(Eslice(x, 0, exactlog2(N))) | e } else { e } } "Sepsilon" : { { e } } "Epc_known" : { { e } } "Efail" : { { e } } "Tunsigned" : { { e } } "Eforce" : { _a0 := simfun(e.x) if not (_a0 === e.x) then e := Eforce(_a0) if (type(_a0) == "Eforce") then { x := _a0 x } else if (type(_a0) == "Gcommented", type(_a0.e) == "Eforce") then { x := _a0 x } else if (type(_a0) == "integer") then { N := _a0 N } else { e } } "Sguarded" : { _a0 := simfun(e.guard) _a1 := simfun(e.x) if not (_a0 === e.guard, _a1 === e.x) then e := Sguarded(_a0, _a1) { e } } #line 355 "exp.nw" $undef simfun default : e } end #line 469 "exp.nw" procedure simp_arms(earms, simfun) local arms l := [] arms := copy(earms) while a := get(arms) & g := simfun(a.guard) do if guard_always_satisfied(g) then { # always take this arm c := simfun(a.x) put(l, if exps_eq(g, a.guard) & exps_eq(c, a.x) then a else Sguarded(g, c)) return if lists_match(l, earms) then earms else l } else if not case type(g) of { "integer" : g = 0 "set" : member(g, 0) } then { # sometimes take this arm c := simfun(a.x) put(l, if exps_eq(g, a.guard) & exps_eq(c, a.x) then a else Sguarded(g, c)) } return if lists_match(l, earms) then earms else l end #line 488 "exp.nw" procedure guard_always_satisfied(g) return case type(g) of { "integer" : g = 1 "set" : *g = 0 "null" : &null } end #line 561 "exp.nw" procedure strip_const_multiple_N(x, N) local y if type(x) == "table" & x[1] ~= 0 & x[1] % N = 0 then { y := copy(x) y[1] := 0 return y } end #line 609 "exp.nw" procedure exactlog2(n) local log log := 0 while 2^log < n do log +:= 1 if n = 2^log then return log else fail end #line 621 "exp.nw" procedure expimage(e, pp, precedence, associativity) local leadingsign, prefix static nopp initial { #line 970 "exp.nw" ops := ["N", ["low"], "L", ["|", "pattern"], "L", [";"], "L", ["&", "sequent", "patlabel"], "R", [":="], "L", [","], "N", ["Sguarded"], "N", ["="], "L", ["ORB", "Eorb"], "L", ["AND", "Eand"], "L", ["<", "<="], "L", ["+"], "N", ["Emod", "Ediv", "*"], "N", ["Eshift"], "N", ["NOT"], "L", ["Eslice", "Enarrowu", "Enarrows", "Ewiden", "."], "N", ["app"], # function application "N", ["high"] ] prec := table([]) # missed lookups break arithmetic comparisons assoc := table() every i := 1 to *ops by 2 do { every prec[!ops[i+1]] := i assoc[i] := ops[i] } #line 625 "exp.nw" #line 639 "exp.nw" nopp := ppspec("", "", "", "", "", "", "") #line 625 "exp.nw" } /pp := nopp /precedence := 0 /associativity := "L" return case type(e) of { #line 647 "exp.nw" "arm" : pp.in || "| @" || e.file || ":" || e.line || ": " || pp.be || expimage(e.pattern, pp) || pp.en || " => " || pp.cn || expimage(e.code, pp) || pp.ou #line 651 "exp.nw" "pattern" : if *e.disjuncts > 0 then { s := commaseparate(maplist3(expimage, e.disjuncts, pp, prec["|"]), " " || pp.cn || "| ") bracket(s, pp, "|", precedence) ### || ("[[" || \e.name || "]]" | "") } else "" #line 657 "exp.nw" "disjunct" : { s := "(" || (if \e.name then e.name else "?noname?") || ") " s ||:= if *\e.conditions > 0 then "{" || pp.be || expimage(e.conditions, pp) || pp.en || "} => " || pp.in || pp.cn else "" s ||:= if *e.sequents = 0 then "epsilon" else { prefix := "" every i := 1 to *e.sequents do { s ||:= prefix || expimage(e.sequents[i], pp, prec[";"]) prefix := (if type(e.sequents[i]) == ("patlabel"|"latent_patlabel") then ": " else "; ") || pp.on } } s ||:= if *\e.conditions > 0 then pp.ou else "" bracket(s, pp, ";", precedence) ### || ("[" || \e.name || "]" | "") } #line 677 "exp.nw" "adisjunct" : { s := "(" || (if \e.name then e.name else "?noname?") || ") " s ||:= if \e.patlabelbindings then { "[" || pp.in || pp.be || bindingimage(e.patlabelbindings, pp) || pp.en || pp.ou || "] " || pp.cn } else "" s ||:= if *\e.conditions > 0 then "{" || pp.be || expimage(e.conditions, pp) || pp.en || "} => " || pp.in || pp.cn else "" s ||:= "LENGTH = " || expimage(e.length) || ", " s ||:= if *e.aconstraints = 0 then "" else commaseparate(maplist3(expimage, e.aconstraints, pp, prec["&"]), " & " || pp.on) s ||:= if *\e.conditions > 0 then pp.ou else "" ### if *\e.answers > 0 then { ### l := [] ### every k := key(e.answers) do ### put(l, k || " = " || expimage(e.answers[k], pp, prec["="])) ### s ||:= pp.in || pp.on || "{" || pp.in || pp.be || ### commaseparate(l, ", " || pp.cn) || pp.en || pp.ou || "}" || pp.ou ### } bracket(s, pp, "&", precedence) } #line 712 "exp.nw" "sequent" : { s := if *e.constraints = 0 then "some " || e.class.name else commaseparate(maplist3(expimage, e.constraints, pp, prec["&"]), " & " || pp.on) pp.be || bracket(s, pp, "&", precedence) || pp.en } "patlabel" : \e.name | e.original_name || "#" || image(e)[17:-3] || ("@" || \e.offset | "") || ":" "latent_patlabel" : "(?" || expimage(e.instance, pp, prec[","]) || ":)" "dots_sequent" : "..." "constraint" : bracket(stringininterval(expimage(e.field, pp, prec["="]), e.lo, e.hi), pp, "=", precedence) "fieldbinding" : { s := expimage(e.field) || " = " || expimage(e.code, pp,prec["="]) bracket(s, pp, "=", precedence) } "field" : e.name "absolute_field" : "{" || expimage(e.field) || " at " || e.offset || "}" #line 729 "exp.nw" "binding_instance" : expimage(e.val) || " : " || expimage(e.type) "constype" : "constructor-type " || e.name #line 732 "exp.nw" "list" : commaseparate(maplist3(expimage, e, pp, prec[","]), ", " || pp.on) "set" : commaseparate(maplist3(expimage, sort(e), pp, prec[","]), ", " || pp.on) "eqn" : bracket(expimage(e.left, pp, prec["="]) || " " || e.op || " " || pp.on || expimage(e.right, pp, prec["="]), pp, "=", precedence) "table" : { # standard normal form #line 748 "exp.nw" { s := ""; leadingsign := "" #line 756 "exp.nw" every e[k := 1 ~=== key(e)] > 0 do { s ||:= leadingsign s ||:= (1 ~= abs(e[k])) || "*" # print coefficient if not 1 s ||:= expimage(k, pp, prec["+"]) leadingsign := " + " || pp.on } if e[1] > 0 then s ||:= leadingsign || string(e[1]) #line 751 "exp.nw" leadingsign := " - " || pp.on #line 764 "exp.nw" every e[k := 1 ~=== key(e)] < 0 do { s ||:= leadingsign s ||:= (1 ~= abs(e[k])) || "*" # print coefficient if not 1 s ||:= expimage(k, pp, prec["+"]) } if e[1] < 0 then s ||:= leadingsign || string(-e[1]) #line 753 "exp.nw" s := if s == "" then "0" else bracket(s, pp, "+", precedence) } #line 738 "exp.nw" pp.in || pp.be || s || pp.en || pp.ou } "string" : e "literal" : image(e.s) "integer" : string(e) "null" : image(e) #line 786 "exp.nw" "Eorb" : { s := expimage(e.x, pp, prec["Eorb"], "L") t := expimage(e.y, pp, prec["Eorb"], "R") bracket(s || " ORB " || pp.on || t, pp, "Eorb", precedence) } "Eand" : { s := expimage(e.x, pp, prec["Eand"], "L") t := expimage(e.y, pp, prec["Eand"], "R") bracket(s || " AND " || t, pp, "Eand", precedence) } #line 795 "exp.nw" "Eslice" : { s := expimage(e.x, pp, prec["Eslice"]) s ||:= "[" || e.lo || ":" || (e.lo + e.n - 1) || "]" bracket(s, pp, "Eslice", precedence) } "Eshift" : { s := expimage(e.x, pp, prec["Eshift"]) s ||:= if e.n < 0 then (" >> " || -e.n) else (" << " || e.n) bracket(s, pp, "Eshift", precedence) } #line 804 "exp.nw" "Enarrowu" : { s := expimage(e.x, pp, prec["Enarrowu"]) s ||:= "[" || e.n || "]" bracket(s, pp, "Enarrowu", precedence) } "Enarrows" : { s := expimage(e.x, pp, prec["Enarrows"]) s ||:= "[" || e.n || "!]" bracket(s, pp, "Enarrows", precedence) } "Ewiden" : { s := expimage(e.x, pp, prec["Ewiden"]) s ||:= "!" || e.n bracket(s, pp, "Ewiden", precedence) } #line 817 "exp.nw" "Ediv" : { s := expimage(e.x, pp, prec["Ediv"]) s ||:= " DIV " || e.n bracket(s, pp, "Ediv", precedence) } "Emod" : { s := expimage(e.x, pp, prec["Emod"]) s ||:= " MOD " || e.n bracket(s, pp, "Emod", precedence) } #line 826 "exp.nw" "Semit" : commaseparate(maplist3(expimage, e.x, pp, prec[","]), ";" || pp.cn) "Stoken" : { s := "EMIT@" || e.offset || "(" || pp.in || expimage(e.x, pp, prec[","]) || ", " || pp.on || e.n || ")" || pp.ou bracket(pp.cn || s, pp, "app", precedence) } #line 833 "exp.nw" "Efitsu" : { s := "FITSU(" || expimage(e.x, pp, prec[","]) || ", " || pp.on || e.n||")" bracket(s, pp, "app", precedence) } "Efitss" : { s := "FITSS(" || expimage(e.x, pp, prec[","]) || ", " || pp.on ||e.n ||")" bracket(s, pp, "app", precedence) } #line 840 "exp.nw" "Epatlabel" : "LOCATION_OF(" || expimage(e.l, pp, prec[","]) || ")" #line 842 "exp.nw" "Eforce" : { s := "FORCE(" || expimage(e.x, pp, prec[","]) || ")" bracket(s, pp, "app", precedence) } "Eforceable":{ s := "FORCEABLE(" || expimage(e.x, pp, prec[","]) || ")" bracket(s, pp, "app", precedence) } #line 849 "exp.nw" "Epc" : "FORCE()" "Epc_known" :" FORCEABLE()" #line 852 "exp.nw" "Enot" : { s := "NOT " || expimage(e.x, pp, prec["NOT"]) bracket(s, pp, "NOT", precedence) } #line 856 "exp.nw" "Enosimp" : expimage(e.x, pp, precedence, associativity) #line 858 "exp.nw" "Sstmts" : pp.in || pp.be || "{ " || pp.cn || commaseparate(maplist3(expimage, e.x, pp), "; " || pp.cn) || pp.ou || pp.cn || " }" || pp.en #line 862 "exp.nw" "Einstance" : { l := []; every i := inputs_of(e.cons) do put(l, expimage(e.argt[i.name], pp)) s := e.cons.name || "(" || commaseparate(l, ", " || pp.on) || ")" bracket(s, pp, "app", precedence) } "Einstance_input" : { s := expimage(e.x, pp, prec["."]) || "." || e.cons.name || "." || e.name bracket(s, pp, ".", precedence) } "Einstance_tagged" : { s := expimage(e.x, pp, prec["="]) || " IS " || e.cons.name bracket(s, pp, "=", precedence) } "Ebinding_instance" : e.name || " : " || e.type.name #line 878 "exp.nw" "Sif" : { s := pp.cn || "if" every s ||:= pp.cn || ":: " || pp.in || expimage(!e.arms, pp, prec["low"]) || pp.ou bracket(s || " " || pp.cn || "fi", pp, "app", precedence) } "Sguarded" : { s := expimage(e.guard, pp, prec["Sguarded"]) || " -> " || pp.in || pp.be || pp.cn || expimage(e.x, pp, prec["Sguarded"]) || pp.en || pp.ou bracket(s, pp, "Sguarded", precedence) } #line 890 "exp.nw" "Stagcase" : { s := "CASE " || expimage(e.x, pp) || " OF " every c := kept_constructors(e.type) do s ||:= pp.nl || "| " || c.name || " => " || pp.in || pp.in || pp.be || pp.cn || expimage(e.arms[c], pp) || pp.en || pp.ou || pp.ou pp.be || pp.cn || s || pp.nl || "END (* " || expimage(e.x, pp) || " *)" || pp.en || pp.on } #line 898 "exp.nw" "Sfail" : { s := "FAIL(" || image(if *pp.nl > 0 then escape_dollars(e.fmt) else e.fmt) every a := e.a1 | e.a2 | e.a3 do s ||:= ", " || pp.on || expimage(\a, pp, prec[","]) s := pp.in || pp.be || s || ")" || pp.en || pp.ou bracket(s, pp, "app", precedence) } "Sepsilon" : "/* skip */" #line 906 "exp.nw" "Efail" : "[BAD EXP: " || e.msg || "]" #line 908 "exp.nw" "Glines" : commaseparate(maplist2(expimage, e.x, pp), "\n") "Gresynch" : "#line " || e.line || " " || image(\e.file | "generated-code") "Gblock" : { s := "{ " || pp.be || pp.in || pp.cn every s ||:= expimage(!e.decls, pp) || "; " || pp.nl every s ||:= expimage(!e.stmts, pp) || "; " || pp.cn s || pp.ou || pp.cn || "}" || pp.en } "Gdecl" : { s := pp.be || expimage(e.type, pp) || " " || e.name s ||:= " = " || pp.in || pp.cn || expimage(\e.init, pp) || pp.ou s || pp.en } #line 920 "exp.nw" "Gcase" : { s := "CASE " || expimage(e.x, pp) || " OF " every s ||:= expimage(!e.arms, pp) pp.be || pp.cn || s || pp.nl || "END (* CASE " || expimage(e.x, pp) || " *)" || pp.en || pp.on } "Gcasearm" : { s := pp.nl || "| " || pp.in every i := 1 to *e.tags by 2 do { if i > 1 then s ||:= ", " || pp.on s ||:= if e.tags[i] + 1 = e.tags[i+1] then e.tags[i] else e.tags[i] || ".." || (e.tags[i+1]-1) } s ||:= " => " || pp.in || pp.cn || expimage(e.x, pp) pp.be || s || pp.ou || pp.ou || pp.en } "Ginrange" : bracket(pp.in || e.lo || " <= " || pp.on || expimage(e.x, pp, prec["<="]) || " < " || e.hi, pp, "<", precedence) "Gcomment" : "(* COMMENT : " || e.s || " *)" "Gcommented" : expimage(e.e, pp) #line 940 "exp.nw" "Gasgn" : bracket(e.lhs || " := " || expimage(e.x, pp, prec[":="]), pp, ":=", precedence) "Gsetname" : e.lhs || " := " || image(e.name) "Gnomatch" : "" "Tunsigned" : { s := "unsigned" s ||:= " /* " || \e.width || " bits */" s } #line 949 "exp.nw" "Eapp" : image(e.f) || "(" || pp.in || expimage(e.args, pp, prec[","]) || pp.ou || ")" #line 951 "exp.nw" "Eclosure" : "CLOSURE(" || pp.in || pp.be || pp.cn || "type = " || e.ty || ", " || pp.cn || "fun = " || e.fun || ", " || pp.cn || "header = " || e.headertype || ", " || pp.cn || "values = {" || expimage(e.values) || "}, " || pp.cn || "addresses = {" || expimage(e.addresses) || "}" || pp.en || pp.ou || ")" "Elambda" : pp.be || "(FN " || commaseparate(e.formals) || " => " || pp.in || pp.on || expimage(e.body, pp, prec[","]) || ")" || pp.ou || pp.en "Eclosure_loc" : "CL->loc" "Eclosure_addr" : "CL->a" || e.n "Eclosure_val" : "CL->v" || e.n #line 631 "exp.nw" default : (proc(type(e) || "image") | image)(e) } end #line 637 "exp.nw" record ppspec(be, en, in, ou, nl, on, cn) # { } t b m o c #line 641 "exp.nw" procedure ppexpimage(e) static pp initial pp := ppspec("${", "$}", "$t", "$b", "$n", "$o", "$c") return expimage(e, pp) end #line 701 "exp.nw" procedure bindingimage(t, pp) local sep, id sep := "" s := "" every id := key(t) do { s ||:= sep || pp.be || id || " -> " || expimage(t[id], pp) || pp.en sep := ", " || pp.on } return s end #line 963 "exp.nw" global prec, assoc procedure bracket(s, pp, op, p, a) /a := "L" return pp.be || (if prec[op] > p | (prec[op] = p & assoc[p] == a) then s else "(" || s || ")") || pp.en end #line 997 "exp.nw" procedure escape_dollars(s) r := "" s ? { while r ||:= tab(upto('$')) do { ="$"; r ||:= "$$" } return r || tab(0) } end #line 1010 "exp.nw" procedure binop(e1, op, e2) e1 := term2table(e1) e2 := term2table(e2) case op of { "+" : every v := key(e2) do e1[v] +:= e2[v] "-" : every v := key(e2) do e1[v] -:= e2[v] "*" : if n2 := constant(e2) then { every !e1 *:= n2 } else if n1 := constant(e1) then { every !e2 *:= n1 e1 := e2 } else error("multiplication must be by constants only") "/" : error("division is not permitted in this language") } return e1 end #line 1027 "exp.nw" procedure term2table(x) return case type(x) of { "table" : x "integer" : 1(e := table(0), e[1] := x) default : 1(e := table(0), e[x] := 1) } end #line 1037 "exp.nw" procedure addconst(e, n) if n = 0 then return e if type(e) == "table" then t := copy(e) else { t := table(0) if type(t) == "integer" then t[1] := e else t[e] := 1 } t[1] +:= n return t end #line 1051 "exp.nw" procedure constant(e) if type(c := untable(e)) == "integer" then return c end #line 1056 "exp.nw" procedure untable(e) return if type(e) ~== "table" then e else { n := 0 every k := key(e) & e[k] ~= 0 do n +:= 1 case n of { 0 : 0 1 : if k := key(e) & e[k] = 1 then k else if e[1] ~= 0 then e[1] else e default : e } } end #line 1075 "exp.nw" procedure mkslice(x, lo, hi) local n # size of range if lo < 0 then error("Can't take negative bit slice!!") if hi <= lo then error(expimage(x), "[", lo, ":", hi - 1, "] has no bits!") if hi > bitsizeof(x) then error(if type(f := symtab[x]) == "field" then "Field " || f.name else "Host machine", " has only ", bitsizeof(x), " bits") bit_numbering_used := 1 #line 1088 "exp.nw" if /bit_zero_is_lsb then { lo := bitsizeof(x) - hi hi := bitsizeof(x) - lo } #line 1085 "exp.nw" return Eslice(x, lo, hi - lo) end #line 1093 "exp.nw" procedure bitsizeof(f) return case type(symtab[f]) of { "field" : fwidth(symtab[f]) default : wordsize } end #line 1100 "exp.nw" procedure fwidth(f) return f.hi - f.lo end #line 1104 "exp.nw" procedure mkshift(x, n) return if n = 0 then x else ishift(\simp & constant(x), n) | Eshift(x, n) end #line 1109 "exp.nw" record bogus(e) # ditch invalid field name complaint #line 1114 "exp.nw" procedure flatten(e, ty, l) /l := [] return if type(e) == ty then flatten(e.x, ty, flatten(e.y, ty, l)) else push(l, e) end #line 1124 "exp.nw" procedure unflatten(l, rator, zero) if *l = 0 then return zero else { x := l[1] every x := rator(x, l[2 to *l]) } return x end #================================================================= expwalk.icn #line 5 "expwalk.nw" procedure expwalk(e, f, closure[]) suspend do_expwalk(e, f, closure) end procedure do_expwalk(e, f, closure) suspend case type(e) of { #line 17 "expwalk.nw" "pattern" : do_expwalk(!e.disjuncts, f, closure) "disjunct" : do_expwalk(!\e.conditions | !e.sequents, f, closure) "adisjunct" : do_expwalk(!\e.conditions | !e.aconstraints, f, closure) "sequent" : do_expwalk(!e.constraints, f, closure) "dots_sequent" : &fail "patlabel" : &fail #line 26 "expwalk.nw" "latent_patlabel" : do_expwalk((vanishing_latent_patlabel ~=== e).instance, f, closure) "constraint" : do_expwalk(e.field, f, closure) "fieldbinding" : do_expwalk(e.code | e.field, f, closure) "absolute_field" : do_expwalk(e.field, f, closure) "field" : &fail #line 32 "expwalk.nw" "list" | "set" : do_expwalk(!e, f, closure) "eqn" : do_expwalk(e.left | e.right, f, closure) "table" : do_expwalk(key(e), f, closure) #line 36 "expwalk.nw" "Eorb" | "Eand" : do_expwalk(e.x | e.y, f, closure) "Eslice" | "Eshift" | "Enarrowu" | "Enarrows" | "Ewiden" | "Ediv" | "Emod" | "Semit" | "Stoken" | "Efitsu" | "Efitss" | "Einstance_input" | "Einstance_tagged" : do_expwalk(e.x, f, closure) #line 42 "expwalk.nw" "Epatlabel" : do_expwalk(e.l, f, closure) "Eforce" | "Eforceable" | "Enot" | "Enosimp" | "Sstmts" : do_expwalk(e.x, f, closure) "Epc" | "Epc_known" : &fail "Einstance" : do_expwalk(!e.argt, f, closure) "Ebinding_instance" : do_expwalk(e.name, f, closure) "Eapp" : do_expwalk(!e.args, f, closure) #line 50 "expwalk.nw" "Eclosure_loc" : &fail "Eclosure_addr" : &fail "Eclosure_val" : &fail #line 54 "expwalk.nw" "Sif" : do_expwalk(!e.arms, f, closure) "Sguarded" : do_expwalk(e.guard | e.x, f, closure) "Sepsilon" : &fail "Stagcase" : do_expwalk(e.x | !e.arms, f, closure) "Sfail" : &fail "integer" | "string" | "literal" : &fail "Efail" : &fail "Sclosure" : do_expwalk(e.disjunct | \e.conditions | \e.creation, f, closure) #line 63 "expwalk.nw" "balance" : do_expwalk(e.left | e.right, f, closure) "balitem" : do_expwalk(e.v | e.value, f, closure) #line 66 "expwalk.nw" "Glines" : &fail "Gresynch" : &fail "Gblock" : do_expwalk(!e.decls | !e.stmts, f, closure) "Gdecl" : do_expwalk(e.init, f, closure) "Gcase" : do_expwalk(e.x | !e.arms, f, closure) "Gcasearm" : do_expwalk(e.x, f, closure) "Ginrange" : do_expwalk(e.x, f, closure) "Gsetname" : &fail "Gnomatch" : &fail "Gasgn" : do_expwalk(e.x, f, closure) "Tunsigned" : &fail "Gcomment" : &fail "Gcommented" : do_expwalk(e.e, f, closure) #line 80 "expwalk.nw" "inject" : do_expwalk(\e.pattern | \e.integer, f, closure) #line 82 "expwalk.nw" "Eclosure" : do_expwalk(!e.values | !e.addresses, f, closure) "Elambda" : do_expwalk(e.body, f, closure) #line 12 "expwalk.nw" default : impossible("expression type in expression walking") } | f ! ([e] ||| closure) end #line 87 "expwalk.nw" procedure gsubst(e, f, closure[]) return do_gsubst(e, f, closure) end procedure do_gsubst(e, f, closure) local args return f ! ([e] ||| closure) | case type(e) of { #line 117 "expwalk.nw" "pattern" : if l := maplistn(do_gsubst, e.disjuncts, [f, closure]) & lists_match(l, e.disjuncts) then e else { ll := []; every d := !l do if not member(\d.conditions, 0) then put(ll, d) pattern(ll, e.name) } "disjunct" : { fclosure := [f, closure] c := do_gsubst_conditions(e.conditions, f, closure) s := [] # this code vanishes dead latent pattern labels every x := do_gsubst(!e.sequents, f, closure) do put(s, vanishing_latent_patlabel ~=== x) if lists_match(s, e.sequents) & c === e.conditions then e else disjunct(s, e.name, c) } #line 148 "expwalk.nw" "adisjunct" : { if \(c := e.conditions) then { c := set(); every insert_condition(c, do_gsubst(!e.conditions, f, closure)) if sets_match(c, e.conditions) then c := e.conditions } if \(p := e.patlabelbindings) then p := do_gsubst_values_in_table(p, f, closure) s := maplistn(do_gsubst, e.aconstraints, [f, closure]) if lists_match(s, e.aconstraints) & c === e.conditions & p === e.patlabelbindings then e else adisjunct(s, e.name, c, e.length, p) } "sequent" : if l := maplistn(do_gsubst, e.constraints, [f, closure]) & lists_match(l, e.constraints) then e else sequent(l, e.class) #line 168 "expwalk.nw" "patlabel" : e "latent_patlabel" : if (x := do_gsubst(e.instance, f, closure)) === e.instance then e else latent_patlabel(x) "dots_sequent" : e "constraint" : e "fieldbinding" : if (x := do_gsubst(e.code, f, closure)) === e.code then e else fieldbinding(e.field, x) "absolute_field" : e #line 177 "expwalk.nw" "list" : if lists_match(l := maplistn(do_gsubst, e, [f, closure]), e) then e else l "eqn" : if l := do_gsubst(e.left, f, closure) & r := do_gsubst(e.right, f, closure) & l === e.left & r === e.right then e else eqn(l, e.op, r) "table" : if (t := do_gsubst_sumprod_table(e, f, closure)) === e then e else t "set" : {s := set() every insert(s, do_gsubst(!e, f, closure)) if x := !s & not member(e, x) then s else e } "string" : e "literal" : e "integer" : e "null" : e #line 191 "expwalk.nw" "Eorb" : if x := do_gsubst(e.x, f, closure) & y := do_gsubst(e.y, f, closure) & x === e.x & y === e.y then e else Eorb(x, y) "Eand" : if x := do_gsubst(e.x, f, closure) & y := do_gsubst(e.y, f, closure) & x === e.x & y === e.y then e else Eand(x, y) "Eslice" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Eslice(x, e.lo, e.n) "Eshift" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Eshift(x, e.n) "Enarrowu" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Enarrowu(x, e.n) "Enarrows" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Enarrows(x, e.n) "Ewiden" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Ewiden(x, e.n) "Ediv" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Ediv(x, e.n) "Emod" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Emod(x, e.n) "Efitsu" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Efitsu(x, e.n) "Efitss" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Efitss(x, e.n) "Epatlabel" : if (l := do_gsubst(e.l, f, closure)) === e.l then e else Epatlabel(l) "Eforce" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Eforce(x) "Eforceable" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Eforceable(x) "Epc" | "Epc_known" : e "Enot" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Enot(x) "Enosimp" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Enosimp(x) "Sstmts" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Sstmts(x) "Semit" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Semit(x) "Stoken" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Stoken(x, e.n, e.offset) #line 217 "expwalk.nw" "Einstance" : e # suppress warning --- will confuse users # --- and we do this with eliminate_instances now # { warning("escaping Einstance: ", expimage(e)); e} "Ebinding_instance" : e "Einstance_input" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Einstance_input(x, e.cons, e.name) "Einstance_tagged" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Einstance_tagged(x, e.cons, e.uid) #line 228 "expwalk.nw" "Eapp" : if (args := do_gsubst(e.args, f, closure)) === e.args then e else Eapp(e.f, args) "Eclosure_loc" : e "Eclosure_addr" : e "Eclosure_val" : e #line 234 "expwalk.nw" "Sif" : if (arms := do_gsubst(e.arms, f, closure)) === e.arms then e else Sif(arms) "Sguarded" : if (guard := do_gsubst(e.guard, f, closure), x := do_gsubst(e.x, f, closure), guard === e.guard, x === e.x) then e else Sguarded(guard, x) "Sepsilon" : e "Sfail" : e "Stagcase" : if (arms := do_gsubst_vals(e.arms, f, closure), x := do_gsubst(e.x, f, closure), arms === e.arms, x === e.x) then e else { write(&errout, "TAGCASE: ", expimage(e.x)) write(&errout, "TAGCASE: ", expimage(e.arms)) write(&errout, "TAGCASE: ", expimage(x)) write(&errout, "TAGCASE: ", expimage(arms)) Stagcase(x, e.type, arms) } "Efail" : e #line 254 "expwalk.nw" "balance" : if l := do_gsubst(e.left, f, closure) & r := do_gsubst(e.right, f, closure) & l === e.left & r === e.right then e else balance(l, r) "balitem" : if l := do_gsubst(e.v, f, closure) & r := do_gsubst(e.value, f, closure) & l === e.v & r === e.value then e else balitem(l, r) #line 261 "expwalk.nw" "Glines" : e "Gresynch" : e "Gblock" : if (decls := do_gsubst(e.decls, f, closure), stmts := do_gsubst(e.stmts, f, closure), decls === e.decls, stmts === e.stmts) then e else Gblock(decls, stmts) "Gdecl" : if (init := do_gsubst(e.init, f, closure)) === e.init then e else Gdecl(e.name, e.type, init) "Gcase" : if (x := do_gsubst(e.x, f, closure), arms := do_gsubst(e.arms, f, closure), x === e.x, arms === e.arms) then e else Gcase(x, arms) "Gcasearm" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Gcasearm(e.tags, x) "Ginrange" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Ginrange(e.lo, x, e.hi) "Gsetname" : e "Gnomatch" : e "Gasgn" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Gasgn(e.lhs, x) "Tunsigned" : e "Gcomment" : e "Gcommented": if (x := do_gsubst(e.e, f, closure)) === e.e then e else Gcommented(x, e.comment) #line 285 "expwalk.nw" "inject" : if (p := do_gsubst(\e.pattern, f, closure) | &null, i := do_gsubst(\e.integer, f, closure) | &null, p === e.pattern, i === e.integer) then e else inject(p, i, e.consop) #line 290 "expwalk.nw" "Eclosure" : if (v := do_gsubst(e.values, f, closure), a := do_gsubst(e.addresses, f, closure), v === e.values, a === e.addresses) then e else Eclosure(e.ty, e.fun, e.headertype, v, a) "Elambda" : if (x := do_gsubst(e.body, f, closure)) === e.body then e else Elambda(e.formals, x) #line 96 "expwalk.nw" default : impossible("expression type in generalized substition") } end procedure do_gsubst_children(e, f, closure) local args return case type(e) of { #line 117 "expwalk.nw" "pattern" : if l := maplistn(do_gsubst, e.disjuncts, [f, closure]) & lists_match(l, e.disjuncts) then e else { ll := []; every d := !l do if not member(\d.conditions, 0) then put(ll, d) pattern(ll, e.name) } "disjunct" : { fclosure := [f, closure] c := do_gsubst_conditions(e.conditions, f, closure) s := [] # this code vanishes dead latent pattern labels every x := do_gsubst(!e.sequents, f, closure) do put(s, vanishing_latent_patlabel ~=== x) if lists_match(s, e.sequents) & c === e.conditions then e else disjunct(s, e.name, c) } #line 148 "expwalk.nw" "adisjunct" : { if \(c := e.conditions) then { c := set(); every insert_condition(c, do_gsubst(!e.conditions, f, closure)) if sets_match(c, e.conditions) then c := e.conditions } if \(p := e.patlabelbindings) then p := do_gsubst_values_in_table(p, f, closure) s := maplistn(do_gsubst, e.aconstraints, [f, closure]) if lists_match(s, e.aconstraints) & c === e.conditions & p === e.patlabelbindings then e else adisjunct(s, e.name, c, e.length, p) } "sequent" : if l := maplistn(do_gsubst, e.constraints, [f, closure]) & lists_match(l, e.constraints) then e else sequent(l, e.class) #line 168 "expwalk.nw" "patlabel" : e "latent_patlabel" : if (x := do_gsubst(e.instance, f, closure)) === e.instance then e else latent_patlabel(x) "dots_sequent" : e "constraint" : e "fieldbinding" : if (x := do_gsubst(e.code, f, closure)) === e.code then e else fieldbinding(e.field, x) "absolute_field" : e #line 177 "expwalk.nw" "list" : if lists_match(l := maplistn(do_gsubst, e, [f, closure]), e) then e else l "eqn" : if l := do_gsubst(e.left, f, closure) & r := do_gsubst(e.right, f, closure) & l === e.left & r === e.right then e else eqn(l, e.op, r) "table" : if (t := do_gsubst_sumprod_table(e, f, closure)) === e then e else t "set" : {s := set() every insert(s, do_gsubst(!e, f, closure)) if x := !s & not member(e, x) then s else e } "string" : e "literal" : e "integer" : e "null" : e #line 191 "expwalk.nw" "Eorb" : if x := do_gsubst(e.x, f, closure) & y := do_gsubst(e.y, f, closure) & x === e.x & y === e.y then e else Eorb(x, y) "Eand" : if x := do_gsubst(e.x, f, closure) & y := do_gsubst(e.y, f, closure) & x === e.x & y === e.y then e else Eand(x, y) "Eslice" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Eslice(x, e.lo, e.n) "Eshift" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Eshift(x, e.n) "Enarrowu" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Enarrowu(x, e.n) "Enarrows" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Enarrows(x, e.n) "Ewiden" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Ewiden(x, e.n) "Ediv" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Ediv(x, e.n) "Emod" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Emod(x, e.n) "Efitsu" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Efitsu(x, e.n) "Efitss" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Efitss(x, e.n) "Epatlabel" : if (l := do_gsubst(e.l, f, closure)) === e.l then e else Epatlabel(l) "Eforce" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Eforce(x) "Eforceable" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Eforceable(x) "Epc" | "Epc_known" : e "Enot" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Enot(x) "Enosimp" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Enosimp(x) "Sstmts" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Sstmts(x) "Semit" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Semit(x) "Stoken" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Stoken(x, e.n, e.offset) #line 217 "expwalk.nw" "Einstance" : e # suppress warning --- will confuse users # --- and we do this with eliminate_instances now # { warning("escaping Einstance: ", expimage(e)); e} "Ebinding_instance" : e "Einstance_input" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Einstance_input(x, e.cons, e.name) "Einstance_tagged" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Einstance_tagged(x, e.cons, e.uid) #line 228 "expwalk.nw" "Eapp" : if (args := do_gsubst(e.args, f, closure)) === e.args then e else Eapp(e.f, args) "Eclosure_loc" : e "Eclosure_addr" : e "Eclosure_val" : e #line 234 "expwalk.nw" "Sif" : if (arms := do_gsubst(e.arms, f, closure)) === e.arms then e else Sif(arms) "Sguarded" : if (guard := do_gsubst(e.guard, f, closure), x := do_gsubst(e.x, f, closure), guard === e.guard, x === e.x) then e else Sguarded(guard, x) "Sepsilon" : e "Sfail" : e "Stagcase" : if (arms := do_gsubst_vals(e.arms, f, closure), x := do_gsubst(e.x, f, closure), arms === e.arms, x === e.x) then e else { write(&errout, "TAGCASE: ", expimage(e.x)) write(&errout, "TAGCASE: ", expimage(e.arms)) write(&errout, "TAGCASE: ", expimage(x)) write(&errout, "TAGCASE: ", expimage(arms)) Stagcase(x, e.type, arms) } "Efail" : e #line 254 "expwalk.nw" "balance" : if l := do_gsubst(e.left, f, closure) & r := do_gsubst(e.right, f, closure) & l === e.left & r === e.right then e else balance(l, r) "balitem" : if l := do_gsubst(e.v, f, closure) & r := do_gsubst(e.value, f, closure) & l === e.v & r === e.value then e else balitem(l, r) #line 261 "expwalk.nw" "Glines" : e "Gresynch" : e "Gblock" : if (decls := do_gsubst(e.decls, f, closure), stmts := do_gsubst(e.stmts, f, closure), decls === e.decls, stmts === e.stmts) then e else Gblock(decls, stmts) "Gdecl" : if (init := do_gsubst(e.init, f, closure)) === e.init then e else Gdecl(e.name, e.type, init) "Gcase" : if (x := do_gsubst(e.x, f, closure), arms := do_gsubst(e.arms, f, closure), x === e.x, arms === e.arms) then e else Gcase(x, arms) "Gcasearm" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Gcasearm(e.tags, x) "Ginrange" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Ginrange(e.lo, x, e.hi) "Gsetname" : e "Gnomatch" : e "Gasgn" : if (x := do_gsubst(e.x, f, closure)) === e.x then e else Gasgn(e.lhs, x) "Tunsigned" : e "Gcomment" : e "Gcommented": if (x := do_gsubst(e.e, f, closure)) === e.e then e else Gcommented(x, e.comment) #line 285 "expwalk.nw" "inject" : if (p := do_gsubst(\e.pattern, f, closure) | &null, i := do_gsubst(\e.integer, f, closure) | &null, p === e.pattern, i === e.integer) then e else inject(p, i, e.consop) #line 290 "expwalk.nw" "Eclosure" : if (v := do_gsubst(e.values, f, closure), a := do_gsubst(e.addresses, f, closure), v === e.values, a === e.addresses) then e else Eclosure(e.ty, e.fun, e.headertype, v, a) "Elambda" : if (x := do_gsubst(e.body, f, closure)) === e.body then e else Elambda(e.formals, x) #line 104 "expwalk.nw" default : impossible("expression type in generalized substition") } end #line 109 "expwalk.nw" procedure maplistn(f, l, closure) local result, x result := [] every x := !l do put(result, f ! ([x] ||| closure) | fail) return result end #line 135 "expwalk.nw" procedure do_gsubst_conditions(e, f, closure) if \(c := e) then { c := set(); every insert_condition(c, do_gsubst(!e, f, closure)) if sets_match(c, e) then c := e } return c end procedure gsubst_conditions(e, f, closure[]) return do_gsubst_conditions(e, f, closure) end #line 306 "expwalk.nw" procedure do_gsubst_sumprod_table(e, f, closure) t := table(0) every k := key(e) & kk := do_gsubst(k, f, closure) do add_to_table(t, kk, e[k]) every k := key(t) & t[k] = 0 do delete(t, k) # delete zeroes return if tables_match(e, t) then e else t end #line 314 "expwalk.nw" procedure insert_condition(s, c) if c ~=== 1 & not exps_eq(c, !s) then insert(s, c) return s end #line 319 "expwalk.nw" procedure add_to_table(t, k, multiplier) case type(k) of { "table" : every v := key(k) do t[v] +:= k[v] * multiplier "integer" : t[1] +:= k * multiplier default : t[k] +:= multiplier } return t end #line 328 "expwalk.nw" procedure lists_match(l1, l2) if n := *l1 = *l2 then if l1[i := 1 to n] ~=== l2[i] then fail else return l2 else fail end #line 335 "expwalk.nw" procedure sets_match(s1, s2) if n := *s1 = *s2 then { s := set() every insert(s, expimage(!s1 | !s2)) if *s = n then return s1 else fail } else fail end #line 343 "expwalk.nw" procedure tables_match(t1, t2) if k := key(t1 | t2) & t1[k] ~= t2[k] then fail else return t1 end #=================================================================== expps.icn #line 7 "expps.nw" procedure expps(e) local leadingsign, prefix static psopstab initial { #line 21 "expps.nw" psopstab := table() psopstab["<"] := "lt" psopstab["<="] := "le" psopstab[">"] := "gt" psopstab[">="] := "ge" psopstab["!="] := "ne" psopstab["="] := "eq" #line 10 "expps.nw" } return case type(e) of { #line 17 "expps.nw" "list" : "[" || commaseparate(maplist(expps, e), " ") || "]" "set" : "[" || commaseparate(sort(maplist(expps, sort(e))), ",") || "] set" "eqn" : expps(e.left) || " " || expps(e.right) || " " || \psopstab[e.op] #line 29 "expps.nw" "table" : { # standard normal form #line 41 "expps.nw" { s := ""; firstterm := 1 t := table(0) l := [] every e[k := key(e)] do { put(l, x := expps(k)) t[x] +:= e[k] } l := sort(l) every x := !l & t[x] ~= 0 do { if \firstterm then s ||:= psx(x, t[x]) else s ||:= " " || psabs(x, t[x]) || " " || if t[x] > 0 then "add" else "sub" firstterm := &null } if s == "" then s := "0" } #line 31 "expps.nw" s } "string" : e "literal" : image(e.s) || " lit" "integer" : string(e) "null" : "null" #line 75 "expps.nw" "Eorb" : { l := sort(maplist(expps, flatten(e, type(e)))) s := l[1] every s ||:= " " || l[2 to *l] || " orb" s } "Eand" : { l := sort(maplist(expps, flatten(e, type(e)))) s := l[1] every s ||:= " " || l[2 to *l] || " and" s } #line 86 "expps.nw" "Eslice" : expps(e.x) || " " || e.lo || " " || (e.lo + e.n - 1) || " bitslice" "Eshift" : expps(e.x) || " " || e.n || " bitshift" #line 89 "expps.nw" "Enarrowu" : expps(e.x) || " " || e.n || " narrowu" "Enarrows" : expps(e.x) || " " || e.n || " narrows" "Ewiden" : expps(e.x) || " " || e.n || " widen" #line 93 "expps.nw" "Ediv" : expps(e.x) || " " || e.n || " idiv" "Emod" : expps(e.x) || " " || e.n || " mod" #line 96 "expps.nw" "Semit" : commaseparate(maplist(expps, e.x), "\n") || "\n" "Stoken" : expps(e.x) || " cl-loc force " || (if e.offset ~= 0 then e.offset || " add " else "") || e.n || " emit-at" #line 101 "expps.nw" "Efitsu" : expps(e.x) || " " || e.n || " fitsu" "Efitss" : expps(e.x) || " " || e.n || " fitss" #line 104 "expps.nw" "Epatlabel" : &fail #line 106 "expps.nw" "Eforce" : expps(e.x) || " force" "Eforceable": expps(e.x) || " known" #line 109 "expps.nw" "Epc" : &fail "Epc_known" : &fail #line 112 "expps.nw" "Enot" : expps(e.x) || " not" #line 114 "expps.nw" "Enosimp" : expps(e.x) #line 116 "expps.nw" "Sstmts" : commaseparate(maplist(expps, e.x), "\n") || "\n" #line 118 "expps.nw" "Einstance" : { s := "<< /instance-of " || e.cons.name every i := inputs_of(e.cons) do s ||:= " /" || i.name || " " || expps(e.argt[i.name]) s || " >>" } "Einstance_input" : expps(e.x) || " /" || e.cons.name || " /" || e.name || " get_instance" "Einstance_tagged" : expps(e.x) || " /" || e.cons.name || " is_instance" "Ebinding_instance" : &fail #line 129 "expps.nw" "Sif" : { s := "[" every s ||:= "\n" || expps(!e.arms) s || "\n] if-guard" } "Sguarded" : psguard(e.guard) || "\n\t{" || expps(e.x) || "}" #line 149 "expps.nw" "Stagcase" : { s := "[" every c := kept_constructors(e.type) do s ||:= "\n/" || c.name || " {" || expps(e.arms[c]) || "}" s ||:= "\n]" || expps(e.x) || " tag-case" } #line 155 "expps.nw" "Sfail" : { s := image(e.fmt) || " [" every a := e.a1 | e.a2 | e.a3 do s ||:= " " || expps(\a) s := s || " ] failmsg" } "Sepsilon" : "" #line 162 "expps.nw" "Efail" : &fail #line 164 "expps.nw" "Glines" : commaseparate(maplist2(expps, e.x), "\n") "Gresynch" : "" "Gblock" : { s := "enterscope " every s ||:= expps(!e.decls) || "\n" every s ||:= expps(!e.stmts) || "\n" s || "exitscope" } "Gdecl" : { s := "/" || e.name || " " || expps(e.type) s ||:= expps(\e.init) | "&uninitialized" s || " decl" } #line 176 "expps.nw" "Gcase" : &fail "Gcasearm" : &fail "Ginrange" : &fail #line 180 "expps.nw" "Gasgn" : &fail "Gsetname" : &fail "Gnomatch" : &fail "Tunsigned" : (\e.width | "wordsize") || " unsigned" #line 185 "expps.nw" "Eapp" : expps(e.args) || " " || image(e.f) || " apply" #line 187 "expps.nw" "Eclosure_loc" : "cl-loc" "Eclosure_addr" : e.n || " cla" "Eclosure_val" : e.n || " clv" #line 191 "expps.nw" "Eclosure" : &fail "Elambda" : { s := "[" every s ||:= " /" || !e.formals s ||:= " ] { " || expps(e.body) || " } fn" } #line 13 "expps.nw" default : &fail } | impossible("postfix expression ", image(e), " : ", type(e)) end #line 60 "expps.nw" procedure psabs(x, mul) return if x == "1" then mul else if abs(mul) = 1 then x else x || " " || abs(mul) || " mul" end procedure psx(x, mul) return if x == "1" then mul else case mul of { 1 : x -1 : x || " neg" default : x || " " || mul || " mul" } end #line 135 "expps.nw" procedure psguard(e) return case type(e) of { "integer" : case e of { 0 : "false"; 1 : "true"; default: impossible("condition") } "null" : "true" "set" : { l := sort(maplist(expps, sort(e))) s := l[1] every s ||:= " " || l[2 to *l] || " and" if *l = 0 then "true" else s } default : expps(e) } end #=================================================================== expbc.icn #line 107 "expbc.nw" procedure expbc(e) local leadingsign, prefix static psopstab initial { #line 121 "expbc.nw" psopstab := table() psopstab["<"] := bc_lt() psopstab["<="] := bc_le() psopstab[">"] := bc_gt() psopstab[">="] := bc_ge() psopstab["!="] := bc_ne() psopstab["="] := bc_eq() #line 110 "expbc.nw" } return case type(e) of { #line 117 "expbc.nw" "list" : bc_mark() || commaseparate(maplist(expbc, e), "") || bc_array() "set" : bc_mark() || commaseparate(sort(maplist(expbc, sort(e))), "") || bc_set() "eqn" : expbc(e.left) || expbc(e.right) || \psopstab[e.op] #line 129 "expbc.nw" "table" : { # standard normal form #line 150 "expbc.nw" { s := ""; firstterm := 1 t := table(0) l := [] every e[k := 1 ~=== key(e)] do { type(k) ~== "integer" | impossible("key ", k, " in ", expimage(e)) put(l, x := expbc(k)) t[x] +:= e[k] } l := sort(l) every x := !l & t[x] > 0 do { s ||:= bcx(x, t[x], firstterm) firstterm := &null } every x := !l & t[x] < 0 do { s ||:= bcx(x, t[x], firstterm) firstterm := &null } if \firstterm then s ||:= bc_sint(e[1]) else if e[1] ~= 0 then s ||:= bc_addlit(e[1]) } #line 131 "expbc.nw" s } "string" : bc_stringout(e) "literal" : bc_stringout(e.s) || bc_lit() "integer" : bc_sint(e) "null" : bc_null() #line 187 "expbc.nw" "Eorb" : { l := sort(maplist(expbc, flatten(e, type(e)))) s := l[1] every s ||:= l[2 to *l] || bc_orb() s } "Eand" : { l := sort(maplist(expbc, flatten(e, type(e)))) s := l[1] every s ||:= l[2 to *l] || bc_and() s } #line 198 "expbc.nw" "Eslice" : expbc(e.x) || bc_bitslice(e.lo, e.lo + e.n - 1) "Eshift" : expbc(e.x) || bc_bitshift(e.n) #line 201 "expbc.nw" "Enarrowu" : expbc(e.x) || bc_narrowu(e.n) "Enarrows" : expbc(e.x) || bc_narrows(e.n) "Ewiden" : expbc(e.x) || bc_widen(e.n) #line 205 "expbc.nw" "Ediv" : expbc(e.x) || bc_sint(e.n) || bc_idiv() "Emod" : expbc(e.x) || bc_sint(e.n) || bc_mod() #line 208 "expbc.nw" "Semit" : commaseparate(maplist(expbc, e.x), "") "Stoken" : expbc(e.x) || if e.offset = 0 then bc_emit_at_loc(e.n) else bc_cl_loc() || bc_force() || bc_addlit(e.offset) || bc_emit_at(e.n) #line 213 "expbc.nw" "Efitsu" : expbc(e.x) || bc_fitsu(e.n) "Efitss" : expbc(e.x) || bc_fitss(e.n) #line 216 "expbc.nw" "Epatlabel" : &fail #line 218 "expbc.nw" "Eforce" : case type(e.x) of { "Eclosure_addr" : bc_cla_force(e.x.n) "Eclosure_loc" : bc_cl_loc_force() default : expbc(e.x) || bc_force() } "Eforceable": expbc(e.x) || bc_known() #line 226 "expbc.nw" "Epc" : &fail "Epc_known" : &fail #line 229 "expbc.nw" "Enot" : expbc(e.x) || bc_not() #line 231 "expbc.nw" "Enosimp" : expbc(e.x) #line 233 "expbc.nw" "Sstmts" : commaseparate(maplist(expbc, e.x), "") #line 235 "expbc.nw" "Einstance" : &fail "Einstance_input" : &fail "Einstance_tagged" : &fail "Ebinding_instance" : &fail #line 240 "expbc.nw" "Sif" : { s := bc_mark() every s ||:= expbc(!e.arms) s || bc_array() || bc_if_guard() } "Sguarded" : bcguard(e.guard) || bc_procmark() || expbc(e.x) || bc_proc() #line 261 "expbc.nw" "Stagcase" : &fail #line 263 "expbc.nw" "Sfail" : if e.fmt ~== "Conditions not satisfied for unnamed constructor" | \(e.a1|e.a2|e.a3) then { s := bc_stringout(e.fmt) || bc_mark() every a := e.a1 | e.a2 | e.a3 do s ||:= expbc(\a) s ||:= bc_array() || bc_failmsg() } else bc_unsat() "Sepsilon" : "" #line 274 "expbc.nw" "Efail" : &fail #line 276 "expbc.nw" "Glines" : commaseparate(maplist2(expbc, e.x), "") "Gresynch" : "" "Gblock" : &fail "Gdecl" : &fail #line 281 "expbc.nw" "Gcase" : &fail "Gcasearm" : &fail "Ginrange" : &fail #line 285 "expbc.nw" "Gasgn" : &fail "Gsetname" : &fail "Gnomatch" : &fail "Tunsigned" : &fail #line 290 "expbc.nw" "Eapp" : &fail #line 292 "expbc.nw" "Eclosure_loc" : bc_cl_loc() "Eclosure_addr" : bc_cla(e.n) "Eclosure_val" : bc_clv(e.n) #line 296 "expbc.nw" "Eclosure" : &fail "Elambda" : &fail #line 113 "expbc.nw" default : &fail } | impossible("postfix expression ", image(e), " : ", type(e)) end #line 138 "expbc.nw" procedure bc_stringout(s) return bc_stringlit() || bc_sint(*s) || s end #line 142 "expbc.nw" procedure bc_lit() initial warning("bc_lit is BOGUS!!!") return "?" end #line 174 "expbc.nw" procedure bcx(x, mul, firstterm) return if \firstterm then case mul of { 1 : x -1 : x || bc_neg() default : x || bc_sint(mul) || bc_mul() } else case mul of { 1 : x || bc_add() -1 : x || bc_sub() default : x || bc_sint(mul) || bc_mul() || bc_add() } end #line 246 "expbc.nw" procedure bcguard(e) return case type(e) of { "integer" : case e of { 0 : bc_false(); 1 : bc_true() default: impossible("condition") } "null" : bc_true() "set" : { l := sort(maplist(expbc, sort(e))) s := l[1] every s ||:= l[2 to *l] || bc_and() if *l = 0 then bc_true() else s } default : expbc(e) } end #=============================================================== fieldinfo.icn #line 28 "fieldinfo.nw" global fnt # field -> name -> value #line 31 "fieldinfo.nw" procedure fieldinfo(f, info) initial { /fnt := table(); /fieldasm := table() } case type(info) of { "string" : case info of { "checked" : { #line 46 "fieldinfo.nw" every delete(guaranteed_fields | unchecked_fields, f) #line 34 "fieldinfo.nw" } "unchecked" : { #line 48 "fieldinfo.nw" insert(unchecked_fields, f) delete(guaranteed_fields, f) #line 35 "fieldinfo.nw" } "guaranteed" : { #line 51 "fieldinfo.nw" every insert(guaranteed_fields | unchecked_fields, f) #line 36 "fieldinfo.nw" } default : { #line 53 "fieldinfo.nw" error("Unknown field info specifier `", info, "'") #line 37 "fieldinfo.nw" } } "namespec" : (/fnt[f] := check_namespec(info, f)) | error("Field names for field ", f.name, " already specified") default : fail } return end #line 57 "fieldinfo.nw" global unchecked_fields, guaranteed_fields #line 64 "fieldinfo.nw" record namespec(nametable, full) procedure sparse_name_table(bindlist) t := table() every b := !bindlist do (/t[b.name] := b.val) | error("duplicate field names") return namespec(t) end #line 72 "fieldinfo.nw" record enumbinding(name, val) #line 75 "fieldinfo.nw" procedure full_name_table(namelist, f) t := table() every i := 1 to *namelist do (/t[namelist[i]] := i - 1) | error("duplicate field names") return namespec(t, 1) end #line 82 "fieldinfo.nw" procedure check_namespec(spec, f) if \spec.full then *spec.nametable = 2^fwidth(f) | error("Field ", f.name, " has ", 2^fwidth(f), " values, not ", *spec.nametable) if x := spec.nametable[n := key(spec.nametable)] & (x < 0 | x >= 2^fwidth(f)) then error("name ", image(n), " = ", x, " falls outside the value range of field ", f.name) return spec.nametable end #line 92 "fieldinfo.nw" procedure fieldname_table(f) initial /fnt := table() return fnt[f] end #line 97 "fieldinfo.nw" procedure fieldname_env_for(f) return [\fieldname_table(f)] | [] end procedure fieldname_env_for_ipt(ipt) return (type(ipt.meaning) == "field", fieldname_env_for(ipt.meaning)) | [] end #line 108 "fieldinfo.nw" procedure emit_fieldnames(base) local header, data, fields data := open(base || implementation_extension, "w") header := open(base || interface_extension, "w"); if interface_extension == ".h" then write(data, "#include \"", base, interface_extension, "\"") pp := PPnew(data); #line 122 "fieldinfo.nw" t := table() fields := [] every f := !symtab & type(f) == "field" do t[f.name] := f every put(fields, (!sort(t))[2]) #line 116 "fieldinfo.nw" every PPxwrite(pp, pretty(Gdeclnamearray(fieldnamearray(!fields))), ";") every write(header, "extern char *", (!fields).name, "_names[];") every close(data | header) return end #line 132 "fieldinfo.nw" procedure fieldnamearray(f) return name_array_from_table(\fieldname_table(f), 2^fwidth(f), f.name) end procedure name_array_from_table(t, limit, fieldname) local name limit <= 1024 | error("Tried to enumerate ", limit, " names for field or operand ", fieldname) na := namearray(field, table(), limit, fieldname || "_names", "") every i := 0 to na.hi - 1 do na.tbl[i] := bad_operand_name(fieldname, i) every name := key(t) do na.tbl[t[name]] := name return na end procedure bad_operand_name(name, value) return "??" || name || "=" || value || "?!" end #line 154 "fieldinfo.nw" procedure nametablekey(nametab) local min, max static cache initial cache := table() if \cache[nametab] then return cache[nametab] if /nametab then return cache[f] := "(no name table)" u := table() every k := key(nametab) do u[nametab[k]] := k #line 169 "fieldinfo.nw" min := max := !nametab | 0 every min >:= !nametab every max <:= !nametab #line 162 "fieldinfo.nw" s := "" every i := min to max do s ||:= \u[i] || "@" || i || "\0" return cache[f] := s end #================================================================= grammar.icn #line 1796 "grammar.nw" #line 4 "grammar.nw" #====== link ebnflex procedure reserved(w) static words initial words := set([ "!", "!=", "#", "$", "%", "&", "'", "(", ")", "*", "+", ",", "-", "...", "/", ":", ";", "<", "<=", "=", "=>", ">", ">=", "@", "[", "\"", "]", "^", "_", "address", "any", "assembly", "bit", "bogus code marker", "bogus spec marker", "columns", "component", "constructors", "discard", "else", "endmatch", "epsilon", "fetch", "field", "fieldinfo", "fields", "for", "is", "keep", "names", "of", "opcode", "operand", "otherwise", "patterns", "pc_unit_bits", "placeholder", "relocatable", "some", "sparse", "syntax", "to", "type", "using", "when", "which", "wordsize", "{", "|", "}", ">"]) if member(words, w) then return w end procedure P_Parsers() local ii1, ii2 case token of { "bogus spec marker" : # Parsers : "bogus spec marker" Spec return { ii1 := expect("bogus spec marker", "Parsers") ii2 := P_Spec() #line 78 "grammar.nw" ii2 #line 1000"generated code" } "bogus code marker" : # Parsers : "bogus code marker" CodeFile return { ii1 := expect("bogus code marker", "Parsers") ii2 := P_CodeFile() #line 78 "grammar.nw" ii2 #line 2000"generated code" } default : error("syntax error parsing Parsers:\n\texpected 'bogus code marker' or 'bogus spec marker'") } end procedure P_Spec() case token of { "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | EOF : # Spec : {Spec_1} return { ii1 := [] while token == ("address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize") do put(ii1, P_Spec_1() ) ii1 } default : error("syntax error parsing Spec") } end procedure P_Spec_1() case token of { "fieldinfo" | "fields" | "wordsize" : # Spec_1 : Fieldspec return P_Fieldspec() "patterns" : # Spec_1 : Patterns return P_Patterns() "constructors" | "discard" | "keep" : # Spec_1 : Constructors return P_Constructors() "placeholder" : # Spec_1 : Placeholder return P_Placeholder() "address" | "fetch" : # Spec_1 : FetchSpec return P_FetchSpec() "pc_unit_bits" : # Spec_1 : PCSpec return P_PCSpec() "relocatable" : # Spec_1 : RelocSpec return P_RelocSpec() "assembly" : # Spec_1 : AsmSpec return P_AsmSpec() "bit" : # Spec_1 : BitSpec return P_BitSpec() default : error("syntax error parsing Spec_1") } end procedure P_PCSpec() local ii1, ii2 case token of { "pc_unit_bits" : # PCSpec : "pc_unit_bits" INT return { ii1 := expect("pc_unit_bits", "PCSpec") ii2 := expect(INT, "PCSpec") #line 96 "grammar.nw" if ii2 > 0 then pc_unit_bits := ii2 else error("pc_unit_bits must be positive") #line 3000"generated code" } default : error("syntax error parsing PCSpec:\n\texpected 'pc_unit_bits'") } end procedure P_Fieldspec() local ii1, ii2, ii3, ii4, ii5, ii6, ii7 case token of { "fields" : # Fieldspec : "fields" "of" Ident "(" INT ")" Fieldspec_1 return { ii1 := expect("fields", "Fieldspec") ii2 := expect("of", "Fieldspec") ii3 := P_Ident() ii4 := expect("(", "Fieldspec") ii5 := expect(INT, "Fieldspec") ii6 := expect(")", "Fieldspec") ii7 := P_Fieldspec_1() #line 136 "grammar.nw" if ii5 % 8 ~= 0 then error("element size ", ii5, " is not a multiple of 8 bits.") if /bit_zero_is_lsb then { if !ii7 then bit_numbering_used := 1 every f := !ii7 do { f.hi := ii5 - f.hi f.lo := ii5 - f.lo f.lo :=: f.hi } } (/symtab[ii3] := equivclass(ii3, ii7, ii5)) | deferror(type(symtab[ii3]) || " ", image(ii3)) put(equivclasses, symtab[ii3]) every (!ii7).class := symtab[ii3] #line 4000"generated code" } "fieldinfo" : # Fieldspec : "fieldinfo" Fieldspec_2 return { ii1 := expect("fieldinfo", "Fieldspec") ii2 := P_Fieldspec_2() #line 266 "grammar.nw" ii2 #line 5000"generated code" } "wordsize" : # Fieldspec : "wordsize" INT return { ii1 := expect("wordsize", "Fieldspec") ii2 := expect(INT, "Fieldspec") #line 362 "grammar.nw" wordsize := ii2 #line 6000"generated code" } default : error("syntax error parsing Fieldspec:\n\texpected 'fieldinfo', 'fields', or 'wordsize'") } end procedure P_Fieldspec_2() case token of { "[" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # Fieldspec_2 : {Fieldinfo} return { ii1 := [] while token == ("[" | "_" | IDENT) do put(ii1, P_Fieldinfo() ) ii1 } default : error("syntax error parsing Fieldspec_2") } end procedure P_Fieldspec_1() case token of { "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # Fieldspec_1 : {Fieldspec_1_1} return { ii1 := [] while token == ("_" | IDENT) do put(ii1, P_Fieldspec_1_1() ) ii1 } default : error("syntax error parsing Fieldspec_1") } end procedure P_Fieldspec_1_1() local ii1, ii2, ii3 case token of { "_" | IDENT : # Fieldspec_1_1 : Ident INT Fieldspec_1_1_1 return { ii1 := P_Ident() ii2 := expect(INT, "Fieldspec_1_1") ii3 := P_Fieldspec_1_1_1() #line 135 "grammar.nw" newfield(ii1, ii2, (\ii3 | ii2)+1) #line 7000"generated code" } default : error("syntax error parsing Fieldspec_1_1:\n\texpected '_' or IDENT") } end procedure P_Fieldspec_1_1_1() case token of { ":" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # Fieldspec_1_1_1 : [Fieldspec_1_1_1_1] return { ii1 := &null if token == (":") then ii1 := ( P_Fieldspec_1_1_1_1() ) ii1 } default : error("syntax error parsing Fieldspec_1_1_1") } end procedure P_Fieldspec_1_1_1_1() local ii1, ii2 case token of { ":" : # Fieldspec_1_1_1_1 : ":" INT return { ii1 := expect(":", "Fieldspec_1_1_1_1") ii2 := expect(INT, "Fieldspec_1_1_1_1") #line 135 "grammar.nw" ii2 #line 8000"generated code" } default : error("syntax error parsing Fieldspec_1_1_1_1:\n\texpected ':'") } end procedure P_BitSpec() local ii1, ii2, ii3, ii4, ii5 case token of { "bit" : # BitSpec : "bit" Zero "is" Significance Significant return { ii1 := expect("bit", "BitSpec") ii2 := P_Zero() ii3 := expect("is", "BitSpec") ii4 := P_Significance() ii5 := P_Significant() #line 183 "grammar.nw" xxx := if ii4 == "least" then 1 else &null if xxx ~=== bit_zero_is_lsb then if \bit_numbering_set then warning("Multiple inconsistent bit numberings --- hope you really mean it!") if \bit_numbering_used then warning("You change the bit numbering, but you've already used the old numbering" || "... seems like a crazy idea, but I'll do it") bit_zero_is_lsb := xxx bit_numbering_set := 1 #line 9000"generated code" } default : error("syntax error parsing BitSpec:\n\texpected 'bit'") } end procedure P_Zero() local ii1 case token of { INT : # Zero : INT return { ii1 := expect(INT, "Zero") #line 190 "grammar.nw" ii1 = 0 | error("expected `0'") #line 10000"generated code" } default : error("syntax error parsing Zero:\n\texpected INT") } end procedure P_Significance() local ii1 case token of { "_" | IDENT : # Significance : Ident return { ii1 := P_Ident() #line 192 "grammar.nw" ii1 == ("most"|"least") | error("expected `most' or `least'") #line 11000"generated code" } default : error("syntax error parsing Significance:\n\texpected '_' or IDENT") } end procedure P_Significant() local ii1 case token of { "_" | IDENT : # Significant : Ident return { ii1 := P_Ident() #line 193 "grammar.nw" ii1 == "significant" | error("expected `significant'") #line 12000"generated code" } default : error("syntax error parsing Significant:\n\texpected '_' or IDENT") } end procedure P_Placeholder() local ii1, ii2, ii3, ii4, ii5 case token of { "placeholder" : # Placeholder : "placeholder" "for" Ident "is" Pattern return { ii1 := expect("placeholder", "Placeholder") ii2 := expect("for", "Placeholder") ii3 := P_Ident() ii4 := expect("is", "Placeholder") ii5 := P_Pattern() #line 235 "grammar.nw" class := lookuptype(ii3, "equivclass") (/class.holder := pnf(ii5, globals)) | error("Placeholder for ", ii3, " is already defined") if pattern_length(class.holder) ~= class.size then error("Length of placeholder `", patimage(class.holder), "' \nfor ", class.name, " does not match class size ", class.size) #line 13000"generated code" } default : error("syntax error parsing Placeholder:\n\texpected 'placeholder'") } end procedure P_Fieldinfo() local ii1, ii2, ii3, ii4, ii5 case token of { "[" | "_" | IDENT : # Fieldinfo : IdentBinding "is" "[" Fieldinfo_1 "]" return { ii1 := P_IdentBinding() ii2 := expect("is", "Fieldinfo") ii3 := expect("[", "Fieldinfo") ii4 := P_Fieldinfo_1() ii5 := expect("]", "Fieldinfo") #line 268 "grammar.nw" every fieldinfo(lookuptype(!ii1, "field"), !ii4) #line 14000"generated code" } default : error("syntax error parsing Fieldinfo:\n\texpected '[', '_', or IDENT") } end procedure P_Fieldinfo_1() case token of { "]" | "_" | "names" | "sparse" | IDENT : # Fieldinfo_1 : {Fielditem} return { ii1 := [] while token == ("_" | "names" | "sparse" | IDENT) do put(ii1, P_Fielditem() ) ii1 } default : error("syntax error parsing Fieldinfo_1") } end procedure P_IdentBinding() local ii1, ii2, ii3 case token of { "_" | IDENT : # IdentBinding : Ident return { ii1 := P_Ident() #line 269 "grammar.nw" [ii1] #line 15000"generated code" } "[" : # IdentBinding : "[" IdentBinding_1 "]" return { ii1 := expect("[", "IdentBinding") ii2 := P_IdentBinding_1() ii3 := expect("]", "IdentBinding") #line 269 "grammar.nw" ii2 #line 16000"generated code" } default : error("syntax error parsing IdentBinding:\n\texpected '[', '_', or IDENT") } end procedure P_IdentBinding_1() case token of { "]" | "_" | IDENT : # IdentBinding_1 : {Ident} return { ii1 := [] while token == ("_" | IDENT) do put(ii1, P_Ident() ) ii1 } default : error("syntax error parsing IdentBinding_1:\n\texpected ']', '_', or IDENT") } end procedure P_Fielditem() case token of { "_" | IDENT : # Fielditem : Ident return P_Ident() "sparse" : # Fielditem : SparseFieldNames return P_SparseFieldNames() "names" : # Fielditem : FieldNameList return P_FieldNameList() default : error("syntax error parsing Fielditem") } end procedure P_SparseFieldNames() local ii1, ii2, ii3, ii4 case token of { "sparse" : # SparseFieldNames : "sparse" "[" FieldNameBindings "]" return { ii1 := expect("sparse", "SparseFieldNames") ii2 := expect("[", "SparseFieldNames") ii3 := P_FieldNameBindings() ii4 := expect("]", "SparseFieldNames") #line 271 "grammar.nw" sparse_name_table(ii3) #line 17000"generated code" } default : error("syntax error parsing SparseFieldNames:\n\texpected 'sparse'") } end procedure P_FieldNameBindings() local ii1, ii2 case token of { "\"" | "_" | IDENT : # FieldNameBindings : FieldNameBinding FieldNameBindings_1 return { ii1 := P_FieldNameBinding() ii2 := P_FieldNameBindings_1() #line 272 "grammar.nw" push(ii2, ii1) #line 18000"generated code" } default : error("syntax error parsing FieldNameBindings:\n\texpected '\'', '_', or IDENT") } end procedure P_FieldNameBindings_1() case token of { "," | "]" : # FieldNameBindings_1 : {FieldNameBindings_1_1} return { ii1 := [] while token == (",") do put(ii1, P_FieldNameBindings_1_1() ) ii1 } default : error("syntax error parsing FieldNameBindings_1:\n\texpected ',' or ']'") } end procedure P_FieldNameBindings_1_1() local ii1, ii2 case token of { "," : # FieldNameBindings_1_1 : "," FieldNameBinding return { ii1 := expect(",", "FieldNameBindings_1_1") ii2 := P_FieldNameBinding() #line 272 "grammar.nw" ii2 #line 19000"generated code" } default : error("syntax error parsing FieldNameBindings_1_1:\n\texpected ','") } end procedure P_FieldNameBinding() local ii1, ii2, ii3 case token of { "\"" | "_" | IDENT : # FieldNameBinding : FieldName "=" Integer return { ii1 := P_FieldName() ii2 := expect("=", "FieldNameBinding") ii3 := P_Integer() #line 273 "grammar.nw" enumbinding(ii1, ii3) #line 20000"generated code" } default : error("syntax error parsing FieldNameBinding:\n\texpected '\'', '_', or IDENT") } end procedure P_FieldNameList() local ii1, ii2, ii3, ii4 case token of { "names" : # FieldNameList : "names" "[" FieldNameList_1 "]" return { ii1 := expect("names", "FieldNameList") ii2 := expect("[", "FieldNameList") ii3 := P_FieldNameList_1() ii4 := expect("]", "FieldNameList") #line 274 "grammar.nw" full_name_table(ii3) #line 21000"generated code" } default : error("syntax error parsing FieldNameList:\n\texpected 'names'") } end procedure P_FieldNameList_1() case token of { "\"" | "]" | "_" | IDENT : # FieldNameList_1 : {FieldName} return { ii1 := [] while token == ("\"" | "_" | IDENT) do put(ii1, P_FieldName() ) ii1 } default : error("syntax error parsing FieldNameList_1") } end procedure P_FieldName() local ii1 case token of { "\"" | "_" | IDENT : # FieldName : FieldName_1 return { ii1 := P_FieldName_1() #line 275 "grammar.nw" { if member(operands_and_ids, ii1) then { every (if not member(warned_literals, ii1) then warning else verbose)( ii1 || " is used as a field-name literal and an operand or id..." | " the literal takes priority in field bindings" ) insert(warned_literals, ii1) } else insert(fieldname_literals, ii1) }; ii1 #line 22000"generated code" } default : error("syntax error parsing FieldName:\n\texpected '\'', '_', or IDENT") } end procedure P_FieldName_1() case token of { "\"" : # FieldName_1 : String return P_String() "_" | IDENT : # FieldName_1 : Ident return P_Ident() default : error("syntax error parsing FieldName_1:\n\texpected '\'', '_', or IDENT") } end procedure P_SparseNames() local ii1, ii2, ii3, ii4 case token of { "sparse" : # SparseNames : "sparse" "[" Bindings "]" return { ii1 := expect("sparse", "SparseNames") ii2 := expect("[", "SparseNames") ii3 := P_Bindings() ii4 := expect("]", "SparseNames") #line 281 "grammar.nw" sparse_name_table(ii3) #line 23000"generated code" } default : error("syntax error parsing SparseNames:\n\texpected 'sparse'") } end procedure P_Bindings() local ii1, ii2 case token of { "\"" | "_" | IDENT : # Bindings : Binding Bindings_1 return { ii1 := P_Binding() ii2 := P_Bindings_1() #line 282 "grammar.nw" push(ii2, ii1) #line 24000"generated code" } default : error("syntax error parsing Bindings:\n\texpected '\'', '_', or IDENT") } end procedure P_Bindings_1() case token of { "," | "]" : # Bindings_1 : {Bindings_1_1} return { ii1 := [] while token == (",") do put(ii1, P_Bindings_1_1() ) ii1 } default : error("syntax error parsing Bindings_1:\n\texpected ',' or ']'") } end procedure P_Bindings_1_1() local ii1, ii2 case token of { "," : # Bindings_1_1 : "," Binding return { ii1 := expect(",", "Bindings_1_1") ii2 := P_Binding() #line 282 "grammar.nw" ii2 #line 25000"generated code" } default : error("syntax error parsing Bindings_1_1:\n\texpected ','") } end procedure P_Binding() local ii1, ii2, ii3 case token of { "\"" | "_" | IDENT : # Binding : Binding_1 "=" Integer return { ii1 := P_Binding_1() ii2 := expect("=", "Binding") ii3 := P_Integer() #line 283 "grammar.nw" enumbinding(ii1, ii3) #line 26000"generated code" } default : error("syntax error parsing Binding:\n\texpected '\'', '_', or IDENT") } end procedure P_Binding_1() case token of { "\"" : # Binding_1 : String return P_String() "_" | IDENT : # Binding_1 : Ident return P_Ident() default : error("syntax error parsing Binding_1:\n\texpected '\'', '_', or IDENT") } end procedure P_DenseNames() local ii1, ii2, ii3, ii4 case token of { "names" : # DenseNames : "names" "[" DenseNames_1 "]" return { ii1 := expect("names", "DenseNames") ii2 := expect("[", "DenseNames") ii3 := P_DenseNames_1() ii4 := expect("]", "DenseNames") #line 284 "grammar.nw" full_name_table(ii3) #line 27000"generated code" } default : error("syntax error parsing DenseNames:\n\texpected 'names'") } end procedure P_DenseNames_1() case token of { "\"" | "]" | "_" | IDENT : # DenseNames_1 : {DenseNames_1_1} return { ii1 := [] while token == ("\"" | "_" | IDENT) do put(ii1, P_DenseNames_1_1() ) ii1 } default : error("syntax error parsing DenseNames_1") } end procedure P_DenseNames_1_1() case token of { "\"" : # DenseNames_1_1 : String return P_String() "_" | IDENT : # DenseNames_1_1 : Ident return P_Ident() default : error("syntax error parsing DenseNames_1_1:\n\texpected '\'', '_', or IDENT") } end procedure P_NameTable() case token of { "sparse" : # NameTable : SparseNames return P_SparseNames() "names" : # NameTable : DenseNames return P_DenseNames() default : error("syntax error parsing NameTable:\n\texpected 'names' or 'sparse'") } end procedure P_Patterns() local ii1, ii2 case token of { "patterns" : # Patterns : "patterns" Patterns_1 return { ii1 := expect("patterns", "Patterns") ii2 := P_Patterns_1() #line 385 "grammar.nw" ii2 #line 28000"generated code" } default : error("syntax error parsing Patterns:\n\texpected 'patterns'") } end procedure P_Patterns_1() case token of { "[" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # Patterns_1 : {PatBinding} return { ii1 := [] while token == ("[" | "_" | IDENT) do put(ii1, P_PatBinding() ) ii1 } default : error("syntax error parsing Patterns_1") } end procedure P_PatBinding() local ii1, ii2, ii3, ii4, ii5 case token of { "_" | IDENT : # PatBinding : PatBinding_1 "is" BindingRHS return { ii1 := P_PatBinding_1() ii2 := expect("is", "PatBinding") ii3 := P_BindingRHS() #line 387 "grammar.nw" [ii1, ii2, ii3] #line 29000"generated code" } "[" : # PatBinding : "[" PatBinding_2 "]" "is" Pattern return { ii1 := expect("[", "PatBinding") ii2 := P_PatBinding_2() ii3 := expect("]", "PatBinding") ii4 := expect("is", "PatBinding") ii5 := P_Pattern() #line 387 "grammar.nw" patbinding(ii2, ii5) #line 30000"generated code" } default : error("syntax error parsing PatBinding:\n\texpected '[', '_', or IDENT") } end procedure P_PatBinding_2() case token of { "]" | "_" | IDENT : # PatBinding_2 : {Ident} return { ii1 := [] while token == ("_" | IDENT) do put(ii1, P_Ident() ) ii1 } default : error("syntax error parsing PatBinding_2:\n\texpected ']', '_', or IDENT") } end procedure P_PatBinding_1() local ii1 case token of { "_" | IDENT : # PatBinding_1 : Ident return { ii1 := P_Ident() #line 386 "grammar.nw" patlhs := ii1 #line 31000"generated code" } default : error("syntax error parsing PatBinding_1:\n\texpected '_' or IDENT") } end procedure P_BindingRHS() local ii1, ii2, ii3, ii4, ii5, ii6, ii7, ii8, ii9 case token of { "(" | "..." | "[" | "\"" | "_" | "epsilon" | "some" | IDENT : # BindingRHS : Pattern return { ii1 := P_Pattern() #line 389 "grammar.nw" patbinding(patlhs, ii1) #line 32000"generated code" } "any" : # BindingRHS : "any" "of" "[" BindingRHS_1 "]" "," "which" "is" Pattern return { ii1 := expect("any", "BindingRHS") ii2 := expect("of", "BindingRHS") ii3 := expect("[", "BindingRHS") ii4 := P_BindingRHS_1() ii5 := expect("]", "BindingRHS") ii6 := expect(",", "BindingRHS") ii7 := expect("which", "BindingRHS") ii8 := expect("is", "BindingRHS") ii9 := P_Pattern() #line 391 "grammar.nw" patbinding(copy(ii4), ii9) l := [] every put(l, Pident("_" ~== !ii4)) patbinding(patlhs, Por(l)) #line 33000"generated code" } default : error("syntax error parsing BindingRHS") } end procedure P_BindingRHS_1() case token of { "]" | "_" | IDENT : # BindingRHS_1 : {Ident} return { ii1 := [] while token == ("_" | IDENT) do put(ii1, P_Ident() ) ii1 } default : error("syntax error parsing BindingRHS_1:\n\texpected ']', '_', or IDENT") } end procedure P_Pattern() local ii1, ii2 case token of { "(" | "..." | "[" | "\"" | "_" | "epsilon" | "some" | IDENT : # Pattern : Disjunct Pattern_1 return { ii1 := P_Disjunct() ii2 := P_Pattern_1() #line 439 "grammar.nw" Por(push(ii2, ii1)) #line 34000"generated code" } default : error("syntax error parsing Pattern") } end procedure P_Pattern_1() case token of { ")" | "=>" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | IDENT | EOF : # Pattern_1 : {Pattern_1_1} return { ii1 := [] while token == ("|") do put(ii1, P_Pattern_1_1() ) ii1 } default : error("syntax error parsing Pattern_1") } end procedure P_Pattern_1_1() local ii1, ii2 case token of { "|" : # Pattern_1_1 : "|" Disjunct return { ii1 := expect("|", "Pattern_1_1") ii2 := P_Disjunct() #line 439 "grammar.nw" ii2 #line 35000"generated code" } default : error("syntax error parsing Pattern_1_1:\n\texpected '|'") } end procedure P_Disjunct() local ii1, ii2 case token of { "(" | "..." | "[" | "\"" | "_" | "epsilon" | "some" | IDENT : # Disjunct : Sequent Disjunct_1 return { ii1 := P_Sequent() ii2 := P_Disjunct_1() #line 442 "grammar.nw" Pseq(colons_to_labels(push(ii2, ii1))) #line 36000"generated code" } default : error("syntax error parsing Disjunct") } end procedure P_Disjunct_1() case token of { ")" | ":" | ";" | "=>" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | IDENT | EOF : # Disjunct_1 : {Disjunct_1_1} return { ii1 := [] while token == (":" | ";") do put(ii1, P_Disjunct_1_1() ) ii1 } default : error("syntax error parsing Disjunct_1") } end procedure P_Disjunct_1_1() local ii1, ii2 case token of { ";" : # Disjunct_1_1 : ";" Sequent return { ii1 := expect(";", "Disjunct_1_1") ii2 := P_Sequent() #line 441 "grammar.nw" ii2 #line 37000"generated code" } ":" : # Disjunct_1_1 : ":" Sequent return { ii1 := expect(":", "Disjunct_1_1") ii2 := P_Sequent() #line 441 "grammar.nw" colon_mark(ii2) #line 38000"generated code" } default : error("syntax error parsing Disjunct_1_1:\n\texpected ':' or ';'") } end procedure P_Sequent() local ii1, ii2 case token of { "(" | "..." | "[" | "\"" | "_" | "epsilon" | "some" | IDENT : # Sequent : Conjunct Sequent_1 return { ii1 := P_Conjunct() ii2 := P_Sequent_1() #line 443 "grammar.nw" Pand(push(ii2, ii1)) #line 39000"generated code" } default : error("syntax error parsing Sequent") } end procedure P_Sequent_1() case token of { "&" | ")" | ":" | ";" | "=>" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | IDENT | EOF : # Sequent_1 : {Sequent_1_1} return { ii1 := [] while token == ("&") do put(ii1, P_Sequent_1_1() ) ii1 } default : error("syntax error parsing Sequent_1") } end procedure P_Sequent_1_1() local ii1, ii2 case token of { "&" : # Sequent_1_1 : "&" Conjunct return { ii1 := expect("&", "Sequent_1_1") ii2 := P_Conjunct() #line 443 "grammar.nw" ii2 #line 40000"generated code" } default : error("syntax error parsing Sequent_1_1:\n\texpected '&'") } end procedure P_Conjunct() local ii1, ii2 case token of { "(" | "..." | "[" | "\"" | "_" | "epsilon" | "some" | IDENT : # Conjunct : Conjunct_1 DotsR return { ii1 := P_Conjunct_1() ii2 := P_DotsR() #line 445 "grammar.nw" if \ii1 then Pseq([dots_pattern(),ii2]) else ii2 #line 41000"generated code" } default : error("syntax error parsing Conjunct") } end procedure P_Conjunct_1() case token of { "(" | "..." | "[" | "\"" | "_" | "epsilon" | "some" | IDENT : # Conjunct_1 : [Conjunct_1_1] return { ii1 := &null if token == ("...") then ii1 := ( P_Conjunct_1_1() ) ii1 } default : error("syntax error parsing Conjunct_1") } end procedure P_Conjunct_1_1() local ii1 case token of { "..." : # Conjunct_1_1 : "..." return { ii1 := expect("...", "Conjunct_1_1") #line 445 "grammar.nw" ii1 #line 42000"generated code" } default : error("syntax error parsing Conjunct_1_1:\n\texpected '...'") } end procedure P_DotsR() local ii1, ii2 case token of { "(" | "[" | "\"" | "_" | "epsilon" | "some" | IDENT : # DotsR : Atomic DotsR_1 return { ii1 := P_Atomic() ii2 := P_DotsR_1() #line 446 "grammar.nw" if \ii2 then Pseq([ii1,dots_pattern()]) else ii1 #line 43000"generated code" } default : error("syntax error parsing DotsR") } end procedure P_DotsR_1() case token of { "&" | ")" | "..." | ":" | ";" | "=>" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | IDENT | EOF : # DotsR_1 : [DotsR_1_1] return { ii1 := &null if token == ("...") then ii1 := ( P_DotsR_1_1() ) ii1 } default : error("syntax error parsing DotsR_1") } end procedure P_DotsR_1_1() local ii1 case token of { "..." : # DotsR_1_1 : "..." return { ii1 := expect("...", "DotsR_1_1") #line 446 "grammar.nw" ii1 #line 44000"generated code" } default : error("syntax error parsing DotsR_1_1:\n\texpected '...'") } end procedure P_Atomic() local ii1, ii2, ii3, ii4, ii5 case token of { "_" | IDENT : # Atomic : Atomic_1 Atomic_2 return { ii1 := P_Atomic_1() ii2 := P_Atomic_2() #line 453 "grammar.nw" ii2 #line 45000"generated code" } "\"" : # Atomic : String Atomic_3 "(" ConstructorArgs ")" return { ii1 := P_String() ii2 := P_Atomic_3() ii3 := expect("(", "Atomic") ii4 := P_ConstructorArgs() ii5 := expect(")", "Atomic") #line 455 "grammar.nw" Papp(push(ii2, ii1), ii4) #line 46000"generated code" } "(" : # Atomic : "(" Pattern ")" return { ii1 := expect("(", "Atomic") ii2 := P_Pattern() ii3 := expect(")", "Atomic") #line 457 "grammar.nw" ii2 #line 47000"generated code" } "[" : # Atomic : "[" Atomic_4 "]" return { ii1 := expect("[", "Atomic") ii2 := P_Atomic_4() ii3 := expect("]", "Atomic") #line 457 "grammar.nw" Plist(ii2) #line 48000"generated code" } "epsilon" : # Atomic : "epsilon" return { ii1 := expect("epsilon", "Atomic") #line 671 "grammar.nw" epsilon() #line 49000"generated code" } "some" : # Atomic : "some" Ident return { ii1 := expect("some", "Atomic") ii2 := P_Ident() #line 672 "grammar.nw" wildcard(lookuptype(ii2, "equivclass")) #line 50000"generated code" } default : error("syntax error parsing Atomic") } end procedure P_Atomic_4() case token of { "]" | "_" | IDENT : # Atomic_4 : {Atomic_4_1} return { ii1 := [] while token == ("_" | IDENT) do put(ii1, P_Atomic_4_1() ) ii1 } default : error("syntax error parsing Atomic_4:\n\texpected ']', '_', or IDENT") } end procedure P_Atomic_4_1() local ii1 case token of { "_" | IDENT : # Atomic_4_1 : Ident return { ii1 := P_Ident() #line 457 "grammar.nw" Pident(ii1) #line 51000"generated code" } default : error("syntax error parsing Atomic_4_1:\n\texpected '_' or IDENT") } end procedure P_Atomic_3() case token of { "(" | "^" : # Atomic_3 : {Atomic_3_1} return { ii1 := [] while token == ("^") do put(ii1, P_Atomic_3_1() ) ii1 } default : error("syntax error parsing Atomic_3:\n\texpected '(' or '^'") } end procedure P_Atomic_3_1() local ii1, ii2 case token of { "^" : # Atomic_3_1 : "^" Opname return { ii1 := expect("^", "Atomic_3_1") ii2 := P_Opname() #line 454 "grammar.nw" ii2 #line 52000"generated code" } default : error("syntax error parsing Atomic_3_1:\n\texpected '^'") } end procedure P_Atomic_2() local ii1, ii2, ii3, ii4 case token of { "&" | ")" | "..." | ":" | ";" | "=>" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | IDENT | EOF : # Atomic_2 : return { #line 449 "grammar.nw" Pident(atomicid) #line 53000"generated code" } "!=" | "<" | "<=" | "=" | ">" | ">=" : # Atomic_2 : Relop Atomic_2_1 return { ii1 := P_Relop() ii2 := P_Atomic_2_1() #line 450 "grammar.nw" Pcon(atomicid, ii1, ii2) #line 54000"generated code" } "(" | "^" : # Atomic_2 : Atomic_2_2 "(" ConstructorArgs ")" return { ii1 := P_Atomic_2_2() ii2 := expect("(", "Atomic_2") ii3 := P_ConstructorArgs() ii4 := expect(")", "Atomic_2") #line 452 "grammar.nw" Papp(push(ii1, \symtab[atomicid] | atomicid), ii3) #line 55000"generated code" } default : error("syntax error parsing Atomic_2") } end procedure P_Atomic_2_2() case token of { "(" | "^" : # Atomic_2_2 : {Atomic_2_2_1} return { ii1 := [] while token == ("^") do put(ii1, P_Atomic_2_2_1() ) ii1 } default : error("syntax error parsing Atomic_2_2:\n\texpected '(' or '^'") } end procedure P_Atomic_2_2_1() local ii1, ii2 case token of { "^" : # Atomic_2_2_1 : "^" Opname return { ii1 := expect("^", "Atomic_2_2_1") ii2 := P_Opname() #line 451 "grammar.nw" ii2 #line 56000"generated code" } default : error("syntax error parsing Atomic_2_2_1:\n\texpected '^'") } end procedure P_Atomic_2_1() case token of { "[" | "{" : # Atomic_2_1 : Generator return P_Generator() "'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT : # Atomic_2_1 : Expr return P_Expr() default : error("syntax error parsing Atomic_2_1") } end procedure P_Atomic_1() local ii1 case token of { "_" | IDENT : # Atomic_1 : Ident return { ii1 := P_Ident() #line 448 "grammar.nw" atomicid := ii1 #line 57000"generated code" } default : error("syntax error parsing Atomic_1:\n\texpected '_' or IDENT") } end procedure P_ConstructorArgs() local ii1, ii2 case token of { "'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT : # ConstructorArgs : AppExpr ConstructorArgs_1 return { ii1 := P_AppExpr() ii2 := P_ConstructorArgs_1() #line 459 "grammar.nw" push(ii2, ii1) #line 58000"generated code" } ")" : # ConstructorArgs : return { #line 460 "grammar.nw" [] #line 59000"generated code" } default : error("syntax error parsing ConstructorArgs") } end procedure P_ConstructorArgs_1() case token of { ")" | "," : # ConstructorArgs_1 : {ConstructorArgs_1_1} return { ii1 := [] while token == (",") do put(ii1, P_ConstructorArgs_1_1() ) ii1 } default : error("syntax error parsing ConstructorArgs_1:\n\texpected ')' or ','") } end procedure P_ConstructorArgs_1_1() local ii1, ii2 case token of { "," : # ConstructorArgs_1_1 : "," AppExpr return { ii1 := expect(",", "ConstructorArgs_1_1") ii2 := P_AppExpr() #line 459 "grammar.nw" ii2 #line 60000"generated code" } default : error("syntax error parsing ConstructorArgs_1_1:\n\texpected ','") } end procedure P_Relop() local ii1 case token of { "=" : # Relop : "=" return { ii1 := expect("=", "Relop") #line 641 "grammar.nw" ii1 #line 61000"generated code" } "!=" : # Relop : "!=" return { ii1 := expect("!=", "Relop") #line 641 "grammar.nw" ii1 #line 62000"generated code" } "<=" : # Relop : "<=" return { ii1 := expect("<=", "Relop") #line 641 "grammar.nw" ii1 #line 63000"generated code" } ">=" : # Relop : ">=" return { ii1 := expect(">=", "Relop") #line 641 "grammar.nw" ii1 #line 64000"generated code" } "<" : # Relop : "<" return { ii1 := expect("<", "Relop") #line 641 "grammar.nw" ii1 #line 65000"generated code" } ">" : # Relop : ">" return { ii1 := expect(">", "Relop") #line 641 "grammar.nw" ii1 #line 66000"generated code" } default : error("syntax error parsing Relop") } end procedure P_Generator() local ii1, ii2, ii3, ii4, ii5, ii6 case token of { "{" : # Generator : "{" Integer "to" Integer Generator_1 "}" return { ii1 := expect("{", "Generator") ii2 := P_Integer() ii3 := expect("to", "Generator") ii4 := P_Integer() ii5 := P_Generator_1() ii6 := expect("}", "Generator") #line 643 "grammar.nw" Gfor(ii2, ii4+1, \ii5 | 1) #line 67000"generated code" } "[" : # Generator : "[" Generator_2 "]" return { ii1 := expect("[", "Generator") ii2 := P_Generator_2() ii3 := expect("]", "Generator") #line 644 "grammar.nw" Glist(ii2) #line 68000"generated code" } default : error("syntax error parsing Generator:\n\texpected '[' or '{'") } end procedure P_Generator_2() case token of { "'" | "]" | INT : # Generator_2 : {Integer} return { ii1 := [] while token == ("'" | INT) do put(ii1, P_Integer() ) ii1 } default : error("syntax error parsing Generator_2:\n\texpected ''', ']', or INT") } end procedure P_Generator_1() case token of { "columns" | "}" : # Generator_1 : [Generator_1_1] return { ii1 := &null if token == ("columns") then ii1 := ( P_Generator_1_1() ) ii1 } default : error("syntax error parsing Generator_1:\n\texpected 'columns' or '}'") } end procedure P_Generator_1_1() local ii1, ii2 case token of { "columns" : # Generator_1_1 : "columns" INT return { ii1 := expect("columns", "Generator_1_1") ii2 := expect(INT, "Generator_1_1") #line 642 "grammar.nw" ii2 #line 69000"generated code" } default : error("syntax error parsing Generator_1_1:\n\texpected 'columns'") } end procedure P_Constructors() local ii1, ii2, ii3 case token of { "discard" : # Constructors : "discard" Constructors_1 return { ii1 := expect("discard", "Constructors") ii2 := P_Constructors_1() #line 1140 "grammar.nw" every discard_cons_named(explode_names(!ii2)) #line 70000"generated code" } "keep" : # Constructors : "keep" Constructors_2 return { ii1 := expect("keep", "Constructors") ii2 := P_Constructors_2() #line 1142 "grammar.nw" s := set() every insert(s, is_constructor(explode_names(!ii2), warning)) every k := key(constructors) do if not member(s, constructors[k]) then delete(constructors, k) #line 71000"generated code" } "constructors" : # Constructors : "constructors" Constructors_3 Constructors_4 return { ii1 := expect("constructors", "Constructors") ii2 := P_Constructors_3() ii3 := P_Constructors_4() #line 753 "grammar.nw" [ii1, ii2, ii3] #line 72000"generated code" } default : error("syntax error parsing Constructors:\n\texpected 'constructors', 'discard', or 'keep'") } end procedure P_Constructors_4() case token of { "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # Constructors_4 : {Constructors_4_1} return { ii1 := [] while token == ("\"" | "_" | IDENT) do put(ii1, P_Constructors_4_1() ) ii1 } default : error("syntax error parsing Constructors_4") } end procedure P_Constructors_4_1() local ii1 case token of { "\"" | "_" | IDENT : # Constructors_4_1 : Constructor return { ii1 := P_Constructor() #line 753 "grammar.nw" see_newline() #line 73000"generated code" } default : error("syntax error parsing Constructors_4_1:\n\texpected '\'', '_', or IDENT") } end procedure P_Constructors_3() case token of { "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # Constructors_3 : return { #line 753 "grammar.nw" see_newline() #line 74000"generated code" } default : error("syntax error parsing Constructors_3") } end procedure P_Constructors_2() case token of { "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # Constructors_2 : {Opcode} return { ii1 := [] while token == ("\"" | "_" | IDENT) do put(ii1, P_Opcode() ) ii1 } default : error("syntax error parsing Constructors_2") } end procedure P_Constructors_1() case token of { "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # Constructors_1 : {Opcode} return { ii1 := [] while token == ("\"" | "_" | IDENT) do put(ii1, P_Opcode() ) ii1 } default : error("syntax error parsing Constructors_1") } end procedure P_Constructor() local ii1, ii2, ii3, ii4 case token of { "\"" | "_" | IDENT : # Constructor : Opcode Operands Constructor_1 NLBranches return { ii1 := P_Opcode() ii2 := P_Operands() ii3 := P_Constructor_1() ii4 := P_NLBranches() #line 755 "grammar.nw" note_constructor(ii1, ii2, \ii3 | instructionctype, ii4) #line 75000"generated code" } default : error("syntax error parsing Constructor:\n\texpected '\'', '_', or IDENT") } end procedure P_Constructor_1() case token of { ":" | "is" | "when" | "{" | NEWLINE : # Constructor_1 : [Constructor_1_1] return { ii1 := &null if token == (":") then ii1 := ( P_Constructor_1_1() ) ii1 } default : error("syntax error parsing Constructor_1") } end procedure P_Constructor_1_1() local ii1, ii2 case token of { ":" : # Constructor_1_1 : ":" ConstType return { ii1 := expect(":", "Constructor_1_1") ii2 := P_ConstType() #line 754 "grammar.nw" ii2 #line 76000"generated code" } default : error("syntax error parsing Constructor_1_1:\n\texpected ':'") } end procedure P_Operands() local ii1, ii2, ii3 case token of { "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "address" | "is" | "when" | "{" | "|" | IDENT | INT | NEWLINE | WHITESPACE : # Operands : SeeWhite Operands_1 StopWhite return { ii1 := P_SeeWhite() ii2 := P_Operands_1() ii3 := P_StopWhite() #line 757 "grammar.nw" process_operands(ii2) #line 77000"generated code" } default : error("syntax error parsing Operands") } end procedure P_Operands_1() case token of { "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "address" | "is" | "when" | "{" | "|" | IDENT | INT | NEWLINE | WHITESPACE : # Operands_1 : {Operand} return { ii1 := [] while token == ("!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "address" | "|" | IDENT | INT | WHITESPACE) do put(ii1, P_Operand() ) ii1 } default : error("syntax error parsing Operands_1") } end procedure P_NLBranches() local ii1, ii2 case token of { "is" | "when" | "{" : # NLBranches : Branches return P_Branches() NEWLINE : # NLBranches : NEWLINE NLBranches_1 return { ii1 := expect(NEWLINE, "NLBranches") ii2 := P_NLBranches_1() #line 794 "grammar.nw" ii2 #line 78000"generated code" } default : error("syntax error parsing NLBranches") } end procedure P_NLBranches_1() case token of { "is" | "when" | "{" : # NLBranches_1 : Branches return P_Branches() "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # NLBranches_1 : return { #line 793 "grammar.nw" [ [ [], &null ] ] #line 79000"generated code" } default : error("syntax error parsing NLBranches_1") } end procedure P_Branches() local ii1, ii2 case token of { "is" | "{" : # Branches : SingleBranch return { ii1 := P_SingleBranch() #line 795 "grammar.nw" [ii1] #line 80000"generated code" } "when" : # Branches : WhenBranch Branches_1 return { ii1 := P_WhenBranch() ii2 := P_Branches_1() #line 797 "grammar.nw" push(ii2, ii1); ii2 #line 81000"generated code" } default : error("syntax error parsing Branches:\n\texpected 'is', 'when', or '{'") } end procedure P_Branches_1() case token of { "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | IDENT | EOF : # Branches_1 : {Branches_1_1} return { ii1 := [] while token == ("otherwise" | "when") do put(ii1, P_Branches_1_1() ) ii1 } default : error("syntax error parsing Branches_1") } end procedure P_Branches_1_1() case token of { "when" : # Branches_1_1 : WhenBranch return P_WhenBranch() "otherwise" : # Branches_1_1 : OtherwiseBranch return P_OtherwiseBranch() default : error("syntax error parsing Branches_1_1:\n\texpected 'otherwise' or 'when'") } end procedure P_SingleBranch() local ii1, ii2, ii3, ii4 case token of { "{" : # SingleBranch : "{" Equations "}" SingleBranch_1 return { ii1 := expect("{", "SingleBranch") ii2 := P_Equations() ii3 := expect("}", "SingleBranch") ii4 := P_SingleBranch_1() #line 799 "grammar.nw" [ ii2, \ii4 | &null] #line 82000"generated code" } "is" : # SingleBranch : "is" Pattern return { ii1 := expect("is", "SingleBranch") ii2 := P_Pattern() #line 800 "grammar.nw" [ [] , ii2 ] #line 83000"generated code" } default : error("syntax error parsing SingleBranch:\n\texpected 'is' or '{'") } end procedure P_SingleBranch_1() case token of { "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "is" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # SingleBranch_1 : [SingleBranch_1_1] return { ii1 := &null if token == ("is") then ii1 := ( P_SingleBranch_1_1() ) ii1 } default : error("syntax error parsing SingleBranch_1") } end procedure P_SingleBranch_1_1() local ii1, ii2 case token of { "is" : # SingleBranch_1_1 : "is" Pattern return { ii1 := expect("is", "SingleBranch_1_1") ii2 := P_Pattern() #line 799 "grammar.nw" ii2 #line 84000"generated code" } default : error("syntax error parsing SingleBranch_1_1:\n\texpected 'is'") } end procedure P_WhenBranch() local ii1, ii2, ii3, ii4, ii5, ii6 case token of { "when" : # WhenBranch : "when" "{" Equations "}" "is" Pattern return { ii1 := expect("when", "WhenBranch") ii2 := expect("{", "WhenBranch") ii3 := P_Equations() ii4 := expect("}", "WhenBranch") ii5 := expect("is", "WhenBranch") ii6 := P_Pattern() #line 802 "grammar.nw" [ii3, ii6] #line 85000"generated code" } default : error("syntax error parsing WhenBranch:\n\texpected 'when'") } end procedure P_OtherwiseBranch() local ii1, ii2, ii3 case token of { "otherwise" : # OtherwiseBranch : "otherwise" "is" Pattern return { ii1 := expect("otherwise", "OtherwiseBranch") ii2 := expect("is", "OtherwiseBranch") ii3 := P_Pattern() #line 803 "grammar.nw" [[], ii3] #line 86000"generated code" } default : error("syntax error parsing OtherwiseBranch:\n\texpected 'otherwise'") } end procedure P_Opcode() local ii1, ii2 case token of { "\"" | "_" | IDENT : # Opcode : Opname Opcode_1 return { ii1 := P_Opname() ii2 := P_Opcode_1() #line 863 "grammar.nw" push(ii2, ii1) #line 87000"generated code" } default : error("syntax error parsing Opcode:\n\texpected '\'', '_', or IDENT") } end procedure P_Opcode_1() case token of { "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "^" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "is" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | IDENT | INT | NEWLINE | WHITESPACE | EOF : # Opcode_1 : {Opcode_1_1} return { ii1 := [] while token == ("^") do put(ii1, P_Opcode_1_1() ) ii1 } default : error("syntax error parsing Opcode_1") } end procedure P_Opcode_1_1() local ii1, ii2 case token of { "^" : # Opcode_1_1 : "^" Opname return { ii1 := expect("^", "Opcode_1_1") ii2 := P_Opname() #line 863 "grammar.nw" ii2 #line 88000"generated code" } default : error("syntax error parsing Opcode_1_1:\n\texpected '^'") } end procedure P_Opname() local ii1 case token of { "_" | IDENT : # Opname : Ident return { ii1 := P_Ident() #line 864 "grammar.nw" \symtab[ii1] | ii1 #line 89000"generated code" } "\"" : # Opname : String return P_String() default : error("syntax error parsing Opname:\n\texpected '\'', '_', or IDENT") } end procedure P_Operand() local ii1, ii2 case token of { "_" | "address" | IDENT : # Operand : Operand_1 Operand_2 return { ii1 := P_Operand_1() ii2 := P_Operand_2() #line 934 "grammar.nw" { if member(fieldname_literals, ii1) then { every (if not member(warned_literals, ii1) then warning else verbose)( ii1 || " is used as a field-name literal and an operand or id..." | " the literal takes priority in field bindings" ) insert(warned_literals, ii1) } else insert(operands_and_ids, ii1) }; name_to_input(ii1, ii2) #line 90000"generated code" } "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "|" | INT | WHITESPACE : # Operand : Operand_3 return { ii1 := P_Operand_3() #line 936 "grammar.nw" literal(ii1) #line 91000"generated code" } default : error("syntax error parsing Operand") } end procedure P_Operand_3() case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "|" | INT : # Operand_3 : Literal return P_Literal() "$" | "*" | "," : # Operand_3 : GlobOperator return P_GlobOperator() WHITESPACE : # Operand_3 : White return P_White() default : error("syntax error parsing Operand_3") } end procedure P_Operand_2() case token of { "!" | "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "address" | "is" | "when" | "{" | "|" | IDENT | INT | NEWLINE | WHITESPACE : # Operand_2 : [Operand_2_1] return { ii1 := &null if token == ("!") then ii1 := ( P_Operand_2_1() ) ii1 } default : error("syntax error parsing Operand_2") } end procedure P_Operand_2_1() local ii1 case token of { "!" : # Operand_2_1 : "!" return { ii1 := expect("!", "Operand_2_1") #line 934 "grammar.nw" ii1 #line 92000"generated code" } default : error("syntax error parsing Operand_2_1:\n\texpected '!'") } end procedure P_Operand_1() case token of { "_" | IDENT : # Operand_1 : Ident return P_Ident() "address" : # Operand_1 : AddressAsIdent return P_AddressAsIdent() default : error("syntax error parsing Operand_1:\n\texpected '_', 'address', or IDENT") } end procedure P_AddressAsIdent() local ii1, ii2, ii3 case token of { "address" : # AddressAsIdent : AddressAsIdent_1 "address" SeeWhite return { ii1 := P_AddressAsIdent_1() ii2 := expect("address", "AddressAsIdent") ii3 := P_SeeWhite() #line 938 "grammar.nw" ii2 #line 93000"generated code" } default : error("syntax error parsing AddressAsIdent:\n\texpected 'address'") } end procedure P_AddressAsIdent_1() case token of { "address" : # AddressAsIdent_1 : return { #line 938 "grammar.nw" NEWLINEVISION := 1 #line 94000"generated code" } default : error("syntax error parsing AddressAsIdent_1:\n\texpected 'address'") } end procedure P_Literal() local ii1 case token of { "\"" : # Literal : String return P_String() "'" | INT : # Literal : Integer return { ii1 := P_Integer() #line 940 "grammar.nw" string(ii1) #line 95000"generated code" } "!=" | "<" | "<=" | "=" | ">" | ">=" : # Literal : Relop return P_Relop() "=>" : # Literal : "=>" return { ii1 := expect("=>", "Literal") #line 941 "grammar.nw" ii1 #line 96000"generated code" } "[" : # Literal : "[" return { ii1 := expect("[", "Literal") #line 941 "grammar.nw" ii1 #line 97000"generated code" } "]" : # Literal : "]" return { ii1 := expect("]", "Literal") #line 941 "grammar.nw" ii1 #line 98000"generated code" } "(" : # Literal : "(" return { ii1 := expect("(", "Literal") #line 941 "grammar.nw" ii1 #line 99000"generated code" } ")" : # Literal : ")" return { ii1 := expect(")", "Literal") #line 941 "grammar.nw" ii1 #line 100000"generated code" } "+" : # Literal : "+" return { ii1 := expect("+", "Literal") #line 941 "grammar.nw" ii1 #line 101000"generated code" } "-" : # Literal : "-" return { ii1 := expect("-", "Literal") #line 941 "grammar.nw" ii1 #line 102000"generated code" } "/" : # Literal : "/" return { ii1 := expect("/", "Literal") #line 942 "grammar.nw" ii1 #line 103000"generated code" } "&" : # Literal : "&" return { ii1 := expect("&", "Literal") #line 942 "grammar.nw" ii1 #line 104000"generated code" } "@" : # Literal : "@" return { ii1 := expect("@", "Literal") #line 942 "grammar.nw" ii1 #line 105000"generated code" } "#" : # Literal : "#" return { ii1 := expect("#", "Literal") #line 942 "grammar.nw" ii1 #line 106000"generated code" } "%" : # Literal : "%" return { ii1 := expect("%", "Literal") #line 942 "grammar.nw" ii1 #line 107000"generated code" } ";" : # Literal : ";" return { ii1 := expect(";", "Literal") #line 942 "grammar.nw" ii1 #line 108000"generated code" } "|" : # Literal : "|" return { ii1 := expect("|", "Literal") #line 943 "grammar.nw" ii1 #line 109000"generated code" } default : error("syntax error parsing Literal") } end procedure P_GlobOperator() local ii1 case token of { "*" : # GlobOperator : "*" return { ii1 := expect("*", "GlobOperator") #line 944 "grammar.nw" ii1 #line 110000"generated code" } "$" : # GlobOperator : "$" return { ii1 := expect("$", "GlobOperator") #line 944 "grammar.nw" ii1 #line 111000"generated code" } "," : # GlobOperator : "," return { ii1 := expect(",", "GlobOperator") #line 945 "grammar.nw" ii1 #line 112000"generated code" } default : error("syntax error parsing GlobOperator:\n\texpected '$', '*', or ','") } end procedure P_ConstType() local ii1 case token of { "_" | "address" | IDENT : # ConstType : ConstType_1 return { ii1 := P_ConstType_1() #line 968 "grammar.nw" 1(/symtab[ii1] := t := constype(ii1, set()), put(all_types ,t)) | lookuptype(ii1, "constype") #line 113000"generated code" } default : error("syntax error parsing ConstType:\n\texpected '_', 'address', or IDENT") } end procedure P_ConstType_1() local ii1 case token of { "_" | IDENT : # ConstType_1 : Ident return P_Ident() "address" : # ConstType_1 : "address" return { ii1 := expect("address", "ConstType_1") #line 967 "grammar.nw" ii1 #line 114000"generated code" } default : error("syntax error parsing ConstType_1:\n\texpected '_', 'address', or IDENT") } end procedure P_RelocSpec() local ii1, ii2, ii3 case token of { "relocatable" : # RelocSpec : "relocatable" Ident RelocSpec_1 return { ii1 := expect("relocatable", "RelocSpec") ii2 := P_Ident() ii3 := P_RelocSpec_1() #line 1089 "grammar.nw" if /no_reloc then every make_relocatable(ii2 | !ii3) #line 115000"generated code" } default : error("syntax error parsing RelocSpec:\n\texpected 'relocatable'") } end procedure P_RelocSpec_1() case token of { "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # RelocSpec_1 : {Ident} return { ii1 := [] while token == ("_" | IDENT) do put(ii1, P_Ident() ) ii1 } default : error("syntax error parsing RelocSpec_1") } end procedure P_Equations() local ii1 case token of { "'" | "(" | "-" | "\"" | "_" | "address" | "}" | IDENT | INT : # Equations : Equations_1 return { ii1 := P_Equations_1() #line 1165 "grammar.nw" \ii1 | [] #line 116000"generated code" } default : error("syntax error parsing Equations") } end procedure P_Equations_1() case token of { "'" | "(" | "-" | "\"" | "_" | "address" | "}" | IDENT | INT : # Equations_1 : [Equations_1_1] return { ii1 := &null if token == ("'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT) then ii1 := ( P_Equations_1_1() ) ii1 } default : error("syntax error parsing Equations_1") } end procedure P_Equations_1_1() local ii1, ii2 case token of { "'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT : # Equations_1_1 : Equation Equations_1_1_1 return { ii1 := P_Equation() ii2 := P_Equations_1_1_1() #line 1165 "grammar.nw" push(ii2, ii1) #line 117000"generated code" } default : error("syntax error parsing Equations_1_1") } end procedure P_Equations_1_1_1() case token of { "," | "}" : # Equations_1_1_1 : {Equations_1_1_1_1} return { ii1 := [] while token == (",") do put(ii1, P_Equations_1_1_1_1() ) ii1 } default : error("syntax error parsing Equations_1_1_1:\n\texpected ',' or '}'") } end procedure P_Equations_1_1_1_1() local ii1, ii2 case token of { "," : # Equations_1_1_1_1 : "," Equation return { ii1 := expect(",", "Equations_1_1_1_1") ii2 := P_Equation() #line 1165 "grammar.nw" ii2 #line 118000"generated code" } default : error("syntax error parsing Equations_1_1_1_1:\n\texpected ','") } end procedure P_Equation() local ii1, ii2, ii3 case token of { "'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT : # Equation : Expr Relop Expr return { ii1 := P_Expr() ii2 := P_Relop() ii3 := P_Expr() #line 1166 "grammar.nw" eqn(ii1, ii2, ii3) #line 119000"generated code" } default : error("syntax error parsing Equation") } end procedure P_Expr() local ii1 case token of { "'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT : # Expr : AppExpr return { ii1 := P_AppExpr() #line 1195 "grammar.nw" if has_app_or_literal(ii1) then error("Application or literal string not legal") else ii1 #line 120000"generated code" } default : error("syntax error parsing Expr") } end procedure P_AppExpr() local ii1, ii2 case token of { "'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT : # AppExpr : Term AppExpr_1 return { ii1 := P_Term() ii2 := P_AppExpr_1() #line 1212 "grammar.nw" every t := !ii2 do ii1 := binop(ii1, t[1], t[2]); ii1 #line 121000"generated code" } default : error("syntax error parsing AppExpr") } end procedure P_AppExpr_1() case token of { "!=" | "&" | ")" | "+" | "," | "-" | "..." | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | "}" | IDENT | EOF : # AppExpr_1 : {AppExpr_1_1} return { ii1 := [] while token == ("+" | "-") do put(ii1, P_AppExpr_1_1() ) ii1 } default : error("syntax error parsing AppExpr_1") } end procedure P_AppExpr_1_1() local ii1, ii2 case token of { "+" | "-" : # AppExpr_1_1 : AOp Term return { ii1 := P_AOp() ii2 := P_Term() #line 1211 "grammar.nw" [ii1, ii2] #line 122000"generated code" } default : error("syntax error parsing AppExpr_1_1:\n\texpected '+' or '-'") } end procedure P_Term() local ii1, ii2 case token of { "'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT : # Term : Factor Term_1 return { ii1 := P_Factor() ii2 := P_Term_1() #line 1214 "grammar.nw" every f := !ii2 do ii1 := binop(ii1, f[1], f[2]); ii1 #line 123000"generated code" } default : error("syntax error parsing Term") } end procedure P_Term_1() case token of { "!=" | "&" | ")" | "*" | "+" | "," | "-" | "..." | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | "}" | IDENT | EOF : # Term_1 : {Term_1_1} return { ii1 := [] while token == ("*" | "/") do put(ii1, P_Term_1_1() ) ii1 } default : error("syntax error parsing Term_1") } end procedure P_Term_1_1() local ii1, ii2 case token of { "*" | "/" : # Term_1_1 : Mop Factor return { ii1 := P_Mop() ii2 := P_Factor() #line 1213 "grammar.nw" [ii1, ii2] #line 124000"generated code" } default : error("syntax error parsing Term_1_1:\n\texpected '*' or '/'") } end procedure P_AOp() local ii1 case token of { "+" : # AOp : "+" return { ii1 := expect("+", "AOp") #line 1215 "grammar.nw" ii1 #line 125000"generated code" } "-" : # AOp : "-" return { ii1 := expect("-", "AOp") #line 1215 "grammar.nw" ii1 #line 126000"generated code" } default : error("syntax error parsing AOp:\n\texpected '+' or '-'") } end procedure P_Mop() local ii1 case token of { "*" : # Mop : "*" return { ii1 := expect("*", "Mop") #line 1216 "grammar.nw" ii1 #line 127000"generated code" } "/" : # Mop : "/" return { ii1 := expect("/", "Mop") #line 1216 "grammar.nw" ii1 #line 128000"generated code" } default : error("syntax error parsing Mop:\n\texpected '*' or '/'") } end procedure P_Factor() local ii1, ii2, ii3 case token of { "'" | INT : # Factor : Integer return P_Integer() "\"" : # Factor : String return { ii1 := P_String() #line 1218 "grammar.nw" literal(ii1) #line 129000"generated code" } "_" : # Factor : "_" return { ii1 := expect("_", "Factor") #line 1219 "grammar.nw" fresh_variable("_") #line 130000"generated code" } "address" | IDENT : # Factor : Factor_1 Factor_2 return { ii1 := P_Factor_1() ii2 := P_Factor_2() #line 1223 "grammar.nw" if member(fieldname_literals, ii1) then { every (if not member(warned_literals, ii1) then warning else verbose)( ii1 || " is used as a field-name literal and an operand or id..." | " the literal takes priority in field bindings" ) insert(warned_literals, ii1) } else insert(operands_and_ids, ii1) if type(ii2) == "SyntaxRange" then mkfactor(ii1, ii2.bits, ii2.bang) else Eapp(ii1, ii2) #line 131000"generated code" } "(" : # Factor : "(" AppExpr ")" return { ii1 := expect("(", "Factor") ii2 := P_AppExpr() ii3 := expect(")", "Factor") #line 1227 "grammar.nw" ii2 #line 132000"generated code" } "-" : # Factor : "-" Factor return { ii1 := expect("-", "Factor") ii2 := P_Factor() #line 1227 "grammar.nw" binop(0, ii1, ii2) #line 133000"generated code" } default : error("syntax error parsing Factor") } end procedure P_Factor_2() local ii1, ii2, ii3 case token of { "!" | "!=" | "&" | ")" | "*" | "+" | "," | "-" | "..." | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | "}" | IDENT | EOF : # Factor_2 : Factor_2_1 Factor_2_2 return { ii1 := P_Factor_2_1() ii2 := P_Factor_2_2() #line 1220 "grammar.nw" SyntaxRange(ii1, ii2) #line 134000"generated code" } "(" : # Factor_2 : "(" Args ")" return { ii1 := expect("(", "Factor_2") ii2 := P_Args() ii3 := expect(")", "Factor_2") #line 1222 "grammar.nw" ii2 #line 135000"generated code" } default : error("syntax error parsing Factor_2") } end procedure P_Factor_2_2() case token of { "!" | "!=" | "&" | ")" | "*" | "+" | "," | "-" | "..." | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | "}" | IDENT | EOF : # Factor_2_2 : [Factor_2_2_1] return { ii1 := &null if token == ("!") then ii1 := ( P_Factor_2_2_1() ) ii1 } default : error("syntax error parsing Factor_2_2") } end procedure P_Factor_2_2_1() local ii1 case token of { "!" : # Factor_2_2_1 : "!" return { ii1 := expect("!", "Factor_2_2_1") #line 1220 "grammar.nw" ii1 #line 136000"generated code" } default : error("syntax error parsing Factor_2_2_1:\n\texpected '!'") } end procedure P_Factor_2_1() case token of { "!" | "!=" | "&" | ")" | "*" | "+" | "," | "-" | "..." | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "otherwise" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "when" | "wordsize" | "{" | "|" | "}" | IDENT | EOF : # Factor_2_1 : [Bitrange] return { ii1 := &null if token == ("@") then ii1 := ( P_Bitrange() ) ii1 } default : error("syntax error parsing Factor_2_1") } end procedure P_Factor_1() local ii1 case token of { IDENT : # Factor_1 : IDENT return { ii1 := expect(IDENT, "Factor_1") #line 1220 "grammar.nw" ii1 #line 137000"generated code" } "address" : # Factor_1 : "address" return { ii1 := expect("address", "Factor_1") #line 1220 "grammar.nw" ii1 #line 138000"generated code" } default : error("syntax error parsing Factor_1:\n\texpected 'address' or IDENT") } end procedure P_Bitrange() local ii1, ii2, ii3, ii4, ii5 case token of { "@" : # Bitrange : "@" "[" INT Bitrange_1 "]" return { ii1 := expect("@", "Bitrange") ii2 := expect("[", "Bitrange") ii3 := expect(INT, "Bitrange") ii4 := P_Bitrange_1() ii5 := expect("]", "Bitrange") #line 1229 "grammar.nw" [ii3, (\ii4|ii3)+1] #line 139000"generated code" } default : error("syntax error parsing Bitrange:\n\texpected '@'") } end procedure P_Bitrange_1() case token of { ":" | "]" : # Bitrange_1 : [Bitrange_1_1] return { ii1 := &null if token == (":") then ii1 := ( P_Bitrange_1_1() ) ii1 } default : error("syntax error parsing Bitrange_1:\n\texpected ':' or ']'") } end procedure P_Bitrange_1_1() local ii1, ii2 case token of { ":" : # Bitrange_1_1 : ":" INT return { ii1 := expect(":", "Bitrange_1_1") ii2 := expect(INT, "Bitrange_1_1") #line 1229 "grammar.nw" ii2 #line 140000"generated code" } default : error("syntax error parsing Bitrange_1_1:\n\texpected ':'") } end procedure P_Args() local ii1, ii2 case token of { "'" | "(" | "-" | "\"" | "_" | "address" | IDENT | INT : # Args : AppExpr Args_1 return { ii1 := P_AppExpr() ii2 := P_Args_1() #line 1230 "grammar.nw" push(ii2, ii1) #line 141000"generated code" } ")" : # Args : return { #line 1231 "grammar.nw" [] #line 142000"generated code" } default : error("syntax error parsing Args") } end procedure P_Args_1() case token of { ")" | "," : # Args_1 : {Args_1_1} return { ii1 := [] while token == (",") do put(ii1, P_Args_1_1() ) ii1 } default : error("syntax error parsing Args_1:\n\texpected ')' or ','") } end procedure P_Args_1_1() local ii1, ii2 case token of { "," : # Args_1_1 : "," AppExpr return { ii1 := expect(",", "Args_1_1") ii2 := P_AppExpr() #line 1230 "grammar.nw" ii2 #line 143000"generated code" } default : error("syntax error parsing Args_1_1:\n\texpected ','") } end procedure P_CodeFile() local ii1, ii2, ii3 case token of { CASELINE | CODELINE | EOF : # CodeFile : CodeFile_1 CodeFile_2 CodeFile_3 return { ii1 := P_CodeFile_1() ii2 := P_CodeFile_2() ii3 := P_CodeFile_3() #line 1311 "grammar.nw" codeheader.original := codeheader; matching_stmts := ii3 #line 144000"generated code" } default : error("syntax error parsing CodeFile:\n\texpected CASELINE, CODELINE, or end of file") } end procedure P_CodeFile_3() case token of { CASELINE | EOF : # CodeFile_3 : {CodeFile_3_1} return { ii1 := [] while token == (CASELINE) do put(ii1, P_CodeFile_3_1() ) ii1 } default : error("syntax error parsing CodeFile_3:\n\texpected CASELINE or end of file") } end procedure P_CodeFile_3_1() local ii1, ii2 case token of { CASELINE : # CodeFile_3_1 : Casestmt CodeFile_3_1_1 return { ii1 := P_Casestmt() ii2 := P_CodeFile_3_1_1() #line 1310 "grammar.nw" ii1.trailer.code := ii2 ; ii1 #line 145000"generated code" } default : error("syntax error parsing CodeFile_3_1:\n\texpected CASELINE") } end procedure P_CodeFile_3_1_1() case token of { CASELINE | CODELINE | EOF : # CodeFile_3_1_1 : {CodeFile_3_1_1_1} return { ii1 := [] while token == (CODELINE) do put(ii1, P_CodeFile_3_1_1_1() ) ii1 } default : error("syntax error parsing CodeFile_3_1_1:\n\texpected CASELINE, CODELINE, or end of file") } end procedure P_CodeFile_3_1_1_1() local ii1 case token of { CODELINE : # CodeFile_3_1_1_1 : CODELINE return { ii1 := expect(CODELINE, "CodeFile_3_1_1_1") #line 1310 "grammar.nw" ii1 #line 146000"generated code" } default : error("syntax error parsing CodeFile_3_1_1_1:\n\texpected CODELINE") } end procedure P_CodeFile_2() local ii1 case token of { CASELINE | CODELINE | EOF : # CodeFile_2 : CodeFile_2_1 return { ii1 := P_CodeFile_2_1() #line 1309 "grammar.nw" codeheader.code := ii1 #line 147000"generated code" } default : error("syntax error parsing CodeFile_2:\n\texpected CASELINE, CODELINE, or end of file") } end procedure P_CodeFile_2_1() case token of { CASELINE | CODELINE | EOF : # CodeFile_2_1 : {CodeFile_2_1_1} return { ii1 := [] while token == (CODELINE) do put(ii1, P_CodeFile_2_1_1() ) ii1 } default : error("syntax error parsing CodeFile_2_1:\n\texpected CASELINE, CODELINE, or end of file") } end procedure P_CodeFile_2_1_1() local ii1 case token of { CODELINE : # CodeFile_2_1_1 : CODELINE return { ii1 := expect(CODELINE, "CodeFile_2_1_1") #line 1309 "grammar.nw" ii1 #line 148000"generated code" } default : error("syntax error parsing CodeFile_2_1_1:\n\texpected CODELINE") } end procedure P_CodeFile_1() case token of { CASELINE | CODELINE | EOF : # CodeFile_1 : return { #line 1308 "grammar.nw" codeheader := arm(filename, lineno) #line 149000"generated code" } default : error("syntax error parsing CodeFile_1:\n\texpected CASELINE, CODELINE, or end of file") } end procedure P_Casestmt() local ii1, ii2, ii3, ii4 case token of { CASELINE : # Casestmt : CASELINE Casestmt_1 Casestmt_2 "endmatch" return { ii1 := expect(CASELINE, "Casestmt") ii2 := P_Casestmt_1() ii3 := P_Casestmt_2() ii4 := expect("endmatch", "Casestmt") #line 1313 "grammar.nw" x := matching_stmt(ii2, ii1, succptr) ; put(x.arms, \ii3) x.trailer := arm(filename, lineno); x #line 150000"generated code" } default : error("syntax error parsing Casestmt:\n\texpected CASELINE") } end procedure P_Casestmt_2() case token of { "else" | "endmatch" : # Casestmt_2 : [ElseArm] return { ii1 := &null if token == ("else") then ii1 := ( P_ElseArm() ) ii1 } default : error("syntax error parsing Casestmt_2:\n\texpected 'else' or 'endmatch'") } end procedure P_Casestmt_1() case token of { "else" | "endmatch" | "|" : # Casestmt_1 : {Casearm} return { ii1 := [] while token == ("|") do put(ii1, P_Casearm() ) ii1 } default : error("syntax error parsing Casestmt_1:\n\texpected 'else', 'endmatch', or '|'") } end procedure P_Casearm() local ii1, ii2, ii3, ii4, ii5, ii6 case token of { "|" : # Casearm : Casearm_1 Pattern OptEquations OptName "=>" Casearm_2 return { ii1 := P_Casearm_1() ii2 := P_Pattern() ii3 := P_OptEquations() ii4 := P_OptName() ii5 := expect("=>", "Casearm") ii6 := P_Casearm_2() #line 1318 "grammar.nw" ii1.pattern := ii2; ii1.eqns := ii3; ii1.name := ii4; ii1.code := ii6 ii1.original := ii1 #line 151000"generated code" } default : error("syntax error parsing Casearm:\n\texpected '|'") } end procedure P_Casearm_2() case token of { "else" | "endmatch" | "|" | CODELINE : # Casearm_2 : {Casearm_2_1} return { ii1 := [] while token == (CODELINE) do put(ii1, P_Casearm_2_1() ) ii1 } default : error("syntax error parsing Casearm_2") } end procedure P_Casearm_2_1() local ii1 case token of { CODELINE : # Casearm_2_1 : CODELINE return { ii1 := expect(CODELINE, "Casearm_2_1") #line 1317 "grammar.nw" ii1 #line 152000"generated code" } default : error("syntax error parsing Casearm_2_1:\n\texpected CODELINE") } end procedure P_Casearm_1() local ii1 case token of { "|" : # Casearm_1 : "|" return { ii1 := expect("|", "Casearm_1") #line 1316 "grammar.nw" arm(filename, lineno) #line 153000"generated code" } default : error("syntax error parsing Casearm_1:\n\texpected '|'") } end procedure P_ElseArm() local ii1, ii2 case token of { "else" : # ElseArm : ElseArm_1 ElseArm_2 return { ii1 := P_ElseArm_1() ii2 := P_ElseArm_2() #line 1321 "grammar.nw" ii1.code := ii2; ii1.original := ii1 #line 154000"generated code" } default : error("syntax error parsing ElseArm:\n\texpected 'else'") } end procedure P_ElseArm_2() case token of { "endmatch" | CODELINE : # ElseArm_2 : {ElseArm_2_1} return { ii1 := [] while token == (CODELINE) do put(ii1, P_ElseArm_2_1() ) ii1 } default : error("syntax error parsing ElseArm_2:\n\texpected 'endmatch' or CODELINE") } end procedure P_ElseArm_2_1() local ii1 case token of { CODELINE : # ElseArm_2_1 : CODELINE return { ii1 := expect(CODELINE, "ElseArm_2_1") #line 1320 "grammar.nw" ii1 #line 155000"generated code" } default : error("syntax error parsing ElseArm_2_1:\n\texpected CODELINE") } end procedure P_ElseArm_1() local ii1 case token of { "else" : # ElseArm_1 : "else" return { ii1 := expect("else", "ElseArm_1") #line 1320 "grammar.nw" arm(filename, lineno, epsilon()) #line 156000"generated code" } default : error("syntax error parsing ElseArm_1:\n\texpected 'else'") } end procedure P_OptName() case token of { "=>" | "[" : # OptName : [OptName_1] return { ii1 := &null if token == ("[") then ii1 := ( P_OptName_1() ) ii1 } default : error("syntax error parsing OptName:\n\texpected '=>' or '['") } end procedure P_OptName_1() local ii1, ii2, ii3 case token of { "[" : # OptName_1 : "[" Ident "]" return { ii1 := expect("[", "OptName_1") ii2 := P_Ident() ii3 := expect("]", "OptName_1") #line 1322 "grammar.nw" ii2 #line 157000"generated code" } default : error("syntax error parsing OptName_1:\n\texpected '['") } end procedure P_OptEquations() case token of { "=>" | "[" | "{" : # OptEquations : [OptEquations_1] return { ii1 := &null if token == ("{") then ii1 := ( P_OptEquations_1() ) ii1 } default : error("syntax error parsing OptEquations:\n\texpected '=>', '[', or '{'") } end procedure P_OptEquations_1() local ii1, ii2, ii3 case token of { "{" : # OptEquations_1 : "{" Equations "}" return { ii1 := expect("{", "OptEquations_1") ii2 := P_Equations() ii3 := expect("}", "OptEquations_1") #line 1323 "grammar.nw" ii2 #line 158000"generated code" } default : error("syntax error parsing OptEquations_1:\n\texpected '{'") } end procedure P_FetchSpec() local ii1, ii2 case token of { "fetch" : # FetchSpec : "fetch" FetchSpec_1 return { ii1 := expect("fetch", "FetchSpec") ii2 := P_FetchSpec_1() #line 1401 "grammar.nw" ii2 #line 159000"generated code" } "address" : # FetchSpec : "address" FetchSpec_2 return { ii1 := expect("address", "FetchSpec") ii2 := P_FetchSpec_2() #line 1405 "grammar.nw" ii2 #line 160000"generated code" } default : error("syntax error parsing FetchSpec:\n\texpected 'address' or 'fetch'") } end procedure P_FetchSpec_2() local ii1, ii2, ii3, ii4 case token of { "_" | IDENT : # FetchSpec_2 : Add "using" String return { ii1 := P_Add() ii2 := expect("using", "FetchSpec_2") ii3 := P_String() #line 1401 "grammar.nw" newfetch(ii1, ii3, 'ao') #line 161000"generated code" } "type" : # FetchSpec_2 : "type" "is" String return { ii1 := expect("type", "FetchSpec_2") ii2 := expect("is", "FetchSpec_2") ii3 := P_String() #line 1402 "grammar.nw" newfetch(ii1, ii3, '') #line 162000"generated code" } "to" : # FetchSpec_2 : "to" IntIdent "using" String return { ii1 := expect("to", "FetchSpec_2") ii2 := P_IntIdent() ii3 := expect("using", "FetchSpec_2") ii4 := P_String() #line 1403 "grammar.nw" newfetch(ii2, ii4, 'a') #line 163000"generated code" } default : error("syntax error parsing FetchSpec_2") } end procedure P_FetchSpec_1() local ii1, ii2, ii3 case token of { INT : # FetchSpec_1 : INT "using" String return { ii1 := expect(INT, "FetchSpec_1") ii2 := expect("using", "FetchSpec_1") ii3 := P_String() #line 1398 "grammar.nw" newfetch(ii1, ii3, 'a') #line 164000"generated code" } "any" : # FetchSpec_1 : "any" "using" String return { ii1 := expect("any", "FetchSpec_1") ii2 := expect("using", "FetchSpec_1") ii3 := P_String() #line 1399 "grammar.nw" newfetch(ii1, ii3, 'aw') #line 165000"generated code" } default : error("syntax error parsing FetchSpec_1:\n\texpected 'any' or INT") } end procedure P_Add() local ii1 case token of { "_" | IDENT : # Add : Ident return { ii1 := P_Ident() #line 1407 "grammar.nw" (ii1 == "add") | error("expected `add', `type', or `to'") #line 166000"generated code" } default : error("syntax error parsing Add:\n\texpected '_' or IDENT") } end procedure P_IntIdent() local ii1 case token of { "_" | IDENT : # IntIdent : Ident return { ii1 := P_Ident() #line 1408 "grammar.nw" (ii1 == "integer") | error("expected", image("integer")) #line 167000"generated code" } default : error("syntax error parsing IntIdent:\n\texpected '_' or IDENT") } end procedure P_AsmSpec() local ii1, ii2 case token of { "assembly" : # AsmSpec : "assembly" AsmSpec_1 return { ii1 := expect("assembly", "AsmSpec") ii2 := P_AsmSpec_1() #line 1550 "grammar.nw" ii2 #line 168000"generated code" } default : error("syntax error parsing AsmSpec:\n\texpected 'assembly'") } end procedure P_AsmSpec_1() local ii1, ii2, ii3 case token of { "operand" : # AsmSpec_1 : "operand" AsmSpec_1_1 return { ii1 := expect("operand", "AsmSpec_1") ii2 := P_AsmSpec_1_1() #line 1547 "grammar.nw" ii2 #line 169000"generated code" } "component" : # AsmSpec_1 : "component" AsmSpec_1_2 return { ii1 := expect("component", "AsmSpec_1") ii2 := P_AsmSpec_1_2() #line 1548 "grammar.nw" ii2 #line 170000"generated code" } "opcode" : # AsmSpec_1 : "opcode" AsmSpec_1_3 return { ii1 := expect("opcode", "AsmSpec_1") ii2 := P_AsmSpec_1_3() #line 1549 "grammar.nw" ii2 #line 171000"generated code" } "syntax" : # AsmSpec_1 : "syntax" AsmSpec_1_4 AsmSpec_1_5 return { ii1 := expect("syntax", "AsmSpec_1") ii2 := P_AsmSpec_1_4() ii3 := P_AsmSpec_1_5() #line 1550 "grammar.nw" [ii1, ii2, ii3] #line 172000"generated code" } default : error("syntax error parsing AsmSpec_1") } end procedure P_AsmSpec_1_5() case token of { "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # AsmSpec_1_5 : {AsmSpec_1_5_1} return { ii1 := [] while token == ("\"" | "_" | IDENT) do put(ii1, P_AsmSpec_1_5_1() ) ii1 } default : error("syntax error parsing AsmSpec_1_5") } end procedure P_AsmSpec_1_5_1() local ii1 case token of { "\"" | "_" | IDENT : # AsmSpec_1_5_1 : AsmSyntax return { ii1 := P_AsmSyntax() #line 1549 "grammar.nw" see_newline() #line 173000"generated code" } default : error("syntax error parsing AsmSpec_1_5_1:\n\texpected '\'', '_', or IDENT") } end procedure P_AsmSpec_1_4() case token of { "\"" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # AsmSpec_1_4 : return { #line 1549 "grammar.nw" see_newline() #line 174000"generated code" } default : error("syntax error parsing AsmSpec_1_4") } end procedure P_AsmSpec_1_3() case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | "{" | "|" | IDENT | INT | WHITESPACE | EOF : # AsmSpec_1_3 : {AsmSpec_1_3_1} return { ii1 := [] while token == ("!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | IDENT | INT | WHITESPACE) do put(ii1, P_AsmSpec_1_3_1() ) ii1 } default : error("syntax error parsing AsmSpec_1_3") } end procedure P_AsmSpec_1_3_1() local ii1, ii2, ii3 case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | IDENT | INT | WHITESPACE : # AsmSpec_1_3_1 : Globbing "is" GlobTarget return { ii1 := P_Globbing() ii2 := expect("is", "AsmSpec_1_3_1") ii3 := P_GlobTarget() #line 1548 "grammar.nw" asmopcode (ii1, ii3, 1) #line 175000"generated code" } default : error("syntax error parsing AsmSpec_1_3_1") } end procedure P_AsmSpec_1_2() case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | "{" | "|" | IDENT | INT | WHITESPACE | EOF : # AsmSpec_1_2 : {AsmSpec_1_2_1} return { ii1 := [] while token == ("!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | IDENT | INT | WHITESPACE) do put(ii1, P_AsmSpec_1_2_1() ) ii1 } default : error("syntax error parsing AsmSpec_1_2") } end procedure P_AsmSpec_1_2_1() local ii1, ii2, ii3 case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | IDENT | INT | WHITESPACE : # AsmSpec_1_2_1 : Globbing "is" GlobTarget return { ii1 := P_Globbing() ii2 := expect("is", "AsmSpec_1_2_1") ii3 := P_GlobTarget() #line 1547 "grammar.nw" asmopcode (ii1, ii3) #line 176000"generated code" } default : error("syntax error parsing AsmSpec_1_2_1") } end procedure P_AsmSpec_1_1() case token of { "[" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "wordsize" | IDENT | EOF : # AsmSpec_1_1 : {AsmSpec_1_1_1} return { ii1 := [] while token == ("[" | "_" | IDENT) do put(ii1, P_AsmSpec_1_1_1() ) ii1 } default : error("syntax error parsing AsmSpec_1_1") } end procedure P_AsmSpec_1_1_1() local ii1, ii2, ii3 case token of { "[" | "_" | IDENT : # AsmSpec_1_1_1 : IdentBinding "is" OperandSyntaxSpec return { ii1 := P_IdentBinding() ii2 := expect("is", "AsmSpec_1_1_1") ii3 := P_OperandSyntaxSpec() #line 1546 "grammar.nw" every asmoperand(!ii1, ii3[1], ii3[2]) #line 177000"generated code" } default : error("syntax error parsing AsmSpec_1_1_1:\n\texpected '[', '_', or IDENT") } end procedure P_OperandSyntaxSpec() local ii1, ii2 case token of { "\"" : # OperandSyntaxSpec : String OperandSyntaxSpec_1 return { ii1 := P_String() ii2 := P_OperandSyntaxSpec_1() #line 1669 "grammar.nw" [ii1, ii2] #line 178000"generated code" } "field" | "names" | "sparse" : # OperandSyntaxSpec : OperandNameSpec return { ii1 := P_OperandNameSpec() #line 1670 "grammar.nw" ["%s", ii1] #line 179000"generated code" } default : error("syntax error parsing OperandSyntaxSpec") } end procedure P_OperandSyntaxSpec_1() case token of { "[" | "_" | "address" | "assembly" | "bit" | "constructors" | "discard" | "fetch" | "fieldinfo" | "fields" | "keep" | "patterns" | "pc_unit_bits" | "placeholder" | "relocatable" | "using" | "wordsize" | IDENT | EOF : # OperandSyntaxSpec_1 : [OperandSyntaxSpec_1_1] return { ii1 := &null if token == ("using") then ii1 := ( P_OperandSyntaxSpec_1_1() ) ii1 } default : error("syntax error parsing OperandSyntaxSpec_1") } end procedure P_OperandSyntaxSpec_1_1() local ii1, ii2 case token of { "using" : # OperandSyntaxSpec_1_1 : "using" OperandNameSpec return { ii1 := expect("using", "OperandSyntaxSpec_1_1") ii2 := P_OperandNameSpec() #line 1669 "grammar.nw" ii2 #line 180000"generated code" } default : error("syntax error parsing OperandSyntaxSpec_1_1:\n\texpected 'using'") } end procedure P_OperandNameSpec() local ii1, ii2 case token of { "names" | "sparse" : # OperandNameSpec : NameTable return P_NameTable() "field" : # OperandNameSpec : "field" Ident return { ii1 := expect("field", "OperandNameSpec") ii2 := P_Ident() #line 1673 "grammar.nw" lookuptype(ii2, "field") #line 181000"generated code" } default : error("syntax error parsing OperandNameSpec:\n\texpected 'field', 'names', or 'sparse'") } end procedure P_AsmSyntax() local ii1, ii2, ii3 case token of { "\"" | "_" | IDENT : # AsmSyntax : Opcode Operands NEWLINE return { ii1 := P_Opcode() ii2 := P_Operands() ii3 := expect(NEWLINE, "AsmSyntax") #line 1720 "grammar.nw" every set_asmsyntax(is_constructor(explode_names(ii1), warning), ii2) #line 182000"generated code" } default : error("syntax error parsing AsmSyntax:\n\texpected '\'', '_', or IDENT") } end procedure P_Globbing() local ii1, ii2, ii3, ii4 case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | IDENT | INT | WHITESPACE : # Globbing : SeeWhite GlobPattern StopWhite White return { ii1 := P_SeeWhite() ii2 := P_GlobPattern() ii3 := P_StopWhite() ii4 := P_White() #line 1769 "grammar.nw" ii2 #line 183000"generated code" } default : error("syntax error parsing Globbing") } end procedure P_GlobPattern() local ii1 case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | "}" | IDENT | INT | WHITESPACE : # GlobPattern : GlobPattern_1 return { ii1 := P_GlobPattern_1() #line 1771 "grammar.nw" number_braces(cat_adjacent_strings(ii1)) #line 184000"generated code" } default : error("syntax error parsing GlobPattern") } end procedure P_GlobPattern_1() case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | "}" | IDENT | INT | WHITESPACE : # GlobPattern_1 : {GlobPattern_1_1} return { ii1 := [] while token == ("!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | IDENT | INT) do put(ii1, P_GlobPattern_1_1() ) ii1 } default : error("syntax error parsing GlobPattern_1") } end procedure P_GlobPattern_1_1() case token of { "*" | "{" : # GlobPattern_1_1 : GlobAlternatives return P_GlobAlternatives() "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "|" | INT : # GlobPattern_1_1 : Literal return P_Literal() "_" | IDENT : # GlobPattern_1_1 : Ident return P_Ident() default : error("syntax error parsing GlobPattern_1_1") } end procedure P_GlobAlternatives() local ii1, ii2, ii3, ii4 case token of { "{" : # GlobAlternatives : "{" GlobPattern GlobAlternatives_1 "}" return { ii1 := expect("{", "GlobAlternatives") ii2 := P_GlobPattern() ii3 := P_GlobAlternatives_1() ii4 := expect("}", "GlobAlternatives") #line 1772 "grammar.nw" glob_any(push(ii3, ii2)) #line 185000"generated code" } "*" : # GlobAlternatives : "*" return { ii1 := expect("*", "GlobAlternatives") #line 1773 "grammar.nw" the_glob_wildcard #line 186000"generated code" } default : error("syntax error parsing GlobAlternatives:\n\texpected '*' or '{'") } end procedure P_GlobAlternatives_1() case token of { "," | "}" : # GlobAlternatives_1 : {GlobAlternatives_1_1} return { ii1 := [] while token == (",") do put(ii1, P_GlobAlternatives_1_1() ) ii1 } default : error("syntax error parsing GlobAlternatives_1:\n\texpected ',' or '}'") } end procedure P_GlobAlternatives_1_1() local ii1, ii2 case token of { "," : # GlobAlternatives_1_1 : "," GlobPattern return { ii1 := expect(",", "GlobAlternatives_1_1") ii2 := P_GlobPattern() #line 1772 "grammar.nw" ii2 #line 187000"generated code" } default : error("syntax error parsing GlobAlternatives_1_1:\n\texpected ','") } end procedure P_GlobTarget() local ii1, ii2, ii3, ii4 case token of { "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | "}" | IDENT | INT | WHITESPACE : # GlobTarget : SeeWhite GlobTargets StopWhite White return { ii1 := P_SeeWhite() ii2 := P_GlobTargets() ii3 := P_StopWhite() ii4 := P_White() #line 1776 "grammar.nw" ii2 #line 188000"generated code" } default : error("syntax error parsing GlobTarget") } end procedure P_GlobTargets() local ii1 case token of { "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | "}" | IDENT | INT | WHITESPACE : # GlobTargets : GlobTargets_1 return { ii1 := P_GlobTargets_1() #line 1778 "grammar.nw" cat_adjacent_strings(ii1) #line 189000"generated code" } default : error("syntax error parsing GlobTargets") } end procedure P_GlobTargets_1() case token of { "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | "}" | IDENT | INT | WHITESPACE : # GlobTargets_1 : {GlobTargets_1_1} return { ii1 := [] while token == ("!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | "}" | IDENT | INT) do put(ii1, P_GlobTargets_1_1() ) ii1 } default : error("syntax error parsing GlobTargets_1") } end procedure P_GlobTargets_1_1() case token of { "$" : # GlobTargets_1_1 : GlobTargetSpecial return P_GlobTargetSpecial() "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "{" | "|" | "}" | IDENT | INT : # GlobTargets_1_1 : GlobTargetLiteral return P_GlobTargetLiteral() default : error("syntax error parsing GlobTargets_1_1") } end procedure P_GlobTargetSpecial() local ii1, ii2 case token of { "$" : # GlobTargetSpecial : "$" GlobTargetSpecial_1 return { ii1 := expect("$", "GlobTargetSpecial") ii2 := P_GlobTargetSpecial_1() #line 1780 "grammar.nw" ii2 #line 190000"generated code" } default : error("syntax error parsing GlobTargetSpecial:\n\texpected '$'") } end procedure P_GlobTargetSpecial_1() local ii1 case token of { "'" | INT : # GlobTargetSpecial_1 : Integer return { ii1 := P_Integer() #line 1779 "grammar.nw" glob_dollar(ii1) #line 191000"generated code" } "$" : # GlobTargetSpecial_1 : "$" return { ii1 := expect("$", "GlobTargetSpecial_1") #line 1779 "grammar.nw" ii1 #line 192000"generated code" } default : error("syntax error parsing GlobTargetSpecial_1:\n\texpected '$', ''', or INT") } end procedure P_GlobTargetLiteral() local ii1 case token of { "!=" | "#" | "%" | "&" | "'" | "(" | ")" | "+" | "-" | "/" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "|" | INT : # GlobTargetLiteral : Literal return P_Literal() "_" | IDENT : # GlobTargetLiteral : Ident return P_Ident() "*" : # GlobTargetLiteral : "*" return { ii1 := expect("*", "GlobTargetLiteral") #line 1781 "grammar.nw" ii1 #line 193000"generated code" } "{" : # GlobTargetLiteral : "{" return { ii1 := expect("{", "GlobTargetLiteral") #line 1781 "grammar.nw" ii1 #line 194000"generated code" } "}" : # GlobTargetLiteral : "}" return { ii1 := expect("}", "GlobTargetLiteral") #line 1781 "grammar.nw" ii1 #line 195000"generated code" } "," : # GlobTargetLiteral : "," return { ii1 := expect(",", "GlobTargetLiteral") #line 1781 "grammar.nw" ii1 #line 196000"generated code" } default : error("syntax error parsing GlobTargetLiteral") } end procedure P_Ident() local ii1 case token of { IDENT : # Ident : IDENT return { ii1 := expect(IDENT, "Ident") #line 1804 "grammar.nw" ii1 #line 197000"generated code" } "_" : # Ident : "_" return { ii1 := expect("_", "Ident") #line 1804 "grammar.nw" ii1 #line 198000"generated code" } default : error("syntax error parsing Ident:\n\texpected '_' or IDENT") } end procedure P_String() local ii1 case token of { "\"" : # String : "\"" return { ii1 := expect("\"", "String") #line 1805 "grammar.nw" ii1 #line 199000"generated code" } default : error("syntax error parsing String:\n\texpected '\''") } end procedure P_Integer() local ii1 case token of { INT : # Integer : INT return { ii1 := expect(INT, "Integer") #line 1806 "grammar.nw" ii1 #line 200000"generated code" } "'" : # Integer : "'" return { ii1 := expect("'", "Integer") #line 1806 "grammar.nw" ord(ii1) #line 201000"generated code" } default : error("syntax error parsing Integer:\n\texpected ''' or INT") } end procedure P_White() local ii1 case token of { WHITESPACE : # White : WHITESPACE return { ii1 := expect(WHITESPACE, "White") #line 1807 "grammar.nw" ii1 #line 202000"generated code" } default : error("syntax error parsing White:\n\texpected WHITESPACE") } end procedure P_SeeWhite() case token of { "!" | "!=" | "#" | "$" | "%" | "&" | "'" | "(" | ")" | "*" | "+" | "," | "-" | "/" | ":" | ";" | "<" | "<=" | "=" | "=>" | ">" | ">=" | "@" | "[" | "\"" | "]" | "_" | "address" | "is" | "when" | "{" | "|" | "}" | IDENT | INT | NEWLINE | WHITESPACE : # SeeWhite : return { #line 1808 "grammar.nw" see_whitespace() #line 203000"generated code" } default : error("syntax error parsing SeeWhite") } end procedure P_StopWhite() case token of { ":" | "is" | "when" | "{" | NEWLINE | WHITESPACE : # StopWhite : return { #line 1809 "grammar.nw" ignore_whitespace() #line 204000"generated code" } default : error("syntax error parsing StopWhite") } end #line 13 "grammar.nw" global symtab # table of top-level symbols global globals # top-level environment global equivclasses # list of equivalence classes of fields global constructors # table mapping constructor name to Stype global conslist # list of all constructors ever defined global instructionctype # the type of instruction constructors global bit_zero_is_lsb # non-null if bits are numbered with 0 == least significant global vanishing_latent_patlabel # should vanish global fieldname_literals, operands_and_ids, warned_literals # find conflicts global all_types # list of all possible constructor types, in order #line 24 "grammar.nw" procedure init_parser() every symtab | constructors := table() globals := [symtab] every unchecked_fields | guaranteed_fields := set() every fieldname_literals | operands_and_ids | warned_literals := set() every conslist | equivclasses | all_types := [] bit_zero_is_lsb := 1 vanishing_latent_patlabel := latent_patlabel() #line 367 "grammar.nw" wordsize := 32 #line 1087 "grammar.nw" the_relocatable := relocatable() #line 1768 "grammar.nw" the_glob_wildcard := glob_wildcard() #line 33 "grammar.nw" end #line 65 "grammar.nw" procedure kept_constructors(constype) local thelist thelist := (\constype).members | conslist suspend 1(c := !thelist, constructors[c.name] === c) end #line 149 "grammar.nw" procedure newfield(name, lo, hi) return (/symtab[name] := field(name, lo, hi)) | deferror("Field", image(name)) end #line 365 "grammar.nw" global wordsize # word size of the machine the application runs on #line 384 "grammar.nw" global patlhs # hold lhs for later action #line 479 "grammar.nw" record colon_mark(x) procedure colons_to_labels(l) every i := 1 to *l & type(l[i]) == "colon_mark" do { l[i] := l[i].x # strip out tag (l[i-1] := undo_identifier_syntax(l[i-1])) | error("Colon must be preceded by an identifier") } return l end procedure undo_identifier_syntax(seq) if type(seq) == "Pand" & *seq.patterns = 1 & con := seq.patterns[1] & type(con) == "Pident" then return Plabel(con.name) end #line 499 "grammar.nw" global atomicid #line 503 "grammar.nw" record Por (patterns) # disjunction record Pseq(patterns) # sequence record Pand(patterns) # conjunction record Pcon(name, relop, value) # constraint on field record Pident(name) # identifier standing for a pattern record Plabel(name) # pattern label record Papp(cons, args) # constructor applied to arguments # (args are AppExprs) record Plist(patterns) # list of patterns in square brackets #line 621 "grammar.nw" procedure explode_apps(opcode, args, rho) l := [] every c := explode_names(opcode, rho) do { put(l, Papp(cons_named(c), args)) } return if *l = 1 then l[1] else Por(l) end #line 685 "grammar.nw" record Glist(values) procedure Gfor(lo, hi, cols) local l, r l := [] r := (hi - lo) / cols every put(l, lo + (0 to r - 1) + r * (0 to cols - 1)) return Glist(l) end #line 698 "grammar.nw" procedure patbinding(id, ast) local p #line 722 "grammar.nw" case type(id) of { "string" : verbose("Pattern ", id) "list" : verbose(*id, " patterns") } #line 701 "grammar.nw" p := pnf(ast, globals) #line 717 "grammar.nw" case type(p) of { "pattern" : insist_global_pattern(p) "list" : every insist_global_pattern(!p) } #line 703 "grammar.nw" case type(id) || "," || type(p) of { "string,pattern" : patbind(id, p, globals) "list,list" : if *id = *p then while patbind(get(id), get(p), globals) else error("identifier list/generator length mismatch: ", *id, " vs ", *p) "string,list" : error("generator must be bound to an identifier list") "list,pattern" : error("identifier list must be bound to a generator") default : impossible("pattern binding") } return end #line 1002 "grammar.nw" record literal(s) # holds string or list to be emitted literally #line 1007 "grammar.nw" record input(name, meaning) # input name and meaning #line 1129 "grammar.nw" procedure reversetrailing(c) local i suspend *&subject + 1 i := *&subject while any(c, &subject, 0 < i) do { suspend i; i -:= 1 } end #line 1201 "grammar.nw" procedure has_app_or_literal_f(e) return type(e) == ("Eapp"|"literal") end procedure has_app_or_literal(e) suspend expwalk(e, has_app_or_literal_f) end #line 1239 "grammar.nw" record SyntaxRange(bits, bang) #line 1307 "grammar.nw" global matching_stmts, codeheader #line 196 "grammar.nw" global bit_numbering_set, bit_numbering_used #line 763 "grammar.nw" procedure process_operands(ops) if type(ops[-1]) == "literal" & ops[-1].s ? (white(), pos(0)) then pull(ops) # discard trailing white space l := [] every x := !ops do if type(x) == "literal" & type(l[-1]) == "literal" then l[-1].s ||:= x.s else put(l, x) return l end #line 1062 "grammar.nw" procedure name_to_input(name, bang) i := input(name, if name ? type(ct := symtab[tab(reversetrailing('0123456789_'))]) == "constype" then mark_ct_as_used(ct) else case type(x := symtab[name]) of { "field" : if /bang then x else fwidth(x) "null" : { #line 1079 "grammar.nw" \bang | warning("Use ", name, "! for signed inputs --- future versions will require it") #line 1068 "grammar.nw" ; x } "relocatable" : "reloc" "constype" : impossible("missed first-round search for constype") default : typeerror(x, "free variable, field, or constructor input", name, globals) }) /bang | type(i.meaning) == ("integer"|"null"|"string") | typeerror(i.meaning, "field or integer (to be sign-extended)", name, globals) return i end #line 1084 "grammar.nw" record relocatable() # type of a name that means relocatable address global the_relocatable # we only need one... #line 1092 "grammar.nw" procedure make_relocatable(name) return (/symtab[name] := the_relocatable) | deferror("Relocatable name", image(name)) end #line 1109 "grammar.nw" global used_types procedure mark_ct_as_used(type) initial used_types := [] if /type.used := lineno then { put(used_types, type) #line 1119 "grammar.nw" t := table() every m := !type.members do t[m.name] := m t := sort(t) type.members := [] every put(type.members, (!t)[2]) #line 1115 "grammar.nw" } return type end #line 1289 "grammar.nw" procedure mkfactor(ident, range, ext) e := ident if \range then { e := mkslice(e, range[1], range[2]) w := e.n } if \ext then { /w := if type(f := symtab[ident]) == "field" then fwidth(f) else error("Can't sign-extend ", ident, " (not a field)") e := Ewiden(e, w) } return e end #line 1411 "grammar.nw" procedure newfetch(k, template, expected) #line 1472 "grammar.nw" c := '' template ? while tab(upto('%')) & ="%" do c := c ++ move(1) every x := !(expected -- c) do warning("expected %", x, " in template") #line 1413 "grammar.nw" return fetchtab[k] := template end #line 1763 "grammar.nw" record glob_any(alternatives, number) # braced list of alternate globbing patterns record glob_wildcard() global the_glob_wildcard # only need one value record glob_dollar(number) # $n on right-hand side #line 1785 "grammar.nw" procedure cat_adjacent_strings(l) m := [] every x := !l do if type(x) == "string" & type(m[-1]) == "string" then m[-1] ||:= x else put(m, x) return m end #================================================================ patterns.icn #line 21 "patterns.nw" record field(name, lo, hi, class) # field is bits lo..hi-1 (note NOT like input) record equivclass(name, fields, size, holder) # equivalence class of fields record pattern(disjuncts, name) # list of disjuncts, name of pattern record disjunct(sequents, name, conditions) # list of sequents, name of disjunct, # set of expressions record sequent(constraints, class) # list of contraints, class record patlabel(name, original_name, offset) # marks a location in a sequence record latent_patlabel(instance) # could become a patlabel or vanish record constraint(field, lo, hi) # constrain lo <= field.value < hi record fieldbinding(field, code) # code to compute field # invariant: constraints of the same sequent have distinct fields #line 43 "patterns.nw" procedure patbind(name, p, env) if name == "_" then return if *p.disjuncts = 1 & \p.disjuncts[1].name then p := pattern([disjunct(p.disjuncts[1].sequents)]) # copy w/o names add_to_rho(name, p, env) /p.name := name every d := !p.disjuncts & /d.name & d.name := name return end #line 116 "patterns.nw" procedure bind_and_remove_patlabel_names(p, keepname, free_vars_ok) if type(!(!p.disjuncts).sequents) == "patlabel" then &null else return p # prem opt q := pattern([], p.name) every put(q.disjuncts, barpm_d(!p.disjuncts, keepname, free_vars_ok)) return q end procedure barpm_d(d, keepname, free_vars_ok) t := table() every s := !d.sequents & type(s) == "patlabel" & \s.name do { (/t[s.name] := Epatlabel(s)) | error("Duplicate labels ", s.name, " in disjunct ", expimage(d)) if s.name == free_variables(d) then &null else \free_vars_ok | warning("Label ", s.name, " not used in disjunct ", expimage(d)) if /keepname then s.name := &null } return subst_tab(d, t) end procedure bind_patlabel_names(p, free_vars_ok) return bind_and_remove_patlabel_names(p, 1, free_vars_ok) end #line 140 "patterns.nw" procedure all_disjuncts_ids(p, idgen, warningmsg, warning2) local alld alld := set() every insert(alld, idgen(p.disjuncts[1])) every d := p.disjuncts[2 to *p.disjuncts] do { s := set() every i := idgen(d) do if member(alld, i) then insert(s, i) else #line 159 "patterns.nw" if \warningmsg then verbose(warningmsg, image(i), warning2) #line 151 "patterns.nw" if *s < *alld then every i := !alld & not member(s, i) do #line 159 "patterns.nw" if \warningmsg then verbose(warningmsg, image(i), warning2) #line 154 "patterns.nw" alld := s } return alld end #line 162 "patterns.nw" procedure patlabels_defined_in_all_disjuncts_of(p) s := all_disjuncts_ids(p, patlabels_defined_in) suspend !s end procedure patlabels_defined_in(d) suspend (seq := !d.sequents, type(seq) == "patlabel", seq.name) end #line 171 "patterns.nw" procedure set_patlabel_offsets(d) local offset offset := 0 every i := 1 to *d.sequents do case type (s := d.sequents[i]) of { "patlabel" : s.offset := bits_to_pcunits(offset) "sequent" : offset +:= s.class.size "dots_sequent" | "latent_patlabel" : &null default : impossible("sequent type") } return end #line 186 "patterns.nw" procedure freshen_patlabels(p) t := table() every l := subterms_matching(p, "patlabel") do /t[l] := copy(l) return if *t = 0 then p else subst_table_elements(p, t) end #line 196 "patterns.nw" procedure label2pattern(name) return pattern([disjunct([patlabel(name, name)])]) end #line 200 "patterns.nw" procedure latent_label2pattern(name) return pattern([disjunct([latent_patlabel(name)])]) end #line 204 "patterns.nw" procedure constraints2pattern(L[]) return pattern([disjunct([sequent(L, L[1].field.class)])]) end procedure conspat(f, op, val) local max, p, q type(val) == "integer" | impossible("non-integer constraint") max := 2 ^ fwidth(f) return case op of { "=" : constraints2pattern(constraint(f, val, val+1)) "<" : { if val <= 0 then warning("Impossible constraint ", f.name, " < ", val) if val > max then error("Constraint value too large in ", f.name, " < ",val) constraints2pattern(constraint(f, 0, val)) } "<=" : { if val >= max then error("Constraint value too large in ", f.name, " <= ", val) constraints2pattern(constraint(f, 0, val+1)) } ">" : { if val >= max-1 then warning("Impossible constraint ", f.name, " > ", val) if val < 0 then error("Constraint value too small in ", f.name, " > ",val) constraints2pattern(constraint(f, val+1, max)) } ">=" : { if val >= max then warning("Impossible constraint ", f.name, " >= ", val) if val < 0 then error("Constraint value too small in ", f.name, " >= ",val) constraints2pattern(constraint(f, val, max)) } "!=" : { if val > 0 then p := constraints2pattern(constraint(f, 0, val)) if val + 1 < max then q := constraints2pattern(constraint(f, val+1, max)) orpx(\p, \q) | \p | \q | impossible("lost inequality") } } end #line 242 "patterns.nw" procedure wildcard(class) # return a pattern that matches anything in class return constraints2pattern(constraint(f := class.fields[1], 0, 2^fwidth(f))) end #line 246 "patterns.nw" procedure epsilon() # pattern with shape of length 0 static e initial e := pattern([disjunct([], "epsilon")], "epsilon") return e end #line 259 "patterns.nw" record dots_sequent() # a very special sequent global dots procedure dots_pattern() static d initial d := pattern([disjunct([dots := dots_sequent()], "...")], "...") return d end #line 274 "patterns.nw" procedure andp(p1, p2) return mix(andpx, p1, p2) end procedure orp(p1, p2) return mix(orpx, p1, p2) end procedure seqp(p1, p2) return mix(seqpx, p1, p2) end #line 286 "patterns.nw" procedure mix(op, p1, p2) # can destroy its list argument because # lists are never saved or bound to names return case type(p1) || "," || type(p2) of { "pattern,pattern" : op(p1, p2) "list,pattern" : { every i := 1 to *p1 do p1[i] := op(p1[i], p2) ; p1 } "pattern,list" : { every i := 1 to *p2 do p2[i] := op(p1, p2[i]) ; p2 } "list,list" : { l := []; every put(l, op(!p1, !p2)); l } default : error("Invalid combination of patterns.") } end #line 297 "patterns.nw" procedure orpx(p1, p2) return pattern(p1.disjuncts ||| p2.disjuncts) end #line 309 "patterns.nw" procedure seqpx(p1, p2) local p, count1, count2 p := pattern([]) count1 := *p1.disjuncts count2 := *p2.disjuncts every d1 := !p1.disjuncts & d2 := !p2.disjuncts do { d := disjunct(concat_sequences(d1.sequents, d2.sequents), &null, conjoin_conditions(d1.conditions, d2.conditions)) if count1 > 1 | count2 > 1 then # d1 or d2 will be reused d := freshen_patlabels(d) put(p.disjuncts, d) } return p end #line 325 "patterns.nw" procedure bits_to_pcunits(n) if n % pc_unit_bits ~= 0 then error("pc is incremented in units of ", pc_unit_bits, ", but some pattern is ", n, " bits wide") else return n / pc_unit_bits end #line 333 "patterns.nw" procedure conjoin_conditions(c1, c2) return if /c1 then c2 else if /c2 then c1 else c1 ++ c2 end #line 341 "patterns.nw" procedure concat_sequences(s1, s2) local seq seq := if s1[-1] === dots & *s1 > 1 then if s2[1] === dots & *s2 > 1 then s1[1:-1] ||| s2[2:0] else s1[1:-1] ||| s2 else if s2[1] === dots & *s2 > 1 then s1 ||| s2[2:0] else s1 ||| s2 return seq end #line 360 "patterns.nw" procedure andpx(p1, p2) local keepname #line 374 "patterns.nw" if *p2.disjuncts = 1 & d := p2.disjuncts[1] & *d.sequents = 1 & s := d.sequents[1] & type(s) == "sequent" & *s.constraints = 1 & type(s.constraints[1]) == "fieldbinding" then keepname := p1.name #line 363 "patterns.nw" p := pattern([], keepname) every d1 := !p1.disjuncts & d2 := !p2.disjuncts do { put(p.disjuncts, d := not_contradictory( disjunct(merge_sequences(d1.sequents, d2.sequents), &null, conjoin_conditions(d1.conditions, d2.conditions)))) if \keepname then d.name := d1.name } return p end #line 391 "patterns.nw" procedure merge_sequences(l1, l2) local grab, first, add l1 := copy(l1) l2 := copy(l2) if (l1|l2)[1] === dots then if (l1|l2)[-1] === dots then #line 436 "patterns.nw" error("Illegal conjunction; dots on both left and right of (", sequenceimage(l1), ") & (", sequenceimage(l2), ")") #line 398 "patterns.nw" else { #line 383 "patterns.nw" grab := pull add := push first := -1 #line 398 "patterns.nw" } else { #line 387 "patterns.nw" grab := get add := put first := 1 #line 399 "patterns.nw" } l := [] #line 426 "patterns.nw" every ll := l1 | l2 do while type(ll[first]) == ("patlabel" | "latent_patlabel") do add(l, grab(ll)) #line 403 "patterns.nw" # invariant: initial elements, if present, are not labels while l1[first] ~=== dots & l2[first] ~=== dots do { s1 := grab(l1) s2 := grab(l2) if s1.class ~=== s2.class then #line 439 "patterns.nw" error("Shapes differ for &; left sequent from class `", s1.class.name, "'; right sequent from class `", s2.class.name, "', in\n\t(", expimage(s1), ") & (", expimage(s2), ")") #line 409 "patterns.nw" else add(l, x := sequent(merge_constraints(s1.constraints, s2.constraints), s1.class)) #line 426 "patterns.nw" every ll := l1 | l2 do while type(ll[first]) == ("patlabel" | "latent_patlabel") do add(l, grab(ll)) #line 412 "patterns.nw" } # invariant: initial elements, if present, are not labels if l1[first] === dots then while add(l, dots ~=== grab(l2)) else if l2[first] === dots then while add(l, dots ~=== grab(l1)) else if l1[first] then #line 430 "patterns.nw" error("Shapes differ for &; right-hand sequence (", sequenceimage(l2), ") too short to conjoin with (", sequenceimage(l1), ")") #line 420 "patterns.nw" else if l2[first] then #line 433 "patterns.nw" error("Shapes differ for &; left-hand sequence (", sequenceimage(l1), ") too short to conjoin with (", sequenceimage(l2), ")") #line 422 "patterns.nw" # else they're an exact match; do nothing return l end #line 446 "patterns.nw" procedure merge_constraints(l1, l2) local c1, c2, S1, S2, maxlo, minhi S1 := set(l1) S2 := set() every c2 := !l2 do if c1 := !S1 & c1.field === c2.field then { # doubly-constrained field if type(c1) == type(c2) == "constraint" then { delete(S1, c1) #line 462 "patterns.nw" maxlo := c1.lo < c2.lo | c1.lo minhi := c1.hi > c2.hi | c1.hi if maxlo >= minhi then maxlo := minhi := 0 # canonical impossible constraint insert(S2, constraint(c1.field, maxlo, minhi)) #line 455 "patterns.nw" } else #line 467 "patterns.nw" error("Code and constraint (or inconsistent code) for field `", c1.field.name, "\n\t", constraintimage(c1), "\n\t", constraintimage(c2)) #line 457 "patterns.nw" } else insert(S2, c2) return sort(S1 ++ S2) end #line 470 "patterns.nw" procedure strip_patlabels(s) if type(!s) == "patlabel" then &null else return s l := [] every put(l, 1(x := !s, type(x) ~== "patlabel")) return l end #line 529 "patterns.nw" procedure sanitize_for_output(seq, conditions) local fields, outconstraints #line 549 "patterns.nw" if type(seq) == "sequent" & c1 := !seq.constraints & c2 := !seq.constraints & c1 ~=== c2 & c1.field === c2.field & type(c1) ~== type(c2) then &null else return seq #line 532 "patterns.nw" warning("Sanitizing ", expimage(seq)) fields := set() outconstraints := [] # will be constraints of new sequent every insert(fields, (!seq.constraints).field) every f := !fields do { ((fb := !seq.constraints).field == f, type(fb) == "fieldbinding") | (fb := &null) ((rc := !seq.constraints).field == f, type(rc) == "constraint") | (rc := &null) if \fb & \rc then { put(outconstraints, fb) insert_constraint_conditions(conditions, rc, fb.code) } else { put(outconstraints, \fb | \rc) } } return sequent(outconstraints, seq.class) end #line 555 "patterns.nw" procedure insert_constraint_conditions(conditions, rc, code) every insert_condition(conditions, eqn( 0 < rc.lo, "<=", code) | eqn(2^fwidth(rc.field) > rc.hi, ">", code)) return end #line 571 "patterns.nw" procedure not_contradictory(d) if s := !d.sequents & type(s) == "sequent" & c := !s.constraints & type(c) == "constraint" & c.lo >= c.hi then fail else return d end #line 580 "patterns.nw" procedure eliminate_contradictions(p) return if d := !p.disjuncts & s := !d.sequents & type(s) == "sequent" & c := !s.constraints & type(c) == "constraint" & c.lo >= c.hi then {impossible("contradiction now eliminated at conjunction") #line 589 "patterns.nw" l := [] every d := !p.disjuncts do if s := !d.sequents & type(s) == "sequent" & c := !s.constraints & type(c) == "constraint" & c.lo >= c.hi then &null else put(l, d) pattern(l, p.name) #line 585 "patterns.nw" } else p end #line 602 "patterns.nw" procedure place_holder(d) local shape, class shape := shapeof(d) #line 612 "patterns.nw" if /(class := !shape).holder then error("No placeholder is defined for class ", class.name) #line 606 "patterns.nw" p := epsilon() every class := !shape do p := seqp(p, class.holder) *p.disjuncts = 1 | impossible("Some placeholder has multiple disjuncts") return p.disjuncts[1] end #line 616 "patterns.nw" procedure pattern_length(p) local shapes, class shapes := maplist(disjunct_length, p.disjuncts) *shapes > 0 | error("length of impossible pattern") if !shapes ~= shapes[1] then error("Length of pattern ", patimage(p), " is not fixed") return shapes[1] end #line 624 "patterns.nw" procedure disjunct_length(d) n := 0 every s := !d.sequents & type(s) == "sequent" do n +:= s.class.size return n end #line 631 "patterns.nw" procedure shapeof(d) l := [] every s := !d.sequents & type(s) == "sequent" do put(l, s.class) return l end #line 641 "patterns.nw" procedure insist_global_pattern(p) if d := !p.disjuncts & *\d.conditions > 0 then error(patimage(p), " cannot be used on the right-hand side; there are conditions") else if d := !p.disjuncts & type(s := !d.sequents) == "sequent" & type(!s.constraints) == "fieldbinding" then error(patimage(p), " cannot be used on the right-hand side; there are inputs") else if d := !p.disjuncts & type(s := !d.sequents) == "patlabel" & \s.name then error(patimage(p), " cannot be used on the right-hand side; there's a loose label") else return end #line 669 "patterns.nw" procedure pnf(p, rho, free_env) return eliminate_instances(pnf_recurse(p, rho, free_env)) end #line 678 "patterns.nw" procedure pnf_recurse(p, rho, free_env) x := case type(p) of { "pattern" : p "Pident" : project(x := lookup(p.name, rho), "pattern") | typeerror(x, "pattern or field operand", p.name, rho) # can never be a free identifier "Plabel" : label2pattern(p.name) "Pcon" : { f := lookuptype(p.name, "field", rho) # free identifiers in constraint are always OK #line 710 "patterns.nw" case type(p.value) of { "Glist" : { l := [] every put(l, conspat(f, p.relop, !p.value.values)) l } default : constraint_or_binding(f, p.relop, p.value, rho, free_env) } #line 688 "patterns.nw" } "Pand" : pnfreduce(andp, p.patterns, rho, free_env) "Por" : pnfreduce(orp, p.patterns, rho, free_env) "Pseq" : pnfreduce(seqp, p.patterns, rho, free_env) "Papp" : if (type(p.cons) == "list") then pnf_recurse(explode_apps(p.cons, p.args, rho), rho, free_env) else apply_constructor(p.cons, p.args, rho, free_env) "Plist" : maplist3(pnf_recurse, p.patterns, rho, free_env) default : impossible("pnf_recurse") } if \showpnf then PPxwrite(PPnew(&output), "pnf_recurse(", image(if type(p) == "Pident" then p.name else p), ") returns: $t${ $o", ppexpimage(x), "$b$}") return x end #line 724 "patterns.nw" procedure binding_subst_f(e, rho, free_env) return if type(e) == "string" then (if is_defined(e, rho) then project(lookup(e, rho), "integer") else new_binding_instance(e, e, "integer", \free_env) ) | typeerror(lookup(e, rho), "integer", e, rho) end #line 735 "patterns.nw" procedure constraint_or_binding(f, relop, val, rho, free_env) val := super_simplify(gsubst(val, binding_subst_f, fieldname_env_for(f) ||| rho, free_env)) val := constant(val) # might fail if expression not constant if type(val) == "integer" then return conspat(f, relop, val) else if relop == "=" then return constraints2pattern(fieldbinding(f, val)) else error("`", expimage(val), "' has free variables, ", "so the only permissible constraint is equality") end #line 750 "patterns.nw" record binding_instance(val, type) procedure new_binding_instance(name, val, type, env) if (/env[name] := binding_instance(val, type)) | env[name].type === type then return val else error(name, " was bound earlier as type ", expimage(env[name].type), " but it's used here as type ", expimage(type)) end #line 764 "patterns.nw" procedure pnfreduce(op, l, rho, free_env) r := &null every p := pnf_recurse(!l, rho, free_env) do r := op(\r, p) | p return r end #line 771 "patterns.nw" procedure equals_pc(e) return e === the_global_pc end #line 778 "patterns.nw" procedure pattern_free_variables(p) case type(p) of { "pattern" : fail # note free var of Pcon is field, not pattern "Pident" : return p.name "Plabel" : fail # name is a binding instance "Pcon" : suspend free_variables(p.value) "Pand" | "Por" | "Pseq" : suspend pattern_free_variables(!p.patterns) "Papp" : suspend free_variables(!p.args) "string" : return p "integer" : fail "literal" : fail default : impossible("pattern free variables") } end #line 796 "patterns.nw" procedure pattern_label_names(p) case type(p) of { "pattern" : fail "Pident" : fail "Plabel" : return p.name "Pcon" : fail "Pand" | "Por" | "Pseq" : suspend pattern_label_names(!p.patterns) "Papp" : fail "string" : fail "integer" : fail "literal" : fail default : impossible("pattern label names") } end #line 820 "patterns.nw" procedure constructors_applied_in(p) case type(p) of { "pattern" | "Pident" | "Plabel" | "Pcon" | "string" | "integer" | "literal" : fail "Pand" | "Por" | "Pseq" : suspend constructors_applied_in(!p.patterns) "Papp" : suspend (if type(p.cons) == "list" then constructors_applied_in(explode_apps(p.cons,p.args)) else p.cons) | constructors_applied_in( 1(a := !p.args, type(a) == ("Papp" | "Eapp"))) "Eapp" : suspend cons_named(p.f) | (a := !p.args, type(a) == "Eapp", constructors_applied_in(a)) default : impossible("pattern AST") } end #line 841 "patterns.nw" procedure bind_condition(p, condition) every bind_condition_d(!p.disjuncts, condition) return p end procedure bind_condition_d(d, condition) /d.conditions := set() insert_condition(d.conditions, condition) return d end #line 852 "patterns.nw" procedure freshen_disjuncts(p) return pattern(maplist(freshen_disjunct, p.disjuncts), p.name) end #====== link maplist procedure freshen_disjunct(d) d := copy(d) d.conditions := copy(d.conditions) return d end #================================================================== output.icn #line 7 "output.nw" global equivclasses, symtab procedure outspec(file) every c := !equivclasses do { writes(file, "fields(", c.size, ") ") every f := !c.fields do writes(file, fieldimage(f)) write(file) } outpatterndefs(file, w := set()) every c := kept_constructors() do write(file, "constructor ", c.name, " ", outinputs(c), " : " || (instructionctype ~=== c.type).name | "") write(file, "%%") end #line 22 "output.nw" procedure outinputs(cons) s := "(" p := "" every i := inputs_of(cons) do { s ||:= p || i.name p := ", " } return s || ")" end #line 33 "output.nw" procedure fieldimage(f) return f.name || " " || f.lo || ":" || f.hi || " " end #line 38 "output.nw" procedure outpatterndefs(file, written) /written := patnames() pats := sort(symtab) # first do patterns that don't depend on other patterns, then catch as catch can every pair := !pats & name := pair[1] & p := pair[2] & type(p) == "pattern" do { if not ((!p.disjuncts).name ~== name) then # doesn't depend on others outpatterndef(file, name, p, written) } every pair := !pats & type(pair[2]) == "pattern" do outpatterndef(file, pair[1], pair[2], written) return end #line 52 "output.nw" procedure outpatterndef(file, name, p, written) if not member(written, name) then { every d := !p.disjuncts & name ~== \d.name do outpatterndef(file, d.name, lookup(d.name), written) writes(file, "pattern ", name, " : ") write(file, patternimage(p, written)) insert(written, name) } return end #line 64 "output.nw" procedure outpattern(file, p, written) /written := patnames() return writes(file, patternimage(p, written)) end #line 69 "output.nw" procedure patnames() static s initial { s := set(); every insert(s, key(symtab)) } # cheat return s end #line 75 "output.nw" procedure patternimage(p, written) /written := emptyset return if member(written, p.name) then # temporary hack p.name else { l := []; every put(l, disjunctimage(!p.disjuncts, p.name)) if *l > 0 then commaseparate(l, " | ") else "" } end #line 85 "output.nw" #====== link commafy #line 87 "output.nw" procedure disjunctimage(d, name) return if \name == \d.name | /d.name then case type(d) of { "disjunct" : sequenceimage(d.sequents) "adisjunct" : if adalwaysmatches(d) then "" else commaseparate(maplist(constraintimage, d.aconstraints), " & ") default : impossible("disjunct type") } else d.name end #line 100 "output.nw" procedure sequenceimage(l) return if *l = 0 then "" else if l[1] === dots then "... " || sequenceimage(l[2:0]) else if l[-1] === dots then sequenceimage(l[1:-1]) || " ..." else commaseparate(maplist(sequentimage, l), "; ") end #line 107 "output.nw" procedure sequentimage(s) return if s === dots then impossible("image of dots") else if type(s) == ("patlabel" | "latent_patlabel") then expimage(s) else if *s.constraints = 0 then "" else commaseparate(maplist(constraintimage, s.constraints), " & ") end #line 114 "output.nw" procedure constraintimage(c) local bitcount s := "" case type(c) of { "constraint": { bitcount := fieldbitcount(c.field) if c.lo + 1 = c.hi then s ||:= patimage(c.field) || " == " || c.lo else if c.lo = 0 & c.hi = 2^bitcount then s ||:= "" else if c.lo >= c.hi then s ||:= "" else { if c.lo > 0 then s ||:= patimage(c.field) || " >= " || c.lo if c.lo > 0 & c.hi < 2^bitcount then s ||:= " & " if c.hi < 2^bitcount then s ||:= patimage(c.field) || " < " || c.hi } } "fieldbinding" : s ||:= patimage(c.field) || " = " || image(c.code) default : impossible("constraint type") } return s end #line 140 "output.nw" procedure fieldbitcount(f) return case type(f) of { "absolute_field" : fieldbitcount(f.field) "field" : fwidth(f) default : impossible("field type") } end #line 148 "output.nw" procedure patimage(v) return case type(v) of { "list" | "set" : "[" || commaseparate(maplist(patimage, v)) || "]" "matching_stmt" : "MATCH " || patimage(v.arms) || "ENDMATCH" "arm" : image(v.file) || ", line " || string(v.line) || ": " || patimage(v.pattern) || " => " || v.code "pattern" : commaseparate(maplist(patimage, v.disjuncts), " | ") "disjunct" : if *v.sequents = 0 then "epsilon" else commaseparate(maplist(patimage, v.sequents), "; ") "adisjunct": if *v.aconstraints = 0 then "" else commaseparate(maplist(patimage, v.aconstraints), " & ") "sequent" : if *v.constraints = 0 then "some " || v.class.name else commaseparate(maplist(patimage, v.constraints), " & ") "constraint" : stringininterval(patimage(v.field), v.lo, v.hi) "fieldbinding" : patimage(v.field) || " = " || image(v.code) "field" : v.name "absolute_field" : "{" || patimage(v.field) || " at " || v.offset || "}" default : image(v) } end #line 169 "output.nw" procedure stringininterval(name, lo, hi) local r, result if type(lo) == "set" then { r := sort(lo ++ hi) if *r = 0 then return "" result := "( " ; result ||:= stringininterval(name, get(r), get(r)) while result ||:= " | " || stringininterval(name, get(r), get(r)) return result || " )" } else if lo + 1 = hi then return name || " == " || fnum(lo) else return fnum(lo) || " <= " || name || " < " || fnum(hi) end #line 181 "output.nw" procedure fnum(n) n := string(n) | impossible("format") if *n < 2 then n := right(n, 2) return n end #line 189 "output.nw" procedure outtree(file, n, prefix, shownode) if /prefix then write(file, "TREE") if *n.children > 0 then { span := *patimage(n.field) + 14 every e := !n.children do outtree(file, e.node, (\prefix || " & " | " ") \ 1 || right(stringininterval(patimage(n.field), e.lo, e.hi),span), shownode) } else { if *n.cs.arms = 0 then write(file, \prefix | " ", " : NO MATCH") else every a := !n.cs.arms do write(file, (\prefix | " ANY? ")\1, " @", a.file, ":", a.line, " ", expimage(a.code)) } if /prefix then write(file, "END TREE\n") return end #line 209 "output.nw" procedure icontree(pp, n, prefix) local comma if /prefix then { PPxwrite(pp, " put(trees,$t$t") icontree(pp, n, " ") PPxwrite(pp, "$b$b)") } else if *n.children > 0 then { PPxwrites(pp, "treenode(${$t", image(n.field.field.name), ", ", n.field.offset, ", [$c") t := table() every e := !n.children do t[edgeleast(e.lo, e.hi)] := [edgestring(e.lo, e.hi), e.node] t := sort(t) comma := "" every e := (!t)[2] do { PPxwrites(pp, comma, "edge(${$t", image(e[1]), ", $o") icontree(pp, e[2], prefix) PPxwrites(pp, "$b$})") comma := if *e[2].children = 0 then ", $o" else ", $c" } PPxwrites(pp, prefix, "]$b$})") } else { if *n.cs.arms = 0 then PPwrites(pp, image("no match")) else { PPxwrites(pp, "[${$t") comma := "" every a := !n.cs.arms do { PPxwrites(pp, comma, "arm(${$t", image(a.file), ", ", a.line, ", ", image(if type(n.name) == "namearray" then naid(n.name) else n.name), ", $o") iconblastcode(pp, a.code) # if match(" F", a.code[1]) then { pushtrace(5); callfor(n, a) } PPxwrites(pp, "$b$})") comma := ", $o" } PPxwrites(pp, "$b$}]") } } return end procedure naid(x) static t initial t := table() /t[x] := "namearray " || (1+*t) return t[x] end procedure callfor(n, a) case type(n) of { "node" : callfor(n.name) } return n end procedure iconblastcode(pp, lines) PPxwrites(pp, "[${$t") c := "" every l := !lines do { PPxwrites(pp, c, image(l)) c := ", $o" } PPxwrites(pp, "$b$}]") return end #line 275 "output.nw" procedure edgeleast(lo, hi) return if type(lo) == "set" then sort(lo)[1] else lo end procedure edgestring(lo, hi) local r, result if type(lo) == "set" then { r := sort(lo ++ hi) if *r = 0 then return "" result := edgestring(get(r), get(r)) while result ||:= ", " || edgestring(get(r), get(r)) return result } else if lo + 1 = hi then return string(lo) else return string(lo) || "-" || string(hi-1) end #line 293 "output.nw" global pagesize procedure dotouttree(file, root) write(file, "digraph decisions {") write(file, " page=", image(pagesize), ";") write(file, " ratio=compress;") dotoutnode(file, root, table(), create(seq())) write(file, "}") end procedure dotoutnode(file, n, known, number) if /known[n] then { if *n.children > 0 then { if alt := alternates(n) then { writes(file, "N", known[n] := @number, " [label=\"") every i := 1 to *alt.constraints do { if i > 1 then writes(file, ",") writes(file, alt.constraints[i].field.field.name) writes(file, "@", 0 < alt.constraints[i].field.offset) } write(file, "\"];") every dotoutnode(file, alt.thennode | alt.elsenode, known, number) #line 348 "output.nw" s := "" every i := 1 to *alt.constraints do { if i > 1 then s ||:= "," c := alt.constraints[i] if *c.lo > 1 then s ||:= "..." else if ?c.lo + 1 = ?c.hi then s ||:= ?c.lo else s ||:= ?c.lo || "-" || (?c.hi - 1) } s := split10(s) #line 315 "output.nw" write(file, "N", known[n], " -> N", known[alt.thennode], " [label=", image(s), "];") write(file, "N", known[n], " -> N", known[alt.elsenode], " [label=\"else\"];") } else { write(file, "N", known[n] := @number, " [label=\"", n.field.field.name, "@" || (0 < n.field.offset) | "", "\"];") every e := !n.children do { dotoutnode(file, e.node, known, number) r := sort(e.lo ++ e.hi) lo := get(r) & hi := get(r) s := "" s ||:= if lo+1 = hi then lo else lo || "-" || (hi - 1) while lo := get(r) & hi := get(r) do s ||:= ", " || if lo+1 = hi then lo else lo || "-" || (hi - 1) write(file, "N", known[n], " -> N", known[e.node], " [label=", image(commaseparate(split10(s), "\n")), "];") } } } else if *n.cs.arms = 0 then write(file, "N", known[n] := @number, " [label=", image("NO MATCH"), "];") else { writes(file, "N", known[n] := @number, " [label=\"") # outpattern(file, n.cs.arms[1].original.pattern) writes(file, \n.cs.arms[1].original.pattern.name | "[" || n.cs.arms[1].original.line || "]") write(file, "\"];") } } return end #line 358 "output.nw" procedure split10(s) static N local k initial N := 18 if *s > N & find(", ", s) <= N then { every k := N >= find(", ", s) return s[1:k+1] || "\n" || split10(s[k+2:0]) # keep comma, drop space } else { return s } end #=================================================================== solve.icn #line 18 "solve.nw" procedure solve(be, inputspec) local value, constraints, fieldsknown, zeroes, balances if *be.eqns = 0 then #line 60 "solve.nw" return solution(table(), [], emptyset, emptyset) #line 20 "solve.nw" # common short cut value := table() # values of dependent variables constraints := [] # constraints to check zeroes := [] # expressions equal to zero pending := [] # pending equations we couldn't solve earlier every defined | used := set() # sets of idents defined and used debugs("# Inputs:"); every debugs(" ", expimage(!inputspec)); debug() inputs := copy(inputspec) insert(inputs, 1) # 1 is hack for finding dependent vars every x := !inputs do value[x] := term2table(x) every eq := !be.eqns do if eq.op == "=" then put(zeroes, subtract(eq.left, eq.right)) else put(constraints, eq) #line 199 "solve.nw" balances := copy(be.balances) baltab := table() every b := !balances & v := (!b.left | !b.right).v do { /baltab[v] := [] put(baltab[v], b) } balsused := set() newlyknown := sort(inputs) oldknown := set() #line 228 "solve.nw" while v := get(newlyknown) do if not member(oldknown, v) then { insert(oldknown, v) #line 237 "solve.nw" debug(image(v), " is newly known ") every vb := !\baltab[v] do if member(balsused, vb) then debug("%%%%% appears in (already used) balance ", balimage(vb)) else debug("!!!!! appears in another balance ", balimage(vb)) if not !\baltab[v] then debug (":-( doesn't appear in any balances") #line 232 "solve.nw" #line 246 "solve.nw" every vb := !\baltab[v] & not member(balsused, vb) & b := balance_completed(vb, value, inputs) do { insert(balsused, vb) tt := table() # used to substitute all balanced goodies at once every vv := (ii := !b.unknown).v & zz := term2table(subst_tab(ii.value, value, 1)) do { debug("=> balancing tells us ", vv, " = ", expimage(zz)) if computable(inputs, \value[vv]) then { #line 266 "solve.nw" if not values_known_equal(value[vv], zz) then { put(constraints, eqn(value[vv], "=", zz)) debug("# new constraint ", expimage(constraints[-1])) } #line 254 "solve.nw" } else { if \value[vv] then { #line 271 "solve.nw" put(zeroes, subtract(value[vv], zz)) value[vv] := zz #line 256 "solve.nw" } else { #line 274 "solve.nw" value[vv] := zz #line 149 "solve.nw" insert(defined, vv) if vv == free_variables(!zeroes | !pending | !value) then insert(used, vv) #line 258 "solve.nw" } tt[vv] := zz if computable(inputs, zz) then push(newlyknown, vv) } } every dsubst_tab(!zeroes | !pending | !value | !constraints, tt) } #line 233 "solve.nw" every v := key(value) & computable(inputs, value[v]) do push(newlyknown, v) } #line 36 "solve.nw" #line 79 "solve.nw" pending := [] # equations with unknowns but no unit coefficients while *zeroes > 0 do { while z := get(zeroes) do { every v := key(z) & z[v] = 0 do delete(z, v) debug("# new equation: ", expimage(z), " = 0") #line 346 "solve.nw" g := &null every g := gcd(g, !z) if \g > 1 then every !z /:= g #line 85 "solve.nw" if v := key(z) & type(v) == "string" & not member(inputs, v) & z[v] = (1 | -1) then { #line 136 "solve.nw" debug("# new dependent variable: ", expimage(v)) m := - z[v] # multiplier of 1 or -1 delete(z, v) every !z *:= m value[v] := z #line 145 "solve.nw" insert(defined, v) if v == free_variables(!zeroes | !pending | !value) then insert(used, v) #line 142 "solve.nw" every dsubst(!zeroes | !pending | !value | !constraints, v, z) debug("# value[", expimage(v), "] := ", expimage(z)) #line 87 "solve.nw" if computable(inputs, value[v]) then push(newlyknown, v) #line 228 "solve.nw" while v := get(newlyknown) do if not member(oldknown, v) then { insert(oldknown, v) #line 237 "solve.nw" debug(image(v), " is newly known ") every vb := !\baltab[v] do if member(balsused, vb) then debug("%%%%% appears in (already used) balance ", balimage(vb)) else debug("!!!!! appears in another balance ", balimage(vb)) if not !\baltab[v] then debug (":-( doesn't appear in any balances") #line 232 "solve.nw" #line 246 "solve.nw" every vb := !\baltab[v] & not member(balsused, vb) & b := balance_completed(vb, value, inputs) do { insert(balsused, vb) tt := table() # used to substitute all balanced goodies at once every vv := (ii := !b.unknown).v & zz := term2table(subst_tab(ii.value, value, 1)) do { debug("=> balancing tells us ", vv, " = ", expimage(zz)) if computable(inputs, \value[vv]) then { #line 266 "solve.nw" if not values_known_equal(value[vv], zz) then { put(constraints, eqn(value[vv], "=", zz)) debug("# new constraint ", expimage(constraints[-1])) } #line 254 "solve.nw" } else { if \value[vv] then { #line 271 "solve.nw" put(zeroes, subtract(value[vv], zz)) value[vv] := zz #line 256 "solve.nw" } else { #line 274 "solve.nw" value[vv] := zz #line 149 "solve.nw" insert(defined, vv) if vv == free_variables(!zeroes | !pending | !value) then insert(used, vv) #line 258 "solve.nw" } tt[vv] := zz if computable(inputs, zz) then push(newlyknown, vv) } } every dsubst_tab(!zeroes | !pending | !value | !constraints, tt) } #line 233 "solve.nw" every v := key(value) & computable(inputs, value[v]) do push(newlyknown, v) } #line 89 "solve.nw" while put(zeroes, get(pending)) } else if v := key(z) & not computable(inputs, v) then { debug("# no new dependent variable in ", expimage(z), " = 0") put(pending, z) } else if not values_known_equal(z, 0) then { debug("# new constraint ", expimage(z), " = 0") #line 321 "solve.nw" debug("#### sure hope ", expimage(z), " is satisfiable!!!") #line 96 "solve.nw" put(constraints, zero_to_constraint(z)) } } #line 103 "solve.nw" pendingpending := [] while z := get(pending) do if v := key(z) & type(v) == "string" & not member(inputs, v) then { m := -z[v] delete(z, v) if m < 0 then { m := -m; z := subtract(0, z) } # make m positive m ~= 1 | impossible("coefficient") #line 117 "solve.nw" every x | q | r := fresh_variable(v) put(balances, b := balance([balitem(x, n_times_q_plus_r(m, q, r))], [balitem(q, Ediv(x, m)), balitem(r, Emod(x, m))])) every /baltab[x | q | r] := []; every put(baltab[x | q | r], b) debug("New balance: ", balimage(b)) #line 111 "solve.nw" # now force x = z, v = q, r = 0 every put(zeroes, subtract(x, z) | subtract(v, q) | subtract(r, 0)) while put(zeroes, get(pendingpending) | get(pending)) } else put(pendingpending, z) #line 100 "solve.nw" } #line 341 "solve.nw" if *pending > 0 then { every write(&errout, "error: equation ", expimage(!pending), " = 0 is unusable") error("Can't solve equations; some are useless") } #line 37 "solve.nw" #line 335 "solve.nw" every debug("# ===> value[", expimage(k := key(value)), "] = ", expimage(value[k])) every debug("# ===> constrain ", expimage(!constraints)) #line 38 "solve.nw" #line 323 "solve.nw" if v := key(value) & not computable(inputs, value[v]) then { write(&errout, "Error! Incomplete solution for value[", expimage(v), "] = ", expimage(value[v])) every write(&errout, " value[", expimage(k := key(value)), "] = ", expimage(value[k])) error() } if v := key(value) & type(v) == "Eslice" & not member(value, v.x) then error("Solved for ", expimage(v), " but not for ", expimage(v.x)) if v := key(value) & type(v) == "Ewiden" & type(v.x) == "Eslice" & not member(value, v.x.x) then error("Solved for ", expimage(v), " but not for ", expimage(v.x.x)) #line 39 "solve.nw" #line 50 "solve.nw" answers := table() non_answer := inputs ## ++ fresh_vars (delete! matcher uses these!) every ident := key(value) & type(ident) == "string" & not member(non_answer, ident) do answers[ident] := simplify(value[ident]) # we think simplify is OK -- super definitely not OK! every insert(used, free_variables(!answers | !constraints)) every debug("# ===> answers[", expimage(k := key(answers)), "] = ", expimage(answers[k])) #line 338 "solve.nw" debugs("# defined:"); every debugs(" ", !defined); debug() debugs("# used:"); every debugs(" ", !used); debug() #line 58 "solve.nw" return solution(answers, simplify(constraints), defined, used) #line 40 "solve.nw" end #line 47 "solve.nw" record solution(answers, constraints, defined, used) #line 125 "solve.nw" procedure computable(inputs, val) if member(inputs, val) then return else if v := free_variables(val) & not member(inputs, v) then fail else return end #line 181 "solve.nw" record balance(left, right) # lists of balitem record balitem(v, value) # v is string, value is exp #line 193 "solve.nw" record kbalance(known, unknown) # lists of balitem #line 212 "solve.nw" procedure balance_completed(bal, value, inputs) local vl, vr if vl := (!bal.left).v & not computable(inputs, \value[vl]) then if vr := (!bal.right).v & not computable(inputs, \value[vr]) then { debug("Balance not completed; ", vl, " = ", expimage(\value[vl]) | "???", " unknown on left and ", vr, " = ", expimage(\value[vr]) | "???", " unknown on right") fail } else return kbalance(bal.right, bal.left) else return kbalance(bal.left, bal.right) end #line 281 "solve.nw" procedure values_known_equal(e1, e2) if e1 === e2 then return e1 e1 := untable(e1) e2 := untable(e2) debug("vals ", expimage(e1), " ?= ", expimage(e2)) return case type(e1) == type(e2) of { "Ewiden" : e1.n = e2.n & exps_eq(e1.x, e2.x) "Eslice" : e1.n == e2.n & e1.lo == e2.lo & exps_eq(e1.x, e2.x) "table" : constant(subtract(e1, e2)) = 0 "integer" : e1 = e2 "string" : e1 == e2 default : e1 === e2 } end #line 299 "solve.nw" procedure subtract(l, r) z := table(0) l := term2table(l) r := term2table(r) every v := key(l) do z[v] := l[v] every v := key(r) do z[v] -:= r[v] return z end #line 312 "solve.nw" procedure zero_to_constraint(z) e := eqn(table(0), "=", table(0)) every k := key(z) do if z[k] > 0 then e.left[k] +:= z[k] else if z[k] < 0 then e.right[k] -:= z[k] return e end #line 350 "solve.nw" procedure gcd(m, n) # Knuth vol 1, p 4 if n < 0 then n := -n if /m then return n if m < n then m :=: n while r := 0 < (m % n) do {m := n; n := r} return n end #================================================================= balance.icn #line 65 "balance.nw" procedure balpass1(e, varaux, varmap #line 117 "balance.nw" , divs, mods #line 186 "balance.nw" , extensions, narrows #line 252 "balance.nw" , slices #line 65 "balance.nw" ) case type(e) of { #line 125 "balance.nw" "Ediv" : addnset(divs, var_for(e.x, varaux, varmap), e) "Emod" : addnset(mods, var_for(e.x, varaux, varmap), e) #line 188 "balance.nw" "Ewiden" : addnset(extensions, var_for(e.x, varaux, varmap), e) "Enarrows" : addnset(narrows, var_for(e.x, varaux, varmap), e) #line 254 "balance.nw" "Eslice" : { vx := var_for(e.x, varaux, varmap) /slices[vx] := set() insert(slices[vx], e) } #line 68 "balance.nw" } end #line 74 "balance.nw" procedure balance_eqns(eqns) local width if *eqns = 0 then return balanced_eqns(eqns, []) # common short cut debug ("$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$") pushtrace("BALANCE") every #line 115 "balance.nw" divs | mods | #line 184 "balance.nw" extensions | narrows | #line 250 "balance.nw" slices | #line 79 "balance.nw" varaux | varmap := table() expwalk(eqns, balpass1, varaux, varmap #line 117 "balance.nw" , divs, mods #line 186 "balance.nw" , extensions, narrows #line 252 "balance.nw" , slices #line 80 "balance.nw" ) balances := [] neweqns := copy(eqns) balmap := table() #line 142 "balance.nw" every vd := key(divs) & n := key(divs[vd]) do if ms := \(\mods[vd])[n] & qs := divs[vd, n] then { vq := var_for(!qs, varaux, varmap) vm := var_for(!ms, varaux, varmap) # vq = vd div n, vm = vd mod n, vd = vq * n + vm put(balances, balance([balitem(vd, n_times_q_plus_r(n, vq, vm))], [balitem(vq, Ediv(vd, n)), balitem(vm, Emod(vd, n))])) debug("==> New balance:", balimage(balances[-1])) put(neweqns, eqn(vd, "=", vd ~=== varmap[vd])) & debug("New balancing equation ", vd, " = ", expimage(varmap[vd])) every balmap[!qs] := vq every balmap[!ms] := vm } #line 197 "balance.nw" baln2w := table() every vn := key(extensions) & width := key(extensions[vn]) do { ws := extensions[vn, width] vw := var_for(!ws, varaux, varmap) | impossible("no extensions") # vw := vn! >< vn := vw[] if member(\baln2w[vn], vw) then { debug("DUPLICATE balance ", vn, " |><| ", vw) } else { #line 233 "balance.nw" /baln2w[vn] := set() insert(baln2w[vn], vw) #line 206 "balance.nw" put(balances, balance([balitem(vw, Ewiden (vn, width))], [balitem(vn, Enarrows(vw, width))])) debug("==> New balance:", balimage(balances[-1])) } put(neweqns, eqn(vn, "=", vn ~=== varmap[vn])) # could tighten (1-element table) ##### *ws # seems to be needed to work around bug in icont! every balmap[!ws] := vw } #line 215 "balance.nw" every vw := key(narrows) & width := key(narrows[vw]) do { ns := narrows[vw, width] vn := var_for(!ns, varaux, varmap) | impossible("no narrows") # vw := vn! >< vn := vw[] if member(\baln2w[vn], vw) then { debug("DUPLICATE balance ", vn, " |><| ", vw) } else { #line 233 "balance.nw" /baln2w[vn] := set() insert(baln2w[vn], vw) #line 223 "balance.nw" put(balances, balance([balitem(vw, Ewiden (vn, width))], [balitem(vn, Enarrows(vw, width))])) debug("==> New balance:", balimage(balances[-1])) } put(neweqns, eqn(vw, "=", vw ~=== varmap[vw])) # could tighten (1-element table) ##### *ns # seems to be needed to work around bug in icont! every balmap[!ns] := vn } baln2w := &null # make it possible to garbage-collect the memory #line 260 "balance.nw" every vx := key(slices) & xslices := slices[vx] do slicetree(vx, xslices, varaux, varmap, 0, bitsizeof(varmap[vx]), neweqns, balances, balmap) #line 85 "balance.nw" neweqns := gsubst(neweqns, balsub_f, balmap) poptrace() #line 367 "balance.nw" debug("Old equations:") every debug(" ", expimage(!eqns)) write(\baldebug, "After substituting:", envimage(balmap, "balmap")) debug("New equations:") every debug(" ", expimage(!neweqns)) debug() #line 88 "balance.nw" return balanced_eqns(neweqns, balances) end record balanced_eqns(eqns, balances) #line 92 "balance.nw" procedure balsub_f(e, balmap) return gsubst(\balmap[e], balsub_f, balmap) end #line 131 "balance.nw" procedure addnset(t, vx, e) /t[vx] := table() /t[vx, e.n] := set() return insert(t[vx, e.n], e) end #line 159 "balance.nw" procedure n_times_q_plus_r(d, q, r) local xtab xtab := table(0); xtab[q] := d; xtab[r] := 1 return xtab end #line 267 "balance.nw" procedure slicetree(vw, xslices, varaux, varmap, lo, hi, neweqns, balances, balmap) return do_slicetree(vw, copy(xslices), varaux, varmap, lo, hi, neweqns, balances, balmap) end procedure do_slicetree(vw, xslices, varaux, varmap, lo, hi, neweqns, balances, balmap) sibs := set() sum := table(0) leftbal := [] debug("Slicing ", expimage(sort(xslices)), " from ", lo, " to ", hi) while lo < hi do { kids := set() #line 307 "balance.nw" first := &null every slice := !xslices do if slice.lo < lo then fail else if slice.lo = lo & not ((\first).n > slice.n) then first := slice \first | fail #line 280 "balance.nw" insert(sibs, first) delete(xslices, first) firstv := var_for(first, varaux, varmap) sum[if lo = 0 then firstv else Eshift(firstv, lo)] +:= 1 put(leftbal, balitem(firstv, Eslice(vw, first.lo, first.n))) every slice := !xslices do if slice.lo + slice.n <= first.lo + first.n then { insert(kids, slice) delete(xslices, slice) } else if slice.lo < first.lo + first.n then error("Overlapping slices: ", expimage(subst_tab(first, varmap)), " and ", expimage(subst_tab(slice, varmap))) if *kids > 0 then do_slicetree(firstv, kids, varaux, varmap, first.lo, first.lo + first.n, neweqns, balances, balmap) lo +:= first.n } *xslices = 0 | impossible("leftover slices: ", expimage(subst_tab(sort(xslices), varmap))) put(balances, balance(leftbal, [balitem(vw, sum)])) debug("==> New balance:", balimage(balances[-1])) every slice := !sibs do balmap[slice] := var_for(slice, varaux, varmap) put(neweqns, eqn(vw, "=", vw ~=== varmap[vw])) & debug("New balancing equation ", vw, " = ", expimage(varmap[vw])) end #line 320 "balance.nw" global fresh_variables procedure fresh_variable(name) static n initial n := 0 insert(fresh_variables, s := fresh_base(name) || "#" || (n +:= 1)) return s end #line 328 "balance.nw" procedure fresh_base(name) static tail initial tail := '#' ++ &digits name ? return 1(tab(upto('#')|0), tab(many(tail)) | "", pos(0)) end #line 338 "balance.nw" procedure var_for(e, aux, var2exp) e := untableexp(e) if type(e) == "string" then return var2exp[e] := e /aux[type(e)] := table() t := aux[type(e)] return \t[e] | { every k := key(t) do if exps_eq(e, k) then { t[e] := t[k] break } var2exp[/t[e] := fresh_variable(free_variables(e) | "???")] := e t[e] } end #line 357 "balance.nw" procedure balimage(b) s := "" every ii := !b.left do s ||:= "\n <<< " || ii.v || " = " || expimage(ii.value) s ||:= "\n -----------------------" every ii := !b.right do s ||:= "\n >>> " || ii.v || " = " || expimage(ii.value) return s end #============================================================= environment.icn #line 13 "environment.nw" procedure is_defined(ident, rho) return ( #line 24 "environment.nw" { /rho := globals; \(!rho)[ident] } #line 14 "environment.nw" ) # parens handle newline from -L end procedure lookup(ident, rho) return ( #line 24 "environment.nw" { /rho := globals; \(!rho)[ident] } #line 17 "environment.nw" ) | error("`", ident, "' is undefined") end procedure lookuptype(ident, ty, rho) type(v := #line 24 "environment.nw" { /rho := globals; \(!rho)[ident] } #line 20 "environment.nw" ) == ty | typeerror(v, ty, ident, rho) return v end #line 26 "environment.nw" procedure add_to_rho(name, val, rho) #write("rho ", *rho, " ", name, " ", expimage(val)) add_to_frame(name, val, rho[1]) | impossible("bogus environment") return rho end procedure add_to_frame(name, val, frame) (/frame[name] := val) | deferror(name) return frame end #line 37 "environment.nw" procedure newscope(rho) return push(copy(rho), table()) end #line 44 "environment.nw" procedure extendscope(rho, frame) (type(frame) == "table" & type(rho) == "list") | impossible("rho extension") return push(copy(rho), frame) end #line 49 "environment.nw" procedure envimage(env, envname) local hidden /envname := "env" s := "" #line 63 "environment.nw" if type(env) == "list" then { t := table() every e := !env & ident := key(e) do (/t[ident] := e[ident]) | { /hidden := "" ; hidden ||:= pairimage(envname, ident, e[ident]) } env := t } #line 54 "environment.nw" if *env = 0 then s ||:= "\nEnvironment " || envname || " is empty" every p := !sort(env) do s ||:= pairimage(envname, p[1], p[2]) if \hidden then { s ||:= " -------- hidden --------\n" return s || hidden } else return s end #line 71 "environment.nw" procedure pairimage(envname, ident, v) return "\n " || envname || "[" || expimage(ident) ||"]" || " = " || case type(v) of { # "pattern" : " " || patternimage(v) # "field" : " " || fieldimage(v) "string" : image(v) default : expimage(v) } end #line 81 "environment.nw" procedure deferror(t, v) error(t, " ", v," is already defined.") end #line 85 "environment.nw" procedure typeerror(x, typename, ident, rho) error("Expected ", (\ident || " to be a " | ""), typename, "; found ", type(x), " ", expimage(x)) end #line 104 "environment.nw" record inject(pattern, integer, consop) procedure project(x, ty) return if type(x) == ty then x else if type(x) == "inject" then case ty of { "pattern" : \x.pattern "integer" : \x.integer "consop" : \x.consop } else if ty == "integer" then case type(x) of { "pattern" | "input" : fail exptypes() : x default : impossible("Bug in toolkit---can't use relocatable name", " in matching statement (was `rethink projection')") } end #=================================================================== debug.icn #line 2 "debug.nw" global debug, debugs, debugstack procedure wrerr(L[]) write ! ([&errout] ||| L) end procedure wrerrs(L[]) writes ! ([&errout] ||| L) end procedure nop() end procedure debug_on() /debugstack := [] every push(debugstack, debug | debugs) debug := wrerr debugs := wrerrs return end procedure debug_off() /debugstack := [] every push(debugstack, debug | debugs) debug := debugs := nop return end procedure debug_pop() every debugs | debug := pop(debugstack) return end #line 37 "debug.nw" procedure astimage(n) return case type(n) of { "pattern" : " " || patternimage(n) "Pident" : n.name "Pcon" : n.name || " " || n.relop || " " || astimage(n.value) "Pand" : commaseparate(astimage(n.patterns), " & ") "Por" : commaseparate(astimage(n.patterns), " | ") "Pseq" : #line 54 "debug.nw" if *n.patterns = 2 & n.patterns[1] === dots_pattern() then "... " || astimage(n.patterns[2]) else if *n.patterns = 2 & n.patterns[2] === dots_pattern() then astimage(n.patterns[1]) || " ..." else commaseparate(astimage(n.patterns), "; ") #line 45 "debug.nw" "Papp" : astimage(n.cons) || "(" || commaseparate(astimage(n.args)) || ")" "integer" : n "string" : n "Glist" : astimage(n.values) "list" : maplist(astimage, n) default : image(n) } end #line 61 "debug.nw" procedure solnimage(soln) s := envimage(soln.answers, "answers") || "\n" s ||:= "Uses " || commafy(maplist(expimage, sort(\soln.used))) || "\n" s ||:= "Defines " || commafy(maplist(expimage, sort(\soln.defined))) || "\n" s ||:= "(constraints: " || commafy(maplist(expimage, \soln.constraints)) || " )" return s end #line 69 "debug.nw" procedure injectimage(i) return "\tas pattern: " || expimage(i.pattern) || "\n" || "\tas integer: " || expimage(i.integer) || "\n" || "\tas consop: " || expimage(i.consop) || "\n" end #line 76 "debug.nw" procedure zeroimage(z) e := eqn(table(0), "=", table(0)) every k := key(z) do if z[k] > 0 then e.left[k] := z[k] else e.right[k] := -z[k] return expimage(e) end #==================================================================== code.icn #line 6 "code.nw" procedure unsignedval(f, val) constant(val) = 0 | return Cshift(val, "left", f.lo) end procedure signedval(f, val) constant(val) = 0 | return Cshift(Cmask(val, fwidth(f)), "left", f.lo) end #line 15 "code.nw" procedure init_tests() #line 21 "code.nw" fieldvals := table() fieldvals["field"] := unsignedval; fieldvals["extended"] := signedval #line 77 "code.nw" every fieldconds | fieldtests := table() fieldconds["field"] := unsignedcond; fieldconds["extended"] := signedcond fieldtests["field"] := unsignedtest; fieldtests["extended"] := signedtest #line 17 "code.nw" return end global fieldval #line 30 "code.nw" procedure unsignedtest(outfile, f, value, inputs) bits := fwidth(f) bits >= f.class.size | if v := constant(value) then v < 2^bits | error("spec forces ", f.name, " = ", v, ", which won't fit in ", bits, " bits") else { value := eqntoC(value, inputs, 1) write(outfile, indent(), "if ((unsigned)(", value, ") > ", mask(bits), ")\n", indent(2), "(*fail)(", image(f.name || " = %d won't fit in " || bits || " bits"), ", ", value, ");") } return end procedure unsignedcond(f, value, inputs) bits := fwidth(f) value := eqntoC(value, inputs, 1) return "((unsigned)(" || value || ") <= " || mask(bits) || ")" end #line 51 "code.nw" procedure signedtest(outfile, f, value, inputs) bits := fwidth(f) bits >= f.class.size | if v := constant(value) then -(2^(bits-1)) <= v < 2^(bits-1) | error("spec forces ", f.name, " = ", v, ", which won't fit in ", bits, " signed bits") else { value := eqntoC(value, inputs, 1) write(outfile, indent(), "if ((int)(", value, ") < -", tworaised(bits-1), " ||\n", indent(2), "(int)(", value, ") >= ", tworaised(bits-1), ")\n", indent(2), "(*fail)(", image(f.name || " = %d won't fit in "|| bits || " signed bits"), ", ", value, ");") } return end procedure signedcond(f, value, inputs) bits := fwidth(f) value := eqntoC(value, inputs, 1) return "((int)(" || value || ") >= -" || tworaised(bits-1) || " && \n" || "(int)(" || value || ") < " || tworaised(bits-1) || ")" end #line 75 "code.nw" global fieldconds, fieldtests #line 84 "code.nw" procedure testcondition(outfile, cond, inputs) write(outfile, indent(), "if (!(", eqntoC(cond, inputs, 1), "))\n", indent(2), "(*fail)(\"Condition ", expimage(cond), " not satisified.\");") end #line 91 "code.nw" global hex_prefix procedure mask(bits) return hex_prefix || ((0 ~= (2^(bits % 4) - 1)) | "") || repl("f", bits / 4) end procedure tworaised(bits) return hex_prefix || (2^(bits % 4)) || repl("0", bits / 4) end #line 99 "code.nw" procedure indent(n) initial /sindent := 2 return repl(" ", sindent + (\n | 0)) end #==================================================================== tree.icn #line 39 "tree.nw" record adisjunct(aconstraints, name, conditions, length, patlabelbindings) # list of absolute constraints, name, conds record absolute_field(field, offset) # used to make absolute constraints #line 51 "tree.nw" procedure anf(p) return pattern(maplist(anfd, p.disjuncts), p.name) end procedure anfd(d) local offset offset := 0 l := [] t := table() every s := !d.sequents do case type(s) of { "sequent" : { every put(l, aconstraint(!s.constraints, offset)) offset +:= s.class.size } "patlabel" : t[\s.name] := bits_to_pcunits(offset) "latent_patlabel" : &null default : impossible("sequent type") } a := adisjunct(l, d.name, d.conditions, offset, if *t > 0 then t else &null) return gsubst(a, Epatlabel_to_Epc_by_table, t, a) end #line 77 "tree.nw" procedure Epatlabel_to_Epc_by_table(x, t, a) if type(x) == "Epatlabel" then return if /x.l.name then Epatlabel_to_Epc(x) else { write(\mdebug, "====> RESORTED TO TABLE in ", expimage(x)) binop(the_global_pc, "+", \t[\x.l.name]) | impossible("in ", expimage(a), "---Label ", x.l.name, " not used yet, but is not in table:", envimage(t, "pattern_table")) } end #line 94 "tree.nw" procedure aconstraint(c, offset) return case type(c) of { "constraint" : constraint(afield(c.field, offset), c.lo, c.hi) "fieldbinding" : if x := constant(super_simplify(c.code)) then constraint(afield(c.field, offset), x, x+1) else fieldbinding(afield(c.field, offset), c.code) default : impossible("constraint type") } end #line 106 "tree.nw" procedure afield(f, offset) static tables initial tables := table() /tables[offset] := table() /tables[offset][f] := absolute_field(f, offset) return tables[offset][f] end #line 121 "tree.nw" record matching_stmt(arms,valcode,succptr,trailer) # case arms, code to compute value, id to set to end of p, trailing code record arm(file, line, pattern, eqns, soln, imp_soln, patlen, name, code, original) # line, file, original(pattern) are used for error reporting # These fields are the original contents: # pattern (in absoslute normal form) is pattern to match # eqns are equations given explicitly with arm (or else null) # name is identifier given in square brackets (or else null) # code is the list of code lines on the right hand side of the => #line 160 "tree.nw" record node(cs, children, field, offset, name, parent) # matching statement, list of edges to children, field chosen, pattern name # (name field used to support name operator, assigned only to leaves) record edge(node, lo, hi) # node pointed to and lo and hi interval of field for this edge #line 176 "tree.nw" procedure needs_splitting(n) local name if *n.cs.arms = 0 then fail if not guard_always_satisfied(n.cs.arms[1].imp_soln.constraints) then return # first arm can't always match. p := n.cs.arms[1].pattern name := \p.disjuncts[1].name | p.name every d := !p.disjuncts do { n := \d.name | p.name if n ~=== name then return # needs splitting if names or answers are different else if adalwaysmatches(d) then fail # always matches, needn't split } return # pattern doesn't always match -> split end #line 196 "tree.nw" procedure aalwaysmatches(p) return adalwaysmatches(!p.disjuncts) end procedure adalwaysmatches(d) if type(!d.aconstraints) == "constraint" then fail else return guard_always_satisfied(d.conditions) end #line 206 "tree.nw" procedure tree(cs) local armcount, arm, armname, nodename static heuristics initial { heuristics := [leafarms, childarms, nomatch, childdisjuncts, branchfactor] } root := node(copy(cs), []) # need empty children in case root not split work := [edge(root)] # work queue of edges (nodes) to be expanded while n := get(work).node do if (needs_splitting(n) & *(afields := mentions(n.cs)) > 0) then { #line 285 "tree.nw" afields := mentions(n.cs) *afields > 0 | impossible("internal node mentions no fields") candidates := table() every f := !afields do candidates[f] := split(n, f) #line 312 "tree.nw" if \tryall & \hdebug & *afields > 1 then { write(\hdebug, repl("=",10), " Splitting ", repl("=", 10)) every findmaxima(!heuristics, candidates, afields) do write(\hdebug) write(\hdebug, repl("=", 30), "\n") } #line 291 "tree.nw" *afields > 1 & write(\hdebug, "Choosing one of ", patimage(afields)) every h := !heuristics do { if *afields = 1 then break afields := findmaxima(h, candidates, afields) write(\hdebug, image(h), " chose ", patimage(afields)) } *afields > 0 | impossible("no fields") *afields = 1 | write(\hdebug, "tie among fields", patimage(afields), " near ", image(n.cs.arms[1].original.file), ", line ", n.cs.arms[1].original.line) work |||:= n.children := candidates[n.field := ?afields] *afields = 1 | write(\hdebug, "arbitrarily chose ", patimage(n.field)) #line 217 "tree.nw" } else { write(\sdebug, "Not splitting ", commaseparate(maplist(expimage, n.cs.arms), "\n")) armcount := *n.cs.arms trim_impossible_arms(n.cs) n.name := case *n.cs.arms of { 0 : &null # was "-NOMATCH-", caused bogus arrays default: get_nodename(n) } if \lc_pat_names then n.name := map(\n.name) if armcount > *n.cs.arms then write(\sdebug, "Trimmed node is ", commaseparate(maplist(expimage, n.cs.arms), "\n")) } return root end #line 248 "tree.nw" procedure get_nodename(n) local nodename, armname nodename := armname := &null every arm := !n.cs.arms do if (armname := \( #line 262 "tree.nw" if \arm.name then { \arm.pattern.disjuncts[1].name | \arm.pattern.name | &null # "-unnamed-" } else &null #line 252 "tree.nw" )) then { write(\sdebug, "[", image(arm.name),"] = ", image(armname), " for ",expimage(arm.pattern)) if (\nodename ~== armname) then nodename := #line 267 "tree.nw" (warning("ambiguous name for pattern arm at ", arm.original.file, ", line ", arm.original.line, ": ", commaseparate(maplist(expimage, n.cs.arms), "\nAre you trying to decode a synthetic instruction?\n")), &null) #line 257 "tree.nw" else nodename := armname } return nodename end #line 305 "tree.nw" procedure parentchoices(n) l := [] n := n.parent while \n do { push(l, n.field); n := n.parent } return l end #line 323 "tree.nw" procedure split(n, f) local vals,v,d,val,c,p,j,i,newd,cst,child,newp, xxx patterns := [] children := [] every put(patterns, (!n.cs.arms).pattern) r := intervals(patterns, f) #line 341 "tree.nw" writes(\sdebug, "Splitting ") outpattern(\sdebug, patterns[1]) every i := 2 to *patterns do { writes(\sdebug, " | "); outpattern(\sdebug, patterns[i])} write(\sdebug, " on ", f.field.name, " at ", f.offset) #line 332 "tree.nw" every i := 1 to *r - 1 do put(children, edge(node(apply(n.cs, f, r[i], r[i+1]),[]), r[i], r[i+1])) write(\sdebug, "Done splitting.\n") every (!children).node.parent := n return children end #line 353 "tree.nw" procedure apply(cs, f, lo, hi) local newarm result := copy(cs) result.arms := [] write(\sdebug, " Applying ", stringininterval(patimage(f), lo, hi)) every a := !cs.arms do { newarm := copy(a) put(result.arms, if newarm.pattern := pmatch(a.pattern, f, lo, hi) then newarm) } if *result.arms > 1 & aalwaysmatches(result.arms[1].pattern) & guard_always_satisfied(result.arms[1].imp_soln.constraints) then { # change 21 write(\sdebug, " Trimming results of apply to ", expimage(result.arms[1])) result.arms := [result.arms[1]] } return result end #line 374 "tree.nw" procedure pmatch(p, f, lo, hi) result := pattern([], p.name) every d := !p.disjuncts do if c := !d.aconstraints & c.field === f & type(c) == "constraint" then # disjunct mentions f if c.lo <= lo & hi <= c.hi then { # this constraint is matched newd := adisjunct([], d.name, d.conditions, d.length,d.patlabelbindings) every c := !d.aconstraints & c.field ~=== f do put(newd.aconstraints, c) put(result.disjuncts, newd) } else c.hi <= lo | c.lo >= hi | impossible("bad intervals") else # disjunct does not mention f put(result.disjuncts, d) #line 393 "tree.nw" if *result.disjuncts > 0 then writes(\sdebug, " ===> ") & outpattern(\sdebug, p) # else writes(\sdebug, " ") & outpattern(\sdebug, p) if *result.disjuncts > 0 then write(\sdebug, " matches") # else write(\sdebug, " does not match") #line 389 "tree.nw" if *result.disjuncts > 0 then return result end #line 404 "tree.nw" procedure findmaxima(h, candidates, afields) local max S := [] every f := !afields do { score := h(candidates[f], f) write(\hdebug,"Field ", patimage(f), " scores ", score, " on ", image(h)) /max := score - 1 if score > max then { max := score S := [f] } else if score = max then put(S, f) } return set(S) end #line 424 "tree.nw" # leafarms: prefer candidate with most arms that appear at leaf # nodes. Each original arm counted only once. # Not matching is also counted as an arm. procedure leafarms(children, f) arms := set() every n := (!children).node & *n.cs.arms > 0 do if not needs_splitting(n) then insert(arms, n.cs.arms[1].original) return *arms + if *(!children).node.cs.arms = 0 then 1 else 0 end #line 436 "tree.nw" # childarms: prefer the candidate with the fewest arms in children procedure childarms(children, f) sum := 0 every sum -:= *(!children).node.cs.arms return sum end #line 444 "tree.nw" # nomatch: if tied on leafarms and childarms, take candidate # with real leaf in preference to nomatch leaf procedure nomatch(children, f) return if *(!children).node.cs.arms = 0 then -1 else 0 end #line 451 "tree.nw" # childdisjuncts: prefer the candidate with the fewest disjuncts in children procedure childdisjuncts(children, f) sum := 0 every sum -:= *(!(!children).node.cs.arms).pattern.disjuncts return sum end #line 459 "tree.nw" # branchfactor: prefer the candidate with the fewest children procedure branchfactor(children, f) return - *children end #line 469 "tree.nw" procedure intervals(patterns, f) cuts := set([0, 2^fwidth(f.field)]) every p := !patterns & d := !p.disjuncts & c := !d.aconstraints & c.field === f & type(c) == "constraint" do every insert(cuts, c.lo | c.hi) return sort(cuts) end #line 485 "tree.nw" procedure mentions(cs) result := set() every a := !cs.arms & d := !a.pattern.disjuncts & c := !d.aconstraints & type(c) == "constraint" do insert(result, c.field) return result end #line 495 "tree.nw" procedure trim_impossible_arms(cs) l := [] every a := !cs.arms do if arm_conditions_always_satisfied(a) then { put(l, a) if *l < *cs.arms then cs.arms := l return cs } else if member(a.imp_soln.constraints, 0) | constant(!(\a.soln).constraints) = 0 then { cs.arms := l return cs } else { put(l, a) } return cs end #line 512 "tree.nw" procedure arm_conditions_always_satisfied(a) return guard_always_satisfied(a.imp_soln.constraints) & /a.soln | guard_always_satisfied(a.soln.constraints) end #line 517 "tree.nw" # find_id: tab to and past identifier id, returning its position # ignores quotes, comment brackets procedure find_id(id) static notlnum initial notlnum := ~ (&letters ++ &digits ++ '_') tab(p := find(id)) & p = 1 | (move(-1) & any(notlnum) & move(1)) & =id & pos(0) | any(notlnum) & suspend p end #line 533 "tree.nw" procedure checktree(n, cs) originals := set() every insert(originals, (!cs.arms).original) deletematching(n, originals) every show_unmatched(n, !originals) if hasnomatch(n) then warning("Matching statement at ", image(cs.arms[1].file), ", line ", n.cs.arms[1].line - 1, " doesn't cover all cases") return n end #line 545 "tree.nw" procedure deletematching(n, originals) if *originals = 0 then return else if *n.children > 0 then every deletematching((!n.children).node, originals) else every delete(originals, (!n.cs.arms).original) end #line 551 "tree.nw" procedure hasnomatch(n) if *n.children > 0 then return hasnomatch((!n.children).node) else if *n.cs.arms = 0 then return # found it end #line 560 "tree.nw" procedure show_unmatched(n, a) warning("No word matches pattern at ", image(a.file), ", line ", a.line, ".") write(&errout," Covered by patterns at") every find_covering_arms(n, a, !a.pattern.disjuncts) return end procedure find_covering_arms(n, a, ad) if *n.children = 0 then every a := !n.cs.arms do write(&errout, "\t", image(a.file), ", line ", a.line) else { c := find_or_invent_constraint(n.field, ad) every e := !n.children & intervals_intersect(c.lo, c.hi, e.lo, e.hi) do find_covering_arms(e.node, a, ad) } return end #line 580 "tree.nw" procedure intervals_intersect(lo1, hi1, lo2, hi2) if hi1 <= lo2 | hi2 <= lo1 then fail else return end # absolute disjuncts! procedure find_or_invent_constraint(f, d) return if type(c := !d.aconstraints) == "constraint" & c.field === f then c else constraint(f, 0, 2^fwidth(f.field)) end #===================================================================== dag.icn #line 39 "dag.nw" procedure addinterval(loset, hiset, lonum, hinum) if member(loset, hinum) then delete(loset, hinum) else insert(hiset, hinum) if member(hiset, lonum) then delete(hiset, lonum) else insert(loset, lonum) return end #line 54 "dag.nw" procedure overlaps(loset, hiset, lonum, hinum) local leftcount, rightcount leftcount := 0; every lonum >= !hiset do leftcount +:= 1 rightcount := 0; every hinum <= !loset do rightcount +:= 1 return leftcount + rightcount < *loset end #line 63 "dag.nw" procedure showbitset(loset, hiset, width) l := sort(loset ++ hiset) b := 0 i := 0 s := "" while i < width do { if i = l[1] then { get(l) b := 1 - b } s ||:= b i +:= 1 } return reverse(s) end #line 88 "dag.nw" procedure nodetostring(n, depth) static cache initial cache := table() /depth := 0 if /cache[n] then if *n.children > 0 then { result := "[" || n.field.field.name || "@" || n.field.offset || ":" every result ||:= edgetostring(!n.children, depth+2) cache[n] := result || "]" } else { cache[n] := "(" || image(n.name) every a := !n.cs.arms do cache[n] ||:= ":" || image(a.original) || ":" || image(a.imp_soln) || ":" || image(a.patlen) cache[n] ||:= ")" } return \cache[n] end #line 107 "dag.nw" procedure edgetostring(e,depth) return left("\n", depth) || "{" || patimage(sort(e.lo ++ e.hi)) || ":" || nodetostring(e.node,depth) || "}" end #line 119 "dag.nw" procedure tree2dag(n, nodetable, depth) outtree(\ascii_tree, n) /nodetable := table() /depth := 0 if *n.children > 0 then combinechildren(n, nodetable, depth+2) # converts edges to set form if *n.children = 1 then { e := n.children[1] if covers(n.children[1], fwidth(n.field.field)) then n := n.children[1].node # all roads to child: hoist it else warning("node with one child doesn't match all cases") } s := nodetostring(n, depth) outtree(\ascii_dag, n) /nodetable[s] := n return nodetable[s] end #line 142 "dag.nw" procedure covers(e, width) l := sort(e.lo ++ e.hi) return *l = 2 & l[1] = 0 & l[2] = 2^width end #line 152 "dag.nw" record namearray(field, tbl, hi, codename, storageclass) # field used as index, table[integer] of name, bound on table, name of this array global natable #line 158 "dag.nw" procedure arraycandidates(n) initial MAXRANGE := 32 suspend e := !n.children & type(e.node.name) == "string" & e.hi - e.lo <= MAXRANGE & e end procedure combinechildren(n, nodetable, depth) initial natable := table() if arraycandidates(n).node.name ~== arraycandidates(n).node.name then { #line 185 "dag.nw" mightuse := set() # name arrays we might use must have right field every na := !\natable[n.field] do insert(mightuse, na) every e := arraycandidates(n) & na := !mightuse do if \na.tbl[e.lo to e.hi - 1] ~== e.node.name then # slot used with wrong name delete(mightuse, na) if *mightuse > 0 then willuse := ?mightuse else { /natable[n.field] := set() insert(natable[n.field], willuse := namearray(n.field, table(), 0)) } every e := arraycandidates(n) & e.lo - willuse.hi <= MAXRANGE do { every willuse.tbl[e.lo to e.hi - 1] := e.node.name; e.node.name := willuse willuse.hi <:= e.hi } #line 169 "dag.nw" } lotable := table() hitable := table() every e := !n.children & child := tree2dag(e.node, nodetable, depth) do { /lotable[child] := set() /hitable[child] := set() addinterval(lotable[child], hitable[child], e.lo, e.hi) } n.children := [] every child := key(lotable) do put(n.children, edge(child, lotable[child], hitable[child])) return end #line 205 "dag.nw" procedure namesused(n, result) /result := set() if type(n.name) == "namearray" then insert(result, n.name) every namesused((!n.children).node, result) return result end #================================================================= gencode.icn #line 9 "gencode.nw" record Glines(x) # list of lines to be written out record Gresynch(line, file) # C #line or m3 <* LINE ... *> record Gblock(decls, stmts) # block with local variables record Gdecl(name, type, init) # variable with name, type, optional initial value record Gcall(name, args) # call to named function #line 19 "gencode.nw" record Gdeclnamearray(na) # declares CONST ARRAY OF TEXT specified by # namearray na. #line 22 "gencode.nw" record Gcase(x, arms) # CASE x OF arms END; record Gcasearm(tags, x) # tags is sorted list of lo, hi s.t. lo <= x < hi record Ginrange(lo, x, hi) # predicate lo <= x < hi record Gsetname(lhs, name) # lhs := name (where name is string or namearray) record Gnomatch() # what happens when there's no match record Tunsigned(width) # unsigned value of width bits (word size if /width) record Tsigned(width) # signed value of width bits (word size if /width) record Gasgn(lhs, x) # set lhs := x #line 38 "gencode.nw" global gen_file_header, gen_outer_decls procedure genheader(header) return Glines([ Gresynch(codeline := 1), literal(gen_file_header), Gresynch(header.line, header.file), Glines(header.code), Gresynch(codeline +:= 100)]) end #line 48 "gencode.nw" global fetchtab # code to use to fetch words: size -> fetch string global codeline #line 51 "gencode.nw" procedure gencase(cs, root) static label local decls initial label := 0 /root := tree(cs) outtree(\ascii_tree, root) decls := [Gdecl("MATCH_p", fetchtab["type"], cs.valcode)] every put(decls, !gen_outer_decls | Gdeclnamearray(!namesused(root))) return Glines([Gblock(decls, [Gresynch(codeline +:= 100), gennode(root, set())])] ||| armscode(cs.trailer)) end #line 67 "gencode.nw" procedure gennode(n, wordsmatched) local firstif, decls, added, single_range, other_child, answer while *n.children = 1 do n := n.children[1].node decls := [] if *n.children > 0 then { added := add_decls(decls, wordsmatched, node_fields(n.field)) if *n.children = 2 & single_range := !n.children & *single_range.lo = 1 then { #line 98 "gencode.nw" other_child := single_range ~=== !n.children #line 110 "gencode.nw" if *other_child.lo = 1 & (!other_child.lo + 1 = !other_child.hi) then { *other_child.hi = 1 | impossible("ranges") other_child :=: single_range } #line 100 "gencode.nw" f := afieldexp(n.field) s := Sif([Sguarded(Ginrange(!single_range.lo, f, !single_range.hi), gennode(single_range.node, wordsmatched)), Sguarded(1, gennode(other_child.node, wordsmatched))]) answer := subst_for_pc(Gblock(decls, [s]), address_to_integer("MATCH_p")) #line 76 "gencode.nw" } else { #line 88 "gencode.nw" edges := table() every e := !n.children do edges[sort(e.lo)[1]] := e edges := sort(edges) ifarms := [] every addarms(ifarms, n.field, (!edges)[2], wordsmatched) casearms := [] every genedge(casearms, n.field, (!edges)[2], wordsmatched) put(ifarms, Sguarded(1, Gcase(afieldexp(n.field), casearms))) answer := subst_for_pc(Gblock(decls, [Sif(ifarms)]), address_to_integer("MATCH_p")) #line 78 "gencode.nw" } } else { added := add_decls(decls, wordsmatched, constraint_fields(n.cs.arms)) s := genarms(n.cs.arms, n, wordsmatched) answer := subst_for_pc(Gblock(decls, [s]), address_to_integer("MATCH_p")) } every delete(wordsmatched, !added) return answer end #line 119 "gencode.nw" procedure add_decls(decls, wordsmatched, fields) local added added := set() every w := wordname(f := !fields) & not member(wordsmatched, w) do { put(decls, Gdecl(wordname(f), Tunsigned(f.field.class.size), fetchcode(address_add("MATCH_p", f.offset), f.field.class.size))) every insert(wordsmatched | added, w) } # with [[afieldexp]], these are no longer needed ## every f := !fields & not member(wordsmatched, f) do { ## put(decls, Gdecl(afieldname(f), Tunsigned(fwidth(f.field)), ## Eslice(literal(wordname(f)), f.field.lo, fwidth(f.field)))) ## every insert(wordsmatched | added, f) ## } return added end #line 136 "gencode.nw" procedure node_fields(f) return case type(f) of { "set" : f "list" : set(f) default : set([f]) } end #line 146 "gencode.nw" procedure constraint_fields(arms) local fields fields := set() every a := !arms do every insert(fields, absolute_fields((\a.imp_soln).constraints | subst_tab(!(\a.soln).constraints, (\a.imp_soln).answers, 1))) return fields end procedure absolute_fields(e) suspend subterms_matching(e, "absolute_field") end #line 164 "gencode.nw" procedure wordname(f) return "MATCH_w_" || f.field.class.size || "_" || f.offset; end #line 169 "gencode.nw" ## procedure afieldname(f) ## return "MATCH_f_" || f.field.name || "_" || f.offset ## end #line 175 "gencode.nw" record Gcommented(e, comment) procedure afieldexp(f) return Gcommented(Eslice(literal(wordname(f)), f.field.lo, fwidth(f.field)), f.field.name || " at " || f.offset) end #line 181 "gencode.nw" global MAXRANGE procedure genedge(casearms, f, e, wordsmatched) local tags tags := [] r := sort(e.lo ++ e.hi) while lo := get(r) & hi := get(r) do if hi - lo <= MAXRANGE then every put(tags, lo | hi) if *tags > 0 then put(casearms, Gcasearm(tags, gennode(e.node, wordsmatched))) return end #line 195 "gencode.nw" procedure addarms(ifarms, f, e, wordsmatched) r := sort(e.lo ++ e.hi) while lo := get(r) & hi := get(r) do if hi - lo > MAXRANGE then put(ifarms, Sguarded(Ginrange(lo, afieldexp(f), hi), gennode(e.node, wordsmatched))) return end #line 204 "gencode.nw" procedure genarms(arms, thenode, wordsmatched) local ifarms ifarms := [] every a := !arms do { c := copy((\a.imp_soln).constraints) | set() every insert_condition(c, subst_tab(!(\a.soln).constraints, (\a.imp_soln).answers, 1)) put(ifarms, Sguarded(c, genarm(a, thenode, wordsmatched))) } put(ifarms, Sguarded(1, Gnomatch())) return Sif(ifarms) end #line 233 "gencode.nw" procedure genarm(a, thenode, wordsmatched) local bindings, fused, block, decls, stmts, patlabels /continue := 0 #line 263 "gencode.nw" if type(c := !(!(\a.pattern).disjuncts).aconstraints) == "fieldbinding" then impossible("field binding in arm: ", expimage(c)) #line 237 "gencode.nw" fused := set(); every e := (t := (\a.soln | \a.imp_soln).answers, id := key(t) & not is_wildcard(id), t[id]) do every insert(fused, absolute_fields(e)) decls := [] added := add_decls(decls, wordsmatched, fused) # patlabels := a.pattern.disjuncts[1].patlabelbindings # every id := key(\patlabels) do # put(decls, Gdecl(id, unsigned_type(), patlabels[id])) every id := key((\a.imp_soln).answers) & not is_wildcard(id) do put(decls, Gdecl(id, &null, a.imp_soln.answers[id])) every id := key((\a.soln).answers) & not is_wildcard(id) do put(decls, Gdecl(id, &null, a.soln.answers[id])) if (\a.name & /thenode.name) then { warning("Name `" || a.name || "' in pattern arm is unbound.\n") put(decls, Gsetname(a.name, "??name of unnamed pattern??")) } put(decls, Gsetname(\a.name, \thenode.name)) every delete(wordsmatched, !added) stmts := armscode(a) push(stmts, Gasgn(\thenode.cs.succptr, address_add("MATCH_p", \a.patlen))) write(\mdebug, "successor for ", image(a), " at ", \a.patlen) return subst_for_pc(Gblock(decls, stmts), address_to_integer("MATCH_p")) end #line 266 "gencode.nw" procedure armscode(a) return [Gresynch(a.line, a.file), Glines(a.code), Gresynch(codeline +:= 100)] end #line 275 "gencode.nw" procedure is_wildcard(v) return member(fresh_variables, v) end #line 282 "gencode.nw" procedure address_add(address, offset) if offset % pc_unit_bits ~= 0 then error("Tried to fetch at offset ", offset, ", but pc_unit_bits = ", pc_unit_bits, " doesn't divide ", offset) offset /:= pc_unit_bits; return interpret_fetchtab(\fetchtab["add"], address, offset, &null, "address add") | error("No template given for 'address add'") end #line 293 "gencode.nw" procedure fetchcode(address, width) return interpret_fetchtab(\fetchtab[width | "any"], address, &null, width, "fetch") | error("No template given to fetch ", width, "-bit word") end #line 300 "gencode.nw" procedure address_to_integer(address) return interpret_fetchtab(\fetchtab["integer"], address, &null, &null, "address to integer") | error("No template given for 'address to integer'") end #line 308 "gencode.nw" procedure interpret_fetchtab(s, address, offset, width, msg) r := "(" s ? { while r ||:= tab(upto('%')) do { ="%" r ||:= case move(1) of { "a" : \address | error("%a illegal in template for ", msg) "o" : \offset | error("%o illegal in template for ", msg) "w" : \width | error("%w illegal in template for ", msg) "%" : "%" default : error("Bad escape in fetch string for ", width, "-bit word: %", move(-1), "; try %a, %o, or %w") } } return r || tab(0) || ")" } end #================================================================ encoding.icn #line 4 "encoding.nw" #====== link pretty procedure emit_encoding(outfilename) local i, f emit_encoding_interface(open(i := outfilename || interface_extension, "w")) | error("Could not open ", image(i), " for writing") emit_encoding_implementation( open(f := outfilename || implementation_extension, "w"), i, outfilename) | error("Could not open ", image(f), " for writing") end #line 14 "encoding.nw" procedure emit_encoding_interface(outfile) local cons, t, u verbose("Emitting encoding interface") pp := PPnew(outfile) every PPwrite(pp, pretty(!header_lines)) PPwrite(pp, "/* must #include before this file */") #line 31 "encoding.nw" every ty := !\all_types | (\encode_as_data, instructionctype) do { PPxwrites(pp, "enum ", ty.name, "_tag ${$t{ $o") every cons := kept_constructors(ty) do PPxwrites(pp, cons.name, "_TAG = ", cons.tag, ", $o") PPxwrite(pp, "$b$}};") emit_instance_type(pp, ty) } #line 21 "encoding.nw" if \gen_counters then declare_counter_types(pp) if \indirectname then PPxwrite(pp, "struct ", indirecttype, " {$t") #line 45 "encoding.nw" every emit_proc_declaration(pp, kept_constructors()) #line 25 "encoding.nw" if \gen_counters then declare_counter_funs(pp) if \indirectname then PPxwrite(pp, "$b$n};") return end #line 47 "encoding.nw" procedure emit_indirect_encoder(pp) e := [] every cons := kept_constructors() do put(e, Cnoreserve(cons.name) || ", $o") c := if \gen_counters then counter_names() else "" emit_template(pp, "proc-structure.t", "indirectname", indirectname, "indirecttype", indirecttype, "encoders", e, "counters", c) return end #line 74 "encoding.nw" procedure emit_encoding_implementation(outfile, interfacename, basename) verbose("Emitting encoding implementation") pp := PPnew(outfile) every PPwrite(pp, pretty(!header_lines)) PPwrite(pp, "#include ") PPwrite(pp, "#include ", image(interfacename)) PPwrite(pp, "#define sign_extend(N,SIZE) \\") PPwrite(pp, " (((int)((N) << (sizeof(unsigned)*8-(SIZE)))) ", ">> (sizeof(unsigned)*8-(SIZE)))") pushtrace("ASS") if \gen_counters then declare_counters(pp) # every cons := kept_constructors() do { verbose("Encoder for constructor ", cons.name) PPwrite(pp, "/**************") show_constructor(pp, cons) PPwrite(pp, "***********/") if cons.type ~=== instructionctype | \encode_as_data then emit_create_instance_body(pp, cons) else emit_emitter_body(pp, cons) } PPwrite(pp) # flush prettyprinter poptrace() if \gen_counters then define_counter_funs(pp) if \indirectname then emit_indirect_encoder(pp) emit_closure_functions_postfix(pp, basename) emit_closure_functions_bytecode(pp, basename) emit_closure_functions_emitclosure_map(pp, basename) return end #line 111 "encoding.nw" procedure show_constructor(pp, cons) PPwrite(pp) PPwrites(pp, cons.name, " ") every o := !cons.operands do case type(o) of { "literal" : PPwrites(pp, o.s) "input" : PPwrites(pp, o.name, if type(o.meaning) == "integer" then "!" else "") default : impossible("operand") } PPxwrites(pp, " is $t${$c") PPxwrite(pp, ppexpimage(pattern_to_case(crhs(cons))), "$}$b$n") return end #line 126 "encoding.nw" procedure show_constype(outfile, type) write(outfile) l := []; every put(l, kept_constructors(type).name) PPwrite(pp, type.name, " (", commaseparate(l, " | "), "):") show_case(outfile, pattern_to_case(constype_pattern(type))) write(outfile) return end #line 135 "encoding.nw" procedure declare_counters(pp) every PPwrite(pp, "static int ", kept_constructors().name, "_ctr = 0;") return end procedure declare_counter_types(pp) PPwrite(pp, "typedef void (*Printer)(void *closure, char *fmt, ...);") return end procedure declare_counter_funs(pp) c_function_declaration(pp, "void", "reset_cons_counters", "(void)") c_function_declaration(pp, "void", "dump_cons_counters","(Printer p, void *closure)") return end procedure counter_names() return "reset_cons_counters, dump_cons_counters, $o" end procedure define_counter_funs(pp) PPxwrites(pp, if \indirectname then "static " else "", "void reset_cons_counters(void) {$t") every PPxwrites(pp, "$n", kept_constructors().name, "_ctr = 0;") PPxwrite(pp, "$b$n}") PPxwrites(pp, if \indirectname then "static " else "", "void dump_cons_counters(Printer p, void *closure) {$t") every cons := kept_constructors() do PPxwrites(pp, "$np(closure, \"%d ", cons.name, " : ", #line 164 "encoding.nw" (if cons.type === instructionctype then "" else cons.type.name) #line 159 "encoding.nw" , "\\n\", ", cons.name, "_ctr);") PPxwrite(pp, "$b$n}") end #==================================================================== main.icn #line 5 "main.nw" #====== link pushtrace #line 7 "main.nw" procedure usage() every write(&errout, ![ "Usage: tools [options] [specfile ...]", "Options:", #line 25 "main.nw" " -ascii-dag file write an ascii representation of matching-statement code", #line 40 "main.nw" " -ascii-tree file write an ascii representation of matchin-statement trees", #line 54 "main.nw" " -asm-encoder file generate assembly-emitting encoding procedures on file.[ch]", #line 67 "main.nw" " -asm-grammar file generate assembly-language grammar on file", #line 80 "main.nw" " -byteorder O use order O (one of [blm]) to emit words", #line 100 "main.nw" " -c generate C code [default]", #line 111 "main.nw" " -checker file generate a checker on file", #line 125 "main.nw" " -count count invocations of encoding procedures", #line 138 "main.nw" " -data encoding procedures return data", #line 153 "main.nw" " -debug-bal file extra debugging info for balancer", #line 166 "main.nw" " -debug-checker file write debugging info about checker", #line 177 "main.nw" " -debug-heur file write debugging info about heuristic scores", #line 190 "main.nw" " -debug-match file write debugging info about matching statements", #line 200 "main.nw" " -debug-solver turn on solver debugging", #line 210 "main.nw" " -debug-split file write debugging info when splitting tree nodes", #line 219 "main.nw" " -decoder file from matcher, generate decoder on file", #line 235 "main.nw" " -dis file generate disassembly code on file", #line 245 "main.nw" " -dot file write dot(1) commands showing matching statements", #line 260 "main.nw" " -emit-bits n unit of emission is n bits (default 8)", #line 278 "main.nw" " -encoder file generate encoding procedures on file.[ch]", #line 289 "main.nw" " -expand-spec file writes an expanded version of the input specification", #line 305 "main.nw" " -fieldnames file write arrays of field names on file.[ch]", #line 319 "main.nw" " -foldemit fold constants in calls to emit functions", #line 334 "main.nw" " -icon generate Icon code (for wizards only)", #line 345 "main.nw" " -icon-dag file write Icon representation of matching-statement dags", #line 358 "main.nw" " -icon-tree file write Icon representation of matching-statement trees", #line 370 "main.nw" " -impossible force errors to stop with stack trace", #line 382 "main.nw" " -indirect name[:type] generated encoding procs called indirect through name", #line 403 "main.nw" " -instype name name of abstract instruction datatype", #line 413 "main.nw" " -late-const include constants in closure functions (default)", #line 427 "main.nw" " -late-none include *no* constants in closure functions", #line 439 "main.nw" " -late-zero include zero in closure functions", #line 450 "main.nw" " -lc-cons-names use all lower case for constructor names", #line 460 "main.nw" " -lc-pat-names map pattern names to lower case in code", #line 471 "main.nw" " -ledger tell dot(1) to use ledger paper with -dot", #line 482 "main.nw" " -matcher file transform pattern-matching statements in file", #line 492 "main.nw" " -max-decimal n values larger than n will be printed in hex", #line 513 "main.nw" " -m3 generate Modula-3 code", #line 525 "main.nw" " -no-asm-ws remove whitespace from assembly syntax", #line 537 "main.nw" " -no-pp don't prettyprint output; use $ escapes", #line 565 "main.nw" " -no-reloc make all relocatable addresses integers", #line 577 "main.nw" " -nowarn no warnings", #line 589 "main.nw" " -old-closures use the old closure technique", #line 598 "main.nw" " -postfix use postfix assembly-language syntax", #line 610 "main.nw" " -symdis file put symbolic disassembler on file.[mh]", #line 623 "main.nw" " -token-closures use one closure per token", #line 633 "main.nw" " -test pay no attention to the man behind the curtain", #line 656 "main.nw" " -tryall try all heuristics on every field, node (for debugging)", #line 666 "main.nw" " -verbose extra warnings & informatory messages", #line 12 "main.nw" "`-' may be used in place of a file name to mean stdin or stdout"]) stop() end #line 149 "main.nw" global encode_as_data #line 163 "main.nw" global baldebug #line 510 "main.nw" global max_decimal #line 534 "main.nw" global no_asm_ws #line 548 "main.nw" global no_asm_ws #line 574 "main.nw" global no_reloc #line 607 "main.nw" global postfix #line 620 "main.nw" global symdisfilename #line 676 "main.nw" procedure info_msg(L[]) write ! ([&errout, image(filename), ", line ", lineno, ": Info -- "] ||| L) end #line 681 "main.nw" global cdebug, mdebug, sdebug, hdebug, tryall, indirectname, indirecttype global lc_pat_names, nowarn, emptyset, emittername, pretty global lowercons, pc_unit_bits, emit_unit_bits, simplify_emits, gen_counters global fieldnamesbase, verbose, version global interface_extension, implementation_extension global emit_closure_functions, latezero, lateconst global asmgrammarfilename, disassemblyfilename #line 715 "main.nw" global emitterstyle # closure or direct, controls emission #line 722 "main.nw" global the_global_pc #line 729 "main.nw" global command_line, header_lines record Gcomment(s) procedure main(args) #line 424 "main.nw" lateconst := 1 #line 508 "main.nw" max_decimal := 2^31 - 1 #line 689 "main.nw" dotfile := ascii_dag := spec := ascii_tree := decoderout := fulltree := sdebug := hdebug := encoderfilename := asmencoderfilename := ledger := tryall := asmgrammarfilename := disassemblyfilename lc_pat_names := alt := matcher := gen_counters := lowercons := &null #line 695 "main.nw" emittername := "emitm" emptyset := set() verbose := nop filename := "-" pagesize := "8.5,11" fetchtab := table() pc_unit_bits := 8 emit_unit_bits := 8 fresh_variables := set() pretty := prettyC interface_extension := ".h" implementation_extension := ".c" debug := debugs := nop emit_closure_functions := emit_optimized_closure_functions #line 717 "main.nw" emitterstyle := "direct" #line 724 "main.nw" the_global_pc := Epc() #line 734 "main.nw" version := #line 3 "main.nw" "0.5a" #line 736 "main.nw" command_line := "tools" every command_line ||:= " " || !args header_lines := [ Gcomment("Generated by the New Jersey Machine-Code Toolkit, version " ||version), Gcomment("command line: " || command_line)] #line 743 "main.nw" Generate_C() # default instructionctype := constype("instruction", set()) while args[1][1:2] == "-" & *args[1] > 1 do case a := get(args) of { #line 17 "main.nw" "-alt" : alt := &output #line 27 "main.nw" "-ascii-dag" : ascii_dag := openfile(get(args),"w") #line 42 "main.nw" "-ascii-tree" : ascii_tree := openfile(get(args),"w") #line 56 "main.nw" "-asm-encoder" : asmencoderfilename := get(args) #line 69 "main.nw" "-asm-grammar" : asmgrammarfilename := get(args) #line 82 "main.nw" "-byteorder" : emittername := "emit" || get(args) #line 102 "main.nw" "-c" : { Generate_C(); interface_extension := ".h"; implementation_extension := ".c" } #line 113 "main.nw" "-checker" : { checkerfilename := get(args) } #line 127 "main.nw" "-count" : gen_counters := 1 #line 140 "main.nw" "-data" : encode_as_data := 1 #line 155 "main.nw" "-debug-bal" : baldebug := openfile(get(args),"w") #line 168 "main.nw" "-debug-checker" : cdebug := openfile(get(args),"w") #line 179 "main.nw" "-debug-heur" : hdebug := openfile(get(args),"w") #line 192 "main.nw" "-debug-match" : mdebug := openfile(get(args),"w") #line 202 "main.nw" "-debug-solver" : debug_on() #line 212 "main.nw" "-debug-split" : sdebug := openfile(get(args),"w") #line 221 "main.nw" "-decoder" : decoderout := openfile(get(args),"w") #line 237 "main.nw" "-dis" : disassemblyfilename := get(args) #line 247 "main.nw" "-dot" : dotfile := openfile(get(args),"w") #line 262 "main.nw" "-emit-bits" : emit_unit_bits := integer(get(args)) | stop("-emitbits not integer") #line 280 "main.nw" "-encoder" : encoderfilename := get(args) #line 291 "main.nw" "-expand-spec" : spec := openfile(get(args),"w") #line 307 "main.nw" "-fieldnames" : fieldnamesbase := get(args) #line 321 "main.nw" "-foldemit" : simplify_emits := 1 #line 336 "main.nw" "-icon" : { Generate_Icon(); interface_extension := ".bogus.icn"; implementation_extension := ".icn" } #line 347 "main.nw" "-icon-dag" : icon_dag := openfile(get(args),"w") #line 360 "main.nw" "-icon-tree" : icon_tree := openfile(get(args),"w") #line 372 "main.nw" "-impossible" : error := stop := impossible #line 384 "main.nw" "-indirect" : get(args) ? { indirectname := tab(upto(':') | 0) indirecttype := if =":" then tab(0) else indirectname } #line 405 "main.nw" "-instype" : instructionctype.name := get(args) #line 415 "main.nw" "-late-const" : lateconst := 1 #line 429 "main.nw" "-late-none" : lateconst := latezero := &null #line 441 "main.nw" "-late-zero" : latezero := 1 #line 452 "main.nw" "-lc-cons-names" : lowercons := 1 #line 462 "main.nw" "-lc-pat-names" : lc_pat_names := 1 #line 473 "main.nw" "-ledger" : {ledger := 1; pagesize := "11,17"} #line 484 "main.nw" "-matcher" : matcher := openfile(get(args),"r") #line 494 "main.nw" "-max-decimal" : max_decimal := 0 <= get(args) | error("-max-decimal value must be nonnegative integer") #line 515 "main.nw" "-m3" : { Generate_M3(); interface_extension := ".i3"; implementation_extension := ".m3" } #line 527 "main.nw" "-no-asm-ws" : no_asm_ws := 1 #line 539 "main.nw" "-no-pp" : { PPxwrite := PPwrite; PPxwrites := PPwrites } #line 567 "main.nw" "-no-reloc" : no_reloc := 1 #line 579 "main.nw" "-nowarn" : nowarn := 1 #line 591 "main.nw" "-old-closures" : emit_closure_functions := emit_original_closure_functions #line 600 "main.nw" "-postfix" : postfix := 1 #line 612 "main.nw" "-symdis" : symdisfilename := get(args) #line 625 "main.nw" "-token-closures" : emit_closure_functions := emit_tokenized_closure_functions #line 635 "main.nw" "-test" : { write("Uncommented ", Cuncomment("/* foo at 0 */")) ###### pp := PPnew(&output) ###### t := constype("Outer", set(), 1, 1) ###### t2 := constype("Inner", set(), 1, 1) ###### c := constructor("mkOut", "mkOut", ["in"], t, [epsilon()], [table()], 1) ###### c2 := constructor("mkIn", "mkIn", ["fish"], t2, [epsilon()], [table()], 1) ###### t.members := [c] ###### t2.members := [c2] ###### b := Ebinding_instance("xxx", t, table()) ###### y2 := Einstance_tagged(Einstance_input(b, c, "in"), c2, 99) ###### PPxwrite(pp, ppexpimage(y2), " =>$t$c ", "???", "$b") ###### pushtrace("TEST") ###### x2 := eliminate_instances_f(y2) ###### # x1 := eliminate_instances_f(y1 := Einstance_input(Einstance_input(b, c, "in"), c2, "fish")) ###### poptrace() ###### # PPxwrite(pp, ppexpimage(y1), " =>$t$c ", ppexpimage(x1), "$b") ###### PPxwrite(pp, ppexpimage(y2), " =>$t$c ", ppexpimage(x2), "$b") } #line 658 "main.nw" "-tryall" : tryall := 1 #line 668 "main.nw" "-verbose" : verbose := info_msg #line 749 "main.nw" default : usage() } verbose("NJ Machine-Code Toolkit, version ", version) init_parser() init_tests() # see code.nw #line 758 "main.nw" if /quiet then write(&errout, "Parsing...") if *args > 0 then every consume(openfile(filename := !args,"r")) else consume(&input) if /quiet then write(&errout, "Done parsing.") #line 767 "main.nw" if \no_asm_ws then every strip_asm_whitespace(kept_constructors()) emit_encoding(\encoderfilename) emit_assembly(\asmencoderfilename) emit_symbolic_disassembler(\symdisfilename) emit_asm_grammar(\asmgrammarfilename) emit_disassembler(\disassemblyfilename) emit_fieldnames(\fieldnamesbase) emit_checker(\checkerfilename) if \ledger then { #line 817 "main.nw" write(\dotfile,"%! PostScript") write(\dotfile,"/setpapertraybyname {") write(\dotfile," { /trayname exch def statusdict trayname known {") write(\dotfile," statusdict trayname get exec } if} stopped") write(\dotfile," { handleerror } if}bind def") write(\dotfile,"/ledgertray setpapertraybyname") #line 775 "main.nw" } outspec(\spec) if \matcher then { #line 781 "main.nw" codelex(matcher) P_CodeFile() #line 812 "main.nw" while (token ~== EOF) do { error("Leftover token ", token, " = ", image(tval)) lex() } #line 784 "main.nw" x := super_simplify(genheader(codeheader)) PPxwrite(PPnew(\decoderout), pretty(x)) every resolve_case_patterns(!matching_stmts) #line 838 "main.nw" every write(\icon_tree | \icon_dag, "procedure tree(n)" | " static trees" | " initial {" | " trees := []") #line 788 "main.nw" every t := tree(cs := !matching_stmts) do { #line 824 "main.nw" checktree(t, cs) outtree(\ascii_tree, t) icontree(PPnew(\icon_tree), t) if \dotfile | \ascii_dag | \icon_dag | \decoderout | \alt then { d := tree2dag(t) outtree(\ascii_dag, d) icontree(PPnew(\icon_dag), d) dotouttree(\dotfile, d) PPxwrite(PPnew(\decoderout), pretty(super_simplify(gencase(cs, d)))) printalternates(\alt, d) write(\alt,"\n", repl("=", 50)) } #line 788 "main.nw" } #line 844 "main.nw" every write(\icon_tree | \icon_dag, " }" | " return trees[n]" | "end") #line 778 "main.nw" } end #line 791 "main.nw" global showpnf #line 793 "main.nw" global real_lex procedure noisylex(k) local x x := real_lex(k) write(&errout, "Lexed ", image(x), " (", image(tval), ")") return x end procedure consume(input) real_lex := lex # lex := noisylex lex(input) pushtrace("PARSE") P_Spec() poptrace() #line 812 "main.nw" while (token ~== EOF) do { error("Leftover token ", token, " = ", image(tval)) lex() } #line 809 "main.nw" return end #line 849 "main.nw" record alternator(constraints, thennode, elsenode) procedure alternates(n) local alt if *n.children = 2 then { every i := 1 to 2 do if alt := alternates(n.children[i].node) & n.children[3-i].node === alt.elsenode then suspend alternator(alt.constraints||| [constraint(n.field, n.children[i].lo, n.children[i].hi)], alt.thennode, alt.elsenode) every i := 1 to 2 do suspend alternator( [constraint(n.field, n.children[i].lo, n.children[i].hi)], n.children[i].node, n.children[3-i].node) } end #line 867 "main.nw" procedure printalternates(file, n) local alt if alt := alternates(n) then { write(file) writes(file, "if (") l := copy(alt.constraints) while genconstraint(file, get(l)) do writes(file, " && ") write(file, "1) {") writes(file, " /*") writes(file, \alt.thennode.cs.arms[1].original.pattern.name | "[" || alt.thennode.cs.arms[1].original.line || "]") write(file, " */") write(file, "} else {") writes(file, " /*") writes(file, \alt.elsenode.cs.arms[1].original.pattern.name | "[" || alt.elsenode.cs.arms[1].original.line || "]") write(file, " */") write(file, "} else assert(0);") } else every printalternates(file, (!n.children).node) end #line 889 "main.nw" procedure genconstraint(file, c) r := sort(c.lo ++ c.hi) writes(file, "(", get(r), "<=", c.field.name, "<", get(r)) while writes(file, " || ", get(r), "<=", c.field.name, "<", get(r)) writes(file, ")") return end #line 900 "main.nw" procedure openfile(name, mode) /mode := "r" if name == "-" then case mode of { "r" : return &input "w" : return &output default : stop("bogus file mode: ", mode) } else return open(name, mode) | stop("Can't open file ", name, " for ", mode) end #=================================================================== match.icn #line 16 "match.nw" procedure resolve_case_patterns(cs) a := [] every put(a, new_matching_arms(!cs.arms, cs.succptr)) cs.arms := a return cs end #line 51 "match.nw" procedure new_matching_arms(a, succptr) local idents, Ii, id, patlabeltab, freevars pp := PPnew(\mdebug) ### idents := set(); every insert(idents, pattern_free_variables(a.pattern)) ### rho := newscope(globals) ### ### patlabeltab := table() ### every n := pattern_label_names(a.pattern) do ### patlabeltab[n] := n ### push(rho, patlabeltab) freevars := table() x := pnf(a.pattern, globals, freevars) PPxwrite(\pp, "after pnf we have case arm $t$o", ppexpimage(x), "$b") x := bind_patlabel_names(x, 1) PPxwrite(\pp, "after binding patlabel names we have case arm $t$o", ppexpimage(x), "$b") every set_patlabel_offsets(!x.disjuncts) PPxwrite(\pp, "after setting offsets we have case arm $t$o", ppexpimage(x), "$b") a.pattern := anf(x) a.pattern := gsubst(a.pattern, always_fail) # remove wildcards and instances, # turn latent to real labels PPxwrite(\pp, "after anf+subst we have case arm $t$o", ppexpimage(a.pattern), "$b") #line 73 "match.nw" #line 94 "match.nw" every delete(freevars, key(\(!a.pattern.disjuncts).patlabelbindings)) #line 74 "match.nw" if *freevars > 0 then write(\mdebug, "caught free variables:", envimage(freevars, "freevars")) #line 96 "match.nw" PPxwrites(\pp, "Before simplification, case arm is $t${$c", ppexpimage(a.pattern)) PPxwrites(\pp, "$o{ ", ppexpimage(\a.eqns), " }") PPxwrite(\pp, "$}$b") #line 77 "match.nw" x := simplify(a.pattern) if not exps_eq(x, a.pattern) then { a.pattern := x #line 100 "match.nw" PPxwrites(\pp, "After simplification, case arm is $t${$c", ppexpimage(a.pattern)) PPxwrites(\pp, "$o{ ", ppexpimage(\a.eqns), " }") PPxwrite(\pp, "$}$b") #line 81 "match.nw" } else write(\mdebug, "Case arm doesn't simplify") idents := all_disjuncts_ids(a.pattern, free_var_or_patlabelbinding_name, "Ignoring bound identifier ", " because it doesn't appear in every disjunct") if *idents > 0 then write(\mdebug, "Saw binding instances of ", commafy(sort(idents))) else write(\mdebug, "No binding instances") a.soln := solve(balance_eqns(\a.eqns), idents) #line 137 "match.nw" acount := 0 lasta := &null every d := !a.pattern.disjuncts do { s := fieldbindings_to_soln(d, idents) l := if \succptr then d.length else &null if (\lasta).imp_soln === s & lasta.patlen === l & patlabelbindings_match(lasta.pattern.disjuncts[1].patlabelbindings, d.patlabelbindings) then put(lasta.pattern.disjuncts, d) else { #line 164 "match.nw" write(\mdebug, "Answers and conditions (", image(\lasta), ") at length ", (\lasta).patlen, " (", image((\lasta).imp_soln), "):", solnimage((\lasta).imp_soln)) #line 149 "match.nw" suspend \lasta lasta := copy(a) lasta.pattern := copy(a.pattern) lasta.pattern.disjuncts := [d] lasta.imp_soln := s lasta.patlen := l acount +:= 1 } } if acount > 1 then write(\mdebug, "split case arm at ", image(a.file), ", line ", a.line, " because of varying implicit solutions or pattern lengths") #line 164 "match.nw" write(\mdebug, "Answers and conditions (", image(\lasta), ") at length ", (\lasta).patlen, " (", image((\lasta).imp_soln), "):", solnimage((\lasta).imp_soln)) #line 162 "match.nw" suspend \lasta #line 92 "match.nw" end #line 128 "match.nw" procedure always_fail() fail end #line 133 "match.nw" procedure free_var_or_patlabelbinding_name(d) suspend free_variables(d) | key(\d.patlabelbindings) end #line 168 "match.nw" procedure patlabelbindings_match(t1, t2) if /t1 then return (/t2 | *t2 = 0, t1) else if /t2 then return (/t1 | *t1 = 0, t1) else if k := key(t1) & (/t2[k] | t1[k] ~= t2[k]) then fail else if k := key(t2) & (/t1[k] | t1[k] ~= t2[k]) then fail else return t1 end #line 200 "match.nw" procedure fieldbindings_to_soln(d, idents) local newconstraints, newconditions, eqns, soln, inputs, x, result every newconstraints | eqns := [] inputs := set() every insert(inputs, key(\d.patlabelbindings)) afield_vars := table() every c := !d.aconstraints do case type(c) of { "constraint" : put(newconstraints, c) "fieldbinding" : { insert(inputs, x := afield_var(c.field)) put(eqns, eqn(x, "=", c.code)) } default : impossible("constraint type") } d.aconstraints := newconstraints newconditions := set() every e := !\d.conditions do case type(e) of { "eqn" : put(eqns, e) default : insert(newconditions, e) } d.conditions := if *newconditions > 0 then newconditions else &null soln := solve(balance_eqns(eqns), inputs) # soln.answers : bound [[idents]] -> exps in afield_vars result := solution(table(), set()) #line 239 "match.nw" if (id := !idents, not member(\d.patlabelbindings, id), /soln.answers[id]) then { PPxwrite(PPnew(&errout),"Error: trouble with disjunct ${$t$o", ppexpimage(d), "$b$}") #line 247 "match.nw" l := [] every /soln.answers[x := !idents] & not member(\d.patlabelbindings, x) do put(l, x) #line 242 "match.nw" error("Can't solve for ", commafy(sort(l)), envimage(soln.answers, "soln.answers")) } #line 227 "match.nw" every id := !idents do result.answers[id] := if member(\d.patlabelbindings, id) then binop(the_global_pc, "+", d.patlabelbindings[id]) else super_simplify(subst_tab(soln.answers[id], afield_vars_inverse, 1)) # is super_simplify really safe here? dunno... every insert_condition(result.constraints, super_simplify(subst_tab(!soln.constraints, afield_vars_inverse, 1))) return unique_soln(result) end #line 252 "match.nw" global afield_vars, afield_vars_inverse procedure afield_var(af) initial { every afield_vars | afield_vars_inverse := table() } afield_vars_inverse[/afield_vars[af] := fresh_variable(af.field.name)] := af return afield_vars[af] end #line 261 "match.nw" procedure unique_soln(soln) static cache initial cache := table() /cache[*soln.constraints] := table() t := cache[*soln.constraints] l := sort(soln.answers) k := ""; every p := !sort(soln.answers) do k ||:= p[1] || " " || type(p[2]) || " " /t[k] := set() if s := !t[k] & answers_eq(s.answers, soln.answers) & exps_eq(s.constraints, soln.constraints) then return s else { insert(t[k], soln) return soln } end #line 279 "match.nw" procedure answers_eq(a1, a2) if a1 === a2 then return *a1 = *a2 | fail if id := key(a1) & not exps_eq(a1[id], \a2[id]) then fail return end #================================================================ assembly.icn #line 5 "assembly.nw" #====== link pretty procedure emit_assembly(outfilename) local i, f verbose("Emitting encoding interface") emit_encoding_interface(openfile(i := outfilename || interface_extension, "w")) | error("Could not open ", image(i), " for writing") verbose("Emitting assembly procedures") emit_assembly_implementation( openfile(f := outfilename || implementation_extension, "w"), i) | error("Could not open ", image(f), " for writing") end #line 33 "assembly.nw" procedure emit_assembly_implementation(outfile, interfacename) pp := PPnew(outfile) every PPwrite(pp, pretty(!header_lines)) emit_template(pp, "assembly-impl.t", "interface", image(interfacename)) pushtrace("ASS") #line 54 "assembly.nw" every cons := kept_constructors() & cons.type ~=== instructionctype do PPwrite(pp, "#define ", cons.name, "_TAG ", cons.tag) #line 40 "assembly.nw" every cons := kept_constructors() do { verbose("Assembler for ", cons.name) if cons.type ~=== instructionctype then emit_create_instance_body(pp, cons) emit_assembler_body(pp, cons) } PPwrite(pp) # flush prettyprinter if \gen_counters then emit_counter_funs(outfile) poptrace() if \indirectname then emit_indirect_encoder(pp) return end #line 101 "assembly.nw" procedure consname2asm(cons) local n, x, cname n := "" cname := "" every cname ||:= opcode_component_name(!cons.opcode) x := map_fullname(cname) pushtrace("GLOB") if (\x) then n := if (\lowercons) then map(x) else x else every x := map_component(opcode_component_name(!cons.opcode), cons.type) do n ||:= if (\lowercons) then map(x) else x poptrace() return if cons.type === instructionctype | *n > 0 then if /postfix then (if !asmoperands(cons) then n || " " else n) else " " || n else "" end #line 122 "assembly.nw" global opcode_globs, opcode_full procedure map_fullname(name) initial /opcode_full := [] return globmap(name, !opcode_full) | &null end procedure map_component(name, type) initial /opcode_globs := [] return globmap(name, !opcode_globs) | if type === instructionctype then name else "" end #line 134 "assembly.nw" record globpair(lhs, rhs) procedure asmopcode(lhs, rhs, full) initial { /opcode_globs := [] /opcode_full := [] } put(if (\full) then opcode_full else opcode_globs, globpair(lhs, rhs)) return end #line 145 "assembly.nw" procedure globmap(name, glob) l := [] # used for $n name ? if consume_globs(glob.lhs, l) & pos(0) then return insert_glob_matches(glob.rhs, l) end #line 152 "assembly.nw" procedure consume_globs(pat, dollars, i) suspend case type(pat) of { "glob_any" : { while *dollars < pat.number do put(dollars, &null) dollars[pat.number] <- consume_globs(!pat.alternatives, dollars) } "glob_wildcard" : tab(&pos to *&subject + 1) "list" : { #line 165 "assembly.nw" /i := 1 if pat[i] then consume_globs(pat[i], dollars) || consume_globs(pat, dollars, i+1) else "" #line 159 "assembly.nw" } "string" : =pat default : impossible("glob pattern") } end #line 171 "assembly.nw" procedure number_braces(pat) do_number_braces(pat, 0) return pat end procedure do_number_braces(pat, bracecount) case type(pat) of { "glob_any" : { pat.number := bracecount +:= 1 bracecount := do_number_braces(pat.alternatives, bracecount) } "glob_wildcard" : &null "list" : every i := 1 to *pat do bracecount := do_number_braces(pat[i], bracecount) "string" : &null default : impossible("glob pattern: ", image(pat)) } return bracecount end #line 190 "assembly.nw" procedure insert_glob_matches(rhs, dollars) s := "" every x := !rhs do s ||:= case type(x) of { "string" : x "glob_dollar" : \dollars[x.number] | error("No match for $", x.number, " in `", grhsimage(rhs), "'") default : impossible("glob rhs") } return s end #line 202 "assembly.nw" procedure grhsimage(rhs) s := "" every x := !rhs do s ||:= case type(x) of { "string" : x "glob_dollar" : "$" || x.number default : impossible("glob rhs") } return s end #line 217 "assembly.nw" record operand_syntax(syntax, nametable) # syntax string, optional name table, optional bound on values (max+1) global operand_syntax_tab procedure asmoperand(name, syntax, names) local nametable initial /operand_syntax_tab := table() #line 243 "assembly.nw" if type(symtab[name]) == ("constype" | "relocatable") then error("You may specify an operand syntax only for integer or field operands") #line 226 "assembly.nw" #line 232 "assembly.nw" if type(names) == "field" then names := namespec(\fieldname_table(names)) | error("No names supplied for field ", ii2) nametable := if type(f := symtab[name]) == "field" then { /names := namespec(\fieldname_table(f)) # use default names if none given check_namespec(\names, f) } else (\names).nametable if \names & /nametable then impossible("name table: ", image(names)) #line 227 "assembly.nw" #line 246 "assembly.nw" if /nametable & !percent_split(syntax) == "%s" then error("You used %s to format operand ", name, ", but you gave no name specifier") #line 228 "assembly.nw" (return /operand_syntax_tab[name] := operand_syntax(syntax, nametable)) | error("Operand syntax for ", name, " already specified") end #line 253 "assembly.nw" procedure operand_syntax_of(ipt) initial /operand_syntax_tab := table() return \operand_syntax_tab[ipt.name] | case type(ipt.meaning) of { "null" : operand_syntax("%d") # integer "integer" : operand_syntax("%d") # signed field "field" : { n := fieldname_table(symtab[ipt.name]) operand_syntax(if \n then "%s" else "%u", n) } default : impossible("violated default syntax invariant") } end #line 271 "assembly.nw" global asmsyntax procedure set_asmsyntax(cons, operands) local oldoperands initial /asmsyntax := table() #line 288 "assembly.nw" s1 := set(); every insert(s1, inputs_of_operands(operands).name) s2 := set(); every insert(s2, inputs_of(cons).name) every x := !s1 & not member(s2, x) do error("Operand ", x, " given in assembly syntax for ", cons.name, " is not in the original constructor specification") every x := !s2 & not member(s1, x) do warning("Operand ", x, " of constructor ", cons.name, " is not shown in the assembly syntax") #line 276 "assembly.nw" #line 297 "assembly.nw" s1 := set(); every insert(s1, inputs_of_operands(operands, "integer").name) s2 := set(); every insert(s2, inputs_of(cons, "integer").name) every x := !s1 & not member(s2, x) do error("Operand ", x, " of constructor ", cons.name, " is signed in assembly syntax but unsigned in the constructor specification") every x := !s2 & not member(s1, x) do error("Operand ", x, " of constructor ", cons.name, " is unsigned in assembly syntax but signed in the constructor specification") #line 277 "assembly.nw" (/asmsyntax[cons] := operands) | { #line 309 "assembly.nw" oldoperands := asmsyntax[cons] *operands = *oldoperands & if i := 1 to *operands & not operands_match(operands[i], oldoperands[i]) then {dump_em("new", operands); dump_em("old", oldoperands); &fail} else &null #line 278 "assembly.nw" } | error("Conflicting assembly syntax already given for constructor ", cons.name) return end procedure asmoperands(cons) initial /asmsyntax := table() return \asmsyntax[cons] | cons.operands end #line 316 "assembly.nw" procedure operands_match(op1, op2) return case type(op1) == type(op2) of { "literal" : op1.s == op2.s "input" : op1.name == op2.name & op1.meaning === op2.meaning } end #line 323 "assembly.nw" procedure dump_em(ty, ops) writes(&errout, ty, " syntax:") every writes(&errout, x := !ops & case type(x) of { "literal" : x.s "input" : x.name || if type(x.meaning) == "integer" then "!" else "" default : impossible("operand type") }) write(&errout) return end #line 345 "assembly.nw" procedure assembler_proc_name(cons) return if cons.type === instructionctype then cons.name else cons.name || "_asm" # unsafe, but what do you want? end procedure assembler_proc_class(cons) return if \indirectname | cons.type ~=== instructionctype then "static " else "" end #line 358 "assembly.nw" procedure emit_assembler_body(pp, cons) local asmname static bodies_emitted initial bodies_emitted := set() if member(bodies_emitted, cons) then return else insert(bodies_emitted, cons) every create_input_print_proc(pp, inputs_of(cons)) emit_template(pp, "emitter-body.t", "safename", Cnoreserve(assembler_proc_name(cons)), "args", arg_decls(cons), "class", assembler_proc_class(cons)) asmname := consname2asm(cons) if *asmname > 0 & /postfix then emit_asm_printf(pp, "%s", image(asmname)) every o := !asmoperands(cons) do case type(o) of { "literal" : emit_asm_printf(pp, "%s", image(o.s)) "input" : PPxwrites(pp, "$n", create_input_print_proc(pp, o), "(", Cnoreserve(o.name), ");") default : impossible("operand type") } if *asmname > 0 & \postfix then emit_asm_printf(pp, "%s", image(asmname)) if cons.type === instructionctype then emit_asm_printf(pp, "\n") PPxwrite(pp, "$b$n}") end #line 393 "assembly.nw" procedure create_input_print_proc(pp, ipt) return case type(ipt.meaning) of { "string" : "asmprintreloc" "constype" : create_constype_print_proc(pp, ipt.name, ipt.meaning) "integer" : create_integer_print_proc(pp, "signed", ipt, signed_type(fwidth(f := symtab[ipt.name])), operand_syntax_of(ipt)) # maybe this should be forced to %d? "field" : create_integer_print_proc(pp, "unsigned", ipt, unsigned_type(fwidth(f := ipt.meaning)), operand_syntax_of(ipt)) "null" : create_integer_print_proc(pp, "signed", ipt, signed_type(), operand_syntax_of(ipt)) default : impossible("Bad operand value", type(ipt.meaning)) } end #line 410 "assembly.nw" procedure create_integer_print_proc(pp, sign, ipt, argtype, syntax) local namearray, argname, limit if p := lookup_printproc(syntax, argtype) then return p argname := ipt.name emit_template(pp, "int-print-header.t", "name", argname, "type", argtype, "sign", sign) l := percent_split(syntax.syntax) if !l == "%s" then { \syntax.nametable | #line 458 "assembly.nw" error("Tried to use field names to format argument ", argname, ", but no name specifier was given") #line 419 "assembly.nw" #line 450 "assembly.nw" case type(ipt.meaning) of { "field" : limit := 2^fwidth(ipt.meaning) "integer" : limit := 2^ipt.meaning default : { limit := 0; every limit <:= !syntax.nametable; limit +:= 1 } } #line 420 "assembly.nw" namearray := name_array_from_table(syntax.nametable, limit, argname) namearray.storageclass := "static" PPxwrite(pp, pretty(Gdeclnamearray(namearray)), ";") # local name array if type(ipt.meaning) == "null" then PPxwrite(pp, pretty(Sif([ Sguarded(set([literal("0 <= " || argname), literal(argname || " < " || limit)]), Sepsilon()), Sguarded(set(), literal("{asmprintf(asmprintfd, " || image(bad_operand_name(argname, "%d")) || ", " || argname || "); return;}"))]))) } every x := !l do case x of { "%s" : emit_asm_printf(pp, "%s", namearray.codename || "[" || argname || "]") "%d" | "%u" | "%x" : emit_asm_printf(pp, x, argname) "%%" : emit_asm_printf(pp, "%%") default : if match("%", x) then error("Unknown escape ", x, " in syntax string for argument ", argname) else emit_asm_printf(pp, "%s", image(x)) } PPxwrite(pp, "$b$n}") p := "print_" || sign || "_" || argname save_printproc(p, syntax, argtype) return p end #line 470 "assembly.nw" global printproctab procedure printproc_key(syntax, argtype) k := syntax.syntax || "\0" || argtype if find("%s", syntax.syntax) then k ||:= nametablekey(syntax.nametable) return k end procedure lookup_printproc(syntax, argtype) initial /printproctab := table() return \printproctab[printproc_key(syntax, argtype)] end procedure save_printproc(procname, syntax, argtype) initial /printproctab := table() (/printproctab[printproc_key(syntax, argtype)] := procname) | impossible("duplicated print procedures") return procname end #line 498 "assembly.nw" procedure create_constype_print_proc(pp, argname, constype) local call, prefix static constype_syntax initial constype_syntax := operand_syntax("") if p := lookup_printproc(constype_syntax, constype.name) then return p every emit_assembler_body(pp, kept_constructors(constype)) emit_template(pp, "constype-print-header.t", "type", constype.name) s := Stagcase(argname, constype, table()) every cons := kept_constructors(constype) do { #line 519 "assembly.nw" call := [assembler_proc_name(cons), "("] prefix := "" every ipt := inputs_of(cons) do { put(call, prefix); prefix := ", " put(call, pretty(Einstance_input(argname, cons, ipt.name))) } put(call, ");") #line 508 "assembly.nw" s.arms[cons] := literal(call) } PPxwrite(pp, pretty(s), "$b$n}") p := "print_" || constype.name save_printproc(p, operand_syntax(""), constype.name) return p end #line 533 "assembly.nw" procedure percent_split(s) l := [] s ? while not pos(0) do { if not match("%") then put(l, tab(upto('%') | 0)) while match("%") do put(l, move(2)) | error("unescaped % at end of syntax string") } return l end #line 548 "assembly.nw" procedure emit_asm_printf(pp, fmt, args[]) PPxwrites(pp, "$nasmprintf(asmprintfd, ") PPwrites(pp, image(fmt)) every PPwrites(pp, ", ", !args) PPwrites(pp, ");") return end #line 558 "assembly.nw" procedure emit_asm_grammar(outfilename) local outfile verbose("Emitting assembly-language grammar") (outfile := openfile(outfilename, "w")) | error("could not open ", image(outfilename), " for writing") pushtrace("ASMGRAMMAR") write(outfile, "%%") every emit_cons_production(outfile, kept_constructors()) poptrace() return end #line 573 "assembly.nw" procedure nonterminal_name(cons) return if cons.type === instructionctype then "Instruction" else cons.type.name || "Operand" end #line 583 "assembly.nw" procedure emit_cons_production(outfile, cons) local asmname, i, operand_positions, procname every create_field_nonterminal(outfile, inputs_of(cons, "field")) writes(outfile, nonterminal_name(cons), " :") asmname := consname2asm(cons) i := 1 if *asmname > 0 then i +:= emit_literal_syntax(outfile, asmname) operand_positions := [] every o := !asmoperands(cons) do case type(o) of { "literal" : i +:= emit_literal_syntax(outfile, o.s) "input" : { put(operand_positions, "$" || i) i +:= emit_operand_syntax(outfile, o) } default : impossible("operand type") } procname := Cnoreserve(cons.name) write(outfile, " /* ", if cons.type === instructionctype then "" else "$0 = ", (\indirectname || "->" | "") || procname, "(", commaseparate(operand_positions), "); */;") return end #line 612 "assembly.nw" procedure emit_literal_syntax(outfile, s) static alphanum, letters, multichar initial { letters := &letters ++ '_.' alphanum := letters ++ &digits multichar := ["<=", ">=", "!="] } n := 0 s ? { optwhite() while not pos(0) do { if any(letters) then writes(outfile, " ", image(tab(many(alphanum)))) else if any(&digits) then { warning("Can't put digits in assembly syntax") tab(many(&digits)) } else writes(outfile, " ", image(=!multichar | move(1))) n +:= 1 optwhite() } } return n end #line 640 "assembly.nw" global operand_input_syntax_tab procedure emit_operand_syntax(outfile, ipt) initial /operand_input_syntax_tab := table() s := \operand_input_syntax_tab[ipt.name] | case type(ipt.meaning) of { "null" : "Integer" "integer" : "Integer" "field" : field_nonterminal[ipt.meaning] "string" : "Relocatable" "constype" : ipt.meaning.name || "Operand" default : impossible("type of operand") } writes(outfile, " ", s) return 1 end #line 657 "assembly.nw" global field_nonterminal # maps fields to nonterminal names procedure create_field_nonterminal(outfile, ipt) local nt, prefix /field_nonterminal := table() f := ipt.meaning if member(field_nonterminal, f) then return field_nonterminal[f] t := fieldname_table(f := ipt.meaning) return field_nonterminal[f] := if /t then "Integer" else if fprime := key(field_nonterminal) & t === fieldname_table(fprime) then field_nonterminal[fprime] # reuse else { nt := f.name || "Field" write(outfile, nt) prefix := ":" every p := !sort(t, 2) do { writes(outfile, " ", prefix) emit_literal_syntax(outfile, p[1]) write(outfile, " /* $0 = ", p[2], "; */") prefix := "|" } write(outfile, " ;\n") nt } end #line 687 "assembly.nw" procedure strip_asm_whitespace(cons) every o := !cons.operands & type(o) == "literal" do o.s := strip_whitespace(o.s) return cons end procedure strip_whitespace(s) r := "" s ? { while r ||:= tab(upto(' \t')) do tab(many(' \t')) return r || tab(0) } end #============================================================= disassemble.icn #line 5 "disassemble.nw" #====== link pretty procedure emit_disassembler(outfilename) local constypes, constype verbose("Emitting disassemblers") f := openfile(outfilename, "w") | error("Could not open ", image(outfilename), " for writing") pp := PPnew(f) pushtrace("DIS") every create_input_print_proc(pp, inputs_of(kept_constructors())) constypes := set() every insert(constypes, kept_constructors().type) every emit_constype_disassembler(pp, !constypes) return end #line 22 "disassemble.nw" procedure emit_constype_disassembler(pp, constype) emit_template(pp, "disassembler-body.t", "name", (\constype).name | "instruction") PPwrite(pp, "match [next] pc to") l := [] every push(l, kept_constructors(constype)) # reverse order every emit_disassembler_match(pp, !l) PPwrite(pp, "endmatch") PPxwrite(pp, "return next;$b$n}$n") PPwrite(pp) # flush prettyprinter return end #line 43 "disassemble.nw" procedure emit_disassembler_match(pp, cons) local asmname PPxwrites(pp, "| $t$t$t${", cons.name, "(") #line 66 "disassemble.nw" pfx := "" every ipt := inputs_of(cons) do { PPxwrites(pp, pfx, ipt.name) pfx := ", $o" } #line 47 "disassemble.nw" PPxwrites(pp, ")$} => $b$o") asmname := consname2asm(cons) if *asmname > 0 & /postfix then emit_asm_printf(pp, "%s", image(asmname)) every o := !asmoperands(cons) do case type(o) of { "literal" : emit_asm_printf(pp, "%s", image(o.s)) "input" : PPxwrites(pp, "$n", create_input_print_proc(pp, o), "(", Cnoreserve(o.name), ");") default : impossible("operand type") } if *asmname > 0 & \postfix then emit_asm_printf(pp, "%s", image(asmname)) if cons.type === instructionctype then emit_asm_printf(pp, "\n") PPxwrite(pp, "$b$b") end #================================================================== symdis.icn #line 7 "symdis.nw" #====== link pretty procedure emit_symbolic_disassembler(outfilename) local constypes, constype, rty, indarg, m verbose("Emitting symbolic disassemblers") f := openfile(m := outfilename || ".m", "w") | error("Could not open ", image(m), " for writing") pp := PPnew(f) PPwrite(pp, "#include ") PPwrite(pp, "#include <", outfilename, ".h>") pushtrace("SYMDIS") every constype := !\all_types | instructionctype do { rty := if constype === instructionctype & /encode_as_data then "void" else constype.name || "_Instance" indarg := ", struct " || (\indirecttype) || " *create" PPxwrite(pp, rty, " disassemble_", constype.name, "(ProgramCounter pc", \indarg | "", ") {$t") PPwrite(pp, "match pc to") l := [] every push(l, kept_constructors(constype)) # reverse order every emit_symbolic_disassembler_match(pp, !l) PPxwrite(pp, "endmatch$b$n}$n") } return end #line 40 "symdis.nw" procedure emit_symbolic_disassembler_match(pp, cons) local asmname, pfx, call call := if \indirecttype then "(*create->" || Cnoreserve(cons.name) || ")" else cons.name PPxwrites(pp, "| $t$t$t${", cons.original_name, "(") #line 66 "symdis.nw" pfx := "" every ipt := inputs_of(cons) do { PPxwrites(pp, pfx, operand_hack(ipt)) pfx := ", $o" } #line 46 "symdis.nw" PPxwrites(pp, ")$} => $b$o", if cons.type === instructionctype & /encode_as_data then "" else "return ", call, "${($t$t") pfx := "" every ipt := inputs_of(cons) do { PPxwrites(pp, pfx) case type(ipt.meaning) of { "integer" | "field" | "null" : PPwrites(pp, operand_hack(ipt)) "string" : PPwrites(pp, "int_to_raddr(", operand_hack(ipt), ")") "constype" : PPwrites(pp, "disassemble_", ipt.meaning.name, "(", operand_hack(ipt), if \indirecttype then ", create" else "", ")") default : impossible("Bad operand value", type(ipt.meaning)) } pfx := ", $o" } PPxwrite(pp, "$b$b)$};$b$b") return end #line 72 "symdis.nw" procedure operand_hack(ipt) return "the_" || ipt.name end #================================================================ bytecode.icn #line 1 "bytecode.nw" # Generated by the New Jersey Machine-Code Toolkit, version 0.4 of 1/25/96 # command line: tools -icon -foldemit -encoder bytecodex bytecode.spec #include #include "bytecodex.bogus.icn" procedure sign_extend(N, SIZE) local plus, minus plus := iand(N, 2^(SIZE-1) - 1) minus := if iand(N, 2^(SIZE-1)) = 0 then 0 else 2^(SIZE-1) return plus - minus end procedure bc_mark() local _result _result := "" _result ||:= char(13) return _result end procedure bc_array() local _result _result := "" _result ||:= char(77) return _result end procedure bc_set() local _result _result := "" _result ||:= char(29) return _result end procedure bc_procmark() local _result _result := "" _result ||:= char(93) return _result end procedure bc_proc() local _result _result := "" _result ||:= char(45) return _result end procedure bc_stringlit() local _result _result := "" _result ||:= char(109) return _result end procedure bc_null() local _result _result := "" _result ||:= char(61) return _result end procedure bc_lt() local _result _result := "" _result ||:= char(14) return _result end procedure bc_le() local _result _result := "" _result ||:= char(78) return _result end procedure bc_gt() local _result _result := "" _result ||:= char(30) return _result end procedure bc_ge() local _result _result := "" _result ||:= char(94) return _result end procedure bc_ne() local _result _result := "" _result ||:= char(46) return _result end procedure bc_eq() local _result _result := "" _result ||:= char(110) return _result end procedure bc_false() local _result _result := "" _result ||:= char(62) return _result end procedure bc_true() local _result _result := "" _result ||:= char(126) return _result end procedure bc_orb() local _result _result := "" _result ||:= char(7) return _result end procedure bc_and() local _result _result := "" _result ||:= char(71) return _result end procedure bc_not() local _result _result := "" _result ||:= char(23) return _result end procedure bc_add() local _result _result := "" _result ||:= char(87) return _result end procedure bc_sub() local _result _result := "" _result ||:= char(39) return _result end procedure bc_mul() local _result _result := "" _result ||:= char(103) return _result end procedure bc_idiv() local _result _result := "" _result ||:= char(55) return _result end procedure bc_mod() local _result _result := "" _result ||:= char(119) return _result end procedure bc_cl_loc() local _result _result := "" _result ||:= char(15) return _result end procedure bc_force() local _result _result := "" _result ||:= char(95) return _result end procedure bc_known() local _result _result := "" _result ||:= char(47) return _result end procedure bc_if_guard() local _result _result := "" _result ||:= char(63) return _result end procedure bc_neg() local _result _result := "" _result ||:= char(127) return _result end procedure bc_failmsg() local _result _result := "" _result ||:= char(118) return _result end procedure bc_sint(n) local _result _result := "" if -8 <= n < 8 then _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) } return _result end procedure bc_emit_at(n) local _result _result := "" if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(111) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(111) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(111) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(111) } return _result end procedure bc_widen(n) local _result _result := "" if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(38) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(38) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(38) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(38) } return _result end procedure bc_fitsu(n) local _result _result := "" if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(102) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(102) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(102) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(102) } return _result end procedure bc_fitss(n) local _result _result := "" if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(54) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(54) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(54) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(54) } return _result end procedure bc_narrows(n) local _result _result := "" if n ~= 0 & 0 <= n < 32 then _result ||:= char(ishift(iand(n, 16r1f), 3)) else if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(86) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(86) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(86) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(86) } return _result end procedure bc_halt() local _result _result := "" _result ||:= char(0) return _result end procedure bc_narrowu(n) local _result _result := "" if 0 <= n < 32 & n ~= 0 then _result ||:= char(ior(ishift(iand(n, 16r1f), 3), 1)) else if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(22) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(22) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(22) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(22) } return _result end procedure bc_unsat() local _result _result := "" _result ||:= char(1) return _result end procedure bc_bitslice(lo, hi) local _result _result := "" if lo = 0 & 0 <= hi < 32 then _result ||:= char(ior(ishift(iand(hi, 16r1f), 3), 2)) else if -8 <= hi < 8 & -8 <= lo < 8 then { _result ||:= char(ior(ishift(iand(lo, 16rf), 4), 3)) _result ||:= char(ior(ishift(iand(hi, 16rf), 4), 3)) _result ||:= char(6) } else if -8 <= lo < 8 & -128 <= hi < 128 then { _result ||:= char(ior(ishift(iand(lo, 16rf), 4), 3)) _result ||:= char(85) _result ||:= char(iand(hi, 16rff)) _result ||:= char(6) } else if -8 <= lo < 8 & -32768 <= hi < 32768 then { _result ||:= char(ior(ishift(iand(lo, 16rf), 4), 3)) _result ||:= char(101) _result ||:= char(iand(hi, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(hi, -8), 16rffffff), 24), 16rff)) _result ||:= char(6) } else if -8 <= lo < 8 then { _result ||:= char(ior(ishift(iand(lo, 16rf), 4), 3)) _result ||:= char(117) _result ||:= char(iand(hi, 16rff)) _result ||:= char(iand(ishift(hi, -8), 16rff)) _result ||:= char(iand(ishift(hi, -16), 16rff)) _result ||:= char(iand(ishift(hi, -24), 16rff)) _result ||:= char(6) } else if -128 <= lo < 128 & -8 <= hi < 8 then { _result ||:= char(85) _result ||:= char(iand(lo, 16rff)) _result ||:= char(ior(ishift(iand(hi, 16rf), 4), 3)) _result ||:= char(6) } else if -128 <= hi < 128 & -128 <= lo < 128 then { _result ||:= char(85) _result ||:= char(iand(lo, 16rff)) _result ||:= char(85) _result ||:= char(iand(hi, 16rff)) _result ||:= char(6) } else if -128 <= lo < 128 & -32768 <= hi < 32768 then { _result ||:= char(85) _result ||:= char(iand(lo, 16rff)) _result ||:= char(101) _result ||:= char(iand(hi, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(hi, -8), 16rffffff), 24), 16rff)) _result ||:= char(6) } else if -128 <= lo < 128 then { _result ||:= char(85) _result ||:= char(iand(lo, 16rff)) _result ||:= char(117) _result ||:= char(iand(hi, 16rff)) _result ||:= char(iand(ishift(hi, -8), 16rff)) _result ||:= char(iand(ishift(hi, -16), 16rff)) _result ||:= char(iand(ishift(hi, -24), 16rff)) _result ||:= char(6) } else if -32768 <= lo < 32768 & -8 <= hi < 8 then { _result ||:= char(101) _result ||:= char(iand(lo, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(lo, -8), 16rffffff), 24), 16rff)) _result ||:= char(ior(ishift(iand(hi, 16rf), 4), 3)) _result ||:= char(6) } else if -128 <= hi < 128 & -32768 <= lo < 32768 then { _result ||:= char(101) _result ||:= char(iand(lo, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(lo, -8), 16rffffff), 24), 16rff)) _result ||:= char(85) _result ||:= char(iand(hi, 16rff)) _result ||:= char(6) } else if -32768 <= lo < 32768 & -32768 <= hi < 32768 then { _result ||:= char(101) _result ||:= char(iand(lo, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(lo, -8), 16rffffff), 24), 16rff)) _result ||:= char(101) _result ||:= char(iand(hi, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(hi, -8), 16rffffff), 24), 16rff)) _result ||:= char(6) } else if -32768 <= lo < 32768 then { _result ||:= char(101) _result ||:= char(iand(lo, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(lo, -8), 16rffffff), 24), 16rff)) _result ||:= char(117) _result ||:= char(iand(hi, 16rff)) _result ||:= char(iand(ishift(hi, -8), 16rff)) _result ||:= char(iand(ishift(hi, -16), 16rff)) _result ||:= char(iand(ishift(hi, -24), 16rff)) _result ||:= char(6) } else if -8 <= hi < 8 then { _result ||:= char(117) _result ||:= char(iand(lo, 16rff)) _result ||:= char(iand(ishift(lo, -8), 16rff)) _result ||:= char(iand(ishift(lo, -16), 16rff)) _result ||:= char(iand(ishift(lo, -24), 16rff)) _result ||:= char(ior(ishift(iand(hi, 16rf), 4), 3)) _result ||:= char(6) } else if -128 <= hi < 128 then { _result ||:= char(117) _result ||:= char(iand(lo, 16rff)) _result ||:= char(iand(ishift(lo, -8), 16rff)) _result ||:= char(iand(ishift(lo, -16), 16rff)) _result ||:= char(iand(ishift(lo, -24), 16rff)) _result ||:= char(85) _result ||:= char(iand(hi, 16rff)) _result ||:= char(6) } else if -32768 <= hi < 32768 then { _result ||:= char(117) _result ||:= char(iand(lo, 16rff)) _result ||:= char(iand(ishift(lo, -8), 16rff)) _result ||:= char(iand(ishift(lo, -16), 16rff)) _result ||:= char(iand(ishift(lo, -24), 16rff)) _result ||:= char(101) _result ||:= char(iand(hi, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(hi, -8), 16rffffff), 24), 16rff)) _result ||:= char(6) } else { _result ||:= char(117) _result ||:= char(iand(lo, 16rff)) _result ||:= char(iand(ishift(lo, -8), 16rff)) _result ||:= char(iand(ishift(lo, -16), 16rff)) _result ||:= char(iand(ishift(lo, -24), 16rff)) _result ||:= char(117) _result ||:= char(iand(hi, 16rff)) _result ||:= char(iand(ishift(hi, -8), 16rff)) _result ||:= char(iand(ishift(hi, -16), 16rff)) _result ||:= char(iand(ishift(hi, -24), 16rff)) _result ||:= char(6) } return _result end procedure bc_addlit(n) local _result _result := "" if -8 <= n < 8 & n ~= 0 then _result ||:= char(ior(ishift(iand(n, 16rf), 4), 11)) else if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(87) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(87) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(87) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(87) } return _result end procedure bc_cl_loc_force() local _result _result := "" _result ||:= char(11) return _result end procedure bc_bitshift(n) local _result _result := "" if -8 <= n < 8 then _result ||:= char(ior(ishift(iand(n, 16rf), 4), 12)) else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(70) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(70) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(70) } return _result end procedure bc_emit_at_loc(n) local _result _result := "" if n = 1 then _result ||:= char(5) else if n = 2 then _result ||:= char(69) else if n = 4 then _result ||:= char(133) else if n = 8 then _result ||:= char(197) else if -8 <= n < 8 then { _result ||:= char(15) _result ||:= char(95) _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(111) } else if -128 <= n < 128 then { _result ||:= char(15) _result ||:= char(95) _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(111) } else if -32768 <= n < 32768 then { _result ||:= char(15) _result ||:= char(95) _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(111) } else { _result ||:= char(15) _result ||:= char(95) _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(111) } return _result end procedure bc_cla(n) local _result _result := "" if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(79) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(79) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(79) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(79) } return _result end procedure bc_cla_force(n) local _result _result := "" if 0 <= n - 1 < 2 then _result ||:= char(ior(ishift(iand(n - 1, 16r1), 7), 21)) else if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(79) _result ||:= char(95) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(79) _result ||:= char(95) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(79) _result ||:= char(95) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(79) _result ||:= char(95) } return _result end procedure bc_clv(n) local _result _result := "" if n <= 2 & 0 <= n - 1 < 2 then _result ||:= char(ior(ishift(iand(n - 1, 16r1), 7), 37)) else if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(31) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(31) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(31) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(31) } return _result end procedure bc_clv_orb(n) local _result _result := "" if 0 <= n - 1 < 2 then _result ||:= char(ior(ishift(iand(n - 1, 16r1), 7), 53)) else if -8 <= n < 8 then { _result ||:= char(ior(ishift(iand(n, 16rf), 4), 3)) _result ||:= char(31) _result ||:= char(7) } else if -128 <= n < 128 then { _result ||:= char(85) _result ||:= char(iand(n, 16rff)) _result ||:= char(31) _result ||:= char(7) } else if -32768 <= n < 32768 then { _result ||:= char(101) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(sign_extend(iand(ishift(n, -8), 16rffffff), 24), 16rff)) _result ||:= char(31) _result ||:= char(7) } else { _result ||:= char(117) _result ||:= char(iand(n, 16rff)) _result ||:= char(iand(ishift(n, -8), 16rff)) _result ||:= char(iand(ishift(n, -16), 16rff)) _result ||:= char(iand(ishift(n, -24), 16rff)) _result ||:= char(31) _result ||:= char(7) } return _result end #=============================================================== templates.icn procedure halt_template(msg) write(&errout, msg) runerr(1, msg) end procedure emit_template_1(file, bindings) PPxwrites(file, "(*f)(closure, _c->") emit_template_value(file, \bindings["irec"]) | halt_template("key \"irec\" unbound instantiating template") PPxwrites(file, ".") emit_template_value(file, \bindings["input"]) | halt_template("key \"input\" unbound instantiating template") PPxwrite(file, ");") return end procedure template_to_list_1(bindings) local l l := [] put(l, "(*f)(closure, _c->") put(l, \bindings["irec"]) | stop("key \"irec\" unbound instantiating template") put(l, ".") put(l, \bindings["input"]) | stop("key \"input\" unbound instantiating template") put(l, ");\n") return l end procedure emit_template_2(file, bindings) PPxwrites(file, "static void ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_relocfn(RClosure c, RelocCallback f, void *closure) {$t") PPxwrites(file, "") emit_template_value(file, \bindings["ptrtype"]) | halt_template("key \"ptrtype\" unbound instantiating template") PPxwrites(file, " _c = (") emit_template_value(file, \bindings["ptrtype"]) | halt_template("key \"ptrtype\" unbound instantiating template") PPxwrite(file, ") c;") PPxwrites(file, "") emit_template_value(file, \bindings["calls"]) | halt_template("key \"calls\" unbound instantiating template") PPxwrite(file, "$b}") return end procedure template_to_list_2(bindings) local l l := [] put(l, "static void ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_relocfn(RClosure c, RelocCallback f, void *closure) {$t\n") put(l, "") put(l, \bindings["ptrtype"]) | stop("key \"ptrtype\" unbound instantiating template") put(l, " _c = (") put(l, \bindings["ptrtype"]) | stop("key \"ptrtype\" unbound instantiating template") put(l, ") c;\n") put(l, "") put(l, \bindings["calls"]) | stop("key \"calls\" unbound instantiating template") put(l, "$b}\n") return l end procedure emit_template_3(file, bindings) PPxwrites(file, "$t${if (!(${") emit_template_value(file, \bindings["condition"]) | halt_template("key \"condition\" unbound instantiating template") PPxwrites(file, "$})) $c(*fail) (\"") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrites(file, " = ") PPxwrites(file, "%") PPxwrites(file, "d won't fit in ") emit_template_value(file, \bindings["width"]) | halt_template("key \"width\" unbound instantiating template") PPxwrites(file, " ") emit_template_value(file, \bindings["signed"]) | halt_template("key \"signed\" unbound instantiating template") PPxwrite(file, " bits\");$}$b") return end procedure template_to_list_3(bindings) local l l := [] put(l, "$t${if (!(${") put(l, \bindings["condition"]) | stop("key \"condition\" unbound instantiating template") put(l, "$})) $c(*fail) (\"") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, " = ") put(l, "%") put(l, "d won't fit in ") put(l, \bindings["width"]) | stop("key \"width\" unbound instantiating template") put(l, " ") put(l, \bindings["signed"]) | stop("key \"signed\" unbound instantiating template") put(l, " bits\");$}$b\n") return l end procedure emit_template_4(file, bindings) PPxwrites(file, "$t${(*(_c->") emit_template_value(file, \bindings["irec"]) | halt_template("key \"irec\" unbound instantiating template") PPxwrites(file, ".") emit_template_value(file, \bindings["input"]) | halt_template("key \"input\" unbound instantiating template") PPxwrites(file, ".h->relocfn))$o((Instance*)(&_c->") emit_template_value(file, \bindings["irec"]) | halt_template("key \"irec\" unbound instantiating template") PPxwrites(file, ".") emit_template_value(file, \bindings["input"]) | halt_template("key \"input\" unbound instantiating template") PPxwrite(file, "), f, closure);$}$b") return end procedure template_to_list_4(bindings) local l l := [] put(l, "$t${(*(_c->") put(l, \bindings["irec"]) | stop("key \"irec\" unbound instantiating template") put(l, ".") put(l, \bindings["input"]) | stop("key \"input\" unbound instantiating template") put(l, ".h->relocfn))$o((Instance*)(&_c->") put(l, \bindings["irec"]) | stop("key \"irec\" unbound instantiating template") put(l, ".") put(l, \bindings["input"]) | stop("key \"input\" unbound instantiating template") put(l, "), f, closure);$}$b\n") return l end procedure emit_template_5(file, bindings) PPxwrites(file, "typedef struct ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_closure {$t") PPxwrite(file, "ClosureHeader h;") PPxwrite(file, "ClosureLocation loc;") PPxwrites(file, "struct { $t${") emit_template_value(file, \bindings["decls"]) | halt_template("key \"decls\" unbound instantiating template") PPxwrite(file, " $b$c$}} v;$b") PPxwrites(file, "} *") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_Closure;") return end procedure template_to_list_5(bindings) local l l := [] put(l, "typedef struct ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_closure {$t\n") put(l, "ClosureHeader h;\n") put(l, "ClosureLocation loc;\n") put(l, "struct { $t${") put(l, \bindings["decls"]) | stop("key \"decls\" unbound instantiating template") put(l, " $b$c$}} v;$b\n") put(l, "} *") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_Closure;\n") return l end procedure emit_template_6(file, bindings) PPxwrites(file, "typedef struct ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_instance {$t") PPxwrites(file, "") emit_template_value(file, \bindings["tagtype"]) | halt_template("key \"tagtype\" unbound instantiating template") PPxwrite(file, " tag;") PPxwrites(file, "union {$t") emit_template_value(file, \bindings["constructors"]) | halt_template("key \"constructors\" unbound instantiating template") PPxwrite(file, "$b") PPxwrite(file, "} u;$b") PPxwrites(file, "} ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_Instance;") return end procedure template_to_list_6(bindings) local l l := [] put(l, "typedef struct ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_instance {$t\n") put(l, "") put(l, \bindings["tagtype"]) | stop("key \"tagtype\" unbound instantiating template") put(l, " tag;\n") put(l, "union {$t") put(l, \bindings["constructors"]) | stop("key \"constructors\" unbound instantiating template") put(l, "$b\n") put(l, "} u;$b\n") put(l, "} ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_Instance;\n") return l end procedure emit_template_7(file, bindings) PPxwrites(file, "_i.u.") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrites(file, ".") emit_template_value(file, \bindings["l"]) | halt_template("key \"l\" unbound instantiating template") PPxwrites(file, " = ") emit_template_value(file, \bindings["r"]) | halt_template("key \"r\" unbound instantiating template") PPxwrite(file, ";") return end procedure template_to_list_7(bindings) local l l := [] put(l, "_i.u.") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, ".") put(l, \bindings["l"]) | stop("key \"l\" unbound instantiating template") put(l, " = ") put(l, \bindings["r"]) | stop("key \"r\" unbound instantiating template") put(l, ";\n") return l end procedure emit_template_8(file, bindings) PPxwrites(file, "extern ") emit_template_value(file, \bindings["return"]) | halt_template("key \"return\" unbound instantiating template") PPxwrites(file, " ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrites(file, "(") emit_template_value(file, \bindings["args"]) | halt_template("key \"args\" unbound instantiating template") PPxwrite(file, ");") return end procedure template_to_list_8(bindings) local l l := [] put(l, "extern ") put(l, \bindings["return"]) | stop("key \"return\" unbound instantiating template") put(l, " ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "(") put(l, \bindings["args"]) | stop("key \"args\" unbound instantiating template") put(l, ");\n") return l end procedure emit_template_9(file, bindings) PPxwrites(file, "") emit_template_value(file, \bindings["return"]) | halt_template("key \"return\" unbound instantiating template") PPxwrites(file, " (*") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrites(file, ")(") emit_template_value(file, \bindings["args"]) | halt_template("key \"args\" unbound instantiating template") PPxwrite(file, ");") return end procedure template_to_list_9(bindings) local l l := [] put(l, "") put(l, \bindings["return"]) | stop("key \"return\" unbound instantiating template") put(l, " (*") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, ")(") put(l, \bindings["args"]) | stop("key \"args\" unbound instantiating template") put(l, ");\n") return l end procedure emit_template_10(file, bindings) PPxwrites(file, "") emit_template_value(file, \bindings["class"]) | halt_template("key \"class\" unbound instantiating template") PPxwrites(file, "") emit_template_value(file, \bindings["type"]) | halt_template("key \"type\" unbound instantiating template") PPxwrites(file, "_Instance ") emit_template_value(file, \bindings["safename"]) | halt_template("key \"safename\" unbound instantiating template") PPxwrites(file, "(") emit_template_value(file, \bindings["args"]) | halt_template("key \"args\" unbound instantiating template") PPxwrite(file, ") {$t") PPxwrites(file, "") emit_template_value(file, \bindings["type"]) | halt_template("key \"type\" unbound instantiating template") PPxwrites(file, "_Instance _i = { ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_TAG };") PPxwrites(file, "") emit_template_value(file, \bindings["input-tests"]) | halt_template("key \"input-tests\" unbound instantiating template") PPxwrites(file, "") emit_template_value(file, \bindings["assignments"]) | halt_template("key \"assignments\" unbound instantiating template") PPxwrite(file, "return _i;$b") PPxwrite(file, "}") return end procedure template_to_list_10(bindings) local l l := [] put(l, "") put(l, \bindings["class"]) | stop("key \"class\" unbound instantiating template") put(l, "") put(l, \bindings["type"]) | stop("key \"type\" unbound instantiating template") put(l, "_Instance ") put(l, \bindings["safename"]) | stop("key \"safename\" unbound instantiating template") put(l, "(") put(l, \bindings["args"]) | stop("key \"args\" unbound instantiating template") put(l, ") {$t\n") put(l, "") put(l, \bindings["type"]) | stop("key \"type\" unbound instantiating template") put(l, "_Instance _i = { ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_TAG };\n") put(l, "") put(l, \bindings["input-tests"]) | stop("key \"input-tests\" unbound instantiating template") put(l, "") put(l, \bindings["assignments"]) | stop("key \"assignments\" unbound instantiating template") put(l, "return _i;$b\n") put(l, "}\n") return l end procedure emit_template_11(file, bindings) PPxwrites(file, "") emit_template_value(file, \bindings["class"]) | halt_template("key \"class\" unbound instantiating template") PPxwrites(file, "void ") emit_template_value(file, \bindings["safename"]) | halt_template("key \"safename\" unbound instantiating template") PPxwrites(file, "(") emit_template_value(file, \bindings["args"]) | halt_template("key \"args\" unbound instantiating template") PPxwrite(file, ") {$t") return end procedure template_to_list_11(bindings) local l l := [] put(l, "") put(l, \bindings["class"]) | stop("key \"class\" unbound instantiating template") put(l, "void ") put(l, \bindings["safename"]) | stop("key \"safename\" unbound instantiating template") put(l, "(") put(l, \bindings["args"]) | stop("key \"args\" unbound instantiating template") put(l, ") {$t\n") return l end procedure emit_template_12(file, bindings) PPxwrites(file, "static void ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_relocfn(RClosure c, RelocCallback f, void *closure) {") PPxwrite(file, " return;") PPxwrite(file, "}") return end procedure template_to_list_12(bindings) local l l := [] put(l, "static void ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_relocfn(RClosure c, RelocCallback f, void *closure) {\n") put(l, " return;\n") put(l, "}\n") return l end procedure emit_template_13(file, bindings) PPxwrites(file, "$t{ ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_Closure _c;") PPxwrites(file, "_c = (") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrites(file, "_Closure) mc_create_closure_here(sizeof *_c, &") emit_template_value(file, \bindings["clofun"]) | halt_template("key \"clofun\" unbound instantiating template") PPxwrite(file, "_closure_header);") PPxwrites(file, "") emit_template_value(file, \bindings["save"]) | halt_template("key \"save\" unbound instantiating template") PPxwrite(file, "/* this line intentionally left blank */$b") PPxwrite(file, "} ") return end procedure template_to_list_13(bindings) local l l := [] put(l, "$t{ ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_Closure _c;\n") put(l, "_c = (") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_Closure) mc_create_closure_here(sizeof *_c, &") put(l, \bindings["clofun"]) | stop("key \"clofun\" unbound instantiating template") put(l, "_closure_header);\n") put(l, "") put(l, \bindings["save"]) | stop("key \"save\" unbound instantiating template") put(l, "/* this line intentionally left blank */$b\n") put(l, "} \n") return l end procedure emit_template_14(file, bindings) PPxwrites(file, "$t{ ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_Closure _c;") PPxwrites(file, "_c = (") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrites(file, "_Closure) mc_create_closure_at_offset(sizeof *_c, &") emit_template_value(file, \bindings["clofun"]) | halt_template("key \"clofun\" unbound instantiating template") PPxwrites(file, "_closure_header, ") emit_template_value(file, \bindings["offset"]) | halt_template("key \"offset\" unbound instantiating template") PPxwrite(file, ");") PPxwrites(file, "") emit_template_value(file, \bindings["save"]) | halt_template("key \"save\" unbound instantiating template") PPxwrite(file, "/* this line intentionally left blank */$b") PPxwrite(file, "} ") return end procedure template_to_list_14(bindings) local l l := [] put(l, "$t{ ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_Closure _c;\n") put(l, "_c = (") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_Closure) mc_create_closure_at_offset(sizeof *_c, &") put(l, \bindings["clofun"]) | stop("key \"clofun\" unbound instantiating template") put(l, "_closure_header, ") put(l, \bindings["offset"]) | stop("key \"offset\" unbound instantiating template") put(l, ");\n") put(l, "") put(l, \bindings["save"]) | stop("key \"save\" unbound instantiating template") put(l, "/* this line intentionally left blank */$b\n") put(l, "} \n") return l end procedure emit_template_15(file, bindings) PPxwrites(file, "static struct ") emit_template_value(file, \bindings["indirecttype"]) | halt_template("key \"indirecttype\" unbound instantiating template") PPxwrites(file, " encoding_procs = {$t") emit_template_value(file, \bindings["encoders"]) | halt_template("key \"encoders\" unbound instantiating template") PPxwrites(file, "") emit_template_value(file, \bindings["counters"]) | halt_template("key \"counters\" unbound instantiating template") PPxwrite(file, "$b") PPxwrite(file, "};") PPxwrites(file, "struct ") emit_template_value(file, \bindings["indirecttype"]) | halt_template("key \"indirecttype\" unbound instantiating template") PPxwrites(file, " *") emit_template_value(file, \bindings["indirectname"]) | halt_template("key \"indirectname\" unbound instantiating template") PPxwrite(file, " = &encoding_procs;") return end procedure template_to_list_15(bindings) local l l := [] put(l, "static struct ") put(l, \bindings["indirecttype"]) | stop("key \"indirecttype\" unbound instantiating template") put(l, " encoding_procs = {$t") put(l, \bindings["encoders"]) | stop("key \"encoders\" unbound instantiating template") put(l, "") put(l, \bindings["counters"]) | stop("key \"counters\" unbound instantiating template") put(l, "$b\n") put(l, "};\n") put(l, "struct ") put(l, \bindings["indirecttype"]) | stop("key \"indirecttype\" unbound instantiating template") put(l, " *") put(l, \bindings["indirectname"]) | stop("key \"indirectname\" unbound instantiating template") put(l, " = &encoding_procs;\n") return l end procedure emit_template_16(file, bindings) PPxwrites(file, "static void print_") emit_template_value(file, \bindings["sign"]) | halt_template("key \"sign\" unbound instantiating template") PPxwrites(file, "_") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrites(file, "(") emit_template_value(file, \bindings["type"]) | halt_template("key \"type\" unbound instantiating template") PPxwrites(file, " ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, ") {$t") return end procedure template_to_list_16(bindings) local l l := [] put(l, "static void print_") put(l, \bindings["sign"]) | stop("key \"sign\" unbound instantiating template") put(l, "_") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "(") put(l, \bindings["type"]) | stop("key \"type\" unbound instantiating template") put(l, " ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, ") {$t\n") return l end procedure emit_template_17(file, bindings) PPxwrites(file, "static void print_") emit_template_value(file, \bindings["type"]) | halt_template("key \"type\" unbound instantiating template") PPxwrites(file, "(") emit_template_value(file, \bindings["type"]) | halt_template("key \"type\" unbound instantiating template") PPxwrites(file, "_Instance ") emit_template_value(file, \bindings["type"]) | halt_template("key \"type\" unbound instantiating template") PPxwrite(file, ") {$t") return end procedure template_to_list_17(bindings) local l l := [] put(l, "static void print_") put(l, \bindings["type"]) | stop("key \"type\" unbound instantiating template") put(l, "(") put(l, \bindings["type"]) | stop("key \"type\" unbound instantiating template") put(l, "_Instance ") put(l, \bindings["type"]) | stop("key \"type\" unbound instantiating template") put(l, ") {$t\n") return l end procedure emit_template_18(file, bindings) PPxwrite(file, "#include ") PPxwrites(file, "#include ") emit_template_value(file, \bindings["interface"]) | halt_template("key \"interface\" unbound instantiating template") PPxwrite(file, "") PPxwrite(file, "") PPxwrite(file, "#define sign_extend(N,SIZE) \\") PPxwrite(file, " (((int)((N) << (sizeof(unsigned)*8-(SIZE)))) >> (sizeof(unsigned)*8-(SIZE)))") PPxwrite(file, " ") return end procedure template_to_list_18(bindings) local l l := [] put(l, "#include \n") put(l, "#include ") put(l, \bindings["interface"]) | stop("key \"interface\" unbound instantiating template") put(l, "\n") put(l, "\n") put(l, "#define sign_extend(N,SIZE) \\\n") put(l, " (((int)((N) << (sizeof(unsigned)*8-(SIZE)))) >> (sizeof(unsigned)*8-(SIZE)))\n") put(l, " \n") return l end procedure emit_template_19(file, bindings) PPxwrite(file, "#include ") PPxwrites(file, "#include ") emit_template_value(file, \bindings["interface"]) | halt_template("key \"interface\" unbound instantiating template") PPxwrite(file, "") PPxwrite(file, "#include ") PPxwrite(file, "#include ") PPxwrites(file, "extern struct ") emit_template_value(file, \bindings["irname"]) | halt_template("key \"irname\" unbound instantiating template") PPxwrites(file, "_asm *") emit_template_value(file, \bindings["irname"]) | halt_template("key \"irname\" unbound instantiating template") PPxwrite(file, "_asm;") PPxwrites(file, "extern struct ") emit_template_value(file, \bindings["irname"]) | halt_template("key \"irname\" unbound instantiating template") PPxwrites(file, "_asm *") emit_template_value(file, \bindings["irname"]) | halt_template("key \"irname\" unbound instantiating template") PPxwrite(file, "_bin;") PPxwrite(file, "static void checkerfail(char *, ...);") PPxwrite(file, "static void reloc_print(RAddr r);") PPxwrite(file, "") PPxwrite(file, "static void reloc_print(RAddr r) {$t") PPxwrite(file, "assert(location_known(r));") PPxwrites(file, "asmprintf(asmprintfd, \"") PPxwrites(file, "%") PPxwrite(file, "s\", r->label->name);") PPxwrites(file, "/* asmprintf(asmprintfd, \"0x") PPxwrites(file, "%") PPxwrite(file, "08x\", location(r)); */$b") PPxwrite(file, "}") PPxwrite(file, "static void checkerfail(char *fmt, ...) {$t") PPxwrite(file, "va_list ap;") PPxwrite(file, "") PPxwrite(file, "va_start(ap, fmt);") PPxwrite(file, "fprintf(stderr, \"Error in checker: \");") PPxwrite(file, "vfprintf(stderr, fmt, ap);") PPxwrite(file, "fprintf(stderr, \"\\n\");") PPxwrite(file, "va_end(ap);") PPxwrite(file, "exit(1);") PPxwrite(file, "$b}$n") PPxwrite(file, "void *mc_alloc(int size, Mc_alloc_pool pool) {$t") PPxwrite(file, "char *p = (char *)malloc(size);") PPxwrite(file, "return (void *)p;") PPxwrite(file, "$b}$n") PPxwrite(file, "RClosure mc_alloc_closure(size_in_bytes, dest_block, dest_lc)") PPxwrite(file, "unsigned size_in_bytes; RBlock dest_block; unsigned dest_lc; {$t") PPxwrite(file, "RClosure cl;") PPxwrite(file, "checkerfail(\"attempt to call mc_alloc_closure!\");") PPxwrite(file, "return cl;") PPxwrite(file, "$b}$n") PPxwrite(file, "main(){$t") PPxwrite(file, "RBlock rb;") PPxwrite(file, "RAddr reloc;") PPxwrite(file, "fail = &checkerfail;") PPxwrite(file, "asmprintreloc = &reloc_print;") PPxwrite(file, "asmprintfd = stdout;") PPxwrite(file, "rb = block_new(0);") PPxwrite(file, "block_label(rb)->name = \"reloc\";") PPxwrite(file, "set_block(rb);") PPxwrite(file, "set_address(rb, (unsigned)CHKRADDR);") PPxwrite(file, "reloc = addr_new(block_label(rb), 0x0);") PPxwrite(file, "") PPxwrite(file, "printf(\".text\\n\");") PPxwrite(file, "printf(\".globl reloc\\n\");") PPxwrite(file, "printf(\".globl main\\n\");") PPxwrite(file, "printf(\".globl _main\\n\");") PPxwrite(file, "printf(\"reloc:\\n\");") PPxwrite(file, "printf(\"main:\\n\");") PPxwrite(file, "printf(\"_main:\\n\");") PPxwrite(file, "") return end procedure template_to_list_19(bindings) local l l := [] put(l, "#include \n") put(l, "#include ") put(l, \bindings["interface"]) | stop("key \"interface\" unbound instantiating template") put(l, "\n") put(l, "#include \n") put(l, "#include \n") put(l, "extern struct ") put(l, \bindings["irname"]) | stop("key \"irname\" unbound instantiating template") put(l, "_asm *") put(l, \bindings["irname"]) | stop("key \"irname\" unbound instantiating template") put(l, "_asm;\n") put(l, "extern struct ") put(l, \bindings["irname"]) | stop("key \"irname\" unbound instantiating template") put(l, "_asm *") put(l, \bindings["irname"]) | stop("key \"irname\" unbound instantiating template") put(l, "_bin;\n") put(l, "static void checkerfail(char *, ...);\n") put(l, "static void reloc_print(RAddr r);\n") put(l, "\n") put(l, "static void reloc_print(RAddr r) {$t\n") put(l, "assert(location_known(r));\n") put(l, "asmprintf(asmprintfd, \"") put(l, "%") put(l, "s\", r->label->name);\n") put(l, "/* asmprintf(asmprintfd, \"0x") put(l, "%") put(l, "08x\", location(r)); */$b\n") put(l, "}\n") put(l, "static void checkerfail(char *fmt, ...) {$t\n") put(l, "va_list ap;\n") put(l, "\n") put(l, "va_start(ap, fmt);\n") put(l, "fprintf(stderr, \"Error in checker: \");\n") put(l, "vfprintf(stderr, fmt, ap);\n") put(l, "fprintf(stderr, \"\\n\");\n") put(l, "va_end(ap);\n") put(l, "exit(1);\n") put(l, "$b}$n\n") put(l, "void *mc_alloc(int size, Mc_alloc_pool pool) {$t\n") put(l, "char *p = (char *)malloc(size);\n") put(l, "return (void *)p;\n") put(l, "$b}$n\n") put(l, "RClosure mc_alloc_closure(size_in_bytes, dest_block, dest_lc)\n") put(l, "unsigned size_in_bytes; RBlock dest_block; unsigned dest_lc; {$t\n") put(l, "RClosure cl;\n") put(l, "checkerfail(\"attempt to call mc_alloc_closure!\");\n") put(l, "return cl;\n") put(l, "$b}$n\n") put(l, "main(){$t\n") put(l, "RBlock rb;\n") put(l, "RAddr reloc;\n") put(l, "fail = &checkerfail;\n") put(l, "asmprintreloc = &reloc_print;\n") put(l, "asmprintfd = stdout;\n") put(l, "rb = block_new(0);\n") put(l, "block_label(rb)->name = \"reloc\";\n") put(l, "set_block(rb);\n") put(l, "set_address(rb, (unsigned)CHKRADDR);\n") put(l, "reloc = addr_new(block_label(rb), 0x0);\n") put(l, "\n") put(l, "printf(\".text\\n\");\n") put(l, "printf(\".globl reloc\\n\");\n") put(l, "printf(\".globl main\\n\");\n") put(l, "printf(\".globl _main\\n\");\n") put(l, "printf(\"reloc:\\n\");\n") put(l, "printf(\"main:\\n\");\n") put(l, "printf(\"_main:\\n\");\n") put(l, "\n") return l end procedure emit_template_20(file, bindings) PPxwrite(file, "printf(\".text\\n\");") PPxwrite(file, "printf(\".globl _asmoutput\\n\");") PPxwrite(file, "printf(\"_asmoutput:\\n\");") PPxwrite(file, "") return end procedure template_to_list_20(bindings) local l l := [] put(l, "printf(\".text\\n\");\n") put(l, "printf(\".globl _asmoutput\\n\");\n") put(l, "printf(\"_asmoutput:\\n\");\n") put(l, "\n") return l end procedure emit_template_21(file, bindings) PPxwrite(file, "printf(\".text\\n\");") PPxwrite(file, "printf(\".globl _endoutput\\n\");") PPxwrite(file, "printf(\"_endoutput:\\n\");") PPxwrite(file, "exit(0);") PPxwrite(file, "") PPxwrite(file, "") PPxwrite(file, "") PPxwrite(file, "") return end procedure template_to_list_21(bindings) local l l := [] put(l, "printf(\".text\\n\");\n") put(l, "printf(\".globl _endoutput\\n\");\n") put(l, "printf(\"_endoutput:\\n\");\n") put(l, "exit(0);\n") put(l, "\n") put(l, "\n") put(l, "\n") put(l, "\n") return l end procedure emit_template_22(file, bindings) PPxwrites(file, "static struct closure_header ") emit_template_value(file, \bindings["clofun"]) | halt_template("key \"clofun\" unbound instantiating template") PPxwrite(file, "_closure_header = $t") PPxwrites(file, "{ ") emit_template_value(file, \bindings["clofun"]) | halt_template("key \"clofun\" unbound instantiating template") PPxwrites(file, ", ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrites(file, "_relocfn, ") emit_template_value(file, \bindings["uses-pc"]) | halt_template("key \"uses-pc\" unbound instantiating template") PPxwrites(file, ", sizeof (struct ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_closure) };$b") return end procedure template_to_list_22(bindings) local l l := [] put(l, "static struct closure_header ") put(l, \bindings["clofun"]) | stop("key \"clofun\" unbound instantiating template") put(l, "_closure_header = $t\n") put(l, "{ ") put(l, \bindings["clofun"]) | stop("key \"clofun\" unbound instantiating template") put(l, ", ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_relocfn, ") put(l, \bindings["uses-pc"]) | stop("key \"uses-pc\" unbound instantiating template") put(l, ", sizeof (struct ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_closure) };$b\n") return l end procedure emit_template_23(file, bindings) PPxwrites(file, "(*") emit_template_value(file, \bindings["emit"]) | halt_template("key \"emit\" unbound instantiating template") PPxwrites(file, ")(closure, _c->v.") emit_template_value(file, \bindings["input"]) | halt_template("key \"input\" unbound instantiating template") PPxwrite(file, ");") return end procedure template_to_list_23(bindings) local l l := [] put(l, "(*") put(l, \bindings["emit"]) | stop("key \"emit\" unbound instantiating template") put(l, ")(closure, _c->v.") put(l, \bindings["input"]) | stop("key \"input\" unbound instantiating template") put(l, ");\n") return l end procedure emit_template_24(file, bindings) PPxwrites(file, "void ") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "_emitclosure(RClosure c, RelocCallback emit_addr,$t$t") PPxwrite(file, "void (*emit_int)(void *closure, unsigned u), void *closure) $b$b") PPxwrite(file, "{$t ") PPxwrites(file, "") emit_template_value(file, \bindings["ptrtype"]) | halt_template("key \"ptrtype\" unbound instantiating template") PPxwrites(file, " _c = (") emit_template_value(file, \bindings["ptrtype"]) | halt_template("key \"ptrtype\" unbound instantiating template") PPxwrite(file, ") c;") PPxwrites(file, "") emit_template_value(file, \bindings["calls"]) | halt_template("key \"calls\" unbound instantiating template") PPxwrite(file, "$b}") return end procedure template_to_list_24(bindings) local l l := [] put(l, "void ") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "_emitclosure(RClosure c, RelocCallback emit_addr,$t$t\n") put(l, "void (*emit_int)(void *closure, unsigned u), void *closure) $b$b\n") put(l, "{$t \n") put(l, "") put(l, \bindings["ptrtype"]) | stop("key \"ptrtype\" unbound instantiating template") put(l, " _c = (") put(l, \bindings["ptrtype"]) | stop("key \"ptrtype\" unbound instantiating template") put(l, ") c;\n") put(l, "") put(l, \bindings["calls"]) | stop("key \"calls\" unbound instantiating template") put(l, "$b}\n") return l end procedure emit_template_25(file, bindings) PPxwrites(file, "unsigned disassemble_") emit_template_value(file, \bindings["name"]) | halt_template("key \"name\" unbound instantiating template") PPxwrite(file, "(void *state, unsigned pc) {$t") PPxwrite(file, "unsigned next;") return end procedure template_to_list_25(bindings) local l l := [] put(l, "unsigned disassemble_") put(l, \bindings["name"]) | stop("key \"name\" unbound instantiating template") put(l, "(void *state, unsigned pc) {$t\n") put(l, "unsigned next;\n") return l end procedure emit_template_value(file, x) case type(x) of { "string" | "integer" : PPxwrites(file, x) "list" : every emit_template_value(file, !x) default : stop("bad value ", image(x), " used in template") } return end procedure list_to_string(x) return case type(x) of { "string" : x "integer" : string(x) "list" : { s := ""; every s ||:= list_to_string(!x); s } default : stop("bad value ", image(x), " used in template") } end procedure template_to_list(tname, bindings[]) static template_procs local p, t, k initial { template_procs := table() template_procs["reloc-call.t"] := template_to_list_1 template_procs["constructor-labels.t"] := template_to_list_2 template_procs["input-test.t"] := template_to_list_3 template_procs["cons-call.t"] := template_to_list_4 template_procs["closure-type.t"] := template_to_list_5 template_procs["instance-type.t"] := template_to_list_6 template_procs["instance-assignment.t"] := template_to_list_7 template_procs["direct-proto.t"] := template_to_list_8 template_procs["indirect-proto.t"] := template_to_list_9 template_procs["create-instance-body.t"] := template_to_list_10 template_procs["emitter-body.t"] := template_to_list_11 template_procs["no-labels.t"] := template_to_list_12 template_procs["create-closure.t"] := template_to_list_13 template_procs["create-closure-at.t"] := template_to_list_14 template_procs["proc-structure.t"] := template_to_list_15 template_procs["int-print-header.t"] := template_to_list_16 template_procs["constype-print-header.t"] := template_to_list_17 template_procs["assembly-impl.t"] := template_to_list_18 template_procs["checker.t"] := template_to_list_19 template_procs["inchecker.t"] := template_to_list_20 template_procs["afterchecker.t"] := template_to_list_21 template_procs["closure-header.t"] := template_to_list_22 template_procs["emitclo-call.t"] := template_to_list_23 template_procs["emitclo.t"] := template_to_list_24 template_procs["disassembler-body.t"] := template_to_list_25 } p := \template_procs[tname] | stop("Unknown template ", image(tname)) t := table() while k := get(bindings) do t[k] := get(bindings) return p(t) end procedure emit_template(file, tname, bindings[]) static template_procs local p, t, k initial { template_procs := table() template_procs["reloc-call.t"] := emit_template_1 template_procs["constructor-labels.t"] := emit_template_2 template_procs["input-test.t"] := emit_template_3 template_procs["cons-call.t"] := emit_template_4 template_procs["closure-type.t"] := emit_template_5 template_procs["instance-type.t"] := emit_template_6 template_procs["instance-assignment.t"] := emit_template_7 template_procs["direct-proto.t"] := emit_template_8 template_procs["indirect-proto.t"] := emit_template_9 template_procs["create-instance-body.t"] := emit_template_10 template_procs["emitter-body.t"] := emit_template_11 template_procs["no-labels.t"] := emit_template_12 template_procs["create-closure.t"] := emit_template_13 template_procs["create-closure-at.t"] := emit_template_14 template_procs["proc-structure.t"] := emit_template_15 template_procs["int-print-header.t"] := emit_template_16 template_procs["constype-print-header.t"] := emit_template_17 template_procs["assembly-impl.t"] := emit_template_18 template_procs["checker.t"] := emit_template_19 template_procs["inchecker.t"] := emit_template_20 template_procs["afterchecker.t"] := emit_template_21 template_procs["closure-header.t"] := emit_template_22 template_procs["emitclo-call.t"] := emit_template_23 template_procs["emitclo.t"] := emit_template_24 template_procs["disassembler-body.t"] := emit_template_25 } p := \template_procs[tname] | stop("Unknown template ", image(tname)) t := table() while k := get(bindings) do t[k] := get(bindings) p(file, t) return \p end #========================================== /home/lair/nr/src/icon/ebnflex.icn #line 25 "/u/norman/src/ebnf/ebnflex.nw" global token, tval, filename, lineno global thisline, thispos #line 30 "/u/norman/src/ebnf/ebnflex.nw" global EOF #line 34 "/u/norman/src/ebnf/ebnflex.nw" procedure lex(newfile) static toks, infile local eol initial {EOF := " end of file "; /lineno := 0; toks := []; infile := &input; filename := "standard input"} filename := image(infile := \newfile)[6:-1] if \newfile then lineno := 0 if *toks = 1 & token := scantokens(pop(toks)) then return token else if *toks = 2 & (pop(toks) ? { tab(thispos := pop(toks)) if token := scantokens() then { every push(toks, if pos(0) then 1 else &pos | &subject) return token } }) then &null else { while thisline := read(infile) do { lineno +:= 1 thispos := 1 thisline ? if (="#line ", lineno := integer(tab(many(&digits)))-1, =" \"", filename := tab(upto('"')), ="\"", pos(0)) | (="<* LINE ", lineno := integer(tab(many(&digits)))-1, =" \"", filename := tab(upto('"')), ="\" *>", pos(0)) then { } else { if token := scantokens() then { every push(toks, if pos(0) then 1 else &pos | &subject) return token } } } } return token := tval := EOF end #line 74 "/u/norman/src/ebnf/ebnflex.nw" procedure gobble(t) if token == t then return 1(.tval, lex()) end procedure expect(t, nt) return gobble(t) | error("when parsing "||\nt||", " | "", "expected ", image(t), " but found ", image(tval)) end procedure lexwhere(outfile) /outfile := &errout write(outfile, thisline) write(outfile, repl(" ", thispos-1), "^", repl(" ", 0 <= *thisline-thispos) | "", "$") return end procedure erroratfl(file, line, L[]) write ! ([&errout, image(filename), ", line ", lineno, ": "] ||| L) stop() end procedure errorat(loc, L[]) write ! ([&errout, loc, ": "] ||| L) stop() end procedure error(L[]) #line 117 "/u/norman/src/ebnf/ebnflex.nw" write ! ([&errout, image(filename), ", line ", lineno, ": "] ||| L) lexwhere() write(&errout, "token = ", token, " [", image(tval), "]") #line 103 "/u/norman/src/ebnf/ebnflex.nw" stop() end procedure warning(L[]) write ! ([&errout, image(filename), ", line ", lineno, ": Warning -- "] ||| L) end procedure impossible(L[]) push(L, "This can't happen: ") #line 117 "/u/norman/src/ebnf/ebnflex.nw" write ! ([&errout, image(filename), ", line ", lineno, ": "] ||| L) lexwhere() write(&errout, "token = ", token, " [", image(tval), "]") #line 113 "/u/norman/src/ebnf/ebnflex.nw" write(&errout, "\n") &null[0] end #========================================== /home/lair/nr/src/icon/maplist.icn procedure maplist(f, l) local ll, x ll := [] every x := !l do put(ll, f(x) | fail) return ll end procedure maplist2(f, l, a2) local ll, x ll := [] every x := !l do put(ll, f(x, a2) | fail) return ll end procedure maplist3(f, l, a2, a3) local ll, x ll := [] every x := !l do put(ll, f(x, a2, a3) | fail) return ll end #========================================== /home/lair/nr/src/icon/commafy.icn procedure commafy(l, andword) local s, comma, and, i if *l = 0 then return "" /andword := "and" comma := if *l > 2 then ", " else " " and := if *l > 1 then andword || " " else "" s := "" every i := 1 to *l - 1 do s ||:= l[i] || comma return s || and || l[*l] end procedure commaseparate(l, comma) local s, i if *l = 0 then return "" /comma := ", " s := "" every i := 1 to *l - 1 do s ||:= l[i] || comma return s || l[*l] end #=========================================== /home/lair/nr/src/icon/pretty.icn #line 21 "pretty.nw" record iPPprettyprinter( break_deque # holds break info , break_level , buffer # holds characters and markers , current_level , file # gets output , indent_width , left_margin # left margin to take at next break , left_margin_w # left margin used on current line , output_width , total_chars_enqueued , total_chars_flushed , total_pchars_enqueued , total_pchars_flushed ) #line 37 "pretty.nw" procedure PPnew(file, width, indent, leftmargin) return iPPprettyprinter( [], 0, [], 0, file, \indent | 2, \leftmargin | 0, 0, \output_width | 80, 0, 0, 0, 0) end #line 42 "pretty.nw" record iPPmarker(level) record iPPnewline() record iPPindent() record iPPoutdent() record iPPcondbreak(chars_enqueued, level, connected) #line 48 "pretty.nw" procedure PPbegin(pp) pp.current_level +:= 1 return pp end #line 53 "pretty.nw" procedure PPend(pp) pp.current_level -:= 1 pp.break_level >:= pp.current_level return pp end #line 59 "pretty.nw" procedure PPindent(pp) static iPPindentval initial iPPindentval := iPPindent() put(pp.buffer, iPPindentval) pp.total_chars_enqueued +:= 1 return pp end #line 67 "pretty.nw" procedure PPoutdent(pp) static iPPoutdentval initial iPPoutdentval := iPPoutdent() put(pp.buffer, iPPoutdentval) pp.total_chars_enqueued +:= 1 return pp end #line 75 "pretty.nw" procedure PPnewline(pp) static iPPnewlineval initial iPPnewlineval := iPPnewline() pp.break_deque := [] pp.break_level := pp.current_level put(pp.buffer, iPPnewlineval) pp.total_chars_enqueued +:= 1 PPflush(pp) if getenv("PPX") then PPinternal_writes(pp, "$n") if pp.total_pchars_flushed ~= pp.total_pchars_enqueued then stop("bad pp") return pp end #line 89 "pretty.nw" procedure PPoptnl(pp) while *pp.break_deque > 0 & (pp.break_deque[1].level > pp.current_level | (pp.break_deque[1].level = pp.current_level & /pp.break_deque[1].connected)) do pop(pp.break_deque) push(pp.break_deque, iPPcondbreak(pp.total_chars_enqueued, pp.current_level, &null)) return pp end #line 99 "pretty.nw" procedure PPconnnl(pp) static iPPnewlineval initial iPPnewlineval := iPPnewline() if pp.break_level < pp.current_level then { while *pp.break_deque > 0 & pp.break_deque[1].level >= pp.current_level do pop(pp.break_deque) put(pp.buffer, iPPmarker(pp.current_level)) pp.total_chars_enqueued +:= 1 push(pp.break_deque, iPPcondbreak(pp.total_chars_enqueued, pp.current_level, 1)) } else { # take an immediate line break at current_level pp.break_deque := [] put(pp.buffer, iPPnewlineval) pp.total_chars_enqueued +:= 1 PPflush(pp) if getenv("PPX") then PPinternal_writes(pp, "$c") } return pp end #line 118 "pretty.nw" procedure PPwrites(pp, L[]) local outn, leftn every s := string(!L) & *s > 0 do { while iPPwont_fit(pp, s) & *pp.break_deque > 0 do if not iPPtake_outermost_connected_break(pp) then iPPtake_break(pp, pop(pp.break_deque)) if \temp & getenv("PPX") then s := "$f[]" || s put(pp.buffer, s) pp.total_chars_enqueued +:= *s pp.total_pchars_enqueued +:= *s } return pp end #line 132 "pretty.nw" procedure iPPtake_outermost_connected_break(pp) local b if \(!pp.break_deque).connected then { b := pull(pp.break_deque) while /b.connected do b := pull(pp.break_deque) return iPPtake_break(pp, b) } else fail end #line 141 "pretty.nw" procedure iPPtake_break(pp, b) pp.break_level := b.level PPflush(pp, b.chars_enqueued - pp.total_chars_flushed) if getenv("PPX") then PPinternal_writes(pp, "$", if \b.connected then "c" else "o", "(", b.level, ")") if /b.connected then iPPwritenl(pp) pp.break_level >:= pp.current_level return end #line 151 "pretty.nw" procedure iPPwont_fit(pp, s) return (pp.total_pchars_enqueued - pp.total_pchars_flushed) + pp.left_margin_w + *s > pp.output_width end #line 156 "pretty.nw" procedure PPwrite(pp, L[]) PPwrites ! (push(L, pp)) return PPnewline(pp) end #line 161 "pretty.nw" procedure PPflush(pp, len) local limit, temp, count out := 0 while not (out >= \len) & temp := get(pp.buffer) do { count := if type(temp) == "string" then *temp else 1 pp.total_chars_flushed +:= count out +:= count if getenv("PPX") then PPinternal_writes(pp, case type(temp) of { "iPPmarker" : "$m(" || temp.level || ")" "iPPnewline" : "$n" "iPPindent" : "$t" "iPPoutdent" : "$b" }) case type(temp) of { "iPPmarker" : if temp.level <= pp.break_level then iPPwritenl(pp) "iPPnewline" : iPPwritenl(pp) "iPPindent" : pp.left_margin +:= pp.indent_width "iPPoutdent" : pp.left_margin -:= pp.indent_width "string" : { PPinternal_writes(pp, temp); pp.total_pchars_flushed +:= *temp } default : stop("bogus prettyprinter") } } return end #line 187 "pretty.nw" procedure iPPwritenl(pp) pp.left_margin_w := 0 < pp.left_margin | 0 return PPinternal_writes(pp, "\n", left("", pp.left_margin_w)) end #line 192 "pretty.nw" procedure PPxwrites(pp, L[]) every s := !L do s ? { while PPwrites(pp, tab(upto('$\n'))) do if ="$" then { if any('${}tbnoc') then case move(1) of { "$" : PPwrites(pp, "$") "{" : PPbegin(pp) "}" : PPend(pp) "t" : PPindent(pp) "b" : PPoutdent(pp) "n" : PPnewline(pp) "o" : PPoptnl(pp) "c" : PPconnnl(pp) } else if c := move(1) then { write(&errout, "Warning: bad prettyprinting escape $", c, " in ", image(s)) PPwrites(pp, c) } else PPwrites(pp, "$") } else if ="\n" then { PPnewline(pp) } else stop("This can't happen -- fouled upto") PPwrites(pp, tab(0)) } return pp end #line 221 "pretty.nw" procedure PPxwrite(pp, L[]) PPxwrites ! (push(L, pp)) return PPnewline(pp) end #line 226 "pretty.nw" procedure PPinternal_writes(pp, L[]) return case type(pp.file) of { "file" : writes ! (push(L, pp.file)) "string" : every pp.file ||:= !L default : impossible("prettyprinter file") } end #======================================== /home/lair/nr/src/icon/pushtrace.icn ################################################################ global tracestack procedure pushtrace(tr) initial tracestack := [] push(tracestack, &trace) return &trace := case type(tr) of { "string" : integer(getenv(tr)) | 0 default : tr } end procedure poptrace() return &trace := pop(tracestack) end