[bug#34948] [PATCH 1/3] records: Allow thunked fields to refer to 'this-record'.

[Ludovic Courtès]

* guix/records.scm (this-record): New syntax parameter.
(make-syntactic-constructor)[wrap-field-value]: When F is thunked,
return a one-argument lambda instead of a thunk, and parameterize
THIS-RECORD.
(define-record-type*)[thunked-field-accessor-definition]: Pass X
to (real-get X).
* tests/records.scm ("define-record-type* & thunked & this-record")
("define-record-type* & thunked & default & this-record")
("define-record-type* & thunked & inherit & this-record"): New tests.
---
 guix/records.scm  | 24 ++++++++++++++++++++++--
 tests/records.scm | 40 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 62 insertions(+), 2 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index 0649c90ea3..244b124098 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -25,6 +25,8 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 rdelim)
   #:export (define-record-type*
+            this-record
+
             alist->record
             object->fields
             recutils->alist
@@ -93,6 +95,17 @@ interface\" (ABI) for TYPE is equal to COOKIE."
            (()
             #t)))))))
 
+(define-syntax-parameter this-record
+  (lambda (s)
+    "Return the record being defined.  This macro may only be used in the
+context of the definition of a thunked field."
+    (syntax-case s ()
+      (id
+       (identifier? #'id)
+       (syntax-violation 'this-record
+                         "cannot be used outside of a record instantiation"
+                         #'id)))))
+
 (define-syntax make-syntactic-constructor
   (syntax-rules ()
     "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
@@ -148,7 +161,14 @@ of TYPE matches the expansion-time ABI."
 
          (define (wrap-field-value f value)
            (cond ((thunked-field? f)
-                  #`(lambda () #,value))
+                  #`(lambda (x)
+                      (syntax-parameterize ((this-record
+                                             (lambda (s)
+                                               (syntax-case s ()
+                                                 (id
+                                                  (identifier? #'id)
+                                                  #'x)))))
+                        #,value)))
                  ((delayed-field? f)
                   #`(delay #,value))
                  (else value)))
@@ -308,7 +328,7 @@ inherited."
          (with-syntax ((real-get (wrapped-field-accessor-name field)))
            #'(define-inlinable (get x)
                ;; The real value of that field is a thunk, so call it.
-               ((real-get x)))))))
+               ((real-get x) x))))))
 
     (define (delayed-field-accessor-definition field)
       ;; Return the real accessor for FIELD, which is assumed to be a
diff --git a/tests/records.scm b/tests/records.scm
index d9469a78bd..45614093a0 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -170,6 +170,46 @@
            (parameterize ((mark (cons 'a 'b)))
              (eq? (foo-bar y) (mark)))))))
 
+(test-assert "define-record-type* & thunked & this-record"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (thunked)))
+
+    (let ((x (foo (bar 40)
+                  (baz (+ (foo-bar this-record) 2)))))
+      (and (= 40 (foo-bar x))
+           (= 42 (foo-baz x))))))
+
+(test-assert "define-record-type* & thunked & default & this-record"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (thunked)
+           (default (+ (foo-bar this-record) 2))))
+
+    (let ((x (foo (bar 40))))
+      (and (= 40 (foo-bar x))
+           (= 42 (foo-baz x))))))
+
+(test-assert "define-record-type* & thunked & inherit & this-record"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (thunked)
+           (default (+ (foo-bar this-record) 2))))
+
+    (let* ((x (foo (bar 40)))
+           (y (foo (inherit x) (bar -2)))
+           (z (foo (inherit x) (baz -2))))
+      (and (= -2 (foo-bar y))
+           (=  0 (foo-baz y))
+           (= 40 (foo-bar z))
+           (= -2 (foo-baz z))))))
+
 (test-assert "define-record-type* & delayed"
   (begin
     (define-record-type* <foo> foo make-foo
-- 
2.21.0