mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
66 lines
3 KiB
Scheme
66 lines
3 KiB
Scheme
|
|
(define-syntax define-record-type
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let* ((name (if (pair? (cadr expr)) (caadr expr) (cadr expr)))
|
|
(parent (and (pair? (cadr expr)) (cadadr expr)))
|
|
(name-str (symbol->string (identifier->symbol name)))
|
|
(make (caaddr expr))
|
|
(make-fields (cdaddr expr))
|
|
(pred (cadddr expr))
|
|
(fields (cddddr expr))
|
|
(_define (rename 'define))
|
|
(_lambda (rename 'lambda))
|
|
(_let (rename 'let))
|
|
(_register (rename 'register-simple-type))
|
|
(_slot-set! (rename 'slot-set!))
|
|
(_type_slot_offset (rename 'type-slot-offset)))
|
|
`(,(rename 'begin)
|
|
;; type
|
|
(,_define ,name (,_register ,name-str ,parent ',fields))
|
|
;; predicate
|
|
(,_define ,pred (,(rename 'make-type-predicate)
|
|
,(symbol->string (identifier->symbol pred))
|
|
,name))
|
|
;; fields
|
|
,@(map (lambda (f)
|
|
(and (pair? f) (pair? (cdr f))
|
|
`(,_define ,(cadar ls)
|
|
(,(rename 'make-getter)
|
|
,(symbol->string
|
|
(identifier->symbol (cadr f)))
|
|
,name
|
|
(,_type_slot_offset ,name ,(car f))))))
|
|
fields)
|
|
,@(map (lambda (f)
|
|
(and (pair? f) (pair? (cdr f)) (pair? (cddr f))
|
|
`(,_define ,(caddar ls)
|
|
(,(rename 'make-setter)
|
|
,(symbol->string
|
|
(identifier->symbol (caddr f)))
|
|
,name
|
|
(,_type_slot_offset ,name ,(car f))))))
|
|
fields)
|
|
;; constructor
|
|
(,_define ,make
|
|
,(let lp ((ls make-fields) (sets '()))
|
|
(cond
|
|
((null? ls)
|
|
`(,_let ((%make (,(rename 'make-constructor)
|
|
,(symbol->string (identifier->symbol make))
|
|
,name)))
|
|
(,_lambda ,make-fields
|
|
(,_let ((res (%make)))
|
|
,@sets
|
|
res))))
|
|
(else
|
|
(let ((field (assq (car ls) fields)))
|
|
(cond
|
|
((not field)
|
|
(error "unknown record field in constructor" (car ls)))
|
|
((pair? (cddr field))
|
|
(lp (cdr ls)
|
|
(cons (list (caddr field) 'res (car ls)) sets)))
|
|
(else
|
|
(lp (cdr ls)
|
|
(cons (list _slot-set! 'res (list 'quote (car ls)) (car ls)) sets))))))))))))))
|