Commit 43b04588 authored by Liam Healy's avatar Liam Healy

Use (parse-callback-static callbacks 'foreign-argument)

Use (parse-callback-static callbacks 'foreign-argument) instead of the
fixed symbol +callback-argument-name+, which has been removed.
New definition for tests for numerical-differentiation and
numerical-integration using CL function names directly.  Callback
tests ported so far pass.
NUMERICAL-INTEGRATION: 3 assertions passed, 0 failed.
NUMERICAL-DIFFERENTIATION: 18 assertions passed, 0 failed.
MONTE-CARLO: 3 assertions passed, 0 failed.
ROOTS-ONE: 6 assertions passed, 0 failed.
MINIMIZATION-ONE: 2 assertions passed, 0 failed.
ROOTS-MULTI: 8 assertions passed, 0 failed.
parent c2f0f2b8
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-03-16 21:45:06EDT callback.lisp>
;; Time-stamp: <2009-03-21 16:25:25EDT callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -63,14 +63,14 @@
;;;; Definitions for making cbstruct
;;;;****************************************************************************
(defun set-cbstruct (cbstruct struct slots-values function-slotnames)
(defun set-cbstruct (cbstruct structure-name 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)
do (set-slot-function cbstruct structure-name slot-name function))
(set-parameters cbstruct structure-name)
(when slots-values
(loop for (slot-name value) on slots-values by #'cddr
do (set-structure-slot cbstruct struct slot-name value))))
do (set-structure-slot cbstruct structure-name slot-name value))))
(defun make-cbstruct (struct slots-values &rest function-slotnames)
"Make the callback structure."
......@@ -120,22 +120,6 @@
(princ "dimensions " stream)
(princ (dimensions object) stream)))
;;;;****************************************************************************
;;;; TO BE OBSOLETE Using callback specification in function arugments
;;;;****************************************************************************
;;; to be obsolete?
(defun callback-arg-p (arglist &optional key)
(member +callback-argument-name+ arglist :key key))
;;; to be obsolete?
(defun callback-replace-arg (replacement list)
(subst replacement +callback-argument-name+ list))
;;; to be obsolete?
(defun callback-remove-arg (list &optional key)
(remove +callback-argument-name+ list :key key))
;;;;****************************************************************************
;;;; Parsing :callback argument specification
;;;;****************************************************************************
......@@ -220,6 +204,26 @@ FUNCTION
(DIM0)
|#
;;;;****************************************************************************
;;;; Using callback specification in function arugments
;;;;****************************************************************************
(defun callback-arg-p (arglist callbacks &optional key)
(member (parse-callback-static callbacks 'foreign-argument) arglist :key key))
(defun callback-replace-arg (replacement list callbacks)
"Replace in the list the symbol representing the foreign callback argument."
(if callbacks
(subst
replacement
(parse-callback-static callbacks 'foreign-argument)
list)
list))
(defun callback-remove-arg (list callbacks &optional key)
"Remove from the list the symbol representing the foreign callback argument."
(remove (parse-callback-static callbacks 'foreign-argument) list :key key))
;;;;****************************************************************************
;;;; Form generation
;;;;****************************************************************************
......
;; Helpers that define a single GSL function interface
;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp
;; Time-stamp: <2009-03-14 21:52:22EDT defmfun-single.lisp>
;; Time-stamp: <2009-03-21 16:44:34EDT defmfun-single.lisp>
;; $Id: $
(in-package :gsl)
......@@ -170,8 +170,9 @@
(first (cl-convert-form it))
sym)))
return))
(mapcan #'cl-convert-form
(callback-remove-arg allocated-decl 'st-symbol))
(mapcan
#'cl-convert-form
(callback-remove-arg allocated-decl callbacks 'st-symbol))
outputs
(unless (eq c-return :void)
(list cret-name)))))
......@@ -179,7 +180,8 @@
'(error 'pass-complex-by-value) ; arglist should be declared ignore
(wrap-letlike
allocated-decl
(mapcar #'wfo-declare allocated-decl)
(mapcar (lambda (d) (wfo-declare d callbacks))
allocated-decl)
'cffi:with-foreign-objects
`(,@(append
(callback-symbol-set
......
;; Macros to interface GSL functions, including definitions necessary for defmfun.
;; Liam Healy
;; Time-stamp: <2009-02-28 14:51:00EST interface.lisp>
;; Time-stamp: <2009-03-21 16:43:54EDT interface.lisp>
;; $Id$
(in-package :gsl)
......@@ -59,11 +59,12 @@
(defun st-pointer-last-p (decl)
(third (st-type decl)))
(defun wfo-declare (d)
(defun wfo-declare (d callbacks)
`(,(st-symbol d)
,@(if (st-arrayp d)
`(',(st-eltype d) ,(st-dim d))
(if (eq (st-symbol d) +callback-argument-name+)
(if (eq (st-symbol d)
(parse-callback-static callbacks 'foreign-argument))
'('gsl-function)
`(',(st-type d))))))
......
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-03-21 11:16:09EDT mobject.lisp>
;; Time-stamp: <2009-03-21 16:45:10EDT mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -19,8 +19,6 @@
((mpointer :initarg :mpointer :reader mpointer
:documentation "A pointer to the GSL representation of the object.")))
(defconstant +callback-argument-name+ 'callback)
;;; Required arguments for defmobject:
;;; class Name of class being made.
;;; prefix String that starts each GSL function name
......@@ -74,7 +72,9 @@
(cl-alloc-args (variables-used-in-c-arguments allocation-args))
(cl-initialize-args
(callback-replace-arg
'functions (variables-used-in-c-arguments initialize-args)))
'functions
(variables-used-in-c-arguments initialize-args)
callbacks))
(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)))
......@@ -108,8 +108,8 @@
(make-reinitialize-instance
class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs
(and callbacks
(not (callback-arg-p class-slots-instance)))))
(and (not (callback-arg-p class-slots-instance callbacks))
callbacks)))
(export '(,maker ,class))
,@(when callbacks `((record-callbacks-for-class ',class ',callbacks)))
,@(when callbacks (make-mobject-defmcallbacks callbacks class))
......@@ -145,15 +145,14 @@
(defun make-reinitialize-instance
(class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs
callback)
"Expand the reinitialize-instance form. In the GSL arglist, the callback
structure pointer should be named the value of +callback-argument-name+."
callbacks)
"Expand the reinitialize-instance form."
(let ((cbstruct (make-symbol "CBSTRUCT")))
`((defmfun reinitialize-instance
((object ,class)
&key
,@cl-initialize-args
,@(when callback
,@(when callbacks
`(&aux (,cbstruct ,(make-cbstruct-object class)))))
,(or initialize-name
(format nil "~a_~a" prefix
......@@ -161,15 +160,15 @@
(first initialize-suffix)
initialize-suffix)))
(((mpointer object) :pointer)
,@(callback-replace-arg cbstruct initialize-args))
,@(callback-replace-arg cbstruct initialize-args callbacks))
:definition :method
,@(when callback '(:callback-object object))
,@(when callbacks '(:callback-object object))
:qualifier :after
,@(when (and initialize-suffix (listp initialize-suffix))
`(:c-return ,(second initialize-suffix)))
:return (object)
,@(when inputs `(:inputs ,inputs))
,@(when callback
,@(when callbacks
`(:after
((trivial-garbage:finalize
object
......@@ -183,13 +182,15 @@
description documentation initialize-args initializerp settingp
singular class-slots-instance callbacks)
"Make the defun form that makes the mobject."
(when callbacks (setf initargs (append initargs '((scalarsp t)))))
`(defun ,maker
,(if arglists
(first arglists)
(singularize
singular
`(,@cl-alloc-args
,@(callback-replace-arg 'functions class-slots-instance)
,@(callback-replace-arg
'functions class-slots-instance callbacks)
,@(when initargs
(append
(list
......@@ -203,17 +204,21 @@
',class
,@(when
callbacks `(:callbacks ',callbacks))
,@(symbol-keyword-symbol (callback-remove-arg class-slots-instance))
,@(when (callback-arg-p class-slots-instance)
,@(symbol-keyword-symbol
(callback-remove-arg class-slots-instance callbacks))
,@(when (callback-arg-p class-slots-instance callbacks)
(symbol-keyword-symbol 'functions))
,@(if arglists
(second arglists)
(symbol-keyword-symbol cl-alloc-args singular)))))
;; There is callback slot variable
,@(when (callback-arg-p class-slots-instance)
,@(when (callback-arg-p class-slots-instance callbacks)
(with-unique-names (cbs)
`((let ((,cbs (make-cbstruct-object object)))
(setf (slot-value object ',+callback-argument-name+) ,cbs)
(setf (slot-value
object
',(parse-callback-static callbacks 'foreign-argument))
,cbs)
(tg:finalize object (lambda () (foreign-free ,cbs)))))))
;; There is an initialization step
,@(when initializerp
......
;;; Multivariate roots.
;;; Liam Healy 2008-01-12 12:49:08
;;; Time-stamp: <2009-03-21 11:16:27EDT roots-multi.lisp>
;;; Time-stamp: <2009-03-21 13:56:37EDT roots-multi.lisp>
;;; $Id$
(in-package :gsl)
......@@ -52,7 +52,6 @@
be supplied, and should return scalars."
:initialize-suffix "set"
:initialize-args ((callback :pointer) ((mpointer initial) :pointer))
;;:ci-class-slots (gsl-mfunction-fdf marray (function df fdf))
:callbacks
(callback gsl-mfunction-fdf
(function :success-failure
......
......@@ -6,15 +6,15 @@
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST 2.718281828441488d0 4.123659913167868d-10)
(MULTIPLE-VALUE-LIST
(CENTRAL-DERIVATIVE 'DERIV-F1 1.0d0 1.d-4)))
(CENTRAL-DERIVATIVE 'exp 1.0d0 1.d-4)))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST 2.7182817825298398d0 9.540320743340577d-7)
(MULTIPLE-VALUE-LIST
(FORWARD-DERIVATIVE 'DERIV-F1 1.0d0 1.d-4)))
(FORWARD-DERIVATIVE 'exp 1.0d0 1.d-4)))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST 2.7182818293827378d0 9.086969640080628d-7)
(MULTIPLE-VALUE-LIST
(BACKWARD-DERIVATIVE 'DERIV-F1 1.0d0 1.d-4)))
(BACKWARD-DERIVATIVE 'exp 1.0d0 1.d-4)))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST 0.474341649024533d0 3.3922603135575853d-11)
(MULTIPLE-VALUE-LIST
......@@ -66,13 +66,13 @@
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST -0.009999999999871223d0 2.6645352591887814d-12)
(MULTIPLE-VALUE-LIST
(CENTRAL-DERIVATIVE 'DERIV-F6 10.0d0 1.d-4)))
(CENTRAL-DERIVATIVE '/ 10.0d0 1.d-4)))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST -0.010000000266238856d0 4.9950606958271945d-9)
(MULTIPLE-VALUE-LIST
(FORWARD-DERIVATIVE 'DERIV-F6 10.0d0 1.d-4)))
(FORWARD-DERIVATIVE '/ 10.0d0 1.d-4)))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST -0.010000000076196142d0 4.641550044799095d-9)
(MULTIPLE-VALUE-LIST
(BACKWARD-DERIVATIVE 'DERIV-F6 10.0d0 1.d-4))))
(BACKWARD-DERIVATIVE '/ 10.0d0 1.d-4))))
......@@ -6,13 +6,13 @@
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST 2.0d0 2.220446049250313d-14 21)
(MULTIPLE-VALUE-LIST
(INTEGRATION-QNG 'ONE-SINE 0.0d0 PI)))
(INTEGRATION-QNG 'SIN 0.0d0 PI)))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST 2.0d0 2.220446049250313d-14)
(MULTIPLE-VALUE-LIST
(INTEGRATION-QAG 'ONE-SINE 0.0d0 PI :GAUSS15 20)))
(INTEGRATION-QAG 'SIN 0.0d0 PI :GAUSS15 20)))
(LISP-UNIT::ASSERT-NUMERICAL-EQUAL
(LIST 2.0d0 2.220446049250313d-14)
(MULTIPLE-VALUE-LIST
(INTEGRATION-QAG 'ONE-SINE 0.0d0 PI :GAUSS21 40))))
(INTEGRATION-QAG 'SIN 0.0d0 PI :GAUSS21 40))))
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