diff --git a/.gitignore b/.gitignore index 13c89de..c4aea44 100644 --- a/.gitignore +++ b/.gitignore @@ -8,6 +8,7 @@ tmp_scm/ cekf pratt_test tags +xref .generated .*.swp .$*.drawio.* diff --git a/Makefile b/Makefile index 421ec60..0a910e4 100644 --- a/Makefile +++ b/Makefile @@ -23,7 +23,7 @@ ifeq ($(MODE),production) CCMODE:= -O2 EXTRA_DEFINES:= -DPRODUCTION_BUILD -DBUILD_MODE=2 else -$(error invalid MODE $(MODE)) +$(error invalid MODE=$(MODE), allowed values: debugging, testing or production) endif endif endif @@ -145,6 +145,9 @@ $(EXTRA_DOCS): docs/generated/%.md: src/%.yaml tools/makeAST.py src/primitives.y tags: src/* $(EXTRA_TARGETS) ctags src/* $(EXTRA_TARGETS) +xref: src/* $(EXTRA_TARGETS) + ctags -x src/* $(EXTRA_TARGETS) > $@ + $(MAIN_OBJ) $(OBJ): obj/%.o: src/%.c | obj $(CC) $(INCLUDE_PATHS) -c $< -o $@ @@ -193,7 +196,7 @@ generated/UnicodeDigits.inc: unicode/UnicodeData.txt tools/makeUnicodeDigits.py $(PYTHON) ./tools/makeUnicodeDigits.py > $@ realclean: clean - rm -rf tags unicode + rm -rf tags xref unicode clean: deps rm -rf $(TARGET) obj callgrind.out.* generated $(TEST_TARGETS) .typedefs src/*~ .generated gmon.out *.fnc core.* diff --git a/docs/generated/anf.md b/docs/generated/anf.md index 4dd04ca..0d76a74 100644 --- a/docs/generated/anf.md +++ b/docs/generated/anf.md @@ -25,8 +25,6 @@ AexpAnnotatedVar --var--> HashSymbol AexpPrimApp --type--> AexpPrimOp AexpPrimApp --exp1--> Aexp AexpPrimApp --exp2--> Aexp -AexpUnaryApp --type--> AexpUnaryOp -AexpUnaryApp --exp--> Aexp AexpList --exp--> Aexp AexpList --next--> AexpList AexpIntList --integer--> int @@ -80,7 +78,6 @@ Aexp --biginteger--> MaybeBigInt Aexp --littleinteger--> int Aexp --character--> character Aexp --prim--> AexpPrimApp -Aexp --unary--> AexpUnaryApp Aexp --makeVec--> AexpMakeVec Aexp --namespaces--> AexpNamespaces Cexp --back--> void_ptr @@ -101,7 +98,6 @@ Exp --let--> ExpLet Exp --lookup--> ExpLookup AexpAnnotatedVarType["enum AexpAnnotatedVarType"] AexpPrimOp["enum AexpPrimOp"] -AexpUnaryOp["enum AexpUnaryOp"] AexpNamespaceArray["AexpNamespaceArray[]"] --entries--> AexpNamespace CTEnvArray["CTEnvArray[]"] --entries--> CTEnv CexpCondCasesVal diff --git a/docs/generated/builtins.md b/docs/generated/builtins.md index d638e26..fcadab0 100644 --- a/docs/generated/builtins.md +++ b/docs/generated/builtins.md @@ -12,6 +12,7 @@ BuiltIn --implementation--> void_ptr BuiltInImplementation --implementation--> void_ptr BuiltInImplementation --nargs--> int BuiltInMemBuf --buffer--> string +BuiltInMemBuf --index--> index BuiltInMemBuf --size--> size BuiltInArgs["BuiltInArgs[]"] --entries--> TcType BuiltIns["BuiltIns[]"] --entries--> BuiltIn diff --git a/docs/generated/lambda.md b/docs/generated/lambda.md index 90e92d0..ca1976d 100644 --- a/docs/generated/lambda.md +++ b/docs/generated/lambda.md @@ -16,8 +16,6 @@ LamVarList --next--> LamVarList LamPrimApp --type--> LamPrimOp LamPrimApp --exp1--> LamExp LamPrimApp --exp2--> LamExp -LamUnaryApp --type--> LamUnaryOp -LamUnaryApp --exp--> LamExp LamSequence --exp--> LamExp LamSequence --next--> LamSequence LamList --exp--> LamExp @@ -116,7 +114,6 @@ LamExp --var--> HashSymbol LamExp --stdint--> int LamExp --biginteger--> MaybeBigInt LamExp --prim--> LamPrimApp -LamExp --unary--> LamUnaryApp LamExp --list--> LamSequence LamExp --makeVec--> LamMakeVec LamExp --construct--> LamConstruct @@ -156,7 +153,6 @@ LamInfo --typeConstructorInfo--> LamTypeConstructorInfo LamInfo --namespaceInfo--> LamContext LamInfo --nsid--> int LamPrimOp["enum LamPrimOp"] -LamUnaryOp["enum LamUnaryOp"] LamNamespaceArray["LamNamespaceArray[]"] --entries--> LamExp LamExpVal LamExpType diff --git a/fn/dictionary.fn b/fn/dictionary.fn index 3b9d5b5..fd89ad6 100644 --- a/fn/dictionary.fn +++ b/fn/dictionary.fn @@ -32,7 +32,7 @@ print Dict(pt, pu, d) { d; } -unsafe fn foreach { +fn foreach { (_, E) | (_, EE) { nothing } (f, D(_, l, #(t, u), r)) { foreach(f, l); @@ -42,6 +42,26 @@ unsafe fn foreach { } } +fn keys (d) { + let fn h { + (E, lst) | (EE, lst) { lst } + (D(_, l, #(k, _), r), lst) { + h(l, k @ h(r, lst)) + } + } + in h(d, []) +} + +fn values (d) { + let fn h { + (E, lst) | (EE, lst) { lst } + (D(_, l, #(_, v), r), lst) { + h(l, v @ h(r, lst)) + } + } + in h(d, []) +} + fn balance { (B, D(R, D(R, a, x, b), y, c), z, d) | (B, D(R, a, x, D(R, b, y, c)), z, d) | @@ -53,7 +73,7 @@ fn balance { } // #t -> Dict(#t, #u) -> Maybe(#u) -unsafe fn lookup { +fn lookup { (_, E) | (_, EE) { nothing } (x, D(_, _, #(x, y), _)) { some(y) } (x, D(_, a, #(y, _), b)) { @@ -72,7 +92,7 @@ fn insert(x, v, s) { (D(R, a, x, t=D(R, _, _, _))) { D(B, a, x, t) } (t) { t } } - unsafe fn ins { + fn ins { (x, EE) | (x, E) { D(R, E, #(x, v), E) } (x, D(c, a, #(x, _), b)) { D(c, a, #(x, v), b) } (x, D(color, a, s=#(y, _), b)) { @@ -89,7 +109,7 @@ fn insert(x, v, s) { fn delete(x, s) { let - unsafe fn del { + fn del { (_, EE, throw) | (_, E, throw) { throw(s) } (x, D(R, E, #(x, _), E), _) { E } (x, D(B, E, #(x, _), E), _) { EE } @@ -152,5 +172,5 @@ fn delete(x, s) { } fn make (keys, values) { - list.foldl(unsafe fn (#(k, v), d) { insert(k, v, d) }, E, list.zip(keys, values)) + list.foldl(fn (#(k, v), d) { insert(k, v, d) }, E, list.zip(keys, values)) } diff --git a/fn/fns.fn b/fn/fns.fn new file mode 100644 index 0000000..c61e6b6 --- /dev/null +++ b/fn/fns.fn @@ -0,0 +1 @@ +print (car of cdr of cdr)([[], [], ['a']]); diff --git a/fn/listutils.fn b/fn/listutils.fn index 5b747c7..dd38b72 100644 --- a/fn/listutils.fn +++ b/fn/listutils.fn @@ -7,6 +7,18 @@ fn member { (x, _ @ t) { member(x, t) } } +// unique: list(#a) -> list(#a) +fn unique { + ([]) { [] } + (h @ t) { + if (member(h, t)) { + unique(t) + } else { + h @ unique(t) + } + } +} + // exclude: list(#t) -> list(#t) -> list(#t) fn exclude { (items, []) { [] } @@ -59,8 +71,11 @@ fn foldr(func, acc, lst) { } // foldl1 (#a -> #a -> #a) -> list(#a) -> #a -unsafe fn foldl1(func, h @ t) { - foldl(func, h, t) +fn foldl1 { + (func, h @ t) { + foldl(func, h, t) + } + (_, _) { error("foldl1") } } // foldr1 (#a -> #a -> #a) -> list(#a) -> #a @@ -82,22 +97,61 @@ fn scanl (func, acc, lst) { in scan([acc], lst) } -// filter: (#a -> bool) list(#a) -> list(#a) -// TCO, but does not preserve order -fn filter(func, lst) { +// filter: (#a -> bool) -> list(#a) -> list(#a) +fn filter { + (f, []) { [] } + (f, h @ t) { + if (f(h)) { + h @ filter(f, t) + } else { + filter(f, t) + } + } +} + +// filter_out: (#a -> bool) -> list(#a) -> list(#a) +fn filter_not (f, l) { + filter(fn (x) { not f(x) }, l) +} + +// indices: (#a -> bool) -> list(#a) -> list(number) +// like filter but returns the indices of the matching elements +fn indices(f, lst) { let fn helper { - ([], res) { res } - (h @ t, res) { - if (func(h)) { - helper(t, h @ res) + ([], _) { [] } + (h @ t, n) { + if (f(h)) { + n @ helper(t, n + 1) } else { - helper(t, res) + helper(t, n + 1) } } } in - helper(lst, []) + helper(lst, 0) +} + +// nths: list(number) -> list(#a) -> list(#a) +fn nths (indices, lst) { + map(fn (n) { nth(n, lst) }, indices) +} + +// except_nth: number -> list(#a) -> list(#a) +fn except_nth (index, lst) { + let + fn helper { + ([], _) { [] } + (h @ t, n) { + if (n == index) { + helper(t, n + 1) + } else { + h @ helper(t, n + 1) + } + } + } + in + helper(lst, 0) } // concat: list(list(#a)) -> list(#a) @@ -149,9 +203,10 @@ fn repeat_prefix(n, v, tail) { } // nth: number -> list(#a) -> #a -unsafe fn nth { +fn nth { (0, h @ _) { h } (n, _ @ t) { nth(n - 1, t) } + (_, _) { error("nth") } } // sum: list(number) -> number @@ -175,8 +230,19 @@ fn zipWith { (_, _, _) { [] } } +// unzip: list(#(#a, #b)) -> #(list(#a), list(#b)) +fn unzip { + ([]) { #([], []) } + (#(x, y) @ rest) { + switch (unzip(rest)) { + (#(xs, ys)) { #(x @ xs, y @ ys) } + } + } +} + // last: list(#a) -> #a -unsafe fn last { +fn last { + ([]) { error("last") } ([a]) { a } (_ @ t) { last(t) } } diff --git a/fn/rewrite/README.md b/fn/rewrite/README.md new file mode 100644 index 0000000..823354a --- /dev/null +++ b/fn/rewrite/README.md @@ -0,0 +1,14 @@ +# Rewrite + +An exploratory sub-project to investigate re-writing F♯ in F♯. For +this to be practical we would need to target LLVM rather than a bytecode +interpreter. + +* [ceskf.fn](ceskf.fn) - The core CESKF machine. +* [infer.fn](infer.fn) - Type inference. +* [interpreter.fn](interpreter.fn) - A naïve lambda interpreter demo. +* [normalize.fn](normalize.fn) - ANF conversion. +* [petterson92.fn](petterson92.fn) - Pettersson's Term Pattern Matching Compiler algorithm. +* [pratt.fn](pratt.fn) - Pratt Parser. + * [pratt_lexer.fn](pratt_lexer.fn) - Lexer Support for the Parser. + * [pratt_sexpr.fn](pratt_sexpr.fn) - Target Symbolic Expressions for the parser. diff --git a/fn/ceskf.fn b/fn/rewrite/ceskf.fn similarity index 97% rename from fn/ceskf.fn rename to fn/rewrite/ceskf.fn index 0a3694f..4d08f89 100644 --- a/fn/ceskf.fn +++ b/fn/rewrite/ceskf.fn @@ -22,7 +22,7 @@ // in a purely functional language. It does include the Fail register though, // making this technically a CESKF machine let - link "listutils.fn" as list; + link "../listutils.fn" as list; typedef prim { add | sub | mul | div } @@ -142,11 +142,11 @@ let (Σ(cexp(letrec(bindings, body)), ρ, σ, κ, ς)) { let inds = indices(bindings, σ); - ks = list.map(unsafe fn (#(k, _)) { k }, bindings); + ks = list.map(fn (#(k, _)) { k }, bindings); e = zipEnv(ks, inds, ρ); tempStore = list.repeat_prefix(list.length(inds), f, σ); s = list.map_prefix(A(e, tempStore), - list.map(unsafe fn (#(_, v)) { v }, bindings), + list.map(fn (#(_, v)) { v }, bindings), σ); in Σ(body, e, s, κ, ς) diff --git a/fn/infer.fn b/fn/rewrite/infer.fn similarity index 100% rename from fn/infer.fn rename to fn/rewrite/infer.fn diff --git a/fn/interpreter.fn b/fn/rewrite/interpreter.fn similarity index 100% rename from fn/interpreter.fn rename to fn/rewrite/interpreter.fn diff --git a/fn/normalize.fn b/fn/rewrite/normalize.fn similarity index 100% rename from fn/normalize.fn rename to fn/rewrite/normalize.fn diff --git a/fn/rewrite/pettersson92.fn b/fn/rewrite/pettersson92.fn new file mode 100644 index 0000000..45202e6 --- /dev/null +++ b/fn/rewrite/pettersson92.fn @@ -0,0 +1,752 @@ +let +/////////////////////////////////////////////////////////////////////////// +// PRELIMINARIES +/////////////////////////////////////////////////////////////////////////// + link "../ioutils.fn" as io; + link "../dictionary.fn" as dict; + link "../listutils.fn" as lst; + + infix left 80 "=>" fn (arg, fun) { fun(arg) }; + infix left 80 "|>" fn (l, f) { lst.map(f, l) }; + infix left 80 "?" fn (l, n) { lst.nth(n, l) }; + infix left 80 "??" fn (l, ns) { lst.nths(ns, l) }; + infix left 80 ".." lst.range; + prefix 85 "$" io.to_string; + + // input data structures + typedef pattern { + wildcard | + variable(string) | + const(number) | + ctor(string, list(pattern)) | + tuple(list(pattern)) | + named(string, pattern) | // input name=pattern + comparison(string) | // output re-used variable in subsequent pattern + tagged(string, pattern) // output tag=pattern + } + + print pattern(p) { + let + fn i { + ([]) { "" } + (p @ []) { h(p) } + (p @ t) { h(p); puts(", "); i(t) } + } + fn h { + (wildcard) { puts("_") } + (variable(name)) { puts('$' @ name) } + (comparison(tag)) { puts("="); puts(tag) } + (const(n)) { puts($n) } + (ctor(tag, pats)) { + puts(tag); + if (lst.length(pats) > 0) { + puts("("); i(pats); puts(")") + } else { "" } + } + (tuple(pats)) { + puts("#("); i(pats); puts(")") + } + (named(name, p)) { puts('$' @ name); puts(":="); h(p) } + (tagged(tag, p)) { puts(tag); putc('='); h(p) } + } + in h(p); p + } + + // DAG components (state table) + alias substs = dict.Dict(string, string); + alias refcounts = dict.Dict(string, number); + + typedef Arc { arc(pattern, list(string), tpmc) } + + typedef tpmc { + final(string, list(string), number, substs, code) | + test(string, string, list(string), number, list(Arc)) + } + + print tpmc(state) { + let fn h { + (final(stamp, free, refcount, substs, code)) { + puts("FINAL stamp:"); + puts(stamp); + puts(" refcount:"); + putn(refcount); + puts(" free:"); + print(free); + puts(" substs:"); + print(substs); + puts(" code:"); + print(code); + "" + } + (test(stamp, var, free, refcount, arcs)) { + let fn a { + (arc(pat, free, s) @ t) { + puts("ARC pat::"); + print(pat); + puts(" free:"); + print(free); + puts(" => state:"); + h(s); + puts(";\n"); + a(t) + } + ([]) { "" } + } in + puts("TEST stamp:"); + puts(stamp); + puts(" var:"); + puts(var); + puts(" free:"); + print(free); + puts(" refcount:"); + putn(refcount); + puts(" arcs:[\n"); + a(arcs); + puts("]\n"); + } + } + in h(state); + state; + } + + // Intermediate Representation (output) + typedef code { + symbol(string) | + case(code, list(code)) | + when(pattern, code) | + letrec(list(#(code, code)), code) | + lambda(list(code), code) | + apply(code, list(code)) + } + + print code(c) { + let + fn pargs { + ([]) { "" } + ([a]) { h(0, false, a) } + (a @ b) { h(0, false, a); puts(", "); pargs(b) } + } + fn h { + (n, dp, symbol(name)) { pad(n, dp); puts(name) } + (n, dp, case(c, cases)) { + pad(n, dp); + puts("consider("); + h(n, false, c); + puts(") {\n"); + cases |> fn (c) { h(n + 1, true, c); puts("\n"); }; + pad(n, true); puts("}"); + } + (n, dp, when(p, c)) { + pad(n, dp); + puts("when "); + print(p); + h(n + 1, true, c); + } + (n, dp, letrec(defs, body)) { + pad(n, dp); + puts("let\n"); + defs |> fn (#(sym, val)) { + h(n + 1, true, sym); + puts(" = "); + h(n + 1, false, val); + puts("\n"); + }; + pad(n, true); + puts("in\n"); + h(n + 1, true, body); + } + (n, dp, lambda(args, body)) { + pad(n, dp); + puts("fn ("); + pargs(args); + puts(") {\n"); + h(n + 1, true, body); + puts("\n"); + pad(n, true); + puts("}"); + } + (n, dp, apply(exp, args)) { + h(n, dp, exp); + puts("("); + pargs(args); + puts(")"); + } + } + fn pad(n, dp) { + puts(lst.repeat(if(dp){n * 2} else {0}, ' ')) + } + in + h(0, true, c); + c; + } + + // makeTag: string -> number -> string + fn makeTag (base, n) { base @@ "$" @@ $n } + + // makeLabel: tpmc -> string + fn makeLabel { + (final(stamp, _, _, _, _)) { stamp } + (test(_, var, _, _, arcs)) { + let fn arcLabel (arc(pat, _, s)) { + $pat @@ "=>" @@ makeLabel(s) + } + in + var @@ + "[" @@ + lst.join(",", arcs |> arcLabel) @@ + "]"; + } + } + +/////////////////////////////////////////////////////////////////////////// +// STAGE 1 RENAMING +/////////////////////////////////////////////////////////////////////////// + + // rename: list(#(list(pattern), code)) -> + // #(list(list(pattern)), list(tpmc)) + fn rename(rows) { + let + // mapTag: string -> number -> substs -> + // list(pattern) -> #(list(pattern), substs) + fn mapTag { + (_, _, d, []) { #([], d) } + (base, n, d, pat @ pats) { + let + // tag: string -> pattern -> substs -> + // #(pattern, substs) + fn tag { + (base, wildcard, d) { + #(tagged(base, wildcard), d) + } + (base, variable(name), d) { + switch (dict.lookup(name, d)) { + (nothing) { + #(tagged(base, wildcard), + dict.insert(name, base, d)) + } + (some(other)) { + #(tagged(base, comparison(other)), d) + } + } + } + (base, c = const(_), d) { + #(tagged(base, c), d) + } + (base, ctor(name, pats), d) { + mapTag(base, 0, d, pats) => + fn (#(pats, d)) { + #(tagged(base, ctor(name, pats)), d) + } + } + (base, tuple(pats), d) { + mapTag(base, 0, d, pats) => + fn (#(pats, d)) { + #(tagged(base, tuple(pats)), d) + } + } + (base, named(name, pat), d) { + tag(base, pat, dict.insert(name, base, d)) + } + (_, comparison(t), _) { + error("already compared: " @@ t) + } + (_, tagged(t, _), _) { + error("already tagged: " @@ t) + } + } + in + tag(makeTag(base, n), pat, d) => fn (#(pat, d)) { + mapTag(base, n + 1, d, pats) => + fn (#(pats, d)) { + #(pat @ pats, d) + } + } + } + } + // applySubsts: substs -> code -> code + fn applySubsts (substs, target) { + let fn h { + (symbol(s)) { + switch (dict.lookup(s, substs)) { + (some(v)) { symbol(v) } + (nothing) { symbol(s) } + } + } + (case(cond, rules)) { case(h(cond), rules |> h) } + (when(pattern, action)) { when(pattern, h(action)) } + (letrec(defs, body)) { + letrec(defs |> fn { + (#(name, value)) { #(h(name), h(value)) } + }, h(body)) + } + (lambda(args, code)) { lambda(args |> h, h(code)) } + (apply(code, args)) { apply(h(code), args |> h) } + } + in h(target) + } + // renameRow: #(list(pattern), code) -> #(list(pattern), tpmc) + fn renameRow (#(row, target, label)) { + mapTag("x", 0, dict.E, row) => fn(#(pats, substs)) { + #(pats, + final(label, + [], + 1, + substs, + applySubsts(substs, target))) + } + } + // labelRows: list(#(list(pattern), code)) -> + // list(#(list(pattern), code, string)) + fn labelRows (rows) { + let fn h { + ([], _) { [] } + (#(pats, body) @ rest, n) { + #(pats, body, "Q$" @@ $n) @ h(rest, n + 1) + } + } + in h(rows, 0) + } + in + rows => labelRows |> renameRow => lst.unzip + } + +/////////////////////////////////////////////////////////////////////////// +// STAGE 2 Generate the DFA +/////////////////////////////////////////////////////////////////////////// + + // match: #(list(list(pattern)), list(tpmc)) -> tpmc + fn match (#(M, S)) { + if (lst.all(simple, M?0)) { + variableRule(S) + } else { + patternRule(M, S) + } + } + + // variableRule: list(tpmc) -> tpmc + fn variableRule(S) { S?0 } + + // patternRule: list(list(pattern)) -> list(tpmc) -> tpmc + fn patternRule (M, S) { + let + // find the first index of a column in M that has a + // constructor in its top position + index = lst.indices(fn (x) { not simple(x) }, M ? 0) ? 0; + // let N be that column in M + N = M |> lst.nth(index); + // let M-N be a matrix of all the columns in M except N + M_N = M |> lst.except_nth(index); + // for each constructor c in N + arcs = lst.filter_not(simple, N) |> fn (c) { + let + // let {i_1 .. i_j} be the row-indices of the patterns + // in N that match c + i1_ij = rowsThatMatch(c, N); + // let {pat_1 .. pat_j} be the patterns in the column + // corresponding to those indices + pat1_patj = N ?? i1_ij; + // let n be the arity of the constructor c + n = arity(c); + // For each pat_i, its n sub-patterns are extracted; + // if pat_i is a wildcard, n wildcards are produced + // instead, each tagged with the right path variable. + // This results in a pattern matrix A with n columns + // and j rows. + A = pat1_patj |> unsafe fn { + (tagged(_, ctor(_, pats))) | + (tagged(_, tuple(pats))) { pats } + (tagged(tag, _)) { + makeTags(tag, n) + } + }; + // This matrix A is then appended to the result of + // selecting, from each column in the rest of the + // original matrix, those rows whose indices are in + // {i_1 .. i_j}. + B = M_N ?? i1_ij; + C = lst.zipWith(append, B, A); + // Finally the indices are used to select the + // corresponding final states X that go with these + // rows. + X = S ?? i1_ij; + in + // The arc for the constructor c is now defined as + // (c’,state), where c’ is c with any immediate + // sub-patterns replaced by their path variables + // (thus c’ is a simple pattern), and state is the + // result of recursively applying match to the new + // matrix and the new sequence of final states. + arc(simplify(c, n), [], match(#(C, X))) + }; + // deduplicate + uarcs = lst.unique(arcs); + in + // Finally, the possibility for matching failure is considered. + if (arcsAreExhaustive(uarcs)) { + // If the set of constructors is exhaustive, then no more + // arcs are computed. + let var = varName(N?0); + in test("L_" @@ var, var, [], 1, uarcs) + } else { + // Otherwise, a default arc (_,state) is the last arc. + let var = varName(N?0); + in test("LD_" @@ var, + var, + [], + 1, + uarcs @@ [makeDefaultArc(N, M_N, S)]) + } + } + + // varName: pattern -> string + fn varName { + (tagged(x, _)) { x } + (err) { error("varName:" @@ $err) } + } + + // makeErrorArc: list(pattern) => Arc + fn makeErrorArc { + (tagged(x, _) @ _) { + arc(tagged(x, wildcard), + [], + final("error", [], 1, dict.E, symbol("error"))) + } + (_) { error("makeErrorArc") } + } + + // makeDefaultArc: list(pattern) -> list(list(pattern)) -> + // list(tpmc) -> Arc + fn makeDefaultArc (N, M_N, S) { + // If there are any wildcard patterns in the selected + // column, then their rows are selected from the rest + // of the matrix and the final states, and the state + // is the result of applying match to the new matrix + // and states. Otherwise, the error state is used + // after its reference count has been incremented. + switch (lst.indices(patternIsWildcard, N)) { + ([]) { makeErrorArc(N) } + (wildcards) { + let M_Ns = M_N ?? wildcards; + Ss = S ?? wildcards; + in + arc(tagged(varName(N?0), wildcard), + [], match(#(M_Ns, Ss))) + } + } + } + + // patternIsWildcard: pattern -> bool + fn patternIsWildcard { + (tagged(_, wildcard)) { true } + (_) { false } + } + + // arcsAreExhaustive: list(Arc) -> bool + fn arcsAreExhaustive { + ([]) { false } + (arcs = arc(tagged(_, ctor(c, _)), _, _) @ _) { + ctorsAreExhaustive(arcs) + } + (arc(tagged(_, const(_)), _, _) @ _) { false } + (arc(tagged(_, comparison(_)), _, _) @ _) { false } + (_) { true } + } + + // ctorsAreExhaustive: list(Arc) -> bool + fn ctorsAreExhaustive { + (arc(tagged(_, ctor("cons", _)), _, _) @ arcs) { + lst.any(fn { + (arc(tagged(_, ctor("nil", _)), _, _)) { true } + (_) { false } + }, + arcs) + } + (arc(tagged(_, ctor("nil", _)), _, _) @ arcs) { + lst.any(fn { + (arc(tagged(_, ctor("cons", _)), _, _)) { true } + (_) { false } + }, + arcs) + } + (_) { false } + } + + // simplify: pattern -> number -> pattern + fn simplify { + (tagged(tag, ctor(name, _)), n) { + tagged(tag, ctor(name, makeTags(tag, n))) + } + (tagged(tag, tuple(_)), n) { + tagged(tag, tuple(makeTags(tag, n))) + } + (x, _) { x } + } + + // makeTags: string -> number -> list(pattern) + fn makeTags(tag, n) { + 0 .. n - 1 |> makeTag(tag) |> fn (t) { tagged(t, wildcard) } + } + + // arity: pattern -> number + fn arity { + (tagged(_, ctor(_, l))) | + (tagged(_, tuple(l))) { lst.length(l) } + (tagged(_, const(_))) { 0 } + (tagged(_, comparison(_))) { 0 } + (x) { error("arity failed on " @@ $x) } + } + + // rowsThatMatch: pattern -> list(pattern) -> list(pattern) + fn rowsThatMatch(c, N) { + let + fn ctorMatches { + (tagged(_, const(n)), tagged(_, const(n))) { true } + (tagged(_, ctor(s, _)), tagged(_, ctor(s, _))) { true } + (tagged(_, tuple(a)), tagged(_, tuple(b))) { lst.length(a) == lst.length(b) } + (_, tagged(_, comparison(_))) { true } + (_, tagged(_, wildcard)) { true } + (_, _) { false } + } + fn helper { + (_, []) { [] } + (n, pat @ pats) { + if (ctorMatches(c, pat)) { + n @ helper(n + 1, pats) + } else { + helper(n + 1, pats) + } + } + } + in helper(0, N) + } + + // simple: pattern -> bool + fn simple { + (tagged(_, ctor(_, _))) { false } + (tagged(_, tuple(_))) { false } + (tagged(_, const(_))) { false } + (tagged(_, comparison(_))) { false } + (_) { true } + } + +/////////////////////////////////////////////////////////////////////////// +// STAGE 3 Optimize the DFA +/////////////////////////////////////////////////////////////////////////// + + // countStates: tpmc -> #(tpmc, refcounts) + fn countStates (dfa) { + let + // collectStates: tpmc -> refcounts -> refcounts + fn collectStates { + (s = final(_, _, _, _, _), d) { + let label = makeLabel(s); + in switch (dict.lookup(label, d)) { + (some(rc)) { dict.insert(label, rc + 1, d) } + (nothing) { dict.insert(label, 1, d) } + } + } + (s = test(_, var, free, _, arcs), d) { + let fn collectArcs { + ([], d) { d } + (arc(_, _, s) @ arcs, d) { + collectArcs(arcs, d) => collectStates(s) + } + } + in collectArcs(arcs, d) => fn (d) { + let label = makeLabel(s); + in switch (dict.lookup(label, d)) { + (some(rc)) { dict.insert(label, rc + 1, d); } + (nothing) { dict.insert(label, 1, d); } + } + } + } + } + in #(dfa, collectStates(dfa, dict.E)) + } + + // transferRefCountsToStates: #(tpmc, refcounts) -> tpmc + fn transferRefCountsToStates (#(state, rcs)) { + let + fn getRc(s) { + switch(dict.lookup(makeLabel(s), rcs)) { + (some(n)) { n } + (nothing) { 0 } + }; + } + fn h { + (s = final(stamp, free, _, substs, code)) { + final(stamp, free, getRc(s), substs, code) + } + (s = test(stamp, var, free, _, st)) { + test(stamp, var, free, getRc(s), st |> i) + } + } + fn i (arc(pat, free, state)) { + arc(pat, free, h(state)) + } + in h(state) + } + +/////////////////////////////////////////////////////////////////////////// +// STAGE 4 Generate Intermediate Code +/////////////////////////////////////////////////////////////////////////// + + // step 4.1 calculate free variables + // calculateFreeVariables: tpmc -> tpmc + fn calculateFreeVariables (dfa) { + let + // calculateFree: dfa -> dfa + fn calculateFree { + (final(stamp, _, rc, substs, code)) { + final(stamp, dict.values(substs), rc, substs, code) + } + (test(stamp, var, _, rc, arcs)) { + let freeArcs = arcs |> calculateFreeArc; + freeVars = (var @ + ((freeArcs |> fn (arc(_, f, _)) { f }) => + lst.concat)) => lst.unique; + in test(stamp, var, freeVars, rc, freeArcs) + } + } + // calculateFreeArc: Arc -> Arc + fn calculateFreeArc (arc(pat, _, s)) { + let s2 = calculateFree(s); + fn arcFree (pat, s3) { + let + // varsInPat: pattern -> list(string) + fn varsInPat { + (tagged(x, ctor(_, args))) { + x @ ((args |> varsInPat) => + lst.concat) + } + (tagged(x, tuple(args))) { + x @ ((args |> varsInPat) => + lst.concat) + } + (tagged(x, _)) { [x] } + (x) { error($x) } + } + // freeVarsInState: tpmc -> list(string) + fn freeVarsInState { + (final(_, f, _, _, _)) | + (test(_, _, f, _, _)) { f } + } + in lst.exclude(varsInPat(pat), + freeVarsInState(s3)) + } + in arc(pat, arcFree(pat, s2), s2) + } + in calculateFree(dfa) + } + + // Stage 4.2 Translate the DFA to intermediate code + // translate: tpmc -> code + fn translate (original, tpmc) { + let + fn collectArcs { + ([], d) { d } + (arc(_, _, s) @ arcs, d) { + collectArcs(arcs, d) => collectLambdas(s) + } + } + fn collectLambdas { + (s = final(_, free, rc, _, _), d) { + if (rc > 1) { + dict.insert(makeLabel(s), s, d) + } else { + d + } + } + (s = test(_, _, _, rc, arcs), d) { + collectArcs(arcs, d) => fn (d) { + if (rc > 1) { + dict.insert(makeLabel(s), s, d) + } else { + d + } + } + } + } + fn translateState { + (final(stamp, free, rc, _, code)) { + if (rc > 1) { + apply(symbol(stamp), free |> fn (s) { symbol(s) }) + } else { + code + } + } + (test(stamp, var, free, rc, arcs)) { + if (rc > 1) { + apply(symbol(stamp), free |> fn (s) { symbol(s) }) + } else { + case(symbol(var), arcs |> translateArc) + } + } + } + fn translateArc(arc(pat, _, state)) { + when(pat, translateState(state)) + } + fn translateLambdas(lambdas) { + dict.values(lambdas) |> fn { + (final(stamp, free, _, _, code)) { + #(symbol(stamp), + lambda(free |> fn (s) { symbol(s) }, code)) + } + (test(stamp, var, free, _, arcs)) { + #(symbol(stamp), lambda(free |> fn (s) { + symbol(s) + }, case(symbol(var), arcs |> translateArc))) + } + } + } + fn wrapLetRec(body, lambdas) { + letrec(translateLambdas(lambdas), body) + } + fn wrapLambda(code) { + let fn h { + ([], _) { [] } + (_ @ args, n) { + symbol("x$" @@ $n) @ h(args, n + 1) + } + } + unsafe fn getargs(#(args, _) @ _) { args } + in lambda(h(getargs(original), 0), code) + } + in collectLambdas(tpmc, dict.E) => + wrapLetRec(translateState(tpmc)) => + wrapLambda + } + +/////////////////////////////////////////////////////////////////////////// +// Input +/////////////////////////////////////////////////////////////////////////// + + input = [ + #( + [ + variable("base"), + const(1), + named("c", tuple([variable("d"), const(3)])), + ctor("cons", [variable("pat"), variable("pats")]) + ], + apply(symbol("c"), [symbol("pat"), symbol("pats")]) + ), + #( + [ + wildcard, + variable("d"), + tuple([variable("d"), wildcard]), + ctor("nil", []) + ], + symbol("d") + ) + ]; + +/////////////////////////////////////////////////////////////////////////// +// Test +/////////////////////////////////////////////////////////////////////////// + +in + print input => rename => match => countStates => + transferRefCountsToStates => calculateFreeVariables => + translate(input) diff --git a/fn/rewrite/pratt.fn b/fn/rewrite/pratt.fn new file mode 100644 index 0000000..20bfc2c --- /dev/null +++ b/fn/rewrite/pratt.fn @@ -0,0 +1,64 @@ +let + link "pratt_lexer.fn" as lex; + link "pratt_sexpr.fn" as exp; + link "../ioutils.fn" as io; + infix left 90 "=>" fn (arg, fun) { fun(arg) }; + prefix 80 "$" io.to_string; + + fn expr(str) { + expr_bp(lex.new(str), 0) + } + + fn prefix_bp { + ('+') | ('-') { 5 } + (x) { error($x) } + } + + fn infix_bp { + ('+') | ('-') { #(1, 2) } + ('*') | ('/') { #(3, 4) } + ('.') { #(8, 7) } + (x) { error($x) } + } + + fn expr_bp(lexer, min_bp) { + let + fn loop { + (lhs, nothing, lexer) { + #(lhs, lexer) + } + (lhs, some(lex.Op(op)), lexer) { + infix_bp(op) => fn (#(l_bp, r_bp)) { + if (l_bp < min_bp) { + #(lhs, lexer) + } else { + lex.next(lexer) => unsafe fn (some(#(_, lexer))) { + expr_bp(lexer, r_bp) => fn (#(rhs, lexer)) { + loop(exp.Cons(op, [lhs, rhs]), lex.peek(lexer), lexer) + } + } + } + } + } + (_, x, _) { + error($x) + } + } + in + switch(lex.next(lexer)) { + (some(#(lex.Atom(it), lexer))) { + loop(exp.Atom(it), lex.peek(lexer), lexer) + } + (some(#(lex.Op(it), lexer))) { + expr_bp(lexer, prefix_bp(it)) => fn (#(rhs, lexer)) { + // []; + loop(exp.Cons(it, [rhs]), lex.peek(lexer), lexer) + } + } + (x) { + error($x) + } + } + } +in + print(expr("1 + - 2 + f . g . h * 3 * 4")) diff --git a/fn/rewrite/pratt_lexer.fn b/fn/rewrite/pratt_lexer.fn new file mode 100644 index 0000000..2460654 --- /dev/null +++ b/fn/rewrite/pratt_lexer.fn @@ -0,0 +1,34 @@ +namespace + +link "../listutils.fn" as lst; +infix left 80 "|>" fn (l, f) { lst.map(f, l) }; +infix left 80 "|?" fn (l, f) { lst.filter(f, l) }; + +typedef Token { + Atom(char) | + Op(char) | + Eof +} + +typedef Lexer { Lexer(list(Token)) } + +fn new (str) { + Lexer(str |? + fn { (' ') | ('\n') | ('\t') { false } (_) { true } } |> + fn (c) { if ((c >= '0' and c <= '9') or + (c >= 'a' and c <= 'z') or + (c >= 'A' and c <= 'Z')) { Atom(c) } + else { Op(c) } + } + ) +} + +fn next { + (Lexer(h @ t)) { some(#(h, Lexer(t))) } + (Lexer([])) { nothing } +} + +fn peek { + (Lexer(h @ _)) { some(h) } + (Lexer([])) { nothing } +} diff --git a/fn/rewrite/pratt_sexpr.fn b/fn/rewrite/pratt_sexpr.fn new file mode 100644 index 0000000..4791770 --- /dev/null +++ b/fn/rewrite/pratt_sexpr.fn @@ -0,0 +1,26 @@ +namespace + +link "../listutils.fn" as lst; +infix left 80 "|>" fn (l, f) { lst.map(f, l) }; + +typedef S { + Atom(char) | Cons(char, list(S)) +} + +print S(s) { +let + fn h { + (Atom(c)) { putc(c) } + (Cons(c, args)) { + putc('('); + putc(c); + args |> fn (a) { + putc(' '); + h(a); + }; + putc(')'); + } + } +in + h(s) +} diff --git a/fn/ternary.fn b/fn/ternary.fn new file mode 100644 index 0000000..685d5f9 --- /dev/null +++ b/fn/ternary.fn @@ -0,0 +1,22 @@ +let + macro TEST(lhs, rhs) { fn { (true) { lhs } (false) { rhs } } } + infix right 20 "?" fn (tst, swtch) { swtch(tst) }; + infix left 20 ":" TEST; +in + // +------+-------------+ + // | | | + // | +-----+---+ | + // | | | | | + print true ? false ? 1 : 2 : 3 + +// left 20; left 25 +// left 20; right 25 +// right 20; left 20 +// +-------+ +// | | +// +---+ | +// | | | +// true ? false ? 1 : 2 : 3 +// right 20; right 20 +// | | +// true ? false ? 1 : 2 : 3 diff --git a/fn/test_import.fn b/fn/test_import.fn new file mode 100644 index 0000000..18a3abe --- /dev/null +++ b/fn/test_import.fn @@ -0,0 +1,12 @@ +let + link "dictionary.fn" as dictionary; + foreach = dictionary.foreach; + lookup = dictionary.lookup; + insert = dictionary.insert; + delete = dictionary.delete; + make = dictionary.make; + fn lu (dict, key) { lookup(key, dict) } + infix left 100 "?" lu; + +in + print(make("abc", [1, 2, 3]) ? 'b'); diff --git a/fn/wonderful-life.fn b/fn/wonderful-life.fn index f45e3f7..9926e11 100644 --- a/fn/wonderful-life.fn +++ b/fn/wonderful-life.fn @@ -12,8 +12,8 @@ let if (depth > 50 or s0 < 0.5) { #(s0, leaf) } else { - unsafe fn (#(s1, t1)) { - unsafe fn (#(s2, t2)) { + fn (#(s1, t1)) { + fn (#(s2, t2)) { #(s2, node(t1, t2)) } (helper(s1, depth + 1)) } (helper(s0, depth + 1)) @@ -23,7 +23,7 @@ let helper(seed, 0) } - unsafe fn printTree(#(_, t)) { + fn printTree(#(_, t)) { let fn inner { (id, leaf) { diff --git a/src/anf.yaml b/src/anf.yaml index 35da31c..10286a0 100644 --- a/src/anf.yaml +++ b/src/anf.yaml @@ -56,10 +56,6 @@ structs: exp1: Aexp exp2: Aexp - AexpUnaryApp: - type: AexpUnaryOp - exp: Aexp - AexpList: exp: Aexp next: AexpList @@ -68,11 +64,6 @@ structs: integer: int next: AexpIntList - CexpApply: - function: Aexp - nargs: int - args: AexpList - AexpMakeVec: nargs: int args: AexpList @@ -85,6 +76,11 @@ structs: namespaces: AexpNamespaceArray body: Exp + CexpApply: + function: Aexp + nargs: int + args: AexpList + CexpIf: condition: Aexp consequent: Exp @@ -108,21 +104,11 @@ structs: condition: Aexp clauses: MatchList - MatchList: - matches: AexpIntList - body: Exp - next: MatchList - CexpLetRec: nbindings: int bindings: LetRecBindings body: Exp - LetRecBindings: - var: HashSymbol - val: Aexp - next: LetRecBindings - CexpAmb: exp1: Exp exp2: Exp @@ -140,6 +126,16 @@ structs: annotatedVar: AexpAnnotatedVar = NULL body: Exp + MatchList: + matches: AexpIntList + body: Exp + next: MatchList + + LetRecBindings: + var: HashSymbol + val: Aexp + next: LetRecBindings + unions: CexpCondCases: charCases: CexpCharCondCases @@ -153,7 +149,6 @@ unions: littleinteger: int character: character prim: AexpPrimApp - unary: AexpUnaryApp makeVec: AexpMakeVec namespaces: AexpNamespaces @@ -195,13 +190,9 @@ enums: - LE - GE - VEC - - XOR - MOD - CMP - AexpUnaryOp: - - NOT - hashes: AnfSymbolTable: {} diff --git a/src/anf_normalize.c b/src/anf_normalize.c index d7019a6..2024e4b 100644 --- a/src/anf_normalize.c +++ b/src/anf_normalize.c @@ -42,7 +42,6 @@ static Exp *normalizeVar(HashSymbol *var, Exp *tail); static Exp *normalizeMaybeBigInteger(MaybeBigInt *integer, Exp *tail); static Exp *normalizeStdInteger(int integer, Exp *tail); static Exp *normalizeCharacter(Character character, Exp *tail); -static Exp *normalizeUnary(LamUnaryApp *app, Exp *tail); static Exp *normalizeAmb(LamAmb *app, Exp *tail); static Exp *normalizeSequence(LamSequence *sequence, Exp *tail); static Exp *normalizePrim(LamPrimApp *app, Exp *tail); @@ -52,7 +51,6 @@ static Exp *normalizeError(Exp *tail); static HashSymbol *freshSymbol(); static LamExpTable *makeLamExpHashTable(); static Aexp *replaceLamExp(LamExp *lamExp, LamExpTable *replacements); -static AexpUnaryOp mapUnaryOp(LamUnaryOp op); static Exp *letBind(Exp *body, LamExpTable *replacements); static AexpPrimOp mapPrimOp(LamPrimOp op); static Aexp *aexpNormalizeVar(HashSymbol *var); @@ -62,11 +60,9 @@ static Aexp *aexpNormalizeCharacter(Character character); static Aexp *aexpNormalizeLam(LamLam *lamLam); static AexpNamespaceArray *aexpNormalizeNamespaces(LamNamespaceArray *nsArray); static AexpVarList *convertVarList(LamVarList *args); -static AexpList *replaceLamList(LamList *list, LamExpTable *replacements); +static AexpList *replaceLamArgs(LamArgs *, LamExpTable *); static Aexp *replaceLamPrim(LamPrimApp *lamPrimApp, LamExpTable *replacements); -static Aexp *replaceLamUnary(LamUnaryApp *lamUnaryApp, - LamExpTable *replacements); static Aexp *replaceLamMakeVec(LamMakeVec *makeVec, LamExpTable *replacements); static Aexp *replaceLamConstruct(LamConstruct *construct, @@ -88,7 +84,7 @@ static CexpCondCases *normalizeCondCases(LamCondCases *cases); static CexpLetRec *replaceCexpLetRec(CexpLetRec *cexpLetRec, LamLetRecBindings *lamLetRecBindings); static Exp *normalizeConstruct(LamConstruct *construct, Exp *tail); -static Exp *normalizeMakeTuple(LamList *tuple, Exp *tail); +static Exp *normalizeMakeTuple(LamArgs *, Exp *); static Exp *normalizeTupleIndex(LamTupleIndex *construct, Exp *tail); static Exp *normalizeDeconstruct(LamDeconstruct *deconstruct, Exp *tail); static Exp *normalizeTag(LamExp *tag, Exp *tail); @@ -113,12 +109,10 @@ static Exp *normalize(LamExp *lamExp, Exp *tail) { return normalizeMaybeBigInteger(lamExp->val.biginteger, tail); case LAMEXP_TYPE_PRIM: return normalizePrim(lamExp->val.prim, tail); - case LAMEXP_TYPE_UNARY: - return normalizeUnary(lamExp->val.unary, tail); case LAMEXP_TYPE_AMB: return normalizeAmb(lamExp->val.amb, tail); - case LAMEXP_TYPE_LIST: - return normalizeSequence(lamExp->val.list, tail); + case LAMEXP_TYPE_SEQUENCE: + return normalizeSequence(lamExp->val.sequence, tail); case LAMEXP_TYPE_MAKEVEC: return normalizeMakeVec(lamExp->val.makeVec, tail); case LAMEXP_TYPE_TYPEDEFS: @@ -382,7 +376,7 @@ static Exp *normalizeCallCc(LamExp *lamExp, Exp *tail) { } static LamApply *printToApply(LamPrint *lamPrint) { - LamList *args = newLamList(CPI(lamPrint), lamPrint->exp, NULL); + LamArgs *args = newLamArgs(CPI(lamPrint), lamPrint->exp, NULL); int save = PROTECT(args); LamApply *lamApply = newLamApply(CPI(lamPrint), lamPrint->printer, args); UNPROTECT(save); @@ -428,8 +422,8 @@ static Exp *normalizeMakeVec(LamMakeVec *lamMakeVec, Exp *tail) { ENTER(normalizeMakeVec); LamExpTable *replacements = makeLamExpHashTable(); int save = PROTECT(replacements); - DEBUG("calling replaceLamList"); - AexpList *args = replaceLamList(lamMakeVec->args, replacements); + DEBUG("calling replaceLamArgs"); + AexpList *args = replaceLamArgs(lamMakeVec->args, replacements); int save2 = PROTECT(args); AexpMakeVec *aexpMakeVec = newAexpMakeVec(countAexpList(args), args); REPLACE_PROTECT(save2, aexpMakeVec); @@ -446,19 +440,19 @@ static Exp *normalizeMakeVec(LamMakeVec *lamMakeVec, Exp *tail) { } static LamMakeVec *constructToMakeVec(LamConstruct *construct) { - int nargs = countLamList(construct->args); + int nargs = countLamArgs(construct->args); LamExp *newArg = newLamExp_Stdint(CPI(construct), construct->tag); int save = PROTECT(newArg); - LamList *extraItem = newLamList(CPI(construct), newArg, construct->args); + LamArgs *extraItem = newLamArgs(CPI(construct), newArg, construct->args); PROTECT(extraItem); LamMakeVec *res = newLamMakeVec(CPI(construct), nargs + 1, extraItem); UNPROTECT(save); return res; } -static LamMakeVec *tupleToMakeVec(LamList *tuple) { - int nargs = countLamList(tuple); +static LamMakeVec *tupleToMakeVec(LamArgs *tuple) { + int nargs = countLamArgs(tuple); LamMakeVec *res = newLamMakeVec(CPI(tuple), nargs, tuple); return res; } @@ -473,7 +467,7 @@ static Exp *normalizeConstruct(LamConstruct *construct, Exp *tail) { return res; } -static Exp *normalizeMakeTuple(LamList *tuple, Exp *tail) { +static Exp *normalizeMakeTuple(LamArgs *tuple, Exp *tail) { LamMakeVec *makeVec = tupleToMakeVec(tuple); int save = PROTECT(makeVec); Exp *res = normalizeMakeVec(makeVec, tail); @@ -535,27 +529,6 @@ static Exp *wrapTail(Exp *exp, Exp *tail) { return exp; } -static Exp *normalizeUnary(LamUnaryApp *app, Exp *tail) { - ENTER(normalizeUnary); - LamExpTable *replacements = makeLamExpHashTable(); - int save = PROTECT(replacements); - Aexp *aexp = replaceLamExp(app->exp, replacements); - int save2 = PROTECT(aexp); - AexpUnaryApp *aexpUnaryApp = newAexpUnaryApp(mapUnaryOp(app->type), aexp); - UNPROTECT(save2); - save2 = PROTECT(aexpUnaryApp); - Aexp *aexp2 = newAexp_Unary(aexpUnaryApp); - REPLACE_PROTECT(save2, aexp2); - Exp *exp = wrapAexp(aexp2); - REPLACE_PROTECT(save2, exp); - exp = wrapTail(exp, tail); - REPLACE_PROTECT(save2, exp); - Exp *res = letBind(exp, replacements); - UNPROTECT(save); - LEAVE(normalizeUnary); - return res; -} - static Exp *normalizePrim(LamPrimApp *app, Exp *tail) { ENTER(normalizePrim); LamExpTable *replacements = makeLamExpHashTable(); @@ -564,8 +537,7 @@ static Exp *normalizePrim(LamPrimApp *app, Exp *tail) { int save2 = PROTECT(exp1); Aexp *exp2 = replaceLamExp(app->exp2, replacements); PROTECT(exp2); - AexpPrimApp *aexpPrimApp = - newAexpPrimApp(mapPrimOp(app->type), exp1, exp2); + AexpPrimApp *aexpPrimApp = newAexpPrimApp(mapPrimOp(app->type), exp1, exp2); UNPROTECT(save2); save2 = PROTECT(aexpPrimApp); Aexp *aexp = newAexp_Prim(aexpPrimApp); @@ -771,10 +743,10 @@ static Exp *normalizeApply(LamApply *lamApply, Exp *tail) { int save = PROTECT(replacements); Aexp *function = replaceLamExp(lamApply->function, replacements); int save2 = PROTECT(function); - DEBUG("calling replaceLamList"); - AexpList *args = replaceLamList(lamApply->args, replacements); + DEBUG("calling replaceLamArgs"); + AexpList *args = replaceLamArgs(lamApply->args, replacements); PROTECT(args); - DEBUG("back from replaceLamList"); + DEBUG("back from replaceLamArgs"); IFDEBUG(printLamExpTable(replacements, 0)); CexpApply *cexpApply = newCexpApply(function, countAexpList(args), args); UNPROTECT(save2); @@ -930,9 +902,6 @@ static Aexp *replaceLamExp(LamExp *lamExp, LamExpTable *replacements) { case LAMEXP_TYPE_PRIM: res = replaceLamPrim(lamExp->val.prim, replacements); break; - case LAMEXP_TYPE_UNARY: - res = replaceLamUnary(lamExp->val.unary, replacements); - break; case LAMEXP_TYPE_PRINT: res = replaceLamPrint(lamExp->val.print, replacements); break; @@ -959,7 +928,7 @@ static Aexp *replaceLamExp(LamExp *lamExp, LamExpTable *replacements) { res = aexpNormalizeCharacter(lamExp->val.character); break; case LAMEXP_TYPE_LOOKUP: - case LAMEXP_TYPE_LIST: + case LAMEXP_TYPE_SEQUENCE: case LAMEXP_TYPE_APPLY: case LAMEXP_TYPE_IFF: case LAMEXP_TYPE_CALLCC: @@ -995,8 +964,7 @@ static bool lamExpIsLambda(LamExp *val) { case LAMEXP_TYPE_ERROR: case LAMEXP_TYPE_AMB: case LAMEXP_TYPE_PRIM: - case LAMEXP_TYPE_UNARY: - case LAMEXP_TYPE_LIST: + case LAMEXP_TYPE_SEQUENCE: case LAMEXP_TYPE_APPLY: case LAMEXP_TYPE_IFF: case LAMEXP_TYPE_CALLCC: @@ -1064,8 +1032,8 @@ static Aexp *replaceLamConstruct(LamConstruct *construct, static Aexp *replaceLamMakeVec(LamMakeVec *makeVec, LamExpTable *replacements) { ENTER(replaceLamMakeVec); - DEBUG("calling replaceLamList"); - AexpList *aexpList = replaceLamList(makeVec->args, replacements); + DEBUG("calling replaceLamArgs"); + AexpList *aexpList = replaceLamArgs(makeVec->args, replacements); int save = PROTECT(aexpList); AexpMakeVec *aexpMakeVec = newAexpMakeVec(countAexpList(aexpList), aexpList); @@ -1088,20 +1056,20 @@ static Aexp *replaceLamPrint(LamPrint *print, LamExpTable *replacements) { return res; } -static AexpList *replaceLamList(LamList *list, LamExpTable *replacements) { - ENTER(replaceLamList); +static AexpList *replaceLamArgs(LamArgs *list, LamExpTable *replacements) { + ENTER(replaceLamArgs); if (list == NULL) { - LEAVE(replaceLamList); + LEAVE(replaceLamArgs); return NULL; } - DEBUG("calling replaceLamList"); - AexpList *next = replaceLamList(list->next, replacements); + DEBUG("calling replaceLamArgs"); + AexpList *next = replaceLamArgs(list->next, replacements); int save = PROTECT(next); Aexp *val = replaceLamExp(list->exp, replacements); PROTECT(val); AexpList *res = newAexpList(val, next); UNPROTECT(save); - LEAVE(replaceLamList); + LEAVE(replaceLamArgs); return res; } @@ -1120,28 +1088,6 @@ static Aexp *replaceLamPrim(LamPrimApp *lamPrimApp, LamExpTable *replacements) { return res; } -static Aexp *replaceLamUnary(LamUnaryApp *lamUnaryApp, - LamExpTable *replacements) { - ENTER(replaceLamUnary); - Aexp *exp = replaceLamExp(lamUnaryApp->exp, replacements); - int save = PROTECT(exp); - AexpUnaryApp *unary = newAexpUnaryApp(mapUnaryOp(lamUnaryApp->type), exp); - PROTECT(unary); - Aexp *res = newAexp_Unary(unary); - UNPROTECT(save); - LEAVE(replaceLamUnary); - return res; -} - -static AexpUnaryOp mapUnaryOp(LamUnaryOp op) { - switch (op) { - case LAMUNARYOP_TYPE_NOT: - return AEXPUNARYOP_TYPE_NOT; - default: - cant_happen("unrecognised type %d in mapUnaryOp", op); - } -} - static AexpPrimOp mapPrimOp(LamPrimOp op) { switch (op) { case LAMPRIMOP_TYPE_ADD: @@ -1168,8 +1114,6 @@ static AexpPrimOp mapPrimOp(LamPrimOp op) { return AEXPPRIMOP_TYPE_LE; case LAMPRIMOP_TYPE_VEC: return AEXPPRIMOP_TYPE_VEC; - case LAMPRIMOP_TYPE_XOR: - return AEXPPRIMOP_TYPE_XOR; case LAMPRIMOP_TYPE_MOD: return AEXPPRIMOP_TYPE_MOD; case LAMPRIMOP_TYPE_CMP: diff --git a/src/anf_pp.c b/src/anf_pp.c index f0baefa..10c4c5b 100644 --- a/src/anf_pp.c +++ b/src/anf_pp.c @@ -122,9 +122,6 @@ void ppAexpPrimApp(AexpPrimApp *x) { case AEXPPRIMOP_TYPE_LE: eprintf("le "); break; - case AEXPPRIMOP_TYPE_XOR: - eprintf("xor "); - break; case AEXPPRIMOP_TYPE_VEC: eprintf("vec "); break; @@ -148,19 +145,6 @@ void ppAexpPrimApp(AexpPrimApp *x) { eprintf(")"); } -void ppAexpUnaryApp(AexpUnaryApp *x) { - eprintf("("); - switch (x->type) { - case AEXPUNARYOP_TYPE_NOT: - eprintf("not "); - break; - default: - cant_happen("unrecognized op in ppAexpUnaryApp (%d)", x->type); - } - ppAexp(x->exp); - eprintf(")"); -} - static void ppAexpListContents(AexpList *x) { while (x != NULL) { ppAexp(x->exp); @@ -390,9 +374,6 @@ void ppAexp(Aexp *x) { case AEXP_TYPE_PRIM: ppAexpPrimApp(x->val.prim); break; - case AEXP_TYPE_UNARY: - ppAexpUnaryApp(x->val.unary); - break; case AEXP_TYPE_MAKEVEC: ppAexpMakeVec(x->val.makeVec); break; diff --git a/src/anf_pp.h b/src/anf_pp.h index 8699409..4fdb36b 100644 --- a/src/anf_pp.h +++ b/src/anf_pp.h @@ -32,7 +32,6 @@ void ppAexpVarList(AexpVarList *x); void ppAexpVar(HashSymbol *x); void ppAexpAnnotatedVar(AexpAnnotatedVar *x); void ppAexpPrimApp(AexpPrimApp *x); -void ppAexpUnaryApp(AexpUnaryApp *x); void ppAexpList(AexpList *x); void ppAexpIntList(AexpIntList *x); void ppAexpMakeList(AexpList *x); diff --git a/src/annotate.c b/src/annotate.c index cb45496..efb7062 100644 --- a/src/annotate.c +++ b/src/annotate.c @@ -43,7 +43,6 @@ static CTEnv *annotateExp(Exp *x, CTEnv *env); static CTEnv *annotateAexpLam(AexpLam *x, CTEnv *env); static AexpAnnotatedVar *annotateAexpVar(HashSymbol *x, CTEnv *env); static CTEnv *annotateAexpPrimApp(AexpPrimApp *x, CTEnv *env); -static CTEnv *annotateAexpUnaryApp(AexpUnaryApp *x, CTEnv *env); static CTEnv *annotateAexpList(AexpList *x, CTEnv *env); static CTEnv *annotateCexpApply(CexpApply *x, CTEnv *env); static CTEnv *annotateCexpIf(CexpIf *x, CTEnv *env); @@ -119,18 +118,6 @@ static CTEnv *annotateAexpPrimApp(AexpPrimApp *x, CTEnv *env) { return env; } -static CTEnv *annotateAexpUnaryApp(AexpUnaryApp *x, CTEnv *env) { -#ifdef DEBUG_ANNOTATE2 - eprintf("annotateAexpPrimApp "); - ppAexpUnaryApp(x); - eprintf(" "); - ppCTEnv(env); - eprintf("\n"); -#endif - annotateAexp(x->exp, env); - return env; -} - static CTEnv *annotateAexpList(AexpList *x, CTEnv *env) { #ifdef DEBUG_ANNOTATE2 eprintf("annotateAexpList "); @@ -387,8 +374,6 @@ static CTEnv *annotateAexp(Aexp *x, CTEnv *env) { return env; case AEXP_TYPE_PRIM: return annotateAexpPrimApp(x->val.prim, env); - case AEXP_TYPE_UNARY: - return annotateAexpUnaryApp(x->val.unary, env); case AEXP_TYPE_MAKEVEC: return annotateAexpMakeVec(x->val.makeVec, env); case AEXP_TYPE_NAMESPACES: diff --git a/src/ast_pp.c b/src/ast_pp.c index 4405bc1..8feb8bd 100644 --- a/src/ast_pp.c +++ b/src/ast_pp.c @@ -275,7 +275,7 @@ static void ppAstTypeClause(PrattUTF8 *dest, AstTypeClause *typeClause) { ppAstTypeFunction(dest, typeClause->val.typeFunction); break; case AST_TYPECLAUSE_TYPE_TYPETUPLE: - psprintf(dest, "#("); + psprintf(dest, "("); ppAstTypeList(dest, typeClause->val.typeTuple); psprintf(dest, ")"); break; @@ -381,7 +381,7 @@ static void ppAstArg(PrattUTF8 *dest, AstArg *arg) { ppUnicodeChar(dest, arg->val.character); break; case AST_ARG_TYPE_TUPLE: - psprintf(dest, "#("); + psprintf(dest, "("); ppAstArgList(dest, arg->val.tuple); psprintf(dest, ")"); break; @@ -462,7 +462,7 @@ void ppAstCharacter(PrattUTF8 *dest, Character c) { } void ppAstTuple(PrattUTF8 *dest, AstExpressions *expressions) { - psprintf(dest, "#("); + psprintf(dest, "("); while (expressions) { ppAstExpression(dest, expressions->expression); if (expressions->next) diff --git a/src/builtin_io.c b/src/builtin_io.c index 2940532..cfa0098 100644 --- a/src/builtin_io.c +++ b/src/builtin_io.c @@ -442,11 +442,8 @@ static Value private_fgets(FILE *fh) { if (buf->buffer == NULL) { cant_happen("fgets on null memstream"); } - if (buf->ptr == NULL) { - buf->ptr = buf->buffer; - } - do { pushByteArray(bytes, (Byte) *(buf->ptr)); } while (*(buf->ptr++)); - buf->ptr--; // point back at '\0' for next time + do { pushByteArray(bytes, (Byte) buf->buffer[buf->index]); } while (buf->buffer[buf->index++]); + buf->index--; // point back at '\0' for next time } else { int c; while ((c = fgetc(fh)) != EOF) { diff --git a/src/builtins.yaml b/src/builtins.yaml index 4e1ac0c..723cfa9 100644 --- a/src/builtins.yaml +++ b/src/builtins.yaml @@ -38,7 +38,7 @@ structs: BuiltInMemBuf: buffer: string=NULL - ptr: string=NULL + index: index=0 size: size=0 hashes: diff --git a/src/bytecode.c b/src/bytecode.c index 02f4840..ec39bca 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -196,23 +196,6 @@ void writeAexpAnnotatedVar(AexpAnnotatedVar *x, ByteCodeArray *b) { LEAVE(writeAexpAnnotatedVar); } -void writeAexpUnaryApp(AexpUnaryApp *x, ByteCodeArray *b) { - ENTER(writeAexpUnaryApp); - if (x == NULL) - return; - writeAexp(x->exp, b); - Byte prim; - switch (x->type) { - case AEXPUNARYOP_TYPE_NOT: - prim = BYTECODES_TYPE_PRIM_NOT; - break; - default: - cant_happen("unrecognised AexpUnaryOp in writeAexpUnaryApp"); - } - addByte(b, prim); - LEAVE(writeAexpUnaryApp); -} - void writeAexpPrimApp(AexpPrimApp *x, ByteCodeArray *b) { ENTER(writeAexpPrimApp); if (x == NULL) @@ -257,9 +240,6 @@ void writeAexpPrimApp(AexpPrimApp *x, ByteCodeArray *b) { case AEXPPRIMOP_TYPE_LE: prim = BYTECODES_TYPE_PRIM_LE; break; - case AEXPPRIMOP_TYPE_XOR: - prim = BYTECODES_TYPE_PRIM_XOR; - break; case AEXPPRIMOP_TYPE_VEC: prim = BYTECODES_TYPE_PRIM_VEC; break; @@ -652,10 +632,6 @@ void writeAexp(Aexp *x, ByteCodeArray *b) { writeAexpPrimApp(x->val.prim, b); } break; - case AEXP_TYPE_UNARY:{ - writeAexpUnaryApp(x->val.unary, b); - } - break; case AEXP_TYPE_MAKEVEC:{ writeAexpMakeVec(x->val.makeVec, b); } diff --git a/src/bytecode.h b/src/bytecode.h index da53bda..4d6f48a 100644 --- a/src/bytecode.h +++ b/src/bytecode.h @@ -40,7 +40,6 @@ void resetByteCodeArray(ByteCodeArray *b); void writeAexpLam(AexpLam *x, ByteCodeArray *b); void writeAexpAnnotatedVar(AexpAnnotatedVar *x, ByteCodeArray *b); void writeAexpPrimApp(AexpPrimApp *x, ByteCodeArray *b); -void writeAexpUnaryApp(AexpUnaryApp *x, ByteCodeArray *b); void writeAexpList(AexpList *x, ByteCodeArray *b); void writeCexpApply(CexpApply *x, ByteCodeArray *b); void writeCexpIf(CexpIf *x, ByteCodeArray *b); diff --git a/src/cekfs.yaml b/src/cekfs.yaml index 07b7386..939a42f 100644 --- a/src/cekfs.yaml +++ b/src/cekfs.yaml @@ -121,10 +121,8 @@ enums: - PRIM_LT - PRIM_GE - PRIM_LE - - PRIM_XOR - PRIM_MAKEVEC - PRIM_VEC - - PRIM_NOT - MATCH - APPLY - IF diff --git a/src/debug.c b/src/debug.c index 46ad054..1e60328 100644 --- a/src/debug.c +++ b/src/debug.c @@ -107,14 +107,6 @@ void dumpByteCode(ByteCodeArray *bca) { eprintf("CMP\n"); } break; - case BYTECODES_TYPE_PRIM_XOR:{ - eprintf("XOR\n"); - } - break; - case BYTECODES_TYPE_PRIM_NOT:{ - eprintf("NOT\n"); - } - break; case BYTECODES_TYPE_PRIM_MAKEVEC:{ int size = readByte(bca, &i); eprintf("MAKEVEC [%d]\n", size); diff --git a/src/errors.c b/src/errors.c index 162ca3e..0fbabe5 100644 --- a/src/errors.c +++ b/src/errors.c @@ -33,7 +33,7 @@ void _cant_happen(char *file, int line, const char *message, ...) { va_start(args, message); vfprintf(errout, message, args); va_end(args); - eprintf(" at %s line %d\n", file, line); + eprintf(" at +%d %s\n", line, file); #ifdef DEBUG_DUMP_CORE abort(); #else diff --git a/src/inline.c b/src/inline.c index cc8bc0b..3e67083 100644 --- a/src/inline.c +++ b/src/inline.c @@ -25,9 +25,8 @@ static LamTypeDefs *inlineTypeDefs(LamTypeDefs *x); static LamNamespaceArray *inlineNamespaces(LamNamespaceArray *x); static LamLam *inlineLam(LamLam *x); static LamPrimApp *inlinePrim(LamPrimApp *x); -static LamUnaryApp *inlineUnary(LamUnaryApp *x); static LamSequence *inlineSequence(LamSequence *x); -static LamList *inlineList(LamList *x); +static LamArgs *inlineArgs(LamArgs *x); static LamExp *inlineApply(LamApply *x); static LamExp *inlineConstant(LamTypeConstructorInfo *x); static LamIff *inlineIff(LamIff *x); @@ -43,7 +42,7 @@ static LamCond *inlineCond(LamCond *x); static LamCondCases *inlineCondCases(LamCondCases *x); static LamCharCondCases *inlineCharCondCases(LamCharCondCases *x); static LamIntCondCases *inlineIntCondCases(LamIntCondCases *x); -static LamExp *makeConstruct(ParserInfo, HashSymbol *name, int tag, LamList *args); +static LamExp *makeConstruct(ParserInfo, HashSymbol *name, int tag, LamArgs *args); static LamExp *makeConstant(ParserInfo, HashSymbol *name, int tag); static LamTypeConstructorInfo *resolveTypeConstructor(LamExp *x); @@ -84,11 +83,6 @@ static LamPrimApp *inlinePrim(LamPrimApp *x) { return x; } -static LamUnaryApp *inlineUnary(LamUnaryApp *x) { - x->exp = inlineExp(x->exp); - return x; -} - static LamSequence *inlineSequence(LamSequence *x) { if (x != NULL) { x->next = inlineSequence(x->next); @@ -97,15 +91,15 @@ static LamSequence *inlineSequence(LamSequence *x) { return x; } -static LamList *inlineList(LamList *x) { +static LamArgs *inlineArgs(LamArgs *x) { if (x != NULL) { - x->next = inlineList(x->next); + x->next = inlineArgs(x->next); x->exp = inlineExp(x->exp); } return x; } -static LamExp *makeConstruct(ParserInfo I, HashSymbol *name, int tag, LamList *args) { +static LamExp *makeConstruct(ParserInfo I, HashSymbol *name, int tag, LamArgs *args) { LamConstruct *construct = newLamConstruct(I, name, tag, args); int save = PROTECT(construct); LamExp *res = @@ -146,12 +140,12 @@ static LamTypeConstructorInfo *resolveTypeConstructor(LamExp *x) { } static LamExp *inlineApply(LamApply *x) { - x->args = inlineList(x->args); + x->args = inlineArgs(x->args); LamTypeConstructorInfo *info = resolveTypeConstructor(x->function); if (info == NULL) { x->function = inlineExp(x->function); } else { - int nargs = countLamList(x->args); + int nargs = countLamArgs(x->args); if (info->needsVec) { if (nargs == info->arity) { return makeConstruct(CPI(x), info->name, info->index, x->args); @@ -280,14 +274,11 @@ static LamExp *inlineExp(LamExp *x) { case LAMEXP_TYPE_PRIM: x->val.prim = inlinePrim(x->val.prim); break; - case LAMEXP_TYPE_UNARY: - x->val.unary = inlineUnary(x->val.unary); - break; - case LAMEXP_TYPE_LIST: - x->val.list = inlineSequence(x->val.list); + case LAMEXP_TYPE_SEQUENCE: + x->val.sequence = inlineSequence(x->val.sequence); break; case LAMEXP_TYPE_MAKE_TUPLE: - x->val.make_tuple = inlineList(x->val.make_tuple); + x->val.make_tuple = inlineArgs(x->val.make_tuple); break; case LAMEXP_TYPE_APPLY: x = inlineApply(x->val.apply); @@ -329,12 +320,11 @@ static LamExp *inlineExp(LamExp *x) { x = inlineConstant(x->val.constructor); break; case LAMEXP_TYPE_CONSTRUCT: - x->val.construct->args = inlineList(x->val.construct->args); + x->val.construct->args = inlineArgs(x->val.construct->args); break; case LAMEXP_TYPE_COND: x->val.cond = inlineCond(x->val.cond); break; - case LAMEXP_TYPE_TUPLE: case LAMEXP_TYPE_MAKEVEC: cant_happen("encountered %s", lamExpTypeName(x->type)); default: diff --git a/src/lambda.yaml b/src/lambda.yaml index 2469397..b2d09c0 100644 --- a/src/lambda.yaml +++ b/src/lambda.yaml @@ -40,21 +40,17 @@ structs: exp1: LamExp exp2: LamExp - LamUnaryApp: - type: LamUnaryOp - exp: LamExp - LamSequence: exp: LamExp next: LamSequence - LamList: + LamArgs: exp: LamExp - next: LamList + next: LamArgs LamApply: function: LamExp - args: LamList + args: LamArgs LamLookup: nsid: int @@ -73,7 +69,7 @@ structs: LamConstruct: name: HashSymbol # the name of the constructor tag: int # the tag of the constructor - args: LamList # the remaining arguments to make-vec + args: LamArgs # the remaining arguments to make-vec LamDeconstruct: name: HashSymbol # name of the constructor being deconstructed @@ -88,7 +84,7 @@ structs: LamMakeVec: nargs: int - args: LamList + args: LamArgs LamIff: condition: LamExp @@ -222,13 +218,9 @@ enums: - LT - GE - LE - - XOR - CMP - VEC - LamUnaryOp: - - NOT - unions: LamExp: namespaces: LamNamespaceArray @@ -237,14 +229,12 @@ unions: stdint: int biginteger: MaybeBigInt prim: LamPrimApp - unary: LamUnaryApp - list: LamSequence + sequence: LamSequence makeVec: LamMakeVec construct: LamConstruct deconstruct: LamDeconstruct tuple_index: LamTupleIndex - tuple: LamList - make_tuple: LamList + make_tuple: LamArgs tag: LamExp constant: LamConstant apply: LamApply diff --git a/src/lambda_conversion.c b/src/lambda_conversion.c index cd6d536..a8504b2 100644 --- a/src/lambda_conversion.c +++ b/src/lambda_conversion.c @@ -37,7 +37,7 @@ char *lambda_conversion_function = NULL; // set by --lambda-conversion flag static LamLetRecBindings *convertFuncDefs(AstDefinitions *, LamContext *); -static LamList *convertExpressions(AstExpressions *, LamContext *); +static LamArgs *convertExpressions(AstExpressions *, LamContext *); static LamSequence *convertSequence(AstExpressions *, LamContext *); static LamLetRecBindings *prependDefinition(AstDefinition *, LamContext *, LamLetRecBindings *); static LamLetRecBindings *prependDefine(AstDefine *, LamContext *, LamLetRecBindings *); @@ -166,7 +166,7 @@ static LamExp *lamConvert(AstDefinitions *definitions, body = newLamSequence(CPI(env), lamNamespaces, body); PROTECT(body); } - LamExp *letRecBody = newLamExp_List(CPI(body), body); + LamExp *letRecBody = newLamExp_Sequence(CPI(body), body); PROTECT(letRecBody); LamExp *result = NULL; if (funcDefsList != NULL) { @@ -176,7 +176,7 @@ static LamExp *lamConvert(AstDefinitions *definitions, PROTECT(letRec); result = newLamExp_Letrec(CPI(letRec), letRec); } else { - result = newLamExp_List(CPI(body), body); + result = newLamExp_Sequence(CPI(body), body); } PROTECT(result); if (typeDefList != NULL) { @@ -219,7 +219,7 @@ static LamExp *lamConvertPrint(AstPrint *print, LamContext *context) { } static LamExp *lamConvertTuple(AstExpressions *tuple, LamContext *env) { - LamList *expressions = convertExpressions(tuple, env); + LamArgs *expressions = convertExpressions(tuple, env); int save = PROTECT(expressions); LamExp *res = newLamExp_Make_tuple(CPI(expressions), expressions); UNPROTECT(save); @@ -763,23 +763,23 @@ static HashSymbol *dollarSubstitute(HashSymbol *symbol, ParserInfo I __attribute } #define CHECK_ONE_ARG(name, args) do { \ - int count = countLamList(args); \ + int count = countLamArgs(args); \ if (count != 1) \ conversionError(CPI(args), "expected 1 arg in " #name ", got %d", count); \ } while(0) #define CHECK_TWO_ARGS(name, args) do { \ - int count = countLamList(args); \ + int count = countLamArgs(args); \ if (count != 2) \ conversionError(CPI(args), "expected 2 args in " #name ", got %d", count); \ } while(0) -static LamExp *makeCallCC(LamList *args) { +static LamExp *makeCallCC(LamArgs *args) { CHECK_ONE_ARG(makeCallCC, args); return newLamExp_Callcc(CPI(args), args->exp); } -static LamExp *makeBinOp(LamPrimOp opCode, LamList *args) { +static LamExp *makeBinOp(LamPrimOp opCode, LamArgs *args) { CHECK_TWO_ARGS(makeBinOp, args); LamPrimApp *app = newLamPrimApp(CPI(args), opCode, args->exp, args->next->exp); int save = PROTECT(app); @@ -788,7 +788,7 @@ static LamExp *makeBinOp(LamPrimOp opCode, LamList *args) { return exp; } -static LamExp *makeLamAmb(LamList *args) { +static LamExp *makeLamAmb(LamArgs *args) { CHECK_TWO_ARGS(makeLamAmb, args); LamAmb *lamAmb = newLamAmb(CPI(args), args->exp, args->next->exp); int save = PROTECT(lamAmb); @@ -797,13 +797,13 @@ static LamExp *makeLamAmb(LamList *args) { return res; } -static LamExp *makeUnaryNeg(LamList *args) { +static LamExp *makeUnaryNeg(LamArgs *args) { CHECK_ONE_ARG(makeUnaryNeg, args); MaybeBigInt *num = fakeBigInt(0, false); int save = PROTECT(num); LamExp *zero = newLamExp_Biginteger(CPI(args), num); PROTECT(zero); - args = newLamList(CPI(args), zero, args); + args = newLamArgs(CPI(args), zero, args); PROTECT(args); LamExp *result = makeBinOp(LAMPRIMOP_TYPE_SUB, args); UNPROTECT(save); @@ -830,21 +830,21 @@ static LamExp *thunkMacroArg(LamExp *arg) { return res; } -static LamList *wrapMacroArgs(LamList *args) { +static LamArgs *wrapMacroArgs(LamArgs *args) { if (args == NULL) { return NULL; } - LamList *next = wrapMacroArgs(args->next); + LamArgs *next = wrapMacroArgs(args->next); int save = PROTECT(next); LamExp *arg = thunkMacroArg(args->exp); PROTECT(arg); - LamList *this = newLamList(CPI(arg), arg, next); + LamArgs *this = newLamArgs(CPI(arg), arg, next); UNPROTECT(save); return this; } // wrap each argument to the macro in a thunk, the macro will invoke -static LamExp *wrapMacro(ParserInfo PI, HashSymbol *symbol, LamList *args) { +static LamExp *wrapMacro(ParserInfo PI, HashSymbol *symbol, LamArgs *args) { args = wrapMacroArgs(args); int save = PROTECT(args); LamExp *macro = newLamExp_Var(PI, symbol); @@ -856,7 +856,7 @@ static LamExp *wrapMacro(ParserInfo PI, HashSymbol *symbol, LamList *args) { return res; } -static LamExp *makePrimApp(ParserInfo PI, HashSymbol *symbol, LamList *args, LamContext *env) { +static LamExp *makePrimApp(ParserInfo PI, HashSymbol *symbol, LamArgs *args, LamContext *env) { if (isMacro(PI, symbol, env)) { return wrapMacro(PI, symbol, args); } @@ -903,7 +903,7 @@ static LamExp *makeConstructor(HashSymbol *symbol, LamContext *env) { return NULL; } -static LamExp *makeApplication(LamExp *fun, LamList *args) { +static LamExp *makeApplication(LamExp *fun, LamArgs *args) { LamApply *apply = newLamApply(CPI(fun), fun, args); int save = PROTECT(apply); LamExp *result = newLamExp_Apply(CPI(apply), apply); @@ -911,13 +911,13 @@ static LamExp *makeApplication(LamExp *fun, LamList *args) { return result; } -static LamList *varListToList(LamVarList *list) { +static LamArgs *varListToList(LamVarList *list) { if (list == NULL) return NULL; - LamList *next = varListToList(list->next); + LamArgs *next = varListToList(list->next); int save = PROTECT(next); LamExp *var = newLamExp_Var(CPI(list), list->var); PROTECT(var); - LamList *this = newLamList(CPI(var), var, next); + LamArgs *this = newLamArgs(CPI(var), var, next); UNPROTECT(save); return this; } @@ -1018,15 +1018,15 @@ static AstExpression *findTaggedExpression(HashSymbol *tag, AstTaggedExpressions return findTaggedExpression(tag, tags->next); } -static LamList *convertTagsToArgs(LamTypeTags *lamTags, AstTaggedExpressions *astTags, LamContext *env) { +static LamArgs *convertTagsToArgs(LamTypeTags *lamTags, AstTaggedExpressions *astTags, LamContext *env) { // lamTags are in canonical order if (lamTags == NULL) return NULL; - LamList *rest = convertTagsToArgs(lamTags->next, astTags, env); + LamArgs *rest = convertTagsToArgs(lamTags->next, astTags, env); int save = PROTECT(rest); AstExpression *expression = findTaggedExpression(lamTags->tag, astTags); LamExp *lamExp = convertExpression(expression, env); PROTECT(lamExp); - LamList *this = newLamList(CPI(lamExp), lamExp, rest); + LamArgs *this = newLamArgs(CPI(lamExp), lamExp, rest); UNPROTECT(save); return this; } @@ -1034,14 +1034,14 @@ static LamList *convertTagsToArgs(LamTypeTags *lamTags, AstTaggedExpressions *as // (costructor4 arg1 arg2) => // ((lambda (x1 x2 x3 x4) (constructor4 x1 x2 x3 x4)) arg1 arg2) -static LamExp *makeConstructorApplication(LamExp *constructor, LamList *args) { - int nargs = (int) countLamList(args); +static LamExp *makeConstructorApplication(LamExp *constructor, LamArgs *args) { + int nargs = (int) countLamArgs(args); LamExp *result; int arity = findUnderlyingArity(constructor); if (nargs < arity) { LamVarList *fargs = genSymVarList(CPI(constructor), arity); int save = PROTECT(fargs); - LamList *aargs = varListToList(fargs); + LamArgs *aargs = varListToList(fargs); PROTECT(aargs); LamApply *innerApply = newLamApply(CPI(constructor), constructor, aargs); PROTECT(innerApply); @@ -1078,7 +1078,7 @@ static LamExp *makeStructureApplication(LamExp *constructor, AstTaggedExpression conversionError(CPI(constructor), "wrong number of args in structure application"); return lamExpError(CPI(tags)); } - LamList *args = convertTagsToArgs(constructor->val.constructor->tags, tags, env); + LamArgs *args = convertTagsToArgs(constructor->val.constructor->tags, tags, env); int save = PROTECT(args); LamApply *apply = newLamApply(CPI(constructor), constructor, args); PROTECT(apply); @@ -1124,7 +1124,7 @@ static LamExp *convertStructure(AstStruct *structure, LamContext *env) { } static LamExp *convertFunCall(AstFunCall *funCall, LamContext *env) { - LamList *args = convertExpressions(funCall->arguments, env); + LamArgs *args = convertExpressions(funCall->arguments, env); int save = PROTECT(args); LamExp *function = convertExpression(funCall->function, env); PROTECT(function); @@ -1314,17 +1314,17 @@ static LamExp *convertSymbol(ParserInfo I, HashSymbol *symbol, LamContext *env) static LamExp *convertAssertion(AstExpression *value, LamContext *env) { LamExp *exp = convertExpression(value, env); int save = PROTECT(exp); - LamList *args = newLamList(CPI(exp), exp, NULL); + LamArgs *args = newLamArgs(CPI(exp), exp, NULL); PROTECT(args); - LamExp *fileName = stringToLamList(CPI(exp), exp->_yy_parser_info.filename); + LamExp *fileName = stringToLamArgs(CPI(exp), exp->_yy_parser_info.filename); PROTECT(fileName); - args = newLamList(CPI(exp), fileName, args); + args = newLamArgs(CPI(exp), fileName, args); PROTECT(args); MaybeBigInt *num = fakeBigInt(exp->_yy_parser_info.lineno, false); PROTECT(num); LamExp *lineNo = newLamExp_Biginteger(CPI(exp), num); PROTECT(lineNo); - args = newLamList(CPI(lineNo), lineNo, args); + args = newLamArgs(CPI(lineNo), lineNo, args); PROTECT(args); LamExp *function = newLamExp_Var(CPI(value), assertSymbol()); PROTECT(function); @@ -1336,17 +1336,17 @@ static LamExp *convertAssertion(AstExpression *value, LamContext *env) { static LamExp *convertError(AstExpression *value, LamContext *env) { LamExp *exp = convertExpression(value, env); int save = PROTECT(exp); - LamList *args = newLamList(CPI(exp), exp, NULL); + LamArgs *args = newLamArgs(CPI(exp), exp, NULL); PROTECT(args); - LamExp *fileName = stringToLamList(CPI(value), value->_yy_parser_info.filename); + LamExp *fileName = stringToLamArgs(CPI(value), value->_yy_parser_info.filename); PROTECT(fileName); - args = newLamList(CPI(exp), fileName, args); + args = newLamArgs(CPI(exp), fileName, args); PROTECT(args); MaybeBigInt *num = fakeBigInt(value->_yy_parser_info.lineno, false); PROTECT(num); LamExp *lineNo = newLamExp_Biginteger(CPI(exp), num); PROTECT(lineNo); - args = newLamList(CPI(lineNo), lineNo, args); + args = newLamArgs(CPI(lineNo), lineNo, args); PROTECT(args); LamExp *function = newLamExp_Var(CPI(value), fnErrorSymbol()); PROTECT(function); @@ -1426,15 +1426,15 @@ static LamExp *convertExpression(AstExpression *expression, LamContext *env) { return result; } -static LamList *convertExpressions(AstExpressions *expressions, +static LamArgs *convertExpressions(AstExpressions *expressions, LamContext *env) { if (expressions == NULL) return NULL; - LamList *next = convertExpressions(expressions->next, env); + LamArgs *next = convertExpressions(expressions->next, env); int save = PROTECT(next); LamExp *exp = convertExpression(expressions->expression, env); (void) PROTECT(exp); - LamList *this = newLamList(CPI(exp), exp, next); + LamArgs *this = newLamArgs(CPI(exp), exp, next); UNPROTECT(save); return this; } diff --git a/src/lambda_pp.c b/src/lambda_pp.c index bbc2227..bf66385 100644 --- a/src/lambda_pp.c +++ b/src/lambda_pp.c @@ -94,11 +94,8 @@ void ppLamExp(LamExp *exp) { case LAMEXP_TYPE_PRIM: ppLamPrimApp(exp->val.prim); break; - case LAMEXP_TYPE_UNARY: - ppLamUnary(exp->val.unary); - break; - case LAMEXP_TYPE_LIST: - ppLamSequence(exp->val.list); + case LAMEXP_TYPE_SEQUENCE: + ppLamSequence(exp->val.sequence); break; case LAMEXP_TYPE_MAKEVEC: ppLamMakeVec(exp->val.makeVec); @@ -253,9 +250,6 @@ void ppLamPrimOp(LamPrimOp type) { case LAMPRIMOP_TYPE_VEC: eprintf("vec"); break; - case LAMPRIMOP_TYPE_XOR: - eprintf("xor"); - break; case LAMPRIMOP_TYPE_MOD: eprintf("mod"); break; @@ -270,28 +264,6 @@ void ppLamPrimOp(LamPrimOp type) { } } -void ppLamUnary(LamUnaryApp *unaryApp) { - if (unaryApp == NULL) { - eprintf(""); - return; - } - eprintf("("); - ppLamUnaryOp(unaryApp->type); - eprintf(" "); - ppLamExp(unaryApp->exp); - eprintf(")"); -} - -void ppLamUnaryOp(LamUnaryOp type) { - switch (type) { - case LAMUNARYOP_TYPE_NOT: - eprintf("not"); - break; - default: - cant_happen("unrecognised type %s in ppLamUnaryOp", lamUnaryOpName(type)); - } -} - static void _ppLamSequence(LamSequence *sequence) { if (sequence == NULL) return; @@ -302,17 +274,17 @@ static void _ppLamSequence(LamSequence *sequence) { } } -static void _ppLamList(LamList *list) { +static void _ppLamArgs(LamArgs *list) { if (list == NULL) return; eprintf(" "); ppLamExp(list->exp); - _ppLamList(list->next); + _ppLamArgs(list->next); } -void ppLamMakeTuple(LamList *args) { +void ppLamMakeTuple(LamArgs *args) { eprintf("(make-tuple"); - _ppLamList(args); + _ppLamArgs(args); eprintf(")"); } @@ -328,7 +300,7 @@ void ppLamMakeVec(LamMakeVec *makeVec) { return; } eprintf("(make-vec"); - _ppLamList(makeVec->args); + _ppLamArgs(makeVec->args); eprintf(")"); } @@ -339,7 +311,7 @@ void ppLamApply(LamApply *apply) { } eprintf("("); ppLamExp(apply->function); - _ppLamList(apply->args); + _ppLamArgs(apply->args); eprintf(")"); } @@ -677,7 +649,7 @@ void ppLamConstruct(LamConstruct *construct) { eprintf("(construct "); ppHashSymbol(construct->name); eprintf(":%d", construct->tag); - _ppLamList(construct->args); + _ppLamArgs(construct->args); eprintf(")"); } diff --git a/src/lambda_pp.h b/src/lambda_pp.h index f444375..e9e56f5 100644 --- a/src/lambda_pp.h +++ b/src/lambda_pp.h @@ -30,8 +30,6 @@ void ppLamExp(LamExp *exp); void ppHashSymbol(HashSymbol *symbol); void ppLamPrimApp(LamPrimApp *primApp); void ppLamPrimOp(LamPrimOp type); -void ppLamUnary(LamUnaryApp *unaryApp); -void ppLamUnaryOp(LamUnaryOp type); void ppLamSequence(LamSequence *sequence); void ppLamMakeVec(LamMakeVec *makeVec); void ppLamApply(LamApply *apply); @@ -49,7 +47,7 @@ void ppLamMatch(LamMatch *match); void ppLamTupleIndex(LamTupleIndex *index); void ppLamLetRecBindings(LamLetRecBindings *bindings); void ppLamIntList(LamIntList *list); -void ppLamMakeTuple(LamList *args); +void ppLamMakeTuple(LamArgs *args); void ppLamNamespaces(LamNamespaceArray *arr); void ppLamLookup(LamLookup *lookup); void ppLamContext(LamContext *env); diff --git a/src/lambda_simplfication.c b/src/lambda_simplfication.c index d6e6687..b6fb04a 100644 --- a/src/lambda_simplfication.c +++ b/src/lambda_simplfication.c @@ -58,13 +58,6 @@ static LamPrimApp *performPrimSimplifications(LamPrimApp *prim) { return prim; } -static LamUnaryApp *performUnarySimplifications(LamUnaryApp *unary) { - ENTER(performUnarySimplifications); - unary->exp = lamPerformSimplifications(unary->exp); - LEAVE(performUnarySimplifications); - return unary; -} - static LamSequence *_performSequenceSimplifications(LamSequence *sequence) { ENTER(_performSequenceSimplifications); if (sequence == NULL) { @@ -88,20 +81,20 @@ static LamExp *performSequenceSimplifications(ParserInfo I, LamSequence *sequenc } #endif int save = PROTECT(sequence); - LamExp *res = newLamExp_List(I, sequence); + LamExp *res = newLamExp_Sequence(I, sequence); UNPROTECT(save); return res; } -static LamList *performListSimplifications(LamList *list) { - ENTER(performListSimplifications); +static LamArgs *performArgsSimplifications(LamArgs *list) { + ENTER(performArgsSimplifications); if (list == NULL) { - LEAVE(performListSimplifications); + LEAVE(performArgsSimplifications); return NULL; } - list->next = performListSimplifications(list->next); + list->next = performArgsSimplifications(list->next); list->exp = lamPerformSimplifications(list->exp); - LEAVE(performListSimplifications); + LEAVE(performArgsSimplifications); return list; } @@ -123,7 +116,7 @@ static LamLookup *performLookupSimplifications(LamLookup *lookup) { static LamMakeVec *performMakeVecSimplifications(LamMakeVec *makeVec) { ENTER(performMakeVecSimplifications); - makeVec->args = performListSimplifications(makeVec->args); + makeVec->args = performArgsSimplifications(makeVec->args); LEAVE(performMakeVecSimplifications); return makeVec; } @@ -137,7 +130,7 @@ static LamDeconstruct *performDeconstructSimplifications(LamDeconstruct *deconst static LamConstruct *performConstructSimplifications(LamConstruct *construct) { ENTER(performConstructSimplifications); - construct->args = performListSimplifications(construct->args); + construct->args = performArgsSimplifications(construct->args); LEAVE(performConstructSimplifications); return construct; } @@ -145,7 +138,7 @@ static LamConstruct *performConstructSimplifications(LamConstruct *construct) { static LamApply *performApplySimplifications(LamApply *apply) { ENTER(performApplySimplifications); apply->function = lamPerformSimplifications(apply->function); - apply->args = performListSimplifications(apply->args); + apply->args = performArgsSimplifications(apply->args); LEAVE(performApplySimplifications); return apply; } @@ -306,11 +299,8 @@ LamExp *lamPerformSimplifications(LamExp *exp) { case LAMEXP_TYPE_PRIM: exp->val.prim = performPrimSimplifications(exp->val.prim); break; - case LAMEXP_TYPE_UNARY: - exp->val.unary = performUnarySimplifications(exp->val.unary); - break; - case LAMEXP_TYPE_LIST: - exp = performSequenceSimplifications(CPI(exp), exp->val.list); + case LAMEXP_TYPE_SEQUENCE: + exp = performSequenceSimplifications(CPI(exp), exp->val.sequence); break; case LAMEXP_TYPE_MAKEVEC: exp->val.makeVec = performMakeVecSimplifications(exp->val.makeVec); @@ -352,7 +342,7 @@ LamExp *lamPerformSimplifications(LamExp *exp) { exp->val.amb = performAmbSimplifications(exp->val.amb); break; case LAMEXP_TYPE_MAKE_TUPLE: - exp->val.make_tuple = performListSimplifications(exp->val.make_tuple); + exp->val.make_tuple = performArgsSimplifications(exp->val.make_tuple); break; case LAMEXP_TYPE_TUPLE_INDEX: exp->val.tuple_index = performTupleIndexSimplifications(exp->val.tuple_index); diff --git a/src/lambda_substitution.c b/src/lambda_substitution.c index 7bfa890..3f7931f 100644 --- a/src/lambda_substitution.c +++ b/src/lambda_substitution.c @@ -92,14 +92,6 @@ static LamPrimApp *performPrimSubstitutions(LamPrimApp *prim, TpmcSubstitutionTa return prim; } -static LamUnaryApp *performUnarySubstitutions(LamUnaryApp *unary, TpmcSubstitutionTable - *substitutions) { - ENTER(performUnarySubstitutions); - unary->exp = lamPerformSubstitutions(unary->exp, substitutions); - LEAVE(performUnarySubstitutions); - return unary; -} - static LamSequence *performSequenceSubstitutions(LamSequence *sequence, TpmcSubstitutionTable *substitutions) { ENTER(performSequenceSubstitutions); @@ -114,16 +106,16 @@ static LamSequence *performSequenceSubstitutions(LamSequence *sequence, TpmcSubs return sequence; } -static LamList *performListSubstitutions(LamList *list, TpmcSubstitutionTable +static LamArgs *performArgsSubstitutions(LamArgs *list, TpmcSubstitutionTable *substitutions) { - ENTER(performListSubstitutions); + ENTER(performArgsSubstitutions); if (list == NULL) { - LEAVE(performListSubstitutions); + LEAVE(performArgsSubstitutions); return NULL; } - list->next = performListSubstitutions(list->next, substitutions); + list->next = performArgsSubstitutions(list->next, substitutions); list->exp = lamPerformSubstitutions(list->exp, substitutions); - LEAVE(performListSubstitutions); + LEAVE(performArgsSubstitutions); return list; } @@ -147,7 +139,7 @@ static LamLookup *performLookupSubstitutions(LamLookup *lookup, TpmcSubstitution static LamMakeVec *performMakeVecSubstitutions(LamMakeVec *makeVec, TpmcSubstitutionTable *substitutions) { ENTER(performMakeVecSubstitutions); - makeVec->args = performListSubstitutions(makeVec->args, substitutions); + makeVec->args = performArgsSubstitutions(makeVec->args, substitutions); LEAVE(performMakeVecSubstitutions); return makeVec; } @@ -166,7 +158,7 @@ static LamConstruct *performConstructSubstitutions(LamConstruct *construct, Tpmc *substitutions) { ENTER(performConstructSubstitutions); construct->args = - performListSubstitutions(construct->args, substitutions); + performArgsSubstitutions(construct->args, substitutions); LEAVE(performConstructSubstitutions); return construct; } @@ -175,7 +167,7 @@ static LamApply *performApplySubstitutions(LamApply *apply, TpmcSubstitutionTabl *substitutions) { ENTER(performApplySubstitutions); apply->function = lamPerformSubstitutions(apply->function, substitutions); - apply->args = performListSubstitutions(apply->args, substitutions); + apply->args = performArgsSubstitutions(apply->args, substitutions); LEAVE(performApplySubstitutions); return apply; } @@ -357,13 +349,9 @@ LamExp *lamPerformSubstitutions(LamExp *exp, exp->val.prim = performPrimSubstitutions(exp->val.prim, substitutions); break; - case LAMEXP_TYPE_UNARY: - exp->val.unary = - performUnarySubstitutions(exp->val.unary, substitutions); - break; - case LAMEXP_TYPE_LIST: - exp->val.list = - performSequenceSubstitutions(exp->val.list, substitutions); + case LAMEXP_TYPE_SEQUENCE: + exp->val.sequence = + performSequenceSubstitutions(exp->val.sequence, substitutions); break; case LAMEXP_TYPE_MAKEVEC: exp->val.makeVec = @@ -422,7 +410,7 @@ LamExp *lamPerformSubstitutions(LamExp *exp, break; case LAMEXP_TYPE_MAKE_TUPLE: exp->val.make_tuple = - performListSubstitutions(exp->val.make_tuple, substitutions); + performArgsSubstitutions(exp->val.make_tuple, substitutions); break; case LAMEXP_TYPE_TUPLE_INDEX: exp->val.tuple_index = diff --git a/src/macro_substitution.c b/src/macro_substitution.c index f2f92e2..77332fb 100644 --- a/src/macro_substitution.c +++ b/src/macro_substitution.c @@ -129,13 +129,6 @@ static LamPrimApp *performPrimSubstitutions(LamPrimApp *prim, LamMacroArgsTable return prim; } -static LamUnaryApp *performUnarySubstitutions(LamUnaryApp *unary, LamMacroArgsTable *symbols) { - ENTER(performUnarySubstitutions); - unary->exp = lamPerformMacroSubstitutions(unary->exp, symbols); - LEAVE(performUnarySubstitutions); - return unary; -} - static LamSequence *performSequenceSubstitutions(LamSequence *sequence, LamMacroArgsTable *symbols) { ENTER(performSequenceSubstitutions); if (sequence == NULL) { @@ -149,15 +142,15 @@ static LamSequence *performSequenceSubstitutions(LamSequence *sequence, LamMacro return sequence; } -static LamList *performListSubstitutions(LamList *list, LamMacroArgsTable *symbols) { - ENTER(performListSubstitutions); +static LamArgs *performArgsSubstitutions(LamArgs *list, LamMacroArgsTable *symbols) { + ENTER(performArgsSubstitutions); if (list == NULL) { - LEAVE(performListSubstitutions); + LEAVE(performArgsSubstitutions); return NULL; } - list->next = performListSubstitutions(list->next, symbols); + list->next = performArgsSubstitutions(list->next, symbols); list->exp = lamPerformMacroSubstitutions(list->exp, symbols); - LEAVE(performListSubstitutions); + LEAVE(performArgsSubstitutions); return list; } @@ -179,7 +172,7 @@ static LamLookup *performLookupSubstitutions(LamLookup *lookup, LamMacroArgsTabl static LamMakeVec *performMakeVecSubstitutions(LamMakeVec *makeVec, LamMacroArgsTable *symbols) { ENTER(performMakeVecSubstitutions); - makeVec->args = performListSubstitutions(makeVec->args, symbols); + makeVec->args = performArgsSubstitutions(makeVec->args, symbols); LEAVE(performMakeVecSubstitutions); return makeVec; } @@ -195,7 +188,7 @@ static LamDeconstruct *performDeconstructSubstitutions(LamDeconstruct *deconstru static LamConstruct *performConstructSubstitutions(LamConstruct *construct, LamMacroArgsTable *symbols) { ENTER(performConstructSubstitutions); construct->args = - performListSubstitutions(construct->args, symbols); + performArgsSubstitutions(construct->args, symbols); LEAVE(performConstructSubstitutions); return construct; } @@ -203,7 +196,7 @@ static LamConstruct *performConstructSubstitutions(LamConstruct *construct, LamM static LamApply *performApplySubstitutions(LamApply *apply, LamMacroArgsTable *symbols) { ENTER(performApplySubstitutions); apply->function = lamPerformMacroSubstitutions(apply->function, symbols); - apply->args = performListSubstitutions(apply->args, symbols); + apply->args = performArgsSubstitutions(apply->args, symbols); LEAVE(performApplySubstitutions); return apply; } @@ -392,11 +385,8 @@ LamExp *lamPerformMacroSubstitutions(LamExp *exp, LamMacroArgsTable *symbols) { case LAMEXP_TYPE_PRIM: exp->val.prim = performPrimSubstitutions(exp->val.prim, symbols); break; - case LAMEXP_TYPE_UNARY: - exp->val.unary = performUnarySubstitutions(exp->val.unary, symbols); - break; - case LAMEXP_TYPE_LIST: - exp->val.list = performSequenceSubstitutions(exp->val.list, symbols); + case LAMEXP_TYPE_SEQUENCE: + exp->val.sequence = performSequenceSubstitutions(exp->val.sequence, symbols); break; case LAMEXP_TYPE_MAKEVEC: exp->val.makeVec = performMakeVecSubstitutions(exp->val.makeVec, symbols); @@ -438,7 +428,7 @@ LamExp *lamPerformMacroSubstitutions(LamExp *exp, LamMacroArgsTable *symbols) { exp->val.amb = performAmbSubstitutions(exp->val.amb, symbols); break; case LAMEXP_TYPE_MAKE_TUPLE: - exp->val.make_tuple = performListSubstitutions(exp->val.make_tuple, symbols); + exp->val.make_tuple = performArgsSubstitutions(exp->val.make_tuple, symbols); break; case LAMEXP_TYPE_TUPLE_INDEX: exp->val.tuple_index = performTupleIndexSubstitutions(exp->val.tuple_index, symbols); diff --git a/src/pratt_parser.c b/src/pratt_parser.c index 7e77aee..d8c9bb0 100644 --- a/src/pratt_parser.c +++ b/src/pratt_parser.c @@ -85,7 +85,7 @@ static AstExpression *expressionPrecedence(PrattParser *, int); static AstExpression *fn(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); static AstExpression *grouping(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); static AstExpression *iff(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); -static AstExpression *infixLeft(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); +// static AstExpression *infixLeft(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); static AstExpression *infixRight(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); static AstExpression *list(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); static AstExpression *lookup(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); @@ -202,7 +202,7 @@ static PrattParser *makePrattParser(void) { addRecord(table, TOK_ASSIGN(), NULL, 0, exprAlias, 60, NULL, 0); - addRecord(table, TOK_COLON(), NULL, 0, infixLeft, 70, NULL, 0); + addRecord(table, TOK_COLON(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_HASH(), doPrefix, 120, NULL, 0, NULL, 0); @@ -1760,11 +1760,19 @@ static AstFunCall *conslist(PrattParser *parser) { AstExpression *nil = newAstExpression_Symbol(PI, nilSymbol()); PROTECT(nil); res = newAstFunCall(PI, nil, NULL); + } else if (check(parser, TOK_EOF())) { + parserError(parser, "unexpected EOF"); + UNPROTECT(save); + return NULL; } else { AstExpression *expr = expression(parser); PROTECT(expr); match(parser, TOK_COMMA()); AstFunCall *rest = conslist(parser); + if (rest == NULL) { + UNPROTECT(save); + return NULL; + } PROTECT(rest); AstExpression *fc = newAstExpression_FunCall(CPI(rest), rest); PROTECT(fc); @@ -2007,6 +2015,7 @@ static AstExpression *tuple(PrattRecord *record __attribute__((unused)), return res; } +/* static AstExpression *infixLeft(PrattRecord *record, PrattParser *parser, AstExpression *lhs, PrattToken *tok __attribute__((unused))) { ENTER(infixLeft); @@ -2017,6 +2026,7 @@ PrattToken *tok __attribute__((unused))) { UNPROTECT(save); return rhs; } +*/ static AstExpression *lookup(PrattRecord *record, PrattParser *parser, AstExpression *lhs, PrattToken *tok __attribute__((unused))) { diff --git a/src/pratt_scanner.c b/src/pratt_scanner.c index 93af2f0..680ac83 100644 --- a/src/pratt_scanner.c +++ b/src/pratt_scanner.c @@ -734,6 +734,8 @@ static PrattToken *parseString(PrattParser *parser, bool single, char sep) { state = PRATTSTRINGSTATE_TYPE_END; } else { parserError(parser, "expected terminator"); + ++buffer->length; + state = PRATTSTRINGSTATE_TYPE_END; } break; case PRATTSTRINGSTATE_TYPE_END: diff --git a/src/preamble.fn b/src/preamble.fn index 7dc9cab..ea0a3e0 100644 --- a/src/preamble.fn +++ b/src/preamble.fn @@ -141,6 +141,8 @@ fn error_(line, file, message) { exit(1); } +infix right 120 "of" fn (f, g, x) { f(g(x)) }; + fn append { ([], b) { b } (h @ t, b) { h @ append(t, b) } @@ -221,14 +223,14 @@ fn print_tuple_0(t) { t } -unsafe fn print_tuple_1(pa, t=#(a)) { +fn print_tuple_1(pa, t=#(a)) { puts("#("); pa(a); puts(")"); t } -unsafe fn print_tuple_2(pa, pb, t=#(a, b)) { +fn print_tuple_2(pa, pb, t=#(a, b)) { puts("#("); pa(a); puts(", "); @@ -237,7 +239,7 @@ unsafe fn print_tuple_2(pa, pb, t=#(a, b)) { t } -unsafe fn print_tuple_3(pa, pb, pc, t=#(a, b, c)) { +fn print_tuple_3(pa, pb, pc, t=#(a, b, c)) { puts("#("); pa(a); puts(", "); @@ -248,7 +250,7 @@ unsafe fn print_tuple_3(pa, pb, pc, t=#(a, b, c)) { t } -unsafe fn print_tuple_4(pa, pb, pc, pd, t=#(a, b, c, d)) { +fn print_tuple_4(pa, pb, pc, pd, t=#(a, b, c, d)) { puts("#("); pa(a); puts(", "); diff --git a/src/print_compiler.c b/src/print_compiler.c index 4d28477..9e4b7ff 100644 --- a/src/print_compiler.c +++ b/src/print_compiler.c @@ -50,7 +50,7 @@ static LamExp *compilePrinter(ParserInfo I, TcType *type, TcEnv *env); static LamExp *makePutcExp(ParserInfo I, char c) { LamExp *character = newLamExp_Character(I, c); int save = PROTECT(character); - LamList *putcArgs = newLamList(I, character, NULL); + LamArgs *putcArgs = newLamArgs(I, character, NULL); PROTECT(putcArgs); LamExp *putc = newLamExp_Var(I, newSymbol("putc")); PROTECT(putc); @@ -79,7 +79,7 @@ LamExp *compilePrinterForType(ParserInfo I, TcType *type, TcEnv *env) { PROTECT(seq); // (printer x) (putc '\n') x) - LamList *args = newLamList(I, var, NULL); + LamArgs *args = newLamArgs(I, var, NULL); PROTECT(args); LamApply *apply = newLamApply(I, printer, args); PROTECT(apply); @@ -91,7 +91,7 @@ LamExp *compilePrinterForType(ParserInfo I, TcType *type, TcEnv *env) { // (lambda (x) (begin (printer x) (putc '\n') x) LamVarList *fargs = newLamVarList(I, name, NULL); PROTECT(fargs); - LamExp *body = newLamExp_List(I, seq); + LamExp *body = newLamExp_Sequence(I, seq); PROTECT(body); LamLam *lambda = newLamLam(I, fargs, body); PROTECT(lambda); @@ -164,31 +164,31 @@ static LamExp *compilePrinterForChar(ParserInfo I) { return makePrintChar(I); } -static LamList *compilePrinterForUserTypeArgs(ParserInfo I, TcUserTypeArgs *args, +static LamArgs *compilePrinterForUserTypeArgs(ParserInfo I, TcUserTypeArgs *args, TcEnv *env) { ENTER(compilePrinterForUserTypeArgs); if (args == NULL) { LEAVE(compilePrinterForUserTypeArgs); return NULL; } - LamList *next = compilePrinterForUserTypeArgs(I, args->next, env); + LamArgs *next = compilePrinterForUserTypeArgs(I, args->next, env); int save = PROTECT(next); LamExp *this = compilePrinter(I, args->type, env); PROTECT(this); - LamList *res = newLamList(I, this, next); + LamArgs *res = newLamArgs(I, this, next); UNPROTECT(save); LEAVE(compilePrinterForUserTypeArgs); return res; } -static LamList *compilePrinterForTupleArgs(ParserInfo I, TcTypeArray *tuple, TcEnv *env) { - LamList *res = NULL; +static LamArgs *compilePrinterForTupleArgs(ParserInfo I, TcTypeArray *tuple, TcEnv *env) { + LamArgs *res = NULL; int save = PROTECT(res); for (int i = tuple->size; i > 0; i--) { int index = i - 1; LamExp *this = compilePrinter(I, tuple->entries[index], env); PROTECT(this); - res = newLamList(I, this, res); + res = newLamArgs(I, this, res); PROTECT(res); } UNPROTECT(save); @@ -239,9 +239,9 @@ static LamExp *compilePrinterForUserType(ParserInfo I, TcUserType *userType, TcE exp = newLamExp_Lookup(I, lookup); PROTECT(exp); } - LamList *args = compilePrinterForUserTypeArgs(I, userType->args, env); + LamArgs *args = compilePrinterForUserTypeArgs(I, userType->args, env); PROTECT(args); - int nargs = countLamList(args); + int nargs = countLamArgs(args); if (nargs == 0) { UNPROTECT(save); return exp; @@ -264,7 +264,7 @@ static LamExp *compilePrinterForTuple(ParserInfo I, TcTypeArray *tuple, TcEnv *e return exp; } int save = PROTECT(exp); - LamList *args = compilePrinterForTupleArgs(I, tuple, env); + LamArgs *args = compilePrinterForTupleArgs(I, tuple, env); PROTECT(args); LamApply *apply = newLamApply(I, exp, args); PROTECT(apply); diff --git a/src/print_generator.c b/src/print_generator.c index ece6057..ce821c2 100644 --- a/src/print_generator.c +++ b/src/print_generator.c @@ -119,9 +119,9 @@ static LamExp *makeCharList(ParserInfo I, char c, LamExp *tail) { LamExp *character = newLamExp_Character(I, c); int save = PROTECT(character); - LamList *args = newLamList(I, tail, NULL); + LamArgs *args = newLamArgs(I, tail, NULL); PROTECT(args); - args = newLamList(I, character, args); + args = newLamArgs(I, character, args); PROTECT(args); LamConstruct *cons = newLamConstruct(I, consSymbol(), 1, args); PROTECT(cons); @@ -131,11 +131,11 @@ static LamExp *makeCharList(ParserInfo I, char c, LamExp *tail) { return res; } -LamExp *stringToLamList(ParserInfo I, char *name) { +LamExp *stringToLamArgs(ParserInfo I, char *name) { if (*name == 0) { return makeNullList(I); } - LamExp *next = stringToLamList(I, name + 1); + LamExp *next = stringToLamArgs(I, name + 1); int save = PROTECT(next); LamExp *this = makeCharList(I, *name, next); UNPROTECT(save); @@ -146,7 +146,7 @@ static LamExp *putsExp(ParserInfo I, LamExp *string) { HashSymbol *sym = putsSymbol(); LamExp *puts = newLamExp_Var(I, sym); int save = PROTECT(puts); - LamList *args = newLamList(I, string, NULL); + LamArgs *args = newLamArgs(I, string, NULL); PROTECT(args); LamApply *apply = newLamApply(I, puts, args); PROTECT(apply); @@ -156,7 +156,7 @@ static LamExp *putsExp(ParserInfo I, LamExp *string) { } static LamExp *makePutsString(ParserInfo I, char *str) { - LamExp *string = stringToLamList(I, str); + LamExp *string = stringToLamArgs(I, str); int save = PROTECT(string); LamExp *res = putsExp(I, string); UNPROTECT(save); @@ -164,7 +164,7 @@ static LamExp *makePutsString(ParserInfo I, char *str) { } static LamExp *makePlainMatchBody(ParserInfo I, LamTypeConstructor *constructor) { - LamExp *string = stringToLamList(I, constructor->name->name); + LamExp *string = stringToLamArgs(I, constructor->name->name); int save = PROTECT(string); LamExp *puts = putsExp(I, string); UNPROTECT(save); @@ -205,14 +205,14 @@ static LamExp *makePrintVar(ParserInfo I, HashSymbol *var) { static LamExp *makePrinter(ParserInfo I, LamTypeConstructorType *arg); -static LamList *makePrintArgs(ParserInfo I, LamTypeConstructorArgs *args) { +static LamArgs *makePrintArgs(ParserInfo I, LamTypeConstructorArgs *args) { if (args == NULL) return NULL; - LamList *next = makePrintArgs(I, args->next); + LamArgs *next = makePrintArgs(I, args->next); int save = PROTECT(next); LamExp *printer = makePrinter(I, args->arg); PROTECT(printer); - LamList *this = newLamList(I, printer, next); + LamArgs *this = newLamArgs(I, printer, next); UNPROTECT(save); return this; } @@ -264,9 +264,9 @@ static LamExp *makePrintType(ParserInfo I, LamTypeFunction *function) { int save = PROTECT(exp); exp = wrapTypeFunction(I, exp, function->name); REPLACE_PROTECT(save, exp); - LamList *args = makePrintArgs(I, function->args); + LamArgs *args = makePrintArgs(I, function->args); PROTECT(args); - int nargs = countLamList(args); + int nargs = countLamArgs(args); if (nargs == 0) { UNPROTECT(save); return exp; @@ -292,7 +292,7 @@ static LamExp *makePrintTuple(ParserInfo I, LamTypeConstructorArgs *tuple) { } LamExp *exp = newLamExp_Var(I, name); int save = PROTECT(exp); - LamList *args = makePrintArgs(I, tuple); + LamArgs *args = makePrintArgs(I, tuple); PROTECT(args); LamApply *apply = newLamApply(I, exp, args); PROTECT(apply); @@ -332,7 +332,7 @@ static LamExp *makePrintConstructorArg(ParserInfo I, LamTypeConstructorType *arg int save = PROTECT(accessor); LamExp *printer = makePrinter(I, arg); PROTECT(printer); - LamList *args = newLamList(I, accessor, NULL); + LamArgs *args = newLamArgs(I, accessor, NULL); PROTECT(args); LamApply *apply = newLamApply(I, printer, args); PROTECT(apply); @@ -400,7 +400,7 @@ static LamExp *makeVecMatchBody(ParserInfo I, LamTypeConstructorInfo *info) { PROTECT(seq); seq = newLamSequence(I, header, seq); PROTECT(seq); - LamExp *res = newLamExp_List(I, seq); + LamExp *res = newLamExp_Sequence(I, seq); UNPROTECT(save); return res; } @@ -503,7 +503,7 @@ static LamExp *makeFunctionBody(ParserInfo I, LamTypeConstructorList *constructo PROTECT(seq); seq = newLamSequence(I, res, seq); PROTECT(seq); - res = newLamExp_List(I, seq); + res = newLamExp_Sequence(I, seq); UNPROTECT(save); return res; } diff --git a/src/print_generator.h b/src/print_generator.h index 585f36f..eed5bba 100644 --- a/src/print_generator.h +++ b/src/print_generator.h @@ -29,6 +29,6 @@ LamExp *makeSymbolExpr(ParserInfo I, char *name); LamExp *makePrintInt(ParserInfo); LamExp *makePrintChar(ParserInfo); HashSymbol *makePrintName(char *prefix, char *name); -LamExp *stringToLamList(ParserInfo I, char *name); +LamExp *stringToLamArgs(ParserInfo I, char *name); #endif diff --git a/src/step.c b/src/step.c index 9622ea5..141eb5f 100644 --- a/src/step.c +++ b/src/step.c @@ -286,10 +286,6 @@ static bool _lt(Value left, Value right) { return _cmp(left, right) == CMP_LT; } -static bool _xor(Value left, Value right) { - return truthy(left) ? !truthy(right) : truthy(right); -} - static Value eq(Value left, Value right) { bool result = _eq(left, right); return result ? vTrue : vFalse; @@ -315,19 +311,11 @@ static Value ge(Value left, Value right) { return result ? vFalse : vTrue; } -static Value xor(Value left, Value right) { - return _xor(left, right) ? vTrue : vFalse; -} - static Value le(Value left, Value right) { bool result = _gt(left, right); return result ? vFalse : vTrue; } -static Value not(Value left) { - return truthy(left) ? vFalse : vTrue; -} - static Value vec(Value index, Value vector) { #ifdef SAFETY_CHECKS if (index.type != VALUE_TYPE_STDINT) @@ -734,28 +722,6 @@ static void step() { } break; - case BYTECODES_TYPE_PRIM_XOR:{ - // pop two values, perform the binop and push the result - DEBUG("XOR"); - Value right = pop(); - int save = protectValue(right); - Value left = pop(); - protectValue(left); - push(xor(left, right)); - UNPROTECT(save); - } - break; - - case BYTECODES_TYPE_PRIM_NOT:{ - // pop value, perform the op and push the result - DEBUG("NOT"); - Value a = pop(); - int save = protectValue(a); - push(not(a)); - UNPROTECT(save); - } - break; - case BYTECODES_TYPE_PRIM_VEC:{ DEBUG("VEC"); Value b = pop(); diff --git a/src/tc_analyze.c b/src/tc_analyze.c index dd4941d..1715f65 100644 --- a/src/tc_analyze.c +++ b/src/tc_analyze.c @@ -62,7 +62,6 @@ static TcType *analyzeVar(ParserInfo I, HashSymbol *var, TcEnv *env, TcNg *ng); static TcType *analyzeSmallInteger(); static TcType *analyzeBigInteger(); static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng); -static TcType *analyzeUnary(LamUnaryApp *app, TcEnv *env, TcNg *ng); static TcType *analyzeSequence(LamSequence *sequence, TcEnv *env, TcNg *ng); static TcType *analyzeConstruct(LamConstruct *construct, TcEnv *env, TcNg *ng); static TcType *analyzeDeconstruct(LamDeconstruct *deconstruct, TcEnv *env, TcNg *ng); @@ -79,7 +78,7 @@ static TcType *analyzeMatch(LamMatch *match, TcEnv *env, TcNg *ng); static TcType *analyzeCond(LamCond *cond, TcEnv *env, TcNg *ng); static TcType *analyzeAmb(LamAmb *amb, TcEnv *env, TcNg *ng); static TcType *analyzeTupleIndex(LamTupleIndex *index, TcEnv *env, TcNg *ng); -static TcType *analyzeMakeTuple(LamList *tuple, TcEnv *env, TcNg *ng); +static TcType *analyzeMakeTuple(LamArgs *tuple, TcEnv *env, TcNg *ng); static TcType *analyzeNamespaces(LamNamespaceArray *nsArray, TcEnv *env, TcNg *ng); static TcType *analyzeCharacter(); static TcType *analyzeBack(); @@ -229,10 +228,8 @@ static TcType *analyzeExp(LamExp *exp, TcEnv *env, TcNg *ng) { return prune(analyzeBigInteger()); case LAMEXP_TYPE_PRIM: return prune(analyzePrim(exp->val.prim, env, ng)); - case LAMEXP_TYPE_UNARY: - return prune(analyzeUnary(exp->val.unary, env, ng)); - case LAMEXP_TYPE_LIST: - return prune(analyzeSequence(exp->val.list, env, ng)); + case LAMEXP_TYPE_SEQUENCE: + return prune(analyzeSequence(exp->val.sequence, env, ng)); case LAMEXP_TYPE_MAKEVEC: cant_happen("encountered make-vec in analyzeExp"); case LAMEXP_TYPE_CONSTRUCT: @@ -408,22 +405,6 @@ static TcType *analyzeSpaceship(LamExp *exp1, LamExp *exp2, TcEnv *env, return res; } -static TcType *analyzeBinaryBool(LamExp *exp1, LamExp *exp2, TcEnv *env, - TcNg *ng) { - // ENTER(analyzeBinaryBool); - (void) analyzeBooleanExp(exp1, env, ng); - TcType *res = analyzeBooleanExp(exp2, env, ng); - // LEAVE(analyzeBinaryBool); - return res; -} - -static TcType *analyzeUnaryBool(LamExp *exp, TcEnv *env, TcNg *ng) { - // ENTER(analyzeUnaryBool); - TcType *res = analyzeBooleanExp(exp, env, ng); - // LEAVE(analyzeUnaryBool); - return res; -} - static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng) { // ENTER(analyzePrim); TcType *res = NULL; @@ -450,9 +431,6 @@ static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng) { case LAMPRIMOP_TYPE_VEC: cant_happen("encountered VEC in analyzePrim"); break; - case LAMPRIMOP_TYPE_XOR: - res = analyzeBinaryBool(app->exp1, app->exp2, env, ng); - break; default: cant_happen("unrecognised type %d in analyzePrim", app->type); } @@ -460,20 +438,6 @@ static TcType *analyzePrim(LamPrimApp *app, TcEnv *env, TcNg *ng) { return res; } -static TcType *analyzeUnary(LamUnaryApp *app, TcEnv *env, TcNg *ng) { - // ENTER(analyzeUnary); - TcType *res = NULL; - switch (app->type) { - case LAMUNARYOP_TYPE_NOT: - res = analyzeUnaryBool(app->exp, env, ng); - break; - default: - cant_happen("unrecognized type %d in analyzeUnary", app->type); - } - // LEAVE(analyzeUnary); - return res; -} - static TcType *analyzeSequence(LamSequence *sequence, TcEnv *env, TcNg *ng) { // ENTER(analyzeSequence); if (sequence == NULL) { @@ -583,7 +547,7 @@ static TcType *analyzeTupleIndex(LamTupleIndex *index, TcEnv *env, TcNg *ng) { return template->val.tuple->entries[index->vec]; } -static TcType *analyzeMakeTuple(LamList *tuple, TcEnv *env, TcNg *ng) { +static TcType *analyzeMakeTuple(LamArgs *tuple, TcEnv *env, TcNg *ng) { TcTypeArray *values = newTcTypeArray(); int save = PROTECT(values); while (tuple != NULL) { @@ -670,12 +634,12 @@ static TcType *analyzeConstant(LamConstant *constant, TcEnv *env, TcNg *ng) { // apply(fn) => fn // apply(fn, arg_1, arg_2, arg_3) => apply(apply(apply(fn, arg1), arg_2), arg_3) static LamApply *curryLamApplyHelper(int nargs, LamExp *function, - LamList *args) { + LamArgs *args) { if (nargs == 1) { LamApply *res = newLamApply(CPI(function), function, args); return res; } - LamList *singleArg = newLamList(CPI(args), args->exp, NULL); + LamArgs *singleArg = newLamArgs(CPI(args), args->exp, NULL); int save = PROTECT(singleArg); LamApply *new = newLamApply(CPI(function), function, singleArg); PROTECT(new); @@ -688,12 +652,12 @@ static LamApply *curryLamApplyHelper(int nargs, LamExp *function, } static LamApply *curryLamApply(LamApply *apply) { - return curryLamApplyHelper(countLamList(apply->args), apply->function, apply->args); + return curryLamApplyHelper(countLamArgs(apply->args), apply->function, apply->args); } static TcType *analyzeApply(LamApply *apply, TcEnv *env, TcNg *ng) { // ENTER(analyzeApply); - switch (countLamList(apply->args)) { + switch (countLamArgs(apply->args)) { case 0:{ TcType *res = analyzeExp(apply->function, env, ng); // LEAVE(analyzeApply); @@ -823,8 +787,12 @@ static void processLetRecBinding(LamLetRecBindings *bindings, TcEnv *env, TcType *type = analyzeExp(bindings->val, env, ng2); PROTECT(type); if (!unify(existingType, type, "letrec")) { - eprintf("while unifying %s with ", bindings->var->name); + eprintf("while unifying letrec %s with ", bindings->var->name); ppLamExp(bindings->val); + eprintf("\nExisting Type: "); + ppTcType(existingType); + eprintf("\nNew Type: "); + ppTcType(type); eprintf("\n"); REPORT_PARSER_INFO(bindings->val); } @@ -864,6 +832,15 @@ static TcType *analyzeLetRec(LamLetRec *letRec, TcEnv *env, TcNg *ng) { } } } + // HACK! third pass through fixes up even more forward references + if (!hadErrors()) { + for (LamLetRecBindings *bindings = letRec->bindings; bindings != NULL; + bindings = bindings->next) { + if (isLambdaBinding(bindings)) { + processLetRecBinding(bindings, env, ng); + } + } + } TcType *res = analyzeExp(letRec->body, env, ng); UNPROTECT(save); // LEAVE(analyzeLetRec); @@ -1812,7 +1789,7 @@ static bool unifyOpaque(HashSymbol *a, HashSymbol *b) { static bool unifyUserTypes(TcUserType *a, TcUserType *b) { if (a->name != b->name) { - can_happen("unification failed [usertype name mismatch]"); + can_happen("\nunification failed [usertype name mismatch %s vs %s]", a->name->name, b->name->name); ppTcUserType(a); eprintf(" vs "); ppTcUserType(b); @@ -1820,7 +1797,7 @@ static bool unifyUserTypes(TcUserType *a, TcUserType *b) { return false; } if (a->ns != b->ns) { - can_happen("unification failed [usertype namespace mismatch]"); + can_happen("\nunification failed [usertype namespace mismatch]"); ppTcUserType(a); eprintf(" vs "); ppTcUserType(b); @@ -1838,7 +1815,7 @@ static bool unifyUserTypes(TcUserType *a, TcUserType *b) { bArgs = bArgs->next; } if (aArgs != NULL || bArgs != NULL) { - can_happen("unification failed [usertype arg count mismatch]"); + can_happen("\nunification failed [usertype arg count mismatch]"); ppTcUserType(a); eprintf(" vs "); ppTcUserType(b); @@ -1871,7 +1848,7 @@ static bool _unify(TcType *a, TcType *b) { return unify(b, a, "unify"); } else { if (a->type != b->type) { - can_happen("unification failed [type mismatch]"); + can_happen("\nunification failed [type mismatch]"); ppTcType(a); eprintf(" vs "); ppTcType(b); diff --git a/src/tc_helper.c b/src/tc_helper.c index 4c1b225..cc8e4b4 100644 --- a/src/tc_helper.c +++ b/src/tc_helper.c @@ -37,7 +37,7 @@ void ppTcType(TcType *type) { ppTcVar(type->val.var); break; case TCTYPE_TYPE_BIGINTEGER: - eprintf("bigint"); + eprintf("number"); break; case TCTYPE_TYPE_SMALLINTEGER: eprintf("smallint"); @@ -81,7 +81,7 @@ void ppTcPair(TcPair *pair) { } void ppTcVar(TcVar *var) { - eprintf("%s", var->name->name); + eprintf("%s", var->name->name); if (var->instance != NULL) { eprintf(" ["); ppTcType(var->instance); @@ -110,9 +110,12 @@ static void ppUserTypeArgs(TcUserTypeArgs *args) { } void ppTcUserType(TcUserType *userType) { - eprintf("%s:%d(", userType->name->name, userType->ns); - ppUserTypeArgs(userType->args); - eprintf(")"); + eprintf("%s", userType->name->name); + if (userType->args != NULL) { + eprintf("("); + ppUserTypeArgs(userType->args); + eprintf(")"); + } } bool eqTcVar(struct TcVar *a, struct TcVar *b, HashTable *map) { diff --git a/src/tpmc_logic.c b/src/tpmc_logic.c index d1763f5..2d306eb 100644 --- a/src/tpmc_logic.c +++ b/src/tpmc_logic.c @@ -162,7 +162,7 @@ static char *getLookupName(AstLookupOrSymbol *los) { static TpmcPattern *makeConstructorPattern(AstUnpack *unpack, LamContext *env) { LamTypeConstructorInfo *info = lookupScopedAstConstructorInLamContext(env, unpack->symbol); if (info == NULL) { - cant_happen("makeConstructorPattern() passed invalid constructor %s", getLookupName(unpack->symbol)); + cant_happen("makeConstructorPattern() passed invalid constructor: '%s'", getLookupName(unpack->symbol)); } TpmcPatternArray *patterns = convertArgList(unpack->argList, env); int save = PROTECT(patterns); @@ -337,22 +337,20 @@ static void renamePattern(TpmcPattern *pattern, HashSymbol *variable) { } } -static void renameRule(TpmcMatchRule *rule, TpmcVariableArray *rootVariables) { +static void renameRule(TpmcMatchRule *rule, TpmcVariableArray *rootVariables, ParserInfo I) { if (rule->patterns->size != rootVariables->size) { - printTpmcMatchRule(rule, 0); - eprintf("\n"); - printTpmcVariableArray(rootVariables, 0); - eprintf("\n"); - cant_happen("size mismatch in renameRule"); + can_happen("inconsistent number of arguments (%d vs %d) in +%d %s", rule->patterns->size, rootVariables->size, I.lineno, I.filename); + // will crash otherwise. + exit(1); } - for (Index i = 0; i < rootVariables->size; i++) { + for (Index i = 0; i < rule->patterns->size; i++) { renamePattern(rule->patterns->entries[i], rootVariables->entries[i]); } } -static void renameRules(TpmcMatchRules *input) { +static void renameRules(TpmcMatchRules *input, ParserInfo I) { for (Index i = 0; i < input->rules->size; i++) { - renameRule(input->rules->entries[i], input->rootVariables); + renameRule(input->rules->entries[i], input->rootVariables, I); } } @@ -643,7 +641,7 @@ LamLam *tpmcConvert(bool allow_unsafe, ParserInfo I, int nargs, TpmcMatchRules *input = newTpmcMatchRules(rules, rootVariables); REPLACE_PROTECT(save, input); replaceComparisonRules(input); - renameRules(input); + renameRules(input, I); performRulesSubstitutions(input); // DEBUG("*** RULES ***"); // IFDEBUG(printTpmcMatchRules(input, 0)); diff --git a/src/tpmc_match.c b/src/tpmc_match.c index b148604..a4ae2dd 100644 --- a/src/tpmc_match.c +++ b/src/tpmc_match.c @@ -83,6 +83,7 @@ static bool topRowOnlyVariables(TpmcMatrix *matrix) { } return true; } + static bool columnHasComparisons(int x, TpmcMatrix *matrix) { for (Index y = 0; y < matrix->height; y++) { if (patternIsComparison(getTpmcMatrixIndex(matrix, x, y))) { @@ -319,7 +320,7 @@ static void populateSubPatternMatrixRowWithConstructor(TpmcMatrix *matrix, if (arity != pattern->pattern->val.constructor->components->size) { ppTpmcPattern(pattern); cant_happen - ("arity %d does not match constructor arity %d", + ("\narity %d does not match constructor arity %d", arity, pattern->pattern->val.constructor->components->size); } for (Index i = 0; i < arity; i++) { @@ -462,16 +463,25 @@ static bool arcsAreExhaustive(int size, TpmcArcArray *arcs, ParserInfo I) { for (Index i = 0; i < arcs->size; ++i) { TpmcArc *arc = arcs->entries[i]; TpmcPattern *pattern = arc->test; - if (pattern->pattern->type != TPMCPATTERNVALUE_TYPE_CONSTRUCTOR) { - cant_happen("arcsAreExhaustive given non-constructor arc while parsing %s, line %d", I.filename, I.lineno); - } - LamTypeConstructorInfo *info = - pattern->pattern->val.constructor->info; - if (info->index >= size) { - cant_happen - ("arcsAreExhaustive given constructor %s with out-of-range index (%d >= %d) while parsing %s, line %d", info->name->name, info->index, size, I.filename, I.lineno); + switch (pattern->pattern->type) { + case TPMCPATTERNVALUE_TYPE_CONSTRUCTOR: { + LamTypeConstructorInfo *info = + pattern->pattern->val.constructor->info; + if (info->index >= size) { + cant_happen("arcsAreExhaustive given constructor %s with out-of-range index (%d >= %d) while parsing %s, line %d", info->name->name, info->index, size, I.filename, I.lineno); + } + flags->entries[info->index] = 1; + } + break; + case TPMCPATTERNVALUE_TYPE_TUPLE: { + // tuples are exhaustive + UNPROTECT(save); + return true; + } + break; + default: + cant_happen("arcsAreExhaustive given non-constructor arc while parsing %s, line %d", I.filename, I.lineno); } - flags->entries[info->index] = 1; } bool res = true; for (int i = 0; i < size; i++) { @@ -497,6 +507,9 @@ static bool constructorsAreExhaustive(TpmcState *state, ParserInfo I) { } else if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_CONSTRUCTOR) { int size = pattern->pattern->val.constructor->info->size; return arcsAreExhaustive(size, testState->arcs, I); + } else if (pattern->pattern->type == TPMCPATTERNVALUE_TYPE_TUPLE) { + int size = pattern->pattern->val.tuple->size; + return arcsAreExhaustive(size, testState->arcs, I); } else { return false; } diff --git a/src/tpmc_translate.c b/src/tpmc_translate.c index 27a9258..afed6dd 100644 --- a/src/tpmc_translate.c +++ b/src/tpmc_translate.c @@ -82,17 +82,17 @@ static LamVarList *makeCanonicalArgs(TpmcVariableTable *freeVariables) { return res; } -static LamList *convertVarListToList(LamVarList *vars) { +static LamArgs *convertVarListToList(LamVarList *vars) { ENTER(convertVarListToList); if (vars == NULL) { LEAVE(convertVarListToList); return NULL; } - LamList *next = convertVarListToList(vars->next); + LamArgs *next = convertVarListToList(vars->next); int save = PROTECT(next); LamExp *exp = newLamExp_Var(I, vars->var); PROTECT(exp); - LamList *this = newLamList(I, exp, next); + LamArgs *this = newLamArgs(I, exp, next); UNPROTECT(save); LEAVE(convertVarListToList); return this; @@ -104,7 +104,7 @@ static LamExp *translateToApply(HashSymbol *name, TpmcState *dfa) { int save = PROTECT(function); LamVarList *cargs = makeCanonicalArgs(dfa->freeVariables); PROTECT(cargs); - LamList *args = convertVarListToList(cargs); + LamArgs *args = convertVarListToList(cargs); PROTECT(args); LamApply *apply = newLamApply(I, function, args); PROTECT(apply); diff --git a/tests/fn/test_lists.fn b/tests/fn/test_lists.fn index 7caa433..ce03cac 100644 --- a/tests/fn/test_lists.fn +++ b/tests/fn/test_lists.fn @@ -11,7 +11,7 @@ in assert(list.foldr1(fn (a, b) { a + b }, [1, 2, 3]) == 6); assert(list.reverse("abc") == "cba"); assert(list.scanl(fn (a, b) { a + b }, 0, [1, 2, 3]) == [6, 3, 1, 0]); - assert(list.filter(fn (x) { x != 2 }, [1, 2, 3]) == [3, 1]); + assert(list.filter(fn (x) { x != 2 }, [1, 2, 3]) == [1, 3]); assert(list.concat(["ab", "cd"]) == "abcd"); assert(list.join(", ", ["hello", "world"]) == "hello, world"); assert(list.any(fn (x) { x == 2 }, [1, 2, 3])); diff --git a/tests/fn/test_monad.fn b/tests/fn/test_monad.fn index 1d0fa38..3e95774 100644 --- a/tests/fn/test_monad.fn +++ b/tests/fn/test_monad.fn @@ -9,8 +9,19 @@ let fn maybePlus(ma, mb) { ma >>= fn(a) { mb >>= fn(b) { some(a + b) } } } + + fn safeDiv { + (a, 0) { nothing } + (a, b) { some(a / b) } + } + + fn maybeDiv (ma, mb) { + ma >>= fn(a) { mb >>= fn(b) { safeDiv(a, b) } } + } in assert(maybePlus(some(5), some(10)) == some(15)); assert(maybePlus(some(5), nothing) == nothing); assert(maybePlus(nothing, some(10)) == nothing); assert(maybePlus(nothing, nothing) == nothing); + assert(maybePlus(some(5), maybeDiv(some(15), some(3))) == some(10)); + assert(maybePlus(some(5), maybeDiv(some(15), some(0))) == nothing); diff --git a/tests/src/test_pratt.c b/tests/src/test_pratt.c index db16be7..6de1642 100644 --- a/tests/src/test_pratt.c +++ b/tests/src/test_pratt.c @@ -89,8 +89,8 @@ int main(int argc __attribute__((unused)), char *argv[] __attribute__((unused))) test("(a -> b) -> c", "{ ->(->(a, b), c); }", false); test("a(b)", "{ a(b); }", false); test("a(b, c)", "{ a(b, c); }", false); - test("#(b)", "{ #(b); }", false); - test("#(b, c)", "{ #(b, c); }", false); + test("#(b)", "{ (b); }", false); + test("#(b, c)", "{ (b, c); }", false); test("a #b", "{ a; }", true); test("0x100", "{ 256; }", false); test("0X100i", "{ 256i; }", false); diff --git a/vim/syntax/fnatural.vim b/vim/syntax/fnatural.vim index a16869a..5f4c13c 100644 --- a/vim/syntax/fnatural.vim +++ b/vim/syntax/fnatural.vim @@ -5,7 +5,7 @@ endif syn match fnDelimeter "(\|)\|\[\|\]\|,\|;\|{\|}" highlight link fnDelimeter Delimeter -syntax keyword fnFunction print error rand car cdr putc fputc getc fgetc putn fputn putv fputv puts fputs gets fgets open close assert argv opendir closedir readdir ftype getenv com_real com_imag com_mag com_theta error +syntax keyword fnFunction print error rand car cdr putc fputc getc fgetc putn fputn putv fputv puts fputs gets fgets open openmem close assert argv opendir closedir readdir ftype getenv com_real com_imag com_mag com_theta error highlight link fnFunction Function syntax keyword fnConditional if else then back @@ -14,9 +14,6 @@ highlight link fnConditional Conditional syntax keyword fnKeyword let fn in typedef here link as unsafe namespace switch alias macro infix prefix suffix highlight link fnKeyword Keyword -syntax keyword FnStatement cons -highlight link FnStatement Statement - syntax match fnOperator "\v\*\*" syntax match fnOperator "\v\*" syntax match fnOperator "\v×" @@ -33,10 +30,11 @@ syntax match fnOperator "\v\>\=" syntax match fnOperator "\v\=\=" syntax match fnOperator "\v\!\=" syntax match fnOperator "\v\!" +syntax match fnOperator "\v\|" syntax match fnOperator "\v\<" syntax match fnOperator "\v\>" syntax match fnOperator "\v\=" -syntax keyword fnOperator and nand or nor not xor xnor +syntax keyword fnOperator and nand or nor not xor xnor of highlight link fnOperator Operator syntax region fnString start=/\v'/ skip=/\v\\./ end=/\v'/ @@ -46,11 +44,18 @@ highlight link fnString String syntax match fnComment "\v\/\/.*$" highlight link fnComment Comment -syntax keyword fnConstant true false null nothing some lt eq gt failure success basic_null basic_number basic_string basic_char io_read io_write io_append left right +syntax match fnConstant "\v\[\]" + +syntax keyword fnConstant true false nil nothing some lt eq gt failure success +syntax keyword fnConstant basic_null basic_number basic_string basic_char io_read +syntax keyword fnConstant io_write io_append left right cons _ +syntax keyword fnConstant ftype_socket ftype_symlink ftype_regular ftype_block ftype_dir ftype_char ftype_fifo +syntax keyword fnConstant GC_Ll GC_Lm GC_Lo GC_Lt GC_Lu GC_Mc GC_Me GC_Mn GC_Nd GC_Nl GC_No GC_Pc GC_Pd GC_Pe GC_Pf GC_Pi GC_Po GC_Ps GC_Sc GC_Sk GC_Sm GC_So GC_Zl GC_Zp GC_Zs GC_Cc GC_Cf GC_Co GC_Cs GC_Cn + highlight link fnConstant Constant -syntax keyword fnType bool number char string list cmp try maybe basic_type io_mode +syntax keyword fnType bool number char string list cmp try maybe basic_type io_mode ftype_type unicode_general_category_type highlight link fnType Type