src/aggregates.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          aggregates.lisp
   6 ;;;; Purpose:       UFFI source to handle aggregate types
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; *************************************************************************
  13
  14 (in-package #:uffi)
  15
  16 (defmacro def-enum (enum-name args &key (separator-string "#"))
  17   "Creates a constants for a C type enum list, symbols are created
  18 in the created in the current package. The symbol is the concatenation
  19 of the enum-name name, separator-string, and field-name"
  20   (let ((counter 0)
  21         (cmds nil)
  22         (constants nil))
  23     (declare (fixnum counter))
  24     (dolist (arg args)
  25       (let ((name (if (listp arg) (car arg) arg))
  26             (value (if (listp arg)
  27                        (prog1
  28                            (setq counter (cadr arg))
  29                          (incf counter))
  30                      (prog1
  31                          counter
  32                        (incf counter)))))
  33         (setq name (intern (concatenate 'string
  34                              (symbol-name enum-name)
  35                              separator-string
  36                              (symbol-name name))))
  37         (push `(uffi:def-constant ,name ,value) constants)))
  38     (setf cmds (append '(progn)
  39                        #+allegro `((ff:def-foreign-type ,enum-name :int))
  40                        #+lispworks `((fli:define-c-typedef ,enum-name :int))
  41                        #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
  42                        #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
  43                        #+digitool `((def-mcl-type ,enum-name :integer))
  44                        #+openmcl `((ccl::def-foreign-type ,enum-name :int))
  45                        (nreverse constants)))
  46     cmds))
  47
  48
  49 (defmacro def-array-pointer (name-array type)
  50   #+allegro
  51   `(ff:def-foreign-type ,name-array
  52     (:array ,(convert-from-uffi-type type :array)))
  53   #+lispworks
  54   `(fli:define-c-typedef ,name-array
  55     (:c-array ,(convert-from-uffi-type type :array)))
  56   #+(or cmu scl)
  57   `(alien:def-alien-type ,name-array
  58     (* ,(convert-from-uffi-type type :array)))
  59   #+sbcl
  60   `(sb-alien:define-alien-type ,name-array
  61     (* ,(convert-from-uffi-type type :array)))
  62   #+digitool
  63   `(def-mcl-type ,name-array '(:array ,type))
  64   #+openmcl
  65   `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
  66   )
  67
  68 (defun process-struct-fields (name fields &optional (variant nil))
  69   (let (processed)
  70     (dolist (field fields)
  71       (let* ((field-name (car field))
  72              (type (cadr field))
  73              (def (append (list field-name)
  74                           (if (eq type :pointer-self)
  75                               #+(or cmu scl) `((* (alien:struct ,name)))
  76                               #+sbcl `((* (sb-alien:struct ,name)))
  77                               #+(or openmcl digitool) `((:* (:struct ,name)))
  78                               #+lispworks `((:pointer ,name))
  79                               #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,name))
  80                               `(,(convert-from-uffi-type type :struct))))))
  81         (if variant
  82             (push (list def) processed)
  83           (push def processed))))
  84     (nreverse processed)))
  85
  86
  87 (defmacro def-struct (name &rest fields)
  88   #+(or cmu scl)
  89   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
  90   #+sbcl
  91   `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
  92   #+allegro
  93   `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
  94   #+lispworks
  95   `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
  96   #+digitool
  97   `(ccl:defrecord ,name ,@(process-struct-fields name fields))
  98   #+openmcl
  99   `(ccl::def-foreign-type
 100     nil
 101     (:struct ,name ,@(process-struct-fields name fields)))
 102   )
 103
 104
 105 (defmacro get-slot-value (obj type slot)
 106   #+(or lispworks cmu sbcl scl) (declare (ignore type))
 107   #+allegro
 108   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 109   #+lispworks
 110   `(fli:foreign-slot-value ,obj ,slot)
 111   #+(or cmu scl)
 112   `(alien:slot ,obj ,slot)
 113   #+sbcl
 114   `(sb-alien:slot ,obj ,slot)
 115   #+(or openmcl digitool)
 116   `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
 117   )
 118
 119 #+(or openmcl digitool)
 120 (defmacro set-slot-value (obj type slot value) ;use setf to set values
 121   `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
 122
 123 #+(or openmcl digitool)
 124 (defsetf get-slot-value set-slot-value)
 125
 126
 127 (defmacro get-slot-pointer (obj type slot)
 128   #+(or lispworks cmu sbcl scl) (declare (ignore type))
 129   #+allegro
 130   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 131   #+lispworks
 132   `(fli:foreign-slot-pointer ,obj ,slot)
 133   #+(or cmu scl)
 134   `(alien:slot ,obj ,slot)
 135   #+sbcl
 136   `(sb-alien:slot ,obj ,slot)
 137   #+digitool
 138   `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
 139   #+openmcl
 140   `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
 141      (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))
 142 )
 143
 144 ;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8
 145 ;; below
 146 (eval-when (:compile-toplevel :load-toplevel :execute)
 147   ;; so we could allow '(:array :long) or deref with other type like :long only
 148   #+(or openmcl digitool)
 149   (defun array-type (type)
 150     (let ((result type))
 151       (when (listp type)
 152         (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
 153           (when (and (listp type-list) (eq (car type-list) :array))
 154             (setf result (cadr type-list)))))
 155       result))
 156
 157
 158   (defmacro deref-array (obj type i)
 159     "Returns a field from a row"
 160     #+(or lispworks cmu sbcl scl) (declare (ignore type))
 161     #+(or cmu scl)  `(alien:deref ,obj ,i)
 162     #+sbcl `(sb-alien:deref ,obj ,i)
 163     #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil)
 164     #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
 165     #+openmcl
 166     (let* ((array-type (array-type type))
 167            (local-type (convert-from-uffi-type array-type :allocation))
 168            (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
 169       (ccl::%foreign-access-form
 170        obj
 171        (ccl::%foreign-type-or-record local-type)
 172        `(* ,i ,element-size-in-bits)
 173        nil))
 174     #+digitool
 175     (let* ((array-type (array-type type))
 176            (local-type (convert-from-uffi-type array-type :allocation))
 177            (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
 178       `(,accessor
 179         ,obj
 180         (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
 181     ))
 182
 183 ; this expands to the %set-xx functions which has different params than %put-xx
 184 #+digitool
 185 (defmacro deref-array-set (obj type i value)
 186   (let* ((array-type (array-type type))
 187          (local-type (convert-from-uffi-type array-type :allocation))
 188          (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
 189          (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
 190     `(,settor
 191       ,obj
 192       (* (the fixnum ,i) ,(size-of-foreign-type local-type))
 193       ,value)))
 194
 195 #+digitool
 196 (defsetf deref-array deref-array-set)
 197
 198 (defmacro def-union (name &rest fields)
 199   #+allegro
 200   `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
 201   #+lispworks
 202   `(fli:define-c-union ,name ,@(process-struct-fields name fields))
 203   #+(or cmu scl)
 204   `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
 205   #+sbcl
 206   `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
 207   #+digitool
 208   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
 209   #+openmcl
 210   `(ccl::def-foreign-type nil
 211                           (:union ,name ,@(process-struct-fields name fields)))
 212 )
 213
 214
 215 #-(or sbcl cmu)
 216 (defun convert-from-foreign-usb8 (s len)
 217   (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
 218            (fixnum len))
 219   (let ((a (make-array len :element-type '(unsigned-byte 8))))
 220     (dotimes (i len a)
 221       (declare (fixnum i))
 222       (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
 223
 224 #+sbcl
 225 (eval-when (:compile-toplevel :load-toplevel :execute)
 226   (sb-ext:without-package-locks
 227       (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
 228                                    (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
 229                                    (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")))
 230     (defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
 231                                           (* sb-vm:vector-data-offset sb-vm:n-word-bits)
 232                                           0))
 233     (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
 234                                               sb-vm:n-byte-bits
 235                                               1))))
 236
 237
 238 #+sbcl
 239 (defun convert-from-foreign-usb8 (s len)
 240   (let ((sap (sb-alien:alien-sap s)))
 241     (declare (type sb-sys:system-area-pointer sap))
 242     (locally
 243      (declare (optimize (speed 3) (safety 0)))
 244      (let ((result (make-array len :element-type '(unsigned-byte 8))))
 245        (funcall *system-copy-fn* sap 0 result +system-copy-offset+
 246                 (* len +system-copy-multiplier+))
 247        result))))
 248
 249 #+cmu
 250 (defun convert-from-foreign-usb8 (s len)
 251   (let ((sap (alien:alien-sap s)))
 252     (declare (type system:system-area-pointer sap))
 253     (locally
 254         (declare (optimize (speed 3) (safety 0)))
 255       (let ((result (make-array len :element-type '(unsigned-byte 8))))
 256         (kernel:copy-from-system-area sap 0
 257                                       result (* vm:vector-data-offset
 258                                                 vm:word-bits)
 259                                       (* len vm:byte-bits))
 260         result))))