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