;;; 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 ()
((_ type name ctor (expected ...)
#:abi-cookie abi-cookie
#:thunked thunked
+ #:this-identifier this-identifier
#:delayed delayed
#:innate innate
#:defaults defaults)
(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)))
#'(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
;; 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
(define-record-type* <thing> thing make-thing
thing?
+ this-thing
(name thing-name (default \"chbouib\"))
(port thing-port
(default (current-output-port)) (thunked))
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.
(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
(((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))
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 '()))
HCoop / jackhill / guix / guix.git / blobdiff