core: Add some error checking.

* lib.c (length): Return -1 for non-proper lists.
  (error): New function.
  (assert_defined): Use it.
  (check_formals, check_apply): New functions.
* mes.c (car, cdr, set_cdr_x, set_env_x, eval_apply): Add error check.
* srfi/srfi-1.mes (member): New function.
* tests/srfi-1.tests ("member"): New test.

lib.c

@@ -38,6 +38,7 @@ length (SCM x)
   while (x != cell_nil)
     {
       n++;
+      if (TYPE (x) != PAIR) return MAKE_NUMBER (-1);
       x = cdr (x);
     }
   return MAKE_NUMBER (n);
@@ -71,14 +72,55 @@ string_to_cstring (SCM s)
   return buf;
 }
 
+int
+error (char const* msg, SCM x)
+{
+  fprintf (stderr, msg);
+  if (x) stderr_ (x);
+  fprintf (stderr, "\n");
+  assert(!msg);
+}
+
 SCM
 assert_defined (SCM x, SCM e)
 {
-  if (e == cell_undefined)
-    {
-      fprintf (stderr, "eval: unbound variable:");
-      stderr_ (x);
-      assert (!"unbound variable");
-    }
+  if (e == cell_undefined) error ("eval: unbound variable: ", x);
   return e;
 }
+
+SCM
+check_formals (SCM f, SCM formals, SCM args)
+{
+  int flen = (TYPE (formals) == NUMBER) ? VALUE (formals) : VALUE (length (formals));
+  int alen = VALUE (length (args));
+  if (alen != flen && alen != -1 && flen != -1)
+    {
+      char buf[1024];
+      sprintf (buf, "apply: wrong number of arguments; expected: %d, got: %d: ", flen, alen);
+      error (buf, f);
+    }
+  return cell_unspecified;
+}
+
+SCM
+check_apply (SCM f, SCM e)
+{
+  char const* type = 0;
+  if (f == cell_f || f == cell_t) type = "bool";
+  if (TYPE (f) == CHAR) type = "char";
+  if (TYPE (f) == NUMBER) type = "number";
+  if (TYPE (f) == STRING) type = "string";
+  if (f == cell_unspecified) type = "*unspecified*";
+  if (f == cell_undefined) type =  "*undefined*";
+
+  if (type)
+    {
+      char buf[1024];
+      sprintf (buf, "cannot apply: %s:", type);
+      fprintf (stderr, " [");
+      stderr_ (e);
+      fprintf (stderr, "]\n");
+      error (buf, f);
+    }
+  return cell_unspecified;
+}

mes.c

@@ -166,6 +166,7 @@ SCM r3 = 0; // param 3
 #define MAKE_REF(n) make_cell (tmp_num_ (REF), n, 0);
 #define MAKE_STRING(x) make_cell (tmp_num_ (STRING), x, 0);
 
+int error (char const* msg, SCM x);
 SCM vm_call (function0_t f, SCM p1, SCM p2, SCM a);
 
 SCM
@@ -220,14 +221,14 @@ cons (SCM x, SCM y)
 SCM
 car (SCM x)
 {
-  assert (TYPE (x) == PAIR);
+  if (TYPE (x) != PAIR) error ("car: not pair: ", x);
   return CAR (x);
 }
 
 SCM
 cdr (SCM x)
 {
-  assert (TYPE (x) == PAIR);
+  if (TYPE (x) != PAIR) error ("cdr: not pair: ", x);
   return CDR (x);
 }
 
@@ -279,7 +280,7 @@ set_car_x (SCM x, SCM e)
 SCM
 set_cdr_x (SCM x, SCM e)
 {
-  assert (TYPE (x) == PAIR);
+  if (TYPE (x) != PAIR) error ("set-cdr!: not pair: ", x);
   CDR (x) = e;
   return cell_unspecified;
 }
@@ -288,6 +289,7 @@ SCM
 set_env_x (SCM x, SCM e, SCM a)
 {
   SCM p = assert_defined (x, assq (x, a));
+  if (TYPE (p) != PAIR) error ("set-env!: not pair: ", x);
   return set_cdr_x (p, e);
 }
 
@@ -360,15 +362,19 @@ eval_apply ()
  apply:
   switch (TYPE (r1))
     {
-    case FUNCTION: return call (r1, r2);
+    case FUNCTION: {
+      check_formals (r1, MAKE_NUMBER (FUNCTION (r1).arity), r2);
+      return call (r1, r2);
+    }
     case CLOSURE:
       {
         SCM cl = CLOSURE (r1);
-        SCM args = cadr (cl);
+        SCM formals = cadr (cl);
         SCM body = cddr (cl);
         SCM aa = cdar (cl);
         aa = cdr (aa);
-        SCM p = pairlis (args, r2, aa);
+        check_formals (r1, formals, r2);
+        SCM p = pairlis (formals, r2, aa);
         call_lambda (body, p, aa, r0);
         goto begin;
       }
@@ -389,9 +395,10 @@ eval_apply ()
           {
           case cell_symbol_lambda:
             {
-              SCM args = cadr (r1);
+              SCM formals = cadr (r1);
               SCM body = cddr (r1);
-              SCM p = pairlis (args, r2, r0);
+              SCM p = pairlis (formals, r2, r0);
+              check_formals (r1, formals, r2);
               call_lambda (body, p, p, r0);
               goto begin;
             }
@@ -407,22 +414,7 @@ eval_apply ()
       }
     }
   SCM e = eval_env (r1, r0);
-  char const* type = 0;
-  if (e == cell_f || e == cell_t) type = "bool";
-  if (TYPE (e) == CHAR) type = "char";
-  if (TYPE (e) == NUMBER) type = "number";
-  if (TYPE (e) == STRING) type = "string";
-  if (e == cell_unspecified) type = "*unspecified*";
-  if (e == cell_undefined) type =  "*undefined*";
-  if (type)
-    {
-      fprintf (stderr, "cannot apply: %s: ", type);
-      stderr_ (e);
-      fprintf (stderr, " [");
-      stderr_ (r1);
-      fprintf (stderr, "]\n");
-      assert (!"cannot apply");
-    }
+  check_apply (e, r1);
   r1 = e;
   goto apply;
 
@@ -562,6 +554,7 @@ call (SCM fn, SCM x)
     case 3: return FUNCTION (fn).function3 (car (x), cadr (x), caddr (x));
     case -1: return FUNCTION (fn).functionn (x);
     }
+
   return cell_unspecified;
 }
 
@@ -811,11 +804,7 @@ gc_up_arena ()
 {
   ARENA_SIZE *= 2;
   void *p = realloc (g_cells-1, 2*ARENA_SIZE*sizeof(scm));
-  if (!p)
-    {
-      if (g_debug) fprintf (stderr, "cannot up arena: %s: arena=%d\n", strerror (errno), 2*ARENA_SIZE);
-      return cell_unspecified;
-    }
+  if (!p) error (strerror (errno), MAKE_NUMBER (g_free.value));
   g_cells = (scm*)p;
   g_cells++;
   gc_init_news ();

module/mes/base-0.mes

@@ -139,7 +139,7 @@
 (define (mes-load-module-env module a)
   (push! *input-ports* (current-input-port))
   (set-current-input-port (open-input-file (string-append *mes-prefix* (module->file module))))
-  (let ((x (eval-env (append (cons 'begin (read-input-file-env #f a))
+  (let ((x (eval-env (append (cons 'begin (read-input-file-env a))
                              '((current-module)))
                      a)))
     (set-current-input-port (pop! *input-ports*))

module/srfi/srfi-1.mes

@@ -70,4 +70,15 @@
           (set-cdr! lst result)
           (loop tail lst)))))
 
+(define (srfi-1:member x lst eq)
+  (if (null? lst) #f
+      (if (eq x (car lst)) lst
+          (srfi-1:member x (cdr lst) eq))))
+
+(define mes:member member)
+
+(define (member x lst . rest)
+  (if (null? rest) (mes:member x lst)
+      (srfi-1:member x lst (car rest))))
+
 (include-from-path "srfi/srfi-1.scm")

module/srfi/srfi-1.scm

@@ -73,8 +73,7 @@
 		(if (null? acc)
 		    (set! acc lst)
 		    (for-each (lambda (elem)
-				(if (not (member elem acc
-						 (lambda (x y) (= y x))))
+				(if (not (member elem acc =))
 				    (set! acc (cons elem acc))))
 			      lst)))
 	      rest)

scripts/repl.mes

@@ -1,6 +1,6 @@
 #! /bin/sh
 # -*-scheme-*-
-MES_ARENA=${MES_ARENA-10000000}
+MES_ARENA=${MES_ARENA-20000000}
 export MES_ARENA
 prefix=module/
 cat $prefix/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@"

tests/srfi-1.test

@@ -48,4 +48,11 @@ exit $?
                '(3 2 1 4 5 6)
                (append-reverse '(1 2 3) '(4 5 6)))
 
+(pass-if-equal "member lambda"
+    '(4)
+  (member 2 '(1 4) (lambda (x y) (even? y))))
+
+(pass-if-not "member ="
+             (member 2 '(1 4) =))
+
 (result 'report)