rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 2018-05-16 10:05:24 +02:00
parent 56f9d442e0
commit 7874bbbb9f
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 80 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
guix/records.scm
View File

@ -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

30
tests/records.scm
View File

@ -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")