mobject.lisp 12.3 KB
Newer Older
1 2
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec  3 2006 - 10:21
3
;; Time-stamp: <2011-01-10 18:19:11EST mobject.lisp>
4
;;
5
;; Copyright 2006, 2007, 2008, 2009, 2011 Liam M. Healy
6 7 8 9 10 11 12 13 14 15 16 17 18 19
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
20

21 22 23 24 25 26 27
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
;;; subclass, the methods #'initialize-instance,
;;; #'reinitialize-instance, and #'allocate, and the function
;;; #'make-<class-name>, which is what the user calls to make the
;;; object.

28 29
(in-package :gsl)

Liam Healy's avatar
Liam Healy committed
30 31 32 33
;;;;****************************************************************************
;;;; The class definition
;;;;****************************************************************************

34
(defclass mobject ()
35
  ((mpointer :initarg :mpointer :reader mpointer
Liam Healy's avatar
Liam Healy committed
36 37
	     :documentation "A pointer to the GSL representation of the object.")))

38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
;;; Required arguments for defmobject:
;;;  class           Name of class being made.
;;;  prefix          String that starts each GSL function name
;;;  allocation-args Arguments used in the allocation (initialization)
;;;  description     Short string describing class

;;; Key arguments for defmobject:
;;; documentation
;;;  Docstring for the object maker.
;;; initialize-suffix
;;;  The string appended to prefix to form GSL function name or a list of
;;;  such a string and the c-return argument.
;;; initialize-name
;;;  A string with the name of the GSL function for initialization; defaults to
;;;  prefix + initialize-suffix.
;;; initialize-args
;;; arglists-function
;;;  A function of one symbol, a flag indicating that an optional
;;;  argument has been set.  It returns a list of three forms: the
;;;  arglists for the maker defun, the arguments that will be applied
;;;  therein to the inititializer and to the reinitializer.
;;; inputs, gsl-version
;;;  Defmfun arguments for reinitializer.
;;; allocator
;;; allocate-inputs
;;; freer
;;; callbacks
65
;;;   See callback.lisp
66 67 68 69 70
;;; superclasses
;;;   List of superclasses other than 'mobject.
;;; singular
;;;   Where a list of several objects like 'functions is specified, this permits
;;;   a single one with the singular form, like 'function.
71 72
;;; switch
;;;   Same as for defmfun.
73 74
;;; ri-c-return
;;;   The c-return for the reinitialize-instance function.
75

Liam Healy's avatar
Liam Healy committed
76
(defmacro defmobject
77
    (class prefix allocation-args description 
Liam Healy's avatar
Liam Healy committed
78 79
     &key documentation initialize-suffix initialize-name initialize-args
     arglists-function inputs gsl-version allocator allocate-inputs freer
80
     ((:callbacks cbinfo)) (export t)
81
     (superclasses (if cbinfo '(callback-included) '(mobject)))
82
     singular switch ri-c-return)
83 84
  "Define the class, the allocate, initialize-instance and
   reinitialize-instance methods, and the make-* function for the GSL object."
85 86 87 88 89 90 91
  (let* ((settingp (make-symbol "SETTINGP"))
	 (arglists
	  (when arglists-function
	    (funcall (coerce arglists-function 'function) settingp)))
	 (maker (intern (format nil "MAKE-~:@(~a~)" class) :gsl))
	 (cl-alloc-args (variables-used-in-c-arguments allocation-args))
	 (cl-initialize-args
92
	  (callback-replace-arg
93
	   'functions
94 95 96 97
	   (variables-used-in-c-arguments
	    (if (initialize-suffix-switched-foreign initialize-suffix)
		(second initialize-args)
		initialize-args))
98
	   cbinfo))
99
	 (initializerp (or initialize-name initialize-suffix)))
100
    ;; Need callback information for macroexpansion make-cbstruct-object
101
    (when cbinfo (record-callbacks-for-class class cbinfo))
102 103
    (if (have-at-least-gsl-version gsl-version)
	`(progn
104
	   ,(if cbinfo
105
		`(,(if (member 'grid:dimensions cl-alloc-args)
106 107
		       'def-ci-subclass 'def-ci-subclass-1d)
		   ,class
108
		   ,superclasses
109
		   ,(format nil "The GSL representation of the ~a." description)
110
		   ,(parse-callback-static cbinfo 'dimension-names))
111 112 113 114
		`(defclass ,class ,superclasses
		   nil
		   (:documentation
		    ,(format nil "The GSL representation of the ~a." description))))
Liam Healy's avatar
Liam Healy committed
115

116
	   (defmfun allocate ((object ,class) &key ,@cl-alloc-args)
Liam Healy's avatar
Liam Healy committed
117
	     ,(or allocator (format nil "~a_alloc" prefix))
118
	     ,allocation-args
Liam Healy's avatar
Liam Healy committed
119
	     ,@(if allocate-inputs `(:inputs ,allocate-inputs))
120 121 122
	     :definition :method
	     :c-return :pointer
	     :index ,maker)
Liam Healy's avatar
Liam Healy committed
123

124 125
	   ,(make-initialize-instance
	     class cl-alloc-args cl-initialize-args prefix freer)
Liam Healy's avatar
Liam Healy committed
126
	   ,@(when initializerp
127 128
		   (make-reinitialize-instance
		    class cl-initialize-args initialize-name prefix
129
		    initialize-suffix initialize-args inputs
130
		    cbinfo
131
		    superclasses
132
		    switch ri-c-return))
133
	   ,@(when export `((export '(,maker ,class))))
134 135
	   ,@(when cbinfo `((record-callbacks-for-class ',class ',cbinfo)))
	   ,@(when cbinfo (make-mobject-defmcallbacks cbinfo class))
136
	   ,(mobject-maker
137
	     maker arglists class cl-alloc-args cl-initialize-args
138
	     description documentation initialize-args initializerp settingp
139
	     singular cbinfo))
140
	`(progn
141
	   ,@(when export `((export ',maker)))
142 143 144 145 146 147
	   (defun ,maker (&rest args)
	     (declare (ignore args))
	     (error 'obsolete-gsl-version
		    :name ',class :gsl-name ,prefix
		    :gsl-version ',gsl-version))))))

148 149 150 151 152 153
(defun initialize-suffix-switched-foreign (initialize-suffix)
  "The specified initialize-suffix indicates that there are two
   foreign functions that can be called; which one is called
   is dependent on the presence or absense of certain arguments."
  (and initialize-suffix (listp initialize-suffix)))

154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
(defun make-initialize-instance
    (class cl-alloc-args cl-initialize-args prefix freer)
  `(defmethod initialize-instance :after
       ((object ,class) &key mpointer ,@(union cl-alloc-args cl-initialize-args))
     ,@(let ((not-alloc (set-difference cl-initialize-args cl-alloc-args)))
	    (when not-alloc)
	    `((declare (ignore ,@not-alloc))))
     (unless mpointer
       (setf mpointer
	     (allocate object ,@(symbol-keyword-symbol cl-alloc-args))
	     (slot-value object 'mpointer) mpointer))
     (tg:finalize object
		  (lambda ()
		    (cffi:foreign-funcall
		     ,(or freer (format nil "~a_free" prefix))
		     :pointer mpointer :void)))))

(defun make-reinitialize-instance
    (class cl-initialize-args initialize-name prefix
173
     initialize-suffix initialize-args inputs
174
     cbinfo superclasses switch ri-c-return)
175
  "Expand the reinitialize-instance form."
176 177 178 179 180 181 182 183 184 185 186 187 188
  (flet ((add-suffix (suffix) (format nil "~a_~a" prefix suffix)))
    (let* ((cbstruct (make-symbol "CBSTRUCT"))
	   (initialize-suffix-switched-foreign
	    (initialize-suffix-switched-foreign initialize-suffix)))
      `((defmfun reinitialize-instance
	    ((object ,class)
	     &key
	     ,@cl-initialize-args
	     ,@(when cbinfo
		     `(&aux (,cbstruct ,(make-cbstruct-object class)))))
	  ,(or initialize-name
	       (if initialize-suffix-switched-foreign
		   (mapcar #'add-suffix initialize-suffix)
189
		   (add-suffix initialize-suffix)))
190 191 192 193 194 195
	  ,(if initialize-suffix-switched-foreign
	       (mapcar (lambda (ia)
			 `(((mpointer object) :pointer)
			   ,@(callback-replace-arg cbstruct ia cbinfo)))
		       initialize-args)
	       `(((mpointer object) :pointer)
196
		 ,@(callback-replace-arg cbstruct initialize-args cbinfo)))
197 198 199
	  :definition :method
	  ,@(when cbinfo '(:callback-object object))
	  :qualifier :after
200
	  ,@(when ri-c-return `(:c-return ,ri-c-return))
201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
	  ,@(when switch (list :switch switch))
	  :return (object)
	  ,@(when inputs `(:inputs ,inputs))
	  ,@(when cbinfo
		  `(:before
		    (,@(when (member 'callback-included-cl superclasses)
			     `((setf (slot-value object 'callback) ,cbstruct)))
		       (make-funcallables-for-object object))
		    :after
		    ((trivial-garbage:finalize 
		      object
		      (lambda ()
			(cffi:foreign-free ,cbstruct))))))
	  :export nil
	  :index (reinitialize-instance ,class))))))
216 217

(defun mobject-maker
218
    (maker arglists class cl-alloc-args cl-initialize-args
219
     description documentation initialize-args initializerp settingp
220
     singular cbinfo)
221
  "Make the defun form that makes the mobject."
222
  (when cbinfo
223 224 225 226 227 228 229 230 231 232 233 234
    (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)))
    `(defun ,maker
	 ,(if arglists
	      (first arglists)
	      (singularize
	       singular
	       `(,@cl-alloc-args
		 ,@(when initargs
			 (append
			  (list
235 236 237 238
			   '&optional
			   (if (listp (first initargs))
			       `(,@(first initargs) ,settingp)
			       `(,(first initargs) nil ,settingp)))
239 240 241 242 243 244 245
			  (rest initargs))))))
       ,(format
	 nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
	 description class documentation)
       (let ((object
	      (make-instance
	       ',class
246
	       ,@(when cbinfo `(:cbinfo ',cbinfo))
247 248 249 250 251
	       ,@(if arglists
		     (second arglists)
		     (symbol-keyword-symbol cl-alloc-args singular)))))
	 ;; There is an initialization step
	 ,@(when initializerp
252
		 (if (or initialize-args arglists)	; with arguments
253 254 255 256 257 258 259 260 261 262 263
		     (let ((reii 
			    `(reinitialize-instance
			      object
			      ,@(if arglists
				    (third arglists)
				    (symbol-keyword-symbol
				     (arglist-plain-and-categories cl-initialize-args)
				     singular)))))
		       (if initargs `((when ,settingp ,reii)) `(,reii)))
		     '((reinitialize-instance object)))) ; without arguments
	 object))))
264

265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287
(defun plural-symbol (symbol)
  "Make the plural form of this symbol."
  (intern (format nil "~aS" (symbol-name symbol))
	  (find-package :gsl)))

(defun singular-symbol (symbol)
  "Make the singular form of this symbol."
  (let ((string (symbol-name symbol)))
    (if (eq #\S (aref string (1- (length string))))
	(intern (subseq string 0 (1- (length string)))
		(find-package :gsl)))))

(defun singularize (symbols form)
  "In the form, replace the plural symbol with the singular symbol
   given."
  (if symbols
      (if (listp symbols)
	  (singularize (first symbols) (singularize (rest symbols) form))
	  (subst symbols (plural-symbol symbols) form))
      form))

(defun symbol-keyword-symbol (symbol &optional singular)
  "Make a list of key symbol, listifying if singular."
288
  (if (listp symbol)
Liam Healy's avatar
Liam Healy committed
289
      (mappend (lambda (s) (symbol-keyword-symbol s singular)) symbol)
290 291 292 293 294
      (if (member (singular-symbol symbol) singular)
	  (list (intern (symbol-name symbol) :keyword)
		`(list ,(singular-symbol symbol)))
	  (list (intern (symbol-name symbol) :keyword)
		symbol))))
295

Liam Healy's avatar
Liam Healy committed
296 297 298
;;;;****************************************************************************
;;;; Generic functions
;;;;****************************************************************************
Liam Healy's avatar
Liam Healy committed
299

300 301 302 303
(defgeneric allocate (object &key &allow-other-keys)
  (:documentation
   "Use GSL to allocate memory.  Returns pointer but does not bind mpointer slot."))

304 305 306 307
(export 'name)
(defgeneric name (object)
  (:documentation "The name given to the GSL object."))

Liam Healy's avatar
Liam Healy committed
308 309 310 311
(export 'size)
(defgeneric size (object)
  (:documentation "The size of the GSL object.")
  (:method ((object array))
312 313 314
    (array-total-size object))
  (:method ((object grid:foreign-array))
    (grid:total-size object)))
Liam Healy's avatar
Liam Healy committed
315

316
(export 'evaluate)
317
(defgeneric evaluate (object point &key #+sbcl &allow-other-keys)
318 319
  (:documentation "Evaluate the GSL object."))

320 321 322
;;; Note: clisp has a foreign pointer class = T, so it would be best
;;; to narrow down methods that dispatch on this class.
(defmacro foreign-pointer-method (pointer form)
323
  "Execute this form only if the pointer is of grid:+foreign-pointer-type+;
324 325 326
   otherwise call the next method."
  #-clisp (declare (ignore pointer))
  #+clisp
327
  `(if (typep ,pointer grid:+foreign-pointer-type+)
328 329 330 331 332
       ,form
       (call-next-method))
  #-clisp
  form)

333
;;; Is this obsolete?  We no longer handle raw pointers.
334 335
(defmethod mpointer ((object #.grid:+foreign-pointer-class+))
  #+clisp (check-type object #.grid:+foreign-pointer-type+)
336
  object)
Liam Healy's avatar
Liam Healy committed
337

338 339 340
(export 'order)
(defgeneric order (object)
  (:documentation "The order of the GSL object."))