mobject.lisp 4.36 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-26 13:21:44EST 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 30 31 32 33 34
  (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
35 36
	  (variables-used-in-c-arguments initialize-args))
	 (realprefix (if (listp prefix) (first prefix) prefix)))
Liam Healy's avatar
Liam Healy committed
37
    `(progn
38
       (defclass ,class (mobject)
Liam Healy's avatar
Liam Healy committed
39 40 41 42
	 ()
	 (:documentation
	  ,(format nil "The GSL representation of the ~a." description)))

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

50 51 52 53 54 55 56 57 58 59 60 61
       (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))))

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

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

104 105 106 107 108 109
(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
110 111 112 113 114
;;; 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.

115 116 117 118 119 120 121 122 123 124 125
(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))))

126 127 128 129
;;; 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.")