Commit 00d7b1db authored by Liam Healy's avatar Liam Healy

Dynamic dimensions for callbacks

Dimensions that have been placed into the dynamic-variable are now
read and used for array input, as for example in Monte Carlo.
Functions that use callbacks with scalar input and output (as for
example in numerical-integration and numerical-differentiation) are
now expanded directly with a funcall instead of call-maybe-scalar.
Modifications and new definitions to set arrays partly written and
untested, await changes to defmobject where callbacks setting array
values exist.
parent 9a4f2247
;; Monte Carlo Integration
;; Liam Healy Sat Feb 3 2007 - 17:42
;; Time-stamp: <2009-03-02 09:25:45EST monte-carlo.lisp>
;; Time-stamp: <2009-03-07 16:39:34EST monte-carlo.lisp>
;; $Id$
(in-package :gsl)
......@@ -247,7 +247,7 @@
(* (/ (expt pi 3))
(/ (- 1 (* (cos x) (cos y) (cos z))))))
(make-callbacks monte-carlo mcrw 3)
;;(make-callbacks monte-carlo mcrw 3)
(defun random-walk-plain-example (&optional (nsamples 500000))
(let ((ws (make-monte-carlo-plain 3))
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2009-02-16 17:15:57EST gsll.asd>
;; Time-stamp: <2009-03-07 22:31:35EST gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -14,16 +14,17 @@
((:module init
:components
((:file "init")
(:file "forms")
(:file "conditions" :depends-on (init))
(:file "number-conversion" :depends-on (init))
(:file "mobject" :depends-on (init))
(:file "callback" :depends-on (init mobject))
(:file "callback" :depends-on (init forms number-conversion mobject))
(:file "types" :depends-on (init))
(:file "complex-types" :depends-on (types))
(:file "element-types" :depends-on (init complex-types))
(:file "number-conversion" :depends-on (init))
(:file "interface"
:depends-on (init conditions element-types number-conversion))
(:file "defmfun" :depends-on (init element-types interface))
(:file "defmfun" :depends-on (init forms element-types interface))
(:file "defmfun-array" :depends-on (defmfun))
(:file "defmfun-single" :depends-on (defmfun mobject callback))
(:file "generate-examples" :depends-on (init))))
......@@ -174,6 +175,7 @@
((:file "numerical-integration")
(:file "monte-carlo")
(:file "numerical-differentiation")))
#+(or)
(:module ordinary-differential-equations
:depends-on (init)
:components
......@@ -190,10 +192,11 @@
(:file "lookup")
(:file "evaluation")
(:file "spline-example" :depends-on (types))))
(:file "chebyshev" :depends-on (init))
;(:file "chebyshev" :depends-on (init))
(:file "series-acceleration" :depends-on (init))
(:file "wavelet" :depends-on (init data))
(:file "hankel" :depends-on (init data))
#+(or)
(:module solve-minimize-fit
:depends-on (init data random)
:components
......
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-03-05 22:48:19EST callback.lisp>
;; Time-stamp: <2009-03-07 22:59:50EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -342,6 +342,7 @@
;;; scalarsp = flag determining whether to pass/accept scalars or arrays
;;; dimensions = dimension of the problem
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *callback-argument-components*
'(foreign-argument callback-structure-type &rest functions))
......@@ -351,6 +352,7 @@
(return-spec :double)
(argument-spec :double)
set1-spec set2-spec marray))
)
(defmacro parse-arglist (template arglist component)
`(destructuring-bind ,template ,arglist
......@@ -394,6 +396,7 @@
append (list symb (cons 'list list))))))
(defun callback-set-slots (callbacks symbols)
(when callbacks
`((set-cbstruct
,(callback-argument-component callbacks foreign-argument)
',(callback-argument-component callbacks callback-structure-type)
......@@ -405,7 +408,7 @@
in (callback-argument-component callbacks functions)
append
`(',(callback-argument-function-component fn structure-slot-name)
',symb))))))
',symb)))))))
(defun callback-args (types)
"The arguments passed by GSL to the callback function."
......@@ -423,56 +426,101 @@
(defmacro defmcallback (name dynamic-variable function-spec)
(let* ((args (callback-args
(list
(callback-argument-function-component function-spec argument-spec)
(callback-argument-function-component function-spec set1-spec)
(callback-argument-function-component function-spec set2-spec))))
(remove ; remove unused arguments in list tail
nil
(list
(callback-argument-function-component function-spec argument-spec)
(callback-argument-function-component function-spec set1-spec)
(callback-argument-function-component function-spec set2-spec)))))
(arg-component
(callback-argument-function-component function-spec argument-spec))
(set1-component
(callback-argument-function-component function-spec set1-spec))
(set2-component
(callback-argument-function-component function-spec set2-spec))
(return-type
(callback-argument-function-component function-spec return-spec)))
`(cffi:defcallback ,name
,(if (eq return-type :success-failure) :int return-type)
(,(first args)
(params :pointer)
,@(list (second args) (third args)))
;; Parameters as C argument are always ignored, because we have
;; CL specials to do the same job.
(declare (ignore params) (special ,dynamic-variable))
(call-maybe-scalar
(first ,dynamic-variable)
,(cons 'list (mapcar 'first args))
(second ,dynamic-variable) ; scalars
(cddr ,dynamic-variable) ; dimensions for each argument
(list ; which are marrays, which are cvectors
,(callback-argument-function-argspec
(callback-argument-function-component function-spec argument-spec)
'array-type)
,(callback-argument-function-argspec
(callback-argument-function-component function-spec set1-spec)
'array-type)
,(callback-argument-function-argspec
(callback-argument-function-component function-spec set2-spec)
'array-type)))
,@(case
return-type
(:success-failure
;; We always return success, because if there was a
;; problem, a CL error would be signalled.
'(success))
(:pointer
;; For unclear reasons, some GSL functions want callbacks
;; to return a void pointer which is apparently meaningless.
'((cffi:null-pointer)))))))
(defun array-to-list (pointer length marray)
(if marray
(print (list arg-component set1-component set2-component))
(flet ((dimargs (component)
(sublis `((dim0 . (third ,dynamic-variable))
(dim1 . (fourth ,dynamic-variable)))
(callback-argument-function-argspec component 'dimensions))))
`(cffi:defcallback ,name
,(if (eq return-type :success-failure) :int return-type)
(,(first args)
(params :pointer)
,@(rest args))
;; Parameters as C argument are always ignored, because we have
;; CL specials to do the same job.
(declare (ignore params) (special ,dynamic-variable))
,(if (or (listp arg-component) set1-component set2-component)
`(call-maybe-scalar
(first ,dynamic-variable)
,(cons 'list (mapcar 'first args))
(second ,dynamic-variable) ; scalars
(list
,(dimargs arg-component)
,(dimargs set1-component)
,(dimargs set2-component))
(list ; which are marrays, which are cvectors
,(callback-argument-function-argspec arg-component 'array-type)
,(callback-argument-function-argspec set1-component 'array-type)
,(callback-argument-function-argspec set2-component 'array-type)))
;; Function with scalar argument and scalar return
`(funcall (first ,dynamic-variable) ,(caar args)))
,@(case
return-type
(:success-failure
;; We always return success, because if there was a
;; problem, a CL error would be signalled.
'(success))
(:pointer
;; For unclear reasons, some GSL functions want callbacks
;; to return a void pointer which is apparently meaningless.
'((cffi:null-pointer))))))))
(defun array-to-list (pointer length marrayp)
(if marrayp
(loop for i below length collect (maref pointer i))
(loop for i below length collect (dcref pointer i)))))
(loop for i below length collect (dcref pointer i))))
(defun list-to-array (list pointer dimensions marrayp)
"From the list of values, set the foreign array at pointer."
(if (= (length dimensions) 2)
(loop for i below (first dimensions)
with indl = -1
do
(loop for j below (second dimensions)
do
(incf indl)
(if marrayp
(setf (maref pointer i j) (nth indl list))
(setf (dcref pointer indl) (nth indl list)))))
(if marrayp
(loop for i below (first dimensions)
do (setf (maref pointer i) (nth i list)))
(loop for i below (first dimensions)
do (setf (dcref pointer i) (nth i list))))))
(defun call-maybe-scalar (function arguments scalars dimensions marrays)
"If scalars is a true, pass the function scalar arguments and set
set1 and set2 to the scalar results."
(if scalars
(apply
function (array-to-list (first arguments) (first dimensions) (first marrays)))
"Call the function on the arguments. If scalars is true, pass the
function scalar arguments and set set1 and set2 to the scalar
results. In that case, the stated dimensions and whether the
arrays are marrays or cvectors will be used."
;; function: a function designator
;; arguments: list of 1-3 symbols
;; scalars: T or NIL
;; dimensions: list of 1-3 lists of 1-2 expressions using dim0/dim1
;; marrays: list of 1-3 boolean
(if scalars ; should be nil also for scalar functions
(let ((user-fn-return
(multiple-value-list
(apply function
;; input should be checked to be array
(array-to-list
(first arguments) (first dimensions) (first marrays))))))
(if (rest arguments)
(list-to-array
user-fn-return (second arguments) (second dimensions) (second marrays))
(first user-fn-return)))
(apply function arguments)))
;; Helpers for defining GSL functions on arrays
;; Liam Healy 2009-01-07 22:01:16EST defmfun-array.lisp
;; Time-stamp: <2009-02-17 21:10:22EST defmfun-array.lisp>
;; Time-stamp: <2009-03-07 15:54:48EST defmfun-array.lisp>
;; $Id: $
(in-package :gsl)
......@@ -182,24 +182,6 @@
"Find the actual form to use as the default based on the list in form."
(loop for (type result) on form by #'cddr
thereis (when (subtypep element-type type) result)))
(defun arglist-plain-and-categories
(arglist &optional (include-llk t))
"Get arglist without classes and a list of categories."
(loop for arg in arglist
with getting-categories = t and categories
do
(when (and getting-categories (member arg *defmfun-llk*))
(setf getting-categories nil))
(when (and getting-categories (listp arg))
;; Collect categories (classes), but not default values to
;; optional arugments.
(pushnew (second arg) categories))
when (or (not (member arg *defmfun-llk*)) include-llk)
collect
(if (listp arg) (first arg) arg)
into noclass-arglist
finally (return (values noclass-arglist categories))))
(defun actual-array-c-type (category c-arguments &optional map-down)
"Replace the declared proto-type with an actual GSL struct type
......
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2009-03-05 21:11:49EST defmfun.lisp>
;; Time-stamp: <2009-03-07 15:52:28EST defmfun.lisp>
;; $Id$
(in-package :gsl)
......@@ -86,12 +86,6 @@
(special indexed-functions callback-gensyms))
,@body))
(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."
......
;; Lisp forms
;; Liam Healy 2009-03-07 15:49:25EST forms.lisp
;; Time-stamp: <2009-03-07 15:52:27EST forms.lisp>
(in-package :gsl)
;;;;****************************************************************************
;;;; Arglists
;;;;****************************************************************************
(defparameter *defmfun-llk* '(&optional &key &aux)
"Possible lambda-list keywords.")
(defparameter *defmfun-optk* '(&optional &key)
"Possible optional-argument keywords.")
(defun arglist-plain-and-categories
(arglist &optional (include-llk t))
"Get arglist without classes and a list of categories."
(loop for arg in arglist
with getting-categories = t and categories
do
(when (and getting-categories (member arg *defmfun-llk*))
(setf getting-categories nil))
(when (and getting-categories (listp arg))
;; Collect categories (classes), but not default values to
;; optional arugments.
(pushnew (second arg) categories))
when (or (not (member arg *defmfun-llk*)) include-llk)
collect
(if (listp arg) (first arg) arg)
into noclass-arglist
finally (return (values noclass-arglist categories))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment