gnu: linux-libre@4.14: Update to 4.14.198.

[jackhill/guix/guix.git] / guix / records.scm

diff --git a/guix/records.scm b/guix/records.scm
index 244b124..3d54a51 100644 (file)
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -24,6 +24,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 rdelim)
+  #:autoload (system base target) (target-most-positive-fixnum)
   #:export (define-record-type*
             this-record
 
@@ -70,14 +71,22 @@ interface\" (ABI) for TYPE is equal to COOKIE."
                  "~a: record ABI mismatch; recompilation needed"
                  (list #,type) '()))))
 
-  (define (report-invalid-field-specifier name bindings)
-    "Report the first invalid binding among BINDINGS."
+  (define* (report-invalid-field-specifier name bindings
+                                           #:optional parent-form)
+    "Report the first invalid binding among BINDINGS.  PARENT-FORM is used for
+error-reporting purposes."
     (let loop ((bindings bindings))
       (syntax-case bindings ()
         (((field value) rest ...)                   ;good
          (loop #'(rest ...)))
         ((weird _ ...)                              ;weird!
-         (syntax-violation name "invalid field specifier" #'weird)))))
+         ;; WEIRD may be an identifier, thus lacking source location info, and
+         ;; BINDINGS is a list, also lacking source location info.  Hopefully
+         ;; PARENT-FORM provides source location info.
+         (apply syntax-violation name "invalid field specifier"
+                (if parent-form
+                    (list parent-form #'weird)
+                    (list #'weird)))))))
 
   (define (report-duplicate-field-specifier name ctor)
     "Report the first duplicate identifier among the bindings in CTOR."
@@ -118,6 +127,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)
@@ -162,7 +172,7 @@ of TYPE matches the expansion-time ABI."
          (define (wrap-field-value f value)
            (cond ((thunked-field? f)
                   #`(lambda (x)
-                      (syntax-parameterize ((this-record
+                      (syntax-parameterize ((#,this-identifier
                                              (lambda (s)
                                                (syntax-case s ()
                                                  (id
@@ -232,7 +242,8 @@ of TYPE matches the expansion-time ABI."
             ;; Report precisely which one is faulty, instead of letting the
             ;; "source expression failed to match any pattern" error.
             (report-invalid-field-specifier 'name
-                                            #'(bindings (... ...))))))))))
+                                            #'(bindings (... ...))
+                                            s))))))))
 
 (define-syntax-rule (define-field-property-predicate predicate property)
   "Define PREDICATE as a procedure that takes a syntax object and, when passed
@@ -254,6 +265,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))
@@ -273,7 +285,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.
@@ -348,11 +361,15 @@ inherited."
         (((field get properties ...) ...)
          (string-hash (object->string
                        (syntax->datum #'((field properties ...) ...)))
-                      most-positive-fixnum))))
+                      (cond-expand
+                        (guile-3 (target-most-positive-fixnum))
+                        (else most-positive-fixnum))))))
 
     (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))
@@ -381,15 +398,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 '()))