aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/records.scm24
-rw-r--r--tests/records.scm40
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