[_CDCSL_93-16_]<1>Cedar>release>Scheme>Records.scheme

;;; Records.scheme

;;; 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