Commit 4c0e484c authored by Liam Healy's avatar Liam Healy

Add :callbacks argument to defmobject to create defmcallback forms

New argument :callbacks added to defmobject.  When defined (as
currently defined in chebyshev), the expansion produces a defmcallback
form.  Since the argument :ci-class-slots partially duplicates the
contents of :callbacks, it needs to be fixed.
parent 00d7b1db
;; Chebyshev Approximations ;; Chebyshev Approximations
;; Liam Healy Sat Nov 17 2007 - 20:36 ;; Liam Healy Sat Nov 17 2007 - 20:36
;; Time-stamp: <2009-02-17 22:52:51EST chebyshev.lisp> ;; Time-stamp: <2009-03-09 22:04:31EDT chebyshev.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -18,6 +18,7 @@ ...@@ -18,6 +18,7 @@
"Make a Chebyshev series of specified order." "Make a Chebyshev series of specified order."
:superclasses (callback-included) :superclasses (callback-included)
:ci-class-slots (gsl-function nil (function)) :ci-class-slots (gsl-function nil (function))
:callbacks (callback gsl-function (function))
:initialize-suffix "init" :initialize-suffix "init"
:initialize-args :initialize-args
((callback :pointer) (lower-limit :double) (upper-limit :double)) ((callback :pointer) (lower-limit :double) (upper-limit :double))
......
;; Foreign callback functions. ;; Foreign callback functions.
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2009-03-07 22:59:50EST callback.lisp> ;; Time-stamp: <2009-03-09 22:56:13EDT callback.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -379,6 +379,9 @@ ...@@ -379,6 +379,9 @@
(cons 'list cddr) (cons 'list cddr)
(first cddr))))))) (first cddr)))))))
(defun number-of-callbacks (callbacks)
(length (callback-argument-component callbacks functions)))
;;; (callback-argument-component '(foo bar baz (bof 1 2 2)) callback-structure-type) ;;; (callback-argument-component '(foo bar baz (bof 1 2 2)) callback-structure-type)
;;; (callback-argument-function-component '(foo bar) argument-spec) ;;; (callback-argument-function-component '(foo bar) argument-spec)
...@@ -390,10 +393,11 @@ ...@@ -390,10 +393,11 @@
"Generate the form to set each of the dynamic (special) variables "Generate the form to set each of the dynamic (special) variables
to (function scalarsp dimensions...) in the body of the demfun for to (function scalarsp dimensions...) in the body of the demfun for
each of the callback functions." each of the callback functions."
`((setf (when callbacks
,@(loop for symb in symbols `((setf
for list in callbacks ,@(loop for symb in symbols
append (list symb (cons 'list list)))))) for list in callbacks
append (list symb (cons 'list list)))))))
(defun callback-set-slots (callbacks symbols) (defun callback-set-slots (callbacks symbols)
(when callbacks (when callbacks
...@@ -424,23 +428,26 @@ ...@@ -424,23 +428,26 @@
;;;; Macro defmcallback NEW ;;;; Macro defmcallback NEW
;;;;**************************************************************************** ;;;;****************************************************************************
(defun make-defmcallbacks (callbacks callback-names function-names)
(when callbacks
(mapcar
(lambda (cb vbl fspec) `(defmcallback ,cb ,vbl ,fspec))
callback-names function-names
(callback-argument-component callbacks functions))))
(defmacro defmcallback (name dynamic-variable function-spec) (defmacro defmcallback (name dynamic-variable function-spec)
(let* ((args (callback-args (let* ((arg-component
(remove ; remove unused arguments in list tail
nil
(list
(callback-argument-function-component function-spec argument-spec)
(callback-argument-function-component function-spec set1-spec)
(callback-argument-function-component function-spec set2-spec)))))
(arg-component
(callback-argument-function-component function-spec argument-spec)) (callback-argument-function-component function-spec argument-spec))
(set1-component (set1-component
(callback-argument-function-component function-spec set1-spec)) (callback-argument-function-component function-spec set1-spec))
(set2-component (set2-component
(callback-argument-function-component function-spec set2-spec)) (callback-argument-function-component function-spec set2-spec))
(return-type (return-type
(callback-argument-function-component function-spec return-spec))) (callback-argument-function-component function-spec return-spec))
(print (list arg-component set1-component set2-component)) (args (callback-args
(remove ; remove unused arguments in list tail
nil
(list arg-component set1-component set2-component)))))
(flet ((dimargs (component) (flet ((dimargs (component)
(sublis `((dim0 . (third ,dynamic-variable)) (sublis `((dim0 . (third ,dynamic-variable))
(dim1 . (fourth ,dynamic-variable))) (dim1 . (fourth ,dynamic-variable)))
...@@ -524,3 +531,20 @@ ...@@ -524,3 +531,20 @@
user-fn-return (second arguments) (second dimensions) (second marrays)) user-fn-return (second arguments) (second dimensions) (second marrays))
(first user-fn-return))) (first user-fn-return)))
(apply function arguments))) (apply function arguments)))
;;;;****************************************************************************
;;;; 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
(callback-argument-component callbacks callback-structure-type)
(callback-argument-function-argspec 'array-type))
)
|#
;; Macro for defining GSL functions. ;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2009-03-07 15:52:28EST defmfun.lisp> ;; Time-stamp: <2009-03-09 22:34:54EDT defmfun.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -104,8 +104,7 @@ ...@@ -104,8 +104,7 @@
callback-gensyms callback-gensyms
;; A list of variable names, and a list of callback names ;; A list of variable names, and a list of callback names
(when callbacks (when callbacks
(let ((num-callbacks (let ((num-callbacks (number-of-callbacks callbacks)))
(length (callback-argument-component callbacks functions))))
(list (list
(loop repeat num-callbacks collect (gensym "DYNFN")) (loop repeat num-callbacks collect (gensym "DYNFN"))
(loop repeat num-callbacks collect (gensym "CBFN")))))) (loop repeat num-callbacks collect (gensym "CBFN"))))))
...@@ -141,12 +140,8 @@ ...@@ -141,12 +140,8 @@
(when export `((export ',name)))))))) (when export `((export ',name))))))))
`(progn `(progn
,@(if (symbolp (first expanded-body)) (list expanded-body) expanded-body) ,@(if (symbolp (first expanded-body)) (list expanded-body) expanded-body)
,@(when callbacks ,@(make-defmcallbacks
(mapcar callbacks (second callback-gensyms) (first callback-gensyms))
(lambda (vbl cb fspec) `(defmcallback ,cb ,vbl ,fspec))
(first callback-gensyms)
(second callback-gensyms)
(callback-argument-component callbacks functions)))
,@index-export)))) ,@index-export))))
;;;;**************************************************************************** ;;;;****************************************************************************
......
;; 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-02-24 15:36:40EST mobject.lisp> ;; Time-stamp: <2009-03-09 22:52:54EDT 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
...@@ -26,7 +26,7 @@ ...@@ -26,7 +26,7 @@
&key documentation initialize-suffix initialize-name initialize-args &key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer arglists-function inputs gsl-version allocator allocate-inputs freer
(superclasses '(mobject)) (superclasses '(mobject))
class-slots-instance ci-class-slots singular) class-slots-instance ci-class-slots callbacks 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 ;; Argument 'initialize-suffix: string appended to prefix to form
...@@ -77,6 +77,12 @@ ...@@ -77,6 +77,12 @@
(and callbackp (and callbackp
(not (callback-arg-p class-slots-instance))))) (not (callback-arg-p class-slots-instance)))))
(export '(,maker ,class)) (export '(,maker ,class))
,@(when callbacks
(let ((numcb (number-of-callbacks callbacks)))
(make-defmcallbacks
callbacks
(mobject-cbvnames class numcb)
(mobject-fnvnames class numcb))))
,(mobject-maker ,(mobject-maker
maker arglists initargs class cl-alloc-args cl-initialize-args maker arglists initargs class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp description documentation initialize-args initializerp settingp
...@@ -221,6 +227,29 @@ ...@@ -221,6 +227,29 @@
(list (intern (symbol-name symbol) :keyword) (list (intern (symbol-name symbol) :keyword)
symbol)))) 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 ;;;; 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