src/aggregates.cl

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