aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-05-16 10:05:24 +0200
committerLudovic Courtès <ludo@gnu.org>2018-05-23 10:21:02 +0200
commit7874bbbb9f09cc14ea3e179fd0fa10da5f90cfc7 (patch)
tree858882215ed759814f841b714250434e975f604f
parent56f9d442e0b5624130042f69f33ea5bd7e970798 (diff)
downloadguix-7874bbbb9f09cc14ea3e179fd0fa10da5f90cfc7.tar
guix-7874bbbb9f09cc14ea3e179fd0fa10da5f90cfc7.tar.gz
records: Insert record type ABI checks in constructors.
* guix/records.scm (print-record-abi-mismatch-error): New procedure. <top level>: Add 'set-exception-printer!' call. (current-abi-identifier, abi-check): New procedures. (make-syntactic-constructor): Add #:abi-cookie parameter. Insert calls to 'abi-check'. (define-record-type*)[compute-abi-cookie]: New procedure. Use it and emit a definition of the 'current-abi-identifier' for TYPE. * tests/records.scm ("ABI checks"): New test.
-rw-r--r--guix/records.scm54
-rw-r--r--tests/records.scm30
2 files changed, 80 insertions, 4 deletions
diff --git a/guix/records.scm b/guix/records.scm
index c02395f2ae..c71cfcfe32 100644
--- 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 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -52,13 +52,45 @@
((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)
+
+(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)
+ (throw 'record-abi-mismatch-error #,type))))
+
(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
@@ -130,6 +162,7 @@ fields, and DELAYED is the list of identifiers of delayed fields."
(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) (... ...))
@@ -144,6 +177,7 @@ fields, and DELAYED is the list of identifiers of delayed fields."
(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 ...)))
@@ -270,6 +304,16 @@ inherited."
;; 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 ...) ...)
@@ -278,7 +322,8 @@ inherited."
(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 ...)
@@ -298,10 +343,13 @@ inherited."
(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
diff --git a/tests/records.scm b/tests/records.scm
index d6d27bb96a..80e08a9a5f 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -288,6 +288,34 @@
(and (string-match "extra.*initializer.*baz" message)
(eq? proc 'foo)))))
+(test-assert "ABI checks"
+ (let ((module (test-module)))
+ (eval '(begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (default 42)))
+
+ (define (make-me-a-record) (foo)))
+ module)
+ (unless (eval '(foo? (make-me-a-record)) module)
+ (error "what?" (eval '(make-me-a-record) module)))
+
+ ;; Redefine <foo> with an additional field.
+ (eval '(define-record-type* <foo> foo make-foo
+ foo?
+ (baz foo-baz)
+ (bar foo-bar (default 42)))
+ module)
+
+ ;; Now 'make-me-a-record' is out of sync because it does an
+ ;; 'allocate-struct' that corresponds to the previous definition of <foo>.
+ (catch 'record-abi-mismatch-error
+ (lambda ()
+ (eval '(foo? (make-me-a-record)) module)
+ #f)
+ (lambda (key rtd . _)
+ (eq? rtd (eval '<foo> module))))))
+
(test-equal "recutils->alist"
'((("Name" . "foo")
("Version" . "0.1")