mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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.
This commit is contained in:
Ludovic Courtès
parent
56f9d442e0
commit
7874bbbb9f
2 changed files with 80 additions and 4 deletions
|
|
@ -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 @@ (define (report-invalid-field-specifier name bindings)
|
|||
((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 @@ (define (field-bindings field+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) (... ...))
|
||||
|
|
@ -144,6 +177,7 @@ (define (field-value f)
|
|||
(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 @@ (define (delayed-field-accessor-definition field)
|
|||
;; 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 @@ (define (delayed-field-accessor-definition field)
|
|||
(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 @@ (define-record-type type
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -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 @@ (define-record-type* <foo> foo make-foo
|
|||
(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")
|
||||
|
|
|
|||
Loading…
Reference in a new issue