defmfun.lisp 23.3 KB
Newer Older
1 2
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
3
;; Time-stamp: <2008-12-27 17:02:11EST defmfun.lisp>
4 5 6 7 8 9 10 11
;; $Id$

(in-package :gsl)

;;;;****************************************************************************
;;;; Macro defmfun
;;;;****************************************************************************

12 13 14 15 16 17 18 19
;;; Demfun is the main macro for defining functions (ordinary
;;; functions, generic functions, and methods) tthat call GSL
;;; functions.  It takes care of mapping the data from CL to C and
;;; then back out from C to CL.  Where the GSL function returns a
;;; condition code, it will insert a check that turns that result into
;;; a CL warning.  For generic functions and methods, it will generate
;;; the interfaces to all the specific GSL functions.

20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40
;;; Required arguments to defmfun:
;;; name        The name of the function being defined in CL
;;; arglist     The CL argument list for the function
;;; gsl-name    A string or list of strings representing the name(s) of
;;;             the GSL function(s)
;;; c-arguments A list of arguments like (symbol c-type)
;;;             (or list of such lists) to the GSL
;;;             functions, including CFFI declarations.
;;;             Anything not in arglist will be allocated.

;;; Keyword arguments to defmfun:
;;; c-return   A symbol naming a type, (e.g. :int, :double, :void),
;;;            or a list of (symbol type) to name the value,
;;;            or :error-code, :number-of-answers, :success-failure,
;;;            :true-false, :enumerate.  If :enumeration is given,
;;;            the :enumeration keyword argument will supply the name
;;;            of the enumeration.
;;; return     A list of quantities to return.
;;;            May be or include :c-return to include the c-return value
;;;            or its derivatives.
;;;            Default are allocated quantities in c-arguments, or :c-return if none.
41
;;; definition :function, :generic, :method, :methods
42
;;; qualifier  A method qualifier such as :after or :before.
43 44 45
;;; element-types
;;;            Permissible types for elements of arrays.  May be
;;;            NIL meaning all of *array-element-types*, :no-complex
46 47 48 49
;;;            meaning that list without the complex types, 
;;;	       :float meaning only the float types, :complex only
;;;	       the complex types, :float-complex both float and complex,
;;;            or a list of element types.
50 51 52 53
;;; index      Name under which this function should be cross-referenced; t
;;;            to use name, nil to not index.
;;; export     Whether to export the symbol.
;;; documentation
54 55 56
;;; inputs     Arrays whose values are used by the GSL function.
;;; outputs    Arrays that are written to in the GSL function.
;;; after      Forms to be evaluated after the foreign call.
57 58
;;; enumeration  The name of the enumeration return.

59
(defmacro defmfun (name arglist gsl-name c-arguments &rest key-args)
60 61 62 63 64 65 66 67 68
  "Definition of a GSL function."
  (expand-defmfun-wrap name arglist gsl-name c-arguments key-args))

;;; Utility for the helper functions
(defmacro with-defmfun-key-args (key-args &body body)
  "Bind defmfun's key arguments."
  `(destructuring-bind
    (&key (c-return :error-code)
     (return nil return-supplied-p)
69
     element-types
70
     (index t)
71
     (definition :function)
72
     (export (not (member definition (list :method :methods))))
73
     documentation inputs outputs after enumeration qualifier)
74 75 76
    ,key-args
    (declare (ignorable c-return return definition element-types
      index export
77
      documentation inputs outputs after enumeration qualifier)
78
     (special indexed-functions))
79 80
    ,@body))

81
(defparameter *defmfun-llk* '(&optional &key))
82 83 84 85 86

(defun llkp (arglist)
  "There is a lambda-list keyword present."
  (intersection *defmfun-llk* arglist))

87
(defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args)
88
  (let (indexed-functions)
89
    (declare (ignorable indexed-functions)) ; workaround for compiler errors that don't see it's used
90 91 92 93 94 95 96
    (with-defmfun-key-args key-args
      (setf indexed-functions (list))
      (wrap-index-export
       (cond
	 ((eq definition :generic)
	  (expand-defmfun-generic name arglist gsl-name c-arguments key-args))
	 ((eq definition :method)
97 98
	  (expand-defmfun-method name arglist gsl-name c-arguments key-args))
	 ((eq definition :methods)
99
	  (expand-defmfun-defmethods name arglist gsl-name c-arguments key-args))
100
	 ((and (llkp arglist) (listp gsl-name))
101 102
	  (expand-defmfun-optional name arglist gsl-name c-arguments key-args))
	 ((eq definition :function)
103
	  (complete-definition 'cl:defun name arglist gsl-name c-arguments key-args)))
104 105 106 107 108 109 110 111 112
       name gsl-name key-args))))

(defun wrap-index-export (definition name gsl-name key-args)
  "Wrap the definition with index and export if requested.
   Use a progn if needed."
  (let ((index-export
	 (with-defmfun-key-args key-args
	   (if (eq index t)
	       (setf index name))
113
	   (flet ((mapnfn (gslnm) `(map-name ',index ,gslnm)))
114 115 116 117
	     (append
	      (when index
		(if indexed-functions
		    (mapcar #'mapnfn indexed-functions)
118 119 120
		    (if (listp gsl-name)
			(mapcar #'mapnfn gsl-name)
			(list (mapnfn gsl-name)))))
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
	      (when export `((export ',name))))))))
    (if index-export
	(if (symbolp (first definition))
	    `(progn ,definition ,@index-export)
	    `(progn ,@definition ,@index-export))
	(if (symbolp (first definition))
	    definition
	    `(progn ,definition ,@index-export)))))

;;;;****************************************************************************
;;;; Test cases
;;;;****************************************************************************

;;; Simple function
#+(or)
(expand-defmfun-wrap
 'airy-Ai '(x)
 "gsl_sf_airy_Ai_e"
139
 '((x :double) (mode sf-mode) (ret sf-result))
140 141 142 143 144 145 146 147
 '(:documentation "The Airy function Ai(x)."))

;;; Generic function and methods of a vector
#+(or)
(expand-defmfun-wrap
 'gsl-zerop
 '((v vector))
 '("gsl_vector" :type "_isnull")
148
 '(((pointer v) :pointer))
149 150 151 152 153 154 155 156 157 158 159
 '(:c-return :boolean
   :definition :generic
   :documentation			; FDL
   "All elements of vector v are zero."))

;;; Generic function and methods of a matrix
#+(or)
(expand-defmfun-wrap
 'gsl-zerop
 '((v matrix))
 '("gsl_" :category :type "_isnull")
160
 '(((pointer v) :pointer))
161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
 '(:c-return :boolean
   :definition :generic
   :documentation			; FDL
   "All elements of v are zero."))

;;; Defgeneric over both matrices and vectors
#+(or)
(expand-defmfun-wrap
 'gsl-zerop
 '((v both))
 '("gsl_" :category :type "_isnull")
 '(((pointer v) (gsl- :category -c)))
 '(:c-return :boolean
   :definition :generic
   :documentation			; FDL
   "All elements of v are zero."))

;;; Methods without generic function declaration
#+(or)
(expand-defmfun-wrap
 'gsl-zerop
 '((v vector))
 '("gsl_vector" :type "_isnull")
184
 '(((pointer v) :pointer))
185
 '(:c-return :boolean
186
   :definition :methods
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
   :documentation			; FDL
   "All elements of vector v are zero."))

;;; Regular function with optional arguments
#+(or)
(expand-defmfun-wrap
 'evaluate-chebyshev
 '(chebyshev x &optional order)
 '("gsl_cheb_eval_err" "gsl_cheb_eval_n_err")
 '(((chebyshev :pointer) (x :double) (result :double) (abserr :double))
   ((chebyshev :pointer) (order size)
    (x :double) (result :double) (abserr :double)))
 '(:documentation			; FDL
   "Evaluate the Chebyshev series at a point x, returning result and
   an estimate of its absolute error."))

;;;;****************************************************************************
204
;;;; A defgeneric with methods, or the methods alone, for vectors or matrices
205 206 207 208 209 210 211 212 213 214 215
;;;;****************************************************************************

(defun expand-defmfun-generic (name arglist gsl-name c-arguments key-args)
  "Define a generic function and methods."
  ;; Need to scan the arglist for categories.
  ;; Can be mixed, unless it says 'both, in which case it can only be both.
  (with-defmfun-key-args key-args
    (multiple-value-bind (noclass-arglist categories)
	(arglist-plain-and-categories arglist)
      `(defgeneric ,name ,noclass-arglist
	(:documentation ,documentation)
216 217 218 219 220 221 222
	,@(if (member 'both categories)
	      (progn 
		(when (> (length categories) 1)
		  ;; Specify 'both alone
		  (error "Internal: mixed both and actual category."))
		;; Generate forms for matrix and vector
		(append
223 224
		 ;; Multiple C arguments for an &optional argument is
		 ;; accomodated with the llkp call.
225 226
		 (generate-methods
		  :method 'vector
227 228
		  name arglist gsl-name
		  (actual-array-c-type 'vector c-arguments (llkp arglist))
Liam Healy's avatar
Liam Healy committed
229
		  (copy-list key-args) 'vector)
230 231
		 (generate-methods
		  :method 'matrix
232 233
		  name arglist gsl-name
		  (actual-array-c-type 'matrix c-arguments (llkp arglist))
Liam Healy's avatar
Liam Healy committed
234
		  (copy-list key-args) 'matrix)))
235 236 237 238
	      ;; Generate forms for one category
	      (generate-methods
	       :method (first categories)
	       name arglist gsl-name c-arguments key-args))))))
239 240 241 242 243 244 245 246 247 248

(defun expand-defmfun-defmethods (name arglist gsl-name c-arguments key-args)
  "Define methods."
  ;; I presume 'both will not occur for pure methods
  (let ((categories (nth-value 1 (arglist-plain-and-categories arglist))))
    (generate-methods
     'cl:defmethod (first categories)
     name arglist gsl-name c-arguments key-args)))

(defun generate-methods
249
    (defn category name arglist gsl-name c-arguments key-args
250 251
     &optional replace-both)
  "Create all the methods for a generic function."
252
  ;; Methods may have &optional in two ways: the optional argument(s)
253
  ;; are defaulted if not supplied and a single GSL function called,
254 255
  ;; or the presence/absence of optional arguments switches between two
  ;; GSL functions.
256 257
  (with-defmfun-key-args key-args
    (mapcar (lambda (eltype)
258 259 260 261 262 263 264 265
	      (flet ((actual-gfn (gslname)
		       (let ((gsl-function-name
			      (actual-gsl-function-name
			       gslname category eltype)))
			 (push gsl-function-name indexed-functions)
			 gsl-function-name)))
		(remf key-args :documentation)
		(when (eq c-return :element-c-type)
266
		  (setf (getf key-args :c-return) (cl-cffi eltype)))
267
		(when (eq c-return :component-float-type)
268
		  (setf (getf key-args :c-return) (component-type eltype)))
269 270 271 272 273 274 275 276 277 278 279 280
		(if (and (llkp arglist) (listp (first gsl-name))) ; ad-hoc detection!
		    ;; The methods have optional argument(s) and
		    ;; multiple GSL functions for presence/absence of
		    ;; options
		    (complete-definition
		     defn
		     (if (eq defn :method) (list nil name) name)
		     (actual-class-arglist arglist eltype replace-both)
		     (mapcar #'actual-gfn gsl-name)
		     (mapcar (lambda (args)
			       (actual-element-c-type eltype args))
			     c-arguments)
281
		     key-args
282
		     'body-optional-arg)
283 284 285 286 287 288 289
		    (complete-definition
		     defn
		     (if (eq defn :method) (list nil name) name)
		     (actual-class-arglist arglist eltype replace-both)
		     (actual-gfn gsl-name)
		     (actual-element-c-type eltype c-arguments)
		     key-args))))
290
	    (element-types element-types))))
291 292

(defun actual-gsl-function-name (base-name category type)
lhealy's avatar
lhealy committed
293 294
  "Create the GSL or BLAS function name for data from the base name
   and the CL type."
295 296 297
  ;; (actual-gsl-function-name
  ;;  '("gsl_" :category :type "_swap") 'vector '(unsigned-byte 16))
  ;; "gsl_vector_ushort_swap"
298 299 300 301 302 303
  (if (listp base-name)
      (if (symbolp (first base-name))
	  ;; An explicit listing of types with function names
	  (getf base-name (cl-single type))
	  (let ((blas (search "blas" (first base-name) :test 'string-equal)))
	    (apply #'concatenate 'string
304
		   (substitute
305 306 307 308 309 310 311 312 313 314 315 316
		    (if (subtypep type 'complex) "_complex" "") :complex
		    (substitute
		     (if (subtypep type 'complex) "u" "") :suffix
		     (substitute
		      (cl-gsl type (not blas) blas) :type
		      (substitute
		       (if (subtypep type 'complex)
			   (cl-gsl (component-float-type type) nil blas)
			   "") :component-float-type
		       (substitute
			(string-downcase (symbol-name category)) :category
			base-name))))))))))
317

318 319 320 321 322 323 324
(defun number-class-from-type (type)
  "Find a class name that contains this type."
  ;; Not exhaustive; just trying to separate reals and complex.
  (cond ((subtypep type 'complex) 'complex)
	((subtypep type 'float) 'float)
	(t (error "Can't pass type ~a." type))))

325 326 327
(defun actual-class-arglist (arglist element-type &optional replace-both)
  "Replace the prototype arglist with an actual arglist."
  (loop for arg in arglist
328 329
     with replacing = t
     do
330
     (when (and replacing (member arg *defmfun-llk*))
331 332 333 334 335
       (setf replacing nil))
     collect
     (if (and replacing (listp arg))
	 (list (first arg)
	       (case (second arg)
Liam Healy's avatar
Liam Healy committed
336
		 (:element-type (number-class-from-type element-type))
337 338 339
		 (:component-float-type
		  (number-class-from-type (component-float-type element-type)))
		 (otherwise
340 341 342 343
		  (data-class-name
		   (if (and (eq (second arg) 'both) replace-both)
		       replace-both
		       (second arg))
344
		   element-type))))
345 346 347 348 349 350 351 352
	 (if (and (listp arg) (numberp (second arg)))
	     ;; optional arg default numerical value
	     (list (first arg)
		   (coerce (second arg) element-type))
	     arg))))

(defun arglist-plain-and-categories
    (arglist &optional (include-llk t))
353 354
  "Get arglist without classes and a list of categories."
  (loop for arg in arglist
355 356 357 358 359 360 361 362 363 364 365 366 367
     with getting-categories = t and categories
     do
     (when (and getting-categories (member arg *defmfun-llk*))
       (setf getting-categories nil))
     (when (and getting-categories (listp arg))
       ;; Collect categories (classes), but not default values to
       ;; optional arugments.
       (pushnew (second arg) categories))
     when (or (not (member arg *defmfun-llk*)) include-llk)
     collect
     (if (listp arg) (first arg) arg)
     into noclass-arglist
     finally (return (values noclass-arglist categories))))
368

369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388
(defun actual-array-c-type (category c-arguments &optional map-down)
  "Replace the declared proto-type with an actual GSL struct type
   in the GSL function name."
  (if map-down
      ;; If there are multiple C argument lists due to an optional
      ;; argument, than map this function onto each.
      (mapcar (lambda (carg) (actual-array-c-type category carg nil))
	      c-arguments)
      (mapcar
       (lambda (v)
	 (if (st-arrayp v)
	     (make-st (st-symbol v)
		      (intern
		       (apply #'concatenate
			      'string
			      (mapcar #'string
				      (substitute category :category (st-type v))))
		       :gsl))
	     v))
       c-arguments)))
389 390 391 392 393 394

(defun actual-element-c-type (element-type c-arguments)
  "Replace the generic element type :element-c-type with the
   actual element type."
  (mapcar 
   (lambda (v)
395 396 397 398
     (if (member (st-type v) '(:element-c-type :component-float-type))
	 (make-st (st-symbol v)
		  (if (eq (st-type v) :component-float-type)
		      (component-type element-type)
399
		      (cl-cffi element-type)))
400 401 402 403 404 405 406 407 408
	 v))
   c-arguments))

;;; (actual-class-arglist '((v1 vector) (v2 vector) (m matrix) x) '(unsigned-byte 16))
;;; ((V1 VECTOR-UNSIGNED-BYTE-16) (V2 VECTOR-UNSIGNED-BYTE-16)
;;;  (M MATRIX-UNSIGNED-BYTE-16) X)
;;; (V1 V2 M X)
;;; (MATRIX VECTOR)

409
;;;;****************************************************************************
410
;;;; A method for a generic function, on any class
411 412 413 414 415
;;;;****************************************************************************

(defun expand-defmfun-method (name arglist gsl-name c-arguments key-args)
  "Create a specific method for a previously-defined generic function."
  (with-defmfun-key-args key-args
416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432
    (if (listp gsl-name)
	(mapc (lambda (n) (push n indexed-functions)) gsl-name)
	(push gsl-name indexed-functions))
    (with-defmfun-key-args key-args
      (remf key-args :documentation)
      (complete-definition
       'cl:defmethod
       name
       arglist
       gsl-name
       c-arguments
       key-args
       (if (and (llkp arglist) (listp gsl-name))
	   ;; Even though it might have optional arguments, if there
	   ;; is only one GSL function, we use 'body-no-optional-arg.
	   'body-optional-arg 'body-no-optional-arg)
       (listp gsl-name)))))
433

434 435 436 437 438 439 440 441
;;;;****************************************************************************
;;;; Optional argument(s)
;;;;****************************************************************************

(defun expand-defmfun-optional
    (name arglist gsl-name c-arguments key-args)
  "Expand defmfun where there is an optional argument
   present, giving the choice between two different GSL functions."
442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466
  (complete-definition 'cl:defun name arglist gsl-name c-arguments key-args
		       'body-optional-arg))

(defun body-optional-arg
    (name arglist gsl-name c-arguments key-args)
  "Create the body of a defmfun with &optional in its arglist,
   where the presence or absence of the optional argument(s)
   selects one of two GSL functions."
  (let ((optpos (position '&optional arglist)))
    (if optpos
	(let ((mandatory-arglist (subseq arglist 0 optpos))
	      (optional-arglist (subseq arglist (1+ optpos))))
	  `(if ,(first optional-arglist)
	       ,(body-no-optional-arg 
		 name
		 (append mandatory-arglist optional-arglist)
		 (second gsl-name)
		 (second c-arguments)
		 key-args)
	       ,(body-no-optional-arg
		 name
		 mandatory-arglist
		 (first gsl-name)
		 (first c-arguments)
		 key-args))))))
467 468 469 470 471

;;;;****************************************************************************
;;;; A single function
;;;;****************************************************************************

472 473 474 475 476 477
(defun defgeneric-method-p (name)
  "When defining :method in a defgeneric, (nil foo) is used for
   the name, and foo will be returned from this function."
  (if (and (listp name) (null (first name)))
      (second name)))

478 479 480 481 482
(defun complex-scalars (cl-arguments c-arguments-types)
  (loop for sd in c-arguments-types
	for cl-type = (cffi-cl (st-type sd))
	append
	(when (and cl-type (subtypep cl-type 'complex)
483 484
		   (member (st-symbol sd)
			   (arglist-plain-and-categories cl-arguments)))
485 486 487 488
	  (list (list (st-symbol sd)
		      (gensym (string (st-symbol sd)))
		      (st-type sd))))))

489 490 491 492 493 494 495 496 497 498 499
(defun stupid-code-walk-find-variables (sexp)
  "This will work with the simplest s-expression forms only to find
   variables used."
  (labels ((scwfv (sexp)
	     (if (atom sexp)
		 (when (and (symbolp sexp)
			    (not (eql (symbol-package sexp)
				      (find-package :keyword))))
		   (list sexp))
		 (unless (member (first sexp) '(quote))
		   (mapcan #'scwfv (rest sexp))))))
500
    (remove nil (remove-duplicates (scwfv sexp)))))
501 502

(defun variables-used-in-c-arguments (c-arguments)
503 504
  "Find the arguments passed to the C function.  This is a poor
  quality code walker, but is sufficient for actual usage of defmfun."
505
  (remove-duplicates
506 507
   (mapcan (lambda (carg)
	     (stupid-code-walk-find-variables (st-symbol carg)))
508 509
	   c-arguments)
   :from-end t))
510

511 512 513 514 515 516 517 518
(defun native-pointer (array-symbols body)
  "Wrap the body with a form that obtains the native pointer
   and protects it during execution of the body."
  (if array-symbols
      ;; http://www.sbcl.org/manual/Calling-Lisp-From-C.html
      (native-pointer-protect array-symbols body)
      body))

519 520
(defun complete-definition
    (definition name arglist gsl-name c-arguments key-args
521 522 523
     &optional
     (body-maker 'body-no-optional-arg)
     (mapdown (eq body-maker 'body-optional-arg)))
524 525
  "A complete definition form, starting with defun, :method, or defmethod."
  (destructuring-bind
526
	(&key documentation inputs outputs after qualifier &allow-other-keys) key-args
527
    (declare (ignorable inputs outputs)) ; workaround for compiler errors that don't see it's used
528
    `(,definition
529 530
	 ,@(when (and name (not (defgeneric-method-p name)))
		 (list name))
531
	 ,@(when qualifier (list qualifier))
532
       ,arglist
533 534 535
       ,(declaration-form
	 (cl-argument-types arglist c-arguments)
	 (set-difference (arglist-plain-and-categories arglist nil)
536 537 538 539 540 541 542
			 (union
			  (if mapdown
			      (apply 'union
				     (mapcar 'variables-used-in-c-arguments c-arguments))
			      (variables-used-in-c-arguments c-arguments))
			  ;; Forms in :after are checked for used variables
			  (stupid-code-walk-find-variables (cons 'values after)))))
543
       ,@(when documentation (list documentation))
544 545 546 547 548 549
       #-native
       ,(funcall body-maker name arglist gsl-name c-arguments key-args)
       #+native
       ,(native-pointer
	 (union inputs outputs)
	 (funcall body-maker name arglist gsl-name c-arguments key-args)))))
550

551
(defun body-no-optional-arg (name arglist gsl-name c-arguments key-args)
552 553 554
  "Expand the body (computational part) of the defmfun."
  (with-defmfun-key-args key-args
    (let* ((cret-type (if (member c-return *special-c-return*)
555 556 557 558
			  :int
			  (if (listp c-return) (st-type c-return) c-return)))
	   (cret-name
	    (if (listp c-return) (st-symbol c-return) (make-symbol "CRETURN")))
559
	   (complex-args (complex-scalars arglist c-arguments))
560 561 562
	   (allocated		     ; Foreign objects to be allocated
	    (remove-if
	     (lambda (s)
563
	       (member s (arglist-plain-and-categories arglist nil)))
564
	     (variables-used-in-c-arguments c-arguments)))
565
	   (allocated-decl
566 567
	    (append
	     (mapcar
568
	      (lambda (s) (find s c-arguments :key #'st-symbol))
569
	      allocated)))
570 571 572 573 574
	   (clret (or			; better as a symbol macro
		   (substitute cret-name :c-return return)
		   (mapcan #'cl-convert-form allocated-decl)
		   outputs
		   (unless (eq c-return :void)
575
		     (list cret-name)))))
576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605
      `(,@(if (or allocated-decl complex-args)
	      `(cffi:with-foreign-objects
		   ,(mapcar #'wfo-declare
			    (append allocated-decl 
				    (mapcar #'rest complex-args))))
	      '(let ()))
	  #-native ,@(mapcar (lambda (v) `(copy-cl-to-c ,v)) inputs)
	  (let ((,cret-name
		 (cffi:foreign-funcall
		  ,gsl-name
		  ,@(mapcan
		     (lambda (arg)
		       (let ((cfind	; variable is complex
			      (first (member (st-symbol arg) complex-args :key 'first))))
			 (if cfind ; so substitute call to complex-to-gsl
			     `(,(third cfind)
				(complex-to-gsl ,(first cfind) ,(second cfind)))
			     ;; otherwise use without conversion
			     (list (if (member (st-symbol arg) allocated)
				       :pointer
				       (st-type arg))
				   (st-symbol arg)))))
		     c-arguments)
		  ,cret-type)))
	    ,@(case c-return
		    (:void `((declare (ignore ,cret-name))))
		    (:error-code	; fill in arguments
		     `((check-gsl-status ,cret-name
					 ',(or (defgeneric-method-p name) name)))))
	    #-native
606
	    ,@(when outputs (mapcar (lambda (x) `(setf (cl-invalid ,x) t)) outputs))
607
	    ,@(when (eq cret-type :pointer)
608 609
		    `((check-null-pointer
		       ,cret-name
610
		       ,@'('memory-allocation-failure "No memory allocated."))))
611 612 613 614 615
	    ,@after
	    (values
	     ,@(defmfun-return
		c-return cret-name clret allocated return return-supplied-p
		enumeration outputs)))))))
616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645

(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
     (mapcan
      (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)
646
		 (not outputs)
647 648 649 650
		 (not allocated)
		 (not return-supplied-p))
	    (and (null return) return-supplied-p))
	 clret))))