Commit d3fd192d authored by Liam Healy's avatar Liam Healy

Dynamic callback defined in mobject, works for chebyshev

The class 'callback-included has been simplified by replacing several
obsolete slots with 'callbacks and 'callback-dynamic.  The :callbacks
static information is saved to a hash table so that it may be
retrieved when the defmfun is expanded.  The function
make-cbstruct-object to make the callback structure
as an &aux variable in reinitialize-instance :after form expanded in
defmobject is now a form expansion executed at macroexpand time.
The argument :callback-object has been added to defmfun; this will
result in the binding of the dynfn dynamic variable on expansion.

The callback arguments for chebyshev definitions have been updated and
the example works.
parent 4e928c8c
;; Chebyshev Approximations
;; Liam Healy Sat Nov 17 2007 - 20:36
;; Time-stamp: <2009-03-10 22:45:03EDT chebyshev.lisp>
;; Time-stamp: <2009-03-14 19:23:41EDT chebyshev.lisp>
;; $Id$
(in-package :gsl)
......@@ -16,15 +16,8 @@
"Chebyshev series"
:documentation ; FDL
"Make a Chebyshev series of specified order."
;; Old arguments:
:superclasses (callback-included)
:ci-class-slots (gsl-function nil (function))
;; :ci-class-slots (gsl-mfunction-fdf marray (function df fdf))
;; New arguments:
:callbacks (callback gsl-function (function))
;:callback-dynamic ((function))
:callback-dynamic ((function))
:initialize-suffix "init"
:initialize-args
((callback :pointer) (lower-limit :double) (upper-limit :double))
......@@ -62,6 +55,7 @@
((((mpointer object) :pointer) (x :double))
(((mpointer object) :pointer) (order sizet) (x :double)))
:definition :method
:callback-object object
:c-return :double
:documentation ; FDL
"Evaluate the Chebyshev series at a point x. If order is supplied,
......@@ -109,7 +103,7 @@
(defun chebyshev-step (x) (if (< x 0.5d0) 0.25d0 0.75d0))
(make-callbacks single-function chebyshev-step)
;; (make-callbacks single-function chebyshev-step)
(defun chebyshev-table-example ()
(let ((steps 100))
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2009-03-14 11:27:10EDT gsll.asd>
;; Time-stamp: <2009-03-14 19:19:06EDT gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -18,15 +18,15 @@
(:file "conditions" :depends-on (init))
(:file "number-conversion" :depends-on (init))
(:file "mobject" :depends-on (init))
(:file "callback" :depends-on (init forms number-conversion))
(:file "callback-included" :depends-on (mobject))
(:file "callback" :depends-on (init forms number-conversion callback-included))
(:file "types" :depends-on (init))
(:file "complex-types" :depends-on (types))
(:file "element-types" :depends-on (init complex-types))
(:file "interface"
:depends-on (init conditions element-types number-conversion))
(:file "defmfun" :depends-on (init forms element-types interface))
(:file "defmfun-array" :depends-on (defmfun))
(:file "defmfun-array" :depends-on (defmfun callback-included))
(:file "defmfun-single" :depends-on (defmfun mobject callback))
(:file "generate-examples" :depends-on (init))))
(:module floating-point
......
;; The mobject that defines callbacks
;; Liam Healy 2009-03-14 11:20:03EDT callback-included.lisp
;; Time-stamp: <2009-03-14 11:29:41EDT callback-included.lisp>
;; Time-stamp: <2009-03-14 21:22:18EDT callback-included.lisp>
;; $Id: $
(in-package :gsl)
;;;;****************************************************************************
;;;; Class definitions and macros
;;;;****************************************************************************
(defclass callback-included (mobject)
((cbstruct-name
:initarg :cbstruct-name :reader cbstruct-name
:documentation
"The name of the GSL structure representing the callback(s).")
(array-type
:initarg :array-type :reader array-type
:documentation "A symbol 'marray or 'cvector.")
(callback-labels
:initarg :callback-labels :reader callback-labels
:documentation "The labels in the GSL struct for each callback function.")
((callbacks
:initarg :callbacks :reader callbacks
:documentation "The specification form for static callback information.")
(callback-dynamic
:initarg :callback-dynamic :reader callback-dynamic
:documentation "A list of (function scalarsp dimensions &rest dimensions).")
(dimension-names
:initarg :dimension-names :reader dimension-names
:documentation "The names in the GSL struct for dimensions.")
(functions
:initarg :functions :reader functions
:documentation "The names of the function(s) put into
the callback. These should correspond in order to
callback-labels.")
:documentation "The names of the function(s) defined by defmcallback.
These should correspond in order to the structure-slot-name list.")
(dimensions :initarg :dimensions :reader dimensions))
(:documentation
"A mobject that includes a callback function or functions to GSL."))
......@@ -37,40 +36,76 @@
(defmacro def-ci-subclass
(class-name superclasses documentation
cbstruct-name array-type callback-labels
&optional (dimension-names '(dimensions)))
`(defclass ,class-name ,superclasses
((cbstruct-name :initform ',cbstruct-name :allocation :class)
(array-type :initform ',array-type :allocation :class)
(callback-labels :initform ',callback-labels :allocation :class)
(dimension-names :initform ',dimension-names :allocation :class))
((dimension-names :initform ',dimension-names :allocation :class))
(:documentation ,documentation)))
(defmacro def-ci-subclass-1d
(class-name superclasses documentation
cbstruct-name array-type callback-labels)
(class-name superclasses documentation)
`(defclass ,class-name ,superclasses
((cbstruct-name :initform ',cbstruct-name :allocation :class)
(array-type :initform ',array-type :allocation :class)
(callback-labels :initform ',callback-labels :allocation :class)
(dimension-names :initform nil :allocation :class)
((dimension-names :initform nil :allocation :class)
(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
;;;;****************************************************************************
#|
(defun ci-subclass-cdddr-args (callbacks)
"Make the list
cbstruct-name array-type callback-labels
&optional (dimension-names '(dimensions)
for def-ci-subclass and def-ci-subclass-1d."
(list
(parse-callback-static callbacks 'callback-structure-type)
(callback-argument-function-argspec 'array-type))
)
|#
(defun callback-set-dynamic (callback-object arglist)
"Make a form to set the dynamic variable defining callbacks."
`((setf
,@(loop for symb in
(let ((class (category-for-argument arglist callback-object)))
(mobject-fnvnames
class
(number-of-callbacks (get-callbacks-for-class class))))
for n from 0
append
`(,symb (nth ,n (callback-dynamic ,callback-object)))))))
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-03-14 11:29:47EDT callback.lisp>
;; Time-stamp: <2009-03-14 21:29:17EDT callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -78,14 +78,23 @@
(set-cbstruct cbstruct struct slots-values function-slotnames)
cbstruct))
(defun make-cbstruct-object (object)
;; 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."
(apply
'make-cbstruct
(cbstruct-name object)
(when (dimension-names object)
(mapcan 'list (dimension-names object) (dimensions object)))
(mapcan 'list (callback-labels object) (functions object))))
(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
......@@ -157,7 +166,8 @@
;;; 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...) where
;;; each element is a list of (function scalarsp dimensions &rest dimensions)
;;; where
;;; function = function designator,
;;; scalarsp = flag determining whether to pass/accept scalars or arrays
;;; dimensions = dimension of the problem
......@@ -170,6 +180,7 @@
(foreign-argument (first callbacks))
(callback-structure-type (second callbacks))
(functions (cddr callbacks))
;; The parts below are obsolete?
(t
(let* ((fn (nth fn-num (cddr callbacks)))
(comp
......@@ -229,6 +240,9 @@ FUNCTION
;;;; Form generation
;;;;****************************************************************************
(defun callback-dynamic-lister (callback-dynamic)
(mapcar (lambda (l) (cons 'list l)) callback-dynamic))
(defun callback-symbol-set (callbacks symbols)
"Generate the form to set each of the dynamic (special) variables
to (function scalarsp dimensions...) in the body of the demfun for
......@@ -236,22 +250,22 @@ FUNCTION
(when callbacks
`((setf
,@(loop for symb in symbols
for list in callbacks
append (list symb (cons 'list list)))))))
for list in (callback-dynamic-lister callbacks)
append (list symb list))))))
(defun callback-set-slots (callbacks symbols)
(when callbacks
`((set-cbstruct
,(parse-callback-static callbacks 'foreign-argument)
',(parse-callback-static callbacks 'callback-structure-type)
nil ; will have dimensions
,(cons
'list
(loop for symb in symbols
for fnnum from 0
append
`(',(parse-callback-static fn 'structure-slot-name)
',symb)))))))
`((set-cbstruct
,(parse-callback-static callbacks 'foreign-argument)
',(parse-callback-static callbacks 'callback-structure-type)
nil ; will have dimensions
,(cons
'list
(loop for symb in symbols
for fn in (parse-callback-static callbacks 'functions)
append
`(',(parse-callback-fnspec fn 'structure-slot-name)
',symb)))))))
(defun callback-args (types)
"The arguments passed by GSL to the callback function."
......
;; Helpers that define a single GSL function interface
;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp
;; Time-stamp: <2009-03-02 08:45:41EST defmfun-single.lisp>
;; Time-stamp: <2009-03-14 21:52:22EDT defmfun-single.lisp>
;; $Id: $
(in-package :gsl)
......@@ -87,7 +87,7 @@
(cl-argument-types arglist c-arguments)
(set-difference ; find all the unused variables
(arglist-plain-and-categories arglist nil)
(union
(remove-duplicates (union
(if mapdown
(apply 'union
(mapcar 'variables-used-in-c-arguments c-arguments))
......@@ -97,14 +97,14 @@
(cons
'values
(append before after
(callback-symbol-set callback-dynamic (first callback-gensyms))
(callback-symbol-set callback-dynamic (first callback-dynamic-variables))
(let ((auxstart (position '&aux arglist)))
;; &aux bindings are checked
(when auxstart
(apply
'append
(mapcar 'rest (subseq arglist (1+ auxstart)))))))))))
(first callback-gensyms))
(mapcar 'rest (subseq arglist (1+ auxstart))))))))))))
(first callback-dynamic-variables))
,@(when documentation (list documentation))
,(funcall body-maker name arglist gsl-name c-arguments key-args))
`(,defn
......@@ -181,9 +181,12 @@
allocated-decl
(mapcar #'wfo-declare allocated-decl)
'cffi:with-foreign-objects
`(,@(append (callback-symbol-set callback-dynamic (first callback-gensyms))
before)
,@(callback-set-slots callbacks (second callback-gensyms))
`(,@(append
(callback-symbol-set
callback-dynamic (first callback-dynamic-variables))
(when callback-object (callback-set-dynamic callback-object arglist))
before)
,@(callback-set-slots callbacks (second callback-dynamic-variables))
(let ((,cret-name
(cffi:foreign-funcall
,gsl-name
......
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2009-03-09 22:34:54EDT defmfun.lisp>
;; Time-stamp: <2009-03-14 21:54:00EDT defmfun.lisp>
;; $Id$
(in-package :gsl)
......@@ -61,6 +61,7 @@
;;; callbacks A list that specifies the callback structure and function(s); see callback.lisp
;;; callback-dynamic Values for callback function(s) set at runtime. The order matches
;;; the functions listed in :callbacks. See callback.lisp for contents.
;;; callback-object Name of the object has callbacks.
(defmacro defmfun (name arglist gsl-name c-arguments &rest key-args)
"Definition of a GSL function."
......@@ -77,13 +78,13 @@
(definition :function)
(export (not (member definition (list :method :methods))))
documentation inputs outputs before after enumeration qualifier
gsl-version switch callbacks callback-dynamic)
gsl-version switch callbacks callback-dynamic callback-object)
,key-args
(declare (ignorable c-return return definition element-types
index export documentation inputs outputs
before after enumeration qualifier
gsl-version switch callbacks callback-dynamic)
(special indexed-functions callback-gensyms))
gsl-version switch callbacks callback-dynamic callback-object)
(special indexed-functions callback-dynamic-variables))
,@body))
(defun optional-args-to-switch-gsl-functions (arglist gsl-name)
......@@ -96,18 +97,24 @@
(listp (first gsl-name)))))
(defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args)
(let (indexed-functions callback-gensyms)
(let (indexed-functions callback-dynamic-variables)
;; workaround for compiler errors that don't see 'indexed-function is used
(declare (ignorable indexed-functions callback-gensyms))
(declare (ignorable indexed-functions callback-dynamic-variables))
(with-defmfun-key-args key-args
(setf indexed-functions (list)
callback-gensyms
callback-dynamic-variables
;; A list of variable names, and a list of callback names
(when callbacks
(let ((num-callbacks (number-of-callbacks callbacks)))
(list
(loop repeat num-callbacks collect (gensym "DYNFN"))
(loop repeat num-callbacks collect (gensym "CBFN"))))))
(when (or callbacks callback-object)
(if callback-object
(let ((class (category-for-argument arglist callback-object)))
(list (mobject-fnvnames
class
(number-of-callbacks (get-callbacks-for-class class)))
nil))
(let ((num-callbacks (number-of-callbacks callbacks)))
(list
(loop repeat num-callbacks collect (gensym "DYNFN"))
(loop repeat num-callbacks collect (gensym "CBFN")))))))
(wrap-index-export
(cond
((eq definition :generic)
......@@ -141,7 +148,9 @@
`(progn
,@(if (symbolp (first expanded-body)) (list expanded-body) expanded-body)
,@(make-defmcallbacks
callbacks (second callback-gensyms) (first callback-gensyms))
callbacks
(second callback-dynamic-variables)
(first callback-dynamic-variables))
,@index-export))))
;;;;****************************************************************************
......
;; Lisp forms
;; Liam Healy 2009-03-07 15:49:25EST forms.lisp
;; Time-stamp: <2009-03-07 15:52:27EST forms.lisp>
;; Time-stamp: <2009-03-14 18:44:04EDT forms.lisp>
(in-package :gsl)
......@@ -31,3 +31,11 @@
(if (listp arg) (first arg) arg)
into noclass-arglist
finally (return (values noclass-arglist categories))))
(defun category-for-argument (arglist symbol)
"Find the category (class) for the given argument."
(multiple-value-bind (plain cats)
(arglist-plain-and-categories arglist)
(let ((pos (position symbol plain)))
(when pos
(nth pos cats)))))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-03-09 22:52:54EDT mobject.lisp>
;; Time-stamp: <2009-03-14 21:39:48EDT mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -25,16 +25,15 @@
(class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer
(superclasses '(mobject))
class-slots-instance ci-class-slots callbacks singular)
class-slots-instance ci-class-slots callbacks callback-dynamic
(superclasses (if callbacks '(callback-included) '(mobject)))
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"))
(callbackp
(member-if (lambda (cl) (subtypep cl 'callback-included)) superclasses))
(arglists
(when arglists-function
(funcall (coerce arglists-function 'function) settingp)))
......@@ -48,7 +47,7 @@
(remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
(if (have-at-least-gsl-version gsl-version)
`(progn
,(if callbackp
,(if callbacks
`(,(if (member 'dimensions cl-alloc-args)
'def-ci-subclass 'def-ci-subclass-1d)
,class
......@@ -74,19 +73,15 @@
(make-reinitialize-instance
class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs
(and callbackp
(and callbacks
(not (callback-arg-p class-slots-instance)))))
(export '(,maker ,class))
,@(when callbacks
(let ((numcb (number-of-callbacks callbacks)))
(make-defmcallbacks
callbacks
(mobject-cbvnames class numcb)
(mobject-fnvnames class numcb))))
,@(when callbacks `((record-callbacks-for-class ',class ',callbacks)))
,@(when callbacks (make-mobject-defmcallbacks callbacks class))
,(mobject-maker
maker arglists initargs class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp
singular class-slots-instance))
singular class-slots-instance callbacks callback-dynamic))
`(progn
(export ',maker)
(defun ,maker (&rest args)
......@@ -124,7 +119,7 @@
&key
,@cl-initialize-args
,@(when callback
`(&aux (,cbstruct (make-cbstruct-object object)))))
`(&aux (,cbstruct ,(make-cbstruct-object class)))))
,(or initialize-name
(format nil "~a_~a" prefix
(if (listp initialize-suffix)
......@@ -133,6 +128,7 @@
(((mpointer object) :pointer)
,@(callback-replace-arg cbstruct initialize-args))
:definition :method
,@(when callback '(:callback-object object))
:qualifier :after
,@(when (and initialize-suffix (listp initialize-suffix))
`(:c-return ,(second initialize-suffix)))
......@@ -150,7 +146,7 @@
(defun mobject-maker
(maker arglists initargs class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp
singular class-slots-instance)
singular class-slots-instance callbacks callback-dynamic)
"Make the defun form that makes the mobject."
`(defun ,maker
,(if arglists
......@@ -170,6 +166,12 @@
(let ((object
(make-instance
',class
,@(when
callbacks
`(:callbacks
',callbacks
: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))
......@@ -227,29 +229,6 @@
(list (intern (symbol-name symbol) :keyword)
symbol))))
;;;;****************************************************************************
;;;; Symbol makers
;;;;****************************************************************************
;;; These functions make interned symbols that will be bound to
;;; dynamic variables.
(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)
(loop for i from 0 below count collect (mobject-fnvname class-name i)))
;;;;****************************************************************************
;;;; Generic functions
;;;;****************************************************************************
......
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