Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +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

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

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

6
tests/record-tests.scm
View file

@ -177,4 +177,10 @@
(define point-x (rtd-accessor point 'x)) (define point-x (rtd-accessor point 'x))
(test 3 (point-x (make-point 3 2))) (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) (test-end)