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

@@ -1164,8 +1164,12 @@ static inline void eval_symbol(eval_context_t *ctx) {
       return;
     }
   }
-  ctx->app_cont = true;
+  if (lbm_is_error(value)) {
-  ctx->r = 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;
+  if (lbm_is_symbol_nil(params)) { // accepts no more params
-  WITH_GC(entry,lbm_cons(lbm_car(params),ctx->r), NIL, NIL);
+    lbm_stack_drop(&ctx->K, 5);
-
+    ctx->curr_env = clo_env;
-  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;
     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;
+    lbm_value aug_env;
-    sptr[3] = lbm_cdr(params);
+    WITH_GC(aug_env,lbm_cons(entry, clo_env),entry,NIL);
-    sptr[4] = lbm_cdr(args);
 
-    lbm_push(&ctx->K, lbm_enc_u(CLOSURE_ARGS));
+    if (lbm_is_symbol_nil(args)) {
-
+      lbm_stack_drop(&ctx->K, 5);
-    ctx->curr_exp = lbm_car(args);
+      ctx->curr_env = aug_env;
-    ctx->curr_env = arg_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,
+                           clo_env,
-                               params,
+                           params,
-                               lbm_cdr(args),
+                           lbm_cdr(args),
-                               lbm_enc_u(CLOSURE_ARGS)));
+                           lbm_enc_u(CLOSURE_ARGS)));
     ctx->curr_exp = lbm_car(args);
+    ctx->curr_env = arg_env;
     ctx->app_cont = false;
   } break;
   default:

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 '\\';

tests/test_lambda_10.lisp

@@ -0,0 +1,10 @@
+
+(define f (lambda ()
+            (lambda (n)
+              (if (= n 0)
+                  42
+                  ((f) (- n 1))
+                  ))))
+
+
+(= ((f) 1) 42)

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)

tests/test_lambda_6.lisp

@@ -0,0 +1,5 @@
+(define f (lambda ()
+            (lambda (x)
+              (+ x 1))))
+
+(= ((f) 1) 2)

tests/test_lambda_7.lisp

@@ -0,0 +1,6 @@
+(define f (lambda ()
+            (let ((a 1))
+              (lambda (x)
+                (+ x a)))))
+
+(= ((f) 1) 2)

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)

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)

tests/test_let_9.lisp

@@ -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)