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.lisp,v 1.1 2002/09/30 10:02:36 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 #+(and mcl (not openmcl)) `((def-mcl-type ,enum-name :integer))
49 #+openmcl `((ccl::def-foreign-type ,enum-name :int))
50 (nreverse constants)))
54 (defmacro def-array-pointer (name-array type)
56 `(ff:def-foreign-type ,name-array
57 (:array ,(convert-from-uffi-type type :array)))
59 `(fli:define-c-typedef ,name-array
60 (:c-array ,(convert-from-uffi-type type :array)))
62 `(alien:def-alien-type ,name-array
63 (* ,(convert-from-uffi-type type :array)))
64 #+(and mcl (not openmcl))
65 `(def-mcl-type ,name-array '(:array ,type))
67 `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
70 (defun process-struct-fields (name fields &optional (variant nil))
72 (dolist (field fields)
73 (let* ((field-name (car field))
75 (def (append (list field-name)
76 (if (eq type :pointer-self)
77 #+cmu `((* (alien:struct ,name)))
78 #+mcl `((:* (:struct ,name)))
79 #-(or cmu mcl) `((* ,name))
80 `(,(convert-from-uffi-type type :struct))))))
82 (push (list def) processed)
83 (push def processed))))
84 (nreverse processed)))
87 (defmacro def-struct (name &rest fields)
89 `(alien:def-alien-type ,name (alien:struct ,name ,@(process-struct-fields name fields)))
91 `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
93 `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
94 #+(and mcl (not openmcl))
95 `(ccl:defrecord ,name ,@(process-struct-fields name fields))
97 `(ccl::def-foreign-type
99 (:struct ,name ,@(process-struct-fields name fields)))
103 (defmacro get-slot-value (obj type slot)
104 #+(or lispworks cmu) (declare (ignore type))
106 `(ff:fslot-value-typed ,type :c ,obj ,slot)
108 `(fli:foreign-slot-value ,obj ,slot)
110 `(alien:slot ,obj ,slot)
112 `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
116 (defmacro set-slot-value (obj type slot value) ;use setf to set values
117 `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
120 (defsetf get-slot-value set-slot-value)
123 (defmacro get-slot-pointer (obj type slot)
124 #+(or lispworks cmu) (declare (ignore type))
126 `(ff:fslot-value-typed ,type :c ,obj ,slot)
128 `(fli:foreign-slot-pointer ,obj ,slot)
130 `(alien:slot ,obj ,slot)
131 #+(and mcl (not openmcl))
132 `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
134 `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
135 (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))
138 ; so we could allow '(:array :long) or deref with other type like :long only
140 (defun array-type (type)
143 (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
144 (when (and (listp type-list) (eq (car type-list) :array))
145 (setf result (cadr type-list)))))
149 (defmacro deref-array (obj type i)
150 "Returns a field from a row"
151 #+(or lispworks cmu) (declare (ignore type))
152 #+cmu `(alien:deref ,obj ,i)
153 #+lispworks `(fli:dereference ,obj :index ,i)
154 #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
156 (let* ((array-type (array-type type))
157 (local-type (convert-from-uffi-type array-type :allocation))
158 (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
161 (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
164 ; this expands to the %set-xx functions which has different params than %put-xx
166 (defmacro deref-array-set (obj type i value)
167 (let* ((array-type (array-type type))
168 (local-type (convert-from-uffi-type array-type :allocation))
169 (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
170 (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
173 (* (the fixnum ,i) ,(size-of-foreign-type local-type))
177 (defsetf deref-array deref-array-set)
179 (defmacro def-union (name &rest fields)
181 `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
183 `(fli:define-c-union ,name ,@(process-struct-fields name fields))
185 `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
186 #+(and mcl (not openmcl))
187 `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
189 `(ccl::def-foreign-type nil
190 (:union ,name ,@(process-struct-fields name fields)))