mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
59 lines
1.8 KiB
Scheme
59 lines
1.8 KiB
Scheme
|
|
(define (make-rtd name fields . o)
|
|
(let ((parent (and (pair? o) (car o))))
|
|
(register-simple-type (if (symbol? name) (symbol->string name) name)
|
|
parent
|
|
(vector->list fields))))
|
|
|
|
(define (rtd? x)
|
|
(type? x))
|
|
|
|
(define (rtd-constructor rtd . o)
|
|
(let ((fields
|
|
(if (pair? o)
|
|
(map
|
|
(lambda (field)
|
|
(rtd-field-offset rtd field))
|
|
(vector->list (car o)))
|
|
(iota (vector-length (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 (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 (let ((i (field-index-of (type-slots rtd) field)))
|
|
(and i
|
|
(if (type? p)
|
|
(+ i (vector-length (rtd-all-field-names p)))
|
|
i)))
|
|
(and (type? p)
|
|
(rtd-field-offset p field)))))
|
|
|
|
(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)))
|
|
|