70 lines
2.4 KiB
Scheme
70 lines
2.4 KiB
Scheme
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
; Same as jar-defrecord.scm, but field access is "optimized" in a
|
||
|
|
; brutally unmodular way. The accessors and modifiers are easily
|
||
|
|
; recognized as inlinable because instead of being produced by the
|
||
|
|
; usual record-accessor and record-modifier combinators, they're
|
||
|
|
; defined directly as procedures that do record-ref and record-set!
|
||
|
|
; with constant indexes. There is no check to make sure that the
|
||
|
|
; record is a record of the correct type.
|
||
|
|
|
||
|
|
; Since the record types are not checked at run time, we use LOOPHOLE
|
||
|
|
; to at least try to get a little bit of compile-time checking.
|
||
|
|
|
||
|
|
(define-syntax define-record-type ;same as in jar-defrecord.scm
|
||
|
|
(syntax-rules ()
|
||
|
|
((define-record-type ?id ?type
|
||
|
|
(?constructor ?arg ...)
|
||
|
|
(?field . ?field-stuff)
|
||
|
|
...)
|
||
|
|
(begin (define ?type (make-record-type '?id '(?field ...)))
|
||
|
|
(define-constructor ?constructor ?type (?arg :value) ...)
|
||
|
|
(define-accessors ?type (?field . ?field-stuff) ...)))
|
||
|
|
((define-record-type ?id ?type
|
||
|
|
(?constructor ?arg ...)
|
||
|
|
?pred
|
||
|
|
?more ...)
|
||
|
|
(begin (define-record-type ?id ?type
|
||
|
|
(?constructor ?arg ...)
|
||
|
|
?more ...)
|
||
|
|
(define ?pred (record-predicate ?type))))))
|
||
|
|
|
||
|
|
(define-syntax define-constructor
|
||
|
|
(syntax-rules ()
|
||
|
|
((define-constructor ?constructor ?type (?arg ?arg-type) ...)
|
||
|
|
(define ?constructor
|
||
|
|
(loophole (proc (?arg-type ...) ?type)
|
||
|
|
(record-constructor ?type '(?arg ...)))))))
|
||
|
|
|
||
|
|
(define-syntax define-accessors
|
||
|
|
(lambda (e r c)
|
||
|
|
(let ((%define-accessor (r 'define-accessor))
|
||
|
|
(%begin (r 'begin))
|
||
|
|
(type (cadr e))
|
||
|
|
(field-specs (cddr e)))
|
||
|
|
(do ((i 1 (+ i 1))
|
||
|
|
(field-specs field-specs (cdr field-specs))
|
||
|
|
(ds '()
|
||
|
|
(cons `(,%define-accessor ,type ,i ,@(cdar field-specs))
|
||
|
|
ds)))
|
||
|
|
((null? field-specs)
|
||
|
|
`(,%begin ,@ds)))))
|
||
|
|
(define-accessor begin))
|
||
|
|
|
||
|
|
(define-syntax define-accessor
|
||
|
|
(syntax-rules ()
|
||
|
|
((define-accessor ?type ?index ?accessor)
|
||
|
|
(define ?accessor
|
||
|
|
(loophole (proc (?type) :value)
|
||
|
|
(lambda (r)
|
||
|
|
(record-ref (loophole :record r) ?index)))))
|
||
|
|
((define-accessor ?type ?index ?accessor ?modifier)
|
||
|
|
(begin (define-accessor ?type ?index ?accessor)
|
||
|
|
(define ?modifier
|
||
|
|
(loophole (proc (?type :value) :unspecific)
|
||
|
|
(lambda (r new)
|
||
|
|
(record-set! (loophole :record r) ?index new))))))
|
||
|
|
((define-accessor ?type ?index)
|
||
|
|
(begin))))
|