From 4d6d76269c869fac1991fbad746dc08dc39e7f61 Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Sun, 27 Mar 2022 20:53:38 +0200 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from 6bf6dd72..184f58ca 184f58ca added one more test involving strange lambdas f17252a1 fixed bug related to closures applied to zero arguments. More tests needed git-subtree-dir: lispBM/lispBM git-subtree-split: 184f58cab68b5350852d2749ef97ee5b4eb245d8 --- src/eval_cps.c | 60 ++++++++++++++++++++++----------------- src/tokpar.c | 1 + tests/test_lambda_10.lisp | 10 +++++++ tests/test_lambda_11.lisp | 6 ++++ tests/test_lambda_6.lisp | 5 ++++ tests/test_lambda_7.lisp | 6 ++++ tests/test_lambda_8.lisp | 7 +++++ tests/test_lambda_9.lisp | 9 ++++++ tests/test_let_9.lisp | 14 --------- 9 files changed, 78 insertions(+), 40 deletions(-) create mode 100644 tests/test_lambda_10.lisp create mode 100644 tests/test_lambda_11.lisp create mode 100644 tests/test_lambda_6.lisp create mode 100644 tests/test_lambda_7.lisp create mode 100644 tests/test_lambda_8.lisp create mode 100644 tests/test_lambda_9.lisp delete mode 100644 tests/test_let_9.lisp diff --git a/src/eval_cps.c b/src/eval_cps.c index d2f91775..9cd2eed6 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -1164,8 +1164,12 @@ static inline void eval_symbol(eval_context_t *ctx) { return; } } - ctx->app_cont = true; - ctx->r = value; + if (lbm_is_error(value)) { + error_ctx(value); + } else { + ctx->app_cont = true; + ctx->r = value; + } } @@ -1788,39 +1792,42 @@ static inline void cont_application(eval_context_t *ctx) { static inline void cont_closure_application_args(eval_context_t *ctx) { lbm_uint* sptr = lbm_get_stack_ptr(&ctx->K, 5); + if (sptr == NULL) { error_ctx(lbm_enc_sym(SYM_FATAL_ERROR)); return; } lbm_value arg_env = (lbm_value)sptr[0]; + lbm_value exp = (lbm_value)sptr[1]; lbm_value clo_env = (lbm_value)sptr[2]; lbm_value params = (lbm_value)sptr[3]; lbm_value args = (lbm_value)sptr[4]; - lbm_value entry; - WITH_GC(entry,lbm_cons(lbm_car(params),ctx->r), NIL, NIL); - - lbm_value aug_env; - WITH_GC(aug_env,lbm_cons(entry, clo_env),entry,NIL); - - if (lbm_is_symbol_nil(args)) { - lbm_stack_drop(&ctx->K, 3); - lbm_value exp; - lbm_pop(&ctx->K, &exp); - lbm_stack_drop(&ctx->K, 1); // arg eval env - ctx->curr_env = aug_env; + if (lbm_is_symbol_nil(params)) { // accepts no more params + lbm_stack_drop(&ctx->K, 5); + ctx->curr_env = clo_env; ctx->curr_exp = exp; ctx->app_cont = false; } else { + lbm_value entry; + WITH_GC(entry,lbm_cons(lbm_car(params),ctx->r), NIL, NIL); - sptr[2] = aug_env; - sptr[3] = lbm_cdr(params); - sptr[4] = lbm_cdr(args); + lbm_value aug_env; + WITH_GC(aug_env,lbm_cons(entry, clo_env),entry,NIL); - lbm_push(&ctx->K, lbm_enc_u(CLOSURE_ARGS)); - - ctx->curr_exp = lbm_car(args); - ctx->curr_env = arg_env; + if (lbm_is_symbol_nil(args)) { + lbm_stack_drop(&ctx->K, 5); + ctx->curr_env = aug_env; + ctx->curr_exp = exp; + ctx->app_cont = false; + } else { + sptr[2] = aug_env; + sptr[3] = lbm_cdr(params); + sptr[4] = lbm_cdr(args); + lbm_push(&ctx->K, lbm_enc_u(CLOSURE_ARGS)); + ctx->curr_exp = lbm_car(args); + ctx->curr_env = arg_env; + } } } @@ -2312,14 +2319,15 @@ static inline void cont_application_start(eval_context_t *ctx) { lbm_value params = lbm_car(cdr_fun); lbm_value exp = lbm_car(cddr_fun); lbm_value clo_env = lbm_car(cdddr_fun); - + lbm_value arg_env = (lbm_value)sptr[0]; sptr[1] = exp; CHECK_STACK(lbm_push_4(&ctx->K, - clo_env, - params, - lbm_cdr(args), - lbm_enc_u(CLOSURE_ARGS))); + clo_env, + params, + lbm_cdr(args), + lbm_enc_u(CLOSURE_ARGS))); ctx->curr_exp = lbm_car(args); + ctx->curr_env = arg_env; ctx->app_cont = false; } break; default: diff --git a/src/tokpar.c b/src/tokpar.c index fdef0da3..b330cc66 100644 --- a/src/tokpar.c +++ b/src/tokpar.c @@ -184,6 +184,7 @@ static char translate_escape_char(char c) { switch(c) { case '\\': return '\\'; case 'n': return '\n'; + case 'r': return '\r'; case 't': return '\t'; case '\"': return '\"'; default: return '\\'; diff --git a/tests/test_lambda_10.lisp b/tests/test_lambda_10.lisp new file mode 100644 index 00000000..044f830e --- /dev/null +++ b/tests/test_lambda_10.lisp @@ -0,0 +1,10 @@ + +(define f (lambda () + (lambda (n) + (if (= n 0) + 42 + ((f) (- n 1)) + )))) + + +(= ((f) 1) 42) diff --git a/tests/test_lambda_11.lisp b/tests/test_lambda_11.lisp new file mode 100644 index 00000000..ea29a044 --- /dev/null +++ b/tests/test_lambda_11.lisp @@ -0,0 +1,6 @@ + +(define f2 (lambda () (lambda (x) (- x 1)))) + +(define f (lambda (n) ((f2) n) )) + +(= (f 2) 1) diff --git a/tests/test_lambda_6.lisp b/tests/test_lambda_6.lisp new file mode 100644 index 00000000..8283b51f --- /dev/null +++ b/tests/test_lambda_6.lisp @@ -0,0 +1,5 @@ +(define f (lambda () + (lambda (x) + (+ x 1)))) + +(= ((f) 1) 2) diff --git a/tests/test_lambda_7.lisp b/tests/test_lambda_7.lisp new file mode 100644 index 00000000..5b5531c6 --- /dev/null +++ b/tests/test_lambda_7.lisp @@ -0,0 +1,6 @@ +(define f (lambda () + (let ((a 1)) + (lambda (x) + (+ x a))))) + +(= ((f) 1) 2) diff --git a/tests/test_lambda_8.lisp b/tests/test_lambda_8.lisp new file mode 100644 index 00000000..3a4d84cd --- /dev/null +++ b/tests/test_lambda_8.lisp @@ -0,0 +1,7 @@ +(define f (lambda () + (let ((a 1)) + (lambda (x) + (let ((b a)) + (+ x b)))))) + +(= ((f) 1) 2) diff --git a/tests/test_lambda_9.lisp b/tests/test_lambda_9.lisp new file mode 100644 index 00000000..9da3ced4 --- /dev/null +++ b/tests/test_lambda_9.lisp @@ -0,0 +1,9 @@ +(define f (lambda () + (let ((a 1)) + (let ((b 2)) + (lambda (x) + (let ((b a)) + (let ((c 3)) + (+ x b)))))))) + +(= ((f) 1) 2) diff --git a/tests/test_let_9.lisp b/tests/test_let_9.lisp deleted file mode 100644 index 3f1d4d97..00000000 --- a/tests/test_let_9.lisp +++ /dev/null @@ -1,14 +0,0 @@ - -(define f (lambda () - (let ((x 200)) - (let ((y 100)) - (lambda (n) - (let ((a 4)) - (let ((b 5)) - (let ((c 6)) - (if (= n 0) (+ x y a b c) (f (- n 1))))))))))) - - -(define g (f)) - -(= ((g) 10) 315)