/[cl-gsl]/cl-gsl/ffi.lisp
ViewVC logotype

Contents of /cl-gsl/ffi.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sat Apr 30 22:34:25 2005 UTC (8 years, 11 months ago) by edenny
Branch: MAIN
Changes since 1.5: +7 -3 lines
Added permutation structure and pointer.
1 ;;;; -*- Mode: Lisp; Synatx: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;;
3 ;;;; Copyright (C) 2005 Edgar Denny <edgardenny@comcast.net>
4 ;;;; This file is part of CL-GSL.
5 ;;;;
6 ;;;; This program is free software; you can redistribute it and/or modify
7 ;;;; it under the terms of the GNU General Public License as published by
8 ;;;; the Free Software Foundation; either version 2 of the License, or
9 ;;;; (at your option) any later version.
10 ;;;;
11 ;;;; This program is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;;; GNU General Public License for more details.
15 ;;;;
16 ;;;; You should have received a copy of the GNU General Public License
17 ;;;; along with this program; if not, write to the Free Software
18 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19
20 (in-package #:cl-gsl)
21
22 (defvar +null-void-pointer+ (uffi:make-null-pointer :void))
23
24 (defun t/nil->1/0 (val)
25 (if val 1 0))
26
27 (defun 1/0->t/nil (val)
28 (if (equal val 1) t nil))
29
30 (defun string_->string- (str)
31 (cl-ppcre:regex-replace-all "_" str "-"))
32
33 ;; ----------------------------------------------------------------------
34
35 (defmacro defun-foreign (name params+types ret-type)
36 `(uffi:def-function
37 ,name
38 ,params+types
39 :module "cl-gsl"
40 :returning ,ret-type))
41
42 (defmacro define-foreign-type (gsl-type uffi-type)
43 (let ((new-type (kmrcl:concat-symbol gsl-type "-def")))
44 `(progn
45 (uffi:def-foreign-type ,gsl-type ,uffi-type)
46 (uffi:def-type ,new-type ,uffi-type)
47 (export '(,gsl-type ,new-type)))))
48
49 (defmacro def-foreign-struct (name &rest params+types)
50 (let ((new-type (kmrcl:concat-symbol name "-def")))
51 `(progn
52 (uffi:def-struct ,name
53 ,@params+types)
54 (uffi:def-type ,new-type ,name)
55 (export '(,name ,new-type)))))
56
57 ;; ----------------------------------------------------------------------
58
59 (define-foreign-type size-t :unsigned-long)
60
61 (def-foreign-struct gsl-complex
62 (dat (:array :double 2)))
63
64 (def-foreign-struct gsl-poly-complex-workspace
65 (nc size-t)
66 (matrix (* :double)))
67
68 (def-foreign-struct gsl-complex-float
69 (dat (:array :float 2)))
70
71 (def-foreign-struct gsl-permutation-struct
72 (size size-t)
73 (data (* size-t)))
74
75 ;; ----------------------------------------------------------------------
76
77 (defmacro def-block-vector-matrix-struct% (struct-postfix data-type)
78 `(progn
79 (def-foreign-struct ,(kmrcl:concat-symbol 'gsl-block struct-postfix)
80 (size :unsigned-long)
81 (data (* ,data-type)))
82
83 (def-foreign-struct ,(kmrcl:concat-symbol 'gsl-vector struct-postfix)
84 (size :unsigned-long)
85 (stride :unsigned-long)
86 (data (* ,data-type))
87 (g-block (* ,(kmrcl:concat-symbol 'gsl-block struct-postfix)))
88 (owner :int))
89
90 (def-foreign-struct ,(kmrcl:concat-symbol 'gsl-matrix struct-postfix)
91 (size1 :unsigned-long)
92 (size2 :unsigned-long)
93 (tda :unsigned-long)
94 (data (* ,data-type))
95 (g-block (* ,(kmrcl:concat-symbol 'gsl-block struct-postfix)))
96 (owner :int))
97
98 ;; FIXME: is this correct?
99 (def-foreign-struct ,(kmrcl:concat-symbol 'gsl-vector struct-postfix '-view)
100 (vec (* ,(kmrcl:concat-symbol 'gsl-vector struct-postfix))))))
101
102
103 (def-block-vector-matrix-struct% "" :double)
104 (def-block-vector-matrix-struct% "-float" :float)
105 (def-block-vector-matrix-struct% "-int" :int)
106 (def-block-vector-matrix-struct% "-complex" :double)
107 (def-block-vector-matrix-struct% "-complex-float" :float)
108
109 ;; ----------------------------------------------------------------------
110
111 (defmacro register-foreign-types ()
112 `(progn
113 ,@(mapcar #'(lambda (elm) `(define-foreign-type ,(car elm) ,(cadr elm)))
114 '((double-ptr '(* :double))
115 (gsl-root-fsolver :pointer-void)
116 (gsl-root-fsolver-type :pointer-void)
117
118 (gsl-complex-ptr '(* gsl-complex))
119 (gsl-poly-complex-workspace-ptr '(* gsl-complex))
120 (gsl-complex-packed '(* :double))
121 (gsl-complex-packed-float '(* :float))
122 (gsl-complex-packed-array '(* :double))
123 (gsl-complex-packed-array-float '(* :float))
124 (gsl-complex-packed-ptr '(* :double))
125 (gsl-complex-packed-float-ptr '(* :float))
126 (gsl-mode-t :unsigned-int)
127
128 (gsl-vector-ptr '(* gsl-vector))
129 (gsl-vector-float-ptr '(* gsl-vector-float))
130 (gsl-vector-int-ptr '(* gsl-vector-int))
131 (gsl-vector-complex-ptr '(* gsl-vector-complex))
132 (gsl-vector-complex-float-ptr '(* gsl-vector-complex-float))
133
134 (gsl-matrix-ptr '(* gsl-matrix))
135 (gsl-matrix-float-ptr '(* gsl-matrix-float))
136 (gsl-matrix-int-ptr '(* gsl-matrix-int))
137 (gsl-matrix-complex-ptr '(* gsl-matrix-complex))
138 (gsl-matrix-complex-float-ptr '(* gsl-matrix-complex-float))
139
140 (size-t-ptr '(* size-t))
141
142 (gsl-permutation-ptr '(* gsl-permutation-struct))
143 ))))
144
145 (register-foreign-types)
146
147 ;; typedef long double * gsl_complex_packed_long_double ;
148 ;; typedef long double * gsl_complex_packed_array_long_double ;
149 ;; typedef long double * gsl_complex_packed_long_double_ptr ;
150
151 ;; ----------------------------------------------------------------------
152
153 (defun gsl-complex->complex (z-ptr)
154 "Copies the value of the foreign object pointed to by Z-PTR to a lisp object
155 of type (complex (double-float)). Returns the lisp object."
156 (let ((dat-array (uffi:get-slot-value z-ptr '(:array :double) 'cl-gsl::dat)))
157 (complex (uffi:deref-array dat-array :double 0)
158 (uffi:deref-array dat-array :double 1))))
159
160 (defun gsl-complex-float->complex (z-ptr)
161 "Copies the value of the foreign object pointed to by Z-PTR to a lisp object
162 of type (complex (single-float)). Returns the lisp object."
163 (let ((dat-array (uffi:get-slot-value z-ptr '(:array :float) 'cl-gsl::dat)))
164 (complex (uffi:deref-array dat-array :float 0)
165 (uffi:deref-array dat-array :float 1))))
166
167
168 (defmacro with-complex-double-float->gsl-complex-ptr ((c-ptr complex-val)
169 &body body)
170 "Copies the value of COMPLEX-VALUE, of type (complex (double-float)),
171 to a newly created foreign object of type gsl_complex. C-PTR is a pointer
172 to the foreign object. Returns the values of BODY and frees the memory
173 allocated for the foreign object."
174 (let ((array (gensym)))
175 `(let* ((,c-ptr (uffi:allocate-foreign-object 'gsl-complex))
176 (,array (uffi:get-slot-value ,c-ptr
177 '(:array :double)
178 'cl-gsl::dat)))
179 (unwind-protect
180 (progn
181 (setf (uffi:deref-array ,array :double 0) (realpart ,complex-val))
182 (setf (uffi:deref-array ,array :double 1) (imagpart ,complex-val))
183 ,@body)
184 (uffi:free-foreign-object ,c-ptr)))))
185
186
187 (defmacro with-complex-single-float->gsl-complex-float-ptr ((c-ptr complex-val)
188 &body body)
189 "Copies the value of COMPLEX-VALUE, of type (complex (single-float)),
190 to a newly created foreign object of type gsl_complex_float. C-PTR is a pointer
191 to the foreign object. Returns the values of BODY and frees the memory
192 allocated for the foreign object."
193 (let ((array (gensym)))
194 `(let* ((,c-ptr (uffi:allocate-foreign-object 'gsl-complex-float))
195 (,array (uffi:get-slot-value ,c-ptr
196 '(:array :float)
197 'cl-gsl::dat)))
198 (unwind-protect
199 (progn
200 (setf (uffi:deref-array ,array :float 0) (realpart ,complex-val))
201 (setf (uffi:deref-array ,array :float 1) (imagpart ,complex-val))
202 ,@body)
203 (uffi:free-foreign-object ,c-ptr)))))
204
205
206 (defmacro with-lisp-vec->c-array ((c-ptr lisp-vec) &body body)
207 (let ((len (gensym))
208 (i (gensym)))
209 `(progn
210 (let* ((,len (length ,lisp-vec))
211 (,c-ptr (uffi:allocate-foreign-object :double ,len)))
212 (unwind-protect
213 (progn
214 (dotimes (,i ,len)
215 (setf (uffi:deref-array ,c-ptr :double ,i)
216 (aref ,lisp-vec ,i)))
217 ,@body)
218 (uffi:free-foreign-object ,c-ptr))))))
219
220
221 (defun c-array->lisp-vec (c-ptr len)
222 (let ((lisp-vec (make-array len :element-type 'double-float)))
223 (dotimes (i len)
224 (setf (aref lisp-vec i) (uffi:deref-array c-ptr :double i)))
225 lisp-vec))
226
227 (defun complex-packed-array->lisp-vec (z-ptr len)
228 "Copies the complex values of a foreign array to a lisp array. Z-PTR is
229 a pointer the the foreign array of length LEN. Returns a lisp array of
230 complex elements, also of length LEN."
231 (declare (gsl-complex-packed-def z-ptr))
232 (let ((lisp-vec (make-array (/ len 2) :element-type 'complex)))
233 (dotimes (i (/ len 2))
234 (setf (aref lisp-vec i)
235 (complex (uffi:deref-array z-ptr :double (* i 2))
236 (uffi:deref-array z-ptr :double (1+ (* i 2))))))
237 lisp-vec))

  ViewVC Help
Powered by ViewVC 1.1.5