diff --git a/mes/module/srfi/srfi-9-struct.mes b/mes/module/srfi/srfi-9-struct.mes index d8448874..fbf6773c 100644 --- a/mes/module/srfi/srfi-9-struct.mes +++ b/mes/module/srfi/srfi-9-struct.mes @@ -35,21 +35,24 @@ (make-struct ' (cons type (list fields)) printer))) (define (record-type? o) - (eq? (struct-vtable o) ')) + (eq? (record-type-descriptor o) ')) (define (struct-vtable o) - (struct-ref o 0)) + (record-type-descriptor o)) -(define (record-type o) +(define (record-type-name o) (struct-ref o 2)) +(define (record-type-descriptor o) + (struct-ref o 0)) + (define (record-type-fields o) (struct-ref o 3)) (define (record-predicate type) (lambda (o) (and (record? o) - (eq? (record-type o) (record-type type))))) + (eq? (record-type-descriptor o) type)))) (define (record? o) (and (struct? o) @@ -57,7 +60,7 @@ (define (record-constructor type . field-names) (let* ((fields (record-type-fields type)) - (name (record-type type)) + (name (record-type-name type)) (field-names (if (null? field-names) fields (car field-names)))) (lambda (. o) @@ -68,7 +71,7 @@ (define record-printer *unspecified*) ; TODO (define (record-printer o) (display "#<") - (display (record-type o)) + (display (record-type-name o)) (let* ((vtable (struct-vtable o)) (fields (record-type-fields vtable))) (for-each (lambda (field) @@ -94,14 +97,14 @@ (define (record-accessor type field) (let ((i (record-field-index type field))) (lambda (o . field?) - (if (not (eq? (record-type o) (record-type type))) (error "record accessor: record expected" type o) + (if (not (eq? (record-type-descriptor o) type)) (error "record accessor: record expected" type o) (if (pair? field?) field (struct-ref o i)))))) (define (record-modifier type field) (let ((i (record-field-index type field))) (lambda (o v) - (if (not (eq? (record-type o) (record-type type))) (error "record modifier: record expected" type o) + (if (not (eq? (record-type-descriptor o) type)) (error "record modifier: record expected" type o) (struct-set! o i v))))) (define (record-field-index type field) diff --git a/mes/module/srfi/srfi-9/gnu-struct.mes b/mes/module/srfi/srfi-9/gnu-struct.mes index f3938c8a..9a972afe 100644 --- a/mes/module/srfi/srfi-9/gnu-struct.mes +++ b/mes/module/srfi/srfi-9/gnu-struct.mes @@ -28,7 +28,7 @@ (define-macro (set-field o getters value) `(let ((getter ,(car getters))) (let* ((type (struct-vtable ,o)) - (name (record-type ,o)) + (name (record-type-name ,o)) (set (getter ,o #t))) (define (field->value field) (if (eq? set field) ,value diff --git a/tests/srfi-9.test b/tests/srfi-9.test index 04d50fe1..78571e7f 100755 --- a/tests/srfi-9.test +++ b/tests/srfi-9.test @@ -39,6 +39,32 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests (pass-if "first dummy" #t) (pass-if-not "second dummy" #f) +(define (make-record-type ' '(one two))) +(pass-if "make-record-type" (record-type? )) + +(define make-zero (record-constructor '(one two))) +(pass-if "record-constructor" (procedure? make-zero)) + +(define zero (make-zero 1 2)) +(pass-if "record?" (record? zero)) + +(define zero? (record-predicate )) +(pass-if "record-predicate" (procedure? zero?)) +(pass-if "zero?" (zero? zero)) + +(define zero-one (record-accessor 'one)) +(pass-if-eq "zero-one" 1 (zero-one zero)) + +(define zero-two-set! (record-modifier 'two)) +(pass-if-eq "zero-one-set!" 42 (begin (zero-two-set! zero 42) + ((record-accessor 'two) zero))) + +(pass-if-eq "record-type-descriptor" (record-type-descriptor zero)) + +(pass-if-eq "record-type-name" ' (record-type-name )) + +(pass-if-equal "record-type-fields" '(one two) (record-type-fields )) + (define-record-type lexical-token (make-lexical-token category source value) lexical-token? @@ -46,7 +72,7 @@ exec ${MES-bin/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests (source lexical-token-source) (value lexical-token-value)) -(pass-if "record" +(pass-if "define-record-type" (lexical-token? (make-lexical-token 'x 'y 'z))) (pass-if-equal "set-field" "baar"