120 lines
3.3 KiB
Scheme
120 lines
3.3 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
; This is file record.scm.
|
||
|
|
|
||
|
|
;;;; Records
|
||
|
|
|
||
|
|
; Every record in the image is assumed to be made either by
|
||
|
|
; make-record-type or by a procedure returned by record-constructor.
|
||
|
|
|
||
|
|
(define (record-type r)
|
||
|
|
(record-ref r 0))
|
||
|
|
|
||
|
|
(define *record-type-uid* -1)
|
||
|
|
(define *record-type* #f)
|
||
|
|
|
||
|
|
(define (make-record-type name field-names)
|
||
|
|
(set! *record-type-uid* (+ *record-type-uid* 1))
|
||
|
|
(let ((r (make-record 5 (unspecific))))
|
||
|
|
(record-set! r 0 *record-type*)
|
||
|
|
(record-set! r 1 *record-type-uid*)
|
||
|
|
(record-set! r 2 name)
|
||
|
|
(record-set! r 3 field-names)
|
||
|
|
(record-set! r 4 default-record-discloser)
|
||
|
|
r))
|
||
|
|
|
||
|
|
(define (record-type? obj)
|
||
|
|
(and (record? obj)
|
||
|
|
(eq? (record-type obj) *record-type*)))
|
||
|
|
|
||
|
|
(define (record-type-uid rt) (record-ref rt 1))
|
||
|
|
(define (record-type-name rt) (record-ref rt 2))
|
||
|
|
(define (record-type-field-names rt) (record-ref rt 3))
|
||
|
|
(define (record-type-discloser rt) (record-ref rt 4))
|
||
|
|
|
||
|
|
(define (record-field-index rt name)
|
||
|
|
(let loop ((names (record-type-field-names rt))
|
||
|
|
(i 1))
|
||
|
|
(cond ((null? names) (error "unknown field"
|
||
|
|
(record-type-name rt)
|
||
|
|
name))
|
||
|
|
((eq? name (car names))
|
||
|
|
i)
|
||
|
|
(else (loop (cdr names) (+ i 1))))))
|
||
|
|
|
||
|
|
(define (record-constructor rt names)
|
||
|
|
(let ((indexes (map (lambda (name)
|
||
|
|
(record-field-index rt name))
|
||
|
|
names))
|
||
|
|
(size (+ 1 (length (record-type-field-names rt)))))
|
||
|
|
(lambda args
|
||
|
|
(let ((r (make-record size (unspecific))))
|
||
|
|
(record-set! r 0 rt)
|
||
|
|
(let loop ((is indexes) (as args))
|
||
|
|
(if (null? as)
|
||
|
|
(if (null? is)
|
||
|
|
r
|
||
|
|
(error "too few arguments to record constructor"
|
||
|
|
rt names args))
|
||
|
|
(if (null? is)
|
||
|
|
(error "too many arguments to record constructor"
|
||
|
|
rt names args)
|
||
|
|
(begin (record-set! r (car is) (car as))
|
||
|
|
(loop (cdr is) (cdr as))))))))))
|
||
|
|
|
||
|
|
(define (record-accessor rt name)
|
||
|
|
(let ((index (record-field-index rt name))
|
||
|
|
(error-cruft `(record-accessor ,rt ',name)))
|
||
|
|
(lambda (r)
|
||
|
|
(if (eq? (record-type r) rt)
|
||
|
|
(record-ref r index)
|
||
|
|
(call-error "invalid record access" error-cruft r)))))
|
||
|
|
|
||
|
|
(define (record-modifier rt name)
|
||
|
|
(let ((index (record-field-index rt name))
|
||
|
|
(error-cruft `(record-modifier ,rt ',name)))
|
||
|
|
(lambda (r x)
|
||
|
|
(if (eq? (record-type r) rt)
|
||
|
|
(record-set! r index x)
|
||
|
|
(call-error "invalid record modification" error-cruft r x)))))
|
||
|
|
|
||
|
|
(define (record-predicate rt)
|
||
|
|
(lambda (x)
|
||
|
|
(and (record? x)
|
||
|
|
(eq? (record-type x) rt))))
|
||
|
|
|
||
|
|
; disclose-record calls the record's discloser procedure to obtain a list
|
||
|
|
; whose head is a string and whose tail is other stuff.
|
||
|
|
|
||
|
|
(define (define-record-discloser rt proc)
|
||
|
|
(if (and (record-type? rt)
|
||
|
|
(procedure? proc))
|
||
|
|
(record-set! rt 4 proc)
|
||
|
|
(call-error "invalid argument" define-record-discloser rt proc)))
|
||
|
|
|
||
|
|
(define (disclose-record r)
|
||
|
|
(if (record? r)
|
||
|
|
(let ((rt (record-type r)))
|
||
|
|
(if (record-type? rt)
|
||
|
|
(or ((record-type-discloser rt) r)
|
||
|
|
(list (record-type-name rt)))
|
||
|
|
#f)) ;Not one of ours.
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(define default-record-discloser
|
||
|
|
(lambda (r) #f))
|
||
|
|
|
||
|
|
; Patch
|
||
|
|
|
||
|
|
(set! *record-type*
|
||
|
|
(make-record-type 'record-type '(uid name field-names discloser)))
|
||
|
|
(record-set! *record-type* 0 *record-type*)
|
||
|
|
|
||
|
|
(define :record-type *record-type*)
|
||
|
|
|
||
|
|
(define-record-discloser :record-type
|
||
|
|
(lambda (rt)
|
||
|
|
(list 'record-type
|
||
|
|
(record-type-uid rt)
|
||
|
|
(record-type-name rt))))
|