diff --git a/chebyshev.lisp b/chebyshev.lisp index 7d8a9ff2a25dc0543030f9eb1895395e192b61f3..4a517658feb71fcf6278579440ac88764ac3e72e 100644 --- a/chebyshev.lisp +++ b/chebyshev.lisp @@ -1,6 +1,6 @@ ;; 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)) diff --git a/gsll.asd b/gsll.asd index f6c1ac3082840013cba00e1b60596ad63760d348..b47aa3069b3f30ca78900ae6313e6f97814059be 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; 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 diff --git a/init/callback-included.lisp b/init/callback-included.lisp index 506c0bf3bd44026144da97502b03d95f83d3d8cb..edacb091fd5f905743277faec52db325fb557743 100644 --- a/init/callback-included.lisp +++ b/init/callback-included.lisp @@ -1,29 +1,28 @@ ;; 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))))))) diff --git a/init/callback.lisp b/init/callback.lisp index 9b19955bcbde10ab82d479ffedd178742c86b356..90d740a342d5838339be0698fb19cc9dde978a5f 100644 --- a/init/callback.lisp +++ b/init/callback.lisp @@ -1,6 +1,6 @@ ;; 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." diff --git a/init/defmfun-single.lisp b/init/defmfun-single.lisp index 6f9f8723a55c756c6c97a1c4954769a45bc0588e..cc7c5883914ccc484b65edc174cc8f5499665f47 100644 --- a/init/defmfun-single.lisp +++ b/init/defmfun-single.lisp @@ -1,6 +1,6 @@ ;; 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 diff --git a/init/defmfun.lisp b/init/defmfun.lisp index f27e89f5dd5dedca2d3481ee14631d6071631537..8e64702864e1e4cc4d413460d2fde7817fb8d42f 100644 --- a/init/defmfun.lisp +++ b/init/defmfun.lisp @@ -1,6 +1,6 @@ ;; 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)))) ;;;;**************************************************************************** diff --git a/init/forms.lisp b/init/forms.lisp index 83c4a60c615708d630b139e40d0cf1b5e4d09ed7..ce1c325bdbc362b895a93266b886ca8a57952ce9 100644 --- a/init/forms.lisp +++ b/init/forms.lisp @@ -1,6 +1,6 @@ ;; 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))))) diff --git a/init/mobject.lisp b/init/mobject.lisp index ffdda1197c33e2c1d71650466aa0e1463d9227dd..7386654abe42ae8692a9f1758372f9c26d5ea910 100644 --- a/init/mobject.lisp +++ b/init/mobject.lisp @@ -1,6 +1,6 @@ ;; 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 ;;;;****************************************************************************