From 333a1f8591167a16e56d262b59d26c8ca852a613 Mon Sep 17 00:00:00 2001 From: Sean Champ Date: Sat, 25 Apr 2020 19:05:23 -0700 Subject: [PATCH] lib/db-io.lisp: Provide some syntax checking in encode-ffi-field Under some build configurations, after processing OS header files in some host environments, ffigen5 may produce field information having non-positive offset and/or width properties, in some specific fields. This changeset provides a rudimentary parse-time syntax check for such data, implemented here in `encode-ffi-field'. On encountering a negative offset or width for a field, the type check will signal a continuable error of type `simple-type-definition-error'. The continuation form would throw to the symbol, `ignore-type', with no values. Furthermore, if encountering a zero width for a field, tentatively the updated `encode-ffi-field' would produce a warning condition of type `simple-type-definition-warning' This also updates the following functions, to gracefully handle the catch symbol `ignore-type', such that may be thrown from the updated `encode-ffi-field' * save-ffi-objc-message * db-write-byte-list * save-ffi-function * save-ffi-typedef * save-ffi-struct * save-ffi-union * save-ffi-transparent-union * db-define-var * save-ffi-objc-class The following condition classes are added, each in a tentative definition, such as to be used in this simple type checking for ffigen data, in `encode-ffi-field' * simple-type-definition-error * simple-type-definition-warning This patch was originally developed circa October, 2019 The patch has been tested, to a limited extent, under a Debian 10 amd64 installation. --- lib/db-io.lisp | 114 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 75 insertions(+), 39 deletions(-) diff --git a/lib/db-io.lisp b/lib/db-io.lisp index f18c2ee78..c03ef3448 100644 --- a/lib/db-io.lisp +++ b/lib/db-io.lisp @@ -1186,8 +1186,35 @@ satisfy the optional predicate PREDICATE." (length (length string))) (cons length (map 'list #'char-code string))))) +(define-condition simple-type-definition-error (simple-error) + ()) + +(define-condition simple-type-definition-warning (simple-warning) + ()) + (defun encode-ffi-field (field) (destructuring-bind (name type offset width) field + (cond + ;; check for some possible errors in the *.ffi encoding + ((minusp offset) + (cerror "Ignore this type definition" + 'simple-type-definition-error + :format-control "Negative offset ~S for field ~S" + :format-arguments (list offset name)) + (throw 'ignore-type (values))) + ((minusp width) + (cerror "Ignore this type definition" + 'simple-type-definition-error + :format-control "Negative width ~S for field ~S" + :format-arguments (list offset name)) + (throw 'ignore-type (values))) + ((zerop width) + ;; The warning text may be verbosely descriptive, using + ;; the unabridged contents of the FIELD description + ;; rather than the field name + (warn 'simple-type-definition-warning + :format-control "Field has zero width: ~S" + :format-arguments (list field)))) `(,@(encode-name name) ,@(encode-ffi-type type) ,@(encode-uint offset) @@ -1480,12 +1507,13 @@ satisfy the optional predicate PREDICATE." (when ml `(,@(encode-ffi-objc-method (car ml)) ,@(encode-objc-method-list (cdr ml)))))) - (db-write-byte-list cdbm - (ffi-objc-message-string message) - `(,@(encode-uint nmethods) - ,@(encode-uint nargs) - ,@(encode-objc-method-list methods)) - t)))) + (catch 'ignore-type + (db-write-byte-list cdbm + (ffi-objc-message-string message) + `(,@(encode-uint nmethods) + ,@(encode-uint nargs) + ,@(encode-objc-method-list methods)) + t))))) (defun save-byte-list (ptr l) @@ -1498,54 +1526,62 @@ satisfy the optional predicate PREDICATE." (setf (%get-unsigned-byte ptr i) b)))) (defun db-write-byte-list (cdbm keyname bytes &optional verbatim) - (let* ((len (length bytes))) - (%stack-block ((p len)) - (save-byte-list p bytes) - (rletZ ((contents :cdb-datum) - (key :cdb-datum)) - (let* ((foreign-name - (if verbatim - keyname - (unescape-foreign-name keyname)))) - (with-cstrs ((keystring foreign-name)) - (setf (pref contents :cdb-datum.data) p - (pref contents :cdb-datum.size) len - (pref key :cdb-datum.data) keystring - (pref key :cdb-datum.size) (length foreign-name)) - (cdbm-put cdbm key contents))))))) + (catch 'ignore-type + (let* ((len (length bytes))) + (%stack-block ((p len)) + (save-byte-list p bytes) + (rletZ ((contents :cdb-datum) + (key :cdb-datum)) + (let* ((foreign-name + (if verbatim + keyname + (unescape-foreign-name keyname)))) + (with-cstrs ((keystring foreign-name)) + (setf (pref contents :cdb-datum.data) p + (pref contents :cdb-datum.size) len + (pref key :cdb-datum.data) keystring + (pref key :cdb-datum.size) (length foreign-name)) + (cdbm-put cdbm key contents)))))))) (defun save-ffi-function (cdbm fun) - (let* ((encoding (encode-ffi-function fun))) - (db-write-byte-list cdbm - (ffi-function-string fun) - encoding - t))) + (catch 'ignore-type + (let* ((encoding (encode-ffi-function fun))) + (db-write-byte-list cdbm + (ffi-function-string fun) + encoding + t)))) (defun save-ffi-typedef (cdbm def) - (db-write-byte-list cdbm - (ffi-typedef-string def) - (encode-ffi-type (ffi-typedef-type def)) - t)) + (catch 'ignore-type + (db-write-byte-list cdbm + (ffi-typedef-string def) + (encode-ffi-type (ffi-typedef-type def)) + t))) (defun save-ffi-struct (cdbm s) - (db-write-byte-list cdbm (ffi-struct-reference s) (encode-ffi-struct s))) + (catch 'ignore-type + (db-write-byte-list cdbm (ffi-struct-reference s) (encode-ffi-struct s)))) (defun save-ffi-union (cdbm u) - (db-write-byte-list cdbm (ffi-union-reference u) (encode-ffi-union u))) + (catch 'ignore-type + (db-write-byte-list cdbm (ffi-union-reference u) (encode-ffi-union u)))) (defun save-ffi-transparent-union (cdbm u) - (db-write-byte-list cdbm (ffi-transparent-union-reference u) (encode-ffi-transparent-union u))) + (catch 'ignore-type + (db-write-byte-list cdbm (ffi-transparent-union-reference u) (encode-ffi-transparent-union u)))) (defun db-define-var (cdbm name type) - (db-write-byte-list cdbm - (if *prepend-underscores-to-ffi-function-names* - (concatenate 'string "_" name) - name) - (encode-ffi-type type) t)) + (catch 'ignore-type + (db-write-byte-list cdbm + (if *prepend-underscores-to-ffi-function-names* + (concatenate 'string "_" name) + name) + (encode-ffi-type type) t))) (defun save-ffi-objc-class (cdbm c) - (db-write-byte-list cdbm (ffi-objc-class-name c) (encode-ffi-objc-class c))) + (catch 'ignore-type + (db-write-byte-list cdbm (ffi-objc-class-name c) (encode-ffi-objc-class c)))) ;;; An "uppercase-sequence" is a maximal substring of a string that