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

Need to rename field parameter names in record constructors.

Browse source
This commit is contained in:
Alex Shinn 2012-07-16 22:49:48 +09:00
parent 35226238ed
commit 0553dd41b9
2 changed files with 32 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

52
lib/srfi/99/records/syntactic.scm
View file

@ -19,6 +19,7 @@
(fields (cddr procs))
(field-names (map (lambda (x) (if (pair? x) (car x) x)) fields))
(make-fields (if (pair? make) (cdr make) (and (not parent) field-names)))
(_make (rename '%make))
(_define (rename 'define))
(_lambda (rename 'lambda))
(_let (rename 'let))
@ -66,34 +67,33 @@
fields)
;; constructor
,(if make-fields
(let ((fields (map (lambda (f) (cons (rename f) f)) make-fields)))
`(,_define ,make-name
,(let lp ((ls fields) (sets '()))
(cond
((null? ls)
`(,_let ((,_make (,(rename 'make-constructor)
,(id->string make-name)
,name)))
(,_lambda ,(map car fields)
(,_let ((res (,_make)))
,@sets
res))))
(else
(let ((field (assq (cdar ls) fields)))
(cond
((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
(lp (cdr ls)
(cons (list (car (cddr field)) 'res (cdar ls)) sets)))
(else
(lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(cdar ls)) ,(caar ls)) sets))))))))))
`(,_define ,make-name
,(let lp ((ls make-fields) (sets '()))
(cond
((null? ls)
`(,_let ((%make (,(rename 'make-constructor)
,(id->string make-name)
,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)))
((and (pair? field) (pair? (cdr field)) (pair? (cddr field)))
(lp (cdr ls)
(cons (list (car (cddr field)) 'res (car ls)) sets)))
(else
(lp (cdr ls)
(cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls)) sets)))))))))
`(,_define ,make-name
(,_let ((%make (,(rename 'make-constructor)
,(id->string make-name)
,name)))
(,_let ((,_make (,(rename 'make-constructor)
,(id->string make-name)
,name)))
(,_lambda args
(,_let ((res (%make)))
(,_let ((res (,_make)))
(let lp ((a args)
(p (,_vector->list (,_rtd-all-field-names ,name))))
(cond

6
tests/record-tests.scm
View file

@ -177,4 +177,10 @@
(define point-x (rtd-accessor point 'x))
(test 3 (point-x (make-point 3 2)))
;; Name conflicts - make sure we rename
(define-record-type example make-example #t example)
(test-assert (example? (make-example 3)))
(test 3 (example-example (make-example 3)))
(test-end)