From bea9e68267ddcecffd2feaeb62659306404975f3 Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Sat, 14 Oct 2023 16:28:31 +0100 Subject: [PATCH] implemented cut --- docs/lambda-conversion.md | 168 ++++++++ prototyping/DFATree.py | 110 ++++-- scm/args.scm | 96 +++++ scm/map-amb.scm | 21 + scm/map.scm | 23 ++ scm/member.scm | 23 ++ src/analysis.c | 13 +- src/bytecode.c | 9 + src/bytecode.h | 2 + src/common.h | 2 +- src/debug.c | 14 + src/debug.h | 1 + src/desugaring.c | 10 + src/exp.c | 24 +- src/exp.h | 10 + src/memory.c | 13 + src/memory.h | 1 + src/step.c | 12 + src/tests/exp.inc | 787 +++++++++++++++++++++++++++++++++++++- tools/makeTree.py | 28 ++ 20 files changed, 1329 insertions(+), 38 deletions(-) create mode 100644 scm/args.scm create mode 100644 scm/map-amb.scm create mode 100644 scm/map.scm create mode 100644 scm/member.scm diff --git a/docs/lambda-conversion.md b/docs/lambda-conversion.md index 42ddfcc..e0dbab6 100644 --- a/docs/lambda-conversion.md +++ b/docs/lambda-conversion.md @@ -217,4 +217,172 @@ Note the equality check has to be part of the DFA, because we don't yet know which branch we're on so can't start binding variables that will differ between branches. +## New Approach +None of the above pans out, there are issues with variable binding confusing the NFA to DFA converter. You can see how far I got in prototyping this in [prototyping/DFATree.py](../prototyping/DFATree.py). + +The new approach is to do what Haskell perportedly does, which is to check each pattern in turn. This is certainly simpler, and we can use a beefed-up variant of `amb` to help out by backtracking when a branch doesn't match. + +The basic skeleton of the generated code should be something like: + +```scheme +(amb ( ) + (amb ( ) + (amb ( ) + (error "patterns exhausted")))) +``` + +Each branch can be generated completely independantly of the others, and need only do a `(back)` if the args fail to match. + +However there is a little problem, if such a function is backtracked through +for other reasons (normal use of `amb` by other code) then a subsequent branch +would be attempted in error. + +How Prolog addresses this problem, where a branch once determined should be committed to, is to use a mechanism called a "green cut". This ensures that when a function body is backtracked out of, the entire function is backtracked out of. + +We can achieve the same by having a new version of `amb` which I'm calling `escape`, and a new version of `back` which I'm calling `cut`. + +`escape` is just like `amb` except it takes only one argument expression, and when backtracked to from that expression, it itself backtracks. + +`cut` is a little different from a normal `back` though, when invoked, instead of just restoring the previous failure continuation, it repeatedly restores the previous continuation unlil it encounters an `escape` continuation. + +The skeleton now becomes: + +```scheme +(escape + (amb ( (amb (cut)) + (amb ( (amb (cut)) + (amb ( (amb (cut)) + (error "patterns exhausted"))))) +``` + +So if for example downstream code attempts to backtrack through ``, the innermost `amb` will catch the failure and invoke `cut`, which will jump over the outer `amb` to the `escape` which will then continue to backtrack out of the entire compound function. + +Let's look at some concrete examples converting familiar functions to lambdas, +first here's `map` + +```scheme +; fn map { +; (_, []) { [] } +; (f, h @ t) { f(h) @ map(f, t) } +; } +(define map + (lambda ($1 $2) + (escape + (amb (match $2 + (nil (amb nil (cut))) + (pair (back)) + (amb (let (f $1) + (match $2 + (nil (let (h (field $2 0)) + (let (t (field $2 1)) + (amb (pair (f h) (map f t)) (cut))))) + (pair (back)))) + (error "patterns exhausted in function map"))))))) +``` + +Arguments to the lambda are bound to generated symbols, which shouldn't be +lexically symbols so they can't conflict (dollar-prefix should do it). + +Then the entire compound is wrapped in an escape, and a nest of `amb`s check +each branch. + +`match` is a simple exhaustive case statement for types. + +`field` extracts a zero-indexed field from a compound structure like `pair`. + +Nested `let`s bind variables appropriately, and the body of the function is constructed within those `let` bindings, wrapped in an `amb` with a trailing `cut`. + +next let's look at `member`. + +```scheme +; fn member { +; (_, []) { false } +; (x, x @ _) { true } +; (x, _ @ t) { member(x, t) } +; } +(define member + (lambda ($1 $2) + (escape + (amb (match $2 + (0 (amb false (cut))) + (1 (back))) + (amb (let (x $1) + (match $2 + (1 (if (eq x (field $2 0)) + (amb true (cut)) + (back))) + (0 (back)))) + (amb (let (x $1) + (match $2 + (1 (let (t (field $2 1)) + (amb (member x t) (cut)))) + (0 (back)))) + (error "patterns exhausted in function member"))))))) +``` + +Much the same process, The additional wrinkle is the comparison of the second +binding of `x` in the true branch, rather than just binding `x`. + +There's rather an accumulation of failure continuations using this approach, +a function call not otherwise using `amb` now costs 2 failure continuations +that are likely never invoked if the application makes no use of `amb`. + +Maybe there's a less costly way. + +## Refinement + +Leave `escape` as is, but change the behaviour of `cut`. Have `cut` now take an expression to evaluate, and *before* evaluating it, peel away all the failure +continuations up to and including the `escape`. + +So instead of: + +```scheme +(amb (member x t) (cut)) +``` + +We just need: + +```scheme +(cut (member x t)) +``` + +In fact we can gain a bit more efficiency still by having `escape` merely +tag the current failure continuation, then `cut` peels back to leave that +continuation, un-tagging it instead of removing it. Any downstream backtracking +from the argument to `cut` will hit that continuation. + + +In fact, we probably don't even need `escape`. If the use of `cut` is restricted +to this specific situation, there will only ever be one failure continuation +installed for pattern matching, and `cut` merely restores the previous one. + +## Changes to "The Math" + +Complex expressions now include `cut` + +$$ +\begin{array}{rcl} +\mathtt{cexp} &::=& \mathtt{(aexp_0\\ aexp_1\dots aexp_n)} +\\ + &|& \mathtt{(if\\ aexp\\ exp\\ exp)} +\\ + &|& \mathtt{(call/cc\\ aexp)} +\\ + &|& \mathtt{(letrec\\ ((var_1\\ aexp_1)\dots(var_n\\ aexp_n))\\ exp)} +\\ + &|& \mathtt{(amb\\ exp\\ exp)} +\\ + &|& \mathtt{(cut\\ exp)} +\\ + &|& \mathtt{(back)} +\end{array} +$$ + +`cut` pops the topmost failure continuation and arranges for its argument to be evaluated. It would be an error if `cut` was invoked without a failure continuation in place: + +$$ +step(\mathtt{(cut\ exp)}, \rho, \kappa, \mathbf{backtrack}(\mathtt{exp'}, \rho', \kappa', f) = (\mathtt{exp}, \rho, \kappa, f)) +$$ + +That's it. We won't expose `cut` as a language feature because its use is purely internal to the implementation. diff --git a/prototyping/DFATree.py b/prototyping/DFATree.py index fc843bc..d35377a 100644 --- a/prototyping/DFATree.py +++ b/prototyping/DFATree.py @@ -28,6 +28,9 @@ def notePosition(self, i): class NumericFarg(Farg): + """ + literal number + """ def __init__(self, n): self.n = n @@ -39,6 +42,9 @@ def __str__(self): class VecFarg(Farg): + """ + vector type like pair or maybe + """ def __init__(self, label, *fields): self.label = label self.fields = fields @@ -56,6 +62,9 @@ def __str__(self): class VarFarg(Farg): + """ + variable + """ def __init__(self, name): self.name = name @@ -66,18 +75,29 @@ def __str__(self): return self.name -class ComparisonFarg(Farg): - def __init__(self, name): +class AssignmentFarg(Farg): + """ + name = value + """ + def __init__(self, name, value): self.name = name + self.value = value def accept(self, visitor, state): - return visitor.visitComparisonFarg(self, state) + return visitor.visitAssignmentFarg(self, state) def __str__(self): - return self.name + return self.name + '=' + str(self.value) + + def notePosition(self, i): + super().notePosition(i) + self.value.notePosition(i) class WildcardFarg(Farg): + """ + Wildcard _ + """ def accept(self, visitor, state): return visitor.visitWildcardFarg(self, state) @@ -553,7 +573,7 @@ def __eq__(self, other): return isinstance(other, DfaVarTransition) and self.var == other.var def __str__(self): - return 'bind ' + self.var + return 'unify ' + self.var def isWildcard(self): return True @@ -562,15 +582,19 @@ def isConditional(self): return True -class DfaWildcardTransition(DfaTransition): +class DfaAssignmentTransition(DfaTransition): + def __init__(self, var): + super().__init__() + self.var = var + def __hash__(self): - return hash(('var', '*')) + return hash(('var', self.var)) def __eq__(self, other): - return isinstance(other, DfaWildcardTransition) + return isinstance(other, DfaAssignmentTransition) and self.var == other.var def __str__(self): - return 'else' + return 'unify ' + self.var def isWildcard(self): return True @@ -579,19 +603,18 @@ def isConditional(self): return True -class DfaComparisonTransition(DfaTransition): - def __init__(self, var): - super().__init__() - self.var = var - +class DfaWildcardTransition(DfaTransition): def __hash__(self): - return hash(('cmp', self.var)) + return hash(('var', '*')) def __eq__(self, other): - return isinstance(other, DfaComparisonTransition) and self.var == other.var + return isinstance(other, DfaWildcardTransition) def __str__(self): - return f'=={str(self.var)}' + return 'else' + + def isWildcard(self): + return True def isConditional(self): return True @@ -716,36 +739,36 @@ def key(self): return DfaArgTransition(self.index) -class NfaVarTransition(NfaTransition): +class NfaAssignmentTransition(NfaTransition): def __init__(self, name, to): super().__init__(to) self.name = name def __str__(self): - return 'bind ' + self.name + ' ' + str(self.to) + return 'unify ' + self.name + ' ' + str(self.to) def key(self): - return DfaVarTransition(self.name) + return DfaAssignmentTransition(self.name) -class NfaWildcardTransition(NfaTransition): +class NfaVarTransition(NfaTransition): + def __init__(self, name, to): + super().__init__(to) + self.name = name + def __str__(self): - return '(=*) ' + str(self.to) + return 'unify ' + self.name + ' ' + str(self.to) def key(self): - return DfaWildcardTransition() + return DfaVarTransition(self.name) -class NfaComparisonTransition(NfaTransition): - def __init__(self, name, to): - super().__init__(to) - self.name = name - +class NfaWildcardTransition(NfaTransition): def __str__(self): - return f'(={self.name}) ' + str(self.to) + return '(=*) ' + str(self.to) def key(self): - return DfaComparisonTransition(self.name) + return DfaWildcardTransition() class FargToNfaVisitor: @@ -780,12 +803,12 @@ def recursivelyVisitVec(self, fields, count, finalState): def visitVarFarg(self, var, state): return NfaState([NfaVarTransition(var.name, state)]) + def visitAssignmentFarg(self, assignment, state): + return NfaState([NfaAssignmentTransition(assignment.name, assignment.value.accept(self, state))]) + def visitWildcardFarg(self, wildcard, state): return NfaState([NfaWildcardTransition(state)]) - def visitComparisonFarg(self, comparison, state): - return NfaState([NfaComparisonTransition(comparison.name, state)]) - def makeMermaid(args): print('```plaintext') @@ -809,7 +832,7 @@ def makeMermaid(args): memberArgs = Compound( Fargs('false', VarFarg('x'), VecFarg('nil')), - Fargs('true', VarFarg('x'), VecFarg('cons', ComparisonFarg('x'), WildcardFarg())), + Fargs('true', VarFarg('x'), VecFarg('cons', VarFarg('x'), WildcardFarg())), Fargs('continue', VarFarg('x'), VecFarg('cons', WildcardFarg(), VarFarg('t'))) ) makeMermaid(memberArgs) @@ -823,3 +846,22 @@ def makeMermaid(args): ) makeMermaid(testArgs) +""" +Problems +-------- + +Because we're matching the args for all functions at once, we can't pay attention to variable names, +we have to assume the variables are bound by a previous (or subsequent) process. +That in turn means we can't handle assignment args (x=[1, 2] etc.) because x won't be bound. +And there are problems with matching common values too, like in member: + +fn member { + (_, []) { false } + (x, x @ y) { true } + (y, _ @ t) { member(y, t) } +} + +The parallel matching would have to bind y as well as x to the first argument, but y shouldn't be bound +in the true case because types are different and it would become a comparison with the second appearence +of y in the true branch. +""" diff --git a/scm/args.scm b/scm/args.scm new file mode 100644 index 0000000..6196518 --- /dev/null +++ b/scm/args.scm @@ -0,0 +1,96 @@ +; fn { +; (['x', ['x']]) { a() } +; (['x', ['y']]) { b() } +; (['y', ['x']]) { c() } +; (['y', ['y']]) { d() } +; (_) { e() } +; } +(lambda ($1) + (escape + (amb (match (kind $1) + (0 (back)) + (1 (if (eq (field $1 0) 'x') + (match (kind (field $1 1)) + (0 (back)) + (1 (if (eq (field (field $1 1) 0) 'x') + (match (kind (field (field $1 1) 1)) + (0 (amb (a) (cut))) + (1 (back))) + (back)))) + (back)))) + (amb (match (kind $1) + (0 (back)) + (1 (if (eq (field $1 0) 'x') + (match (kind (field $1 1)) + (0 (back)) + (1 (if (eq (field (field $1 1) 0) 'y') + (match (kind (field (field $1 1) 1)) + (0 (amb (b) (cut))) + (1 (back))) + (back)))) + (back)))) + (amb (match (kind $1) + (0 (back)) + (1 (if (eq (field $1 0) 'y') + (match (kind (field $1 1)) + (0 (back)) + (1 (if (eq (field (field $1 1) 0) 'x') + (match (kind (field (field $1 1) 1)) + (0 (amb (c) (cut))) + (1 (back))) + (back)))) + (back)))) + (amb (match (kind $1) + (0 (back)) + (1 (if (eq (field $1 0) 'y') + (match (kind (field $1 1)) + (0 (back)) + (1 (if (eq (field (field $1 1) 0) 'y') + (match (kind (field (field $1 1) 1)) + (0 (amb (d) (cut))) + (1 (back))) + (back)))) + (back)))) + (amb (e) (cut)))))))) + +; fn map { +; (_, []) { [] } +; (f, h @ t) { f(h) @ map(f, t) } +; } +(define map + (lambda ($1 $2) + (escape + (amb (match (kind $2) + (0 (amb nil (cut))) + (1 (back)) + (amb (let (f $1) + (match (kind $2) + (1 (let (h (field $2 0)) + (let (t (field $2 1)) + (amb (pair (f h) (map f t)) (cut))))) + (0 (back)))) + (error "patterns exhausted in function map"))))))) + +; fn member { +; (_, []) { false } +; (x, x @ _) { true } +; (x, _ @ t) { member(x, t) } +; } +(define member + (lambda ($1 $2) + (escape + (amb (match (kind $2) + (0 (amb false (cut))) + (1 (back))) + (amb (let (x $1) + (match (kind $2) + (1 (if (eq x (field $2 0)) + (amb true (cut)) + (back))) + (0 (back)))) + (amb (let (x $1) + (match (kind $2) + (1 (let (t (field $2 1)) + (amb (member x t) (cut)))) + (0 (back)))) + (error "patterns exhausted in function member"))))))) diff --git a/scm/map-amb.scm b/scm/map-amb.scm new file mode 100644 index 0000000..9972c17 --- /dev/null +++ b/scm/map-amb.scm @@ -0,0 +1,21 @@ +; fn map { +; (_, []) { [] } +; (f, h @ t) { f(h) @ map(f, t) } +; } +(letrec + ((map (lambda (a1 a2) + (amb (match (vec 0 a2) + ((0) (cut (make-vec 0))) + ((1) (back))) + (amb (let (f a1) + (match (vec 0 a2) + ((0) (back)) + ((1) (cut (let (h (vec 1 a2)) + (let (t (vec 2 a2)) + (let (v1 (f h)) + (let (v2 (map f t)) + (make-vec 1 v1 v2))))))))) + (make-vec 0)))))) + (amb + (map (lambda (x) (back)) (make-vec 1 2 (make-vec 0))) + (make-vec 1 1 (make-vec 0)))) ; should be the final result diff --git a/scm/map.scm b/scm/map.scm new file mode 100644 index 0000000..de76b1f --- /dev/null +++ b/scm/map.scm @@ -0,0 +1,23 @@ +; fn map { +; (_, []) { [] } +; (f, h @ t) { f(h) @ map(f, t) } +; } +(letrec + ((map (lambda (a1 a2) + (amb (match (vec 0 a2) + ((0) (cut (make-vec 0))) + ((1) (back))) + (amb (let (f a1) + (match (vec 0 a2) + ((0) (back)) + ((1) (cut (let (h (vec 1 a2)) + (let (t (vec 2 a2)) + (let (v1 (f h)) + (let (v2 (map f t)) + (make-vec 1 v1 v2))))))))) + nil))))) + (map (lambda (x) (+ 1 x)) + (make-vec 1 1 + (make-vec 1 2 + (make-vec 1 3 + (make-vec 0)))))) diff --git a/scm/member.scm b/scm/member.scm new file mode 100644 index 0000000..61522a6 --- /dev/null +++ b/scm/member.scm @@ -0,0 +1,23 @@ +; fn member { +; (_, []) { false } +; (x, x @ _) { true } +; (x, _ @ t) { member(x, t) } +; } +(define member + (lambda ($1 $2) + (escape + (amb (match (kind $2) + (0 (amb false (cut))) + (1 (back))) + (amb (let (x $1) + (match (kind $2) + (1 (if (eq x (field $2 0)) + (amb true (cut)) + (back))) + (0 (back)))) + (amb (let (x $1) + (match (kind $2) + (1 (let (t (field $2 1)) + (amb (member x t) (cut)))) + (0 (back)))) + (error "patterns exhausted in function member"))))))) diff --git a/src/analysis.c b/src/analysis.c index 5ef9cf4..40a036f 100644 --- a/src/analysis.c +++ b/src/analysis.c @@ -44,6 +44,7 @@ static void analizeCexpApply(CexpApply *x, CTEnv *env); static void analizeCexpCond(CexpCond *x, CTEnv *env); static void analizeCexpLetRec(CexpLetRec *x, CTEnv *env); static void analizeCexpAmb(CexpAmb *x, CTEnv *env); +static void analizeCexpCut(CexpCut *x, CTEnv *env); static void analizeExpLet(ExpLet *x, CTEnv *env); static void analizeAexp(Aexp *x, CTEnv *env); static void analizeCexp(Cexp *x, CTEnv *env); @@ -169,6 +170,13 @@ static void analizeCexpAmb(CexpAmb *x, CTEnv *env) { analizeExp(x->exp2, env); } +static void analizeCexpCut(CexpCut *x, CTEnv *env) { +#ifdef DEBUG_ANALIZE + printf("analizeCexpCut "); printCexpCut(x); printf(" "); printCTEnv(env); printf("\n"); +#endif + analizeExp(x->exp, env); +} + static void analizeExpLet(ExpLet *x, CTEnv *env) { #ifdef DEBUG_ANALIZE printf("analizeExpLet "); printExpLet(x); printf(" "); printCTEnv(env); printf("\n"); @@ -262,13 +270,16 @@ static void analizeCexp(Cexp *x, CTEnv *env) { case CEXP_TYPE_AMB: analizeCexpAmb(x->val.amb, env); break; + case CEXP_TYPE_CUT: + analizeCexpCut(x->val.cut, env); + break; case CEXP_TYPE_MATCH: analizeCexpMatch(x->val.match, env); break; case CEXP_TYPE_BACK: break; default: - cant_happen("unrecognized type in analizeCexp"); + cant_happen("unrecognized type %d in analizeCexp", x->type); } } diff --git a/src/bytecode.c b/src/bytecode.c index 066d850..87af7c5 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -332,6 +332,11 @@ void writeCexpAmb(CexpAmb *x, ByteCodeArray *b) { writeCurrentAddressAt(patch2, b); } +void writeCexpCut(CexpCut *x, ByteCodeArray *b) { + addByte(b, BYTECODE_CUT); + writeExp(x->exp, b); +} + void writeExpLet(ExpLet *x, ByteCodeArray *b) { addByte(b, BYTECODE_LET); int patch = reserveWord(b); @@ -416,6 +421,10 @@ void writeCexp(Cexp *x, ByteCodeArray *b) { writeCexpAmb(x->val.amb, b); } break; + case CEXP_TYPE_CUT: { + writeCexpCut(x->val.cut, b); + } + break; case CEXP_TYPE_BACK: { addByte(b, BYTECODE_BACK); } diff --git a/src/bytecode.h b/src/bytecode.h index 822b3d7..fea6be1 100644 --- a/src/bytecode.h +++ b/src/bytecode.h @@ -51,6 +51,7 @@ typedef enum ByteCodes { BYTECODE_IF, BYTECODE_LETREC, BYTECODE_AMB, + BYTECODE_CUT, BYTECODE_BACK, BYTECODE_LET, BYTECODE_CALLCC, @@ -87,6 +88,7 @@ void writeCexpMatch(CexpMatch *x, ByteCodeArray *b); void writeCexpLetRec(CexpLetRec *x, ByteCodeArray *b); void writeLetRecBindings(LetRecBindings *x, ByteCodeArray *b); void writeCexpAmb(CexpAmb *x, ByteCodeArray *b); +void writeCexpCut(CexpCut *x, ByteCodeArray *b); void writeCexpAnd(CexpBool *x, ByteCodeArray *b); void writeCexpOr(CexpBool *x, ByteCodeArray *b); void writeExpLet(ExpLet *x, ByteCodeArray *b); diff --git a/src/common.h b/src/common.h index a1a5f86..61404e9 100644 --- a/src/common.h +++ b/src/common.h @@ -28,7 +28,7 @@ #define DEBUG_STEP #define DEBUG_STRESS_GC // #define DEBUG_LOG_GC -#define DEBUG_RUN_TESTS 4 +#define DEBUG_RUN_TESTS 1 // #define DEBUG_ANALIZE // #define DEBUG_DESUGARING // #define DEBUG_HASHTABLE diff --git a/src/debug.c b/src/debug.c index 377dd4d..55caa3b 100644 --- a/src/debug.c +++ b/src/debug.c @@ -532,6 +532,12 @@ void printCexpAmb(CexpAmb *x) { printf(")"); } +void printCexpCut(CexpCut *x) { + printf("(cut "); + printExp(x->exp); + printf(")"); +} + void printCexpBool(CexpBool *x) { printf("("); switch (x->type) { @@ -631,6 +637,9 @@ void printCexp(Cexp *x) { case CEXP_TYPE_AMB: printCexpAmb(x->val.amb); break; + case CEXP_TYPE_CUT: + printCexpCut(x->val.cut); + break; case CEXP_TYPE_BOOL: printCexpBool(x->val.boolean); break; @@ -837,6 +846,11 @@ void dumpByteCode(ByteCodeArray *b) { i += 3; } break; + case BYTECODE_CUT: { + printf("%04d ### CUT\n", i); + i++; + } + break; case BYTECODE_BACK: { printf("%04d ### BACK\n", i); i++; diff --git a/src/debug.h b/src/debug.h index 73390df..ad4f267 100644 --- a/src/debug.h +++ b/src/debug.h @@ -34,6 +34,7 @@ void printAexpVarList(AexpVarList *x); void printBareAexpList(AexpList *x); void printCEKF(CEKF *x); void printCexpAmb(CexpAmb *x); +void printCexpCut(CexpCut *x); void printCexpApply(CexpApply *x); void printCexpBool(CexpBool *x); void printCexp(Cexp *x); diff --git a/src/desugaring.c b/src/desugaring.c index 5e90998..4ade04c 100644 --- a/src/desugaring.c +++ b/src/desugaring.c @@ -37,6 +37,7 @@ static CexpApply *desugarCexpApply(CexpApply *x); static CexpCond *desugarCexpCond(CexpCond *x); static CexpLetRec *desugarCexpLetRec(CexpLetRec *x); static CexpAmb *desugarCexpAmb(CexpAmb *x); +static CexpCut *desugarCexpCut(CexpCut *x); static ExpLet *desugarCexpBool(CexpBool *x); static ExpLet *desugarExpLet(ExpLet *x); static Aexp *desugarAexp(Aexp *x); @@ -127,6 +128,12 @@ static CexpAmb *desugarCexpAmb(CexpAmb *x) { return x; } +static CexpCut *desugarCexpCut(CexpCut *x) { + DEBUG_DESUGAR(CexpCut, x); + x->exp = desugarExp(x->exp); + return x; +} + static Exp *aexpAndToExp(Aexp *exp1, Exp *exp2) { return newExp(EXP_TYPE_CEXP, EXP_VAL_CEXP(newCexp @@ -322,6 +329,9 @@ static Cexp *desugarCexp(Cexp *x) { case CEXP_TYPE_AMB: x->val.amb = desugarCexpAmb(x->val.amb); break; + case CEXP_TYPE_CUT: + x->val.cut = desugarCexpCut(x->val.cut); + break; case CEXP_TYPE_MATCH: x->val.match = desugarCexpMatch(x->val.match); break; diff --git a/src/exp.c b/src/exp.c index 3be3adc..f2fec8b 100644 --- a/src/exp.c +++ b/src/exp.c @@ -167,6 +167,12 @@ CexpAmb *newCexpAmb(Exp *exp1, Exp *exp2) { return x; } +CexpCut *newCexpCut(Exp *exp) { + CexpCut *x = NEW(CexpCut, OBJTYPE_CUT); + x->exp = exp; + return x; +} + CexpBool *newCexpBool(CexpBoolType type, Exp *exp1, Exp *exp2) { CexpBool *x = NEW(CexpBool, OBJTYPE_BOOL); x->type = type; @@ -323,6 +329,13 @@ void markCexpAmb(CexpAmb *x) { markExp(x->exp2); } +void markCexpCut(CexpCut *x) { + if (x == NULL) return; + if (MARKED(x)) return; + MARK(x); + markExp(x->exp); +} + void markCexpBool(CexpBool *x) { if (x == NULL) return; if (MARKED(x)) return; @@ -396,6 +409,9 @@ void markCexp(Cexp *x) { case CEXP_TYPE_AMB: markCexpAmb(x->val.amb); break; + case CEXP_TYPE_CUT: + markCexpCut(x->val.cut); + break; case CEXP_TYPE_BOOL: markCexpBool(x->val.boolean); break; @@ -434,11 +450,14 @@ void freeExpObj(Header *h) { if (h == NULL) return; switch (h->type) { case OBJTYPE_BOOL: - FREE(h, CexpAmb); + FREE(h, CexpBool); break; case OBJTYPE_AMB: FREE(h, CexpAmb); break; + case OBJTYPE_CUT: + FREE(h, CexpCut); + break; case OBJTYPE_APPLY: FREE(h, CexpApply); break; @@ -501,6 +520,9 @@ void markExpObj(Header *h) { case OBJTYPE_AMB: markCexpAmb((CexpAmb *) h); break; + case OBJTYPE_CUT: + markCexpCut((CexpCut *) h); + break; case OBJTYPE_BOOL: markCexpBool((CexpBool *) h); break; diff --git a/src/exp.h b/src/exp.h index cba13c2..b9fd5fd 100644 --- a/src/exp.h +++ b/src/exp.h @@ -157,6 +157,11 @@ typedef struct CexpAmb { struct Exp *exp2; } CexpAmb; +typedef struct CexpCut { + Header header; + struct Exp *exp; +} CexpCut; + typedef enum { BOOL_TYPE_AND, BOOL_TYPE_OR, @@ -226,6 +231,7 @@ typedef enum { CEXP_TYPE_CALLCC, CEXP_TYPE_LETREC, CEXP_TYPE_AMB, + CEXP_TYPE_CUT, CEXP_TYPE_BACK, CEXP_TYPE_BOOL, CEXP_TYPE_MATCH, @@ -238,6 +244,7 @@ typedef union { struct Aexp *callCC; struct CexpLetRec *letRec; struct CexpAmb *amb; + struct CexpCut *cut; struct CexpBool *boolean; struct CexpMatch *match; } CexpVal; @@ -253,6 +260,7 @@ typedef struct Cexp { #define CEXP_VAL_CALLCC(x) ((CexpVal){.callCC = (x)}) #define CEXP_VAL_LETREC(x) ((CexpVal){.letRec = (x)}) #define CEXP_VAL_AMB(x) ((CexpVal){.amb = (x)}) +#define CEXP_VAL_CUT(x) ((CexpVal){.cut = (x)}) #define CEXP_VAL_BOOL(x) ((CexpVal){.boolean = (x)}) #define CEXP_VAL_MATCH(x) ((CexpVal){.match = (x)}) #define CEXP_VAL_BACK() ((CexpVal){.none = NULL}) @@ -292,6 +300,7 @@ AexpVarList *newAexpVarList(AexpVarList *next, HashSymbol *var); AexpMakeVec *newAexpMakeVec(AexpList *args); HashSymbol *newAexpVar(char *name); CexpAmb *newCexpAmb(Exp *exp1, Exp *exp2); +CexpCut *newCexpCut(Exp *exp); CexpBool *newCexpBool(CexpBoolType type, Exp *exp1, Exp *exp2); CexpApply *newCexpApply(Aexp *function, AexpList *args); CexpCond *newCexpCond(Aexp *condition, Exp *consequent, Exp *alternative); @@ -312,6 +321,7 @@ void markAexpUnaryApp(AexpUnaryApp *x); void markAexpVarList(AexpVarList *x); void markAexpMakeVec(AexpMakeVec *x); void markCexpAmb(CexpAmb *x); +void markCexpCut(CexpCut *x); void markCexpBool(CexpBool *x); void markCexpApply(CexpApply *x); void markCexpCond(CexpCond *x); diff --git a/src/memory.c b/src/memory.c index fc7fc63..d6b22db 100644 --- a/src/memory.c +++ b/src/memory.c @@ -63,6 +63,8 @@ const char *typeName(ObjType type) { switch (type) { case OBJTYPE_AMB: return "amb"; + case OBJTYPE_CUT: + return "cut"; case OBJTYPE_BOOL: return "bool"; case OBJTYPE_APPLY: @@ -95,6 +97,12 @@ const char *typeName(ObjType type) { return "annotatedvar"; case OBJTYPE_VARLIST: return "varlist"; + case OBJTYPE_MAKEVEC: + return "makevec"; + case OBJTYPE_MATCH: + return "match"; + case OBJTYPE_MATCHLIST: + return "matchlist"; case OBJTYPE_CLO: return "clo"; case OBJTYPE_ENV: @@ -152,6 +160,9 @@ bool disableGC() { #define FREE_PROTECT(p) ((void)reallocate(p, sizeof(ProtectionStack) + ((ProtectionStack *)p)->capacity * sizeof(Header *), 0)) void initProtection(void) { +#ifdef DEBUG_LOG_GC + fprintf(stderr, "initProtection\n"); +#endif protected = NEW_PROTECT(INITIAL_PROTECTION); protected->capacity = INITIAL_PROTECTION; protected->sp = 0; @@ -271,6 +282,7 @@ void markObj(Header *h) { #endif switch (h->type) { case OBJTYPE_AMB: + case OBJTYPE_CUT: case OBJTYPE_APPLY: case OBJTYPE_BINDINGS: case OBJTYPE_BOOL: @@ -335,6 +347,7 @@ static void freeProtectionObj(Header *h) { void freeObj(Header *h) { switch (h->type) { case OBJTYPE_AMB: + case OBJTYPE_CUT: case OBJTYPE_APPLY: case OBJTYPE_BINDINGS: case OBJTYPE_BOOL: diff --git a/src/memory.h b/src/memory.h index 12a40bd..419be44 100644 --- a/src/memory.h +++ b/src/memory.h @@ -30,6 +30,7 @@ struct Header; typedef enum { // exp types OBJTYPE_AMB, + OBJTYPE_CUT, OBJTYPE_APPLY, OBJTYPE_BINDINGS, OBJTYPE_BOOL, diff --git a/src/step.c b/src/step.c index dc2fa34..3935c7b 100644 --- a/src/step.c +++ b/src/step.c @@ -633,6 +633,18 @@ static void step() { state.C += 3; } break; + case BYTECODE_CUT: { // discard the current failure continuation +#ifdef DEBUG_STEP + printCEKF(&state); + printf("%4d) %04d ### CUT\n", ++count, state.C); +#endif + if (state.F == NULL) { + cant_happen("cut with no extant failure continuation"); + } + state.F = state.F->next; + state.C += 1; + } + break; case BYTECODE_BACK: { // restore the failure continuation or halt #ifdef DEBUG_STEP printCEKF(&state); diff --git a/src/tests/exp.inc b/src/tests/exp.inc index e646f48..e1912ef 100644 --- a/src/tests/exp.inc +++ b/src/tests/exp.inc @@ -3657,6 +3657,787 @@ Exp *makeTestExpClosure() (3)))))))))))))); } +Exp *makeTestExpMap() { + /* map.scm */ + return newExp(EXP_TYPE_CEXP, + EXP_VAL_CEXP(newCexp + (CEXP_TYPE_LETREC, + CEXP_VAL_LETREC(newCexpLetRec + (newLetRecBindings + (NULL, newAexpVar("map"), + newAexp(AEXP_TYPE_LAM, + AEXP_VAL_LAM + (newAexpLam + (newAexpVarList + (newAexpVarList + (NULL, + newAexpVar("a2")), + newAexpVar("a1")), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_AMB, + CEXP_VAL_AMB + (newCexpAmb + (newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_MATCH, + CEXP_VAL_MATCH + (newCexpMatch + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_VEC, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a2")))))), + newMatchList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_CUT, + CEXP_VAL_CUT + (newCexpCut + (newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))))))))))))), + newMatchList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_BACK, + CEXP_VAL_BACK + ()))), + NULL))))))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_AMB, + CEXP_VAL_AMB + (newCexpAmb + (newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("f"), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a1"))))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_MATCH, + CEXP_VAL_MATCH + (newCexpMatch + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_VEC, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a2")))))), + newMatchList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_BACK, + CEXP_VAL_BACK + ()))), + newMatchList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_CUT, + CEXP_VAL_CUT + (newCexpCut + (newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("h"), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_VEC, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a2")))))))), + newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("t"), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_VEC, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (2)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a2")))))))), + newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("v1"), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_APPLY, + CEXP_VAL_APPLY + (newCexpApply + (newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("f"))), + newAexpList + (NULL, + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("h"))))))))), + newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("v2"), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_APPLY, + CEXP_VAL_APPLY + (newCexpApply + (newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("map"))), + newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("t")))), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("f"))))))))), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("v2")))), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("v1")))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))))))))))))))))))))))))), + NULL)))))))))), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_VOID, + AEXP_VAL_VOID + ()))))))))))))))))), + newExp(EXP_TYPE_CEXP, + EXP_VAL_CEXP(newCexp + (CEXP_TYPE_APPLY, + CEXP_VAL_APPLY + (newCexpApply + (newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("map"))), + newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))))))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (3))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))))))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (2))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))))))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))))))), + newAexp + (AEXP_TYPE_LAM, + AEXP_VAL_LAM + (newAexpLam + (newAexpVarList + (NULL, + newAexpVar + ("x")), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_ADD, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("x")))))))))))))))))))))); +} + +Exp *makeTestExpMapAmb() { + /* map-amb.scm */ + return + newExp(EXP_TYPE_CEXP, + EXP_VAL_CEXP(newCexp + (CEXP_TYPE_LETREC, + CEXP_VAL_LETREC(newCexpLetRec + (newLetRecBindings + (NULL, newAexpVar("map"), + newAexp(AEXP_TYPE_LAM, + AEXP_VAL_LAM(newAexpLam + (newAexpVarList + (newAexpVarList + (NULL, + newAexpVar + ("a2")), + newAexpVar + ("a1")), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_AMB, + CEXP_VAL_AMB + (newCexpAmb + (newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_MATCH, + CEXP_VAL_MATCH + (newCexpMatch + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_VEC, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a2")))))), + newMatchList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_CUT, + CEXP_VAL_CUT + (newCexpCut + (newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))))))))))))), + newMatchList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_BACK, + CEXP_VAL_BACK + ()))), + NULL))))))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_AMB, + CEXP_VAL_AMB + (newCexpAmb + (newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("f"), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a1"))))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_MATCH, + CEXP_VAL_MATCH + (newCexpMatch + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_VEC, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a2")))))), + newMatchList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_BACK, + CEXP_VAL_BACK + ()))), + newMatchList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_CUT, + CEXP_VAL_CUT + (newCexpCut + (newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("h"), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_VEC, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a2")))))))), + newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("t"), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_PRIM, + AEXP_VAL_PRIM + (newAexpPrimApp + (AEXP_PRIM_VEC, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (2)), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("a2")))))))), + newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("v1"), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_APPLY, + CEXP_VAL_APPLY + (newCexpApply + (newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("f"))), + newAexpList + (NULL, + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("h"))))))))), + newExp + (EXP_TYPE_LET, + EXP_VAL_LET + (newExpLet + (newAexpVar + ("v2"), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_APPLY, + CEXP_VAL_APPLY + (newCexpApply + (newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("map"))), + newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("t")))), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("f"))))))))), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("v2")))), + newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("v1")))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))))))))))))))))))))))))), + NULL)))))))))), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0)))))))))))))))))))))), + newExp(EXP_TYPE_CEXP, + EXP_VAL_CEXP(newCexp + (CEXP_TYPE_AMB, + CEXP_VAL_AMB + (newCexpAmb + (newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_APPLY, + CEXP_VAL_APPLY + (newCexpApply + (newAexp + (AEXP_TYPE_VAR, + AEXP_VAL_VAR + (newAexpVar + ("map"))), + newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))))))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (2))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))))))), + newAexp + (AEXP_TYPE_LAM, + AEXP_VAL_LAM + (newAexpLam + (newAexpVarList + (NULL, + newAexpVar + ("x")), + newExp + (EXP_TYPE_CEXP, + EXP_VAL_CEXP + (newCexp + (CEXP_TYPE_BACK, + CEXP_VAL_BACK + ())))))))))))), + newExp + (EXP_TYPE_AEXP, + EXP_VAL_AEXP + (newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (newAexpList + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_MAKEVEC, + AEXP_VAL_MAKEVEC + (newAexpMakeVec + (newAexpList + (NULL, + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (0))))))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1))), + newAexp + (AEXP_TYPE_INT, + AEXP_VAL_INT + (1)))))))))))))))))); +} + + #ifdef DEBUG_STEP #define DUMP_BYTECODE(bc) dumpByteCode(bc) #else @@ -3701,8 +4482,12 @@ int main(int argc, char *argv[]) { int depth = 4; if (argc == 2) depth = atoi(argv[1]); - RUN_EXP(makeTestExpMatch()); + initProtection(); + + RUN_EXP(makeTestExpMapAmb()); /* + RUN_EXP(makeTestExpMap()); + RUN_EXP(makeTestExpMatch()); RUN_EXP(makeTestExpVec()); RUN_EXP(makeTestExpFib(depth)); RUN_EXP(makeTestExpCons()); diff --git a/tools/makeTree.py b/tools/makeTree.py index 301a471..c38d583 100644 --- a/tools/makeTree.py +++ b/tools/makeTree.py @@ -428,6 +428,24 @@ def expCVal(self): +class CexpCut(CexpBase): + def __init__(self, exp): + self.exp = exp + + def __str__(self): + return "(cut " + str(self.exp) + ")" + + def makeC(self): + return "newCexpCut(" + self.exp.makeC() + ")" + + def expCType(self): + return "CEXP_TYPE_CUT" + + def expCVal(self): + return "CEXP_VAL_CUT(" + self.makeC() + ")" + + + class CexpBool(CexpBase): def __init__(self, token, exp1, exp2): self.name = token.val; @@ -581,6 +599,7 @@ class Token: LIST = 17 MAKEVEC = 18 MATCH = 19 + CUT = 20 def __init__(self, kind, val, line): self.kind = kind @@ -644,6 +663,8 @@ def lexer(self, file): match res: case 'amb': yield Token(Token.AMB, res, line_number) + case 'cut': + yield Token(Token.CUT, res, line_number) case 'back': yield Token(Token.BACK, res, line_number) case 'letrec': @@ -792,6 +813,11 @@ def parse_amb(tokens): exp2 = parse_exp(tokens) return Cexp(CexpAmb(exp1, exp2)) +def parse_cut(tokens): + print("parse_cut", str(tokens.peek())) + exp = parse_exp(tokens) + return Cexp(CexpCut(exp)) + def parse_back(tokens): print("parse_back", str(tokens.peek())) return Cexp(CexpBack()) @@ -909,6 +935,8 @@ def parse_list(tokens): return parse_bool(token, tokens) case Token.AMB: return parse_amb(tokens) + case Token.CUT: + return parse_cut(tokens) case Token.BACK: return parse_back(tokens) case Token.LETREC: