Squashed 'lispBM/lispBM/' changes from c81eb021..8b64ae8b

8b64ae8b added some tests for matching with guards.
62e2c688 update lbm_ref
14ec7847 error message on malformed recv patterns
e9ea4e4e match with guards
0e3a29fc Pattern matching now support optional boolean guard expressions
4af283e8 some precautionary changes to certain fundamentals
a4435fb0 added a test of built in map

git-subtree-dir: lispBM/lispBM
git-subtree-split: 8b64ae8b1193fee0f9f9ca361c25ca9357a3384a

doc/lbmref.md

@@ -1209,6 +1209,24 @@ An example that evaluates to 19.
 
 ---
 
+### Match with guards
+
+Patterns used in a match expressions can be augmented with a boolean
+guard to further discern between cases. A pattern with a guard is of the
+form `(pattern-expr guard-expr expr)`. A pattern with a guard, matches only
+if the pattern structurally matches and if the guard-expr evaluates to true
+in the match environment.
+
+Example:
+```clj
+(match (x)
+       ( (? y) (< y 0) 'less-than-zero)
+       ( (? y) (> y 0) 'greater-than-zero)
+       ( (? y) (= y 0) 'equal-to-zero))
+``` 
+
+---
+
 ## Concurrency
 
 The concurrency support in LispBM is provided by the set of functions,

repl/test_mp.lisp

@@ -23,7 +23,7 @@
                  (print "FRED!")
                  (print "fred iteration\n" )
                  (recv ( (apa (? x) 107) (print "fred received apa " x "\n"))
-                       ( (bepa (?i x))  (print "fred received bepa " x "\n")))
+                       ( (bepa (? x))  (print "fred received bepa " x "\n")))
                  (fred))))
 
 (let ((apa 1000))
@@ -59,10 +59,6 @@
 ;;                        (space)))))
 ;;          space))
 
-
-(define f (lambda (x y z)
-            (+ x y z)))
-
 ;;(spawn 20 f 1 2 3)
 
 (define fredpid (spawn fred))

src/eval_cps.c

@@ -68,7 +68,12 @@
 #define READ_APPEND_ARRAY     ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U)
 #define MAP_FIRST             ((30 << LBM_VAL_SHIFT) | LBM_TYPE_U)
 #define MAP_REST              ((31 << LBM_VAL_SHIFT) | LBM_TYPE_U)
-#define NUM_CONTINUATIONS     32
+#define MATCH_GUARD           ((32 << LBM_VAL_SHIFT) | LBM_TYPE_U)
+#define NUM_CONTINUATIONS     33
+
+#define FM_NEED_GC       -1
+#define FM_NO_MATCH      -2
+#define FM_PATTERN_ERROR -3
 
 static const char* parse_error_eof = "End of parse stream";
 static const char* parse_error_token = "Malformed token";
@@ -970,16 +975,22 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
   return struct_eq(p, e);
 }
 
-static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env, bool *gc) {
+static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
 
   lbm_value curr_p = plist;
   int n = 0;
+  bool gc = false;
   for (int i = 0; i < (int)num; i ++ ) {
     lbm_value curr_e = earr[i];
     while (lbm_type_of(curr_p) == LBM_TYPE_CONS) {
-      if (match(lbm_car(lbm_car(curr_p)), curr_e, env, gc)) {
-        if (*gc) return -1;
-        *e = lbm_cadr(lbm_car(curr_p));
+      lbm_value me = lbm_car(curr_p);
+      if (match(lbm_car(me), curr_e, env, &gc)) {
+        if (gc) return FM_NEED_GC;
+        *e = lbm_cadr(me);
+
+        if (!lbm_is_symbol_nil(lbm_cadr(lbm_cdr(me)))) {
+          return FM_PATTERN_ERROR;
+        }
         return n;
       }
       curr_p = lbm_cdr(curr_p);
@@ -988,7 +999,7 @@ static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value
     n ++;
   }
 
-  return -1;
+  return FM_NO_MATCH;
 }
 
 /****************************************************/
@@ -1411,20 +1422,21 @@ static void eval_receive(eval_context_t *ctx) {
       lbm_value e;
       lbm_value new_env = ctx->curr_env;
       bool do_gc = false;
-      int n = find_match(lbm_cdr(pats), msgs, num, &e, &new_env, &do_gc);
-      if (do_gc) {
+      int n = find_match(lbm_cdr(pats), msgs, num, &e, &new_env);
+      if (n == FM_NEED_GC) {
         gc();
         do_gc = false;
-        n = find_match(lbm_cdr(pats), msgs, num, &e, &new_env, &do_gc);
+        n = find_match(lbm_cdr(pats), msgs, num, &e, &new_env);
         if (do_gc) {
           ctx_running->done = true;
           error_ctx(ENC_SYM_MERROR);
           return;
         }
-      }
-      if (n >= 0 ) { /* Match */
+      } else if (n == FM_PATTERN_ERROR) {
+        lbm_set_error_reason("Incorrect pattern format for recv");
+        error_ctx(ENC_SYM_EERROR);
+      } else if (n >= 0 ) { /* Match */
         mailbox_remove_mail(ctx, (lbm_uint)n);
-
         ctx->curr_env = new_env;
         ctx->curr_exp = e;
       } else { /* No match  go back to sleep */
@@ -2161,12 +2173,28 @@ static void cont_match(eval_context_t *ctx) {
     ctx->r = ENC_SYM_NO_MATCH;
     ctx->app_cont = true;
   } else if (lbm_is_cons(patterns)) {
-    lbm_value pattern = lbm_car(lbm_car(patterns));
-    lbm_value body    = lbm_cadr(lbm_car(patterns));
-
+    lbm_value match_case = lbm_car(patterns);
+    lbm_value pattern = lbm_car(match_case);
+    lbm_value n1      = lbm_cadr(match_case);
+    lbm_value n2      = lbm_cadr(lbm_cdr(match_case));
+    lbm_value body;
+    bool check_guard = false;
+    if (lbm_is_symbol_nil(n2)) {
+      body = n1;
+    } else {
+      body = n2;
+      check_guard = true;
+    }
     if (match(pattern, e, &new_env, &do_gc)) {
+      if (check_guard) {
+        CHECK_STACK(lbm_push_3(&ctx->K, lbm_cdr(patterns), ctx->curr_env, MATCH));
+        CHECK_STACK(lbm_push_3(&ctx->K, body, e, MATCH_GUARD));
+        ctx->curr_env = new_env;
+        ctx->curr_exp = n1; // The guard
+      } else {
         ctx->curr_env = new_env;
         ctx->curr_exp = body;
+      }
     } else if (do_gc) {
       lbm_gc_mark_phase(patterns);
       lbm_gc_mark_phase(e);
@@ -2179,8 +2207,15 @@ static void cont_match(eval_context_t *ctx) {
         error_ctx(ENC_SYM_MERROR);
         return;
       }
+      if (check_guard) {
+        CHECK_STACK(lbm_push_3(&ctx->K, lbm_cdr(patterns), ctx->curr_env, MATCH));
+        CHECK_STACK(lbm_push_3(&ctx->K, body, e, MATCH_GUARD));
+        ctx->curr_env = new_env;
+        ctx->curr_exp = n1; // The guard
+      } else {
         ctx->curr_env = new_env;
         ctx->curr_exp = body;
+      }
     } else {
       /* set up for checking of next pattern */
       CHECK_STACK(lbm_push_3(&ctx->K, lbm_cdr(patterns),ctx->curr_env, MATCH));
@@ -2257,6 +2292,23 @@ static void cont_map_rest(eval_context_t *ctx) {
   }
 }
 
+static void cont_match_guard(eval_context_t *ctx) {
+  if (lbm_is_symbol_nil(ctx->r)) {
+    lbm_value e;
+    lbm_pop(&ctx->K, &e);
+    lbm_stack_drop(&ctx->K, 1);
+    ctx->r = e;
+    ctx->app_cont = true;
+  } else {
+    lbm_value body;
+    lbm_stack_drop(&ctx->K, 1);
+    lbm_pop(&ctx->K, &body);
+    lbm_stack_drop(&ctx->K, 3);
+    ctx->curr_exp = body;
+  }
+}
+
+
 /****************************************************/
 /*   READER                                         */
 
@@ -2849,7 +2901,8 @@ static const cont_fun continuations[NUM_CONTINUATIONS] =
     cont_read_start_array,
     cont_read_append_array,
     cont_map_first,
-    cont_map_rest
+    cont_map_rest,
+    cont_match_guard,
   };
 
 /*********************************************************/

src/fundamental.c

@@ -1010,8 +1010,9 @@ static lbm_value fundamental_string_to_symbol(lbm_value *args, lbm_uint nargs, e
   lbm_value result = ENC_SYM_EERROR;
   if (nargs < 1 ||
       lbm_type_of(args[0] != LBM_TYPE_ARRAY))
-    return result;;
+    return result;
   lbm_array_header_t *arr = (lbm_array_header_t *)lbm_car(args[0]);
+  if (!arr) return ENC_SYM_FATAL_ERROR;
   if (arr->elt_type != LBM_TYPE_CHAR)
     return result;
   char *str = (char *)arr->data;
@@ -1380,6 +1381,7 @@ static lbm_value fundamental_custom_destruct(lbm_value *args, lbm_uint nargs, ev
   lbm_value result = ENC_SYM_EERROR;
   if (nargs == 1 && (lbm_type_of(args[0]) == LBM_TYPE_CUSTOM)) {
     lbm_uint *mem_ptr = (lbm_uint*)lbm_dec_custom(args[0]);
+    if(!mem_ptr) return ENC_SYM_FATAL_ERROR;
     lbm_custom_type_destroy(mem_ptr);
     lbm_value tmp = lbm_set_ptr_type(args[0], LBM_TYPE_CONS);
     lbm_set_car(tmp, ENC_SYM_NIL);

tests/test_map_8.lisp

@@ -0,0 +1,7 @@
+(defun f (x) (+ x 1))
+
+
+(define ls (list (list (list 1 2 3) (range 2 5))))
+(define rs '(((2 3 4) (3 4 5))))
+
+(eq (map (map (map f)) ls) rs)

tests/test_match_guard_0.lisp

@@ -0,0 +1,11 @@
+
+(defun f (x)
+  (match x
+         ( _ (<= x 10) (+ x 1))
+         ( _ (>  x 10) (+ x 100))))
+
+
+
+(and (= (f 0) 1)
+     (= (f 2) 3)
+     (= (f 11) 111))

tests/test_match_guard_1.lisp

@@ -0,0 +1,11 @@
+
+(defun f (x)
+  (match nil
+         ( _ (<= x 10) (+ x 1))
+         ( _ (>  x 10) (+ x 100))))
+
+
+
+(and (= (f 0) 1)
+     (= (f 2) 3)
+     (= (f 11) 111))

tests/test_match_guard_2.lisp

@@ -0,0 +1,11 @@
+
+(defun f (x)
+  (match x
+         ( (apa (? x)) (<= x 10) (+ x 1))
+         ( (apa (? x)) (>  x 10) (+ x 100))))
+
+
+
+(and (= (f '(apa 0)) 1)
+     (= (f '(apa 2)) 3)
+     (= (f '(apa 11)) 111))

tests/test_match_guard_3.lisp

@@ -0,0 +1,12 @@
+
+(defun f (x)
+  (match x
+         ( (apa (? x) (? y)) (> x y) 'bigger)
+         ( (apa (? x) (? y)) (< x y) 'smaller)))
+
+
+
+(and (eq (f '(apa 0 1)) 'smaller)
+     (eq (f '(apa 1 0)) 'bigger)
+     (eq (f '(apa 1000 900)) 'bigger)
+     (eq (f '(apa 900 1000)) 'smaller))

tests/test_match_guard_4.lisp

@@ -0,0 +1,11 @@
+(defun f (x i)
+  (match x
+         ( (apa (? x)) (> x i) 'bigger)
+         ( (apa (? x)) (< x i) 'smaller)))
+
+
+
+(and (eq (f '(apa 0) 1) 'smaller)
+     (eq (f '(apa 1) 0) 'bigger)
+     (eq (f '(apa 1000) 900) 'bigger)
+     (eq (f '(apa 900) 1000) 'smaller))

tests/test_match_guard_5.lisp

@@ -0,0 +1,8 @@
+
+(defun f (x)
+  (match x
+         ( (? x) (eq (type-of x) type-i) 'an-integer)
+         ( (? x) 'something-else)))
+
+(and (eq (f 23) 'an-integer)
+     (eq (f 0.3) 'something-else))