Commit 127d3d02 authored by Liam M. Healy's avatar Liam M. Healy

Substitute for dim0 and dim1 in funcallables when scalarsp=NIL

Previously, the funcallable form made by #'make-funcallable-form (for e.g. ODE solvers) when scalarsp=T involved substituting the symbols 'dim0 and 'dim1, but when scalarsp=NIL, would not do the substitution. This caused an error when those unevaluated and unbound symbols appeared in the lambda. By altering #'faify-form with an additional 'dimension-values argument and calling (value-from-dimensions argspec dimension-values) instead of (parse-callback-argspec argspec 'dimensions), this problem is fixed.
parent 2ea64e90
;; Generate a lambda that calls the user function; will be called by callback.
;; Liam Healy
;; Time-stamp: <2011-10-23 22:10:08EDT funcallable.lisp>
;; Time-stamp: <2012-11-18 11:16:47EST funcallable.lisp>
;;
;; Copyright 2009, 2010, 2011 Liam M. Healy
;; Copyright 2009, 2010, 2011, 2012 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
......@@ -25,8 +25,7 @@
;;;;****************************************************************************
(defun value-from-dimensions (argspec dimension-values &optional total)
"Return a list of numerical sizes for dimensions of an array. If
total = T, then return the product of those dimensions."
"Return argspec 'dimensions with numerical sizes for dimensions substituted for dim0, dim1. If total = T, then return the product of those dimensions. The list dimensions-values is a list of one or two numerical values, (dim0-value dim1-value) or (dim0-value)."
;; (DIM0) -> numerical value
;; (DIM0 DIM0) -> product of numerical values
(let ((list
......@@ -36,7 +35,8 @@
'dim1
(parse-callback-argspec argspec 'dimensions)))))
(if total
(apply '* list) list)))
(apply '* list)
list)))
(defun all-io (direction &optional (arrays t))
"Create a function that returns dimensions for argspecs that are arrays
......@@ -61,7 +61,7 @@
arg))
argspecs))
(defun faify-form (ptr argspec)
(defun faify-form (ptr argspec dimension-values)
"Make the form that turns the mpointer into a foreign-array."
;; No finalizer, because pointer might be reused by GSL.
(ecase (parse-callback-argspec argspec 'array-type)
......@@ -69,12 +69,12 @@
`(make-foreign-array-from-mpointer
,ptr
',(grid:cffi-cl (parse-callback-argspec argspec 'element-type))
,(length (parse-callback-argspec argspec 'dimensions))
,(length (value-from-dimensions argspec dimension-values))
nil)) ; no finalizer
(:cvector ; a raw C vector
`(grid:make-foreign-array-from-pointer
,ptr
',(parse-callback-argspec argspec 'dimensions)
',(value-from-dimensions argspec dimension-values)
',(grid:cffi-cl (parse-callback-argspec argspec 'element-type))
nil))
((nil) ptr)))
......@@ -158,54 +158,56 @@
(let* ((argspecs (remove :slug (parse-callback-fnspec fnspec 'arguments-spec)))
(inargs-specs (vspecs-direction argspecs :input))
(inargs-names
(make-symbol-cardinals
'input
(length (remove nil (mapcar (all-io :input nil) argspecs)))))
(make-symbol-cardinals
'input
(length (remove nil (mapcar (all-io :input nil) argspecs)))))
(outarrayp (vspecs-direction argspecs :output t))
(outargs-names (make-symbol-cardinals 'output (length outarrayp)))
(lambda-args
(loop for arg in argspecs
with oarg = (copy-list outargs-names)
and iarg = (copy-list inargs-names)
append
(if (and (eql (parse-callback-argspec arg 'io) :output)
(parse-callback-argspec arg 'array-type))
(list (pop oarg))
(if (eql (parse-callback-argspec arg 'io) :input)
(list (pop iarg))))))
(loop for arg in argspecs
with oarg = (copy-list outargs-names)
and iarg = (copy-list inargs-names)
append
(if (and (eql (parse-callback-argspec arg 'io) :output)
(parse-callback-argspec arg 'array-type))
(list (pop oarg))
(if (eql (parse-callback-argspec arg 'io) :input)
(list (pop iarg))))))
(function-designator
(if (symbolp user-function)
(let ((uf user-function)) `',uf)
user-function)))
(if (symbolp user-function)
(let ((uf user-function)) `',uf)
user-function)))
`(lambda ,lambda-args
,(if (and scalarsp (or inargs-specs outarrayp))
(let ((call-form
`(funcall
,function-designator
,@(array-element-refs inargs-names inargs-specs dimension-values))))
`(funcall
,function-designator
,@(array-element-refs inargs-names inargs-specs dimension-values))))
(if outarrayp
(callback-set-mvb outargs-names call-form fnspec dimension-values)
;; no specified output, return what the function returns
call-form))
`(funcall ,function-designator
,@(if outarrayp
(append (mapcar 'faify-form inargs-names inargs-specs)
(mapcar 'faify-form outargs-names outarrayp))
;; no arrays to return, just return the value
(mapcar 'faify-form inargs-names inargs-specs))))
(let ((faify-form-dv
(alexandria:rcurry 'faify-form dimension-values)))
`(funcall ,function-designator
,@(if outarrayp
(append (mapcar faify-form-dv inargs-names inargs-specs)
(mapcar faify-form-dv outargs-names outarrayp))
;; no arrays to return, just return the value
(mapcar faify-form-dv inargs-names inargs-specs)))))
,@(case
(parse-callback-fnspec fnspec 'return-spec)
(:success-failure
;; We always return success, because if there is a
;; problem, a CL error should be signalled.
'(+success+))
(:pointer
;; For unclear reasons, some GSL functions want callbacks
;; to return a void pointer which is apparently meaningless.
'((cffi:null-pointer)))
;; If it isn't either of these things, return what the
;; function returned.
(otherwise nil)))))
(parse-callback-fnspec fnspec 'return-spec)
(:success-failure
;; We always return success, because if there is a
;; problem, a CL error should be signalled.
'(+success+))
(:pointer
;; For unclear reasons, some GSL functions want callbacks
;; to return a void pointer which is apparently meaningless.
'((cffi:null-pointer)))
;; If it isn't either of these things, return what the
;; function returned.
(otherwise nil)))))
(defun make-funcallables-for-object (object)
"Make compiled functions for the object that can be funcalled in the callback."
......
;; Evolution functions for ODE integration.
;; Liam Healy, Sun Sep 30 2007 - 14:31
;; Time-stamp: <2012-01-13 12:01:23EST evolution.lisp>
;; Time-stamp: <2012-11-17 12:06:56EST evolution.lisp>
;;
;; Copyright 2007, 2008, 2009, 2011 Liam M. Healy
;; Copyright 2007, 2008, 2009, 2011, 2012 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
......@@ -18,6 +18,8 @@
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;; /usr/include/gsl_odeiv.h
(in-package :gsl)
(defmobject ode-evolution "gsl_odeiv_evolve"
......
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