<<>>
<<;;; Records.scheme>>
<<;;; Copyright Ó 1989, 1991 by Xerox Corporation.  All rights reserved.>>
<<;;; Last changed by Pavel on March 20, 1989 6:20:56 pm PST>>

(export (make-record-type record-constructor record-predicate record-accessor record-updater)

(define (make-record-type name field-names . rest)
(define (compute-field-map parent-size field-names)
(let loop ((index (+ parent-size 1))
        (field-names field-names)
     (field-map '()))
(if (null? field-names)
(reverse field-map)
(loop (+ index 1)
   (cdr field-names)
(cons `(,(car field-names) . ,index) field-map)))))
(let* ((nargs (length rest))
    (parent (if (= nargs 0) #f (car rest)))
 (print-proc (if (<= nargs 1) #f (cadr rest))))
(unless (<= nargs 2)
(error 'make-record-type (cddr rest) "Too many arguments"))
(let* ((parent-map (if parent (descriptor-all-field-map parent) '()))
    (parent-size (if parent (descriptor-size parent) 0))
 (field-map (compute-field-map parent-size field-names))
 (all-field-map (append parent-map field-map))
 (real-print-proc (or print-proc
                   (and parent (descriptor-print-proc parent))
                (default-printer name all-field-map)))
 (size (+ parent-size 1 (length field-names)))
 (new-cookie (cons real-print-proc size))
 (cookie-map (cons `(,new-cookie . ,parent-size)
                (if parent
                (descriptor-cookie-map parent)
             '()))))
(make-descriptor
name                ; name
size                ; size
field-map            ; field-map
all-field-map            ; all-field-map
(map cdr all-field-map)        ; indices
cookie-map            ; cookie-map
print-proc            ; print-proc
))))

(define (record-constructor descriptor)
(unless (descriptor? descriptor)
(error 'record-constructor descriptor "not a record-type descriptor"))
(let ((size (descriptor-size descriptor))
   (count (length (descriptor-all-field-map descriptor)))
(indices (descriptor-indices descriptor))
(cookie-map (descriptor-cookie-map descriptor))
(name (descriptor-name descriptor)))
(lambda args
"Record value constructor"
(unless (= count (length args))
(error (format #f "~S constructor" name) args
    "Wrong number of arguments"))
(let ((record (%make-record size)))
(let loop ((map cookie-map))
(unless (null? map)
(%record-set! record (cdar map) (caar map))
(loop (cdr map))))
(let loop ((args args)
        (indices indices))
(cond
((null? args)
record)
(else
(%record-set! record (car indices) (car args))
(loop (cdr args) (cdr indices)))))))))

(define (record-predicate descriptor)
(unless (descriptor? descriptor)
(error 'record-predicate descriptor "not a record-type descriptor"))
(let ((cookie-map (descriptor-cookie-map descriptor)))
(let ((size (descriptor-size descriptor))
   (cookie (caar cookie-map))
(index (cdar cookie-map)))
(lambda (value)
"Record type predicate"
(and (%record? value)
  (>= (%record-length value) size)
  (eq? (%record-ref value index) cookie))))))

(define (record-accessor descriptor field-name)
(unless (descriptor? descriptor)
(error 'record-accessor descriptor "not a record-type descriptor"))
(let ((pair (assq field-name (descriptor-field-map descriptor)))
   (cookie-map (descriptor-cookie-map descriptor))
(name (descriptor-name descriptor)))
(if (not pair)
(error 'record-accessor field-name "unrecognized field name")
(let ((index (cdr pair))
   (size (descriptor-size descriptor))
(cookie (caar cookie-map))
(cookie-index (cdar cookie-map)))
(lambda (record)
"Record field accessor"
(if (and (%record? record)
      (>= (%record-length record) size)
   (eq? (%record-ref record cookie-index) cookie))
(%record-ref record index)
(error (format #f "~S accessor for type ~S"
               field-name name)
 record
 (format #f "not a ~S record" name))))))))

(define (record-updater descriptor field-name)
(unless (descriptor? descriptor)
(error 'record-updater descriptor "not a record-type descriptor"))
(let ((pair (assq field-name (descriptor-field-map descriptor)))
   (cookie-map (descriptor-cookie-map descriptor))
(name (descriptor-name descriptor)))
(if (not pair)
(error 'record-updater field-name "unrecognized field name")
(let ((index (cdr pair))
   (size (descriptor-size descriptor))
(cookie (caar cookie-map))
(cookie-index (cdar cookie-map)))
(lambda (record value)
"Record field updater"
(if (and (%record? record)
      (>= (%record-length record) size)
   (eq? (%record-ref record cookie-index) cookie))
(%record-set! record index value)
(error (format #f "~S updater for type ~S"
               field-name name)
 record
 (format #f "not a ~S record" name))))))))

(define ((default-printer name all-field-map) port record display?)
(format port "#<~S" name)
(for-each (lambda (pair)
          (format port " ~S: ~S"
                    (car pair)
                 (%record-ref record (cdr pair))))
       all-field-map)
(display ">" port))

<<;;; Bootstrapping descriptors>>

<<(make-record-type 'descriptor '(>>
<<name        ; first arg to make-record-type for this descriptor>>
<<size        ; how many slots in the whole record, with cookies?>>
<<field-map    ; a-list mapping field names to slot indices (in order)>>
<<all-field-map    ; same, but including ancestor fields (parent first)>>
<<indices        ; (map cdr all-field-map)>>
<<cookie-map    ; list of pairs: (cookie index); gives cookie locations>>
<<        ;  in decreasing order of index (i.e., child first)>>
<<print-proc    ; client-defined print proc or #f>>
<<))>>

(define descriptor-cookie #f)

(define (make-descriptor name size field-map all-field-map
                      indices cookie-map print-proc)
(let ((record (%make-record 8)))
(%record-set! record 0 descriptor-cookie)
(%record-set! record 1 name)
(%record-set! record 2 size)
(%record-set! record 3 field-map)
(%record-set! record 4 all-field-map)
(%record-set! record 5 indices)
(%record-set! record 6 cookie-map)
(%record-set! record 7 print-proc)
record))

(define (descriptor? value)
(and (%record? value)
  (= 8 (%record-length value))
  (eq? (%record-ref value 0) descriptor-cookie)))

(define ((make-descriptor-accessor name index) record)
(if (descriptor? record)
(%record-ref record index)
(error (format #f "~S accessor for record-type descriptors" name)
    record
 "not a record-type descriptor")))

(define descriptor-name #f)
(define descriptor-size #f)
(define descriptor-field-map #f)
(define descriptor-all-field-map #f)
(define descriptor-indices #f)
(define descriptor-cookie-map #f)
(define descriptor-print-proc #f)

(define (print-descriptor port descriptor display?)
(format port "#<Record-type descriptor: ~S>"
          (descriptor-name descriptor)))

(set! descriptor-cookie (cons print-descriptor 8))

(set! descriptor-name (make-descriptor-accessor 'name 1))
(set! descriptor-size (make-descriptor-accessor 'size 2))
(set! descriptor-field-map (make-descriptor-accessor 'field-map 3))
(set! descriptor-all-field-map
        (make-descriptor-accessor 'all-field-map 4))
(set! descriptor-indices (make-descriptor-accessor 'indices 5))
(set! descriptor-cookie-map (make-descriptor-accessor 'cookie-map 6))
(set! descriptor-print-proc (make-descriptor-accessor 'print-proc 7))

) ; end export