diff --git a/Makefile b/Makefile index b3bc5e7b..c40baa06 100644 --- a/Makefile +++ b/Makefile @@ -13,7 +13,7 @@ GC_OBJ=./gc/gc.a sexp.o: sexp.c sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< -eval.o: eval.c debug.c eval.h sexp.h config.h defaults.h Makefile +eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile gcc -c $(CFLAGS) -o $@ $< # main.o: main.c eval.h sexp.h config.h Makefile diff --git a/debug.c b/debug.c index fee2f48b..052d2412 100644 --- a/debug.c +++ b/debug.c @@ -4,14 +4,14 @@ static const char* reverse_opcode_names[] = {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL_CALL", "CALL", - "FCALL0", "FCALL1", "FCALL2", "FCALL3", "EVAL", "JUMP_UNLESS", "JUMP", - "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", + "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP_UNLESS", + "JUMP", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET", "CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET", - "MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP", - "SYMBOLP", "CHARP", "EOFP", "TYPEP", - "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV", - "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", "DISPLAY", "WRITE", - "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", + "MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP", "SYMBOLP", "CHARP", + "EOFP", "TYPEP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", + "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", + "DISPLAY", "WRITE", "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", + "READ_CHAR", "RET", "DONE", }; void disasm (sexp bc, sexp out) { diff --git a/eval.c b/eval.c index 4f636ddb..1e3a8654 100644 --- a/eval.c +++ b/eval.c @@ -88,7 +88,7 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) { static void env_define(sexp e, sexp key, sexp value) { sexp cell = sexp_assq(key, sexp_env_bindings(e)); if (cell != SEXP_FALSE) - sexp_cdar(cell) = value; + sexp_cdr(cell) = value; else sexp_push(sexp_env_bindings(e), sexp_cons(key, value)); } @@ -278,6 +278,25 @@ static sexp sexp_identifierp (sexp x) { return sexp_make_boolean(sexp_idp(x)); } +static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) { + sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE; + if (sexp_synclop(id1)) { + e1 = sexp_synclo_env(id1); + id1 = sexp_synclo_expr(id1); + } + if (sexp_synclop(id2)) { + e2 = sexp_synclo_env(id2); + id2 = sexp_synclo_expr(id2); + } + cell = env_cell(e1, id1); + if (sexp_lambdap(sexp_cdr(cell))) + lam1 = sexp_cdr(cell); + cell = env_cell(e2, id2); + if (sexp_lambdap(sexp_cdr(cell))) + lam2 = sexp_cdr(cell); + return sexp_make_boolean((id1 == id2) && (lam1 == lam2)); +} + /************************* the compiler ***************************/ static sexp sexp_compile_error(char *message, sexp irritants) { @@ -298,10 +317,14 @@ static sexp analyze (sexp x, sexp context) { sexp op, cell, res; loop: if (sexp_pairp(x)) { - if (! sexp_listp(x)) { + if (sexp_listp(x) == SEXP_FALSE) { res = sexp_compile_error("dotted list in source", sexp_list1(x)); } else if (sexp_idp(sexp_car(x))) { - cell = env_cell(sexp_context_env(context), sexp_car(x)); + if (sexp_synclop(sexp_car(x))) + cell = env_cell(sexp_synclo_env(sexp_car(x)), + sexp_synclo_expr(sexp_car(x))); + else + cell = env_cell(sexp_context_env(context), sexp_car(x)); if (! cell) return analyze_app(x, context); op = sexp_cdr(cell); if (sexp_corep(op)) { @@ -365,7 +388,7 @@ static sexp analyze_lambda (sexp x, sexp context) { if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x)))) return sexp_compile_error("bad lambda syntax", sexp_list1(x)); for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls)) - if (! sexp_symbolp(sexp_car(ls))) + if (! sexp_idp(sexp_car(ls))) return sexp_compile_error("non-symbol parameter", sexp_list1(x)); else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE) return sexp_compile_error("duplicate parameter", sexp_list1(x)); @@ -757,7 +780,8 @@ static void generate_lambda (sexp lambda, sexp context) { } } generate(sexp_lambda_body(lambda), ctx); - flags = sexp_make_integer(sexp_listp(sexp_lambda_params(lambda)) ? 0 : 1); + flags = sexp_make_integer((sexp_listp(sexp_lambda_params(lambda))==SEXP_FALSE) + ? 1 : 0); len = sexp_length(sexp_lambda_params(lambda)); bc = finalize_bytecode(ctx); if (sexp_nullp(fv)) { @@ -1404,91 +1428,9 @@ static struct sexp_struct core_forms[] = { {.tag=SEXP_CORE, .value={.core={CORE_LETREC_SYNTAX, "letrec-syntax"}}}, }; -static struct sexp_struct opcodes[] = { -#define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}} -#define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL) -#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) -#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) -#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) -#define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f) -#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_NOOP, 0, 2, t, 0, 0, n, a, NULL) -_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL), -_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL), -_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL), -_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL), -_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL), -_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), -_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), -_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL), -_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL), -_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), -_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), -_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL), -_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL), -_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), -_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), -_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), -_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), -_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), -_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), -_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), -_FN1(0, "identifier?", sexp_identifierp), -_FN1(SEXP_PAIR, "length", sexp_length), -_FN1(SEXP_PAIR, "reverse", sexp_reverse), -_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), -_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), -_FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), -_FN1(SEXP_IPORT, "close-input-port", sexp_close_port), -_FN1(SEXP_OPORT, "close-output-port", sexp_close_port), -_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env), -_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env), -_FN2(0, SEXP_ENV, "%load", sexp_load), -#if USE_MATH -_FN1(0, "exp", sexp_exp), -_FN1(0, "log", sexp_log), -_FN1(0, "sin", sexp_sin), -_FN1(0, "cos", sexp_cos), -_FN1(0, "tan", sexp_tan), -_FN1(0, "asin", sexp_asin), -_FN1(0, "acos", sexp_acos), -_FN1(0, "atan", sexp_atan), -_FN1(0, "sqrt", sexp_sqrt), -#endif -_FN2(0, SEXP_PAIR, "memq", sexp_memq), -_FN2(0, SEXP_PAIR, "assq", sexp_assq), -_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), -_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), -_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), -_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), -_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), -_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), -}; +#include "opcodes.c" -static sexp standard_env_syms_interned_p = 0; +static int standard_env_syms_interned_p = 0; static sexp sexp_make_null_env (sexp version) { sexp_uint_t i; @@ -1502,16 +1444,17 @@ static sexp sexp_make_null_env (sexp version) { static sexp sexp_make_standard_env (sexp version) { sexp_uint_t i; - sexp e = sexp_make_null_env(version), cell, sym; + sexp e = sexp_make_null_env(version), op, cell, sym; for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) { + op = &opcodes[i]; if ((! standard_env_syms_interned_p) - && sexp_opcode_opt_param_p(&opcodes[i]) - && sexp_opcode_data(&opcodes[i])) { - sym = sexp_intern((char*)sexp_opcode_data(&opcodes[i])); + && sexp_opcode_opt_param_p(op) + && sexp_opcode_data(op)) { + sym = sexp_intern((char*)sexp_opcode_data(op)); cell = env_cell_create(e, sym, SEXP_UNDEF); - sexp_opcode_data(&opcodes[i]) = cell; + sexp_opcode_data(op) = cell; } - env_define(e, sexp_intern(sexp_opcode_name(&opcodes[i])), &opcodes[i]); + 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)); @@ -1523,7 +1466,6 @@ static sexp sexp_make_standard_env (sexp version) { /************************** eval interface ****************************/ -/* args ... n ret-ip ret-cp ret-fp */ sexp apply(sexp proc, sexp args, sexp context) { sexp *stack = sexp_context_stack(context), ls; sexp_sint_t top = sexp_context_top(context), offset; @@ -1558,9 +1500,9 @@ sexp compile (sexp x, sexp context) { sexp eval_in_context (sexp obj, sexp context) { sexp thunk = compile(obj, context); if (sexp_exceptionp(thunk)) { - sexp_print_exception(obj, env_global_ref(sexp_context_env(context), - the_cur_err_symbol, - SEXP_FALSE)); + sexp_print_exception(thunk, env_global_ref(sexp_context_env(context), + the_cur_err_symbol, + SEXP_FALSE)); return SEXP_UNDEF; } return apply(thunk, SEXP_NULL, context); diff --git a/eval.h b/eval.h index 1062ed9c..18a3d6dc 100644 --- a/eval.h +++ b/eval.h @@ -68,6 +68,7 @@ enum opcode_names { OP_FCALL1, OP_FCALL2, OP_FCALL3, + OP_FCALL4, OP_EVAL, OP_JUMP_UNLESS, OP_JUMP, diff --git a/init.scm b/init.scm index 1e6587de..b80658b1 100644 --- a/init.scm +++ b/init.scm @@ -1,22 +1,21 @@ -;; let* cond case delay and do +;; cond case delay do ;; quasiquote let-syntax -;; letrec-syntax syntax-rules eqv? equal? not boolean? number? +;; letrec-syntax syntax-rules not boolean? number? ;; complex? real? rational? integer? exact? inexact? ;; positive? negative? odd? even? max min quotient remainder ;; modulo numerator denominator floor ceiling truncate round -;; rationalize sqrt expt +;; rationalize expt ;; make-rectangular make-polar real-part imag-part magnitude angle ;; exact->inexact inexact->exact number->string string->number -;; list? list-tail list-ref memv -;; member assv assoc symbol->string string->symbol +;; symbol->string string->symbol ;; char-alphabetic? char-numeric? char-whitespace? ;; char-upper-case? char-lower-case? char->integer integer->char ;; char-upcase char-downcase make-string string string-length ;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? ;; substring string-append string->list list->string string-copy -;; string-fill! make-vector vector vector-length +;; string-fill! vector vector-length ;; vector->list list->vector vector-fill! procedure? apply ;; map for-each force call-with-current-continuation values ;; call-with-values dynamic-wind scheme-report-environment @@ -24,8 +23,7 @@ ;; current-input-port current-output-port ;; with-input-from-file with-output-to-file open-input-file ;; open-output-file close-input-port close-output-port -;; peek-char eof-object? char-ready? -;; eval +;; peek-char char-ready? ;; provide c[ad]{2,4}r @@ -34,14 +32,14 @@ (define (cdar x) (cdr (car x))) (define (cddr x) (cdr (cdr x))) -;; (define (caaar x) (car (car (car x)))) -;; (define (caadr x) (car (car (cdr x)))) -;; (define (cadar x) (car (cdr (car x)))) -;; (define (caddr x) (car (cdr (cdr x)))) -;; (define (cdaar x) (cdr (car (car x)))) -;; (define (cdadr x) (cdr (car (cdr x)))) -;; (define (cddar x) (cdr (cdr (car x)))) -;; (define (cdddr x) (cdr (cdr (cdr x)))) +(define (caaar x) (car (car (car x)))) +(define (caadr x) (car (car (cdr x)))) +(define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) +(define (cddar x) (cdr (cdr (car x)))) +(define (cdddr x) (cdr (cdr (cdr x)))) ;; (define (caaaar x) (car (car (car (car x))))) ;; (define (caaadr x) (car (car (car (cdr x))))) @@ -62,6 +60,33 @@ (define (list . args) args) +(define (list-tail ls k) + (if (zero? k) + ls + (list-tail (cdr ls) (- k 1)))) + +(define (list-ref ls k) (car (list-tail ls k))) + +(define eqv? equal?) + +(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)) + ls + (member obj (cdr ls))))) + +(define assv assoc) + (define (append-reverse a b) (if (pair? a) (append-reverse (cdr a) (cons (car a) b)) @@ -114,30 +139,74 @@ (lambda (expr use-env mac-env) (make-syntactic-closure use-env '() (f expr mac-env))))) -(define-syntax let - (lambda (expr use-env mac-env) - (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) - (map cadr (cadr expr))))) +(define er-macro-transformer + (lambda (f) + (lambda (expr use-env mac-env) + ((lambda (rename compare) (f expr rename compare)) + ((lambda (renames) + (lambda (identifier) + ((lambda (cell) + (if cell + (cdr cell) + ((lambda (name) + (set! renames (cons (cons identifier name) renames)) + name) + (make-syntactic-closure mac-env '() identifier)))) + (assq identifier renames)))) + '()) + (lambda (x y) (identifier=? use-env x use-env y)))))) (define-syntax letrec - (lambda (expr use-env mac-env) - (list - (cons 'lambda - (cons '() - (append (map (lambda (x) (cons 'define x)) (cadr expr)) - (cddr expr))))))) + (er-macro-transformer + (lambda (expr rename compare) + (list + (cons (rename 'lambda) + (cons '() + (append (map (lambda (x) (cons (rename 'define) x)) (cadr expr)) + (cddr expr)))))))) + +(define-syntax let + (er-macro-transformer + (lambda (expr rename compare) + (if (identifier? (cadr expr)) + (list (rename 'letrec) + (list (list (cadr expr) + (cons (rename 'lambda) + (cons (map car (caddr expr)) + (cdddr expr))))) + (cons (cadr expr) (map cadr (caddr expr)))) + (cons (cons (rename 'lambda) (cons (map car (cadr expr)) (cddr expr))) + (map cadr (cadr expr))))))) + +(define-syntax let* + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cadr expr)) + (cons (rename 'begin) (cddr expr)) + (list (rename 'let) + (list (caadr expr)) + (cons (rename 'let*) (cons (cdadr expr) (cddr expr)))))))) (define-syntax or - (sc-macro-transformer - (lambda (expr use-env) + (er-macro-transformer + (lambda (expr rename compare) (if (null? (cdr expr)) #f + (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) + (list (rename 'if) (rename 'tmp) + (rename 'tmp) + (cons (rename 'or) (cddr expr)))))))) + +(define-syntax and + (er-macro-transformer + (lambda (expr rename compare) + (if (null? (cdr expr)) + #t (if (null? (cddr expr)) - (make-syntactic-closure use-env '() (cadr expr)) - (list 'let (list (list 'tmp (make-syntactic-closure use-env '() (cadr expr)))) - (list 'if 'tmp - 'tmp - (make-syntactic-closure use-env '() (cons 'or (cddr expr)))))))))) + (cadr expr) + (list (rename 'if) (cadr expr) + (cons (rename 'and) (cddr expr)) + #f)))))) ;; char utils diff --git a/opcodes.c b/opcodes.c new file mode 100644 index 00000000..faac6fb3 --- /dev/null +++ b/opcodes.c @@ -0,0 +1,90 @@ + +#define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}} +#define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL) +#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f) +#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f) +#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f) +#define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f) +#define _FN4(t, u, s, f) _FN(OP_FCALL4, 4, t, u, s, f) +#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_NOOP, 0, 2, t, 0, 0, n, a, NULL) + +static struct sexp_struct opcodes[] = { +_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL), +_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL), +_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL), +_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL), +_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL), +_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), +_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), +_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL), +_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL), +_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL), +_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL), +_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL), +_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL), +_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL), +_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL), +_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL), +_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), +_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), +_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), +_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), +_FN2(0, 0, "equal?", sexp_equalp), +_FN1(0, "list?", sexp_listp), +_FN1(0, "identifier?", sexp_identifierp), +_FN4(0, SEXP_ENV, "identifier=?", sexp_identifier_eq), +_FN1(SEXP_PAIR, "length", sexp_length), +_FN1(SEXP_PAIR, "reverse", sexp_reverse), +_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector), +_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file), +_FN1(SEXP_STRING, "open-output-file", sexp_open_output_file), +_FN1(SEXP_IPORT, "close-input-port", sexp_close_port), +_FN1(SEXP_OPORT, "close-output-port", sexp_close_port), +_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env), +_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env), +_FN2(0, SEXP_ENV, "%load", sexp_load), +#if USE_MATH +_FN1(0, "exp", sexp_exp), +_FN1(0, "log", sexp_log), +_FN1(0, "sin", sexp_sin), +_FN1(0, "cos", sexp_cos), +_FN1(0, "tan", sexp_tan), +_FN1(0, "asin", sexp_asin), +_FN1(0, "acos", sexp_acos), +_FN1(0, "atan", sexp_atan), +_FN1(0, "sqrt", sexp_sqrt), +#endif +_FN2(0, SEXP_PAIR, "memq", sexp_memq), +_FN2(0, SEXP_PAIR, "assq", sexp_assq), +_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo), +_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT), +_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT), +_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT), +_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE), +_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV), +}; + diff --git a/sexp.c b/sexp.c index 5c5efb76..65118d45 100644 --- a/sexp.c +++ b/sexp.c @@ -91,8 +91,8 @@ void sexp_deep_free (sexp obj) { /***************************** exceptions *****************************/ -sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, - sexp file, sexp line) { +sexp sexp_make_exception (sexp kind, sexp message, sexp irritants, + sexp file, sexp line) { sexp exn = sexp_alloc_type(exception, SEXP_EXCEPTION); sexp_exception_kind(exn) = kind; sexp_exception_message(exn) = message; @@ -102,11 +102,11 @@ sexp sexp_make_exception(sexp kind, sexp message, sexp irritants, return exn; } -sexp sexp_print_exception(sexp exn, sexp out) { +sexp sexp_print_exception (sexp exn, sexp out) { sexp ls; sexp_write_string("ERROR", out); if (sexp_integerp(sexp_exception_line(exn)) - && sexp_exception_line(exn) > sexp_make_integer(0)) { + && (sexp_exception_line(exn) > sexp_make_integer(0))) { sexp_write_string(" on line ", out); sexp_write(sexp_exception_line(exn), out); } @@ -116,7 +116,8 @@ sexp sexp_print_exception(sexp exn, sexp out) { } sexp_write_string(": ", out); sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out); - if (sexp_pairp(sexp_exception_irritants(exn))) { + if (sexp_exception_irritants(exn) + && sexp_pairp(sexp_exception_irritants(exn))) { if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) { sexp_write_string(": ", out); sexp_write(sexp_car(sexp_exception_irritants(exn)), out); @@ -136,7 +137,7 @@ sexp sexp_print_exception(sexp exn, sexp out) { return SEXP_UNDEF; } -static sexp sexp_read_error(char *message, sexp irritants, sexp port) { +static sexp sexp_read_error (char *message, sexp irritants, sexp port) { sexp name = (sexp_port_name(port) ? sexp_make_string(sexp_port_name(port)) : SEXP_FALSE); return sexp_make_exception(the_read_error_symbol, @@ -148,17 +149,17 @@ static sexp sexp_read_error(char *message, sexp irritants, sexp port) { /*************************** list utilities ***************************/ -sexp sexp_cons(sexp head, sexp tail) { +sexp sexp_cons (sexp head, sexp tail) { sexp pair = sexp_alloc_type(pair, SEXP_PAIR); sexp_car(pair) = head; sexp_cdr(pair) = tail; return pair; } -int sexp_listp (sexp obj) { +sexp sexp_listp (sexp obj) { while (sexp_pairp(obj)) obj = sexp_cdr(obj); - return (obj == SEXP_NULL); + return sexp_make_boolean(obj == SEXP_NULL); } sexp sexp_memq (sexp x, sexp ls) { @@ -172,21 +173,21 @@ sexp sexp_memq (sexp x, sexp ls) { sexp sexp_assq (sexp x, sexp ls) { while (sexp_pairp(ls)) - if (x == sexp_caar(ls)) - return ls; + if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls))) + return sexp_car(ls); else ls = sexp_cdr(ls); return SEXP_FALSE; } -sexp sexp_reverse(sexp ls) { +sexp sexp_reverse (sexp ls) { sexp res = SEXP_NULL; for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) res = sexp_cons(sexp_car(ls), res); return res; } -sexp sexp_nreverse(sexp ls) { +sexp sexp_nreverse (sexp ls) { sexp a, b, tmp; if (ls == SEXP_NULL) { return ls; @@ -204,19 +205,62 @@ sexp sexp_nreverse(sexp ls) { } } -sexp sexp_append(sexp a, sexp b) { +sexp sexp_append (sexp a, sexp b) { for (a=sexp_reverse(a); sexp_pairp(a); a=sexp_cdr(a)) b = sexp_cons(sexp_car(a), b); return b; } -sexp sexp_length(sexp ls) { +sexp sexp_length (sexp ls) { sexp_uint_t res=0; for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls)) ; return sexp_make_integer(res); } +sexp sexp_equalp (sexp a, sexp b) { + sexp_uint_t len; + sexp *v1, *v2; + loop: + if (a == b) + return SEXP_TRUE; + if (! sexp_pointerp(a)) + return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b) + && (sexp_unbox_integer(a) + == sexp_flonum_value(b))); + else if (! sexp_pointerp(b)) + return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a) + && (sexp_unbox_integer(b) + == sexp_flonum_value(a))); + if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) + return SEXP_FALSE; + switch (sexp_pointer_tag(a)) { + case SEXP_PAIR: + if (sexp_equalp(sexp_car(a), sexp_car(b)) == SEXP_FALSE) + return SEXP_FALSE; + a = sexp_cdr(a); + b = sexp_cdr(b); + goto loop; + case SEXP_VECTOR: + len = sexp_vector_length(a); + if (len != sexp_vector_length(b)) + return SEXP_FALSE; + v1 = sexp_vector_data(a); + v2 = sexp_vector_data(b); + for (len--; len >= 0; len--) + if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE) + return SEXP_FALSE; + return SEXP_TRUE; + case SEXP_STRING: + return sexp_make_boolean((sexp_string_length(a) == sexp_string_length(b)) + && (! strncmp(sexp_string_data(a), + sexp_string_data(b), + sexp_string_length(a)))); + default: + return SEXP_FALSE; + } +} + /********************* strings, symbols, vectors **********************/ sexp sexp_make_flonum(double f) { @@ -805,7 +849,7 @@ sexp sexp_read_raw (sexp in) { case '(': sexp_push_char(c1, in); res = sexp_read(in); - if (! sexp_listp(res)) { + if (sexp_listp(res) == SEXP_FALSE) { if (! sexp_exceptionp(res)) { sexp_deep_free(res); res = sexp_read_error("dotted list not allowed in vector syntax", diff --git a/sexp.h b/sexp.h index 81f26e7d..a8f13150 100644 --- a/sexp.h +++ b/sexp.h @@ -153,7 +153,7 @@ struct sexp_struct { } lit; /* compiler state */ struct { - sexp bc, lambda, offsets, *stack, env; + sexp bc, lambda, *stack, env; sexp_uint_t pos, top, depth, tailp; } context; } value; @@ -326,7 +326,6 @@ struct sexp_struct { #define sexp_context_pos(x) ((x)->value.context.pos) #define sexp_context_top(x) ((x)->value.context.top) #define sexp_context_lambda(x) ((x)->value.context.lambda) -#define sexp_context_offsets(x) ((x)->value.context.offsets) #define sexp_context_tailp(x) ((x)->value.context.tailp) /****************************** arithmetic ****************************/ @@ -400,7 +399,8 @@ void sexp_printf(sexp port, sexp fmt, ...); sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag); sexp sexp_cons(sexp head, sexp tail); -int sexp_listp(sexp obj); +sexp sexp_equalp (sexp a, sexp b); +sexp sexp_listp(sexp obj); sexp sexp_reverse(sexp ls); sexp sexp_nreverse(sexp ls); sexp sexp_append(sexp a, sexp b);