1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: aggregates.lisp
6 ;;;; Purpose: UFFI source to handle aggregate types
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Feb 2002
10 ;;;; This file, part of UFFI, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
12 ;;;; *************************************************************************
16 (defmacro def-enum (enum-name args &key (separator-string "#"))
17 "Creates a constants for a C type enum list, symbols are created
18 in the created in the current package. The symbol is the concatenation
19 of the enum-name name, separator-string, and field-name"
23 (declare (fixnum counter))
25 (let ((name (if (listp arg) (car arg) arg))
26 (value (if (listp arg)
28 (setq counter (cadr arg))
33 (setq name (intern (concatenate 'string
34 (symbol-name enum-name)
37 (push `(uffi:def-constant ,name ,value) constants)))
38 (setf cmds (append '(progn)
39 #+allegro `((ff:def-foreign-type ,enum-name :int))
40 #+lispworks `((fli:define-c-typedef ,enum-name :int))
41 #+(or cmu scl) `((alien:def-alien-type ,enum-name alien:signed))
42 #+sbcl `((sb-alien:define-alien-type ,enum-name sb-alien:signed))
43 #+digitool `((def-mcl-type ,enum-name :integer))
44 #+openmcl `((ccl::def-foreign-type ,enum-name :int))
45 (nreverse constants)))
49 (defmacro def-array-pointer (name-array type)
51 `(ff:def-foreign-type ,name-array
52 (:array ,(convert-from-uffi-type type :array)))
54 `(fli:define-c-typedef ,name-array
55 (:c-array ,(convert-from-uffi-type type :array)))
57 `(alien:def-alien-type ,name-array
58 (* ,(convert-from-uffi-type type :array)))
60 `(sb-alien:define-alien-type ,name-array
61 (* ,(convert-from-uffi-type type :array)))
63 `(def-mcl-type ,name-array '(:array ,type))
65 `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array)))
68 (defun process-struct-fields (name fields &optional (variant nil))
70 (dolist (field fields)
71 (let* ((field-name (car field))
73 (def (append (list field-name)
74 (if (eq type :pointer-self)
75 #+(or cmu scl) `((* (alien:struct ,name)))
76 #+sbcl `((* (sb-alien:struct ,name)))
77 #+(or openmcl digitool) `((:* (:struct ,name)))
78 #+lispworks `((:pointer ,name))
79 #-(or cmu sbcl scl openmcl digitool lispworks) `((* ,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 `(sb-alien:define-alien-type ,name (sb-alien:struct ,name ,@(process-struct-fields name fields)))
93 `(ff:def-foreign-type ,name (:struct ,@(process-struct-fields name fields)))
95 `(fli:define-c-struct ,name ,@(process-struct-fields name fields))
97 `(ccl:defrecord ,name ,@(process-struct-fields name fields))
99 `(ccl::def-foreign-type
101 (:struct ,name ,@(process-struct-fields name fields)))
105 (defmacro get-slot-value (obj type slot)
106 #+(or lispworks cmu sbcl scl) (declare (ignore type))
108 `(ff:fslot-value-typed ,type :c ,obj ,slot)
110 `(fli:foreign-slot-value ,obj ,slot)
112 `(alien:slot ,obj ,slot)
114 `(sb-alien:slot ,obj ,slot)
115 #+(or openmcl digitool)
116 `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot))))
119 #+(or openmcl digitool)
120 (defmacro set-slot-value (obj type slot value) ;use setf to set values
121 `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
123 #+(or openmcl digitool)
124 (defsetf get-slot-value set-slot-value)
127 (defmacro get-slot-pointer (obj type slot)
128 #+(or lispworks cmu sbcl scl) (declare (ignore type))
130 `(ff:fslot-value-typed ,type :c ,obj ,slot)
132 `(fli:foreign-slot-pointer ,obj ,slot)
134 `(alien:slot ,obj ,slot)
136 `(sb-alien:slot ,obj ,slot)
138 `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot))))
140 `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
141 (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field)))))
144 ;; necessary to eval at compile time for openmcl to compile convert-from-foreign-usb8
146 (eval-when (:compile-toplevel :load-toplevel :execute)
147 ;; so we could allow '(:array :long) or deref with other type like :long only
148 #+(or openmcl digitool)
149 (defun array-type (type)
152 (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
153 (when (and (listp type-list) (eq (car type-list) :array))
154 (setf result (cadr type-list)))))
158 (defmacro deref-array (obj type i)
159 "Returns a field from a row"
160 #+(or lispworks cmu sbcl scl) (declare (ignore type))
161 #+(or cmu scl) `(alien:deref ,obj ,i)
162 #+sbcl `(sb-alien:deref ,obj ,i)
163 #+lispworks `(fli:dereference ,obj :index ,i :copy-foreign-object nil)
164 #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
166 (let* ((array-type (array-type type))
167 (local-type (convert-from-uffi-type array-type :allocation))
168 (element-size-in-bits (ccl::%foreign-type-or-record-size local-type :bits)))
169 (ccl::%foreign-access-form
171 (ccl::%foreign-type-or-record local-type)
172 `(* ,i ,element-size-in-bits)
175 (let* ((array-type (array-type type))
176 (local-type (convert-from-uffi-type array-type :allocation))
177 (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
180 (* (the fixnum ,i) ,(size-of-foreign-type local-type))))
183 ; this expands to the %set-xx functions which has different params than %put-xx
185 (defmacro deref-array-set (obj type i value)
186 (let* ((array-type (array-type type))
187 (local-type (convert-from-uffi-type array-type :allocation))
188 (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
189 (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
192 (* (the fixnum ,i) ,(size-of-foreign-type local-type))
196 (defsetf deref-array deref-array-set)
198 (defmacro def-union (name &rest fields)
200 `(ff:def-foreign-type ,name (:union ,@(process-struct-fields name fields)))
202 `(fli:define-c-union ,name ,@(process-struct-fields name fields))
204 `(alien:def-alien-type ,name (alien:union ,name ,@(process-struct-fields name fields)))
206 `(sb-alien:define-alien-type ,name (sb-alien:union ,name ,@(process-struct-fields name fields)))
208 `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t)))
210 `(ccl::def-foreign-type nil
211 (:union ,name ,@(process-struct-fields name fields)))
216 (defun convert-from-foreign-usb8 (s len)
217 (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
219 (let ((a (make-array len :element-type '(unsigned-byte 8))))
222 (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
225 (eval-when (:compile-toplevel :load-toplevel :execute)
226 (sb-ext:without-package-locks
227 (defvar *system-copy-fn* (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
228 (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL")
229 (intern "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL")))
230 (defconstant +system-copy-offset+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
231 (* sb-vm:vector-data-offset sb-vm:n-word-bits)
233 (defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
239 (defun convert-from-foreign-usb8 (s len)
240 (let ((sap (sb-alien:alien-sap s)))
241 (declare (type sb-sys:system-area-pointer sap))
243 (declare (optimize (speed 3) (safety 0)))
244 (let ((result (make-array len :element-type '(unsigned-byte 8))))
245 (funcall *system-copy-fn* sap 0 result +system-copy-offset+
246 (* len +system-copy-multiplier+))
250 (defun convert-from-foreign-usb8 (s len)
251 (let ((sap (alien:alien-sap s)))
252 (declare (type system:system-area-pointer sap))
254 (declare (optimize (speed 3) (safety 0)))
255 (let ((result (make-array len :element-type '(unsigned-byte 8))))
256 (kernel:copy-from-system-area sap 0
257 result (* vm:vector-data-offset
259 (* len vm:byte-bits))