mobject.lisp 8.48 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: <2008-12-25 23:01:24EST gsl-objects.lisp>
lhealy's avatar
lhealy committed
4
;; $Id$
5 6 7

(in-package :gsl)

Liam Healy's avatar
Liam Healy committed
8
#|
9
(defclass mobject ()
10
  ((mpointer :initarg :mpointer :reader mpointer
Liam Healy's avatar
Liam Healy committed
11 12
	     :documentation "A pointer to the GSL representation of the object.")))

13

Liam Healy's avatar
Liam Healy committed
14
(defmacro defmobject
15 16 17 18 19 20 21 22
    (class prefix allocation-args description 
     &optional docstring initialize-suffix initialize-args arglists-function
     inputs)
  "Define the class, initialize-instance and reinitialize-instance methods,
   and the make-* function for the GSL object."
  ;; If prefix is a list, the first is the actual prefix, and the
  ;; second is the name of the allocateor.  I'm looking at you,
  ;; discrete-random.  Grrr.
23 24 25 26 27 28 29
  (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
30 31
	  (variables-used-in-c-arguments initialize-args))
	 (realprefix (if (listp prefix) (first prefix) prefix)))
Liam Healy's avatar
Liam Healy committed
32
    `(progn
33
       (defclass ,class (mobject)
Liam Healy's avatar
Liam Healy committed
34 35 36 37
	 ()
	 (:documentation
	  ,(format nil "The GSL representation of the ~a." description)))

38
       (defmfun allocate ((object ,class) &key ,@cl-alloc-args)
39
	 ,(if (listp prefix) (second prefix) (format nil "~a_alloc" prefix))
Liam Healy's avatar
Liam Healy committed
40 41
	 ,allocation-args
	 :definition :method
42
	 :c-return :pointer
Liam Healy's avatar
Liam Healy committed
43 44
	 :index ,maker)

45 46 47 48 49 50 51 52 53 54 55 56
       (defmethod initialize-instance :after
	   ((object ,class) &key mpointer ,@cl-alloc-args)
	 (unless mpointer
	   (setf mpointer
		 (allocate object ,@(symbol-keyword-symbol cl-alloc-args))))
	 (trivial-garbage:finalize
	  object
	  (lambda ()
	    (cffi:foreign-funcall
	     ,(format nil "~a_free" realprefix)
	     :pointer mpointer :void))))

57
       ,@(when initialize-suffix
58 59 60 61 62
	       `((defmfun reinitialize-instance
		     ,(if initialize-args
			  `((object ,class) &key ,@cl-initialize-args)
			  `((object ,class)))
		   ,(format nil "~a_~a" realprefix initialize-suffix)
63 64 65 66
		   (((mpointer object) :pointer) ,@initialize-args)
		   :definition :method
		   :qualifier :after
		   :return (object)
67
		   ,@(when inputs `(:inputs ,inputs))
68 69
		   :export nil
		   :index (reinitialize-instance ,class))))
Liam Healy's avatar
Liam Healy committed
70

71
       (export ',maker)
Liam Healy's avatar
Liam Healy committed
72
       (defun ,maker
73 74 75
	   ,(if arglists
		(first arglists)
		`(,@cl-alloc-args
76
		  ,@(when initialize-args
77 78 79 80
			  (append
			   (list '&optional
				 (list (first cl-initialize-args) nil settingp))
			   (rest cl-initialize-args)))))
81
	 ,(format nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
82
		  description class docstring)
83
	 (let ((object
84 85 86 87 88
		(make-instance
		 ',class
		 ,@(if arglists
		       (second arglists)
		       (symbol-keyword-symbol cl-alloc-args)))))
89
	   ;; There is an initialization step
90
	   ,@(when initialize-suffix
91 92 93 94 95 96 97 98
		   (if initialize-args	; with arguments
		       `((when ,settingp
			   (reinitialize-instance
			    object
			    ,@(if arglists
				  (third arglists)
				  (symbol-keyword-symbol cl-initialize-args)))))
		       '((reinitialize-instance object)))) ; without arguments
Liam Healy's avatar
Liam Healy committed
99 100
	   object)))))

101 102 103 104 105 106
(defun symbol-keyword-symbol (symbol)
  (if (listp symbol)
      (mapcan #'symbol-keyword-symbol symbol)
      (list (intern (symbol-name symbol) :keyword)
	    symbol)))

Liam Healy's avatar
Liam Healy committed
107 108 109 110 111 112
;;; To make-load-form
;;; (make-basis-spline (bspline-order bspline) (number-of-breakpoints bspline))
;;; Then initialize by making a vector from (breakpoint i bspline)
;;; and calling knots.
|#

113 114 115 116 117 118 119 120 121 122 123
(defgeneric allocate (object &key &allow-other-keys)
  (:documentation
   "Use GSL to allocate memory.  Returns pointer but does not bind mpointer slot."))

;;; Could be part of copy when the second argument is optional?
(export 'clone)
(defgeneric clone (object)
  (:documentation "Create a duplicate object.")
  (:method :around ((object mobject))
	   (make-instance (class-of object) :mpointer (call-next-method))))

Liam Healy's avatar
Liam Healy committed
124 125 126
;;;;;;;;;;;;;;;;;;;;;;;; OLD ;;;;;;;;;;;;;;;;;;;;;;;;;;;


127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
;;; There are numerous "GSL objects" which need to by manually
;;; memory-managed.  The macro letm takes care of this.
;;; A method #'letm-expansion which eql specializes on the object name
;;; in the second argument is responsible for doing the expansion.
;;;
;;; Many GSL objects simply need to be allocated, optionally set, and
;;; then freed after the work has been done.  To cover those cases,
;;; the macro #'defgo (and simpler macro #'defgo-s) is defined.  The
;;; default #'letm-expansion assumes that the object has been defined
;;; with defgo or defgo-s.  Their names are saved in
;;; *letm-expanded-object*.
;;; 
;;; Each object has a defun named after it, with an arglist
;;; (and perhaps docstring) appropriate for when that form
;;; is a binding to a letm.  This function shouldn't be called;
;;; it is defined and exported for the benefit of arglist
;;; displayers like slime.
144

Liam Healy's avatar
Liam Healy committed
145

146
(export 'letm)
147
(defmacro letm (bindings &body body)
148
  (first (letm-expand bindings body)))
149

150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
(defun letm-expand (bindings body)
  (if (null bindings)
      body
      (let ((binding (first bindings)))
	(if (and (listp binding) (listp (second binding)))
	    (destructuring-bind (symbol (object &rest arguments))
		binding
	      `(,(letm-expansion
		  symbol
		  object
		  arguments
		  (letm-expand (rest bindings) body))))
	    ;; binding value is an atom or not present
	    `((let (,binding)
		,@(letm-expand (rest bindings) body)))))))

(defvar *not-for-users* nil)
(defparameter *letm-expanded-object* nil)
168 169 170 171 172 173

(defun not-for-users (form)
  (unless *not-for-users*
    (error "The form ~a should be placed in the binding of a letm."
	   form)))

174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201
(defmacro arglist-only (symbol docstring &rest arglist)
  "Define objects to be used with letm bindings, but 
   make the function itself signal an error."
  `(eval-when (:compile-toplevel :load-toplevel :execute)
    (pushnew ',symbol *letm-expanded-object*)
    (export ',symbol)
    (defun ,symbol (,@arglist) ,docstring
	   (declare (ignorable ,@arglist))
	   (not-for-users (list ',symbol ,@arglist)))))

(defgeneric letm-expansion (symbol type args body)
  ;; The method that expands a defgo-created object.
  (:method (symbol type args body)
    (if (member type *letm-expanded-object*)
	(let ((*not-for-users* t))
	  (destructuring-bind (allocator freer &optional setter assign)
	      (if type (apply type args) (list nil nil))
	    `(let* (,@(when assign (list (funcall assign)))
		    (,symbol ,allocator))
	      (unwind-protect
		   (progn
		     ,@(when setter (list (funcall setter symbol)))
		     ,@body)
		(,freer ,symbol)))))
	;; Not a GSL object; create a regular let form
	`(let ((,symbol (,type ,@args)))
	  ,@body))))

202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
;;; General definition for object creation
(defmacro defgo (symbol arglist &body body)
  "Define a GSL object to be bound in a letm.
   The body should return a list of two to four values.
   The first is the allocation form, the second is
   the freeing function name, the third is
   form to set or initialize the object,
   and the last is a function of no arguments
   that gives a form to be bound in a let prior
   to binding the object.  The symbol will be exported
   even though users should not call the function, so that
   it will show up in arglist prompters."
  `(eval-when (:compile-toplevel :load-toplevel :execute)
    (pushnew ',symbol *letm-expanded-object*)
    (export ',symbol)
    (defun ,symbol ,arglist
      (not-for-users ',(cons symbol arglist))
      ,@body)))

;;; Specific, simple and common types of object creation 
(defmacro defgo-s (form allocate free &optional set (num-alloc-args 1))
  "Make an object usable in letm with the arglist is the allocate
   and set arglists appended."
  (let ((symb (gensym "SASF")))
    `(defgo ,(first form)
      (,@(subseq (rest form) 0 num-alloc-args)
       &optional
       ,@(when set `((,(nth num-alloc-args (rest form))
		      nil
		      settingp)))
       ,@(when set (subseq (rest form) (1+ num-alloc-args))))
      (list
       `(,',allocate ,,@(subseq (rest form) 0 num-alloc-args))
       ',free
       ,@(when set
	       `((when settingp
		   (lambda (,symb)
		     `(,',set ,,symb ,,@(subseq (rest form) num-alloc-args))))))))))
240

241 242 243 244
;;; Pointer type
(defconstant +foreign-pointer-class+ (class-name (class-of (cffi:null-pointer)))
  "The class in which foreign pointers fall.  This will be assumed to be a 
   GSL vector or matrix.")
245 246 247 248 249 250 251

;;; Generic allocation and free used for histograms and random
(export '(alloc free))
(defgeneric alloc (object)
  (:documentation "Allocate the GSL storage."))
(defgeneric free (object)
  (:documentation "Free the GSL storage."))