From 8fd5bd2b69b51e370144f26c01201a178c024483 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 1 Jul 2012 17:32:03 +0200
Subject: 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.
---
 guix/utils.scm  | 29 ++++++++++++++---------------
 tests/utils.scm | 16 ++++++++++++++++
 2 files changed, 30 insertions(+), 15 deletions(-)

diff --git a/guix/utils.scm b/guix/utils.scm
index ed13bae307..3d92bac9cc 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -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)))
-
-                   (define (field-value f)
-                     (match (assoc f inits)
-                       ((_ v) v)
-                       (#f (car (assoc-ref dflt f)))))
+                 (let ((fields (map syntax->datum #'(field (... ...))))
+                       (dflt   (map (match-lambda
+                                     ((f v)
+                                      (list (syntax->datum f) v)))
+                                    #'defaults)))
+
+                    (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)))
diff --git a/tests/utils.scm b/tests/utils.scm
index 83a78b7a78..4a24e23df9 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -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)
 
 
-- 
cgit v1.2.3