src-main/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.1 2002/09/16 17:54:30 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                        (nreverse constants)))
  49     cmds))
  50
  51
  52 (defmacro def-array-pointer (name-array type)
  53   #+allegro
  54   `(ff:def-foreign-type ,name-array
  55     (:array ,(convert-from-uffi-type type :array)))
  56   #+lispworks
  57   `(fli:define-c-typedef ,name-array
  58     (:c-array ,(convert-from-uffi-type type :array)))
  59   #+cmu
  60   `(alien:def-alien-type ,name-array
  61     (* ,(convert-from-uffi-type type :array)))
  62   )
  63
  64 (defun process-struct-fields (name fields)
  65   (let (processed)
  66     (dolist (field fields)
  67       (let ((field-name (car field))
  68             (type (cadr field)))
  69         (push (append (list field-name)
  70                     (if (eq type :pointer-self)
  71                         #+cmu `((* (alien:struct ,name)))
  72                         #-cmu `((* ,name))
  73                         `(,(convert-from-uffi-type type :struct))))
  74                     processed)))
  75     (nreverse processed)))
  76
  77
  78 (defmacro def-struct (name &rest fields)
  79   #+cmu
  80   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
  81   #+allegro
  82   `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
  83   #+lispworks
  84   `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
  85   )
  86
  87
  88 (defmacro get-slot-value (obj type slot)
  89   #+(or lispworks cmu) (declare (ignore type))
  90   #+allegro
  91   `(ff:fslot-value-typed ,type :c ,obj ,slot)
  92   #+lispworks
  93   `(fli:foreign-slot-value ,obj ,slot)
  94   #+cmu
  95   `(alien:slot ,obj ,slot)
  96   )
  97
  98 (defmacro get-slot-pointer (obj type slot)
  99   #+(or lispworks cmu) (declare (ignore type))
 100   #+allegro
 101   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 102   #+lispworks
 103   `(fli:foreign-slot-pointer ,obj ,slot)
 104   #+cmu
 105   `(alien:slot ,obj ,slot)
 106   )
 107
 108 (defmacro deref-array (obj type i)
 109   "Returns a field from a row"
 110   #+(or lispworks cmu) (declare (ignore type))
 111   #+cmu  `(alien:deref ,obj ,i)
 112   #+lispworks `(fli:dereference ,obj :index ,i)
 113   #+allegro `(ff:fslot-value-typed ,type :c ,obj ,i)
 114   )
 115
 116 (defmacro def-union (name &rest fields)
 117   #+allegro
 118   `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
 119   #+lispworks
 120   `(fli:define-c-union ,name ,@(process-struct-fields name fields))
 121   #+cmu
 122   `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
 123 )
 124
 125