src/aggregates.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   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 ;;;; Copyright (c) 2002 Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; $Id: aggregates.cl,v 1.1 2002/03/09 19:55:33 kevin Exp $
  13 ;;;;
  14 ;;;; This file is part of the UFFI.
  15 ;;;;
  16 ;;;; UFFI is free software; you can redistribute it and/or modify
  17 ;;;; it under the terms of the GNU General Public License (version 2) as
  18 ;;;; published by the Free Software Foundation.
  19 ;;;;
  20 ;;;; UFFI is distributed in the hope that it will be useful,
  21 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;;;; GNU General Public License for more details.
  24 ;;;;
  25 ;;;; You should have received a copy of the GNU General Public License
  26 ;;;; along with UFFI; if not, write to the Free Software
  27 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  28 ;;;; *************************************************************************
  29
  30 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  31 (in-package :uffi)
  32
  33 (defmacro def-enum (enum-name args &key (separator-string "#"))
  34   "Creates a constants for a C type enum list, symbols are created
  35 in the created in the current package. The symbol is the concatenation
  36 of the enum-name name, separator-string, and field-name"
  37   (let ((counter 0)
  38         (cmds nil)
  39         (constants nil))
  40     (dolist (arg args)
  41       (let ((name (if (listp arg) (car arg) arg))
  42             (value (if (listp arg)
  43                        (prog1
  44                            (setq counter (cadr arg))
  45                          (incf counter))
  46                      (prog1
  47                          counter
  48                        (incf counter)))))
  49         (setq name (intern (concatenate 'string
  50                              (symbol-name enum-name)
  51                              separator-string
  52                              (symbol-name name))))
  53         (push `(uffi:def-constant ,name ,value) constants)))
  54     (setf cmds (append '(progn)
  55                        #+allegro `((ff:def-foreign-type ,enum-name :int))
  56                        #+lispworks `((fli:define-c-typedef ,enum-name :int))
  57                        #+cmu `((alien:def-alien-type ,enum-name alien:signed))
  58                        (nreverse constants)))
  59     cmds))
  60
  61
  62 (defmacro def-array (name-array type)
  63   #+allegro
  64   `(ff:def-foreign-type ,name-array
  65        (:struct (:my-field (:array ,(convert-from-uffi-type type :array)))))
  66   #+lispworks
  67   `(fli:define-c-typedef ,name-array
  68        (:pointer (:pointer ,(convert-from-uffi-type type :array))))
  69   #+cmu
  70   `(alien:def-alien-type ,name-array
  71        (* ,(convert-from-uffi-type type :array)))
  72   )
  73
  74 (defun process-struct-args (name args)
  75   (let (processed)
  76     (dolist (arg args)
  77       (let ((field-name (car arg))
  78             (type (cadr arg)))
  79         (push (append (list field-name)
  80                     (if (eq type :pointer-self)
  81                         #+cmu `((* (alien:struct ,name)))
  82                         #-cmu `((* ,name))
  83                         `(,(convert-from-uffi-type type :struct))))
  84                     processed)))
  85     (nreverse processed)))
  86
  87
  88 (defmacro def-struct (name &rest args)
  89   #+cmu
  90   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-args name args)))
  91   #+allegro
  92   `(ff:def-foreign-type ,name (:struct ,@(process-struct-args name args)))
  93   #+lispworks
  94   `(fli:define-c-struct ,name ,@(process-struct-args name args))
  95   )
  96
  97
  98 (defmacro get-slot-value (obj slot type)
  99   #+(or lispworks cmu) (declare (ignore type))
 100   #+allegro
 101   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 102   #+lispworks
 103   `(fli:foreign-slot-value ,obj ,slot)
 104   #+cmu
 105   `(alien:slot ,obj ,slot)
 106   )
 107
 108 (defmacro get-slot-pointer (obj slot type)
 109   #+(or lispworks cmu) (declare (ignore type))
 110   #+allegro
 111   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 112   #+lispworks
 113   `(fli:foreign-slot-pointer ,obj ,slot)
 114   #+cmu
 115   `(alien:slot ,obj ,slot)
 116   )
 117
 118 (defmacro deref-array (obj i type)
 119   "Returns a field from a row"
 120   #+(or lispworks cmu) (declare (ignore type))
 121   #+cmu  `(alien:deref ,obj ,i)
 122   #+lispworks `(fli:dereference ,obj :index ,i)
 123   #+allegro `(ff:fslot-value-typed ,type :c ,obj ':my-field ,i)
 124   )
 125
 126
 127
 128
 129