From e8d8d5c3beacbd340f10cc25e696e6ef7d352ac8 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 24 Dec 2016 12:10:05 +0100 Subject: [PATCH] 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 | 54 +++++++++++++++++++++++++++++++++++++----- mes.c | 47 ++++++++++++++---------------------- module/mes/base-0.mes | 2 +- module/srfi/srfi-1.mes | 11 +++++++++ module/srfi/srfi-1.scm | 3 +-- scripts/repl.mes | 2 +- tests/srfi-1.test | 7 ++++++ 7 files changed, 87 insertions(+), 39 deletions(-) diff --git a/lib.c b/lib.c index 06a6f8e2..ae14245c 100644 --- a/lib.c +++ b/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; +} diff --git a/mes.c b/mes.c index 7b12b64d..cab98d36 100644 --- a/mes.c +++ b/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 (); diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index 2ac99432..5f0ee3c5 100644 --- a/module/mes/base-0.mes +++ b/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*)) diff --git a/module/srfi/srfi-1.mes b/module/srfi/srfi-1.mes index 4f9315e2..89400ff3 100644 --- a/module/srfi/srfi-1.mes +++ b/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") diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index c51e69d0..50452774 100644 --- a/module/srfi/srfi-1.scm +++ b/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) diff --git a/scripts/repl.mes b/scripts/repl.mes index 462ffdd0..ac32000a 100755 --- a/scripts/repl.mes +++ b/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 "$@" diff --git a/tests/srfi-1.test b/tests/srfi-1.test index 446c5884..dd811ccb 100755 --- a/tests/srfi-1.test +++ b/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)