body-expand.lisp 7.45 KB
Newer Older
1 2
;; Expand the body of a defmfun
;; Liam Healy 2009-04-13 22:07:13EDT body-expand.lisp
3
;; Time-stamp: <2010-12-04 09:48:48EST body-expand.lisp>
4
;;
Liam M. Healy's avatar
Liam M. Healy committed
5
;; Copyright 2009, 2010 Liam M. Healy
6 7 8 9 10 11 12 13 14 15 16 17 18 19
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
20 21 22 23 24

(in-package :gsl)

(defun creturn-st (c-return)
  "The symbol-type of the return from the C function."
25
  (grid:make-st
26
   (if (listp c-return)
27
       (grid:st-symbol c-return)
28 29 30
       (make-symbol "CRETURN"))
   (if (member c-return *special-c-return*)
       :int
31
       (if (listp c-return) (grid:st-type c-return) c-return))))
32

33
#+fsbv
34 35 36 37 38
(defun variables-passed-by-value (c-arguments-st)
  "Create a list of (symbol newsymbol-st) for each structure
  variable in the C argument list."
  (loop for sd in c-arguments-st
     collect
39 40 41 42 43
     (when (fsbv:defined-type-p (grid:st-type sd))
       (list (grid:st-symbol sd)
	     (grid:make-st
	      (make-symbol (string (grid:st-symbol sd)))
	      (grid:st-type sd))))))
44

Liam Healy's avatar
Liam Healy committed
45 46 47 48 49 50 51 52 53 54 55
;;; This function should never be called even when FSBV is absent,
;;; because the potential callers should all have #-fsbv
;;; conditionalization.  It is here just so that body-expand can
;;; compile when FSBV is absent.
#-fsbv
(defmacro no-fsbv-error (function-name &rest args)
  (declare (ignore args))
  `(error
    "System FSBV is not present, so function ~a cannot be used."
    ,function-name))

56 57 58 59 60 61 62
#+fsbv
(defun make-defcfun-for-fsbv (gsl-name ff-args)
  "Make a fsbv:defcfun form so that function will be prepped."
  (multiple-value-bind (args return-type)
      (fsbv:defcfun-args-from-ff-args ff-args)
    (let ((gsl-name-symbol (make-symbol gsl-name))
	  (symbargs
63
	   (mapcar (lambda (st) (grid:make-st (gensym "ARG") (grid:st-type st)))
64 65
		   args)))
      (values
Liam M. Healy's avatar
Liam M. Healy committed
66
       `(fsbv:defcfun (,gsl-name-symbol ,gsl-name) ,return-type
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
	  "Function definition generated for FSBV prepping; will actually
        be called by fsbv:foreign-funcall"
	  ,@symbargs)
       gsl-name-symbol))))

(defun ffexpand (pass-by-value-p gsl-name args)
  "Expand the foreign funcall."
  (if pass-by-value-p
      #+fsbv
      (multiple-value-bind (form symbol)
	  (make-defcfun-for-fsbv gsl-name args)
	(declare (special fsbv-functions))
	(push form fsbv-functions)
	`(fsbv:foreign-funcall ,symbol ,@args))
      #-fsbv
      `(no-fsbv-error no-fsbv-error ,@args)
      `(cffi:foreign-funcall ,gsl-name ,@args)))

85 86
(defun cl-convert-form (decl)
  "Generate a form that calls the appropriate converter from C/GSL to CL."
87 88
  (or 
   #+fsbv
89
   (if (fsbv:converter-defined-p (grid:st-actual-type decl))
90 91 92 93
       `((fsbv:object ,(grid:st-symbol decl) ',(grid:st-actual-type decl))))
   #-fsbv nil
   (case (grid:st-actual-type decl)
     (sf-result 
94 95
	`((val ,(grid:st-symbol decl))
	  (err ,(grid:st-symbol decl))))
96
     (sf-result-e10
97 98 99
	`((val ,(grid:st-symbol decl) 'sf-result-e10)
	  (e10 ,(grid:st-symbol decl))
	  (err ,(grid:st-symbol decl) 'sf-result-e10)))
100
     (t `((cffi:mem-aref ,(grid:st-symbol decl) ',(grid:st-actual-type decl)))))))
101

102 103 104 105 106 107
(defun values-unless-singleton (forms)
  (unless (listp forms) (error "Values are not a list."))
  (if (rest forms)
    `(values ,@forms)
    (first forms)))

108 109 110 111 112
(defun body-expand (name arglist gsl-name c-arguments key-args)
  "Expand the body (computational part) of the defmfun."
  (with-defmfun-key-args key-args
    (let* ((creturn-st (creturn-st c-return))
	   (allocated-return ; Allocated and then returned from CL function
113
	    (mapcar
114
	     (lambda (s)
115
	       (or (find s c-arguments :key #'grid:st-symbol)
116 117 118 119 120 121
		   ;; Catch programming errors, usually typos
		   (error "Could not find ~a among the arguments" s)))
	     (remove-if
	      (lambda (s)
		(member s (arglist-plain-and-categories arglist nil)))
	      (variables-used-in-c-arguments c-arguments))))
Liam Healy's avatar
Liam Healy committed
122
	   (pbv				; passed by value
123
	    #+fsbv
124 125
	     (variables-passed-by-value (cons creturn-st c-arguments))
	     #-fsbv nil)
126 127
	   (clret (or			; better as a symbol macro
		   (substitute
128
		    (grid:st-symbol creturn-st) :c-return
129
		    (mapcar (lambda (sym)
130
			      (let ((it (find sym allocated-return :key 'grid:st-symbol)))
131 132 133 134 135 136
				(if it
				    (first (cl-convert-form it))
				    sym)))
			    return))
		   (mappend
		    #'cl-convert-form
137
		    (callback-remove-arg allocated-return cbinfo 'grid:st-symbol))
138 139
		   outputs
		   (unless (eq c-return :void)
140
		     (list (grid:st-symbol creturn-st))))))
141 142 143 144 145 146 147 148 149 150 151 152
      (wrap-letlike
       allocated-return
       (mapcar (lambda (d) (wfo-declare d cbinfo))
	       allocated-return)
       'cffi:with-foreign-objects
       `(,@(append
	    (callback-symbol-set
	     callback-dynamic cbinfo (first callback-dynamic-variables))
	    before
	    (when callback-object (callback-set-dynamic callback-object arglist)))
	   ,@(callback-set-slots
	      cbinfo callback-dynamic-variables callback-dynamic)
153
	   (let ((,(grid:st-symbol creturn-st)
154 155 156 157 158 159
		  ,(ffexpand (some 'identity pbv)
			     gsl-name
			     (append
			      (mappend
			       (lambda (arg)
				 (list (cond
160
					 ((member (grid:st-symbol arg)
Liam Healy's avatar
Liam Healy committed
161 162
						  allocated-return)
					  :pointer)
163 164 165
					 (t (grid:st-type arg)))
				       (grid:st-symbol arg)))
			       (mapcar 'grid:st-pointer-generic-pointer
Liam Healy's avatar
Liam Healy committed
166
				       c-arguments))
167
			      (list (grid:st-type creturn-st))))))
168
	     ,@(case c-return
169
		     (:void `((declare (ignore ,(grid:st-symbol creturn-st)))))
170
		     (:error-code	; fill in arguments
171
		      `((check-gsl-status ,(grid:st-symbol creturn-st)
172
					  ',(or (defgeneric-method-p name) name)))))
173
	     ,@(when (eq (grid:st-type creturn-st) :pointer)
174
		     `((check-null-pointer
175
			,(grid:st-symbol creturn-st)
176 177
			,@'('memory-allocation-failure "No memory allocated."))))
	     ,@after
178 179 180 181 182 183
	     ,(values-unless-singleton
	       (defmfun-return
		   c-return (grid:st-symbol creturn-st) clret
		   allocated-return
		   return return-supplied-p
		   enumeration outputs))))))))
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 211 212 213 214 215 216 217 218

(defun defmfun-return
    (c-return cret-name clret allocated return return-supplied-p enumeration outputs)
  "Generate the return computation expression for defmfun."
  (case c-return
    (:number-of-answers
     (mappend
      (lambda (vbl seq)
	`((when (> ,cret-name ,seq) ,vbl)))
      clret
      (loop for i below (length clret) collect i)))
    (:success-failure
     (if (equal clret outputs)
	 ;; success-failure more important than passed-in
	 `((success-failure ,cret-name))
	 (remove cret-name		; don't return c-return itself
		 `(,@clret (success-failure ,cret-name)))))
    (:success-continue
     (if (equal clret outputs)
	 ;; success-failure more important than passed-in
	 `((success-continue ,cret-name))
	 (remove cret-name		; don't return c-return itself
		 `(,@clret (success-continue ,cret-name)))))
    (:true-false
     `((not (zerop ,cret-name))))
    (:enumerate
     `((cffi:foreign-enum-keyword ',enumeration ,cret-name)))
    (t (unless
	   (or
	    (and (eq c-return :error-code)
		 (not outputs)
		 (not allocated)
		 (not return-supplied-p))
	    (and (null return) return-supplied-p))
	 clret))))