CLOS based R6RS record implementation

record.scm

(import (rnrs) (clos user) (clos core))

(define-class <record-type-descriptor> ()
  ((name    :init-keyword :name)
   (parent  :init-keyword :parent    :reader record-type-parent)
   (uid     :init-keyword :uid)
   (sealed? :init-keyword :sealed?)
   (opaque? :init-keyword :opaque?)
   (fields  :init-keyword :fields    :reader rtd-fields)
   ;; instanciate class
   (class   :init-keyword :class     :reader rtd-class)))
(define-class <record-constructor-descriptor> ()
  ((rtd      :init-keyword :rtd      :reader rcd-rtd)
   (protocol :init-keyword :protocol :reader rcd-protocol)
   (parent   :init-keyword :parent   :reader rcd-parent)))
(define-class <record-type-meta> (<class>)
  ((rtd   :init-keyword :rtd)
   (rcd   :init-keyword :rcd)))

(define-method compute-getter-and-setter ((c <record-type-meta>) slot)
  (let ((mutability (slot-definition-option slot :mutable #f))
	(accessors (call-next-method)))
    (if mutability
	accessors
	(list (car accessors)
	      (lambda (o v) (error 'record-accessor 
				   "field is immutable" 
				   (slot-definition-name slot) o))
	      (caddr accessors)))))

(define (make-record-type-descriptor name parent uid sealed? opaque? fields)
  (define (process-fields fields)
    ;; -> slot form
    (map (lambda (field)
	   (if (pair? field)
	       (let ((mutability (car field))
		     (name       (cadr field)))
		 ;; TODO check mutability keyword
		 (list name :mutable (eq? mutability 'mutable)
		       :init-keyword (make-keyword name)))
	       (error 'make-record-type-descriptor "invalid field")))
	 (vector->list fields)))
  (let* ((p (and parent (slot-ref parent 'class)))
	 (type (make <record-type-meta>
		 :definition-name name
		 :direct-supers (or (and p (list p))
				    '())
		 :direct-slots (process-fields fields)
		 :defined-library (current-library)))
	 (rtd (make <record-type-descriptor>
		:name name :parent parent :uid uid
		:sealed? sealed? :opaque? opaque?
		:fields fields :class type)))
    (slot-set! type 'rtd rtd)
    rtd))

(define (make-record-constructor-descriptor rtd parent protocol)
  (let ((rcd (make <record-constructor-descriptor>
	       :rtd rtd :parent parent 
	       :protocol (or protocol (default-protocol rtd)))))
    (slot-set! (slot-ref rtd 'class) 'rcd rcd)
    rcd))

(define (make-record-type name rtd rcd) (slot-ref rtd 'class))

(define (rtd-total-field-count rtd)
  (length (class-slots (slot-ref rtd 'class))))

(define (record-type-rcd type) (slot-ref type 'rcd))
(define (record-type-descriptor type) (slot-ref type 'rtd))

(define-syntax record-constructor-descriptor
  (syntax-rules ()
    ((_ type) (record-type-rcd type))))

(define (record-constructor rcd)
  (let ((parent (rcd-parent rcd))
	(rtd    (rcd-rtd rcd)))
    (if parent
	(let ((class (slot-ref rtd 'class)))
	  (make-nested-conser rcd rtd (length (class-slots class))))
	(make-simple-conser rcd rtd (vector-length (rtd-fields rtd))))))

(define (%make-record rtd field-values)
  (let* ((class (slot-ref rtd 'class))
	 ;; TODO create (kw v) list to make mutable/immutable thing
	 (tuple (make class)))
    (for-each (lambda (slot value) 
		(slot-set-using-class! class tuple 
				       (slot-definition-name slot) value))
	      (class-slots class) field-values)
    tuple))

(define (make-nested-conser desc rtd argc)
  ((rcd-protocol desc)
   ((let loop ((desc desc))
      (cond ((rcd-parent desc)
             => (lambda (parent)
                  (lambda extra-field-values
                    (lambda protocol-args
                      (lambda this-field-values
                        (apply ((rcd-protocol parent)
                                (apply (loop parent)
                                       (append this-field-values 
					       extra-field-values)))
                               protocol-args))))))
            (else
             (lambda extra-field-values
               (lambda this-field-values
                 (let ((field-values (append this-field-values 
					     extra-field-values)))
                   (if (= (length field-values) argc)
		       (%make-record rtd field-values)
                       (assertion-violation "record constructor"
					    "wrong number of arguments"
					    field-values)))))))))))

(define (make-simple-conser desc rtd argc)
  ((rcd-protocol desc)
   (lambda field-values
     (if (= (length field-values) argc)
         (%make-record rtd field-values)
         (assertion-violation "record constructor"
			      "wrong number of arguments"
			      field-values)))))

(define (default-protocol rtd)
  (let ((parent (record-type-parent rtd)))
    (if parent
        (let ((parent-field-count (rtd-total-field-count parent)))
          (lambda (p)
            (lambda field-values
              (receive (parent-field-values this-field-values) 
		  (split-at field-values parent-field-count)
		(let ((n (apply p parent-field-values)))
		  (apply n this-field-values))))))
        (lambda (p)
          (lambda field-values
            (apply p field-values))))))

test.scm

(import (rnrs) (clos user) (clos core))

(define rtd1
  (make-record-type-descriptor
   'rtd1 #f #f #f #f
   '#((immutable x1) (immutable x2))))
(define rtd2
  (make-record-type-descriptor
   'rtd2 rtd1 #f #f #f
   '#((immutable x3) (immutable x4))))
(define rtd3
  (make-record-type-descriptor
   'rtd3 rtd2 #f #f #f
   '#((immutable x5) (immutable x6))))
(define protocol1
  (lambda (p)
    (lambda (a b c)
      (p (+ a b) (+ b c)))))
(define protocol2
  (lambda (n)
    (lambda (a b c d e f)
      (let ((p (n a b c)))
        (p (+ d e) (+ e f))))))
(define protocol3
  (lambda (n)
    (lambda (a b c d e f g h i)
      (let ((p (n a b c d e f)))
        (p (+ g h) (+ h i))))))
(define cd1
  (make-record-constructor-descriptor
    rtd1 #f protocol1))
(define cd2
  (make-record-constructor-descriptor
    rtd2 cd1 protocol2))
(define cd3
  (make-record-constructor-descriptor
    rtd3 cd2 protocol3))
(define make-rtd1 (record-constructor cd1))
(define make-rtd2 (record-constructor cd2))
(define make-rtd3 (record-constructor cd3))

;; for check
(define <rtd3> (slot-ref rtd3 'class))
(define-method write-object ((r <rtd3>) out)
  (display "#<rtd3" out)
  (for-each (lambda (s) 
	      (display " " out)
	      (display (slot-ref r (slot-definition-name s)) out))
	    (class-slots <rtd3>))
  (display ">" out))
(let ((r (make-rtd3 1 2 3 4 5 6 7 8 9)))
  (print r)
  (slot-set! r 'x1 5)) ;; -> error