1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
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 ;;;; $Id: aggregates.cl,v 1.3 2002/09/30 01:57:32 kevin Exp $
12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
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 ;;;; *************************************************************************
19 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
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"
29 (declare (fixnum counter))
31 (let ((name (if (listp arg) (car arg) arg))
32 (value (if (listp arg)
34 (setq counter (cadr arg))
39 (setq name (intern (concatenate 'string
40 (symbol-name enum-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)))
52 (defmacro def-array-pointer (name-array type)
54 `(ff:def-foreign-type ,name-array
55 (:array ,(convert-from-uffi-type type :array)))
57 `(fli:define-c-typedef ,name-array
58 (:c-array ,(convert-from-uffi-type type :array)))
60 `(alien:def-alien-type ,name-array
61 (* ,(convert-from-uffi-type type :array)))
64 (defun process-struct-fields (name fields)
66 (dolist (field fields)
67 (let ((field-name (car field))
69 (push (append (list field-name)
70 (if (eq type :pointer-self)
71 #+cmu `((* (alien:struct ,name)))
73 `(,(convert-from-uffi-type type :struct))))
75 (nreverse processed)))
78 (defmacro def-struct (name &rest fields)
80 `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
82 `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
84 `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
88 (defmacro get-slot-value (obj type slot)
89 #+(or lispworks cmu) (declare (ignore type))
91 `(ff:fslot-value-typed ,type :c ,obj ,slot)
93 `(fli:foreign-slot-value ,obj ,slot)
95 `(alien:slot ,obj ,slot)
98 (defmacro get-slot-pointer (obj type slot)
99 #+(or lispworks cmu) (declare (ignore type))
101 `(ff:fslot-value-typed ,type :c ,obj ,slot)
103 `(fli:foreign-slot-pointer ,obj ,slot)
105 `(alien:slot ,obj ,slot)
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 (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
116 (defmacro def-union (name &rest fields)
118 `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
120 `(fli:define-c-union ,name ,@(process-struct-fields name fields))
122 `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))