From abd4d6b33dba4de228e90ad15a8efb456fcf7b6e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 22 Mar 2019 14:02:00 +0100
Subject: records: Allow thunked fields to refer to 'this-record'.

* 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.
---
 tests/records.scm | 40 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 40 insertions(+)

(limited to 'tests/records.scm')

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
-- 
cgit v1.2.3