1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: aggregates.cl
6 ;;;; Purpose: UFFI source to handle aggregate types
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Feb 2002
10 ;;;; Copyright (c) 2002 Kevin M. Rosenberg
12 ;;;; $Id: aggregates.cl,v 1.1 2002/03/09 19:55:33 kevin Exp $
14 ;;;; This file is part of the UFFI.
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.
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.
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 ;;;; *************************************************************************
30 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
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"
41 (let ((name (if (listp arg) (car arg) arg))
42 (value (if (listp arg)
44 (setq counter (cadr arg))
49 (setq name (intern (concatenate 'string
50 (symbol-name enum-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)))
62 (defmacro def-array (name-array type)
64 `(ff:def-foreign-type ,name-array
65 (:struct (:my-field (:array ,(convert-from-uffi-type type :array)))))
67 `(fli:define-c-typedef ,name-array
68 (:pointer (:pointer ,(convert-from-uffi-type type :array))))
70 `(alien:def-alien-type ,name-array
71 (* ,(convert-from-uffi-type type :array)))
74 (defun process-struct-args (name args)
77 (let ((field-name (car arg))
79 (push (append (list field-name)
80 (if (eq type :pointer-self)
81 #+cmu `((* (alien:struct ,name)))
83 `(,(convert-from-uffi-type type :struct))))
85 (nreverse processed)))
88 (defmacro def-struct (name &rest args)
90 `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-args name args)))
92 `(ff:def-foreign-type ,name (:struct ,@(process-struct-args name args)))
94 `(fli:define-c-struct ,name ,@(process-struct-args name args))
98 (defmacro get-slot-value (obj slot type)
99 #+(or lispworks cmu) (declare (ignore type))
101 `(ff:fslot-value-typed ,type :c ,obj ,slot)
103 `(fli:foreign-slot-value ,obj ,slot)
105 `(alien:slot ,obj ,slot)
108 (defmacro get-slot-pointer (obj slot type)
109 #+(or lispworks cmu) (declare (ignore type))
111 `(ff:fslot-value-typed ,type :c ,obj ,slot)
113 `(fli:foreign-slot-pointer ,obj ,slot)
115 `(alien:slot ,obj ,slot)
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)