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