Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

oops, fixing srfi-9

Browse source
This commit is contained in:
Alex Shinn 2010-09-16 00:04:35 +09:00
parent d9bdc5fb1a
commit 11e552576e
1 changed files with 35 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

69
lib/srfi/9.scm
View file

@ -17,7 +17,7 @@
(_type_slot_offset (rename 'type-slot-offset)))
`(,(rename 'begin)
;; type
(,_define ,name (,_register ,name-str ,parent ',fields))
(,_define ,name (,_register ,name-str ,parent ',(map car fields)))
;; predicate
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string (identifier->symbol pred))
@ -25,42 +25,43 @@
;; 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))))))
`(,_define ,(cadr f)
(,(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))))))
`(,_define ,(caddr f)
(,(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))))))))))))))
,(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 `(,(caddr field) res ,(car ls)) sets)))
(else
(lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
sets))))))))))))))