gsl-objects.lisp 5.89 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-03-23 17:49:12EDT gsl-objects.lisp>
lhealy's avatar
lhealy committed
4
;; $Id$
5 6 7

(in-package :gsl)

8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
;;; 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.
25

26
(export 'letm)
27
(defmacro letm (bindings &body body)
28
  (first (letm-expand bindings body)))
29

30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
(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)
48 49 50 51 52 53

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

54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
(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))))

82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
;;; 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))))))))))
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;OBSOLETE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Old form
(defmacro letm-obsolete (bindings &body body)
  "A macro to bind variables to GSL objects, possibly setting
   initial values, and freeing them when done.  The binding is as
   in a let*; any bindings for non-GSL objects are done as in
   a let*."
  (let* (setters			; save setting forms
	 freers				; save freeing forms
	 assigns			; save global assignements
	 (*not-for-users* t))
    ;; Rewrite the bindings with allocators and push them on assigns
    (dolist (b bindings)
      (if (atom b)
	  (push b assigns)
	  (let ((defsymb (first b)) (defas (second b)))
	    (if (and (listp b) (listp defas)
		     (member (first defas) *letm-expanded-object*))
		;; It is a GSL object
		(destructuring-bind (allocator freer &optional setter assign)
		    (apply (first defas) (rest defas))
		  ;; If there's a setting function, save the form
		  (when setter (push (funcall setter defsymb) setters))
		  ;; Save the freeing form
		  (push `(,freer ,defsymb) freers)
		  ;; Save the global assignments
		  (when assign (push (funcall assign) assigns))
		  ;; Return the allocation form to be used in let
		  (push `(,defsymb ,allocator) assigns))
		;; Not a GSL object, just define it with let
		(push b assigns)))))
    (if freers
	;; There were GSL objects
	`(let* (,@(reverse assigns))
	  ;; put the body in an unwind-protect
	  (unwind-protect
	       (progn
		 ,@(reverse setters)		; setting the objects 
		 ,@body)
	    ,@freers))			; freeing the objects
	;; No GSL objects in the bindings, just make an ordinary let
	`(let* (,@bindings) ,@body))))