diff --git a/eval.c b/eval.c index 3647b5fb..20947d69 100644 --- a/eval.c +++ b/eval.c @@ -397,7 +397,7 @@ static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), s return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); } -static sexp sexp_strip_synclos (sexp ctx, sexp x) { +static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { sexp res; sexp_gc_var2(kar, kdr); sexp_gc_preserve2(ctx, kar, kdr); @@ -406,8 +406,8 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { x = sexp_synclo_expr(x); goto loop; } else if (sexp_pairp(x)) { - kar = sexp_strip_synclos(ctx, sexp_car(x)); - kdr = sexp_strip_synclos(ctx, sexp_cdr(x)); + kar = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_car(x)); + kdr = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_cdr(x)); res = sexp_cons(ctx, kar, kdr); sexp_immutablep(res) = 1; } else { @@ -641,8 +641,8 @@ static sexp analyze_define (sexp ctx, sexp x) { static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { sexp res = SEXP_VOID, name; - sexp_gc_var3(proc, mac, tmp); - sexp_gc_preserve3(eval_ctx, proc, mac, tmp); + sexp_gc_var2(proc, mac); + sexp_gc_preserve2(eval_ctx, proc, mac); for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) { if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls)) && sexp_nullp(sexp_cddar(ls)))) { @@ -662,7 +662,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) { } } } - sexp_gc_release3(eval_ctx); + sexp_gc_release2(eval_ctx); return res; } @@ -741,7 +741,7 @@ static sexp analyze (sexp ctx, sexp object) { else res = sexp_make_lit(ctx, (sexp_core_code(op) == SEXP_CORE_QUOTE) ? - sexp_strip_synclos(ctx, sexp_cadr(x)) : + sexp_strip_synclos(ctx sexp_api_pass(NULL, 1), sexp_cadr(x)) : sexp_cadr(x)); break; case SEXP_CORE_DEFINE_SYNTAX: @@ -1361,6 +1361,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar #if SEXP_USE_TYPE_DEFS sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE), sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO, @@ -1369,6 +1370,7 @@ sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) { sexp_uint_t type_size; + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type); type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type))); return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR), @@ -1378,6 +1380,7 @@ sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sex } sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) @@ -1389,6 +1392,7 @@ sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp typ } sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) { + if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type)); if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0)) return sexp_type_exception(ctx, self, SEXP_FIXNUM, type); if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0)) diff --git a/include/chibi/eval.h b/include/chibi/eval.h index e1a82378..290243ae 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -93,6 +93,9 @@ enum sexp_opcode_names { SEXP_OP_MAKE, SEXP_OP_SLOT_REF, SEXP_OP_SLOT_SET, + SEXP_OP_ISA, + SEXP_OP_SLOTN_REF, + SEXP_OP_SLOTN_SET, SEXP_OP_CAR, SEXP_OP_CDR, SEXP_OP_SET_CAR, diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 2cb2ebb2..7adb008c 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -472,6 +472,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size); #define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i]) #define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v)) +#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b))) + #if SEXP_USE_IMMEDIATE_FLONUMS union sexp_flonum_conv { float flonum; diff --git a/lib/chibi/match/match.scm b/lib/chibi/match/match.scm index 963b89ff..f4eb173d 100644 --- a/lib/chibi/match/match.scm +++ b/lib/chibi/match/match.scm @@ -161,6 +161,10 @@ (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ())) ((match-two v (p *** . q) g+s sk fk i) (match-syntax-error "invalid use of ***" (p *** . q))) + ((match-two v ($ rec p ...) g+s sk fk i) + (if (is-a? v rec) + (match-record-refs v rec 0 (p ...) g+s sk fk i) + fk)) ((match-two v (p . q) g+s sk fk i) (if (pair? v) (let ((w (car v)) (x (cdr v))) @@ -471,6 +475,15 @@ (match-drop-ids (loop (+ j 1) (cons id id-ls) ...)) fk i))))))) +(define-syntax match-record-refs + (syntax-rules () + ((_ v rec n (p . q) g+s sk fk i) + (let ((w (slot-ref rec v n))) + (match-one w p ((slot-ref rec v n) (slot-set! rec v n)) + (match-record-refs v rec (+ n 1) q g+s sk fk) fk i))) + ((_ v rec n () g+s (sk ...) fk i) + (sk ... i)))) + ;; Extract all identifiers in a pattern. A little more complicated ;; than just looking for symbols, we need to ignore special keywords ;; and non-pattern forms (such as the predicate expression in ? diff --git a/lib/srfi/9.module b/lib/srfi/9.module index 1c9aad91..58368111 100644 --- a/lib/srfi/9.module +++ b/lib/srfi/9.module @@ -13,17 +13,21 @@ (pred (cadddr expr)) (fields (cddddr expr)) (num-fields (length fields)) - (index (register-simple-type name-str num-fields)) (_define (rename 'define)) (_lambda (rename 'lambda)) - (_let (rename 'let))) + (_let (rename 'let)) + (_register (rename 'register-simple-type))) (define (index-of field ls) (let lp ((ls ls) (i 0)) (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1))))) `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,num-fields)) + ;; predicate (,_define ,pred (,(rename 'make-type-predicate) ,(symbol->string (identifier->symbol pred)) - ,index)) + ,name)) + ;; fields ,@(let lp ((ls fields) (i 0) (res '())) (if (null? ls) res @@ -32,7 +36,7 @@ (,(rename 'make-getter) ,(symbol->string (identifier->symbol (cadar ls))) - ,index + ,name ,i)) res))) (lp (cdr ls) @@ -43,17 +47,18 @@ (,(rename 'make-setter) ,(symbol->string (identifier->symbol (caddar ls))) - ,index + ,name ,i)) res) res))))) + ;; constructor (,_define ,make ,(let lp ((ls make-fields) (sets '()) (set-defs '())) (cond ((null? ls) `(,_let ((%make (,(rename 'make-constructor) ,(symbol->string (identifier->symbol make)) - ,index)) + ,name)) ,@set-defs) (,_lambda ,make-fields (,_let ((res (%make))) @@ -79,7 +84,7 @@ (cons (list setter (list (rename 'make-setter) setter-name - index + name (index-of (car ls) fields))) set-defs))))))))))))))))) diff --git a/opcodes.c b/opcodes.c index cf40794f..efc11d50 100644 --- a/opcodes.c +++ b/opcodes.c @@ -36,6 +36,8 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string #endif #endif _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF,3,0, 0, SEXP_FIXNUM, 0,"slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET,4,0, 0, SEXP_FIXNUM, 0,"slot-set!", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL), @@ -58,6 +60,7 @@ _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL), _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, 0, 0, 0, "is-a?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0), _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0), diff --git a/opt/opcode_names.h b/opt/opcode_names.h index 88bc4387..a87aeb1c 100644 --- a/opt/opcode_names.h +++ b/opt/opcode_names.h @@ -10,9 +10,10 @@ static const char* reverse_opcode_names[] = "STRING-REF", "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", - "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR", - "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", - "MUL", "DIV", "QUOTIENT", "REMAINDER", + "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", + "ISA?", "SLOTN-REF", "SLOTN-SET", + "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", + "ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", diff --git a/sexp.c b/sexp.c index 59bfdff8..910e8523 100644 --- a/sexp.c +++ b/sexp.c @@ -183,7 +183,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, sexp_type_size_scale(type) = sexp_unbox_fixnum(sc); sexp_type_name(type) = strdup(sexp_string_data(name)); sexp_type_finalize(type) = f; - res = sexp_make_fixnum(num_types); + res = type; #if SEXP_USE_GLOBAL_TYPES sexp_num_types = num_types + 1; #else @@ -1200,6 +1200,11 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) { sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out); sexp_write_string(ctx, ">", out); break; + case SEXP_SYNCLO: + sexp_write_string(ctx, "#", out); + break; case SEXP_STRING: sexp_write_char(ctx, '"', out); i = sexp_string_length(obj); diff --git a/vm.c b/vm.c index d292aaab..94ef207f 100644 --- a/vm.c +++ b/vm.c @@ -931,6 +931,33 @@ sexp sexp_vm (sexp ctx, sexp proc) { ip += sizeof(sexp)*2; top--; break; + case SEXP_OP_ISA: + _ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2)); + top--; + break; + case SEXP_OP_SLOTN_REF: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + _ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3)); + top-=2; + break; + case SEXP_OP_SLOTN_SET: + if (! sexp_typep(_ARG1)) + sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + else if (! sexp_isa(_ARG2, _ARG1)) + sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2)); + else if (sexp_immutablep(_ARG2)) + sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2)); + else if (! sexp_fixnump(_ARG3)) + sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3)); + sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4); + _ARG4 = SEXP_VOID; + top-=3; + break; case SEXP_OP_CAR: if (! sexp_pairp(_ARG1)) sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));