110 lines
3.5 KiB
Scheme
110 lines
3.5 KiB
Scheme
(define-library (picrin record)
|
|
(import (picrin base)
|
|
(picrin macro))
|
|
|
|
;; define-record-writer
|
|
|
|
(define (set-record-writer! record-type writer)
|
|
(record-set! record-type 'writer writer))
|
|
|
|
(define-syntax define-record-writer
|
|
(er-macro-transformer
|
|
(lambda (form r compare)
|
|
(let ((formal (cadr form)))
|
|
(if (pair? formal)
|
|
`(,(r 'set-record-writer!) ,(car formal)
|
|
(,(r 'lambda) (,(cadr formal))
|
|
,@(cddr form)))
|
|
`(,(r 'set-record-writer!) ,formal
|
|
,@(cddr form)))))))
|
|
|
|
;; define-record-type
|
|
|
|
(define ((default-record-writer ctor) obj)
|
|
(let ((port (open-output-string)))
|
|
(display "#.(" port)
|
|
(display (car ctor) port)
|
|
(for-each
|
|
(lambda (field)
|
|
(display " " port)
|
|
(write (record-ref obj field) port))
|
|
(cdr ctor))
|
|
(display ")" port)
|
|
(get-output-string port)))
|
|
|
|
(define ((boot-make-record-type <meta-type>) name ctor)
|
|
(let ((rectype (make-record <meta-type>)))
|
|
(record-set! rectype 'name name)
|
|
(record-set! rectype 'writer (default-record-writer ctor))
|
|
rectype))
|
|
|
|
(define <record-type>
|
|
(let ((<record-type>
|
|
((boot-make-record-type #t) 'record-type '(record-type name writer))))
|
|
(record-set! <record-type> '@@type <record-type>)
|
|
<record-type>))
|
|
|
|
(define make-record-type (boot-make-record-type <record-type>))
|
|
|
|
(define-syntax define-record-constructor
|
|
(ir-macro-transformer
|
|
(lambda (form inject compare?)
|
|
(let ((rectype (car (cdr form)))
|
|
(name (car (cdr (cdr form))))
|
|
(fields (cdr (cdr (cdr form)))))
|
|
`(define (,name ,@fields)
|
|
(let ((record (make-record ,rectype)))
|
|
,@(map (lambda (field)
|
|
`(record-set! record ',field ,field))
|
|
fields)
|
|
record))))))
|
|
|
|
(define-syntax define-record-predicate
|
|
(ir-macro-transformer
|
|
(lambda (form inject compare?)
|
|
(let ((rectype (car (cdr form)))
|
|
(name (car (cdr (cdr form)))))
|
|
`(define (,name obj)
|
|
(and (record? obj)
|
|
(eq? (record-type obj)
|
|
,rectype)))))))
|
|
|
|
(define-syntax define-record-field
|
|
(ir-macro-transformer
|
|
(lambda (form inject compare?)
|
|
(let ((pred (car (cdr form)))
|
|
(field-name (car (cdr (cdr form))))
|
|
(accessor (car (cdr (cdr (cdr form)))))
|
|
(modifier? (cdr (cdr (cdr (cdr form))))))
|
|
(if (null? modifier?)
|
|
`(define (,accessor record)
|
|
(if (,pred record)
|
|
(record-ref record ',field-name)
|
|
(error (string-append (symbol->string ',accessor) ": wrong record type") record)))
|
|
`(begin
|
|
(define (,accessor record)
|
|
(if (,pred record)
|
|
(record-ref record ',field-name)
|
|
(error (string-append (symbol->string ',accessor) ": wrong record type") record)))
|
|
(define (,(car modifier?) record val)
|
|
(if (,pred record)
|
|
(record-set! record ',field-name val)
|
|
(error (string-append (symbol->string ',(car modifier?)) ": wrong record type") record)))))))))
|
|
|
|
(define-syntax define-record-type
|
|
(ir-macro-transformer
|
|
(lambda (form inject compare?)
|
|
(let ((name (car (cdr form)))
|
|
(ctor (car (cdr (cdr form))))
|
|
(pred (car (cdr (cdr (cdr form)))))
|
|
(fields (cdr (cdr (cdr (cdr form))))))
|
|
`(begin
|
|
(define ,name (make-record-type ',name ',ctor))
|
|
(define-record-constructor ,name ,@ctor)
|
|
(define-record-predicate ,name ,pred)
|
|
,@(map (lambda (field) `(define-record-field ,pred ,@field))
|
|
fields))))))
|
|
|
|
(export define-record-type
|
|
define-record-writer))
|