mobject.lisp 5.53 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-29 17:37:25EST 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)

15
(defclass mobject ()
16
  ((mpointer :initarg :mpointer :reader mpointer
Liam Healy's avatar
Liam Healy committed
17 18 19
	     :documentation "A pointer to the GSL representation of the object.")))

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

45
       (defmfun allocate ((object ,class) &key ,@cl-alloc-args)
46
	 ,(if (listp prefix) (second prefix) (format nil "~a_alloc" prefix))
Liam Healy's avatar
Liam Healy committed
47 48
	 ,allocation-args
	 :definition :method
49
	 :c-return :pointer
Liam Healy's avatar
Liam Healy committed
50 51
	 :index ,maker)

52 53 54 55
       (defmethod initialize-instance :after
	   ((object ,class) &key mpointer ,@cl-alloc-args)
	 (unless mpointer
	   (setf mpointer
56 57
		 (allocate object ,@(symbol-keyword-symbol cl-alloc-args))
		 (slot-value object 'mpointer) mpointer))
58 59 60 61 62 63 64
	 (trivial-garbage:finalize
	  object
	  (lambda ()
	    (cffi:foreign-funcall
	     ,(format nil "~a_free" realprefix)
	     :pointer mpointer :void))))

65
       ,@(when initialize-suffix
66
	       `((defmfun reinitialize-instance
67
		     ((object ,class) &key ,@cl-initialize-args)
68 69 70 71
		   ,(format nil "~a_~a" realprefix
			    (if (listp initialize-suffix)
				(first initialize-suffix)
				initialize-suffix))
72 73 74
		   (((mpointer object) :pointer) ,@initialize-args)
		   :definition :method
		   :qualifier :after
75 76
		   ,@(when (listp initialize-suffix)
			   `(:c-return ,(second initialize-suffix)))
77
		   :return (object)
78
		   ,@(when inputs `(:inputs ,inputs))
79 80
		   :export nil
		   :index (reinitialize-instance ,class))))
Liam Healy's avatar
Liam Healy committed
81

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

112 113 114 115 116 117
(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
118 119 120 121 122
;;; 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.

123 124 125 126 127 128 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."))

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

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)