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 (defcfun "sizeof_bool" :unsigned-int)
  90
  91 (deftest misc-types.sizeof.bool
  92     (eql (sizeof-bool) (foreign-type-size :bool))
  93   t)
  94
  95 (defcfun "bool_to_unsigned" :unsigned-int
  96   (b :bool))
  97
  98 (defcfun "unsigned_to_bool" :bool
  99   (u :unsigned-int))
 100
 101 (deftest misc-types.bool.convert-to-foreign.mem
 102     (loop for v in '(nil t)
 103           collect
 104           (with-foreign-object (b :bool)
 105             (setf (mem-ref b :bool) v)
 106             (mem-ref b #.(cffi::canonicalize-foreign-type :bool))))
 107   (0 1))
 108
 109 (deftest misc-types.bool.convert-to-foreign.call
 110     (mapcar #'bool-to-unsigned '(nil t))
 111   (0 1))
 112
 113 (deftest misc-types.bool.convert-from-foreign.mem
 114     (loop for v in '(0 1 42)
 115           collect
 116           (with-foreign-object (b :bool)
 117             (setf (mem-ref b #.(cffi::canonicalize-foreign-type :bool)) v)
 118             (mem-ref b :bool)))
 119   (nil t t))
 120
 121 (deftest misc-types.bool.convert-from-foreign.call
 122     (mapcar #'unsigned-to-bool '(0 1 42))
 123   (nil t t))
 124
 125 ;;; Regression test: boolean type only worked with canonicalized
 126 ;;; built-in integer types. Should work for any type that canonicalizes
 127 ;;; to a built-in integer type.
 128 (defctype int-for-bool :int)
 129 (defcfun ("equalequal" equalequal2) :boolean
 130   (a (:boolean int-for-bool))
 131   (b (:boolean :uint)))
 132
 133 (deftest misc-types.boolean.2
 134     (equalequal2 nil t)
 135   nil)
 136
 137 (defctype my-string :string+ptr)
 138
 139 (defun funkify (str)
 140   (concatenate 'string "MORE " (string-upcase str)))
 141
 142 (defun 3rd-person (value)
 143   (list (concatenate 'string "Strdup says: " (first value))
 144         (second value)))
 145
 146 ;; (defctype funky-string
 147 ;;     (:wrapper my-string
 148 ;;               :to-c #'funkify
 149 ;;               :from-c (lambda (value)
 150 ;;                         (list
 151 ;;                          (concatenate 'string "Strdup says: "
 152 ;;                                       (first value))
 153 ;;                          (second value))))
 154 ;;   "A useful type.")
 155
 156 (defctype funky-string (:wrapper my-string :to-c funkify :from-c 3rd-person))
 157
 158 (defcfun ("my_strdup" funky-strdup) funky-string
 159   (str funky-string))
 160
 161 (deftest misc-types.wrapper
 162     (destructuring-bind (string ptr)
 163         (funky-strdup "code")
 164       (strfree ptr)
 165       string)
 166   "Strdup says: MORE CODE")
 167
 168 (deftest misc-types.sized-ints
 169     (mapcar #'foreign-type-size
 170             '(:int8 :uint8 :int16 :uint16 :int32 :uint32 :int64 :uint64))
 171   (1 1 2 2 4 4 8 8))
 172
 173 (define-foreign-type error-error ()
 174   ()
 175   (:actual-type :int)
 176   (:simple-parser error-error))
 177
 178 (defmethod translate-to-foreign (value (type error-error))
 179   (declare (ignore value))
 180   (error "translate-to-foreign invoked."))
 181
 182 (defmethod translate-from-foreign (value (type error-error))
 183   (declare (ignore value))
 184   (error "translate-from-foreign invoked."))
 185
 186 (eval-when (:load-toplevel :compile-toplevel :execute)
 187   (defmethod expand-to-foreign (value (type error-error))
 188     value)
 189
 190   (defmethod expand-from-foreign (value (type error-error))
 191     value))
 192
 193 (defcfun ("abs" expand-abs) error-error
 194   (n error-error))
 195
 196 (defcvar ("var_int" *expand-var-int*) error-error)
 197
 198 (defcfun ("expect_int_sum" expand-expect-int-sum) :boolean
 199   (cb :pointer))
 200
 201 (defcallback expand-int-sum error-error ((x error-error) (y error-error))
 202   (+ x y))
 203
 204 ;;; Ensure that macroexpansion-time translators are called where this
 205 ;;; is guaranteed (defcfun, defcvar, foreign-funcall and defcallback)
 206 (deftest misc-types.expand.1
 207     (expand-abs -1)
 208   1)
 209
 210 #-cffi-sys::no-foreign-funcall
 211 (deftest misc-types.expand.2
 212     (foreign-funcall "abs" error-error -1 error-error)
 213   1)
 214
 215 (deftest misc-types.expand.3
 216     (let ((old (mem-ref (get-var-pointer '*expand-var-int*) :int)))
 217       (unwind-protect
 218            (progn
 219              (setf *expand-var-int* 42)
 220              *expand-var-int*)
 221         (setf (mem-ref (get-var-pointer '*expand-var-int*) :int) old)))
 222   42)
 223
 224 (deftest misc-types.expand.4
 225     (expand-expect-int-sum (callback expand-int-sum))
 226   t)
 227
 228 (define-foreign-type translate-tracker ()
 229   ()
 230   (:actual-type :int)
 231   (:simple-parser translate-tracker))
 232
 233 (declaim (special .fto-called.))
 234
 235 (defmethod free-translated-object (value (type translate-tracker) param)
 236   (declare (ignore value param))
 237   (setf .fto-called. t))
 238
 239 (define-foreign-type expand-tracker ()
 240   ()
 241   (:actual-type :int)
 242   (:simple-parser expand-tracker))
 243
 244 (defmethod free-translated-object (value (type expand-tracker) param)
 245   (declare (ignore value param))
 246   (setf .fto-called. t))
 247
 248 (eval-when (:compile-toplevel :load-toplevel :execute)
 249   (defmethod expand-to-foreign (value (type expand-tracker))
 250     (declare (ignore value))
 251     (call-next-method)))
 252
 253 (defcfun ("abs" ttracker-abs) :int
 254   (n translate-tracker))
 255
 256 (defcfun ("abs" etracker-abs) :int
 257   (n expand-tracker))
 258
 259 ;; free-translated-object must be called when there is no etf
 260 (deftest misc-types.expand.5
 261     (let ((.fto-called. nil))
 262       (ttracker-abs -1)
 263       .fto-called.)
 264   t)
 265
 266 ;; free-translated-object must be called when there is an etf, but
 267 ;; they answer *runtime-translator-form*
 268 (deftest misc-types.expand.6
 269     (let ((.fto-called. nil))
 270       (etracker-abs -1)
 271       .fto-called.)
 272   t)
 273
 274 (define-foreign-type misc-type.expand.7 ()
 275   ()
 276   (:actual-type :int)
 277   (:simple-parser misc-type.expand.7))
 278
 279 (defmethod translate-to-foreign (value (type misc-type.expand.7))
 280   (values value 'second-value))
 281
 282 ;; Auxiliary function to test CONVERT-TO-FOREIGN's compiler macro.
 283 (defun misc-type.expand.7-aux ()
 284   (convert-to-foreign "foo" 'misc-type.expand.7))
 285
 286 ;; Checking that expand-to-foreign doesn't ignore the second value of
 287 ;; translate-to-foreign.
 288 (deftest misc-type.expand.7
 289     (misc-type.expand.7-aux)
 290   "foo" second-value)
 291
 292 ;; Like MISC-TYPE.EXPAND.7 but doesn't depend on compiler macros
 293 ;; kicking in.
 294 (deftest misc-type.expand.8
 295     (eval (expand-to-foreign "foo" (cffi::parse-type 'misc-type.expand.7)))
 296   "foo" second-value)
 297
 298 ;; stdint.h
 299 (defcfun "sizeof_ptrdiff" :unsigned-int)
 300 (defcfun "sizeof_size" :unsigned-int)
 301 (defcfun "sizeof_offset" :unsigned-int)
 302 (defcfun "sizeof_uintptr" :unsigned-int)
 303 (defcfun "sizeof_intptr" :unsigned-int)
 304
 305 (deftest misc-types.sizeof.ptrdiff
 306     (eql (sizeof-ptrdiff) (foreign-type-size :ptrdiff))
 307   t)
 308
 309 (deftest misc-types.sizeof.size
 310     (eql (sizeof-size) (foreign-type-size :size))
 311   t)
 312
 313 (deftest misc-types.sizeof.offset
 314     (eql (sizeof-offset) (foreign-type-size :offset))
 315   t)
 316
 317 (deftest misc-types.sizeof.uintptr
 318     (eql (sizeof-uintptr) (foreign-type-size :uintptr))
 319   t)
 320
 321 (deftest misc-types.sizeof.intptr
 322     (eql (sizeof-intptr) (foreign-type-size :intptr))
 323   t)