interface.lisp 9.25 KB
Newer Older
1
2
3
4
5
;********************************************************
; file:        interface.lisp                            
; description: Macros to interface GSL functions.
; date:        Mon Mar  6 2006 - 22:35                   
; author:      Liam M. Healy
6
; modified:    Sun Jan  6 2008 - 13:48
7
8
9
10
;********************************************************

(in-package :gsl)

liam's avatar
liam committed
11
(export '(gsl-lookup *make-sequence-type*))
12

13
;;;;****************************************************************************
14
;;;; Lookup table to find CL functions from C function names
15
;;;;****************************************************************************
16

17
18
19
20
(defparameter *sf-name-mapping* nil
  "An alist mapping the CL and GSL names of the special functions.
   This will only be populated when macros are expanded.")

liam's avatar
liam committed
21
22
23
(defun map-name (cl-name gsl-name)
  (setf *sf-name-mapping* (acons cl-name gsl-name *sf-name-mapping*)))

liam's avatar
liam committed
24
(defun gsl-lookup (string)
25
26
27
28
29
30
31
32
33
34
35
36
  "Find the CL function name given the GSL C special function function name.
   If cl-ppcre (http://www.weitz.de/cl-ppcre/) is installed, the string
   can be a regular expression; otherwise, it must match the C name exactly
   except for case."
  (remove string *sf-name-mapping*
	  :key #'rest
	  :test-not
	  (if (find-package :ppcre)
	      (symbol-function (intern "ALL-MATCHES" :ppcre))
	      #'string-equal)))

;;;;****************************************************************************
37
;;;; Symbol-type declaration
38
39
;;;;****************************************************************************

40
;;; An "st" or symbol-type is a list (symbol type) where
41
;;; type could be (element-type array-dim).  These are examples of lists
42
;;; of sts: 
43
44
45
46
47
48
 ;; ((#:RET3500 SF-RESULT))
 ;; ((#:RET3501 (:DOUBLE (- NMAX NMIN)))) 
 ;; ((#:RET3502 (:DOUBLE (1+ KMAX))) (#:RET3503 (:DOUBLE (1+ KMAX)))
 ;;  (#:RET3504 (:DOUBLE (1+ KMAX))) (#:RET3505 (:DOUBLE (1+ KMAX)))
 ;;  (#:RET3506 :DOUBLE) (#:RET3507 :DOUBLE))

49
50
51
(defun make-st (symbol type)
  (list symbol type))

52
(defun st-symbol (decl)
53
54
  (first decl))

55
(defun st-type (decl)
56
57
  (second decl))

58
59
60
61
62
63
64
65
(defun st-arrayp (decl)
  (listp (st-type decl)))

(defun st-array-pointer-last-p (decl)
  (listp (st-type decl)))

(defun st-eltype (decl)
  (first (st-type decl)))
66

67
68
(defun st-dim (decl)
  (second (st-type decl)))
69

70
71
(defun st-pointer-last-p (decl)
  (third (st-type decl)))
72

73
74
75
76
77
78
(defun wfo-declare (d)
  `(,(st-symbol d)
    ,@(if (st-arrayp d)
	  `(',(st-eltype d) ,(st-dim d))
	  `(',(st-type d)))))

79
;;;;****************************************************************************
80
;;;; Checking results from GSL functions
81
82
;;;;****************************************************************************

83
84
85
86
87
(defun check-gsl-status (status-code context)
  "Check the return status code from a GSL function and signal a warning
   if it is not :SUCCESS."
  (unless (eql :success (cffi:foreign-enum-keyword 'gsl-errorno status-code))
    (warn 'gsl-warning
88
	  :gsl-errno status-code :gsl-context context)))
89

90
91
92
93
94
95
(defun check-null-pointer (pointer error-code reason)
  (when (cffi:null-pointer-p pointer)
    (error 'gsl-error
	   :gsl-errno (cffi:foreign-enum-value 'gsl-errorno error-code)
	   :gsl-reason reason)))

96
97
(defun success-failure (value)
  "If status indicates failure, return NIL, othewise return T."
98
99
100
  ;;(not (eql value (cffi:foreign-enum-value 'gsl-errorno :FAILURE)))
  ;; More general, to allow :CONTINUE
  (not (minusp value)))
101

102
103
104
105
(defun success-continue (value)
  "If status indicates success, return T, othewise return NIL."
  (eql value (cffi:foreign-enum-value 'gsl-errorno :SUCCESS)))

106
107
108
109
;;;;****************************************************************************
;;;; Macro defun-gsl 
;;;;****************************************************************************

liam's avatar
liam committed
110
(defvar *special-c-return*
111
112
  '(:error-code :number-of-answers :success-failure :success-continue
    :true-false :enumerate))
113

114
;;; arglist    List of CL arguments.
115
116
;;; gsl-name   Name of the GSL C function, as a quoted string.
;;; c-arguments List of (symbol c-type). Anything not in arglist will be allocated.
117
;;; c-return,  a symbol naming a type, (e.g. :int, :double, :void),
118
;;;            or a list of (symbol type) to name the value,
liam's avatar
liam committed
119
;;;            or :error-code, :number-of-answers, :success-failure,
120
121
122
;;;            :true-false, :enumerate.  If :enumeration is given,
;;;            the :enumeration keyword argument will supply the name
;;;            of the enumeration.
123
;;; return, a list of quantities to return.
124
125
126
;;;            May be or include :c-return to include the c-return value
;;;            or its derivatives.
;;;            Default are allocated quantities in c-arguments, or :c-return if none.
127
128
129
130
131
132
133
134
;;; type       :function or :method
;;; index      Name under which this function should be cross-referenced
;;; export     Whether to export the symbol.
;;; null-pointer-info Return value if C function returns a null pointer.
;;; documentation
;;; invalidate   Invalidate the CL array/matrix cache.
;;; after        After method.
;;; enumeration  The name of the enumeration return.
liam's avatar
liam committed
135
(defmacro defun-gsl
136
137
138
    (name arglist gsl-name c-arguments
     &key (c-return :error-code)
     (return nil return-supplied-p)
139
     (type :function) index (export (not (eq type :method)))
140
     null-pointer-info documentation invalidate after enumeration)
141
142
143
144
  (let* ((cargs (substitute '(mode sf-mode) :mode c-arguments))
	 (carg-symbs
	  (remove-if-not #'symbolp
			 (mapcar #'st-symbol (remove :mode c-arguments))))
145
146
147
148
149
	 (clargs
	  (or arglist carg-symbs))
	 (arglist-symbs
	  (when arglist			; can be method, so get symbol
	    (mapcar (lambda (x) (if (listp x) (first x) x)) arglist)))
150
	 (cret-type (if (member c-return *special-c-return*)
151
152
			:int
			(if (listp c-return) (st-type c-return) c-return)))
153
154
	 (cret-name
	  (if (listp c-return) (st-symbol c-return) (make-symbol "CRETURN")))
155
	 (allocated		     ; Foreign objects to be allocated
156
	  (remove-if (lambda (s) (member s arglist-symbs)) carg-symbs))
157
158
159
160
	 (allocated-decl
	  (mapcar
	   (lambda (s) (find s cargs :key #'st-symbol))
	   allocated))
161
	 (clret (or (substitute cret-name :c-return return)
162
		    (mapcan #'cl-convert-form allocated-decl)
163
164
165
		    invalidate
		    (unless (eq c-return :void)
		      (list cret-name)))))
166
    `(progn
liam's avatar
liam committed
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
       (,(if (eq type :function) 'defun 'defmethod)
	 ,name
	 ,(if (member :mode c-arguments)
	      `(,@clargs &optional (mode :double-prec))
	      `(,@clargs))
	 ,@(when documentation (list documentation))
	 (,@(if allocated
		`(cffi:with-foreign-objects
		     ,(mapcar #'wfo-declare allocated-decl))
		'(let ()))
	    (let ((,cret-name
		   (cffi:foreign-funcall
		    ,gsl-name
		    ,@(mapcan
		       (lambda (arg)
			 (list (if (member (st-symbol arg) allocated)
				   :pointer
				   (st-type arg))
			       (st-symbol arg)))
		       cargs)
		    ,cret-type)))
	      ,@(case c-return
		      (:void `((declare (ignore ,cret-name))))
		      (:error-code	; fill in arguments
		       `((check-gsl-status ,cret-name ',name))))
	      ,@(when invalidate `((cl-invalidate ,@invalidate)))
	      ,@(when (or null-pointer-info (eq c-return :pointer))
		      `((check-null-pointer ,cret-name
					    ,@(or null-pointer-info
						  '(:ENOMEM "No memory allocated")))))
	      ,@after
	      (values
	       ,@(case c-return
		       (:number-of-answers
			(mapcan
			 (lambda (vbl seq)
			   `((when (> ,cret-name ,seq) ,vbl)))
			 clret
			 (loop for i below (length clret) collect i)))
		       (:success-failure
			(if (equal clret invalidate)
			    ;; success-failure more important than passed-in
209
			    `(success-failure ,@clret)
liam's avatar
liam committed
210
211
			    (remove cret-name ; don't return c-return itself
				    `(,@clret (success-failure ,cret-name)))))
212
213
214
215
216
217
		       (:success-continue
			(if (equal clret invalidate)
			    ;; success-failure more important than passed-in
			    `(success-continue ,@clret)
			    (remove cret-name ; don't return c-return itself
				    `(,@clret (success-continue ,cret-name)))))
liam's avatar
liam committed
218
219
		       (:true-false
			`((not (zerop ,cret-name))))
220
221
		       (:enumerate
			`((cffi:foreign-enum-keyword ',enumeration ,cret-name)))
liam's avatar
liam committed
222
223
224
225
226
227
228
229
		       (t (unless
			      (or
			       (and (eq c-return :error-code)
				    (not allocated))
			       (and (null return) return-supplied-p))
			    clret)))))))
       (map-name ',(or index name) ,gsl-name)
       ,@(when export `((export ',name))))))
230

231
232
233
234
235
236
237
238
239
240
241
242
243
(defmacro defun-optionals
    (name arglist no-optional optionals &optional documentation)
  "Define a function with and without optional arguments."
  (let* ((optpos (position '&optional arglist))
	 (mandatory-arglist (subseq arglist 0 optpos))
	 (optional-arglist (subseq arglist (1+ optpos))))
    `(defun ,name ,arglist
       ,documentation
       (if ,(first optional-arglist)
	   (,(intern
	      (concatenate 'string (string name) (string optionals)))
	     ,@mandatory-arglist ,@optional-arglist)
	   (,(intern
liam's avatar
liam committed
244
245
	      (concatenate 'string (string name)
			   (if no-optional (string no-optional) "")))
246
	     ,@mandatory-arglist)))))
247
248
249
250
251
252
253
254
255
256
257

;;;;****************************************************************************
;;;; Variables in library
;;;;****************************************************************************

(defmacro defvariable (cl-symbol gsl-symbol documentation)
  "Define a library variable pointer."
  `(progn
    (cffi:defcvar (,gsl-symbol ,cl-symbol) :pointer :read-only t)
    (map-name ',cl-symbol ,gsl-symbol)
    (setf (documentation ',cl-symbol 'variable) ,documentation)))