mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 21:59:17 +02:00
51 lines
1.6 KiB
Scheme
51 lines
1.6 KiB
Scheme
|
|
(define (make-rtd name fields . o)
|
|
(let ((parent (and (pair? o) (car o))))
|
|
(register-simple-type name parent (vector->list fields))))
|
|
|
|
(define (rtd? x)
|
|
(type? x))
|
|
|
|
(define (rtd-constructor rtd . o)
|
|
(let ((fields (vector->list (if (pair? o) (car o) (rtd-all-field-names rtd))))
|
|
(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! rtd res (rtd-field-offset 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 (car (cdar 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 (type-name rtd) rtd (rtd-field-offset rtd field)))
|
|
|
|
(define (rtd-mutator rtd field)
|
|
(if (rtd-field-mutable? rtd field)
|
|
(make-setter (type-name rtd) rtd (rtd-field-offset rtd field))
|
|
(error "can't make mutator for immutable field" rtd field)))
|
|
|