mobject.lisp 12.9 KB
Newer Older
1 2
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec  3 2006 - 10:21
Liam Healy's avatar
Liam Healy committed
3
;; Time-stamp: <2017-01-01 17:26:26EST mobject.lisp>
4
;;
Liam Healy's avatar
Liam Healy committed
5
;; Copyright 2006, 2007, 2008, 2009, 2011, 2017 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
;;; 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.
Liam Healy's avatar
Liam Healy committed
47 48 49
;;; initialize-when-making
;;;  Call to initializer when making:
;;;  T=yes, NIL=no, :default-T=optional (default T), :default-NIL=optional (default NIL)
50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67
;;; 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
68
;;;   See callback.lisp
69 70 71 72 73
;;; 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.
74 75
;;; switch
;;;   Same as for defmfun.
76 77
;;; ri-c-return
;;;   The c-return for the reinitialize-instance function.
78

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

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

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

152 153 154 155 156 157
(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)))

158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176
(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
177
     initialize-suffix initialize-args inputs
178
     cbinfo superclasses switch ri-c-return)
179
  "Expand the reinitialize-instance form."
180 181 182 183 184 185 186 187 188 189 190 191 192
  (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)
193
		   (add-suffix initialize-suffix)))
194 195 196 197 198 199
	  ,(if initialize-suffix-switched-foreign
	       (mapcar (lambda (ia)
			 `(((mpointer object) :pointer)
			   ,@(callback-replace-arg cbstruct ia cbinfo)))
		       initialize-args)
	       `(((mpointer object) :pointer)
200
		 ,@(callback-replace-arg cbstruct initialize-args cbinfo)))
201 202 203
	  :definition :method
	  ,@(when cbinfo '(:callback-object object))
	  :qualifier :after
204
	  ,@(when ri-c-return `(:c-return ,ri-c-return))
205 206 207 208 209 210 211 212 213 214 215 216 217 218 219
	  ,@(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))))))
220 221

(defun mobject-maker
Liam Healy's avatar
Liam Healy committed
222 223 224
    (maker arglists class cl-alloc-args initialize-when-making
     cl-initialize-args description documentation initialize-args
     initializerp settingp singular cbinfo)
225
  "Make the defun form that makes the mobject."
226
  (when cbinfo
227 228
    (setf cl-initialize-args (append cl-initialize-args '((scalarsp t)))))
  (let ((initargs ; arguments that are exclusively for reinitialize-instance
Liam Healy's avatar
Liam Healy committed
229
	  (remove-if (lambda (s) (member s cl-alloc-args)) cl-initialize-args)))
230 231 232 233 234 235
    `(defun ,maker
	 ,(if arglists
	      (first arglists)
	      (singularize
	       singular
	       `(,@cl-alloc-args
Liam Healy's avatar
Liam Healy committed
236 237 238 239 240 241 242 243 244 245 246 247
		 ,@(when (or initargs (member initialize-when-making '(:default-t :default-nil)))
		     (append
		      '(&optional)
		      (cond
			((eql initialize-when-making :default-t) '((initialize T)))
			((eql initialize-when-making :default-nil) '((initialize NIL)))
			(t nil))
		      (when initargs
			(if (listp (first initargs))
			    `((,@(first initargs) ,settingp))
			    `((,(first initargs) nil ,settingp))))
		      (rest initargs))))))
248 249 250 251
       ,(format
	 nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
	 description class documentation)
       (let ((object
Liam Healy's avatar
Liam Healy committed
252 253 254 255 256 257
	       (make-instance
		',class
		,@(when cbinfo `(:cbinfo ',cbinfo))
		,@(if arglists
		      (second arglists)
		      (symbol-keyword-symbol cl-alloc-args singular)))))
258
	 ,@(when initializerp
Liam Healy's avatar
Liam Healy committed
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274
	     (let ((call
		     (if (or initialize-args arglists) ; with arguments
			 (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
	       (case initialize-when-making
		 ((:default-t :default-nil) `((when initialize ,@call)))
		 ((t) call)
		 (otherwise nil))))
275
	 object))))
276

277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299
(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."
300
  (if (listp symbol)
Liam Healy's avatar
Liam Healy committed
301
      (mappend (lambda (s) (symbol-keyword-symbol s singular)) symbol)
302
      (if (member (singular-symbol symbol) singular)
303
	  (list (alexandria:make-keyword symbol)
304
		`(list ,(singular-symbol symbol)))
305
	  (list (alexandria:make-keyword symbol)
306
		symbol))))
307

Liam Healy's avatar
Liam Healy committed
308 309 310
;;;;****************************************************************************
;;;; Generic functions
;;;;****************************************************************************
Liam Healy's avatar
Liam Healy committed
311

312 313 314 315
(defgeneric allocate (object &key &allow-other-keys)
  (:documentation
   "Use GSL to allocate memory.  Returns pointer but does not bind mpointer slot."))

316 317 318 319
(export 'name)
(defgeneric name (object)
  (:documentation "The name given to the GSL object."))

Liam Healy's avatar
Liam Healy committed
320 321 322 323
(export 'size)
(defgeneric size (object)
  (:documentation "The size of the GSL object.")
  (:method ((object array))
324 325 326
    (array-total-size object))
  (:method ((object grid:foreign-array))
    (grid:total-size object)))
Liam Healy's avatar
Liam Healy committed
327

328
(export 'evaluate)
329
(defgeneric evaluate (object point &key #+sbcl &allow-other-keys)
330 331
  (:documentation "Evaluate the GSL object."))

332 333 334
;;; 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)
335
  "Execute this form only if the pointer is of grid:+foreign-pointer-type+;
336 337 338
   otherwise call the next method."
  #-clisp (declare (ignore pointer))
  #+clisp
339
  `(if (typep ,pointer grid:+foreign-pointer-type+)
340 341 342 343 344
       ,form
       (call-next-method))
  #-clisp
  form)

345
;;; Is this obsolete?  We no longer handle raw pointers.
346 347
(defmethod mpointer ((object #.grid:+foreign-pointer-class+))
  #+clisp (check-type object #.grid:+foreign-pointer-type+)
348
  object)
Liam Healy's avatar
Liam Healy committed
349

350 351 352
(export 'order)
(defgeneric order (object)
  (:documentation "The order of the GSL object."))