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

Contents of /cl-gsl/ffi.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Fri Mar 4 01:52:38 2005 UTC (9 years, 1 month ago) by edenny
Branch: MAIN
Changes since 1.1: +18 -7 lines
Add functions needed by vector.lisp.
1 edenny 1.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 edenny 1.2 (define-foreign-type size-t :unsigned-long)
61 edenny 1.1
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 edenny 1.2 ;; FIXME: this returns a pointer to a gsl-complex. Is this correct?
216     ;; How do we free it?
217     ;; Replace with a with-complex->gsl-complex macro that cleans up after
218     ;; itself
219 edenny 1.1 (defun complex->gsl-complex (z)
220     (let* ((z-ptr (uffi:allocate-foreign-object 'gsl-complex))
221 edenny 1.2 (dat-array (uffi:get-slot-value z-ptr (:array :float) 'cl-gsl::dat)))
222     (setf (uffi:deref-array dat-array :double 0) (realpart z))
223     (setf (uffi:deref-array dat-array :double 1) (imagpart z))
224     z-ptr))
225 edenny 1.1
226 edenny 1.2 ;; FIXME: see above
227 edenny 1.1 (defun complex->gsl-complex-float (z)
228 edenny 1.2 (let* ((z-ptr (uffi:allocate-foreign-object 'gsl-complex-float))
229     (dat-array (uffi:get-slot-value z-ptr (:array :float) 'cl-gsl::dat)))
230     (setf (uffi:deref-array dat-array :double 0) (realpart z))
231     (setf (uffi:deref-array dat-array :double 1) (imagpart z))
232     z-ptr))
233 edenny 1.1
234 edenny 1.2
235     ;; TODO: generalize to all supported types?
236 edenny 1.1 (defun lisp-vec->c-array (v)
237     (declare (vector v))
238     (let* ((len (length v))
239     (c-ptr (uffi:allocate-foreign-object :double len)))
240     (dotimes (i len)
241     (setf (uffi:deref-array c-ptr :double i) (aref v i)))
242     c-ptr))
243    
244 edenny 1.2 ;; TODO: generalize to all supported types?
245 edenny 1.1 (defun c-array->lisp-vec (c-ptr len)
246     (let ((lisp-vec (make-array len :element-type 'double-float)))
247     (dotimes (i len)
248     (setf (aref lisp-vec i) (uffi:deref-array c-ptr :double i)))
249     lisp-vec))
250    
251     (defun complex-packed-array->lisp-vec (z-ptr len)
252     (declare (gsl-complex-packed-def z-ptr))
253     (let ((lisp-vec (make-array (/ len 2) :element-type 'complex)))
254     (dotimes (i (/ len 2))
255     (setf (aref lisp-vec i)
256     (complex (uffi:deref-array z-ptr :double (* i 2))
257     (uffi:deref-array z-ptr :double (1+ (* i 2))))))
258     lisp-vec))

  ViewVC Help
Powered by ViewVC 1.1.5