Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-06-08 03:45:04 +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

69
lib/srfi/9.scm
View file

@ -17,7 +17,7 @@
(_type_slot_offset (rename 'type-slot-offset))) (_type_slot_offset (rename 'type-slot-offset)))
`(,(rename 'begin) `(,(rename 'begin)
;; type ;; type
(,_define ,name (,_register ,name-str ,parent ',fields)) (,_define ,name (,_register ,name-str ,parent ',(map car fields)))
;; predicate ;; predicate
(,_define ,pred (,(rename 'make-type-predicate) (,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string (identifier->symbol pred)) ,(symbol->string (identifier->symbol pred))
@ -25,42 +25,43 @@
;; fields ;; fields
,@(map (lambda (f) ,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (and (pair? f) (pair? (cdr f))
`(,_define ,(cadar ls) `(,_define ,(cadr f)
(,(rename 'make-getter) (,(rename 'make-getter)
,(symbol->string ,(symbol->string
(identifier->symbol (cadr f))) (identifier->symbol (cadr f)))
,name ,name
(,_type_slot_offset ,name ,(car f)))))) (,_type_slot_offset ,name ',(car f))))))
fields) fields)
,@(map (lambda (f) ,@(map (lambda (f)
(and (pair? f) (pair? (cdr f)) (pair? (cddr f)) (and (pair? f) (pair? (cdr f)) (pair? (cddr f))
`(,_define ,(caddar ls) `(,_define ,(caddr f)
(,(rename 'make-setter) (,(rename 'make-setter)
,(symbol->string ,(symbol->string
(identifier->symbol (caddr f))) (identifier->symbol (caddr f)))
,name ,name
(,_type_slot_offset ,name ,(car f)))))) (,_type_slot_offset ,name ',(car f))))))
fields) fields)
;; constructor ;; constructor
(,_define ,make (,_define ,make
,(let lp ((ls make-fields) (sets '())) ,(let lp ((ls make-fields) (sets '()))
(cond (cond
((null? ls) ((null? ls)
`(,_let ((%make (,(rename 'make-constructor) `(,_let ((%make (,(rename 'make-constructor)
,(symbol->string (identifier->symbol make)) ,(symbol->string (identifier->symbol make))
,name))) ,name)))
(,_lambda ,make-fields (,_lambda ,make-fields
(,_let ((res (%make))) (,_let ((res (%make)))
,@sets ,@sets
res)))) res))))
(else (else
(let ((field (assq (car ls) fields))) (let ((field (assq (car ls) fields)))
(cond (cond
((not field) ((not field)
(error "unknown record field in constructor" (car ls))) (error "unknown record field in constructor" (car ls)))
((pair? (cddr field)) ((pair? (cddr field))
(lp (cdr ls) (lp (cdr ls)
(cons (list (caddr field) 'res (car ls)) sets))) (cons `(,(caddr field) res ,(car ls)) sets)))
(else (else
(lp (cdr ls) (lp (cdr ls)
(cons (list _slot-set! 'res (list 'quote (car ls)) (car ls)) sets)))))))))))))) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
sets))))))))))))))