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

Contents of /cl-gsl/ffi.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Mon May 16 01:29:36 2005 UTC (8 years, 11 months ago) by edenny
Branch: MAIN
CVS Tags: HEAD
Changes since 1.6: +3 -0 lines
Add random-number-generator foreign types.
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 (gsl-rng-type-ptr '(* :void))
145 (gsl-rng-ptr '(* :void))
146 ))))
147
148 (register-foreign-types)
149
150 ;; typedef long double * gsl_complex_packed_long_double ;
151 ;; typedef long double * gsl_complex_packed_array_long_double ;
152 ;; typedef long double * gsl_complex_packed_long_double_ptr ;
153
154 ;; ----------------------------------------------------------------------
155
156 (defun gsl-complex->complex (z-ptr)
157 "Copies the value of the foreign object pointed to by Z-PTR to a lisp object
158 of type (complex (double-float)). Returns the lisp object."
159 (let ((dat-array (uffi:get-slot-value z-ptr '(:array :double) 'cl-gsl::dat)))
160 (complex (uffi:deref-array dat-array :double 0)
161 (uffi:deref-array dat-array :double 1))))
162
163 (defun gsl-complex-float->complex (z-ptr)
164 "Copies the value of the foreign object pointed to by Z-PTR to a lisp object
165 of type (complex (single-float)). Returns the lisp object."
166 (let ((dat-array (uffi:get-slot-value z-ptr '(:array :float) 'cl-gsl::dat)))
167 (complex (uffi:deref-array dat-array :float 0)
168 (uffi:deref-array dat-array :float 1))))
169
170
171 (defmacro with-complex-double-float->gsl-complex-ptr ((c-ptr complex-val)
172 &body body)
173 "Copies the value of COMPLEX-VALUE, of type (complex (double-float)),
174 to a newly created foreign object of type gsl_complex. C-PTR is a pointer
175 to the foreign object. Returns the values of BODY and frees the memory
176 allocated for the foreign object."
177 (let ((array (gensym)))
178 `(let* ((,c-ptr (uffi:allocate-foreign-object 'gsl-complex))
179 (,array (uffi:get-slot-value ,c-ptr
180 '(:array :double)
181 'cl-gsl::dat)))
182 (unwind-protect
183 (progn
184 (setf (uffi:deref-array ,array :double 0) (realpart ,complex-val))
185 (setf (uffi:deref-array ,array :double 1) (imagpart ,complex-val))
186 ,@body)
187 (uffi:free-foreign-object ,c-ptr)))))
188
189
190 (defmacro with-complex-single-float->gsl-complex-float-ptr ((c-ptr complex-val)
191 &body body)
192 "Copies the value of COMPLEX-VALUE, of type (complex (single-float)),
193 to a newly created foreign object of type gsl_complex_float. C-PTR is a pointer
194 to the foreign object. Returns the values of BODY and frees the memory
195 allocated for the foreign object."
196 (let ((array (gensym)))
197 `(let* ((,c-ptr (uffi:allocate-foreign-object 'gsl-complex-float))
198 (,array (uffi:get-slot-value ,c-ptr
199 '(:array :float)
200 'cl-gsl::dat)))
201 (unwind-protect
202 (progn
203 (setf (uffi:deref-array ,array :float 0) (realpart ,complex-val))
204 (setf (uffi:deref-array ,array :float 1) (imagpart ,complex-val))
205 ,@body)
206 (uffi:free-foreign-object ,c-ptr)))))
207
208
209 (defmacro with-lisp-vec->c-array ((c-ptr lisp-vec) &body body)
210 (let ((len (gensym))
211 (i (gensym)))
212 `(progn
213 (let* ((,len (length ,lisp-vec))
214 (,c-ptr (uffi:allocate-foreign-object :double ,len)))
215 (unwind-protect
216 (progn
217 (dotimes (,i ,len)
218 (setf (uffi:deref-array ,c-ptr :double ,i)
219 (aref ,lisp-vec ,i)))
220 ,@body)
221 (uffi:free-foreign-object ,c-ptr))))))
222
223
224 (defun c-array->lisp-vec (c-ptr len)
225 (let ((lisp-vec (make-array len :element-type 'double-float)))
226 (dotimes (i len)
227 (setf (aref lisp-vec i) (uffi:deref-array c-ptr :double i)))
228 lisp-vec))
229
230 (defun complex-packed-array->lisp-vec (z-ptr len)
231 "Copies the complex values of a foreign array to a lisp array. Z-PTR is
232 a pointer the the foreign array of length LEN. Returns a lisp array of
233 complex elements, also of length LEN."
234 (declare (gsl-complex-packed-def z-ptr))
235 (let ((lisp-vec (make-array (/ len 2) :element-type 'complex)))
236 (dotimes (i (/ len 2))
237 (setf (aref lisp-vec i)
238 (complex (uffi:deref-array z-ptr :double (* i 2))
239 (uffi:deref-array z-ptr :double (1+ (* i 2))))))
240 lisp-vec))

  ViewVC Help
Powered by ViewVC 1.1.5