mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-21 14:49:18 +02:00
85 lines
3.8 KiB
Text
85 lines
3.8 KiB
Text
|
|
(define-module (srfi 9)
|
|
(export define-record-type)
|
|
(import-immutable (scheme))
|
|
(body
|
|
(define-syntax define-record-type
|
|
(er-macro-transformer
|
|
(lambda (expr rename compare)
|
|
(let* ((name (cadr expr))
|
|
(name-str (symbol->string (identifier->symbol name)))
|
|
(make (caaddr expr))
|
|
(make-fields (cdaddr expr))
|
|
(pred (cadddr expr))
|
|
(fields (cddddr expr))
|
|
(num-fields (length fields))
|
|
(index (register-simple-type name-str num-fields))
|
|
(_define (rename 'define))
|
|
(_lambda (rename 'lambda))
|
|
(_let (rename 'let)))
|
|
(define (index-of field ls)
|
|
(let lp ((ls ls) (i 0))
|
|
(if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
|
|
`(,(rename 'begin)
|
|
(,_define ,pred (,(rename 'make-type-predicate)
|
|
,(symbol->string (identifier->symbol pred))
|
|
,index))
|
|
,@(let lp ((ls fields) (i 0) (res '()))
|
|
(if (null? ls)
|
|
res
|
|
(let ((res
|
|
(cons `(,_define ,(cadar ls)
|
|
(,(rename 'make-getter)
|
|
,(symbol->string
|
|
(identifier->symbol (cadar ls)))
|
|
,index
|
|
,i))
|
|
res)))
|
|
(lp (cdr ls)
|
|
(+ i 1)
|
|
(if (pair? (cddar ls))
|
|
(cons
|
|
`(,_define ,(caddar ls)
|
|
(,(rename 'make-setter)
|
|
,(symbol->string
|
|
(identifier->symbol (caddar ls)))
|
|
,index
|
|
,i))
|
|
res)
|
|
res)))))
|
|
(,_define ,make
|
|
,(let lp ((ls make-fields) (sets '()) (set-defs '()))
|
|
(cond
|
|
((null? ls)
|
|
`(,_let ((%make (,(rename 'make-constructor)
|
|
,(symbol->string (identifier->symbol make))
|
|
,index))
|
|
,@set-defs)
|
|
(,_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)
|
|
set-defs))
|
|
(else
|
|
(let* ((setter-name
|
|
(string-append "%" name-str "-"
|
|
(symbol->string (car ls)) "-set!"))
|
|
(setter (rename (string->symbol setter-name)))
|
|
(i (index-of (car ls) fields)))
|
|
(lp (cdr ls)
|
|
(cons (list setter 'res (car ls)) sets)
|
|
(cons (list setter
|
|
(list (rename 'make-setter)
|
|
setter-name
|
|
index
|
|
(index-of (car ls) fields)))
|
|
set-defs)))))))))))))))))
|
|
|