mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
52 lines
2.1 KiB
Scheme
52 lines
2.1 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; binary records, simpler version with type-checking on set! removed
|
|
|
|
(define-syntax defrec
|
|
(syntax-rules (make: pred: read: write: block:)
|
|
((defrec () n m p r w
|
|
((field-tmp field-read field-read-expr field-write field-write-expr field-get) ...)
|
|
((field getter . s) ...))
|
|
(begin
|
|
(define-record-type n (m field ...) p
|
|
(field getter . s) ...)
|
|
(define n 'n) ; chicken define-record-type doesn't define the rtd
|
|
(define r
|
|
(let ((field-read field-read-expr) ...)
|
|
(lambda (in)
|
|
(let* ((field-tmp (field-read in)) ...)
|
|
(m field ...)))))
|
|
(define w
|
|
(let ((field-write field-write-expr) ...)
|
|
(lambda (x out)
|
|
(field-write (field-get x) out) ...)))))
|
|
((defrec ((make: x) . rest) n m p r w b f)
|
|
(defrec rest n x p r w b f))
|
|
((defrec ((pred: x) . rest) n m p r w b f)
|
|
(defrec rest n m x r w b f))
|
|
((defrec ((read: x) . rest) n m p r w b f)
|
|
(defrec rest n m p x w b f))
|
|
((defrec ((write: x) . rest) n m p r w b f)
|
|
(defrec rest n m p r x b f))
|
|
((defrec ((block: (field (type . args) getter . s) . fields) . rest) n m p r w
|
|
(b ...) (f ...))
|
|
(defrec ((block: . fields) . rest) n m p r w
|
|
(b ...
|
|
(field read-tmp (type read: args) write-tmp (type write: args) getter))
|
|
(f ...
|
|
(field getter . s))))
|
|
((defrec ((block: (field . x)) . rest) n m p r w b f)
|
|
(syntax-error "invalid field in block" (field . x)))
|
|
((defrec ((block: data . fields) . rest) n m p r w (b ...) f)
|
|
(defrec ((block: . fields) . rest) n m p r w
|
|
(b ...
|
|
(tmp-data read-tmp (read-literal 'data) write-tmp (write-literal 'data) (lambda (x) x)))
|
|
f))
|
|
((defrec ((block:) . rest) n m p r w b f)
|
|
(defrec rest n m p r w b f))
|
|
))
|
|
|
|
(define-syntax define-binary-record-type
|
|
(syntax-rules ()
|
|
((define-binary-record-type name x ...)
|
|
(defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
|
|
() ()))))
|