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
;; 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$
(in-package :gsl)
......@@ -18,6 +18,7 @@
"Make a Chebyshev series of specified order."
:superclasses (callback-included)
:ci-class-slots (gsl-function nil (function))
:callbacks (callback gsl-function (function))
:initialize-suffix "init"
:initialize-args
((callback :pointer) (lower-limit :double) (upper-limit :double))
......
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-03-07 22:59:50EST callback.lisp>
;; Time-stamp: <2009-03-09 22:56:13EDT callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -379,6 +379,9 @@
(cons 'list 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-function-component '(foo bar) argument-spec)
......@@ -390,10 +393,11 @@
"Generate the form to set each of the dynamic (special) variables
to (function scalarsp dimensions...) in the body of the demfun for
each of the callback functions."
`((setf
,@(loop for symb in symbols
for list in callbacks
append (list symb (cons 'list list))))))
(when callbacks
`((setf
,@(loop for symb in symbols
for list in callbacks
append (list symb (cons 'list list)))))))
(defun callback-set-slots (callbacks symbols)
(when callbacks
......@@ -424,23 +428,26 @@
;;;; 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)
(let* ((args (callback-args
(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
(let* ((arg-component
(callback-argument-function-component function-spec argument-spec))
(set1-component
(callback-argument-function-component function-spec set1-spec))
(set2-component
(callback-argument-function-component function-spec set2-spec))
(return-type
(callback-argument-function-component function-spec return-spec)))
(print (list arg-component set1-component set2-component))
(callback-argument-function-component function-spec return-spec))
(args (callback-args
(remove ; remove unused arguments in list tail
nil
(list arg-component set1-component set2-component)))))
(flet ((dimargs (component)
(sublis `((dim0 . (third ,dynamic-variable))
(dim1 . (fourth ,dynamic-variable)))
......@@ -524,3 +531,20 @@
user-fn-return (second arguments) (second dimensions) (second marrays))
(first user-fn-return)))
(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.
;; 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$
(in-package :gsl)
......@@ -104,8 +104,7 @@
callback-gensyms
;; A list of variable names, and a list of callback names
(when callbacks
(let ((num-callbacks
(length (callback-argument-component callbacks functions))))
(let ((num-callbacks (number-of-callbacks callbacks)))
(list
(loop repeat num-callbacks collect (gensym "DYNFN"))
(loop repeat num-callbacks collect (gensym "CBFN"))))))
......@@ -141,12 +140,8 @@
(when export `((export ',name))))))))
`(progn
,@(if (symbolp (first expanded-body)) (list expanded-body) expanded-body)
,@(when callbacks
(mapcar
(lambda (vbl cb fspec) `(defmcallback ,cb ,vbl ,fspec))
(first callback-gensyms)
(second callback-gensyms)
(callback-argument-component callbacks functions)))
,@(make-defmcallbacks
callbacks (second callback-gensyms) (first callback-gensyms))
,@index-export))))
;;;;****************************************************************************
......
;; Definition of GSL objects and ways to use them.
;; 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.
;;; The macro demobject takes care of defining the appropriate
......@@ -26,7 +26,7 @@
&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 singular)
class-slots-instance ci-class-slots callbacks 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
......@@ -77,6 +77,12 @@
(and callbackp
(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))))
,(mobject-maker
maker arglists initargs class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp
......@@ -221,6 +227,29 @@
(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