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