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

Contents of /cl-gsl/ffi.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Wed Mar 2 01:04:53 2005 UTC (9 years, 1 month ago) by edenny
Branch: cl-gsl
CVS Tags: start
Changes since 1.1: +0 -0 lines
Initial Import
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 ;; TODO: size_t may not always be unsigned long, could also be unsigned int.
60 (define-foreign-type (size-t :unsigned-long))
61
62 (def-foreign-struct gsl-complex
63 (dat (:array :double 2)))
64
65 (def-foreign-struct gsl-poly-complex-workspace
66 (nc :unsigned-long)
67 (matrix (* :double)))
68
69 (def-foreign-struct gsl-complex-float
70 (dat (:array :float 2)))
71
72 ;; ----------------------------------------------------------------------
73
74 (def-foreign-struct gsl-block
75 (size :unsigned-long)
76 (data (* :double)))
77
78 (def-foreign-struct gsl-vector
79 (size :unsigned-long)
80 (stride :unsigned-long)
81 (data (* :double))
82 (g-block (* gsl-block))
83 (owner :int))
84
85 (def-foreign-struct gsl-vector-view
86 (vec (* gsl-vector)))
87
88 ;; ----------------------------------------------------------------------
89
90 (def-foreign-struct gsl-block-float
91 (size :unsigned-long)
92 (data (* :float)))
93
94 (def-foreign-struct gsl-vector-float
95 (size :unsigned-long)
96 (stride :unsigned-long)
97 (data (* :float))
98 (g-block (* gsl-block-float))
99 (owner :int))
100
101 (def-foreign-struct gsl-vector-float-view
102 (vec (* gsl-vector-float)))
103
104 ;; ----------------------------------------------------------------------
105
106 (def-foreign-struct gsl-block-int
107 (size :unsigned-long)
108 (data (* :int)))
109
110 (def-foreign-struct gsl-vector-int
111 (size :unsigned-long)
112 (stride :unsigned-long)
113 (data (* :int))
114 (g-block (* gsl-block-int))
115 (owner :int))
116
117 (def-foreign-struct gsl-vector-int-view
118 (vec (* gsl-vector-int)))
119
120 ;; ----------------------------------------------------------------------
121
122 (def-foreign-struct gsl-block-complex
123 (size :unsigned-long)
124 (data (* gsl-complex)))
125
126 (def-foreign-struct gsl-vector-complex
127 (size :unsigned-long)
128 (stride :unsigned-long)
129 (data (* gsl-complex))
130 (g-block (* gsl-block-complex))
131 (owner :int))
132
133 (def-foreign-struct gsl-vector-complex-view
134 (vec (* gsl-vector-complex)))
135
136 ;; ----------------------------------------------------------------------
137
138 (def-foreign-struct gsl-block-complex-float
139 (size :unsigned-long)
140 (data (* gsl-complex-float)))
141
142 (def-foreign-struct gsl-vector-complex-float
143 (size :unsigned-long)
144 (stride :unsigned-long)
145 (data (* gsl-complex-float))
146 (g-block (* gsl-block-complex-float))
147 (owner :int))
148
149 (def-foreign-struct gsl-vector-complex-float-view
150 (vec (* gsl-vector-complex-float)))
151
152 ;; ----------------------------------------------------------------------
153
154 (def-foreign-struct gsl-matrix
155 (size1 :unsigned-long)
156 (size2 :unsigned-long)
157 (tda :unsigned-long)
158 (data (* :double))
159 (g-block (* gsl-block))
160 (owner :int))
161
162 (defmacro register-foreign-types ()
163 `(progn
164 ,@(mapcar #'(lambda (elm) `(define-foreign-type ,(car elm) ,(cadr elm)))
165 '((double-ptr '(* :double))
166 (gsl-root-fsolver :pointer-void)
167 (gsl-root-fsolver-type :pointer-void)
168
169 (gsl-complex-ptr '(* gsl-complex))
170 (gsl-poly-complex-workspace-ptr '(* gsl-complex))
171 (gsl-complex-packed '(* :double))
172 (gsl-complex-packed-float '(* :float))
173 (gsl-complex-packed-array '(* :double))
174 (gsl-complex-packed-array-float '(* :float))
175 (gsl-complex-packed-ptr '(* :double))
176 (gsl-complex-packed-float-ptr '(* :float))
177 (gsl-mode-t :unsigned-int)
178
179 (gsl-vector-ptr '(* gsl-vector))
180 (gsl-vector-float-ptr '(* gsl-vector-float))
181 (gsl-vector-int-ptr '(* gsl-vector-int))
182 (gsl-vector-complex-ptr '(* gsl-vector-complex))
183 (gsl-vector-complex-float-ptr '(* gsl-vector-complex-float))
184
185 (gsl-matrix-ptr '(* gsl-matrix))
186 (size-t-ptr '(* size-t))
187 ))))
188
189 (register-foreign-types)
190
191 ;; typedef long double * gsl_complex_packed_long_double ;
192 ;; typedef long double * gsl_complex_packed_array_long_double ;
193 ;; typedef long double * gsl_complex_packed_long_double_ptr ;
194
195 ;; typedef struct
196 ;; {
197 ;; long double dat[2];
198 ;; }
199 ;; gsl_complex_long_double;
200
201 ;; ----------------------------------------------------------------------
202
203 (defun gsl-complex->complex (z)
204 (declare (gsl-complex-def z))
205 (let ((dat-array (uffi:get-slot-value z (:array :double) 'cl-gsl::dat)))
206 (complex (uffi:deref-array dat-array :double 0)
207 (uffi:deref-array dat-array :double 1))))
208
209 (defun gsl-complex-float->complex (z)
210 (declare (gsl-complex-float-def z))
211 (let ((dat-array (uffi:get-slot-value z (:array :float) 'cl-gsl::dat)))
212 (complex (uffi:deref-array dat-array :float 0)
213 (uffi:deref-array dat-array :float 1))))
214
215 (defun complex->gsl-complex (z)
216 (let* ((z-ptr (uffi:allocate-foreign-object 'gsl-complex))
217 (uffi:get-slot-pointer z-ptr 'double-ptr 'cl-gsl::dat))
218 ))
219
220 (defun complex->gsl-complex-float (z)
221 (let ((z-ptr (uffi:allocate-foreign-object 'gsl-complex-float)))
222 ))
223
224 ;; TODO: generalize to all supported types
225 (defun lisp-vec->c-array (v)
226 (declare (vector v))
227 (let* ((len (length v))
228 (c-ptr (uffi:allocate-foreign-object :double len)))
229 (dotimes (i len)
230 (setf (uffi:deref-array c-ptr :double i) (aref v i)))
231 c-ptr))
232
233 ;; TODO: generalize to all supported types
234 (defun c-array->lisp-vec (c-ptr len)
235 (let ((lisp-vec (make-array len :element-type 'double-float)))
236 (dotimes (i len)
237 (setf (aref lisp-vec i) (uffi:deref-array c-ptr :double i)))
238 lisp-vec))
239
240 (defun complex-packed-array->lisp-vec (z-ptr len)
241 (declare (gsl-complex-packed-def z-ptr))
242 (let ((lisp-vec (make-array (/ len 2) :element-type 'complex)))
243 (dotimes (i (/ len 2))
244 (setf (aref lisp-vec i)
245 (complex (uffi:deref-array z-ptr :double (* i 2))
246 (uffi:deref-array z-ptr :double (1+ (* i 2))))))
247 lisp-vec))

  ViewVC Help
Powered by ViewVC 1.1.5