element-types.lisp 10.7 KB
Newer Older
1 2
;; Mapping of element type names
;; Liam Healy 2008-04-13 11:22:46EDT element-types.lisp
3
;; Time-stamp: <2008-12-31 21:10:07EST element-types.lisp>
4 5 6
;; $Id$

;;; The different element type forms:
7 8 9 10 11
;;; C standard full, or "CFFI"  :unsigned-char
;;; GSL splice name             "uchar"
;;; C explicit                  :uint8     (not used here)
;;; CL                          '(unsigned-byte 8)
;;; Single                      'unsigned-byte-8 
12

13 14 15
;;; Functions to perform conversions
;;; CL -> single in function #'cl-single
;;; CL -> GSL in function #'cl-gsl
16
;;; CL -> CFFI (Cstd) in function #'cl-cffi
17
;;; CFFI (Cstd) -> CL in function #'cffi-cl
18

19
;;; Sources of equivalence
20 21
;;; Cstd -> CL in alist *cstd-cl-type-mapping*
;;; Cstd -> GSL in alist *cstd-gsl-mapping*
22

23 24 25
;;; :long-double may be pushed onto *features* if
;;; the implementation supports long doubles in CFFI.

26 27 28 29 30 31
(in-package :gsl)

;;;;****************************************************************************
;;;; Basic definition
;;;;****************************************************************************

32 33 34 35 36 37 38 39 40 41
;;; Preliminary definitions.  These are not used directly outside this
;;; file; they exist to define the two variables
;;; *cstd-cl-type-mapping* and *cstd-gsl-mapping* which are used by
;;; the conversion functions.

(defparameter *cstd-integer-types*
  '(:char :unsigned-char
    :short :unsigned-short
    :int :unsigned-int
    :long :unsigned-long
42
    #+int64
43
    :long-long
44
    #+int64
45 46 47 48 49 50 51 52
    :unsigned-long-long)
  ;; http://common-lisp.net/project/cffi/manual/html_node/Built_002dIn-Types.html
  "List of integer types supported by CFFI, from the CFFI docs.")

(defparameter *fp-type-mapping*
  '((:float . single-float) (:double . double-float)
    ;; For those implementations that support a separate long-double
    ;; type assume this mapping:
53 54 55
    #+long-double (:long-double . long-float)
    (complex-float-c . (complex single-float))
    (complex-double-c . (complex double-float))
56 57
    ;; For those implementations that support a separate long-double
    ;; type assume this mapping:
58 59
    #+long-double
    (complex-long-double-c . (complex long-float)))
60 61 62 63 64 65 66 67 68 69 70 71
  ;; Ordered by: real shortest to longest, then complex shortest to longest.
  "List of floating point types supported by CFFI from the CFFI docs
   plus corresponding complex types.")

(defparameter *gsl-splice-int-types*
  ;; list | grep -i 'gsl_vector.*_alloc\b'
  '("char" "int" "long" "short" "uchar" "uint" "ulong" "ushort")
  "The list of integer types that can be spliced into function names.")

(defparameter *gsl-splice-fp-types*
  ;; list | grep -i 'gsl_vector.*_alloc\b'
  ;; Ordered by: real shortest to longest, then complex shortest to longest.
72 73 74
  ;; Must match *fp-type-mapping*.
  '("float" "" #+long-double "long_double"
    "complex_float" "complex" #+long-double "complex_long_double")
75 76 77 78 79 80 81
  "The list of floating point types that can be spliced into function names.")

;;; Mapping alists used by conversion functions.

;;; Used by #'cl-gsl
(defparameter *cstd-cl-type-mapping*
  (append
82
   *fp-type-mapping*
83 84 85 86 87 88 89 90 91
   (mapcar
    (lambda (type)
      (cons
       type
       (list
	(if (string-equal type "uns" :end1 3)
	    'unsigned-byte
	    'signed-byte)
	(* 8 (cffi:foreign-type-size type)))))
92
    *cstd-integer-types*))
93 94
  ;; Be careful when reverse associating, as there may be several C
  ;; types that map to a single CL type.
95 96 97 98
  "An alist of the C standard types as keywords, and the CL type
   The exception is complex types, which don't have a definition
   in the C standard; in that case, the C type is the GSL struct
   definition.")
99

100 101 102 103 104 105
(defmacro floating-point-association (splice-list)
  `(mapcar
   #'cons
   (mapcar #'first *fp-type-mapping*)
   (subseq ,splice-list 0 (length *fp-type-mapping*))))

106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
(defparameter *cstd-gsl-mapping*
  (append
   ;; The integer types 
   (remove-if-not
    (lambda (x) (find (rest x) *gsl-splice-int-types* :test 'string-equal))
    (mapcar
     (lambda (type)
       (cons type
	     (let ((ut
		    (if (string-equal type "uns" :end1 3)
			(string-downcase
			 (concatenate 'string "u" (subseq (string type) 9)))
			(string-downcase type))))
	       (if (and (> (length ut) 8)
			(string-equal
			 (subseq ut (- (length ut) 9))
			 "long-long"))
		   (concatenate 'string (subseq ut 0 (- (length ut) 9)) "llong")
		   ut))))
     *cstd-integer-types*))
   ;; The floating types are associated by order, so it is important that
   ;; order of *fp-type-mapping* and *gsl-splice-fp-types* match,
   ;; though the latter may be longer.
129
   (floating-point-association *gsl-splice-fp-types*))
130 131
  "Mapping the C standard types to the GSL splice name.")

132 133 134 135 136 137 138 139 140 141 142 143 144 145
(defparameter *blas-splice-fp-types*
  ;; Ordered by: real shortest to longest, then complex shortest to longest.
  ;; Must match *fp-type-mapping*.
  '("s" "d" #+long-double nil
    "c" "z" #+long-double nil)
  "The list of floating point types that can be spliced into BLAS function names.")

(defparameter *cstd-blas-mapping*
  ;; The floating types are associated by order, so it is important that
  ;; order of *fp-type-mapping* and *blas-splice-fp-types* match,
  ;; though the latter may be longer.
  (floating-point-association *blas-splice-fp-types*)
  "Mapping the C standard types to the BLAS splice name.")

146 147 148 149 150 151 152 153 154 155
;;;;****************************************************************************
;;;; Conversions
;;;;****************************************************************************

(defun all-types (alist &optional right-side)
  "A list of all types defined by symbol or definition."
  (mapcar (if right-side #'rest #'first) alist))

(defun lookup-type (symbol alist &optional reverse)
  "Lookup the symbol defined in the alist."
156 157 158 159 160 161
  (or 
   (if reverse
       (first (rassoc symbol alist :test #'equal))
       (rest (assoc symbol alist)))
   ;;(error "Did not find ~a in ~a" symbol (mapcar #'first alist))
   ))
162 163 164 165 166 167 168 169 170 171 172 173

;;; (cl-single '(unsigned-byte 8))
;;; UNSIGNED-BYTE-8
(defun cl-single (cl-type)
  "The element type name as a single symbol."
  (intern (if (atom cl-type)
	      (princ-to-string cl-type)
	      (format nil "~{~a~^-~}" cl-type))
	  :gsl))

;;; (cl-gsl '(unsigned-byte 8))
;;; "uchar"
174
(defun cl-gsl (cl-type &optional prepend-underscore blas)
175
  "The GSL splice string from the CL type."
176 177
  (let ((string
	 (lookup-type
178
	  (lookup-type cl-type *cstd-cl-type-mapping* t)
179
	  (if blas *cstd-blas-mapping* *cstd-gsl-mapping*))))
180 181 182
    (if (and prepend-underscore (plusp (length string)))
	(concatenate 'string "_" string)
	string)))
183

184 185
(defun cl-cffi (cl-type)
  "The CFFI element type from the CL type."
186
  (lookup-type (clean-type cl-type) *cstd-cl-type-mapping* t))
187 188

(defun cffi-cl (cffi-type)
189
  "The CL type from the CFFI element type."
190 191
  (unless (eq cffi-type :pointer)
    (lookup-type cffi-type *cstd-cl-type-mapping*)))
192 193 194 195 196 197 198 199 200 201 202 203 204

(defun splice-name (base-name type keyword)
  "Make a new C name for a data function from a base name."
  (let ((pos (search keyword base-name)))
    (when pos
      (let ((insert (+ pos (length keyword)))
	    (gsltype (cl-gsl type)))
	(concatenate 'string 
		     (subseq base-name 0 insert)
		     (if (zerop (length gsltype)) "" "_")
		     (cl-gsl type)
		     (subseq base-name insert))))))

205 206 207 208
;;;;****************************************************************************
;;;; GSL complex types
;;;;****************************************************************************

209 210 211 212
;;; GSL defines complex numbers in a struct, and passes the struct by
;;; value.  CFFI does not support call by value for structs, so we
;;; cannot use functions that call or return complex scalars.

213 214 215 216 217 218 219 220 221 222 223
;;; See /usr/include/gsl/gsl_complex.h
(cffi:defcstruct complex-float-c
  (dat :float :count 2))

(cffi:defcstruct complex-double-c
  (dat :double :count 2))

#+long-double
(cffi:defcstruct complex-long-double-c
  (dat :long-double :count 2))

224 225 226 227 228 229 230 231 232 233 234
(defun clean-type (type)
  ;; SBCL at least will specify limits on the type, e.g.
  ;; (type-of #C(1.0 2.0))
  ;; (COMPLEX (DOUBLE-FLOAT 1.0 2.0))
  ;; This cleans that up to make
  ;; (clean-type (type-of #C(1.0 2.0)))
  ;; (COMPLEX DOUBLE-FLOAT)
  (if (and (subtypep type 'complex) (listp (second type)))
      (list (first type) (first (second type)))
      type))

235 236 237
(defun complex-to-gsl (number gsl)
  "Set the already-allocated GSL (foreign) struct to the CL complex number.
   Returns the struct."
238 239 240
  (cerror "Accept gibberish."
	  "Cannot pass complex scalars to and from GSL functions (structs passed by value).")
  (let* ((cleantype (clean-type (type-of number)))
241
	 (comptype (cl-cffi (second cleantype)))
242
	 (datslot
243
	  (cffi:foreign-slot-pointer gsl (cl-cffi cleantype) 'dat)))
244 245 246 247
    (setf (cffi:mem-aref datslot comptype 0) (realpart number)
	  (cffi:mem-aref datslot comptype 1) (imagpart number))
    gsl))

248 249 250 251 252 253 254
(defun component-float-type (eltype)
  "The float type of this type."
  (if (subtypep eltype 'complex)
      ;; complex: use the component type
      (second eltype)
      eltype))

255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276
;;; Use GSL to create the complex.  This actually does work on
;;; SBCL/amd64, but it shouldn't.
#+(or)
(defmfun complex-to-gsl (complex)
  "gsl_complex_rect"
  (((realpart complex) :double) ((imagpart complex) :double))
  :c-return :pointer
  :documentation
  "Convert the CL complex double into a GSL complex.")

#|
(defmfun complex-abs (number)
  "gsl_complex_abs"
  (((complex-to-gsl number) :pointer))
  :c-return :double)

(defmfun complex-arg (number)
  "gsl_complex_arg"
  (((complex-to-gsl number) :pointer))
  :c-return :double)
|#

277
;;;;****************************************************************************
278
;;;; Common element type groups for generic functions
279 280 281 282 283 284 285 286 287 288
;;;;****************************************************************************

(defparameter *array-element-types*
  (remove-duplicates (all-types *cstd-cl-type-mapping* t) :test 'equal)
  "All the array element types supported.")

(defparameter *array-element-types-no-complex*
  (remove-if (lambda (tp) (subtypep tp 'complex)) *array-element-types*)
  "All the array element types supported except for complex types.")

289 290
(defparameter *float-complex-types*
  (remove-if (lambda (tp) (subtypep tp 'integer)) *array-element-types*)
291
  "All the float or complex array element types supported.")
292 293 294

(defparameter *float-types*
  (remove-if-not (lambda (tp) (subtypep tp 'float)) *array-element-types*)
295
  "All the float array element types.")
296

297 298 299 300
(defparameter *complex-types*
  (remove-if-not (lambda (tp) (subtypep tp 'complex)) *array-element-types*)
  "All the supported complex array element types.")

301 302 303 304
(defparameter *double-types*
  (list 'double-float '(complex double-float))
  "All the supported double float element types.")

305 306 307 308 309 310 311 312 313 314 315
(defun element-types (element-types)
  "All the element types available of a given category."
  (case element-types
    ((nil t) *array-element-types*)
    (:no-complex *array-element-types-no-complex*)
    (:float *float-types*)
    (:complex *complex-types*)
    (:float-complex *float-complex-types*)
    (:doubles *double-types*)
    (t element-types)))