tests/grovel.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; grovel.lisp --- CFFI-Grovel tests.
   4 ;;;
   5 ;;; Copyright (C) 2014, Luis Oliveira  <loliveira@common-lisp.net>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person
   8 ;;; obtaining a copy of this software and associated documentation
   9 ;;; files (the "Software"), to deal in the Software without
  10 ;;; restriction, including without limitation the rights to use, copy,
  11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;;; of the Software, and to permit persons to whom the Software is
  13 ;;; furnished to do so, subject to the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  25 ;;; DEALINGS IN THE SOFTWARE.
  26 ;;;
  27
  28 (in-package #:cffi-tests)
  29
  30 (deftest %invoke
  31     (cffi-grovel::invoke "echo" "test")
  32   nil nil 0)
  33
  34 (defun grovel-forms (forms &key (quiet t))
  35   (uiop:with-temporary-file (:stream grovel-stream :pathname grovel-file)
  36     (with-standard-io-syntax
  37       (with-open-stream (*standard-output* grovel-stream)
  38         (let ((*package* (find-package :keyword)))
  39           (mapc #'write forms))))
  40     (let ((lisp-file (let ((*debug-io* (if quiet (make-broadcast-stream) *debug-io*)))
  41                        (cffi-grovel:process-grovel-file grovel-file))))
  42       (unwind-protect
  43            (load lisp-file)
  44         (uiop:delete-file-if-exists lisp-file)))))
  45
  46 (defun bug-1395242-helper (enum-type base-type constant-name)
  47   (check-type enum-type (member constantenum cenum))
  48   (check-type base-type string)
  49   (check-type constant-name string)
  50   (let ((enum-name (intern (symbol-name (gensym))))
  51         (base-type-name (intern (symbol-name (gensym)))))
  52     (grovel-forms `((ctype ,base-type-name ,base-type)
  53                     (,enum-type (,enum-name :base-type ,base-type-name)
  54                                 ((:value ,constant-name)))))
  55     (cffi:foreign-enum-value enum-name :value)))
  56
  57 (deftest bug-1395242
  58     (labels
  59         ((process-expression (expression)
  60            (loop for enum-type in '(constantenum cenum)
  61                  always (destructuring-bind (base-type &rest evaluations) expression
  62                           (loop for (name expected-value) in evaluations
  63                                 for actual-value = (bug-1395242-helper enum-type base-type name)
  64                                 always (or (= expected-value actual-value)
  65                                            (progn
  66                                              (format *error-output*
  67                                                      "Test failed for case: ~A, ~A, ~A (expected ~A, actual ~A)~%"
  68                                                      enum-type base-type name expected-value actual-value)
  69                                              nil)))))))
  70       (every #'process-expression
  71              '(("uint8_t" ("UINT8_MAX" 255) ("INT8_MAX" 127) ("INT8_MIN" 128))
  72                ("int8_t" ("INT8_MIN" -128) ("INT8_MAX" 127) ("UINT8_MAX" -1))
  73                ("uint16_t" ("UINT16_MAX" 65535) ("INT8_MIN" 65408))
  74                ("int16_t" ("INT16_MIN" -32768) ("INT16_MAX" 32767) ("UINT16_MAX" -1))
  75                ("uint32_t" ("UINT32_MAX" 4294967295) ("INT8_MIN" 4294967168))
  76                ("int32_t" ("INT32_MIN" -2147483648) ("INT32_MAX" 2147483647)))))
  77   t)
  78
  79 (defvar *grovelled-features*)
  80
  81 (deftest grovel-feature
  82     (let ((*grovelled-features* nil))
  83       (grovel-forms `((in-package :cffi-tests)
  84                       (include "limits.h")
  85                       (feature grovel-test-feature "CHAR_BIT")
  86                       (feature :char-bit "CHAR_BIT"
  87                                :feature-list *grovelled-features*)
  88                       (feature :inexistent-grovel-feature
  89                                "INEXISTENT_CFFI_GROVEL_FEATURE"
  90                                :feature-list *grovelled-features*)))
  91       (unwind-protect
  92            (values (and (member 'grovel-test-feature *features*) t)
  93                    (and (member :char-bit *grovelled-features*) t)
  94                    (member :inexistent-grovel-feature *grovelled-features*))
  95         (alexandria:removef *features* 'grovel-test-feature)))
  96   t t nil)
  97
  98 (deftest grovel-types
  99     (let* ((this #.(or *compile-file-truename* *load-truename*))
 100            (include-dir (uiop:native-namestring (make-pathname :directory (pathname-directory this)))))
 101       (grovel-forms `((in-package :cffi-tests)
 102                       (cc-flags ,(concatenate 'string "-I" include-dir))
 103                       (include "grovel-test.h")
 104                       (constant (tagged-array-max-length "TAGGED_ARRAY_MAX_LENGTH")
 105                        :documentation "Maximum length of tagged_array.arr (should be 64)")
 106                       (cstruct tagged-array "struct tagged_array"
 107                        (tagged-array-arr "arr" :type (:array :pointer 64))
 108                        (tagged-array-len "len" :type :unsigned-int))))
 109       (let ((arr-type (cffi:foreign-slot-type '(:struct tagged-array) 'tagged-array-arr))
 110             (len-type (cffi:foreign-slot-type '(:struct tagged-array) 'tagged-array-len)))
 111         (values (eql tagged-array-max-length 64)
 112                 (and (eql (car arr-type) :array)
 113                      (eql (cadr arr-type) :pointer)
 114                      (eql (caddr arr-type) tagged-array-max-length))
 115                 (and (eql len-type :unsigned-int)))))
 116   t t t)