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 ;; Definition of GSLL system
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2009-03-14 19:19:06EDT gsll.asd> ;; Time-stamp: <2009-03-15 14:53:45EDT gsll.asd>
;; $Id$ ;; $Id$
(asdf:defsystem "gsll" (asdf:defsystem "gsll"
...@@ -17,7 +17,8 @@ ...@@ -17,7 +17,8 @@
(:file "forms") (:file "forms")
(:file "conditions" :depends-on (init)) (:file "conditions" :depends-on (init))
(:file "number-conversion" :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-included" :depends-on (mobject))
(:file "callback" :depends-on (init forms number-conversion callback-included)) (:file "callback" :depends-on (init forms number-conversion callback-included))
(:file "types" :depends-on (init)) (:file "types" :depends-on (init))
...@@ -193,19 +194,19 @@ ...@@ -193,19 +194,19 @@
(:file "lookup") (:file "lookup")
(:file "evaluation") (:file "evaluation")
(:file "spline-example" :depends-on (types)))) (:file "spline-example" :depends-on (types))))
;(:file "chebyshev" :depends-on (init)) (:file "chebyshev" :depends-on (init))
(:file "series-acceleration" :depends-on (init)) (:file "series-acceleration" :depends-on (init))
(:file "wavelet" :depends-on (init data)) (:file "wavelet" :depends-on (init data))
(:file "hankel" :depends-on (init data)) (:file "hankel" :depends-on (init data))
#+(or)
(:module solve-minimize-fit (:module solve-minimize-fit
:depends-on (init data random) :depends-on (init data random)
:components :components
((:file "generic") ((:file "generic")
(:file "roots-one" :depends-on (generic)) (:file "roots-one" :depends-on (generic))
(:file "minimization-one" :depends-on (generic)) ;;(:file "minimization-one" :depends-on (generic))
(:file "roots-multi" :depends-on (roots-one generic)) ;;(:file "roots-multi" :depends-on (roots-one generic))
(:file "minimization-multi" :depends-on (generic)) ;;(:file "minimization-multi" :depends-on (generic))
(:file "linear-least-squares") ;;(:file "linear-least-squares")
(:file "nonlinear-least-squares" :depends-on (generic)))) ;;(:file "nonlinear-least-squares" :depends-on (generic))
))
(:file "basis-splines" :depends-on (init data random)))) (: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 ;; The mobject that defines callbacks
;; Liam Healy 2009-03-14 11:20:03EDT callback-included.lisp ;; 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: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -48,52 +48,6 @@ ...@@ -48,52 +48,6 @@
(dimensions :initform '(1) :allocation :class)) (dimensions :initform '(1) :allocation :class))
(:documentation ,documentation))) (: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 ;;;; For making mobjects
;;;;**************************************************************************** ;;;;****************************************************************************
......
;; Foreign callback functions. ;; Foreign callback functions.
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2009-03-14 21:29:17EDT callback.lisp> ;; Time-stamp: <2009-03-15 14:28:59EDT callback.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -74,28 +74,11 @@ ...@@ -74,28 +74,11 @@
(defun make-cbstruct (struct slots-values &rest function-slotnames) (defun make-cbstruct (struct slots-values &rest function-slotnames)
"Make the callback structure." "Make the callback structure."
(assert struct (struct) "Structure must be supplied.")
(let ((cbstruct (cffi:foreign-alloc struct))) (let ((cbstruct (cffi:foreign-alloc struct)))
(set-cbstruct cbstruct struct slots-values function-slotnames) (set-cbstruct cbstruct struct slots-values function-slotnames)
cbstruct)) 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 ;;;; to be obsolete make-callbacks
;;;;**************************************************************************** ;;;;****************************************************************************
...@@ -166,7 +149,7 @@ ...@@ -166,7 +149,7 @@
;;; and each of the *-spec are (type array-type &rest dimensions). ;;; and each of the *-spec are (type array-type &rest dimensions).
;;; The :callback-dynamic is a list of functions corresponding in ;;; The :callback-dynamic is a list of functions corresponding in
;;; order to the cddr of the :callbacks argument (function... ) in which ;;; 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 ;;; where
;;; function = function designator, ;;; function = function designator,
;;; scalarsp = flag determining whether to pass/accept scalars or arrays ;;; scalarsp = flag determining whether to pass/accept scalars or arrays
...@@ -213,9 +196,10 @@ ...@@ -213,9 +196,10 @@
"From the :callbacks argument, parse a single argument of a single "From the :callbacks argument, parse a single argument of a single
function specification." function specification."
(ecase component (ecase component
(element-type (first argspec)) ; but it's always :double when this is a list (element-type
(array-type (second argspec)) (if (listp argspec) (first argspec) argspec)) ; but it's always :double when this is a list
(dimensions (cddr argspec)))) (array-type (when (listp argspec) (second argspec)))
(dimensions (when (listp argspec) (cddr argspec)))))
#| #|
(defparameter *cblist* (defparameter *cblist*
...@@ -331,34 +315,49 @@ FUNCTION ...@@ -331,34 +315,49 @@ FUNCTION
;; We always return success, because if there was a ;; We always return success, because if there was a
;; problem, a CL error would be signalled. ;; problem, a CL error would be signalled.
'(success)) '(success))
(:pointer ((:void :pointer)
;; For unclear reasons, some GSL functions want callbacks ;; For unclear reasons, some GSL functions want callbacks
;; to return a void pointer which is apparently meaningless. ;; to return a void pointer which is apparently meaningless.
'((cffi:null-pointer)))))))) '((cffi:null-pointer))))))))
(defun array-to-list (pointer dimensions marrayp) (defun array-to-list (pointer dimensions marrayp)
(assert (null (rest dimensions))) ; a vector only (assert (null (rest dimensions))) ; a vector only
(if marrayp (if dimensions
(loop for i below (first dimensions) collect (maref pointer i)) (if marrayp
(loop for i below (first dimensions) collect (dcref pointer i)))) (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) ;; a scalar, not an array
"From the list of values, set the foreign array at pointer." (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) (if (= (length dimensions) 2)
(loop for i below (first dimensions) (loop for i below (first dimensions)
with indl = -1 with indl = (1- start)
do do
(loop for j below (second dimensions) (loop for j below (second dimensions)
do do
(incf indl) (incf indl)
(if marrayp (if marrayp
(setf (maref pointer i j) (nth indl list)) (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 (if marrayp
(loop for i below (first dimensions) (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) (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) (defun call-maybe-scalar (function arguments scalars dimensions marrays)
"Call the function on the arguments. If scalars is true, pass the "Call the function on the arguments. If scalars is true, pass the
...@@ -380,7 +379,7 @@ FUNCTION ...@@ -380,7 +379,7 @@ FUNCTION
(first dimensions) (first dimensions)
(eq :marray (first marrays))))))) (eq :marray (first marrays)))))))
(if (rest arguments) (if (rest arguments)
(list-to-array (list-to-arrays
user-fn-return (second arguments) (second dimensions) (second marrays)) user-fn-return (rest arguments) (rest dimensions) (rest marrays))
(first user-fn-return))) (first user-fn-return)))
(apply function arguments))) (apply function arguments)))
;; Definition of GSL objects and ways to use them. ;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21 ;; 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. ;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate ;;; The macro demobject takes care of defining the appropriate
...@@ -21,6 +21,44 @@ ...@@ -21,6 +21,44 @@
(defconstant +callback-argument-name+ 'callback) (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 (defmacro defmobject
(class prefix allocation-args description (class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args &key documentation initialize-suffix initialize-name initialize-args
...@@ -30,9 +68,6 @@ ...@@ -30,9 +68,6 @@
singular) singular)
"Define the class, the allocate, initialize-instance and "Define the class, the allocate, initialize-instance and
reinitialize-instance methods, and the make-* function for the GSL object." 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")) (let* ((settingp (make-symbol "SETTINGP"))
(arglists (arglists
(when arglists-function (when arglists-function
...@@ -45,6 +80,8 @@ ...@@ -45,6 +80,8 @@
(initializerp (or initialize-name initialize-suffix)) (initializerp (or initialize-name initialize-suffix))
(initargs ; arguments that are exclusively for reinitialize-instance (initargs ; arguments that are exclusively for reinitialize-instance
(remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args))) (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) (if (have-at-least-gsl-version gsl-version)
`(progn `(progn
,(if callbacks ,(if callbacks
...@@ -171,7 +208,7 @@ ...@@ -171,7 +208,7 @@
`(:callbacks `(:callbacks
',callbacks ',callbacks
:callback-dynamic :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)) ,@(symbol-keyword-symbol (callback-remove-arg class-slots-instance))
,@(when (callback-arg-p class-slots-instance) ,@(when (callback-arg-p class-slots-instance)
(symbol-keyword-symbol 'functions)) (symbol-keyword-symbol 'functions))
......
;; One-dimensional root solver. ;; One-dimensional root solver.
;; Liam Healy ;; 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$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -14,19 +14,28 @@ ...@@ -14,19 +14,28 @@
(defmobject one-dimensional-root-solver-f "gsl_root_fsolver" (defmobject one-dimensional-root-solver-f "gsl_root_fsolver"
((type :pointer)) ((type :pointer))
"one-dimensional root solver with function only" "one-dimensional root solver with function only"
:superclasses (callback-included)
:ci-class-slots (gsl-function nil (function))
:initialize-suffix "set" :initialize-suffix "set"
:initialize-args ((callback :pointer) (lower :double) (upper :double)) :initialize-args ((callback :pointer) (lower :double) (upper :double))
:callbacks (callback gsl-function (function))
:callback-dynamic ((function))
:singular (function)) :singular (function))
(defmobject one-dimensional-root-solver-fdf "gsl_root_fdfsolver" (defmobject one-dimensional-root-solver-fdf "gsl_root_fdfsolver"
((type :pointer)) ((type :pointer))
"one-dimensional root solver with function and derivative" "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-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) (def-make-callbacks one-dimensional-root-solver-fdf (function df fdf)
`(progn `(progn
...@@ -70,6 +79,7 @@ ...@@ -70,6 +79,7 @@
"gsl_root_fsolver_iterate" "gsl_root_fsolver_iterate"
(((mpointer solver) :pointer)) (((mpointer solver) :pointer))
:definition :method :definition :method
:callback-object solver
:documentation ; FDL :documentation ; FDL
"Perform a single iteration of the solver. The following errors may "Perform a single iteration of the solver. The following errors may
be signalled: 'bad-function-supplied, the iteration encountered a be signalled: 'bad-function-supplied, the iteration encountered a
...@@ -82,6 +92,7 @@ ...@@ -82,6 +92,7 @@
"gsl_root_fdfsolver_iterate" "gsl_root_fdfsolver_iterate"
(((mpointer solver) :pointer)) (((mpointer solver) :pointer))
:definition :method :definition :method
:callback-object solver
:documentation ; FDL :documentation ; FDL
"Perform a single iteration of the solver. The following errors may "Perform a single iteration of the solver. The following errors may
be signalled: 'bad-function-supplied, the iteration encountered a be signalled: 'bad-function-supplied, the iteration encountered a
...@@ -302,9 +313,9 @@ ...@@ -302,9 +313,9 @@
(values (+ (* (+ (* a x) b) x) c) (values (+ (* (+ (* a x) b) x) c)
(+ (* 2 a x) b)))) (+ (* 2 a x) b))))
(make-callbacks single-function quadratic) ;; (make-callbacks single-function quadratic)
(make-callbacks one-dimensional-root-solver-fdf ;; (make-callbacks one-dimensional-root-solver-fdf
quadratic quadratic-derivative quadratic-and-derivative) ;; quadratic quadratic-derivative quadratic-and-derivative)
(defun roots-one-example-no-derivative (defun roots-one-example-no-derivative
(&optional (method +brent-fsolver+) (print-steps t)) (&optional (method +brent-fsolver+) (print-steps t))
...@@ -336,7 +347,7 @@ ...@@ -336,7 +347,7 @@
(initial 5.0d0) (initial 5.0d0)
(solver (make-one-dimensional-root-solver-fdf (solver (make-one-dimensional-root-solver-fdf
method method
'(quadratic quadratic-derivative quadratic-and-derivative) 'quadratic 'quadratic-derivative 'quadratic-and-derivative
initial))) initial)))
(when print-steps (when print-steps
(format t "iter ~6t ~8troot ~22terr ~34terr(est)~&")) (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