;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 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 regex)
#:use-module (ice-9 rdelim)
#: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)))))
+(eval-when (expand load eval)
+ ;; The procedures below are needed both at run time and at expansion time.
+
+ (define (current-abi-identifier type)
+ "Return an identifier unhygienically derived from TYPE for use as its
+\"current ABI\" variable."
+ (let ((type-name (syntax->datum type)))
+ (datum->syntax
+ type
+ (string->symbol
+ (string-append "% " (symbol->string type-name)
+ " abi-cookie")))))
+
+ (define (abi-check type cookie)
+ "Return syntax that checks that the current \"application binary
+interface\" (ABI) for TYPE is equal to COOKIE."
+ (with-syntax ((current-abi (current-abi-identifier type)))
+ #`(unless (eq? current-abi #,cookie)
+ ;; 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)
+ "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 (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 ()
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and
expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
-fields, and DELAYED is the list of identifiers of delayed fields."
+fields, and DELAYED is the list of identifiers of delayed fields.
+
+ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI
+of TYPE matches the expansion-time ABI."
((_ type name ctor (expected ...)
+ #:abi-cookie abi-cookie
#:thunked thunked
#:delayed delayed
#:innate innate
(record-error 'name s "extraneous field initializers ~a"
unexpected)))
- #`(make-struct type 0
+ #`(make-struct/no-tail type
#,@(map (lambda (field index)
(or (field-inherited-value field)
(if (innate-field? field)
(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)))
(syntax-case s (inherit expected ...)
((_ (inherit orig-record) (field value) (... ...))
#`(let* #,(field-bindings #'((field value) (... ...)))
+ #,(abi-check #'type abi-cookie)
#,(record-inheritance #'orig-record
#'((field value) (... ...)))))
((_ (field 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
#'((field value) (... ...)))
+ #,(abi-check #'type abi-cookie)
(ctor #,@(map field-value '(expected ...)))))
((pair? (lset-difference eq? fields
'(expected ...)))
(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
;; The real value of that field is a promise, so force it.
(force (real-get x)))))))
+ (define (compute-abi-cookie field-specs)
+ ;; Compute an "ABI cookie" for the given FIELD-SPECS. We use
+ ;; 'string-hash' because that's a better hash function that 'hash' on a
+ ;; list of symbols.
+ (syntax-case field-specs ()
+ (((field get properties ...) ...)
+ (string-hash (object->string
+ (syntax->datum #'((field properties ...) ...)))
+ most-positive-fixnum))))
+
(syntax-case s ()
((_ type syntactic-ctor ctor pred
(field get properties ...) ...)
(delayed (filter-map delayed-field? field-spec))
(innate (filter-map innate-field? field-spec))
(defaults (filter-map field-default-value
- #'((field properties ...) ...))))
+ #'((field properties ...) ...)))
+ (cookie (compute-abi-cookie field-spec)))
(with-syntax (((field-spec* ...)
(map field-spec->srfi-9 field-spec))
((thunked-field-accessor ...)
(ctor field ...)
pred
field-spec* ...)
+ (define #,(current-abi-identifier #'type)
+ #,cookie)
thunked-field-accessor ...
delayed-field-accessor ...
(make-syntactic-constructor type syntactic-ctor ctor
(field ...)
+ #:abi-cookie #,cookie
#:thunked #,thunked
#:delayed #,delayed
#:innate #,innate
HCoop / jackhill / guix / guix.git / blobdiff