Commit 3987beef authored by Liam Healy's avatar Liam Healy

Internal variable rename 'cbinfo

Internally call the :callbacks argument to defmobject or defmfun
'cbinfo, to better distinguish it in the source code.  In numerical
integration example functions, apply #'realpart, because
implementations are permitted to return complex numbers from #'expt
when the second argument is a float.
parent 2217c408
;; Numerical integration
;; Liam Healy, Wed Jul 5 2006 - 23:14
;; Time-stamp: <2009-04-04 19:35:50EDT numerical-integration.lisp>
;; Time-stamp: <2009-04-04 21:30:01EDT numerical-integration.lisp>
;; $Id$
(in-package :gsl)
......@@ -266,15 +266,6 @@
;;;; Examples and unit test
;;; CCL 1.2 returns a complex number when the exponent is a double
;;; float even if it's positive whole number value. This is a
;;; workaround.
(defun nn-expt (base power)
(if (= power (floor power))
(expt base (floor power))
(expt base power)))
(defun integration-test-f1 (alpha)
(lambda (x) (* (expt x alpha) (log (/ x)))))
......@@ -282,7 +273,7 @@
(lambda (x) (cos (* (expt 2 alpha) (sin x)))))
(defun integration-test-f11 (alpha)
(lambda (x) (#+ccl nn-expt #-ccl expt (log (/ x)) (1- alpha))))
(lambda (x) (realpart (expt (log (/ x)) (1- alpha)))))
(defun integration-test-f15 (alpha)
(lambda (x) (* x x (exp (* (- (expt 2 (- alpha))) x)))))
......@@ -292,8 +283,9 @@
((and (= alpha 1.0d0) (zerop x)) 1.0d0)
((and (> alpha 1.0d0) (zerop x)) 0.0d0)
(t (/ (#+ccl nn-expt #-ccl expt x (1- alpha))
(expt (1+ (* 10 x)) 2))))))
(t (realpart
(/ (expt x (1- alpha))
(expt (1+ (* 10 x)) 2)))))))
(defun integration-test-f454 (x)
(* (expt x 3) (* (log (abs (* (- (expt x 2) 1.0d0) (- (expt x 2) 2.0d0)))))))
;; Definitions for macro expansion
;; Liam Healy 2009-03-15 14:50:28EDT callback-compile-defs.lisp
;; Time-stamp: <2009-04-01 21:36:12EDT callback-compile-defs.lisp>
;; Time-stamp: <2009-04-04 21:40:57EDT callback-compile-defs.lisp>
;; $Id: $
(in-package :gsl)
......@@ -12,8 +12,8 @@
(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 record-callbacks-for-class (class cbinfo)
(setf (gethash class *callbacks-for-classes*) cbinfo))
(defun get-callbacks-for-class (class)
(gethash class *callbacks-for-classes*))
......@@ -41,12 +41,12 @@
;;; These functions make interned symbols that will be bound to
;;; dynamic variables.
(defun make-mobject-defmcallbacks (callbacks class)
(defun make-mobject-defmcallbacks (cbinfo class)
"Make the defmcallback forms needed to define the callbacks
associated with mobject that includes callback functions."
(let ((numcb (number-of-callbacks callbacks)))
(let ((numcb (number-of-callbacks cbinfo)))
(mobject-cbvnames class numcb)
(mobject-fnvnames class numcb))))
;; The mobject that defines callbacks
;; Liam Healy 2009-03-14 11:20:03EDT callback-included.lisp
;; Time-stamp: <2009-03-31 22:33:09EDT callback-included.lisp>
;; Time-stamp: <2009-04-04 21:45:12EDT callback-included.lisp>
;; $Id: $
(in-package :gsl)
......@@ -10,8 +10,8 @@
(defclass callback-included (mobject)
:initarg :callbacks :reader callbacks
:initarg :cbinfo :reader cbinfo
:documentation "The specification form for static callback information.")
:initarg :dimension-names :reader dimension-names
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-04-04 09:55:41EDT callback.lisp>
;; Time-stamp: <2009-04-04 21:58:32EDT callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -87,24 +87,25 @@
;;;; Parsing :callback argument specification
;;; The :callbacks argument is a list of the form:
;;; The :callbacks (cbinfo) argument is a list of the form:
;;; (foreign-argument callback-structure-type dimension-names function ...)
;;; where each function is of the form
;;; (structure-slot-name
;;; &optional (return-spec 'double-float) (argument-spec 'double-float)
;;; set1-spec set2-spec)
;;; and each of the *-spec are (type array-type &rest dimensions).
;;; When assigned to a variable, the variable is named 'cbinfo.
(defun parse-callback-static (callbacks component)
(defun parse-callback-static (cbinfo component)
"Get the information component from the callbacks list."
(case component
(foreign-argument (first callbacks))
(callback-structure-type (second callbacks))
(dimension-names (third callbacks))
(functions (nthcdr 3 callbacks))))
(foreign-argument (first cbinfo))
(callback-structure-type (second cbinfo))
(dimension-names (third cbinfo))
(functions (nthcdr 3 cbinfo))))
(defun number-of-callbacks (callbacks)
(length (parse-callback-static callbacks 'functions)))
(defun number-of-callbacks (cbinfo)
(length (parse-callback-static cbinfo 'functions)))
(defun parse-callback-fnspec (fnspec component)
"From the :callbacks argument, parse a single function specification."
......@@ -126,18 +127,18 @@
;;;; Using callback specification in function arugments
(defun callback-replace-arg (replacement list callbacks)
(defun callback-replace-arg (replacement list cbinfo)
"Replace in the list the symbol representing the foreign callback argument."
(if callbacks
(if cbinfo
(parse-callback-static callbacks 'foreign-argument)
(parse-callback-static cbinfo 'foreign-argument)
(defun callback-remove-arg (list callbacks &optional key)
(defun callback-remove-arg (list cbinfo &optional key)
"Remove from the list the symbol representing the foreign callback argument."
(remove (parse-callback-static callbacks 'foreign-argument) list :key key))
(remove (parse-callback-static cbinfo 'foreign-argument) list :key key))
;;;; Form generation
......@@ -158,15 +159,15 @@
(defun cbd-functions (callback-dynamic)
(rest callback-dynamic))
(defun callback-symbol-set (callback-dynamic callbacks symbols)
(defun callback-symbol-set (callback-dynamic cbinfo symbols)
"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."
(when callbacks
(when cbinfo
,@(loop for symb in symbols
for function in (cbd-functions callback-dynamic)
for fnspec in (parse-callback-static callbacks 'functions)
for fnspec in (parse-callback-static cbinfo 'functions)
......@@ -175,22 +176,22 @@
,(second function)
,(cons 'list (cbd-dimensions callback-dynamic)))))))))
(defun callback-set-slots (callbacks dynamic-variables callback-dynamic)
(defun callback-set-slots (cbinfo dynamic-variables callback-dynamic)
"Set the slots in the foreign callback struct."
(when callbacks
(when cbinfo
,(parse-callback-static callbacks 'foreign-argument)
',(parse-callback-static callbacks 'callback-structure-type)
,(when (parse-callback-static callbacks 'dimension-names)
,(parse-callback-static cbinfo 'foreign-argument)
',(parse-callback-static cbinfo 'callback-structure-type)
,(when (parse-callback-static cbinfo 'dimension-names)
(cons 'list
for dim-name in (parse-callback-static callbacks 'dimension-names)
for dim-name in (parse-callback-static cbinfo 'dimension-names)
for dim in (cbd-dimensions callback-dynamic)
append (list `',dim-name dim))))
(loop for symb in (second dynamic-variables)
for fn in (parse-callback-static callbacks 'functions)
for fn in (parse-callback-static cbinfo 'functions)
`(',(parse-callback-fnspec fn 'structure-slot-name)
......@@ -211,12 +212,12 @@
;;;; Macro defmcallback
(defun make-defmcallbacks (callbacks callback-names function-names)
(when callbacks
(defun make-defmcallbacks (cbinfo callback-names function-names)
(when cbinfo
(lambda (cb vbl fspec) `(defmcallback ,cb ,vbl ,fspec))
callback-names function-names
(parse-callback-static callbacks 'functions))))
(parse-callback-static cbinfo 'functions))))
(defmacro defmcallback (name dynamic-variable function-spec)
(let* ((argspec (parse-callback-fnspec function-spec 'arguments-spec))
;; Helpers that define a single GSL function interface
;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp
;; Time-stamp: <2009-04-04 18:47:47EDT defmfun-single.lisp>
;; Time-stamp: <2009-04-04 21:56:30EDT defmfun-single.lisp>
;; $Id: $
(in-package :gsl)
......@@ -98,7 +98,7 @@
(append before after
callback-dynamic callbacks (first callback-dynamic-variables))
callback-dynamic cbinfo (first callback-dynamic-variables))
;; &optional/&key/&aux defaults are checked
(let ((auxstart (after-llk arglist)))
(when auxstart
......@@ -173,7 +173,7 @@
(callback-remove-arg allocated-decl callbacks 'st-symbol))
(callback-remove-arg allocated-decl cbinfo 'st-symbol))
(unless (eq c-return :void)
(list cret-name)))))
......@@ -181,16 +181,16 @@
'(error 'pass-complex-by-value) ; arglist should be declared ignore
(mapcar (lambda (d) (wfo-declare d callbacks))
(mapcar (lambda (d) (wfo-declare d cbinfo))
callback-dynamic callbacks (first callback-dynamic-variables))
callback-dynamic cbinfo (first callback-dynamic-variables))
(when callback-object (callback-set-dynamic callback-object arglist)))
callbacks callback-dynamic-variables callback-dynamic)
cbinfo callback-dynamic-variables callback-dynamic)
(let ((,cret-name
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2009-04-02 22:48:34EDT defmfun.lisp>
;; Time-stamp: <2009-04-04 22:00:20EDT defmfun.lisp>
;; $Id$
(in-package :gsl)
......@@ -78,12 +78,12 @@
(definition :function)
(export (not (member definition (list :method :methods))))
documentation inputs outputs before after enumeration qualifier
gsl-version switch callbacks callback-dynamic callback-object)
gsl-version switch ((:callbacks cbinfo)) callback-dynamic callback-object)
(declare (ignorable c-return return definition element-types
index export documentation inputs outputs
before after enumeration qualifier
gsl-version switch callbacks callback-dynamic callback-object)
gsl-version switch cbinfo callback-dynamic callback-object)
(special indexed-functions callback-dynamic-variables))
......@@ -104,7 +104,7 @@
(setf indexed-functions (list)
;; A list of variable names, and a list of callback names
(when (or callbacks callback-object)
(when (or cbinfo callback-object)
(if callback-object
(let ((class
(if (listp callback-object)
......@@ -114,7 +114,7 @@
(number-of-callbacks (get-callbacks-for-class class)))
(let ((num-callbacks (number-of-callbacks callbacks)))
(let ((num-callbacks (number-of-callbacks cbinfo)))
(list name 'dynfn) num-callbacks :gsl)
......@@ -153,7 +153,7 @@
,@(if (symbolp (first expanded-body)) (list expanded-body) expanded-body)
(second callback-dynamic-variables)
(first callback-dynamic-variables))
;; Generate a lambda that calls the user function; will be called by callback.
;; Liam Healy
;; Time-stamp: <2009-04-02 22:34:03EDT funcallable.lisp>
;; Time-stamp: <2009-04-04 21:45:11EDT funcallable.lisp>
;; $Id$
(in-package :gsl)
......@@ -183,7 +183,7 @@
(make-funcallable-form fn fnspec (scalarsp object) (dimensions object))))
(functions object)
(parse-callback-static (callbacks object) 'functions))))
(parse-callback-static (cbinfo object) 'functions))))
(defun make-compiled-funcallable (function fnspec scalarsp dimensions)
(compile nil (make-funcallable-form function fnspec scalarsp dimensions)))
;; Macros to interface GSL functions, including definitions necessary for defmfun.
;; Liam Healy
;; Time-stamp: <2009-04-04 12:02:28EDT interface.lisp>
;; Time-stamp: <2009-04-04 21:42:32EDT interface.lisp>
;; $Id$
(in-package :gsl)
......@@ -59,13 +59,13 @@
(defun st-pointer-last-p (decl)
(third (st-type decl)))
(defun wfo-declare (d callbacks)
(defun wfo-declare (d cbinfo)
`(,(st-symbol d)
,@(if (st-arrayp d)
`(',(st-eltype d) ,(st-dim d))
(if (eq (st-symbol d)
(parse-callback-static callbacks 'foreign-argument))
`(',(parse-callback-static callbacks 'callback-structure-type))
(parse-callback-static cbinfo 'foreign-argument))
`(',(parse-callback-static cbinfo 'callback-structure-type))
`(',(st-type d))))))
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-04-04 09:51:08EDT mobject.lisp>
;; Time-stamp: <2009-04-04 22:00:21EDT mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -57,8 +57,8 @@
(class prefix allocation-args description
&key documentation initialize-suffix initialize-name initialize-args
arglists-function inputs gsl-version allocator allocate-inputs freer
(superclasses (if callbacks '(callback-included) '(mobject)))
((:callbacks cbinfo))
(superclasses (if cbinfo '(callback-included) '(mobject)))
"Define the class, the allocate, initialize-instance and
reinitialize-instance methods, and the make-* function for the GSL object."
......@@ -72,19 +72,19 @@
(variables-used-in-c-arguments initialize-args)
(initializerp (or initialize-name initialize-suffix)))
;; Need callback information for macroexpansion make-cbstruct-object
(when callbacks (record-callbacks-for-class class callbacks))
(when cbinfo (record-callbacks-for-class class cbinfo))
(if (have-at-least-gsl-version gsl-version)
,(if callbacks
,(if cbinfo
`(,(if (member 'dimensions cl-alloc-args)
'def-ci-subclass 'def-ci-subclass-1d)
,(format nil "The GSL representation of the ~a." description)
,(parse-callback-static callbacks 'dimension-names))
,(parse-callback-static cbinfo 'dimension-names))
`(defclass ,class ,superclasses
......@@ -104,15 +104,15 @@
class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs
(export '(,maker ,class))
,@(when callbacks `((record-callbacks-for-class ',class ',callbacks)))
,@(when callbacks (make-mobject-defmcallbacks callbacks class))
,@(when cbinfo `((record-callbacks-for-class ',class ',cbinfo)))
,@(when cbinfo (make-mobject-defmcallbacks cbinfo class))
maker arglists class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp
singular callbacks))
singular cbinfo))
(export ',maker)
(defun ,maker (&rest args)
......@@ -141,14 +141,14 @@
(defun make-reinitialize-instance
(class cl-initialize-args initialize-name prefix
initialize-suffix initialize-args inputs
callbacks superclasses)
cbinfo superclasses)
"Expand the reinitialize-instance form."
(let ((cbstruct (make-symbol "CBSTRUCT")))
`((defmfun reinitialize-instance
((object ,class)
,@(when callbacks
,@(when cbinfo
`(&aux (,cbstruct ,(make-cbstruct-object class)))))
,(or initialize-name
(format nil "~a_~a" prefix
......@@ -156,15 +156,15 @@
(first initialize-suffix)
(((mpointer object) :pointer)
,@(callback-replace-arg cbstruct initialize-args callbacks))
,@(callback-replace-arg cbstruct initialize-args cbinfo))
:definition :method
,@(when callbacks '(:callback-object object))
,@(when cbinfo '(:callback-object object))
:qualifier :after
,@(when (and initialize-suffix (listp initialize-suffix))
`(:c-return ,(second initialize-suffix)))
:return (object)
,@(when inputs `(:inputs ,inputs))
,@(when callbacks
,@(when cbinfo
(,@(when (member 'callback-included-cl superclasses)
`((setf (slot-value object 'callback) ,cbstruct)))
......@@ -180,9 +180,9 @@
(defun mobject-maker
(maker arglists class cl-alloc-args cl-initialize-args
description documentation initialize-args initializerp settingp
singular callbacks)
singular cbinfo)
"Make the defun form that makes the mobject."
(when callbacks
(when cbinfo
(setf cl-initialize-args (append cl-initialize-args '((scalarsp t)))))
(let ((initargs ; arguments that are exclusively for reinitialize-instance
(remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
......@@ -206,7 +206,7 @@
(let ((object
,@(when callbacks `(:callbacks ',callbacks))
,@(when cbinfo `(:cbinfo ',cbinfo))
,@(if arglists
(second arglists)
(symbol-keyword-symbol cl-alloc-args singular)))))
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