Commit 3d57ef40 authored by Liam Healy's avatar Liam Healy

Define functions and macro to help direct use of callbacks in defmfun

As a way of making it easier to use something other than a
gsl-function and with additional slots set, and to make more clear
where specific variable names are treated specially, define and use:
  callback-arg-p
  callback-replace-arg
  callback-remove-arg
  callback-set-slots
Also split off #'set-cbstruct which #'make-cbstruct and
callback-set-slots both use.
parent 575fe965
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2009-01-28 21:05:10EST gsll.asd>
;; Time-stamp: <2009-02-15 17:44:02EST gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -16,6 +16,7 @@
((:file "init")
(:file "conditions" :depends-on (init))
(:file "mobject" :depends-on (init))
(:file "callback" :depends-on (init mobject))
(:file "types" :depends-on (init))
(:file "complex-types" :depends-on (types))
(:file "element-types" :depends-on (init complex-types))
......@@ -24,8 +25,7 @@
:depends-on (init conditions element-types number-conversion))
(:file "defmfun" :depends-on (init element-types interface))
(:file "defmfun-array" :depends-on (defmfun))
(:file "defmfun-single" :depends-on (defmfun mobject))
(:file "callback" :depends-on (init))
(:file "defmfun-single" :depends-on (defmfun mobject callback))
(:file "generate-examples" :depends-on (init))))
(:module floating-point
:depends-on (init)
......
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-02-15 11:23:42EST callback.lisp>
;; Time-stamp: <2009-02-15 18:42:55EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -225,15 +225,19 @@
,name ',structure ',(first slot) ,(second slot)))
,name)))
(defun set-cbstruct (cbstruct struct slots-values function-slotnames)
"Make the slots in the foreign callback structure."
(loop for (slot-name function) on function-slotnames by #'cddr
do (set-slot-function cbstruct struct slot-name function))
(set-parameters cbstruct struct)
(when slots-values
(loop for (slot-name value) on slots-values by #'cddr
do (set-structure-slot cbstruct struct slot-name value))))
(defun make-cbstruct (struct slots-values &rest function-slotnames)
"Make the callback structure."
(let ((cbstruct (cffi:foreign-alloc struct)))
(loop for (slot-name function) on function-slotnames by #'cddr
do (set-slot-function cbstruct struct slot-name function))
(set-parameters cbstruct struct)
(when slots-values
(loop for (slot-name value) on slots-values by #'cddr
do (set-structure-slot cbstruct struct slot-name value)))
(set-cbstruct cbstruct struct slots-values function-slotnames)
cbstruct))
(defun make-cbstruct-object (object)
......@@ -385,3 +389,26 @@
(princ "," stream))
(princ "dimensions " stream)
(princ (dimensions object) stream)))
;;;;****************************************************************************
;;;; Using callback specification in function arugments
;;;;****************************************************************************
(defun callback-arg-p (arglist &optional key)
(member +callback-argument-name+ arglist :key key))
(defun callback-replace-arg (replacement list)
(subst replacement +callback-argument-name+ list))
(defun callback-remove-arg (list &optional key)
(remove +callback-argument-name+ list :key key))
(defmacro callback-set-slots
(trigger-list struct-name function &optional dimension)
"If the callback argument is on trigger-list, then return a form
that sets the slots in the GSL callback structure."
`(when (callback-arg-p ,trigger-list)
`(set-cbstruct ,',+callback-argument-name+ ',',struct-name
,',(when dimension `('dimension ,dimension))
(list 'function ,',function))))
;; Helpers that define a single GSL function interface
;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp
;; Time-stamp: <2009-02-15 14:17:36EST defmfun-single.lisp>
;; Time-stamp: <2009-02-15 17:41:07EST defmfun-single.lisp>
;; $Id: $
(in-package :gsl)
......@@ -100,8 +100,8 @@
(cons
'values
(append before after
(when (member +callback-argument-name+
(variables-used-in-c-arguments c-arguments))
(when (callback-arg-p
(variables-used-in-c-arguments c-arguments))
'(function)) ; hardwired name to use for callback
(let ((auxstart (position '&aux arglist)))
;; &aux bindings are checked
......@@ -168,8 +168,7 @@
(clret (or ; better as a symbol macro
(substitute cret-name :c-return return)
(mapcan #'cl-convert-form
(remove +callback-argument-name+
allocated-decl :key 'st-symbol))
(callback-remove-arg allocated-decl 'st-symbol))
outputs
(unless (eq c-return :void)
(list cret-name)))))
......@@ -180,12 +179,7 @@
(mapcar #'wfo-declare allocated-decl)
'cffi:with-foreign-objects
`(,@before
,@(when (member +callback-argument-name+ allocated)
`((set-parameters
,+callback-argument-name+ 'gsl-function)
(set-slot-function
,+callback-argument-name+
'gsl-function 'function function)))
,(callback-set-slots allocated gsl-function function)
(let ((,cret-name
(cffi:foreign-funcall
,gsl-name
......
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-02-15 09:52:41EST mobject.lisp>
;; Time-stamp: <2009-02-15 17:06:23EST mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -41,8 +41,8 @@
(maker (intern (format nil "MAKE-~:@(~a~)" class) :gsl))
(cl-alloc-args (variables-used-in-c-arguments allocation-args))
(cl-initialize-args
(subst 'functions +callback-argument-name+
(variables-used-in-c-arguments initialize-args)))
(callback-replace-arg
'functions (variables-used-in-c-arguments initialize-args)))
(initializerp (or initialize-name initialize-suffix))
(initargs ; arguments that are exclusively for reinitialize-instance
(remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
......@@ -53,7 +53,7 @@
'def-ci-subclass 'def-ci-subclass-1d)
,class
,superclasses
,(format nil "The GSL representation of the ~a." description)
,(format nil "The GSL representation of the ~a." description)
,@ci-class-slots)
`(defclass ,class ,superclasses
nil
......@@ -75,8 +75,7 @@
class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs
(and callbackp
(not (member +callback-argument-name+
class-slots-instance)))))
(not (callback-arg-p class-slots-instance)))))
(export ',maker)
,(mobject-maker
maker arglists initargs class cl-alloc-args cl-initialize-args
......@@ -126,9 +125,7 @@
(first initialize-suffix)
initialize-suffix)))
(((mpointer object) :pointer)
,@(if callback
(subst cbstruct +callback-argument-name+ initialize-args)
initialize-args))
,@(callback-replace-arg cbstruct initialize-args))
:definition :method
:qualifier :after
,@(when (and initialize-suffix (listp initialize-suffix))
......@@ -155,7 +152,7 @@
(singularize
singular
`(,@cl-alloc-args
,@(subst 'functions +callback-argument-name+ class-slots-instance)
,@(callback-replace-arg 'functions class-slots-instance)
,@(when initargs
(append
(list
......@@ -167,15 +164,14 @@
(let ((object
(make-instance
',class
,@(symbol-keyword-symbol
(remove +callback-argument-name+ class-slots-instance))
,@(when (member +callback-argument-name+ class-slots-instance)
,@(symbol-keyword-symbol (callback-remove-arg class-slots-instance))
,@(when (callback-arg-p class-slots-instance)
(symbol-keyword-symbol 'functions))
,@(if arglists
(second arglists)
(symbol-keyword-symbol cl-alloc-args singular)))))
;; There is callback slot variable
,@(when (member +callback-argument-name+ class-slots-instance)
,@(when (callback-arg-p class-slots-instance)
(with-unique-names (cbs)
`((let ((,cbs (make-cbstruct-object object)))
(setf (slot-value object '#.+callback-argument-name+) ,cbs)
......
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