r5rs test suite, various bugfixes

Makefile

@@ -44,7 +44,7 @@ cleaner: clean
 	rm -rf *.dSYM
 
 test: chibi-scheme
-	@for f in tests/*.scm; do \
+	@for f in tests/basic/*.scm; do \
 	    ./chibi-scheme $$f >$${f%.scm}.out 2>$${f%.scm}.err; \
 	    if diff -q $${f%.scm}.out $${f%.scm}.res; then \
 	        echo "[PASS] $${f%.scm}"; \

config.h

@@ -11,6 +11,9 @@
 /* uncomment this if you don't need extended math operations */
 /* #define USE_MATH 0 */
 
+/* uncomment this to disable warning about references to undefined variables */
+/* #define USE_WARN_UNDEFS 0 */
+
 /* uncomment this to disable huffman-coded immediate symbols */
 /* #define USE_HUFF_SYMS 0 */
 

defaults.h

@@ -27,6 +27,10 @@
 #define USE_MATH 1
 #endif
 
+#ifndef USE_WARN_UNDEFS
+#define USE_WARN_UNDEFS 1
+#endif
+
 #ifndef USE_HUFF_SYMS
 #define USE_HUFF_SYMS 1
 #endif

eval.c

@@ -689,6 +689,10 @@ static void generate_opcode_app (sexp app, sexp context) {
 
   /* emit the actual operator call */
   switch (sexp_opcode_class(op)) {
+  case OPC_ARITHMETIC:
+    if (num_args > 1)
+      emit(sexp_opcode_code(op), context);
+    break;
   case OPC_ARITHMETIC_INV:
     emit((num_args == 1) ? sexp_opcode_inverse(op)
          : sexp_opcode_code(op), context);
@@ -1368,7 +1372,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     break;
   case OP_LT:
     if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
-      i = _ARG1 < _ARG2;
+      i = (sexp_sint_t)_ARG1 < (sexp_sint_t)_ARG2;
 #if USE_FLONUMS
     else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
       i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2);
@@ -1383,7 +1387,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     break;
   case OP_LE:
     if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
-      i = _ARG1 <= _ARG2;
+      i = (sexp_sint_t)_ARG1 <= (sexp_sint_t)_ARG2;
 #if USE_FLONUMS
     else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
       i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2);
@@ -1510,31 +1514,55 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
 
 /************************ library procedures **************************/
 
-sexp sexp_open_input_file (sexp path) {
-  return sexp_make_input_port(fopen(sexp_string_data(path), "r"));
+static sexp sexp_open_input_file (sexp path) {
+  FILE *in;
+  if (! sexp_stringp(path)) return sexp_type_exception("not a string", path);
+  in = fopen(sexp_string_data(path), "r");
+  if (! in) return sexp_user_exception("couldn't open input file", path);
+  return sexp_make_input_port(in, sexp_string_data(path));
 }
 
-sexp sexp_open_output_file (sexp path) {
-  return sexp_make_input_port(fopen(sexp_string_data(path), "w"));
+static sexp sexp_open_output_file (sexp path) {
+  FILE *out;
+  if (! sexp_stringp(path)) return sexp_type_exception("not a string", path);
+  out = fopen(sexp_string_data(path), "w");
+  if (! out) return sexp_user_exception("couldn't open output file", path);
+  return sexp_make_input_port(out, sexp_string_data(path));
 }
 
-sexp sexp_close_port (sexp port) {
+static sexp sexp_close_port (sexp port) {
   fclose(sexp_port_stream(port));
   return SEXP_VOID;
 }
 
+static void sexp_warn_undefs (sexp from, sexp to, sexp out) {
+  sexp x;
+  for (x=from; sexp_pairp(x) && x!=to; x=sexp_cdr(x))
+    if (sexp_cdar(x) == SEXP_UNDEF) {
+      sexp_write_string("WARNING: reference to undefined variable: ", out);
+      sexp_write(sexp_caar(x), out);
+      sexp_write_char('\n', out);
+    }
+}
+
 sexp sexp_load (sexp source, sexp env) {
-  sexp obj, res, in, context = sexp_make_context(NULL, env);
+  sexp x, res, in, tmp, out, context = sexp_make_context(NULL, env);
+  tmp = sexp_env_bindings(env);
   sexp_context_tailp(context) = 0;
   in = sexp_open_input_file(source);
-  while ((obj=sexp_read(in)) != (sexp) SEXP_EOF) {
-    res = eval_in_context(obj, context);
+  while ((x=sexp_read(in)) != (sexp) SEXP_EOF) {
+    res = eval_in_context(x, context);
     if (sexp_exceptionp(res))
       break;
   }
-  if (obj == SEXP_EOF)
+  if (x == SEXP_EOF)
     res = SEXP_VOID;
   sexp_close_port(in);
+#ifdef USE_WARN_UNDEFS
+  out = env_global_ref(env, the_cur_err_symbol, SEXP_FALSE);
+  if (sexp_oportp(out))
+    sexp_warn_undefs(sexp_env_bindings(env), tmp, out);
+#endif
   return res;
 }
 
@@ -1688,9 +1716,9 @@ static sexp sexp_make_standard_env (sexp version) {
     }
     env_define(e, sexp_intern(sexp_opcode_name(op)), op);
   }
-  env_define(e, the_cur_in_symbol, sexp_make_input_port(stdin));
-  env_define(e, the_cur_out_symbol, sexp_make_output_port(stdout));
-  env_define(e, the_cur_err_symbol, sexp_make_output_port(stderr));
+  env_define(e, the_cur_in_symbol, sexp_make_input_port(stdin, NULL));
+  env_define(e, the_cur_out_symbol, sexp_make_output_port(stdout, NULL));
+  env_define(e, the_cur_err_symbol, sexp_make_output_port(stderr, NULL));
   env_define(e, the_interaction_env_symbol, e);
   return e;
 }

init.scm

@@ -30,6 +30,10 @@
 (define (cdddar x) (cdr (cdr (cdr (car x)))))
 (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
 
+;; basic utils
+
+(define (procedure? x) (if (closure? x) #t (opcode? x)))
+
 (define (list . args) args)
 
 (define (list-tail ls k)
@@ -39,26 +43,6 @@
 
 (define (list-ref ls k) (car (list-tail ls k)))
 
-(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b))))
-
-(define (member obj ls)
-  (if (null? ls)
-      #f
-      (if (equal? obj (car ls))
-          ls
-          (member obj (cdr ls)))))
-
-(define memv member)
-
-(define (assoc obj ls)
-  (if (null? ls)
-      #f
-      (if (equal? obj (caar ls))
-          (car ls)
-          (assoc obj (cdr ls)))))
-
-(define assv assoc)
-
 (define (append-reverse a b)
   (if (pair? a)
       (append-reverse (cdr a) (cons (car a) b))
@@ -175,13 +159,16 @@
           ((eq? 'unquote (car x))
            (if (<= d 0)
                (cadr x)
-               (list (rename 'unquote) (qq (cadr x) (- d 1)))))
+               (list (rename 'list) (list (rename 'quote) 'unquote)
+                     (qq (cadr x) (- d 1)))))
           ((eq? 'unquote-splicing (car x))
            (if (<= d 0)
                (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
-               (list (rename 'unquote-splicing) (qq (cadr x) (- d 1)))))
+               (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
+                     (qq (cadr x) (- d 1)))))
           ((eq? 'quasiquote (car x))
-           (list (rename 'quasiquote) (qq (cadr x) (+ d 1))))
+           (list (rename 'list) (list (rename 'quote) 'quasiquote)
+                 (qq (cadr x) (+ d 1))))
           ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x)))
            (if (null? (cdr x))
                (cadar x)
@@ -264,7 +251,7 @@
 (define-syntax delay
   (er-macro-transformer
    (lambda (expr rename compare)
-     `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr epr))))))
+     `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
 
 (define (make-promise thunk)
   (lambda ()
@@ -348,6 +335,28 @@
 (define (string-ci>? s1 s2) (> (string-cmp-ci s1 s2) 0))
 (define (string-ci>=? s1 s2) (>= (string-cmp-ci s1 s2) 0))
 
+;; list utils
+
+(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b))))
+
+(define (member obj ls)
+  (if (null? ls)
+      #f
+      (if (equal? obj (car ls))
+          ls
+          (member obj (cdr ls)))))
+
+(define memv member)
+
+(define (assoc obj ls)
+  (if (null? ls)
+      #f
+      (if (equal? obj (caar ls))
+          (car ls)
+          (assoc obj (cdr ls)))))
+
+(define assv assoc)
+
 ;; math utils
 
 (define (number? x) (if (fixnum? x) #t (flonum? x)))
@@ -369,16 +378,16 @@
 (define (modulo a b)
   (let ((res (remainder a b)))
     (if (< b 0)
-        (if (< res 0) res (- res b))
-        (if (> res 0) res (+ res b)))))
+        (if (<= res 0) res (+ res b))
+        (if (>= res 0) res (+ res b)))))
 
 (define (gcd a b)
   (if (= b 0)
-      a
-      (gcd b (modulo a b))))
+      (abs a)
+      (gcd b (remainder a b))))
 
 (define (lcm a b)
-  (quotient (* a b) (gcd a b)))
+  (abs (quotient (* a b) (gcd a b))))
 
 (define (max x . rest)
   (let lp ((hi x) (ls rest))
@@ -468,8 +477,8 @@
 
 (define (call-with-output-file file proc)
   (let* ((out (open-output-file file))
-         (res (proc in)))
-    (close-output-port in)
+         (res (proc out)))
+    (close-output-port out)
     res))
 
 (define (with-input-from-file file thunk)

main.c

@@ -2,7 +2,7 @@
 #include "eval.c"
 
 void repl (sexp context) {
-  sexp obj, res, env, in, out, err;
+  sexp obj, tmp, res, env, in, out, err;
   env = sexp_context_env(context);
   sexp_context_tracep(context) = 1;
   in = env_global_ref(env, the_cur_in_symbol, SEXP_FALSE);
@@ -17,7 +17,11 @@ void repl (sexp context) {
     if (sexp_exceptionp(obj)) {
       sexp_print_exception(obj, err);
     } else {
+      tmp = sexp_env_bindings(env);
       res = eval_in_context(obj, context);
+#ifdef USE_WARN_UNDEFS
+      sexp_warn_undefs(sexp_env_bindings(env), tmp, err);
+#endif
       if (res != SEXP_VOID) {
         sexp_write(res, out);
         sexp_write_char('\n', out);

opcodes.c

@@ -52,7 +52,8 @@ _OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "pair?", 0, (sexp)SEXP_PAIR),
 _OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "string?", 0, (sexp)SEXP_STRING),
 _OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "vector?", 0, (sexp)SEXP_VECTOR),
 _OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "flonum?", 0, (sexp)SEXP_FLONUM),
-_OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "procedure?", 0, (sexp)SEXP_PROCEDURE),
+_OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "closure?", 0, (sexp)SEXP_PROCEDURE),
+_OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "opcode?", 0, (sexp)SEXP_OPCODE),
 _OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "input-port?", 0, (sexp)SEXP_IPORT),
 _OP(OPC_TYPE_PREDICATE, OP_TYPEP,  1, 0, 0, 0, 0, "output-port?", 0, (sexp)SEXP_OPORT),
 _OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", 0, NULL),

sexp.c

@@ -102,6 +102,14 @@ sexp sexp_make_exception (sexp kind, sexp message, sexp irritants,
   return exn;
 }
 
+sexp sexp_user_exception (char *message, sexp irritants) {
+  return sexp_make_exception(sexp_intern("user-error"),
+                             sexp_c_string(message),
+                             ((sexp_pairp(irritants) || sexp_nullp(irritants))
+                              ? irritants : sexp_list1(irritants)),
+                             SEXP_FALSE, SEXP_FALSE);
+}
+
 sexp sexp_type_exception (char *message, sexp obj) {
   return sexp_make_exception(sexp_intern("type-error"),
                              sexp_c_string(message),
@@ -178,10 +186,18 @@ sexp sexp_cons (sexp head, sexp tail) {
   return pair;
 }
 
-sexp sexp_listp (sexp obj) {
-  while (sexp_pairp(obj))
-    obj = sexp_cdr(obj);
-  return sexp_make_boolean(obj == SEXP_NULL);
+sexp sexp_listp (sexp hare) {
+  sexp turtle;
+  if (! sexp_pairp(hare))
+    return sexp_make_boolean(hare == SEXP_NULL);
+  turtle = hare;
+  hare = sexp_cdr(hare);
+  for ( ; sexp_pairp(hare); turtle=sexp_cdr(turtle)) {
+    if (hare == turtle) return SEXP_FALSE;
+    hare = sexp_cdr(hare);
+    if (sexp_pairp(hare)) hare = sexp_cdr(hare);
+  }
+  return sexp_make_boolean(hare == SEXP_NULL);
 }
 
 sexp sexp_memq (sexp x, sexp ls) {
@@ -269,7 +285,7 @@ sexp sexp_equalp (sexp a, sexp b) {
       return SEXP_FALSE;
     v1 = sexp_vector_data(a);
     v2 = sexp_vector_data(b);
-    for (len--; len >= 0; len--)
+    for (len--; len > 0; len--)
       if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE)
         return SEXP_FALSE;
     return SEXP_TRUE;
@@ -278,6 +294,8 @@ sexp sexp_equalp (sexp a, sexp b) {
                              && (! strncmp(sexp_string_data(a),
                                            sexp_string_data(b),
                                            sexp_string_length(a))));
+  case SEXP_FLONUM:
+    return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b));
   default:
     return SEXP_FALSE;
   }
@@ -292,9 +310,11 @@ sexp sexp_make_flonum(double f) {
 }
 
 sexp sexp_make_string(sexp len, sexp ch) {
+  char *cstr;
   sexp s = sexp_alloc_type(string, SEXP_STRING);
-  sexp_uint_t clen = sexp_unbox_integer(len);
-  char *cstr = sexp_alloc(clen+1);
+  sexp_sint_t clen = sexp_unbox_integer(len);
+  if (clen < 0) return sexp_type_exception("negative length", len);
+  cstr = sexp_alloc(clen+1);
   if (sexp_charp(ch))
     memset(cstr, sexp_unbox_character(ch), clen);
   cstr[clen] = '\0';
@@ -441,7 +461,7 @@ int sstream_read (void *vec, char *dst, int n) {
   if (pos >= len) return 0;
   if (n > (len - pos)) n = (len - pos);
   memcpy(dst, sexp_string_data(sexp_stream_buf(vec))+pos, n);
-  sexp_vector_set((sexp) vec, sexp_make_integer(2), sexp_make_integer(n));
+  sexp_stream_pos(vec) = sexp_make_integer(n);
   return n;
 }
 
@@ -451,16 +471,16 @@ int sstream_write (void *vec, const char *src, int n) {
   len = sexp_unbox_integer(sexp_stream_size(vec));
   pos = sexp_unbox_integer(sexp_stream_pos(vec));
   newpos = pos+n;
-  if (newpos > len) {
-    newbuf = sexp_make_string(sexp_make_integer(len*2), SEXP_VOID);
+  if (newpos >= len) {
+    newbuf = sexp_make_string(sexp_make_integer(newpos*2), SEXP_VOID);
     memcpy(sexp_string_data(newbuf),
            sexp_string_data(sexp_stream_buf(vec)),
            pos);
-    sexp_vector_set((sexp)vec, sexp_make_integer(0), newbuf);
-    sexp_vector_set((sexp)vec, sexp_make_integer(1), sexp_make_integer(len*2));
+    sexp_stream_buf(vec) = newbuf;
+    sexp_stream_size(vec) = sexp_make_integer(newpos*2);
   }
   memcpy(sexp_string_data(sexp_stream_buf(vec))+pos, src, n);
-  sexp_vector_set((sexp)vec, sexp_make_integer(2), sexp_make_integer(newpos));
+  sexp_stream_pos(vec) = sexp_make_integer(newpos);
   return n;
 }
 
@@ -473,7 +493,7 @@ off_t sstream_seek (void *vec, off_t offset, int whence) {
   } else {                      /* SEEK_END */
     pos = sexp_unbox_integer(sexp_stream_size(vec)) + offset;
   }
-  sexp_vector_set((sexp)vec, sexp_make_integer(2), sexp_make_integer(pos));
+  sexp_stream_pos(vec) = sexp_make_integer(pos);
   return pos;
 }
 
@@ -483,7 +503,7 @@ sexp sexp_make_input_string_port (sexp str) {
   cookie = sexp_vector(3, str, sexp_make_integer(sexp_string_length(str)),
                        sexp_make_integer(0));
   in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
-  res = sexp_make_input_port(in);
+  res = sexp_make_input_port(in, NULL);
   sexp_port_cookie(res) = cookie;
   return res;
 }
@@ -495,7 +515,7 @@ sexp sexp_make_output_string_port () {
   cookie = sexp_vector(3, sexp_make_string(size, SEXP_VOID),
                        size, sexp_make_integer(0));
   out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
-  res = sexp_make_output_port(out);
+  res = sexp_make_output_port(out, NULL);
   sexp_port_cookie(res) = cookie;
   return res;
 }
@@ -512,14 +532,14 @@ sexp sexp_get_output_string (sexp port) {
 
 sexp sexp_make_input_string_port (sexp str) {
   FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r");
-  return sexp_make_input_port(in);
+  return sexp_make_input_port(in, NULL);
 }
 
 sexp sexp_make_output_string_port () {
   FILE *out;
   sexp buf = sexp_alloc_type(string, SEXP_STRING), res;
   out = open_memstream(&sexp_string_data(buf), &sexp_string_length(buf));
-  res = sexp_make_input_port(out);
+  res = sexp_make_input_port(out, NULL);
   sexp_port_cookie(res) = buf;
   return res;
 }
@@ -536,18 +556,18 @@ sexp sexp_get_output_string (sexp port) {
 
 #endif
 
-sexp sexp_make_input_port (FILE* in) {
+sexp sexp_make_input_port (FILE* in, char *path) {
   sexp p = sexp_alloc_type(port, SEXP_IPORT);
   sexp_port_stream(p) = in;
-  sexp_port_name(p) = NULL;
+  sexp_port_name(p) = path;
   sexp_port_line(p) = 0;
   return p;
 }
 
-sexp sexp_make_output_port (FILE* out) {
+sexp sexp_make_output_port (FILE* out, char *path) {
   sexp p = sexp_alloc_type(port, SEXP_OPORT);
   sexp_port_stream(p) = out;
-  sexp_port_name(p) = NULL;
+  sexp_port_name(p) = path;
   sexp_port_line(p) = 0;
   return p;
 }
@@ -786,39 +806,58 @@ char* sexp_read_symbol(sexp in, int init) {
   return res;
 }
 
-sexp sexp_read_float_tail(sexp in, long whole) {
-  double res = 0.0, scale=0.1;
+sexp sexp_read_float_tail(sexp in, sexp_sint_t whole) {
+  sexp exponent;
+  double res=0.0, scale=0.1, e=0.0;
   int c;
   for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1)
     res += digit_value(c)*scale;
   sexp_push_char(c, in);
-  return sexp_make_flonum(whole + res);
+  if (c=='e' || c=='E') {
+    exponent = sexp_read_number(in, 10);
+    if (sexp_exceptionp(exponent)) return exponent;
+    e = (sexp_integerp(exponent) ? sexp_unbox_integer(exponent)
+         : sexp_flonump(exponent) ? sexp_flonum_value(exponent) : 0.0);
+  } else if ((c!=EOF) && ! is_separator(c))
+    return sexp_read_error("invalid numeric syntax",
+                           sexp_list1(sexp_make_character(c)), in);
+  return sexp_make_flonum((whole + res) * pow(10, e));
 }
 
 sexp sexp_read_number(sexp in, int base) {
-  sexp tmp;
-  long res = 0, negativep = 0, c;
+  sexp f;
+  sexp_sint_t res = 0, negativep = 0, c;
 
   c = sexp_read_char(in);
-  if (c == '-') {
+  if (c == '-')
     negativep = 1;
-  } else if (isdigit(c)) {
-    res = c - '0';
-  }
+  else if (isdigit(c))
+    res = digit_value(c);
 
-  for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in))
-    res = res * base + digit_value(c);
-  if (c=='.') {
-    if (base != 10) {
+  if (base == 16)
+    for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in))
+      res = res * base + digit_value(c);
+    for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in))
+      res = res * base + digit_value(c);
+
+  if (c=='.' || c=='e' || c=='E') {
+    if (base != 10)
       return sexp_read_error("decimal found in non-base 10", SEXP_NULL, in);
+    if (c!='.')
+      sexp_push_char(c, in);
+    f = sexp_read_float_tail(in, res);
+    if (! sexp_flonump(f)) return f;
+    if ((c!='.') && (sexp_flonum_value(f) == round(sexp_flonum_value(f)))) {
+      res = (sexp_sint_t) sexp_flonum_value(f);
+    } else {
+      if (negativep) sexp_flonum_value(f) = -sexp_flonum_value(f);
+      return f;
     }
-    tmp = sexp_read_float_tail(in, res);
-    if (sexp_exceptionp(tmp)) return tmp;
-    if (negativep && sexp_flonump(tmp))
-      sexp_flonum_value(tmp) = -1 * sexp_flonum_value(tmp);
-    return tmp;
   } else {
     sexp_push_char(c, in);
+    if ((c!=EOF) && ! is_separator(c))
+      return sexp_read_error("invalid numeric syntax",
+                             sexp_list1(sexp_make_character(c)), in);
   }
 
   return sexp_make_integer(negativep ? -res : res);
@@ -1009,7 +1048,14 @@ sexp sexp_read_raw (sexp in) {
       sexp_push_char(c2, in);
       res = sexp_read_number(in, 10);
       if (sexp_exceptionp(res)) return res;
-      if (c1 == '-') res = sexp_fx_mul(res, -1);
+      if (c1 == '-') {
+#ifdef USE_FLONUMS
+        if (sexp_flonump(res))
+          sexp_flonum_value(res) = -1 * sexp_flonum_value(res);
+        else
+#endif
+          res = sexp_fx_mul(res, -1);
+      }
     } else {
       sexp_push_char(c2, in);
       str = sexp_read_symbol(in, c1);

sexp.h

@@ -391,6 +391,7 @@ struct sexp_struct {
 #define sexp_write_char(c, p) (putc(c, sexp_port_stream(p)))
 #define sexp_write_string(s, p) (fputs(s, sexp_port_stream(p)))
 #define sexp_printf(p, ...) (fprintf(sexp_port_stream(p), __VA_ARGS__))
+#define sexp_scanf(p, ...) (fscanf(sexp_port_stream(p), __VA_ARGS__))
 #define sexp_flush(p) (fflush(sexp_port_stream(p)))
 
 sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag);
@@ -420,12 +421,13 @@ sexp sexp_read_number(sexp in, int base);
 sexp sexp_read_raw(sexp in);
 sexp sexp_read(sexp in);
 sexp sexp_read_from_string(char *str);
-sexp sexp_make_input_port(FILE* in);
-sexp sexp_make_output_port(FILE* out);
+sexp sexp_make_input_port(FILE* in, char *path);
+sexp sexp_make_output_port(FILE* out, char *path);
 sexp sexp_make_input_string_port(sexp str);
 sexp sexp_make_output_string_port();
 sexp sexp_get_output_string(sexp port);
 sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, sexp file, sexp line);
+sexp sexp_user_exception (char *message, sexp obj);
 sexp sexp_type_exception (char *message, sexp obj);
 sexp sexp_range_exception (sexp obj, sexp start, sexp end);
 sexp sexp_print_exception(sexp exn, sexp out);

tests/r5rs-tests.scm

@@ -0,0 +1,372 @@
+
+(define *tests-passed* 0)
+(define *tests-failed* 0)
+
+(define-syntax test
+  (syntax-rules ()
+    ((test expect expr)
+     (let ((str (call-with-output-string (lambda (out) (display 'expr out))))
+           (res expr))
+       (display str)
+       (write-char #\space)
+       (display (make-string (max 0 (- 72 (string-length str))) #\.))
+       (flush-output)
+       (cond
+        ((equal? res expect)
+         (set! *tests-passed* (+ *tests-passed* 1))
+         (display " [PASS]\n"))
+        (else
+         (set! *tests-failed* (+ *tests-failed* 1))
+         (display " [FAIL]\n")
+         (display "    expected ") (write expect)
+         (display " but got ") (write res) (newline)))))))
+
+(define (test-report)
+  (write *tests-passed*)
+  (display " out of ")
+  (write (+ *tests-passed* *tests-failed*))
+  (display " passed (")
+  (write (* (/ *tests-passed* (+ *tests-passed* *tests-failed*)) 100))
+  (display "%)")
+  (newline))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test 8 ((lambda (x) (+ x x)) 4))
+
+(test '(3 4 5 6) ((lambda x x) 3 4 5 6))
+
+(test '(5 6) ((lambda (x y . z) z) 3 4 5 6))
+
+(test 'yes (if (> 3 2) 'yes 'no))
+
+(test 'no (if (> 2 3) 'yes 'no))
+
+(test 1 (if (> 3 2) (- 3 2) (+ 3 2)))
+
+(test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less)))
+
+(test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal)))
+
+(test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite)))
+
+(test 'consonant
+    (case (car '(c d))
+      ((a e i o u) 'vowel)
+      ((w y) 'semivowel)
+      (else 'consonant)))
+
+(test #t (and (= 2 2) (> 2 1)))
+
+(test #f (and (= 2 2) (< 2 1)))
+
+(test '(f g) (and 1 2 'c '(f g)))
+
+(test #t (and))
+
+(test #t (or (= 2 2) (> 2 1)))
+
+(test #t (or (= 2 2) (< 2 1)))
+
+(test '(b c) (or (memq 'b '(a b c)) (/ 3 0)))
+
+(test 6 (let ((x 2) (y 3)) (* x y)))
+
+(test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+
+(test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+
+(test '#(0 1 2 3 4)
+ (do ((vec (make-vector 5))
+      (i 0 (+ i 1)))
+     ((= i 5) vec)
+   (vector-set! vec i i)))
+
+(test 25
+    (let ((x '(1 3 5 7 9)))
+      (do ((x x (cdr x))
+           (sum 0 (+ sum (car x))))
+          ((null? x)
+           sum))))
+
+(test '((6 1 3) (-5 -2))
+    (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '()))
+      (cond
+       ((null? numbers)
+        (list nonneg neg))
+       ((>= (car numbers) 0)
+        (loop (cdr numbers) (cons (car numbers) nonneg) neg))
+       ((< (car numbers) 0)
+        (loop (cdr numbers) nonneg (cons (car numbers) neg))))))
+
+(test '(list 3 4) `(list ,(+ 1 2) 4))
+
+(test '(list a 'a) (let ((name 'a)) `(list ,name ',name)))
+
+(test '(a 3 4 5 6 b)
+    `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+
+(test '(10 5 2 4 3 8)
+    `(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))
+
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+    `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+
+(test '(a `(b ,x ,'y d) e)
+    (let ((name1 'x)
+          (name2 'y))
+      `(a `(b ,,name1 ,',name2 d) e)))
+
+(test '(list 3 4)
+ (quasiquote (list (unquote (+ 1 2)) 4)))
+
+(test #t (eqv? 'a 'a))
+
+(test #f (eqv? 'a 'b))
+
+(test #t (eqv? '() '()))
+
+(test #f (eqv? (cons 1 2) (cons 1 2)))
+
+(test #f (eqv? (lambda () 1) (lambda () 2)))
+
+(test #t (let ((p (lambda (x) x))) (eqv? p p)))
+
+(test #t (eq? 'a 'a))
+
+(test #f (eq? (list 'a) (list 'a)))
+
+(test #t (eq? '() '()))
+
+(test #t (eq? car car))
+
+(test #t (let ((x '(a))) (eq? x x)))
+
+(test #t (let ((p (lambda (x) x))) (eq? p p)))
+
+(test #t (equal? 'a 'a))
+
+(test #t (equal? '(a) '(a)))
+
+(test #t (equal? '(a (b) c) '(a (b) c)))
+
+(test #t (equal? "abc" "abc"))
+
+(test #t (equal? 2 2))
+
+(test #t (equal? (make-vector 5 'a) (make-vector 5 'a)))
+
+(test 4 (max 3 4))
+
+(test 4 (max 3.9 4))
+
+(test 7 (+ 3 4))
+
+(test 3 (+ 3))
+
+(test 0 (+))
+
+(test 4 (* 4))
+
+(test 1 (*))
+
+(test -1 (- 3 4))
+
+(test -6 (- 3 4 5))
+
+(test -3 (- 3))
+
+(test 7 (abs -7))
+
+(test 1 (modulo 13 4))
+
+(test 1 (remainder 13 4))
+
+(test 3 (modulo -13 4))
+
+(test -1 (remainder -13 4))
+
+(test -3 (modulo 13 -4))
+
+(test 1 (remainder 13 -4))
+
+(test -1 (modulo -13 -4))
+
+(test -1 (remainder -13 -4))
+
+(test 4 (gcd 32 -36))
+
+(test 288 (lcm 32 -36))
+
+(test -5 (floor -4.3))
+
+(test -4 (ceiling -4.3))
+
+(test -4 (truncate -4.3))
+
+(test -4 (round -4.3))
+
+(test 3 (floor 3.5))
+
+(test 4 (ceiling 3.5))
+
+(test 3 (truncate 3.5))
+
+(test 4 (round 3.5))
+
+(test 100 (string->number "100"))
+
+(test 256 (string->number "100" 16))
+
+(test 100 (string->number "1e2"))
+
+(test #f (not 3))
+
+(test #f (not (list 3)))
+
+(test #f (not '()))
+
+(test #f (not (list)))
+
+(test #f (not '()))
+
+(test #f (boolean? 0))
+
+(test #f (boolean? '()))
+
+(test #t (pair? '(a . b)))
+
+(test #t (pair? '(a b c)))
+
+(test '(a) (cons 'a '()))
+
+(test '((a) b c d) (cons '(a) '(b c d)))
+
+(test '("a" b c) (cons "a" '(b c)))
+
+(test '(a . 3) (cons 'a 3))
+
+(test '((a b) . c) (cons '(a b) 'c))
+
+(test 'a (car '(a b c)))
+
+(test '(a) (car '((a) b c d)))
+
+(test 1 (car '(1 . 2)))
+
+(test '(b c d) (cdr '((a) b c d)))
+
+(test 2 (cdr '(1 . 2)))
+
+(test #t (list? '(a b c)))
+
+(test #t (list? '()))
+
+(test #f (list? '(a . b)))
+
+(test #f
+    (let ((x (list 'a)))
+      (set-cdr! x x)
+      (list? x)))
+
+(test '(a 7 c) (list 'a (+ 3 4) 'c))
+
+(test '() (list))
+
+(test 3 (length '(a b c)))
+
+(test 3 (length '(a (b) (c d e))))
+
+(test 0 (length '()))
+
+(test '(x y) (append '(x) '(y)))
+
+(test '(a b c d) (append '(a) '(b c d)))
+
+(test '(a (b) (c)) (append '(a (b)) '((c))))
+
+(test '(a b c . d) (append '(a b) '(c . d)))
+
+(test 'a (append '() 'a))
+
+(test '(c b a) (reverse '(a b c)))
+
+(test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+
+(test 'c (list-ref '(a b c d) 2))
+
+(test '(a b c) (memq 'a '(a b c)))
+
+(test '(b c) (memq 'b '(a b c)))
+
+(test #f (memq 'a '(b c d)))
+
+(test #f (memq (list 'a) '(b (a) c)))
+
+(test '((a) c) (member (list 'a) '(b (a) c)))
+
+(test '(101 102) (memv 101 '(100 101 102)))
+
+(test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+
+(test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+
+(test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+
+(test #t (symbol? 'foo))
+
+(test #t (symbol? (car '(a b))))
+
+(test #f (symbol? "bar"))
+
+(test #t (symbol? 'nil))
+
+(test #f (symbol? '()))
+
+(test "flying-fish" (symbol->string 'flying-fish))
+
+(test "Martin" (symbol->string 'Martin))
+
+(test "Malvina" (symbol->string (string->symbol "Malvina")))
+
+(test '#(0 ("Sue" "Sue") "Anna")
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+   (vector-set! vec 1 '("Sue" "Sue"))
+   vec))
+
+(test '(dah dah didah) (vector->list '#(dah dah didah)))
+
+(test '#(dididit dah) (list->vector '(dididit dah)))
+
+(test #t (procedure? car))
+
+(test #f (procedure? 'car))
+
+(test #t (procedure? (lambda (x) (* x x))))
+
+(test #f (procedure? '(lambda (x) (* x x))))
+
+(test #t (call-with-current-continuation procedure?))
+
+(test 7 (apply + (list 3 4)))
+
+(test '(b e h) (map cadr '((a b) (d e) (g h))))
+
+(test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5)))
+
+(test '(5 7 9) (map + '(1 2 3) '(4 5 6)))
+
+(test '#(0 1 4 9 16)
+    (let ((v (make-vector 5)))
+      (for-each
+       (lambda (i) (vector-set! v i (* i i)))
+       '(0 1 2 3 4))
+      v))
+
+(test 3 (force (delay (+ 1 2))))
+
+(test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-report)