Commit 94bcffd5 authored by Liam Healy's avatar Liam Healy

Better support for array returns (prototype roots-one), ordering of load

In roots-one.lisp, added arguments for dynamic callbacks.  This is not
complete; 
 (roots-one-example-derivative +newton-fdfsolver+ nil)
causes both SBCL and CCL to crash to low-level debuggers.
These changes included using a new function list-to-arrays in
call-maybe-scalar so that multiple arrays can be set. 
New file callback-compile-defs has definitions that are needed at
compile time of later files.  Added a call record-callbacks-for-class
in defmobject, in addition to the expansion in the form, because the
hash table *callbacks-for-classes* needs to be updated with the class
being defined for the macro make-cbstruct-object to work.  Added
comments above defmobject to explain some of the arguments.
parent d3fd192d
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2009-03-14 19:19:06EDT gsll.asd>
;; Time-stamp: <2009-03-15 14:53:45EDT gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -17,7 +17,8 @@
(:file "forms")
(:file "conditions" :depends-on (init))
(:file "number-conversion" :depends-on (init))
(:file "mobject" :depends-on (init))
(:file "callback-compile-defs" :depends-on (init))
(:file "mobject" :depends-on (init callback-compile-defs))
(:file "callback-included" :depends-on (mobject))
(:file "callback" :depends-on (init forms number-conversion callback-included))
(:file "types" :depends-on (init))
......@@ -193,19 +194,19 @@
(: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
((:file "generic")
(:file "roots-one" :depends-on (generic))
(:file "minimization-one" :depends-on (generic))
(:file "roots-multi" :depends-on (roots-one generic))
(:file "minimization-multi" :depends-on (generic))
(:file "linear-least-squares")
(:file "nonlinear-least-squares" :depends-on (generic))))
;;(:file "minimization-one" :depends-on (generic))
;;(:file "roots-multi" :depends-on (roots-one generic))
;;(:file "minimization-multi" :depends-on (generic))
;;(:file "linear-least-squares")
;;(:file "nonlinear-least-squares" :depends-on (generic))
))
(:file "basis-splines" :depends-on (init data random))))
;; Definitions for macro expansion
;; Liam Healy 2009-03-15 14:50:28EDT callback-compile-defs.lisp
;; Time-stamp: <2009-03-15 14:53:24EDT callback-compile-defs.lisp>
;; $Id: $
(in-package :gsl)
;;;;****************************************************************************
;;;; Record the :callbacks information for the object
;;;;****************************************************************************
(defvar *callbacks-for-classes* (make-hash-table :size 32)
"A table of :callbacks arguments for each class.")
(defun record-callbacks-for-class (class callbacks)
(setf (gethash class *callbacks-for-classes*) callbacks))
(defun get-callbacks-for-class (class)
(gethash class *callbacks-for-classes*))
;; old dimensions
;; (when (dimension-names object)
;; (mapcan 'list (dimension-names object) (dimensions object)))
(defun make-cbstruct-object (class)
"Make the callback structure based on the mobject definition."
(let ((cbs (get-callbacks-for-class class)))
(unless cbs (error "Class ~a not defined." class))
`(make-cbstruct
',(parse-callback-static cbs 'callback-structure-type)
nil ; dimensions eventually, see above
,@(mapcan
'list
(mapcar
(lambda (fn) `',(parse-callback-fnspec fn 'structure-slot-name))
(parse-callback-static cbs 'functions))
(mapcar (lambda (nm) `',nm)
(mobject-cbvnames class (number-of-callbacks cbs)))))))
;;;;****************************************************************************
;;;; Make defmcallback forms
;;;;****************************************************************************
;;; These functions make interned symbols that will be bound to
;;; dynamic variables.
(defun make-mobject-defmcallbacks (callbacks class)
"Make the defmcallback forms needed to define the callbacks
associated with mobject that includes callback functions."
(let ((numcb (number-of-callbacks callbacks)))
(make-defmcallbacks
callbacks
(mobject-cbvnames class numcb)
(mobject-fnvnames class numcb))))
(defun mobject-variable-name (class-name suffix &optional count)
(intern (format nil "~:@(~a~)-~:@(~a~)~@[~d~]" class-name suffix count)
:gsll))
(defun mobject-cbvname (class-name &optional count)
(mobject-variable-name class-name 'cbfn count))
(defun mobject-cbvnames (class-name &optional count)
(loop for i from 0 below count collect (mobject-cbvname class-name i)))
(defun mobject-fnvname (class-name &optional count)
(mobject-variable-name class-name 'dynfn count))
(defun mobject-fnvnames (class-name &optional count)
(when class-name
(loop for i from 0 below count collect (mobject-fnvname class-name i))))
;; The mobject that defines callbacks
;; Liam Healy 2009-03-14 11:20:03EDT callback-included.lisp
;; Time-stamp: <2009-03-14 21:22:18EDT callback-included.lisp>
;; Time-stamp: <2009-03-15 14:53:27EDT callback-included.lisp>
;; $Id: $
(in-package :gsl)
......@@ -48,52 +48,6 @@
(dimensions :initform '(1) :allocation :class))
(:documentation ,documentation)))
;;;;****************************************************************************
;;;; Record the :callbacks information for the object
;;;;****************************************************************************
(defvar *callbacks-for-classes* (make-hash-table :size 32)
"A table of :callbacks arguments for each class.")
(defun record-callbacks-for-class (class callbacks)
(setf (gethash class *callbacks-for-classes*) callbacks))
(defun get-callbacks-for-class (class)
(gethash class *callbacks-for-classes*))
;;;;****************************************************************************
;;;; Make defmcallback forms
;;;;****************************************************************************
;;; These functions make interned symbols that will be bound to
;;; dynamic variables.
(defun make-mobject-defmcallbacks (callbacks class)
"Make the defmcallback forms needed to define the callbacks
associated with mobject that includes callback functions."
(let ((numcb (number-of-callbacks callbacks)))
(make-defmcallbacks
callbacks
(mobject-cbvnames class numcb)
(mobject-fnvnames class numcb))))
(defun mobject-variable-name (class-name suffix &optional count)
(intern (format nil "~:@(~a~)-~:@(~a~)~@[~d~]" class-name suffix count)
:gsll))
(defun mobject-cbvname (class-name &optional count)
(mobject-variable-name class-name 'cbfn count))
(defun mobject-cbvnames (class-name &optional count)
(loop for i from 0 below count collect (mobject-cbvname class-name i)))
(defun mobject-fnvname (class-name &optional count)
(mobject-variable-name class-name 'dynfn count))
(defun mobject-fnvnames (class-name &optional count)
(when class-name
(loop for i from 0 below count collect (mobject-fnvname class-name i))))
;;;;****************************************************************************
;;;; For making mobjects
;;;;****************************************************************************
......
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-03-14 21:29:17EDT callback.lisp>
;; Time-stamp: <2009-03-15 14:28:59EDT callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -74,28 +74,11 @@
(defun make-cbstruct (struct slots-values &rest function-slotnames)
"Make the callback structure."
(assert struct (struct) "Structure must be supplied.")
(let ((cbstruct (cffi:foreign-alloc struct)))
(set-cbstruct cbstruct struct slots-values function-slotnames)
cbstruct))
;; old dimensions
;; (when (dimension-names object)
;; (mapcan 'list (dimension-names object) (dimensions object)))
(defun make-cbstruct-object (class)
"Make the callback structure based on the mobject definition."
(let ((cbs (get-callbacks-for-class class)))
`(make-cbstruct
',(parse-callback-static cbs 'callback-structure-type)
nil ; dimensions eventually, see above
,@(mapcan
'list
(mapcar
(lambda (fn) `',(parse-callback-fnspec fn 'structure-slot-name))
(parse-callback-static cbs 'functions))
(mapcar (lambda (nm) `',nm)
(mobject-cbvnames class (number-of-callbacks cbs)))))))
;;;;****************************************************************************
;;;; to be obsolete make-callbacks
;;;;****************************************************************************
......@@ -166,7 +149,7 @@
;;; and each of the *-spec are (type array-type &rest dimensions).
;;; The :callback-dynamic is a list of functions corresponding in
;;; order to the cddr of the :callbacks argument (function... ) in which
;;; each element is a list of (function scalarsp dimensions &rest dimensions)
;;; each element is a list of (function scalarsp &rest dimensions)
;;; where
;;; function = function designator,
;;; scalarsp = flag determining whether to pass/accept scalars or arrays
......@@ -213,9 +196,10 @@
"From the :callbacks argument, parse a single argument of a single
function specification."
(ecase component
(element-type (first argspec)) ; but it's always :double when this is a list
(array-type (second argspec))
(dimensions (cddr argspec))))
(element-type
(if (listp argspec) (first argspec) argspec)) ; but it's always :double when this is a list
(array-type (when (listp argspec) (second argspec)))
(dimensions (when (listp argspec) (cddr argspec)))))
#|
(defparameter *cblist*
......@@ -331,34 +315,49 @@ FUNCTION
;; We always return success, because if there was a
;; problem, a CL error would be signalled.
'(success))
(:pointer
((:void :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 dimensions marrayp)
(assert (null (rest dimensions))) ; a vector only
(if marrayp
(loop for i below (first dimensions) collect (maref pointer i))
(loop for i below (first dimensions) collect (dcref pointer i))))
(defun list-to-array (list pointer dimensions marrayp)
"From the list of values, set the foreign array at pointer."
(if dimensions
(if marrayp
(loop for i below (first dimensions) collect (maref pointer i))
(loop for i below (first dimensions) collect (dcref pointer i)))
;; a scalar, not an array
(list pointer)))
(defun list-to-array (list pointer dimensions marrayp &optional (start 0))
"From the list of values starting at index start, set the foreign
array at pointer. Return the index in the list of the next element
not processed."
(if (= (length dimensions) 2)
(loop for i below (first dimensions)
with indl = -1
with indl = (1- start)
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)))))
(setf (dcref pointer indl) (nth indl list))))
finally (return (1+ indl)))
(if marrayp
(loop for i below (first dimensions)
do (setf (maref pointer i) (nth i list)))
do (setf (maref pointer i) (nth (+ start i) list))
finally (return (+ start (first dimensions))))
(loop for i below (first dimensions)
do (setf (dcref pointer i) (nth i list))))))
do (setf (dcref pointer i) (nth (+ start i) list))
finally (return (+ start (first dimensions)))))))
(defun list-to-arrays (list pointers dimensionss marrayps)
(loop for pointer in pointers
for dimensions in dimensionss
for marrayp in marrayps
for start = 0 then
(list-to-array list pointer dimensions marrayp start)))
(defun call-maybe-scalar (function arguments scalars dimensions marrays)
"Call the function on the arguments. If scalars is true, pass the
......@@ -380,7 +379,7 @@ FUNCTION
(first dimensions)
(eq :marray (first marrays)))))))
(if (rest arguments)
(list-to-array
user-fn-return (second arguments) (second dimensions) (second marrays))
(list-to-arrays
user-fn-return (rest arguments) (rest dimensions) (rest marrays))
(first user-fn-return)))
(apply function arguments)))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-03-14 21:39:48EDT mobject.lisp>
;; Time-stamp: <2009-03-15 14:56:45EDT mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -21,6 +21,44 @@
(defconstant +callback-argument-name+ 'callback)
;;; Required arguments for defmobject:
;;; class Name of class being made.
;;; prefix String that starts each GSL function name
;;; allocation-args Arguments used in the allocation (initialization)
;;; description Short string describing class
;;; Key arguments for defmobject:
;;; documentation
;;; Docstring for the object maker.
;;; initialize-suffix
;;; The string appended to prefix to form GSL function name or a list of
;;; such a string and the c-return argument.
;;; initialize-name
;;; A string with the name of the GSL function for initialization; defaults to
;;; prefix + initialize-suffix.
;;; initialize-args
;;; arglists-function
;;; A function of one symbol, a flag indicating that an optional
;;; argument has been set. It returns a list of three forms: the
;;; arglists for the maker defun, the arguments that will be applied
;;; therein to the inititializer and to the reinitializer.
;;; inputs, gsl-version
;;; Defmfun arguments for reinitializer.
;;; allocator
;;; allocate-inputs
;;; freer
;;; class-slots-instance
;;; ci-class-slots OBSOLETE
;;; callbacks
;;; See callbacks.lisp
;;; callback-dynamic
;;; See callbacks.lisp
;;; superclasses
;;; List of superclasses other than 'mobject.
;;; singular
;;; Where a list of several objects like 'functions is specified, this permits
;;; a single one with the singular form, like 'function.
(defmacro defmobject
(class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args
......@@ -30,9 +68,6 @@
singular)
"Define the class, the allocate, initialize-instance and
reinitialize-instance methods, and the make-* function for the GSL object."
;; Argument 'initialize-suffix: string appended to prefix to form
;; GSL function name or a list of such a string and the c-return
;; argument.
(let* ((settingp (make-symbol "SETTINGP"))
(arglists
(when arglists-function
......@@ -45,6 +80,8 @@
(initializerp (or initialize-name initialize-suffix))
(initargs ; arguments that are exclusively for reinitialize-instance
(remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
;; Need callback information for macroexpansion make-cbstruct-object
(when callbacks (record-callbacks-for-class class callbacks))
(if (have-at-least-gsl-version gsl-version)
`(progn
,(if callbacks
......@@ -171,7 +208,7 @@
`(:callbacks
',callbacks
:callback-dynamic
,(cons 'cl:list(callback-dynamic-lister callback-dynamic))))
,(cons 'cl:list (callback-dynamic-lister callback-dynamic))))
,@(symbol-keyword-symbol (callback-remove-arg class-slots-instance))
,@(when (callback-arg-p class-slots-instance)
(symbol-keyword-symbol 'functions))
......
;; One-dimensional root solver.
;; Liam Healy
;; Time-stamp: <2009-02-16 09:50:33EST roots-one.lisp>
;; Time-stamp: <2009-03-15 12:39:02EDT roots-one.lisp>
;; $Id$
(in-package :gsl)
......@@ -14,19 +14,28 @@
(defmobject one-dimensional-root-solver-f "gsl_root_fsolver"
((type :pointer))
"one-dimensional root solver with function only"
:superclasses (callback-included)
:ci-class-slots (gsl-function nil (function))
:initialize-suffix "set"
:initialize-args ((callback :pointer) (lower :double) (upper :double))
:callbacks (callback gsl-function (function))
:callback-dynamic ((function))
:singular (function))
(defmobject one-dimensional-root-solver-fdf "gsl_root_fdfsolver"
((type :pointer))
"one-dimensional root solver with function and derivative"
:superclasses (callback-included)
:ci-class-slots (gsl-function-fdf nil (function df fdf))
:initialize-suffix "set"
:initialize-args ((callback :pointer) (root-guess :double)))
:initialize-args ((callback :pointer) (root-guess :double))
:callbacks
(callback gsl-function-fdf
(function)
(df)
(fdf :void :double (:double :cvector 1) (:double :cvector 1)))
:callback-dynamic ((function) (df) (fdf t))
:arglists-function
(lambda (set)
`((type &optional (function nil ,set) df fdf root-guess)
(:type type)
(:functions (list function df fdf) :root-guess root-guess))))
(def-make-callbacks one-dimensional-root-solver-fdf (function df fdf)
`(progn
......@@ -70,6 +79,7 @@
"gsl_root_fsolver_iterate"
(((mpointer solver) :pointer))
:definition :method
:callback-object solver
:documentation ; FDL
"Perform a single iteration of the solver. The following errors may
be signalled: 'bad-function-supplied, the iteration encountered a
......@@ -82,6 +92,7 @@
"gsl_root_fdfsolver_iterate"
(((mpointer solver) :pointer))
:definition :method
:callback-object solver
:documentation ; FDL
"Perform a single iteration of the solver. The following errors may
be signalled: 'bad-function-supplied, the iteration encountered a
......@@ -302,9 +313,9 @@
(values (+ (* (+ (* a x) b) x) c)
(+ (* 2 a x) b))))
(make-callbacks single-function quadratic)
(make-callbacks one-dimensional-root-solver-fdf
quadratic quadratic-derivative quadratic-and-derivative)
;; (make-callbacks single-function quadratic)
;; (make-callbacks one-dimensional-root-solver-fdf
;; quadratic quadratic-derivative quadratic-and-derivative)
(defun roots-one-example-no-derivative
(&optional (method +brent-fsolver+) (print-steps t))
......@@ -336,7 +347,7 @@
(initial 5.0d0)
(solver (make-one-dimensional-root-solver-fdf
method
'(quadratic quadratic-derivative quadratic-and-derivative)
'quadratic 'quadratic-derivative 'quadratic-and-derivative
initial)))
(when print-steps
(format t "iter ~6t ~8troot ~22terr ~34terr(est)~&"))
......
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