src/aggregates.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          aggregates.cl
   6 ;;;; Purpose:       UFFI source to handle aggregate types
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id: aggregates.lisp,v 1.2 2002/10/14 01:51:15 kevin Exp $
  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 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  20 (in-package :uffi)
  21
  22 (defmacro def-enum (enum-name args &key (separator-string "#"))
  23   "Creates a constants for a C type enum list, symbols are created
  24 in the created in the current package. The symbol is the concatenation
  25 of the enum-name name, separator-string, and field-name"
  26   (let ((counter 0)
  27         (cmds nil)
  28         (constants nil))
  29     (declare (fixnum counter))
  30     (dolist (arg args)
  31       (let ((name (if (listp arg) (car arg) arg))
  32             (value (if (listp arg)
  33                        (prog1
  34                            (setq counter (cadr arg))
  35                          (incf counter))
  36                      (prog1
  37                          counter
  38                        (incf counter)))))
  39         (setq name (intern (concatenate 'string
  40                              (symbol-name enum-name)
  41                              separator-string
  42                              (symbol-name name))))
  43         (push `(uffi:def-constant ,name ,value) constants)))
  44     (setf cmds (append '(progn)
  45                        #+allegro `((ff:def-foreign-type ,enum-name :int))
  46                        #+lispworks `((fli:define-c-typedef ,enum-name :int))
  47                        #+cmu `((alien:def-alien-type ,enum-name alien:signed))
  48                        #+sbcl `((sb-alien:def-alien-type ,enum-name sb-alien:signed))
  49                        #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
  50                        #+openmcl `((ccl::def-foreign-type ,enum-name :int))
  51                        (nreverse constants)))
  52     cmds))
  53
  54
  55 (defmacro def-array-pointer (name-array type)
  56   #+allegro
  57   `(ff:def-foreign-type ,name-array
  58     (:array ,(convert-from-uffi-type type :array)))
  59   #+lispworks
  60   `(fli:define-c-typedef ,name-array
  61     (:c-array ,(convert-from-uffi-type type :array)))
  62   #+cmu
  63   `(alien:def-alien-type ,name-array
  64     (* ,(convert-from-uffi-type type :array)))
  65   #+sbcl
  66   `(sb-alien:def-alien-type ,name-array
  67     (* ,(convert-from-uffi-type type :array)))
  68   #+(and mcl (not openmcl))
  69   `(def-mcl-type ,name-array '(:array ,type))
  70   #+openmcl
  71   `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
  72   )
  73
  74 (defun process-struct-fields (name fields &optional (variant nil))
  75   (let (processed)
  76     (dolist (field fields)
  77       (let* ((field-name (car field))
  78              (type (cadr field))
  79              (def (append (list field-name)
  80                           (if (eq type :pointer-self)
  81                               #+cmu `((* (alien:struct ,name)))
  82                               #+sbcl `((* (sb-alien:struct ,name)))
  83                               #+mcl `((:* (:struct ,name)))
  84                               #-(or cmu sbcl mcl) `((* ,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   #+cmu
  94   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
  95   #+sbcl
  96   `(sb-alien:def-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) (declare (ignore type))
 112   #+allegro
 113   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 114   #+lispworks
 115   `(fli:foreign-slot-value ,obj ,slot)
 116   #+cmu
 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) (declare (ignore type))
 134   #+allegro
 135   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 136   #+lispworks
 137   `(fli:foreign-slot-pointer ,obj ,slot)
 138   #+cmu
 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 ; 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) (declare (ignore type))
 163   #+cmu  `(alien:deref ,obj ,i)
 164   #+sbcl  `(sb-alien:deref ,obj ,i)
 165   #+lispworks `(fli:dereference ,obj :index ,i)
 166   #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
 167   #+mcl
 168   (let* ((array-type (array-type type))
 169          (local-type (convert-from-uffi-type array-type :allocation))
 170          (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
 171     `(,accessor
 172       ,obj
 173       (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
 174   )
 175
 176 ; this expands to the %set-xx functions which has different params than %put-xx
 177 #+mcl
 178 (defmacro deref-array-set (obj type i value)
 179   (let* ((array-type (array-type type))
 180          (local-type (convert-from-uffi-type array-type :allocation))
 181          (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
 182          (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
 183     `(,settor
 184       ,obj
 185       (* (the fixnum ,i) ,(size-of-foreign-type local-type))
 186       ,value)))
 187
 188 #+mcl
 189 (defsetf deref-array deref-array-set)
 190
 191 (defmacro def-union (name &rest fields)
 192   #+allegro
 193   `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
 194   #+lispworks
 195   `(fli:define-c-union ,name ,@(process-struct-fields name fields))
 196   #+cmu
 197   `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
 198   #+sbcl
 199   `(sb-alien:def-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
 200   #+(and mcl (not openmcl))
 201   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
 202   #+openmcl
 203   `(ccl::def-foreign-type nil
 204                           (:union ,name ,@(process-struct-fields name fields)))
 205 )