mobject.lisp 7.74 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: <2009-01-21 22:38:01EST mobject.lisp>
lhealy's avatar
lhealy committed
4
;; $Id$
5

6 7 8 9 10 11 12
;;; 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.

13 14
(in-package :gsl)

Liam Healy's avatar
Liam Healy committed
15 16 17 18
;;;;****************************************************************************
;;;; The class definition
;;;;****************************************************************************

19
(defclass mobject ()
20
  ((mpointer :initarg :mpointer :reader mpointer
Liam Healy's avatar
Liam Healy committed
21 22 23
	     :documentation "A pointer to the GSL representation of the object.")))

(defmacro defmobject
24 25 26
    (class prefix allocation-args description 
     &optional docstring initialize-suffix initialize-args arglists-function
     inputs)
27 28
  "Define the class, the allocate, initialize-instance and
   reinitialize-instance methods, and the make-* function for the GSL object."
29
  ;; If prefix is a list, the first is the actual prefix, and the
30
  ;; second is the name of the allocator.  I'm looking at you,
31
  ;; discrete-random.  Grrr.
32 33
  ;; Argument 'initialize-suffix: string appended to prefix for form GSL function name
  ;;   or a list of such a string and the c-return argument.
34 35 36 37 38 39 40
  (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
41 42
	  (variables-used-in-c-arguments initialize-args))
	 (realprefix (if (listp prefix) (first prefix) prefix)))
Liam Healy's avatar
Liam Healy committed
43
    `(progn
44
       (defclass ,class (mobject)
Liam Healy's avatar
Liam Healy committed
45 46 47 48
	 ()
	 (:documentation
	  ,(format nil "The GSL representation of the ~a." description)))

49
       (defmfun allocate ((object ,class) &key ,@cl-alloc-args)
50
	 ,(if (listp prefix) (second prefix) (format nil "~a_alloc" prefix))
Liam Healy's avatar
Liam Healy committed
51
	 ,allocation-args
52 53
	 ,@(if (and (listp prefix) (third prefix))
	       `(:inputs ,(third prefix)))
Liam Healy's avatar
Liam Healy committed
54
	 :definition :method
55
	 :c-return :pointer
Liam Healy's avatar
Liam Healy committed
56 57
	 :index ,maker)

58
       (defmethod initialize-instance :after
59 60 61 62
	   ((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))))
63 64
	 (unless mpointer
	   (setf mpointer
65 66
		 (allocate object ,@(symbol-keyword-symbol cl-alloc-args))
		 (slot-value object 'mpointer) mpointer))
67 68 69 70 71
	 (tg:finalize object
		      (lambda ()
			(cffi:foreign-funcall
			 ,(format nil "~a_free" realprefix)
			 :pointer mpointer :void))))
72

73
       ,@(when initialize-suffix
74
	       `((defmfun reinitialize-instance
75
		     ((object ,class) &key ,@cl-initialize-args)
76 77 78 79
		   ,(format nil "~a_~a" realprefix
			    (if (listp initialize-suffix)
				(first initialize-suffix)
				initialize-suffix))
80 81 82
		   (((mpointer object) :pointer) ,@initialize-args)
		   :definition :method
		   :qualifier :after
83 84
		   ,@(when (listp initialize-suffix)
			   `(:c-return ,(second initialize-suffix)))
85
		   :return (object)
86
		   ,@(when inputs `(:inputs ,inputs))
87 88
		   :export nil
		   :index (reinitialize-instance ,class))))
Liam Healy's avatar
Liam Healy committed
89

90
       (export ',maker)
Liam Healy's avatar
Liam Healy committed
91
       (defun ,maker
92 93 94
	   ,(if arglists
		(first arglists)
		`(,@cl-alloc-args
95
		  ,@(when initialize-args
96 97 98 99
			  (append
			   (list '&optional
				 (list (first cl-initialize-args) nil settingp))
			   (rest cl-initialize-args)))))
100
	 ,(format nil "Create the GSL object representing a ~a (class ~a).~@[~&~a~]"
101
		  description class docstring)
102
	 (let ((object
103 104 105 106 107
		(make-instance
		 ',class
		 ,@(if arglists
		       (second arglists)
		       (symbol-keyword-symbol cl-alloc-args)))))
108
	   ;; There is an initialization step
109
	   ,@(when initialize-suffix
110 111 112 113 114 115 116 117
		   (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
118 119
	   object)))))

120 121 122 123 124 125
(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
126 127 128
;;;;****************************************************************************
;;;; Generic functions
;;;;****************************************************************************
Liam Healy's avatar
Liam Healy committed
129

130 131 132 133
(defgeneric allocate (object &key &allow-other-keys)
  (:documentation
   "Use GSL to allocate memory.  Returns pointer but does not bind mpointer slot."))

134 135 136 137
(export 'name)
(defgeneric name (object)
  (:documentation "The name given to the GSL object."))

138
;;; Pointer type
139 140 141 142 143
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +foreign-pointer-class+ (class-name (class-of (cffi:null-pointer)))
    "The class in which foreign pointers fall.")
  (defconstant +foreign-pointer-type+ (type-of (cffi:null-pointer))
    "The type of foreign pointers."))
144 145 146 147 148 149 150 151 152 153 154 155 156

;;; Some functions in solve-minimize-fit return a pointer to a GSL
;;; vector with double-floats.  This function will return a contents
;;; form suitable for make-marray.  There is no choice but to copy
;;; over the data even on native implementations; because GSL is doing
;;; the mallocing, the data are not CL-accessible.

(defgeneric contents-from-pointer (pointer struct-type &optional element-type)
  (:documentation
   "Create a contents list from the GSL object of type struct-type
    referenced by pointer."))

(defmethod mpointer ((object #.+foreign-pointer-class+))
157
  (check-type object #.+foreign-pointer-type+)
158
  object)
Liam Healy's avatar
Liam Healy committed
159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 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 202 203 204 205 206 207 208 209 210

;;;;****************************************************************************
;;;; Making objects from existing objects
;;;;****************************************************************************

(export 'copy)
(defgeneric copy (object &optional destination)
  (:documentation "Create a duplicate object.")
  ;; This method is used for all GSL objects except arrays.
  (:method ((object mobject) &optional destination)
    (if destination
	(copy-to-destination object destination)
	(copy-making-destination object))))

(defgeneric copy-to-destination (object destination)
  ;; This copies values into an existing object.  Methods are defined
  ;; for non-array GSL objects that have _memcpy functions defined.
  ;; Defined for
  ;; random-number-generator, quasi-random-number-generator,
  ;; histogram, histogram2d, permutation, combination.
  (:documentation "Copy contents into existing object."))

(defgeneric copy-making-destination (object)
  (:documentation "Create new duplicate object.")
  (:method :around ((object mobject))
    (if (next-method-p)
	;; The subclass method should only return the malloced
	;; mpointer (as from a "_clone" function); it will be put into
	;; the CL object here.  The initial-instance method for these
	;; objects must be written to do nothing if the mpointer is
	;; already defined.
	;; Defined for
	;; histogram, histogram2d, 
	;; random-number-generator, quasi-random-number-generator,
	(make-instance (class-of object) :mpointer (call-next-method))
	;; The subclass does not supply a method, so this will be called
	;; by default.  We can only try to make something from the load form.
	(eval (make-load-form object)))))

;;; 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))))


;;; 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.