nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

define-record-type*: Add `letrec*' behavior. 

* guix/utils.scm (define-record-type*)[make-syntactic-constructor]: Bind
  all the ((FIELD VALUE) ...) in a `letrec*'.  Adjust `field-value'
  accordingly.

* tests/utils.scm ("define-record-type* with letrec* behavior"): New
  test.
master
Ludovic Courtès 2012-07-01 17:32:03 +02:00
parent e4c245f8a5
commit 8fd5bd2b69
2 changed files with 29 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
guix/utils.scm
View File

@ -479,20 +479,18 @@ tuples."
(lambda (s)
(syntax-case s expected
((_ (field value) (... ...))
(let ((fields (map syntax->datum #'(field (... ...))))
(inits (map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'((field value) (... ...))))
(dflt (map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'defaults)))
(let ((fields (map syntax->datum #'(field (... ...))))
(dflt (map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'defaults)))
(define (field-value f)
(match (assoc f inits)
((_ v) v)
(#f (car (assoc-ref dflt f)))))
(define (field-value f)
(or (and=> (find (lambda (x)
(eq? f (car (syntax->datum x))))
#'((field value) (... ...)))
car)
(car (assoc-ref dflt (syntax->datum f)))))
(let-syntax ((error*
(syntax-rules ()
@ -503,7 +501,8 @@ tuples."
s)))))
(let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected)
#`(ctor #,@(map field-value 'expected)))
#`(letrec* ((field value) (... ...))
(ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected))
(error* "extraneous field initializers ~a"
(lset-difference eq? fields 'expected)))

16
tests/utils.scm
View File

@ -112,6 +112,22 @@
(match (foo (bar 1))
(($ <foo> 1 42) #t)))))
(test-assert "define-record-type* with letrec* behavior"
;; Make sure field initializers can refer to each other as if they were in
;; a `letrec*'.
(begin
(define-record-type* <bar> bar make-bar
foo?
(x bar-x)
(y bar-y (default (+ 40 2)))
(z bar-z))
(and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
(($ <bar> 1 2 4) #t))
(match (bar (x 7) (z (* x 3)))
(($ <bar> 7 42 21)))
(match (bar (z 21) (x (/ z 3)))
(($ <bar> 7 42 21))))))
(test-end)