gnu: linux-libre@4.14: Update to 4.14.198.
[jackhill/guix/guix.git] / guix / records.scm
index da3ecda..3d54a51 100644 (file)
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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.
 ;;;
   #: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
+
             alist->record
             object->fields
             recutils->alist
                        (format #f fmt args ...)
                        form))))
 
-(define (report-invalid-field-specifier name bindings)
-  "Report the first invalid binding among BINDINGS."
-  (let loop ((bindings bindings))
-    (syntax-case bindings ()
-      (((field value) rest ...)                   ;good
-       (loop #'(rest ...)))
-      ((weird _ ...)                              ;weird!
-       (syntax-violation name "invalid field specifier" #'weird)))))
-
-(define (print-record-abi-mismatch-error port key args
-                                         default-printer)
-  (match args
-    ((rtd . _)
-     ;; The source file where this exception is thrown must be recompiled.
-     (format port "ERROR: ~a: record ABI mismatch; recompilation needed"
-             rtd))))
-
-(set-exception-printer! 'record-abi-mismatch-error
-                        print-record-abi-mismatch-error)
-
 (eval-when (expand load eval)
   ;; The procedures below are needed both at run time and at expansion time.
 
 interface\" (ABI) for TYPE is equal to COOKIE."
     (with-syntax ((current-abi (current-abi-identifier type)))
       #`(unless (eq? current-abi #,cookie)
-          (throw 'record-abi-mismatch-error #,type)))))
+          ;; The source file where this exception is thrown must be
+          ;; recompiled.
+          (throw 'record-abi-mismatch-error 'abi-check
+                 "~a: record ABI mismatch; recompilation needed"
+                 (list #,type) '()))))
+
+  (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!
+         ;; 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."
+    (syntax-case ctor ()
+      ((_ bindings ...)
+       (let loop ((bindings #'(bindings ...))
+                  (seen   '()))
+         (syntax-case bindings ()
+           (((field value) rest ...)
+            (not (memq (syntax->datum #'field) seen))
+            (loop #'(rest ...) (cons (syntax->datum #'field) seen)))
+           ((duplicate rest ...)
+            (syntax-violation name "duplicate field initializer"
+                              #'duplicate))
+           (()
+            #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 ()
@@ -95,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)
@@ -138,7 +171,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)))
@@ -176,6 +216,9 @@ of TYPE matches the expansion-time ABI."
                           #'(field (... ...)))
                     (wrap-field-value f (field-default-value f))))
 
+              ;; Pass S to make sure source location info is preserved.
+              (report-duplicate-field-specifier 'name s)
+
               (let ((fields (append fields (map car default-values))))
                 (cond ((lset= eq? fields '(expected ...))
                        #`(let* #,(field-bindings
@@ -199,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
@@ -221,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))
@@ -240,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.
@@ -295,7 +341,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
@@ -315,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))
@@ -348,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 '()))