(parent-args parent-args) (inits inits)) (apply (if* ((and parent (rcd-protocol parent)) => protocol) (protocol (if* ((rcd-parent parent) => parent) ;; Parent has a protocol too; collect ;; inits from parent. (lambda parent-args (lambda parent-inits (collect-inits parent parent-args (append parent-inits inits)))) ;; Default case: parent args correspond ;; to inits. (lambda parent-args (apply raw-constructor (append parent-args inits))))) ;; Default case: parent args correspond to inits. (lambda parent-args (apply raw-constructor (append parent-args inits)))) parent-args)))) raw-constructor)) raw-constructor)) (define (record-accessor rtd k) (define pred (record-predicate rtd)) (let* ((parent (record-type-parent rtd)) (parent-nfields (if parent (length (record-type-fields parent)) 0)) (k (+ k parent-nfields))) (unless (and (<= parent-nfields k) (< k (length (record-type-fields rtd)))) (raise (make-assertion-violation))) (lambda (obj) (unless (pred obj) (raise (make-assertion-violation))) (struct-ref obj k)))) (define (record-mutator rtd k) (define pred (record-predicate rtd)) (let* ((parent (record-type-parent rtd)) (parent-nfields (if parent (length (record-type-fields parent)) 0)) (k (+ k parent-nfields))) (unless (and (<= parent-nfields k) (< k (length (record-type-fields rtd)))) (raise (make-assertion-violation))) (unless (logbit? k (record-type-mutable-fields rtd)) (raise (make-assertion-violation))) (lambda (obj val) (unless (pred obj) (raise (make-assertion-violation))) (struct-set! obj k val)))) )