(library (rnrs records private core)
(export make-record-type-descriptor
record-type-descriptor?
record-type-name
record-type-parent
record-type-sealed?
record-type-uid
record-type-field-names
record-type-opaque?
make-record-constructor-descriptor record-constructor
record-predicate
record-accessor record-mutator
record-field-mutable? record-type-generative?
record? record-rtd)
(import (rnrs base)
(only (rnrs lists) find for-all)
(core vector-types)
(primitives contract-violation))
(define make-field-spec cons)
(define field-spec-mutable? car)
(define field-spec-name cdr)
(define (field-spec=? spec-1 spec-2)
(and (eq? (field-spec-mutable? spec-1)
(field-spec-mutable? spec-2))
(eq? (field-spec-name spec-1)
(field-spec-name spec-2))))
(define :record-type-data (make-vector-type 'record-type-descriptor
#f #f '(#f #f #f #f #f #f) #t))
(define (make-record-type-data name uid sealed? opaque? field-specs parent)
((typed-vector-constructor :record-type-data)
name uid sealed? opaque? field-specs parent))
(define (record-type-data? thing)
((vector-type-predicate :record-type-data) thing))
(define (typed-vector-ref t v pos)
((typed-vector-accessor t pos) v))
(define (record-type-name rtd)
(typed-vector-ref :record-type-data (vector-type-data rtd) 0))
(define (record-type-uid rtd)
(typed-vector-ref :record-type-data (vector-type-data rtd) 1))
(define (record-type-sealed? rtd)
(typed-vector-ref :record-type-data (vector-type-data rtd) 2))
(define (record-type-opaque? rtd)
(typed-vector-ref :record-type-data (vector-type-data rtd) 3))
(define (record-type-field-specs rtd)
(typed-vector-ref :record-type-data (vector-type-data rtd) 4))
(define (record-type-parent rtd)
(typed-vector-ref :record-type-data (vector-type-data rtd) 5))
(define (record-type-descriptor=? rtd-1 rtd-2)
(and (eq? (record-type-parent rtd-1) (record-type-parent rtd-2))
(eq? (record-type-uid rtd-1) (record-type-uid rtd-2))
(for-all field-spec=?
(record-type-field-specs rtd-1)
(record-type-field-specs rtd-2))))
(define (uid->record-type-descriptor uid)
(find (lambda (rtd)
(eq? (record-type-uid rtd) uid))
*nongenerative-record-types*))
(define (record-type-generative? rtd)
(not (record-type-uid rtd)))
(define *nongenerative-record-types* '())
(define (append-field-mutable-specs parent)
(if parent
(append (append-field-mutable-specs (record-type-parent parent))
(map field-spec-mutable? (record-type-field-specs parent)))
'()))
(define (make-record-type-descriptor name parent uid sealed? opaque? field-specs)
(if (and parent
(record-type-sealed? parent))
(contract-violation "can't extend a sealed parent class" parent))
(let ((opaque? (if parent
(or (record-type-opaque? parent)
opaque?)
opaque?))
(field-specs (map parse-field-spec field-specs)))
(let ((rtd
(make-vector-type name
parent
(make-record-type-data name uid sealed? opaque? field-specs parent)
(append (append-field-mutable-specs parent)
(map field-spec-mutable? field-specs))
opaque?)))
(if uid
(cond
((uid->record-type-descriptor uid)
=> (lambda (old-rtd)
(if (record-type-descriptor=? rtd old-rtd)
old-rtd
(contract-violation "mismatched nongenerative record types with identical uids"
old-rtd rtd))))
(else
(set! *nongenerative-record-types*
(cons rtd *nongenerative-record-types*))
rtd))
rtd))))
(define (record-type-descriptor? thing)
(and (vector-type? thing)
(record-type-data? (vector-type-data thing))))
(define (ensure-rtd thing)
(if (not (record-type-descriptor? thing))
(contract-violation "not a record-type descriptor" thing)))
(define (parse-field-spec spec)
(apply (lambda (mutability name)
(make-field-spec
(case mutability
((mutable) #t)
((immutable) #f)
(else (contract-violation "field spec with invalid mutability specification" spec)))
name))
spec))
(define (record-type-field-names rtd)
(map field-spec-name (record-type-field-specs rtd)))
(define (field-count rtd)
(let loop ((rtd rtd)
(count 0))
(if (not rtd)
count
(loop (record-type-parent rtd)
(+ count (length (record-type-field-specs rtd)))))))
(define (record? thing)
(and (typed-vector? thing)
(let ((rtd (typed-vector-type thing)))
(and (record-type-descriptor? rtd)
(not (record-type-opaque? rtd))))))
(define (record-rtd rec)
(if (record? rec)
(typed-vector-type rec)
(contract-violation "cannot extract rtd of a non-record or opaque record" rec)))
(define :record-constructor-descriptor (make-vector-type 'record-constructor-descriptor #f #f '(#f #f #f #f) #t))
(define (make-record-constructor-descriptor rtd previous protocol)
(let ((parent (record-type-parent rtd)))
(if (and previous (not parent))
(contract-violation "mismatch between rtd and constructor descriptor" rtd previous))
(if (and previous
(not protocol)
(record-constructor-descriptor-custom-protocol? previous))
(contract-violation "default protocol requested when parent constructor descriptor has custom one"
protocol previous))
(let ((custom-protocol? (and protocol #t))
(protocol (or protocol (default-protocol rtd)))
(previous
(if (or previous
(not parent))
previous
(make-record-constructor-descriptor parent #f #f))))
((typed-vector-constructor :record-constructor-descriptor)
rtd protocol custom-protocol? previous))))
(define (split-at l n)
(if (zero? n)
(values '() l)
(let-values (((a b) (split-at (cdr l) (- n 1))))
(values (cons (car l) a) b))))
(define (default-protocol rtd)
(let ((parent (record-type-parent rtd)))
(if (not parent)
(lambda (p)
(lambda field-values
(apply p field-values)))
(let ((parent-field-count (field-count parent)))
(lambda (p)
(lambda all-field-values
(call-with-values
(lambda () (split-at all-field-values parent-field-count))
(lambda (parent-field-values this-field-values)
(apply (apply p parent-field-values) this-field-values)))))))))
(define (record-constructor-descriptor-rtd desc)
(typed-vector-ref :record-constructor-descriptor desc 0))
(define (record-constructor-descriptor-protocol desc)
(typed-vector-ref :record-constructor-descriptor desc 1))
(define (record-constructor-descriptor-custom-protocol? desc)
(typed-vector-ref :record-constructor-descriptor desc 2))
(define (record-constructor-descriptor-previous desc)
(typed-vector-ref :record-constructor-descriptor desc 3))
(define (make-make-seeder real-rtd wrap for-desc)
(let recur ((for-desc for-desc))
(let* ((for-rtd (record-constructor-descriptor-rtd for-desc))
(for-rtd-field-count (length (record-type-field-specs for-rtd))))
(cond
((record-constructor-descriptor-previous for-desc)
=> (lambda (parent-desc)
(let ((parent-protocol (record-constructor-descriptor-protocol parent-desc))
(parent-make-seeder (recur parent-desc)))
(lambda extension-field-values
(lambda parent-protocol-args
(lambda for-rtd-field-values
(if (not (= (length for-rtd-field-values) for-rtd-field-count))
(contract-violation "wrong number of arguments to record constructor"
for-rtd for-rtd-field-values))
(apply (parent-protocol
(apply parent-make-seeder
(append for-rtd-field-values extension-field-values)))
parent-protocol-args)))))))
(else
(lambda extension-field-values
(lambda for-rtd-field-values
(if (not (= (length for-rtd-field-values) for-rtd-field-count))
(contract-violation "wrong number of arguments to record constructor"
for-rtd for-rtd-field-values))
(wrap
(apply (typed-vector-constructor real-rtd)
(append for-rtd-field-values extension-field-values))))))))))
(define (rtd-ancestor? rtd-1 rtd-2)
(let loop ((rtd-2 rtd-2))
(or (eq? rtd-1 rtd-2)
(and rtd-2
(loop (record-type-parent rtd-2))))))
(define (record-constructor desc)
(let* ((rtd (record-constructor-descriptor-rtd desc)))
((record-constructor-descriptor-protocol desc)
((make-make-seeder rtd (lambda (r) r) desc)))))
(define (record-predicate rtd)
(vector-type-predicate rtd))
(define (record-accessor rtd field-id)
(typed-vector-accessor rtd (field-id-index rtd field-id)))
(define (record-mutator rtd field-id)
(if (not (record-field-mutable? rtd field-id))
(contract-violation "record-mutator called on immutable field" rtd field-id))
(typed-vector-mutator rtd (field-id-index rtd field-id)))
(define (field-id-index rtd field-id)
(+ (field-count (record-type-parent rtd))
field-id))
(define (record-field-mutable? rtd field-id)
(field-spec-mutable? (list-ref (record-type-field-specs rtd) field-id))))