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.4 2002/03/14 21:03:12 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     (dolist (arg args)
  30       (let ((name (if (listp arg) (car arg) arg))
  31             (value (if (listp arg)
  32                        (prog1
  33                            (setq counter (cadr arg))
  34                          (incf counter))
  35                      (prog1
  36                          counter
  37                        (incf counter)))))
  38         (setq name (intern (concatenate 'string
  39                              (symbol-name enum-name)
  40                              separator-string
  41                              (symbol-name name))))
  42         (push `(uffi:def-constant ,name ,value) constants)))
  43     (setf cmds (append '(progn)
  44                        #+allegro `((ff:def-foreign-type ,enum-name :int))
  45                        #+lispworks `((fli:define-c-typedef ,enum-name :int))
  46                        #+cmu `((alien:def-alien-type ,enum-name alien:signed))
  47                        (nreverse constants)))
  48     cmds))
  49
  50
  51 (defmacro def-array (name-array type)
  52   #+allegro
  53   `(ff:def-foreign-type ,name-array
  54        (:array ,(convert-from-uffi-type type :array)))
  55   #+lispworks
  56   `(fli:define-c-typedef ,name-array
  57        (:pointer (:pointer ,(convert-from-uffi-type type :array))))
  58   #+cmu
  59   `(alien:def-alien-type ,name-array
  60        (* ,(convert-from-uffi-type type :array)))
  61   )
  62
  63 (defun process-struct-args (name args)
  64   (let (processed)
  65     (dolist (arg args)
  66       (let ((field-name (car arg))
  67             (type (cadr arg)))
  68         (push (append (list field-name)
  69                     (if (eq type :pointer-self)
  70                         #+cmu `((* (alien:struct ,name)))
  71                         #-cmu `((* ,name))
  72                         `(,(convert-from-uffi-type type :struct))))
  73                     processed)))
  74     (nreverse processed)))
  75
  76
  77 (defmacro def-struct (name &rest args)
  78   #+cmu
  79   `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-args name args)))
  80   #+allegro
  81   `(ff:def-foreign-type ,name (:struct ,@(process-struct-args name args)))
  82   #+lispworks
  83   `(fli:define-c-struct ,name ,@(process-struct-args name args))
  84   )
  85
  86
  87 (defmacro get-slot-value (obj type slot)
  88   #+(or lispworks cmu) (declare (ignore type))
  89   #+allegro
  90   `(ff:fslot-value-typed ,type :c ,obj ,slot)
  91   #+lispworks
  92   `(fli:foreign-slot-value ,obj ,slot)
  93   #+cmu
  94   `(alien:slot ,obj ,slot)
  95   )
  96
  97 (defmacro get-slot-pointer (obj type slot)
  98   #+(or lispworks cmu) (declare (ignore type))
  99   #+allegro
 100   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 101   #+lispworks
 102   `(fli:foreign-slot-pointer ,obj ,slot)
 103   #+cmu
 104   `(alien:slot ,obj ,slot)
 105   )
 106
 107 (defmacro deref-array (obj type i)
 108   "Returns a field from a row"
 109   #+(or lispworks cmu) (declare (ignore type))
 110   #+cmu  `(alien:deref ,obj ,i)
 111   #+lispworks `(fli:dereference ,obj :index ,i)
 112   #+allegro `(ff:fslot-value-typed ,type :c ,obj ,i)
 113   )
 114
 115
 116
 117
 118