diff --git a/Makefile b/Makefile index eac74288..10333b68 100644 --- a/Makefile +++ b/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}"; \ diff --git a/config.h b/config.h index cf480383..81f1444c 100644 --- a/config.h +++ b/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 */ diff --git a/defaults.h b/defaults.h index c463c75e..f2399aff 100644 --- a/defaults.h +++ b/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 diff --git a/eval.c b/eval.c index b6541f8b..f41a1a13 100644 --- a/eval.c +++ b/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; } diff --git a/init.scm b/init.scm index 6773cb03..17f3ad5d 100644 --- a/init.scm +++ b/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) diff --git a/main.c b/main.c index 1b14ee97..f666c07a 100644 --- a/main.c +++ b/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); diff --git a/opcodes.c b/opcodes.c index af18e911..8305cf3f 100644 --- a/opcodes.c +++ b/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), diff --git a/sexp.c b/sexp.c index 531f1b32..9708f1fe 100644 --- a/sexp.c +++ b/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); diff --git a/sexp.h b/sexp.h index 9784795f..c7cdff30 100644 --- a/sexp.h +++ b/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); diff --git a/tests/test00-fact-3.res b/tests/basic/test00-fact-3.res similarity index 100% rename from tests/test00-fact-3.res rename to tests/basic/test00-fact-3.res diff --git a/tests/test00-fact-3.scm b/tests/basic/test00-fact-3.scm similarity index 100% rename from tests/test00-fact-3.scm rename to tests/basic/test00-fact-3.scm diff --git a/tests/test01-apply.res b/tests/basic/test01-apply.res similarity index 100% rename from tests/test01-apply.res rename to tests/basic/test01-apply.res diff --git a/tests/test01-apply.scm b/tests/basic/test01-apply.scm similarity index 100% rename from tests/test01-apply.scm rename to tests/basic/test01-apply.scm diff --git a/tests/test02-closure.res b/tests/basic/test02-closure.res similarity index 100% rename from tests/test02-closure.res rename to tests/basic/test02-closure.res diff --git a/tests/test02-closure.scm b/tests/basic/test02-closure.scm similarity index 100% rename from tests/test02-closure.scm rename to tests/basic/test02-closure.scm diff --git a/tests/test03-nested-closure.res b/tests/basic/test03-nested-closure.res similarity index 100% rename from tests/test03-nested-closure.res rename to tests/basic/test03-nested-closure.res diff --git a/tests/test03-nested-closure.scm b/tests/basic/test03-nested-closure.scm similarity index 100% rename from tests/test03-nested-closure.scm rename to tests/basic/test03-nested-closure.scm diff --git a/tests/test04-nested-let.res b/tests/basic/test04-nested-let.res similarity index 100% rename from tests/test04-nested-let.res rename to tests/basic/test04-nested-let.res diff --git a/tests/test04-nested-let.scm b/tests/basic/test04-nested-let.scm similarity index 100% rename from tests/test04-nested-let.scm rename to tests/basic/test04-nested-let.scm diff --git a/tests/test05-internal-define.res b/tests/basic/test05-internal-define.res similarity index 100% rename from tests/test05-internal-define.res rename to tests/basic/test05-internal-define.res diff --git a/tests/test05-internal-define.scm b/tests/basic/test05-internal-define.scm similarity index 100% rename from tests/test05-internal-define.scm rename to tests/basic/test05-internal-define.scm diff --git a/tests/test06-letrec.res b/tests/basic/test06-letrec.res similarity index 100% rename from tests/test06-letrec.res rename to tests/basic/test06-letrec.res diff --git a/tests/test06-letrec.scm b/tests/basic/test06-letrec.scm similarity index 100% rename from tests/test06-letrec.scm rename to tests/basic/test06-letrec.scm diff --git a/tests/test07-mutation.res b/tests/basic/test07-mutation.res similarity index 100% rename from tests/test07-mutation.res rename to tests/basic/test07-mutation.res diff --git a/tests/test07-mutation.scm b/tests/basic/test07-mutation.scm similarity index 100% rename from tests/test07-mutation.scm rename to tests/basic/test07-mutation.scm diff --git a/tests/test08-callcc.res b/tests/basic/test08-callcc.res similarity index 100% rename from tests/test08-callcc.res rename to tests/basic/test08-callcc.res diff --git a/tests/test08-callcc.scm b/tests/basic/test08-callcc.scm similarity index 100% rename from tests/test08-callcc.scm rename to tests/basic/test08-callcc.scm diff --git a/tests/test09-hygiene.res b/tests/basic/test09-hygiene.res similarity index 100% rename from tests/test09-hygiene.res rename to tests/basic/test09-hygiene.res diff --git a/tests/test09-hygiene.scm b/tests/basic/test09-hygiene.scm similarity index 100% rename from tests/test09-hygiene.scm rename to tests/basic/test09-hygiene.scm diff --git a/tests/r5rs-tests.scm b/tests/r5rs-tests.scm new file mode 100644 index 00000000..96d0dd09 --- /dev/null +++ b/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)