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 ;;;; $Id: aggregates.cl,v 1.5 2002/03/14 21:32:23 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 (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        (:pointer (:pointer ,(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-args (name args)
  65   (let (processed)
  66     (dolist (arg args)
  67       (let ((field-name (car arg))
  68             (type (cadr arg)))
  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 args)
  79   #+cmu
  80   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-args name args)))
  81   #+allegro
  82   `(ff:def-foreign-type ,name (:struct ,@(process-struct-args name args)))
  83   #+lispworks
  84   `(fli:define-c-struct ,name ,@(process-struct-args name args))
  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
 117
 118
 119