Skip to content
Snippets Groups Projects
Commit 0b69f21e authored by Liam Healy's avatar Liam Healy
Browse files

Use &aux definitions in defmfun; clean up foreign-friendly definitions

Add &aux to defmfuns to that e.g. array arguments can optionally take
a size and make an array (bessel.lisp).  Remove several unused
definitions in foreign-friendly held over from ffa.
SBCL 64: TOTAL: 1223 assertions passed, 5 failed, 0 execution errors.
CCL 64: TOTAL: 1228 assertions passed, 0 failed, 0 execution errors.
parent 56161207
No related branches found
No related tags found
No related merge requests found
;; Use the foreign-friendly arrays package.
;; Liam Healy 2008-03-22 15:40:08EDT
;; Time-stamp: <2009-01-04 12:08:59EST foreign-friendly.lisp>
;; Time-stamp: <2009-01-10 12:47:53EST foreign-friendly.lisp>
;; $Id$
;;; Foreign-friendly arrays (original implementation by Tamas Papp)
......@@ -102,7 +102,7 @@
array)))
;;;;****************************************************************************
;;;; Protect native pointers (supercedes "pointer management" below for native)
;;;; Protect native pointers
;;;;****************************************************************************
;;; To be called by a defmfun expander
......@@ -125,47 +125,6 @@
;;;; Pointer management
;;;;****************************************************************************
#+native
(defmacro with-pointer-to-array ((array pointer cffi-type length)
&body body)
(assert (symbolp pointer))
(once-only (array cffi-type)
(with-unique-names (original-array index-offset)
`(multiple-value-bind (,original-array ,index-offset)
(find-original-array ,array)
(pin-to-pointer (,original-array ,pointer ,cffi-type
,length ,index-offset)
,@body)))))
#-native
(defmacro with-pointer-to-array ((array pointer cffi-type length)
&body body)
(assert (symbolp pointer))
(once-only (array cffi-type)
(with-unique-names (original-array index-offset)
`(multiple-value-bind (,original-array ,index-offset)
(find-original-array ,array)
(cffi:with-foreign-object (,pointer ,cffi-type ,length)
,@body)))))
#+(and native sbcl)
(defmacro pin-to-pointer ((array pointer cffi-type length index-offset)
&body body)
(declare (ignorable length))
"Use SBCL's sb-sys:with-pinned-objects and sb-sys:vector-sap for
mapping an array to a memory location. NOTE: checking that cffi-type
matches the type of the array is the responsibility of the user of
this macro. The size of the array is checked. The array is required
to have rank one."
(once-only (array)
`(sb-sys:with-pinned-objects (,array)
;;(assert (<= (+ ,index-offset ,length) (length ,array)))
(let ((,pointer
(cffi:inc-pointer
(sb-sys:vector-sap ,array)
(* ,index-offset (cffi:foreign-type-size ,cffi-type)))))
,@body))))
(defun find-original-array (array)
"Find the original parent of a displaced array, return this and the
sum of displaced index offsets."
......
;; Helpers that define a single GSL function interface
;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp
;; Time-stamp: <2009-01-07 22:07:52EST defmfun-single.lisp>
;; Time-stamp: <2009-01-10 20:15:42EST defmfun-single.lisp>
;; $Id: $
(in-package :gsl)
......@@ -76,7 +76,7 @@
,arglist
,(declaration-form
(cl-argument-types arglist c-arguments)
(set-difference
(set-difference ; find all the unused variables
(arglist-plain-and-categories arglist nil)
(union
(if mapdown
......@@ -85,7 +85,13 @@
(variables-used-in-c-arguments c-arguments))
;; Forms in :before, :after are checked for used variables
(stupid-code-walk-find-variables
(cons 'values (append before after))))))
(cons
'values
(append before after
(let ((auxstart (position '&aux arglist)))
;; &aux bindings are checked
(when auxstart
(mapcan 'rest (subseq arglist (1+ auxstart)))))))))))
,@(when documentation (list documentation))
#-native
,(funcall body-maker name arglist gsl-name c-arguments key-args)
......@@ -106,6 +112,13 @@
~a of GSL; it was introduced in version ~d.~d."
name gsl-name *gsl-version* gsl-version))))))
(defun wrap-letlike (when binding wrapping body)
(if when
`(,wrapping ,binding ,@body)
(if (eql (length body) 1)
(first body)
`(progn ,@body))))
(defun body-no-optional-arg (name arglist gsl-name c-arguments key-args)
"Expand the body (computational part) of the defmfun."
(with-defmfun-key-args key-args
......@@ -130,51 +143,52 @@
outputs
(unless (eq c-return :void)
(list cret-name)))))
`(,@(if (or allocated-decl complex-args)
`(cffi:with-foreign-objects
,(mapcar #'wfo-declare
(append allocated-decl
(mapcar #'rest complex-args))))
'(let ()))
#-native ,@(mapcar (lambda (v) `(copy-cl-to-c ,v)) inputs)
,@before
(let ((,cret-name
(cffi:foreign-funcall
,gsl-name
,@(mapcan
(lambda (arg)
(let ((cfind ; variable is complex
(first (member (st-symbol arg)
complex-args :key 'first))))
(if cfind ; so substitute call to complex-to-gsl
`(,(third cfind)
(complex-to-gsl ,(first cfind) ,(second cfind)))
;; otherwise use without conversion
(list (if (member (st-symbol arg) allocated)
:pointer
(st-type arg))
(st-symbol arg)))))
c-arguments)
,cret-type)))
,@(case c-return
(:void `((declare (ignore ,cret-name))))
(:error-code ; fill in arguments
`((check-gsl-status ,cret-name
',(or (defgeneric-method-p name) name)))))
#-native
,@(when outputs
(mapcar
(lambda (x) `(setf (cl-invalid ,x) t (c-invalid ,x) nil))
outputs))
,@(when (eq cret-type :pointer)
`((check-null-pointer
,cret-name
,@'('memory-allocation-failure "No memory allocated."))))
,@after
(values
,@(defmfun-return
c-return cret-name clret allocated return return-supplied-p
enumeration outputs)))))))
(wrap-letlike
(or allocated-decl complex-args)
(mapcar #'wfo-declare
(append allocated-decl
(mapcar #'rest complex-args)))
'cffi:with-foreign-objects
`(#-native
,@(mapcar (lambda (v) `(copy-cl-to-c ,v)) inputs)
,@before
(let ((,cret-name
(cffi:foreign-funcall
,gsl-name
,@(mapcan
(lambda (arg)
(let ((cfind ; variable is complex
(first (member (st-symbol arg)
complex-args :key 'first))))
(if cfind ; so substitute call to complex-to-gsl
`(,(third cfind)
(complex-to-gsl ,(first cfind) ,(second cfind)))
;; otherwise use without conversion
(list (if (member (st-symbol arg) allocated)
:pointer
(st-type arg))
(st-symbol arg)))))
c-arguments)
,cret-type)))
,@(case c-return
(:void `((declare (ignore ,cret-name))))
(:error-code ; fill in arguments
`((check-gsl-status ,cret-name
',(or (defgeneric-method-p name) name)))))
#-native
,@(when outputs
(mapcar
(lambda (x) `(setf (cl-invalid ,x) t (c-invalid ,x) nil))
outputs))
,@(when (eq cret-type :pointer)
`((check-null-pointer
,cret-name
,@'('memory-allocation-failure "No memory allocated."))))
,@after
(values
,@(defmfun-return
c-return cret-name clret allocated return return-supplied-p
enumeration outputs))))))))
(defun defmfun-return
(c-return cret-name clret allocated return return-supplied-p enumeration outputs)
......
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2009-01-07 22:02:49EST defmfun.lisp>
;; Time-stamp: <2009-01-10 20:29:54EST defmfun.lisp>
;; $Id$
(in-package :gsl)
......@@ -57,6 +57,7 @@
;;; after Forms to be evaluated after the foreign call.
;;; enumeration The name of the enumeration return.
;;; gsl-version The GSL version at which this function was introduced.
;;; switch Switch only the listed optional/key variables (default all of them)
(defmacro defmfun (name arglist gsl-name c-arguments &rest key-args)
"Definition of a GSL function."
......@@ -73,21 +74,25 @@
(definition :function)
(export (not (member definition (list :method :methods))))
documentation inputs outputs before after enumeration qualifier
gsl-version)
gsl-version switch)
,key-args
(declare (ignorable c-return return definition element-types
index export documentation inputs outputs
before after enumeration qualifier
gsl-version indexed-functions)
gsl-version switch indexed-functions)
(special indexed-functions))
,@body))
(defparameter *defmfun-llk* '(&optional &key) "Possible lambda-list keywords.")
(defparameter *defmfun-llk* '(&optional &key &aux)
"Possible lambda-list keywords.")
(defparameter *defmfun-optk* '(&optional &key)
"Possible optional-argument keywords.")
(defun optional-args-to-switch-gsl-functions (arglist gsl-name)
"The presence/absence of optional arguments will switch between the
first and second listed GSL function names."
(and (intersection *defmfun-llk* arglist)
(and (intersection *defmfun-optk* arglist)
(listp gsl-name)
(or
(every 'stringp gsl-name)
......@@ -175,7 +180,7 @@
"Create the body of a defmfun with &optional in its arglist,
where the presence or absence of the optional argument(s)
selects one of two GSL functions."
(let ((optpos (position '&optional arglist)))
(let ((optpos (position-if (lambda (s) (member s *defmfun-optk*)) arglist)))
(if optpos
(let ((mandatory-arglist (subseq arglist 0 optpos))
(optional-arglist (subseq arglist (1+ optpos))))
......
;; Bessel functions
;; Liam Healy, Fri Mar 17 2006 - 18:42
;; Time-stamp: <2008-12-30 18:56:40EST bessel.lisp>
;; Time-stamp: <2009-01-10 19:25:39EST bessel.lisp>
;; $Id$
(in-package :gsl)
......@@ -25,7 +25,9 @@
:documentation ; FDL
"The regular cylindrical Bessel function of order n, J_n(x).")
(defmfun cylindrical-bessel-Jn-array (x array &optional (nmin 0))
(defmfun cylindrical-bessel-Jn-array
(x &optional (size-or-array *default-sf-array-size*) (nmin 0)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_Jn_array"
((nmin :int) ((+ nmin (dim0 array) -1) :int) (x :double)
((c-pointer array) :pointer))
......@@ -56,7 +58,9 @@
:documentation ; FDL
"The irregular cylindrical Bessel function of order n, Y_n(x).")
(defmfun cylindrical-bessel-Yn-array (x array &optional (nmin 0))
(defmfun cylindrical-bessel-Yn-array
(x &optional (size-or-array *default-sf-array-size*) (nmin 0)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_Yn_array"
((nmin :int) ((+ nmin (dim0 array) -1) :int) (x :double)
((c-pointer array) :pointer))
......@@ -87,7 +91,9 @@
:documentation ; FDL
"The regular modified cylindrical Bessel function of order n, I_n(x).")
(defmfun cylindrical-bessel-In-array (x array &optional (nmin 0))
(defmfun cylindrical-bessel-In-array
(x &optional (size-or-array *default-sf-array-size*) (nmin 0)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_In_array"
((nmin :int) ((+ nmin (dim0 array) -1) :int) (x :double)
((c-pointer array) :pointer))
......@@ -116,7 +122,9 @@
"The scaled regular modified cylindrical Bessel function of order n,
\exp(-|x|) I_n(x)}.")
(defmfun cylindrical-bessel-In-scaled-array (x array &optional (nmin 0))
(defmfun cylindrical-bessel-In-scaled-array
(x &optional (size-or-array *default-sf-array-size*) (nmin 0)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_In_scaled_array"
((nmin :int) ((+ nmin (dim0 array) -1) :int) (x :double)
((c-pointer array) :pointer))
......@@ -149,7 +157,9 @@
:documentation ; FDL
"The irregular modified cylindrical Bessel function of order n, K_n(x).")
(defmfun cylindrical-bessel-Kn-array (x array &optional (nmin 0))
(defmfun cylindrical-bessel-Kn-array
(x &optional (size-or-array *default-sf-array-size*) (nmin 0)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_Kn_array"
((nmin :int) ((+ nmin (dim0 array) -1) :int) (x :double)
((c-pointer array) :pointer))
......@@ -178,7 +188,9 @@
"The scaled irregular modified cylindrical Bessel function of order n,
\exp(-|x|) K_n(x).")
(defmfun cylindrical-bessel-Kn-scaled-array (x array &optional (nmin 0))
(defmfun cylindrical-bessel-Kn-scaled-array
(x &optional (size-or-array *default-sf-array-size*) (nmin 0)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_Kn_scaled_array"
((nmin :int) ((+ nmin (dim0 array) -1) :int) (x :double)
((c-pointer array) :pointer))
......@@ -219,7 +231,9 @@
"The regular spherical Bessel function of order
l, j_l(x), for l >= 0 and x >= 0.")
(defmfun spherical-bessel-jl-array (x array)
(defmfun spherical-bessel-jl-array
(x &optional (size-or-array *default-sf-array-size*)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_jl_array"
(((1- (dim0 array)) :int) (x :double) ((c-pointer array) :pointer))
:outputs (array)
......@@ -229,7 +243,9 @@
The values are computed using recurrence relations for
efficiency, and therefore may differ slightly from the exact values.")
(defmfun spherical-bessel-jl-steed-array (x array)
(defmfun spherical-bessel-jl-steed-array
(x &optional (size-or-array *default-sf-array-size*)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_jl_steed_array"
(((1- (dim0 array)) :int) (x :double) ((c-pointer array) :pointer))
:outputs (array)
......@@ -268,7 +284,9 @@
:documentation ; FDL
"The irregular spherical Bessel function of order l, y_l(x), for l >= 0.")
(defmfun spherical-bessel-yl-array (x array)
(defmfun spherical-bessel-yl-array
(x &optional (size-or-array *default-sf-array-size*)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_yl_array"
(((1- (dim0 array)) :int) (x :double) ((c-pointer array) :pointer))
:outputs (array)
......@@ -306,7 +324,9 @@
"The scaled regular modified spherical Bessel function of order l,
\exp(-|x|) i_l(x).")
(defmfun spherical-bessel-il-scaled-array (x array)
(defmfun spherical-bessel-il-scaled-array
(x &optional (size-or-array *default-sf-array-size*)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_il_scaled_array"
(((1- (dim0 array)) :int) (x :double) ((c-pointer array) :pointer))
:outputs (array)
......@@ -344,7 +364,9 @@
"The scaled irregular modified spherical Bessel function of order l,
\exp(x) k_l(x), for x>0.")
(defmfun spherical-bessel-kl-scaled-array (x array)
(defmfun spherical-bessel-kl-scaled-array
(x &optional (size-or-array *default-sf-array-size*)
&aux (array (vdf size-or-array)))
"gsl_sf_bessel_kl_scaled_array"
(((1- (dim0 array)) :int) (x :double) ((c-pointer array) :pointer))
:outputs (array)
......
;; Structures returned by special functions.
;; Liam Healy, Mon Jan 1 2007 - 11:35
;; Time-stamp: <2008-08-10 17:47:07EDT return-structures.lisp>
;; Time-stamp: <2009-01-10 17:21:24EST return-structures.lisp>
;; $Id$
(in-package :gsl)
......@@ -39,3 +39,15 @@
(defun e10 (sf-result)
(cffi:foreign-slot-value sf-result 'sf-result-e10 'e10))
;;;;****************************************************************************
;;;; Array construction
;;;;****************************************************************************
(defparameter *default-sf-array-size* 5
"The default size to make an array returned from a special function.")
(defun vdf (size-or-array)
"Make or take a vector-double-float."
(if (integerp size-or-array)
(make-marray 'double-float :dimensions size-or-array)
size-or-array))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment