Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-06-09 12:25:05 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

preserving hygienie in define-record-type

Browse source
This commit is contained in:
Alex Shinn 2016-06-18 23:02:25 +09:00
parent 99b39a183f
commit b88f13ef4a
1 changed files with 13 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
lib/srfi/9.scm
View file

@ -16,13 +16,14 @@
(_let (rename 'let)) (_let (rename 'let))
(_register (rename 'register-simple-type)) (_register (rename 'register-simple-type))
(_slot-set! (rename 'slot-set!)) (_slot-set! (rename 'slot-set!))
(_type_slot_offset (rename 'type-slot-offset))) (_type_slot_offset (rename 'type-slot-offset))
(q (rename 'syntax-quote)))
;; catch a common mistake ;; catch a common mistake
(if (eq? name make) (if (eq? name make)
(error "same binding for record rtd and constructor" name)) (error "same binding for record rtd and constructor" name))
`(,(rename 'begin) `(,(rename 'begin)
;; type ;; type
(,_define ,name (,_register ,name-str ,parent ',(map car fields))) (,_define ,name (,_register ,name-str ,parent (,q ,(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))
@ -35,7 +36,7 @@
,(symbol->string ,(symbol->string
(identifier->symbol (cadr f))) (identifier->symbol (cadr f)))
,name ,name
(,_type_slot_offset ,name ',(car f)))))) (,_type_slot_offset ,name (,q ,(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))
@ -44,7 +45,7 @@
,(symbol->string ,(symbol->string
(identifier->symbol (car (cddr f)))) (identifier->symbol (car (cddr f))))
,name ,name
(,_type_slot_offset ,name ',(car f)))))) (,_type_slot_offset ,name (,q ,(car f)))))))
fields) fields)
;; constructor ;; constructor
(,_define ,make (,_define ,make
@ -59,14 +60,16 @@
,@sets ,@sets
res)))) res))))
(else (else
(let ((field (assq (car ls) fields))) (let lp2 ((f fields))
(cond (cond
((not field) ((null? f)
(error "unknown record field in constructor" (car ls))) (error "unknown record field in constructor" (car ls) fields))
((pair? (cddr field)) ((not (compare (car ls) (caar f)))
(lp2 (cdr f)))
((pair? (cddr (car f)))
(lp (cdr ls) (lp (cdr ls)
(cons `(,(car (cddr field)) res ,(car ls)) sets))) (cons `(,(car (cddr (car f))) res ,(car ls)) sets)))
(else (else
(lp (cdr ls) (lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) (cons `(,_slot-set! ,name res (,_type_slot_offset ,name (,q ,(car ls))) ,(car ls))
sets)))))))))))))) sets))))))))))))))