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: aggregates.lisp,v 1.7 2003/06/06 21:59:18 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 (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                               #-(or cmu sbcl scl mcl) `((* ,name))
  84                               `(,(convert-from-uffi-type type :struct))))))
  85         (if variant
  86             (push (list def) processed)
  87           (push def processed))))
  88     (nreverse processed)))
  89
  90
  91 (defmacro def-struct (name &rest fields)
  92   #+(or cmu scl)
  93   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
  94   #+sbcl
  95   `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
  96   #+allegro
  97   `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
  98   #+lispworks
  99   `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
 100   #+(and mcl (not openmcl))
 101   `(ccl:defrecord ,name ,@(process-struct-fields name fields))
 102   #+openmcl
 103   `(ccl::def-foreign-type
 104     nil
 105     (:struct ,name ,@(process-struct-fields name fields)))
 106   )
 107
 108
 109 (defmacro get-slot-value (obj type slot)
 110   #+(or lispworks cmu sbcl scl) (declare (ignore type))
 111   #+allegro
 112   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 113   #+lispworks
 114   `(fli:foreign-slot-value ,obj ,slot)
 115   #+(or cmu scl)
 116   `(alien:slot ,obj ,slot)
 117   #+sbcl
 118   `(sb-alien:slot ,obj ,slot)
 119   #+mcl
 120   `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
 121   )
 122
 123 #+mcl
 124 (defmacro set-slot-value (obj type slot value) ;use setf to set values
 125   `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
 126
 127 #+mcl
 128 (defsetf get-slot-value set-slot-value)
 129
 130
 131 (defmacro get-slot-pointer (obj type slot)
 132   #+(or lispworks cmu sbcl scl) (declare (ignore type))
 133   #+allegro
 134   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 135   #+lispworks
 136   `(fli:foreign-slot-pointer ,obj ,slot)
 137   #+(or cmu scl)
 138   `(alien:slot ,obj ,slot)
 139   #+sbcl
 140   `(sb-alien:slot ,obj ,slot)
 141   #+(and mcl (not openmcl))
 142   `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
 143   #+openmcl
 144   `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
 145      (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))
 146 )
 147
 148 ; so we could allow '(:array :long) or deref with other type like :long only
 149 #+mcl
 150 (defun array-type (type)
 151   (let ((result type))
 152     (when (listp type)
 153       (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
 154         (when (and (listp type-list) (eq (car type-list) :array))
 155           (setf result (cadr type-list)))))
 156     result))
 157
 158
 159 (defmacro deref-array (obj type i)
 160   "Returns a field from a row"
 161   #+(or lispworks cmu sbcl scl) (declare (ignore type))
 162   #+(or cmu scl)  `(alien:deref ,obj ,i)
 163   #+sbcl  `(sb-alien:deref ,obj ,i)
 164   #+lispworks `(fli:dereference ,obj :index ,i)
 165   #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
 166   #+mcl
 167   (let* ((array-type (array-type type))
 168          (local-type (convert-from-uffi-type array-type :allocation))
 169          (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
 170     `(,accessor
 171       ,obj
 172       (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
 173   )
 174
 175 ; this expands to the %set-xx functions which has different params than %put-xx
 176 #+mcl
 177 (defmacro deref-array-set (obj type i value)
 178   (let* ((array-type (array-type type))
 179          (local-type (convert-from-uffi-type array-type :allocation))
 180          (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
 181          (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
 182     `(,settor
 183       ,obj
 184       (* (the fixnum ,i) ,(size-of-foreign-type local-type))
 185       ,value)))
 186
 187 #+mcl
 188 (defsetf deref-array deref-array-set)
 189
 190 (defmacro def-union (name &rest fields)
 191   #+allegro
 192   `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
 193   #+lispworks
 194   `(fli:define-c-union ,name ,@(process-struct-fields name fields))
 195   #+(or cmu scl)
 196   `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
 197   #+sbcl
 198   `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
 199   #+(and mcl (not openmcl))
 200   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
 201   #+openmcl
 202   `(ccl::def-foreign-type nil
 203                           (:union ,name ,@(process-struct-fields name fields)))
 204 )