Merge branch 'master' into staging

1 files changed, 50 insertions, 4 deletions

diff --git a/guix/records.scm b/guix/records.scm
index 0649c90ea3..99507dc384 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
@@ -105,6 +118,7 @@ of TYPE matches the expansion-time ABI."
     ((_ type name ctor (expected ...)
         #:abi-cookie abi-cookie
         #:thunked thunked
+        #:this-identifier this-identifier
         #:delayed delayed
         #:innate innate
         #:defaults defaults)
@@ -148,7 +162,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-identifier
+                                             (lambda (s)
+                                               (syntax-case s ()
+                                                 (id
+                                                  (identifier? #'id)
+                                                  #'x)))))
+                        #,value)))
                  ((delayed-field? f)
                   #`(delay #,value))
                  (else value)))
@@ -234,6 +255,7 @@ may look like this:
 
   (define-record-type* <thing> thing make-thing
     thing?
+    this-thing
     (name  thing-name (default \"chbouib\"))
     (port  thing-port
            (default (current-output-port)) (thunked))
@@ -253,7 +275,8 @@ default value specified in the 'define-record-type*' form is used:
 
 The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
 actually compute the field's value in the current dynamic extent, which is
-useful when referring to fluids in a field's value.
+useful when referring to fluids in a field's value.  Furthermore, that thunk
+can access the record it belongs to via the 'this-thing' identifier.
 
 A field can also be marked as \"delayed\" instead of \"thunked\", in which
 case its value is effectively wrapped in a (delay …) form.
@@ -308,7 +331,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
@@ -332,7 +355,9 @@ inherited."
 
     (syntax-case s ()
       ((_ type syntactic-ctor ctor pred
+          this-identifier
           (field get properties ...) ...)
+       (identifier? #'this-identifier)
        (let* ((field-spec #'((field get properties ...) ...))
               (thunked    (filter-map thunked-field? field-spec))
               (delayed    (filter-map delayed-field? field-spec))
@@ -361,15 +386,36 @@ inherited."
                  field-spec* ...)
                (define #,(current-abi-identifier #'type)
                  #,cookie)
+
+               #,@(if (free-identifier=? #'this-identifier #'this-record)
+                      #'()
+                      #'((define-syntax-parameter this-identifier
+                           (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-identifier
+                                                  "cannot be used outside \
+of a record instantiation"
+                                                  #'id)))))))
                thunked-field-accessor ...
                delayed-field-accessor ...
                (make-syntactic-constructor type syntactic-ctor ctor
                                            (field ...)
                                            #:abi-cookie #,cookie
                                            #:thunked #,thunked
+                                           #:this-identifier #'this-identifier
                                            #:delayed #,delayed
                                            #:innate #,innate
-                                           #:defaults #,defaults))))))))
+                                           #:defaults #,defaults)))))
+      ((_ type syntactic-ctor ctor pred
+          (field get properties ...) ...)
+       ;; When no 'this' identifier was specified, use 'this-record'.
+       #'(define-record-type* type syntactic-ctor ctor pred
+           this-record
+           (field get properties ...) ...)))))
 
 (define* (alist->record alist make keys
                         #:optional (multiple-value-keys '()))