ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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.
This commit is contained in:
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 @@ (define (make-syntactic-constructor name ctor fields defaults)
(lambda (s) (lambda (s)
(syntax-case s expected (syntax-case s expected
((_ (field value) (... ...)) ((_ (field value) (... ...))
(let ((fields (map syntax->datum #'(field (... ...)))) (let ((fields (map syntax->datum #'(field (... ...))))
(inits (map (match-lambda (dflt (map (match-lambda
((f v) ((f v)
(list (syntax->datum f) v))) (list (syntax->datum f) v)))
#'((field value) (... ...)))) #'defaults)))
(dflt (map (match-lambda
((f v)
(list (syntax->datum f) v)))
#'defaults)))
(define (field-value f) (define (field-value f)
(match (assoc f inits) (or (and=> (find (lambda (x)
((_ v) v) (eq? f (car (syntax->datum x))))
(#f (car (assoc-ref dflt f))))) #'((field value) (... ...)))
car)
(car (assoc-ref dflt (syntax->datum f)))))
(let-syntax ((error* (let-syntax ((error*
(syntax-rules () (syntax-rules ()
@ -503,7 +501,8 @@ (define (field-value f)
s))))) s)))))
(let ((fields (append fields (map car dflt)))) (let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected) (cond ((lset= eq? fields 'expected)
#`(ctor #,@(map field-value 'expected))) #`(letrec* ((field value) (... ...))
(ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected)) ((pair? (lset-difference eq? fields 'expected))
(error* "extraneous field initializers ~a" (error* "extraneous field initializers ~a"
(lset-difference eq? fields 'expected))) (lset-difference eq? fields 'expected)))

16
tests/utils.scm
View file

@ -112,6 +112,22 @@ (define-record-type* <foo> foo make-foo
(match (foo (bar 1)) (match (foo (bar 1))
(($ <foo> 1 42) #t))))) (($ <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) (test-end)