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

Contents of /cl-gsl/ffi.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Mon Apr 18 00:50:33 2005 UTC (9 years ago) by edenny
Branch: MAIN
Changes since 1.4: +36 -85 lines
Add matrix types.
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 edenny 1.4 ;; TODO: size_t may not always be unsigned long, could also be unsigned int
60     ;; on some systems?
61 edenny 1.2 (define-foreign-type size-t :unsigned-long)
62 edenny 1.1
63     (def-foreign-struct gsl-complex
64     (dat (:array :double 2)))
65    
66     (def-foreign-struct gsl-poly-complex-workspace
67     (nc :unsigned-long)
68     (matrix (* :double)))
69    
70     (def-foreign-struct gsl-complex-float
71     (dat (:array :float 2)))
72    
73     ;; ----------------------------------------------------------------------
74    
75 edenny 1.5 (defmacro def-block-vector-matrix-struct% (struct-postfix data-type)
76     `(progn
77     (def-foreign-struct ,(kmrcl:concat-symbol 'gsl-block struct-postfix)
78     (size :unsigned-long)
79     (data (* ,data-type)))
80    
81     (def-foreign-struct ,(kmrcl:concat-symbol 'gsl-vector struct-postfix)
82     (size :unsigned-long)
83     (stride :unsigned-long)
84     (data (* ,data-type))
85     (g-block (* ,(kmrcl:concat-symbol 'gsl-block struct-postfix)))
86     (owner :int))
87    
88     (def-foreign-struct ,(kmrcl:concat-symbol 'gsl-matrix struct-postfix)
89     (size1 :unsigned-long)
90     (size2 :unsigned-long)
91     (tda :unsigned-long)
92     (data (* ,data-type))
93     (g-block (* ,(kmrcl:concat-symbol 'gsl-block struct-postfix)))
94     (owner :int))
95    
96     ;; FIXME: is this correct?
97     (def-foreign-struct ,(kmrcl:concat-symbol 'gsl-vector struct-postfix '-view)
98     (vec (* ,(kmrcl:concat-symbol 'gsl-vector struct-postfix))))))
99    
100    
101     (def-block-vector-matrix-struct% "" :double)
102     (def-block-vector-matrix-struct% "-float" :float)
103     (def-block-vector-matrix-struct% "-int" :int)
104     (def-block-vector-matrix-struct% "-complex" :double)
105     (def-block-vector-matrix-struct% "-complex-float" :float)
106 edenny 1.1
107     ;; ----------------------------------------------------------------------
108    
109     (defmacro register-foreign-types ()
110     `(progn
111     ,@(mapcar #'(lambda (elm) `(define-foreign-type ,(car elm) ,(cadr elm)))
112     '((double-ptr '(* :double))
113     (gsl-root-fsolver :pointer-void)
114     (gsl-root-fsolver-type :pointer-void)
115    
116     (gsl-complex-ptr '(* gsl-complex))
117     (gsl-poly-complex-workspace-ptr '(* gsl-complex))
118     (gsl-complex-packed '(* :double))
119     (gsl-complex-packed-float '(* :float))
120     (gsl-complex-packed-array '(* :double))
121     (gsl-complex-packed-array-float '(* :float))
122     (gsl-complex-packed-ptr '(* :double))
123     (gsl-complex-packed-float-ptr '(* :float))
124     (gsl-mode-t :unsigned-int)
125    
126     (gsl-vector-ptr '(* gsl-vector))
127     (gsl-vector-float-ptr '(* gsl-vector-float))
128     (gsl-vector-int-ptr '(* gsl-vector-int))
129     (gsl-vector-complex-ptr '(* gsl-vector-complex))
130     (gsl-vector-complex-float-ptr '(* gsl-vector-complex-float))
131    
132     (gsl-matrix-ptr '(* gsl-matrix))
133 edenny 1.5 (gsl-matrix-float-ptr '(* gsl-matrix-float))
134     (gsl-matrix-int-ptr '(* gsl-matrix-int))
135     (gsl-matrix-complex-ptr '(* gsl-matrix-complex))
136     (gsl-matrix-complex-float-ptr '(* gsl-matrix-complex-float))
137    
138 edenny 1.1 (size-t-ptr '(* size-t))
139     ))))
140    
141     (register-foreign-types)
142    
143     ;; typedef long double * gsl_complex_packed_long_double ;
144     ;; typedef long double * gsl_complex_packed_array_long_double ;
145     ;; typedef long double * gsl_complex_packed_long_double_ptr ;
146    
147     ;; ----------------------------------------------------------------------
148    
149 edenny 1.3 (defun gsl-complex->complex (z-ptr)
150 edenny 1.4 "Copies the value of the foreign object pointed to by Z-PTR to a lisp object
151     of type (complex (double-float)). Returns the lisp object."
152 edenny 1.3 (let ((dat-array (uffi:get-slot-value z-ptr '(:array :double) 'cl-gsl::dat)))
153 edenny 1.1 (complex (uffi:deref-array dat-array :double 0)
154     (uffi:deref-array dat-array :double 1))))
155    
156 edenny 1.3 (defun gsl-complex-float->complex (z-ptr)
157 edenny 1.4 "Copies the value of the foreign object pointed to by Z-PTR to a lisp object
158     of type (complex (single-float)). Returns the lisp object."
159 edenny 1.3 (let ((dat-array (uffi:get-slot-value z-ptr '(:array :float) 'cl-gsl::dat)))
160 edenny 1.1 (complex (uffi:deref-array dat-array :float 0)
161     (uffi:deref-array dat-array :float 1))))
162    
163    
164 edenny 1.4 (defmacro with-complex-double-float->gsl-complex-ptr ((c-ptr complex-val)
165     &body body)
166     "Copies the value of COMPLEX-VALUE, of type (complex (double-float)),
167     to a newly created foreign object of type gsl_complex. C-PTR is a pointer
168     to the foreign object. Returns the values of BODY and frees the memory
169     allocated for the foreign object."
170     (let ((array (gensym)))
171     `(let* ((,c-ptr (uffi:allocate-foreign-object 'gsl-complex))
172     (,array (uffi:get-slot-value ,c-ptr
173     '(:array :double)
174     'cl-gsl::dat)))
175     (unwind-protect
176     (progn
177     (setf (uffi:deref-array ,array :double 0) (realpart ,complex-val))
178     (setf (uffi:deref-array ,array :double 1) (imagpart ,complex-val))
179     ,@body)
180     (uffi:free-foreign-object ,c-ptr)))))
181    
182    
183     (defmacro with-complex-single-float->gsl-complex-float-ptr ((c-ptr complex-val)
184     &body body)
185     "Copies the value of COMPLEX-VALUE, of type (complex (single-float)),
186     to a newly created foreign object of type gsl_complex_float. C-PTR is a pointer
187     to the foreign object. Returns the values of BODY and frees the memory
188     allocated for the foreign object."
189     (let ((array (gensym)))
190     `(let* ((,c-ptr (uffi:allocate-foreign-object 'gsl-complex-float))
191     (,array (uffi:get-slot-value ,c-ptr
192     '(:array :float)
193     'cl-gsl::dat)))
194     (unwind-protect
195     (progn
196     (setf (uffi:deref-array ,array :float 0) (realpart ,complex-val))
197     (setf (uffi:deref-array ,array :float 1) (imagpart ,complex-val))
198     ,@body)
199     (uffi:free-foreign-object ,c-ptr)))))
200    
201    
202     (defmacro with-lisp-vec->c-array ((c-ptr lisp-vec) &body body)
203     (let ((len (gensym))
204     (i (gensym)))
205     `(progn
206     (let* ((,len (length ,lisp-vec))
207     (,c-ptr (uffi:allocate-foreign-object :double ,len)))
208     (unwind-protect
209     (progn
210     (dotimes (,i ,len)
211     (setf (uffi:deref-array ,c-ptr :double ,i)
212     (aref ,lisp-vec ,i)))
213     ,@body)
214     (uffi:free-foreign-object ,c-ptr))))))
215    
216    
217 edenny 1.1 (defun c-array->lisp-vec (c-ptr len)
218     (let ((lisp-vec (make-array len :element-type 'double-float)))
219     (dotimes (i len)
220     (setf (aref lisp-vec i) (uffi:deref-array c-ptr :double i)))
221     lisp-vec))
222    
223     (defun complex-packed-array->lisp-vec (z-ptr len)
224 edenny 1.4 "Copies the complex values of a foreign array to a lisp array. Z-PTR is
225     a pointer the the foreign array of length LEN. Returns a lisp array of
226     complex elements, also of length LEN."
227 edenny 1.1 (declare (gsl-complex-packed-def z-ptr))
228     (let ((lisp-vec (make-array (/ len 2) :element-type 'complex)))
229     (dotimes (i (/ len 2))
230     (setf (aref lisp-vec i)
231     (complex (uffi:deref-array z-ptr :double (* i 2))
232     (uffi:deref-array z-ptr :double (1+ (* i 2))))))
233     lisp-vec))

  ViewVC Help
Powered by ViewVC 1.1.5