diff --git a/Makefile b/Makefile index 3840909e..b4e8f221 100644 --- a/Makefile +++ b/Makefile @@ -200,6 +200,9 @@ test-loop: chibi-scheme$(EXE) test-sort: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/sort-tests.scm +test-records: chibi-scheme$(EXE) + LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/record-tests.scm + test-libs: chibi-scheme$(EXE) LD_LIBRARY_PATH=".:$(LD_LIBRARY_PATH)" ./chibi-scheme$(EXE) tests/lib-tests.scm diff --git a/eval.c b/eval.c index c0c7e166..55aba87f 100644 --- a/eval.c +++ b/eval.c @@ -1288,6 +1288,73 @@ sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, se /***************************** opcodes ********************************/ +#if SEXP_USE_TYPE_DEFS + +sexp sexp_type_slot_offset_op (sexp ctx sexp_api_params(self, n), sexp type, sexp slot) { + sexp cpl, slots, *v; + int i, offset=0, len; + sexp_assert_type(ctx, sexp_typep, SEXP_TYPE, type); + cpl = sexp_type_cpl(type); + if (sexp_vectorp(cpl)) { + v = sexp_vector_data(cpl); + len = sexp_vector_length(cpl); + } else { + v = &sexp_type_slots(type); + len = 1; + } + len = sexp_vectorp(cpl) ? sexp_vector_length(cpl) : 1; + for (i=0; i= sexp_context_num_types(ctx))) + return SEXP_ZERO; + t = sexp_object_type(ctx, x); + return sexp_make_fixnum(sexp_type_size_of_object(t, x)); +} + static sexp sexp_analyze_op (sexp ctx sexp_api_params(self, n), sexp x, sexp e) { sexp ctx2 = ctx; if (sexp_envp(e)) { @@ -243,6 +266,10 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "opcode-param-type", 2, sexp_get_opcode_param_type); sexp_define_foreign(ctx, env, "optimize", 1, sexp_optimize); sexp_define_foreign(ctx, env, "type-of", 1, sexp_type_of); + sexp_define_foreign(ctx, env, "type-name", 1, sexp_type_name_op); + sexp_define_foreign(ctx, env, "type-cpl", 1, sexp_type_cpl_op); + sexp_define_foreign(ctx, env, "type-slots", 1, sexp_type_slots_op); + sexp_define_foreign(ctx, env, "object-size", 1, sexp_object_size); return SEXP_VOID; } diff --git a/lib/chibi/ast.module b/lib/chibi/ast.module index a439bd57..5a590489 100644 --- a/lib/chibi/ast.module +++ b/lib/chibi/ast.module @@ -26,7 +26,9 @@ exception-irritants exception-irritants-set! opcode-name opcode-num-params opcode-return-type opcode-param-type opcode-variadic? - procedure-code procedure-vars procedure-name bytecode-name) + procedure-code procedure-vars procedure-name bytecode-name + type? type-name type-cpl type-parent type-slots + object-size) (import-immutable (scheme)) (include-shared "ast") (include "ast.scm")) diff --git a/lib/chibi/ast.scm b/lib/chibi/ast.scm index 020f257a..f4506ff5 100644 --- a/lib/chibi/ast.scm +++ b/lib/chibi/ast.scm @@ -89,3 +89,8 @@ ((opcode? x) (or (opcode-name x) x)) (else x))))) +(define (type-parent x) + (let ((v (type-cpl x))) + (and (vector? v) + (> (vector-length v) 1) + (vector-ref v (- (vector-length v) 2))))) diff --git a/lib/srfi/9.scm b/lib/srfi/9.scm index 5100b341..c1818042 100644 --- a/lib/srfi/9.scm +++ b/lib/srfi/9.scm @@ -12,11 +12,9 @@ (_define (rename 'define)) (_lambda (rename 'lambda)) (_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))))) - (write `(name: ,name parent: ,parent)) (newline) + (_register (rename 'register-simple-type)) + (_slot-set! (rename 'slot-set!)) + (_type_slot_offset (rename 'type-slot-offset))) `(,(rename 'begin) ;; type (,_define ,name (,_register ,name-str ,parent ',fields)) @@ -25,63 +23,44 @@ ,(symbol->string (identifier->symbol pred)) ,name)) ;; fields - ,@(let lp ((ls fields) (i 0) (res '())) - (if (null? ls) - res - (let ((res - (cons `(,_define ,(cadar ls) - (,(rename 'make-getter) - ,(symbol->string - (identifier->symbol (cadar ls))) - ,name - ,i)) - res))) - (lp (cdr ls) - (+ i 1) - (if (pair? (cddar ls)) - (cons - `(,_define ,(caddar ls) - (,(rename 'make-setter) - ,(symbol->string - (identifier->symbol (caddar ls))) - ,name - ,i)) - res) - res))))) + ,@(map (lambda (f) + (and (pair? f) (pair? (cdr f)) + `(,_define ,(cadar ls) + (,(rename 'make-getter) + ,(symbol->string + (identifier->symbol (cadr f))) + ,name + (,_type_slot_offset ,name ,(car f)))))) + fields) + ,@(map (lambda (f) + (and (pair? f) (pair? (cdr f)) (pair? (cddr f)) + `(,_define ,(caddar ls) + (,(rename 'make-setter) + ,(symbol->string + (identifier->symbol (caddr f))) + ,name + (,_type_slot_offset ,name ,(car f)))))) + fields) ;; constructor (,_define ,make - ,(let lp ((ls make-fields) (sets '()) (set-defs '())) - (cond - ((null? ls) - `(,_let ((%make (,(rename 'make-constructor) - ,(symbol->string (identifier->symbol make)) - ,name)) - ,@set-defs) - (,_lambda ,make-fields - (,_let ((res (%make))) - ,@sets - res)))) - (else - (let ((field (assq (car ls) fields))) - (cond - ((not field) - (error "unknown record field in constructor" (car ls))) - ((pair? (cddr field)) - (lp (cdr ls) - (cons (list (caddr field) 'res (car ls)) sets) - set-defs)) - (else - (let* ((setter-name - (string-append "%" name-str "-" - (symbol->string (car ls)) "-set!")) - (setter (rename (string->symbol setter-name))) - (i (index-of (car ls) fields))) - (lp (cdr ls) - (cons (list setter 'res (car ls)) sets) - (cons (list setter - (list (rename 'make-setter) - setter-name - name - (index-of (car ls) fields))) - set-defs)))))))))) - (display "done\n")))))) + ,(let lp ((ls make-fields) (sets '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(symbol->string (identifier->symbol make)) + ,name))) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ((not field) + (error "unknown record field in constructor" (car ls))) + ((pair? (cddr field)) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets))) + (else + (lp (cdr ls) + (cons (list _slot-set! 'res (list 'quote (car ls)) (car ls)) sets)))))))))))))) diff --git a/lib/srfi/99.module b/lib/srfi/99.module new file mode 100644 index 00000000..66bec55d --- /dev/null +++ b/lib/srfi/99.module @@ -0,0 +1,7 @@ + +(define-module (srfi 99) + (import (srfi 99 records)) + (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator + record? record-rtd rtd-name rtd-parent + rtd-field-names rtd-all-field-names rtd-field-mutable? + define-record-type)) \ No newline at end of file diff --git a/lib/srfi/99/records.module b/lib/srfi/99/records.module new file mode 100644 index 00000000..e26a9a77 --- /dev/null +++ b/lib/srfi/99/records.module @@ -0,0 +1,9 @@ + +(define-module (srfi 99 records) + (import (srfi 99 records procedural) + (srfi 99 records inspection) + (srfi 99 records syntactic)) + (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator + record? record-rtd rtd-name rtd-parent + rtd-field-names rtd-all-field-names rtd-field-mutable? + define-record-type)) diff --git a/lib/srfi/99/records/inspection.module b/lib/srfi/99/records/inspection.module new file mode 100644 index 00000000..527ada49 --- /dev/null +++ b/lib/srfi/99/records/inspection.module @@ -0,0 +1,7 @@ + +(define-module (srfi 99 records inspection) + (export record? record-rtd rtd-name rtd-parent + rtd-field-names rtd-all-field-names rtd-field-mutable?) + (import-immutable (scheme)) + (import (chibi ast)) + (include "inspection.scm")) diff --git a/lib/srfi/99/records/inspection.scm b/lib/srfi/99/records/inspection.scm new file mode 100644 index 00000000..bc66a3d2 --- /dev/null +++ b/lib/srfi/99/records/inspection.scm @@ -0,0 +1,34 @@ + +(define (record? x) + (is-a? x )) + +(define (record-rtd x) + (type-of x)) + +(define (rtd-name x) (type-name x)) + +(define (rtd-parent x) (type-parent x)) + +(define (rtd-field-names x) + (list->vector + (map (lambda (x) (if (pair? x) (cadr x) x)) (type-slots x)))) + +(define (rtd-all-field-names x) + (let lp ((x x) (res '())) + (let ((res (append (vector->list (rtd-field-names x)) res))) + (let ((p (type-parent x))) + (if (type? p) + (lp p res) + (list->vector res)))))) + +(define (rtd-field-mutable? rtd x) + (let lp ((ls (type-slots rtd))) + (cond ((null? ls) + (let ((p (type-parent rtd))) + (if (type? p) + (rtd-field-mutable? p x) + (error "unknown field" rtd x)))) + ((eq? x (car ls))) + ((and (pair? (car ls)) (eq? x (cadar ls))) + (not (eq? 'immutable (caar ls)))) + (else (lp (cdr ls)))))) diff --git a/lib/srfi/99/records/procedural.module b/lib/srfi/99/records/procedural.module new file mode 100644 index 00000000..2289ecf1 --- /dev/null +++ b/lib/srfi/99/records/procedural.module @@ -0,0 +1,6 @@ + +(define-module (srfi 99 records procedural) + (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator) + (import-immutable (scheme)) + (import (chibi ast) (srfi 99 records inspection)) + (include "procedural.scm")) diff --git a/lib/srfi/99/records/procedural.scm b/lib/srfi/99/records/procedural.scm new file mode 100644 index 00000000..5994f934 --- /dev/null +++ b/lib/srfi/99/records/procedural.scm @@ -0,0 +1,51 @@ + +(define (make-rtd name fields . o) + (let ((parent (and (pair? o) (car o)))) + (register-simple-type name (vector->list fields) parent))) + +(define (rtd? x) + (type? x)) + +(define (rtd-constructor rtd . o) + (let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names)))) + (make (make-constructor (type-name rtd) rtd))) + (lambda args + (let ((res (make))) + (let lp ((a args) (p fields)) + (cond + ((null? a) (if (null? p) res (error "not enough args" p))) + ((null? p) (error "too many args" a)) + (else + (slot-set! res rtd (car p) (car a)) + (lp (cdr a) (cdr p))))))))) + +(define (rtd-predicate rtd) + (make-type-predicate (type-name rtd) rtd)) + +(define (field-index-of ls field) + (let lp ((i 0) (ls ls)) + (cond ((null? ls ) #f) + ((if (pair? (car ls)) + (eq? field (cadar ls)) + (eq? field (car ls))) + i) + (else (lp (+ i 1) (cdr ls)))))) + +(define (rtd-field-offset rtd field) + (let ((p (type-parent rtd))) + (or (and (type? p) + (rtd-field-offset p field)) + (let ((i (field-index-of (type-slots rtd) field))) + (and i + (if (type? p) + (+ i (vector-length (rtd-all-field-names p))) + i)))))) + +(define (rtd-accessor rtd field) + (make-getter rtd (type-name rtd) (rtd-field-offset rtd field))) + +(define (rtd-mutator rtd field) + (if (rtd-field-mutable? rtd field) + (make-setter rtd (type-name rtd) (rtd-field-offset rtd field)) + (error "can't make mutator for immutable field" rtd field))) + diff --git a/lib/srfi/99/records/syntactic.module b/lib/srfi/99/records/syntactic.module new file mode 100644 index 00000000..3d6f7a10 --- /dev/null +++ b/lib/srfi/99/records/syntactic.module @@ -0,0 +1,6 @@ + +(define-module (srfi 99 records syntactic) + (export define-record-type) + (import-immutable (scheme)) + (import (srfi 99 records inspection)) + (include "syntactic.scm")) diff --git a/lib/srfi/99/records/syntactic.scm b/lib/srfi/99/records/syntactic.scm new file mode 100644 index 00000000..356ec34f --- /dev/null +++ b/lib/srfi/99/records/syntactic.scm @@ -0,0 +1,109 @@ + +(define-syntax define-record-type + (er-macro-transformer + (lambda (expr rename compare) + (let* ((id->string (lambda (x) (symbol->string (identifier->symbol x)))) + (name (if (pair? (cadr expr)) (caadr expr) (cadr expr))) + (parent (and (pair? (cadr expr)) (cadadr expr))) + (name-str (id->string name)) + (make (caddr expr)) + (make-name (if (eq? make #t) + (string->symbol (string-append "make-" name-str)) + (if (pair? make) (car make) make))) + (pred (cadddr expr)) + (pred-name (if (eq? pred #t) + (string->symbol (string-append name-str "?")) + pred)) + (fields (cddddr expr)) + (field-names (map (lambda (x) (if (pair? x) (car x) x)) fields)) + (make-fields (if (pair? make) (cdr make) (and (not parent) field-names))) + (_define (rename 'define)) + (_lambda (rename 'lambda)) + (_let (rename 'let)) + (_register (rename 'register-simple-type)) + (_slot-set! (rename 'slot-set!)) + (_vector->list (rename 'vector->list)) + (_type_slot_offset (rename 'type-slot-offset)) + (_rtd-all-field-names (rename 'rtd-all-field-names))) + `(,(rename 'begin) + ;; type + (,_define ,name (,_register ,name-str ,parent ',field-names)) + ;; predicate + ,@(if pred-name + `((,_define ,pred-name + (,(rename 'make-type-predicate) + ,(id->string pred-name) + ,name))) + #f) + ;; accessors + ,@(map (lambda (f) + (let ((g (if (and (pair? f) (pair? (cdr f))) + (cadr f) + (and (identifier? f) + (string->symbol + (string-append name-str "-" (id->string f))))))) + (and g + `(,_define ,g + (,(rename 'make-getter) + ,(id->string g) + ,name + (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) + fields) + ,@(map (lambda (f) + (let ((s (if (and (pair? f) (pair? (cdr f)) (pair? (cddr f))) + (caddr f) + (and (identifier? f) + (string->symbol + (string-append name-str "-" (id->string f) "-set!")))))) + (and s + `(,_define ,s + (,(rename 'make-setter) + ,(id->string s) + ,name + (,_type_slot_offset ,name ',(if (pair? f) (car f) f))))))) + fields) + ;; constructor + ,(if make-fields + `(,_define ,make-name + ,(let lp ((ls make-fields) (sets '())) + (cond + ((null? ls) + `(,_let ((%make (,(rename 'make-constructor) + ,(id->string make-name) + ,name))) + (,_lambda ,make-fields + (,_let ((res (%make))) + ,@sets + res)))) + (else + (let ((field (assq (car ls) fields))) + (cond + ;;((not field) + ;; (error "unknown record field in constructor" (car ls))) + ((and (pair? field) (pair? (cdr field)) (pair? (cddr field))) + (lp (cdr ls) + (cons (list (caddr field) 'res (car ls)) sets))) + (else + (lp (cdr ls) + (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets))))))))) + `(,_define ,make-name + (,_let ((%make (,(rename 'make-constructor) + ,(id->string make-name) + ,name))) + (,_lambda args + (,_let ((res (%make))) + (let lp ((a args) + (p (,_vector->list (,_rtd-all-field-names ,name)))) + (cond + ((null? a) + (if (null? p) + res + (error ,(string-append "not enough arguments to " (id->string make-name) ": missing") + p))) + ((null? p) + (error ,(string-append "too many arguments to " (id->string make-name)) + a)) + (else + (,_slot-set! ,name res (,_type_slot_offset ,name (car p)) (car a)) + (lp (cdr a) (cdr p))))))))) + )))))) diff --git a/opcodes.c b/opcodes.c index 3d3aff5d..f4e66948 100644 --- a/opcodes.c +++ b/opcodes.c @@ -37,8 +37,6 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SE #endif #endif _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL), -_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), -_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), @@ -159,6 +157,9 @@ _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0 _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-constructor", 0, sexp_make_constructor_op), _FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-getter", 0, sexp_make_getter_op), _FN3(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-setter", 0, sexp_make_setter_op), +_FN2(_I(SEXP_OPCODE), _I(SEXP_TYPE), _I(SEXP_SYMBOL), "type-slot-offset", 0, sexp_type_slot_offset_op), +_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF, 3, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0, "slot-ref", 0, NULL), +_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET, 4, 0, SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_FIXNUM), 0,"slot-set!", 0, NULL), #endif #if PLAN9 #include "opt/plan9-opcodes.c" diff --git a/sexp.c b/sexp.c index d043b9ae..01a20a5f 100644 --- a/sexp.c +++ b/sexp.c @@ -173,6 +173,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name, type = sexp_type_by_index(ctx, num_types); sexp_pointer_tag(type) = SEXP_TYPE; sexp_type_tag(type) = num_types; + sexp_type_slots(type) = slots; sexp_type_field_base(type) = sexp_unbox_fixnum(fb); sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb); sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb); diff --git a/tests/match-tests.scm b/tests/match-tests.scm index 911dd831..2a8cf3ae 100644 --- a/tests/match-tests.scm +++ b/tests/match-tests.scm @@ -132,4 +132,103 @@ (list tag attrs text)) (else #f))) +(test "joined tail" '(1 2) + (match '(1 2 3) ((and (a ... b) x) a))) + (((x . y) ... u v w) (list x y u v w)))) + +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) + +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) + +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) + +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) + +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) + +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) + +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) + +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "collect tree search" + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) + +(test "joined tail" '(1 2) + (match '(1 2 3) ((and (a ... b) x) a))) + + (((x . y) ... u v w) (list x y u v w)))) + +(test "Riastradh quasiquote" '(2 3) + (match '(1 2 3) (`(1 ,b ,c) (list b c)))) + +(test "trivial tree search" '(1 2 3) + (match '(1 2 3) ((_ *** (a b c)) (list a b c)))) + +(test "simple tree search" '(1 2 3) + (match '(x (1 2 3)) ((_ *** (a b c)) (list a b c)))) + +(test "deep tree search" '(1 2 3) + (match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c)))) + +(test "non-tail tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c)))) + +(test "restricted tree search" '(1 2 3) + (match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c)))) + +(test "fail restricted tree search" #f + (match '(x (y (x a b c (1 2 3) d e f))) + (('x *** (a b c)) (list a b c)) + (else #f))) + +(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "failed sxml tree search" #f + (match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...)) + (list attrs text)) + (else #f))) + +(test "collect tree search" + '((p ul li) ((href . "http://synthcode.com/")) ("synthcode")) + (match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f))) + (((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...)) + (list tag attrs text)) + (else #f))) + +(test "anded tail pattern" '(1 2) + (match '(1 2 3) ((and (a ... b) x) a))) + +(test "anded search pattern" '(a b c) + (match '(a (b (c d))) ((and (p *** 'd) x) p))) + (test-end) diff --git a/tests/record-tests.scm b/tests/record-tests.scm new file mode 100644 index 00000000..32237fb9 --- /dev/null +++ b/tests/record-tests.scm @@ -0,0 +1,151 @@ + +(import (srfi 99 records syntactic) (chibi test)) + +(test-begin "records") + +(define-record-type organism + (make-organism name) + organism? + (name name-of set-name-of!)) + +;; kingdom +(define-record-type (animal organism) + (make-animal name food) + animal? + ;; all animals eat + (food food-of set-food-of!)) + +;; phylum +(define-record-type (chordate animal) + (make-chordate name food) + chordate?) + +;; class +(define-record-type (mammal chordate) + (make-mammal name food num-nipples) + mammal? + ;; all mammals have nipples + (num-nipples num-nipples-of set-num-nipples-of!)) + +;; order +(define-record-type (carnivore mammal) + (make-carnivore name food num-nipples) + carnivore?) + +(define-record-type (rodent mammal) + (make-rodent name food num-nipples) + rodent?) + +;; family +(define-record-type (felidae carnivore) + (make-felidae name food num-nipples) + felidae?) + +(define-record-type (muridae rodent) + (make-muridae name food num-nipples) + muridae?) + +;; genus +(define-record-type (felis felidae) + (make-felis name food num-nipples) + felis?) + +(define-record-type (mus muridae) + (make-mus name food num-nipples) + mus?) + +;; species +(define-record-type (cat felis) + (make-cat name food num-nipples breed color) + cat? + (breed breed-of set-breed-of!) + (color color-of set-color-of!)) + +(define-record-type (mouse mus) + (make-mouse name food num-nipples) + mouse?) + +(define mickey (make-mouse "Mickey" "cheese" 10)) +(define felix (make-cat "Felix" mickey 8 'mixed '(and black white))) + +(test-assert (organism? mickey)) +(test-assert (animal? mickey)) +(test-assert (chordate? mickey)) +(test-assert (mammal? mickey)) +(test-assert (rodent? mickey)) +(test-assert (muridae? mickey)) +(test-assert (mus? mickey)) +(test-assert (mouse? mickey)) + +(test-assert (not (carnivore? mickey))) +(test-assert (not (felidae? mickey))) +(test-assert (not (felis? mickey))) +(test-assert (not (cat? mickey))) + +(test-assert (organism? felix)) +(test-assert (animal? felix)) +(test-assert (chordate? felix)) +(test-assert (mammal? felix)) +(test-assert (carnivore? felix)) +(test-assert (felidae? felix)) +(test-assert (felis? felix)) +(test-assert (cat? felix)) + +(test-assert (not (rodent? felix))) +(test-assert (not (muridae? felix))) +(test-assert (not (mus? felix))) +(test-assert (not (mouse? felix))) + +(test "Mickey" (name-of mickey)) +(test "cheese" (food-of mickey)) +(test 10 (num-nipples-of mickey)) + +(test "Felix" (name-of felix)) +(test mickey (food-of felix)) +(test 8 (num-nipples-of felix)) +(test 'mixed (breed-of felix)) +(test '(and black white) (color-of felix)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-record-type person #t #t name sex age) +(define-record-type (employee person) #t #t department salary) + +(define bob (make-employee "Bob" 'male 28 'hr 50000.0)) +(define alice (make-employee "Alice" 'female 32 'research 100000.0)) + +(test-assert (person? bob)) +(test-assert (employee? bob)) +(test "Bob" (person-name bob)) +(test 'male (person-sex bob)) +(test 28 (person-age bob)) +(test 'hr (employee-department bob)) +(test 50000.0 (employee-salary bob)) + +(test-assert (person? alice)) +(test-assert (employee? alice)) +(test "Alice" (person-name alice)) +(test 'female (person-sex alice)) +(test 32 (person-age alice)) +(test 'research (employee-department alice)) +(test 100000.0 (employee-salary alice)) + +;; After a trip to Thailand... +(person-sex-set! bob 'female) +(person-name-set! bob "Roberta") + +;; Then Roberta quits! +(employee-department-set! bob #f) +(employee-salary-set! bob 0.0) + +(test "Roberta" (person-name bob)) +(test 'female (person-sex bob)) +(test 28 (person-age bob)) +(test #f (employee-department bob)) +(test 0.0 (employee-salary bob)) + +;;;; SRFI-99 forbids this, but we currently do it anyway. +;;(test-assert (equal? (make-employee "Chuck" 'male 20 'janitorial 50000.0) +;; (make-employee "Chuck" 'male 20 'janitorial 50000.0))) + +(test-end) diff --git a/vm.c b/vm.c index eef3e5b3..0a60c6d0 100644 --- a/vm.c +++ b/vm.c @@ -969,13 +969,13 @@ sexp sexp_vm (sexp ctx, sexp proc) { break; case SEXP_OP_SLOTN_SET: if (! sexp_typep(_ARG1)) - sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1)); + sexp_raise("slot-set!: not a record type", sexp_list1(ctx, _ARG1)); else if (! sexp_check_type(ctx, _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_raise("slot-set!: not an integer", sexp_list1(ctx, _ARG3)); sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4); _ARG4 = SEXP_VOID; top-=3;