mes: srfi-9: Guile interface compliancy.
* mes/module/srfi/srfi-9-struct.mes (record-type-name): Rename from record-type. Update users. (record-type-descriptor): New function. * mes/module/srfi/srfi-9/gnu-struct.mes (set-field): Update. * tests/srfi-9.test ("make-record-type", "record-constructor", "record?", "record-predicate", "zero?", "zero-one", "zero-one-set!", "record-type-descriptor", "record-type-name", "record-type-fields"): New test.
This commit is contained in:
parent
c31a597143
commit
e8c81f283b
|
@ -35,21 +35,24 @@
|
|||
(make-struct '<record-type> (cons type (list fields)) printer)))
|
||||
|
||||
(define (record-type? o)
|
||||
(eq? (struct-vtable o) '<record-type>))
|
||||
(eq? (record-type-descriptor o) '<record-type>))
|
||||
|
||||
(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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 <zero> (make-record-type '<zero> '(one two)))
|
||||
(pass-if "make-record-type" (record-type? <zero>))
|
||||
|
||||
(define make-zero (record-constructor <zero> '(one two)))
|
||||
(pass-if "record-constructor" (procedure? make-zero))
|
||||
|
||||
(define zero (make-zero 1 2))
|
||||
(pass-if "record?" (record? zero))
|
||||
|
||||
(define zero? (record-predicate <zero>))
|
||||
(pass-if "record-predicate" (procedure? zero?))
|
||||
(pass-if "zero?" (zero? zero))
|
||||
|
||||
(define zero-one (record-accessor <zero> 'one))
|
||||
(pass-if-eq "zero-one" 1 (zero-one zero))
|
||||
|
||||
(define zero-two-set! (record-modifier <zero> 'two))
|
||||
(pass-if-eq "zero-one-set!" 42 (begin (zero-two-set! zero 42)
|
||||
((record-accessor <zero> 'two) zero)))
|
||||
|
||||
(pass-if-eq "record-type-descriptor" <zero> (record-type-descriptor zero))
|
||||
|
||||
(pass-if-eq "record-type-name" '<zero> (record-type-name <zero>))
|
||||
|
||||
(pass-if-equal "record-type-fields" '(one two) (record-type-fields <zero>))
|
||||
|
||||
(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"
|
||||
|
|
Loading…
Reference in New Issue