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