tests/misc-types.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; misc-types.lisp --- Various tests on the type system.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, 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 (defcfun ("my_strdup" strdup) :string+ptr (str :string))
  31
  32 (defcfun ("my_strfree" strfree) :void (str :pointer))
  33
  34 (deftest misc-types.string+ptr
  35     (destructuring-bind (string pointer)
  36         (strdup "foo")
  37       (strfree pointer)
  38       string)
  39   "foo")
  40
  41 #-(and)
  42 (deftest misc-types.string+ptr.ub8
  43     (destructuring-bind (string pointer)
  44         (strdup (make-array 3 :element-type '(unsigned-byte 8)
  45                             :initial-contents (map 'list #'char-code "foo")))
  46       (strfree pointer)
  47       string)
  48   "foo")
  49
  50 #-(and)
  51 (deftest misc-types.string.ub8.1
  52     (let ((array (make-array 7 :element-type '(unsigned-byte 8)
  53                              :initial-contents '(84 117 114 97 110 103 97))))
  54       (with-foreign-string (foreign-string array)
  55         (foreign-string-to-lisp foreign-string)))
  56   "Turanga")
  57
  58 #-(and)
  59 (deftest misc-types.string.ub8.2
  60     (let ((str (foreign-string-alloc
  61                 (make-array 7 :element-type '(unsigned-byte 8)
  62                             :initial-contents '(84 117 114 97 110 103 97)))))
  63       (prog1 (foreign-string-to-lisp str)
  64         (foreign-string-free str)))
  65   "Turanga")
  66
  67 (defcfun "equalequal" :boolean
  68   (a (:boolean :int))
  69   (b (:boolean :unsigned-int)))
  70
  71 (defcfun "bool_and" (:boolean :char)
  72   (a (:boolean :unsigned-char))
  73   (b (:boolean :char)))
  74
  75 (defcfun "bool_xor" (:boolean :unsigned-long)
  76   (a (:boolean :long))
  77   (b (:boolean :unsigned-long)))
  78
  79 (deftest misc-types.boolean.1
  80     (list (equalequal nil nil)
  81           (equalequal t t)
  82           (equalequal t 23)
  83           (bool-and 'a 'b)
  84           (bool-and "foo" nil)
  85           (bool-xor t nil)
  86           (bool-xor nil nil))
  87   (t t t t nil t nil))
  88
  89
  90 ;;; Regression test: boolean type only worked with canonicalized
  91 ;;; built-in integer types. Should work for any type that canonicalizes
  92 ;;; to a built-in integer type.
  93 (defctype int-for-bool :int)
  94 (defcfun ("equalequal" equalequal2) :boolean
  95   (a (:boolean int-for-bool))
  96   (b (:boolean :uint)))
  97
  98 (deftest misc-types.boolean.2
  99     (equalequal2 nil t)
 100   nil)
 101
 102 (defctype my-string :string+ptr)
 103
 104 (defun funkify (str)
 105   (concatenate 'string "MORE " (string-upcase str)))
 106
 107 (defun 3rd-person (value)
 108   (list (concatenate 'string "Strdup says: " (first value))
 109         (second value)))
 110
 111 ;; (defctype funky-string
 112 ;;     (:wrapper my-string
 113 ;;               :to-c #'funkify
 114 ;;               :from-c (lambda (value)
 115 ;;                         (list
 116 ;;                          (concatenate 'string "Strdup says: "
 117 ;;                                       (first value))
 118 ;;                          (second value))))
 119 ;;   "A useful type.")
 120
 121 (defctype funky-string (:wrapper my-string :to-c funkify :from-c 3rd-person))
 122
 123 (defcfun ("my_strdup" funky-strdup) funky-string
 124   (str funky-string))
 125
 126 (deftest misc-types.wrapper
 127     (destructuring-bind (string ptr)
 128         (funky-strdup "code")
 129       (strfree ptr)
 130       string)
 131   "Strdup says: MORE CODE")
 132
 133 (deftest misc-types.sized-ints
 134     (mapcar #'foreign-type-size
 135             '(:int8 :uint8 :int16 :uint16 :int32 :uint32 :int64 :uint64))
 136   (1 1 2 2 4 4 8 8))
 137
 138 (define-foreign-type error-error ()
 139   ()
 140   (:actual-type :int)
 141   (:simple-parser error-error))
 142
 143 (defmethod translate-to-foreign (value (type error-error))
 144   (declare (ignore value))
 145   (error "translate-to-foreign invoked."))
 146
 147 (defmethod translate-from-foreign (value (type error-error))
 148   (declare (ignore value))
 149   (error "translate-from-foreign invoked."))
 150
 151 (eval-when (:load-toplevel :compile-toplevel :execute)
 152   (defmethod expand-to-foreign (value (type error-error))
 153     value)
 154
 155   (defmethod expand-from-foreign (value (type error-error))
 156     value))
 157
 158 (defcfun ("abs" expand-abs) error-error
 159   (n error-error))
 160
 161 (defcvar ("var_int" *expand-var-int*) error-error)
 162
 163 (defcfun ("expect_int_sum" expand-expect-int-sum) :boolean
 164   (cb :pointer))
 165
 166 (defcallback expand-int-sum error-error ((x error-error) (y error-error))
 167   (+ x y))
 168
 169 ;;; Ensure that macroexpansion-time translators are called where this
 170 ;;; is guaranteed (defcfun, defcvar, foreign-funcall and defcallback)
 171 (deftest misc-types.expand.1
 172     (expand-abs -1)
 173   1)
 174
 175 #-cffi-sys::no-foreign-funcall
 176 (deftest misc-types.expand.2
 177     (foreign-funcall "abs" error-error -1 error-error)
 178   1)
 179
 180 (deftest misc-types.expand.3
 181     (let ((old (mem-ref (get-var-pointer '*expand-var-int*) :int)))
 182       (unwind-protect
 183            (progn
 184              (setf *expand-var-int* 42)
 185              *expand-var-int*)
 186         (setf (mem-ref (get-var-pointer '*expand-var-int*) :int) old)))
 187   42)
 188
 189 (deftest misc-types.expand.4
 190     (expand-expect-int-sum (callback expand-int-sum))
 191   t)
 192
 193 (define-foreign-type translate-tracker ()
 194   ()
 195   (:actual-type :int)
 196   (:simple-parser translate-tracker))
 197
 198 (declaim (special .fto-called.))
 199
 200 (defmethod free-translated-object (value (type translate-tracker) param)
 201   (declare (ignore value param))
 202   (setf .fto-called. t))
 203
 204 (define-foreign-type expand-tracker ()
 205   ()
 206   (:actual-type :int)
 207   (:simple-parser expand-tracker))
 208
 209 (defmethod free-translated-object (value (type expand-tracker) param)
 210   (declare (ignore value param))
 211   (setf .fto-called. t))
 212
 213 (eval-when (:compile-toplevel :load-toplevel :execute)
 214   (defmethod expand-to-foreign (value (type expand-tracker))
 215     (declare (ignore value))
 216     (call-next-method)))
 217
 218 (defcfun ("abs" ttracker-abs) :int
 219   (n translate-tracker))
 220
 221 (defcfun ("abs" etracker-abs) :int
 222   (n expand-tracker))
 223
 224 ;; free-translated-object must be called when there is no etf
 225 (deftest misc-types.expand.5
 226     (let ((.fto-called. nil))
 227       (ttracker-abs -1)
 228       .fto-called.)
 229   t)
 230
 231 ;; free-translated-object must be called when there is an etf, but
 232 ;; they answer *runtime-translator-form*
 233 (deftest misc-types.expand.6
 234     (let ((.fto-called. nil))
 235       (etracker-abs -1)
 236       .fto-called.)
 237   t)
 238
 239 (define-foreign-type misc-type.expand.7 ()
 240   ()
 241   (:actual-type :int)
 242   (:simple-parser misc-type.expand.7))
 243
 244 (defmethod translate-to-foreign (value (type misc-type.expand.7))
 245   (values value 'second-value))
 246
 247 ;; Auxiliary function to test CONVERT-TO-FOREIGN's compiler macro.
 248 (defun misc-type.expand.7-aux ()
 249   (convert-to-foreign "foo" 'misc-type.expand.7))
 250
 251 ;; Checking that expand-to-foreign doesn't ignore the second value of
 252 ;; translate-to-foreign.
 253 (deftest misc-type.expand.7
 254     (misc-type.expand.7-aux)
 255   "foo" second-value)
 256
 257 ;; Like MISC-TYPE.EXPAND.7 but doesn't depend on compiler macros
 258 ;; kicking in.
 259 (deftest misc-type.expand.8
 260     (eval (expand-to-foreign "foo" (cffi::parse-type 'misc-type.expand.7)))
 261   "foo" second-value)