diff --git a/init/defmfun.lisp b/init/defmfun.lisp index 54c95a9658e7a72106f4e33fcb6e98f89f77b29a..55253c0ae6e2b3d34558ef2cdaf9f58a571fd756 100644 --- a/init/defmfun.lisp +++ b/init/defmfun.lisp @@ -1,6 +1,6 @@ ;; Macro for defining GSL functions. ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp -;; Time-stamp: <2008-08-03 23:27:25EDT defmfun.lisp> +;; Time-stamp: <2008-08-07 21:09:31EDT defmfun.lisp> ;; $Id$ (in-package :gsl) @@ -81,17 +81,17 @@ (setf indexed-functions (list)) (wrap-index-export (cond - ((and (member '&optional arglist) (listp gsl-name)) - (expand-defmfun-optional name arglist gsl-name c-arguments key-args)) - ((eq definition :function) - (setf defn 'cl:defun) - (expand-defmfun-plain name arglist gsl-name c-arguments key-args)) ((eq definition :generic) (expand-defmfun-generic name arglist gsl-name c-arguments key-args)) ((eq definition :method) (expand-defmfun-method name arglist gsl-name c-arguments key-args)) ((eq definition :methods) (expand-defmfun-defmethods name arglist gsl-name c-arguments key-args)) + ((and (member '&optional arglist) (listp gsl-name)) + (expand-defmfun-optional name arglist gsl-name c-arguments key-args)) + ((eq definition :function) + (setf defn 'cl:defun) + (expand-defmfun-plain name arglist gsl-name c-arguments key-args)) (t (expand-defmfun-plain name arglist gsl-name c-arguments key-args))) name gsl-name key-args)))) @@ -311,21 +311,31 @@ replace-both (second arg)) element-type)))) - arg))) + (if (and (listp arg) (numberp (second arg))) + ;; optional arg default numerical value + (list (first arg) + (coerce (second arg) element-type)) + arg)))) + +(defparameter *defmfun-llk* '(&optional)) -(defun arglist-plain-and-categories (arglist) +(defun arglist-plain-and-categories + (arglist &optional (include-llk t)) "Get arglist without classes and a list of categories." (loop for arg in arglist - with replacing = t and categories - do - (when (and replacing (member arg '(&optional))) - (setf replacing nil)) - (when (and replacing (listp arg)) - (pushnew (second arg) categories)) - collect - (if (and replacing (listp arg)) (first arg) arg) - into noclass-arglist - finally (return (values noclass-arglist categories)))) + 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)))) (defun actual-array-c-type (category c-arguments) "Replace the declared proto-type with an actual GSL struct type." @@ -438,16 +448,24 @@ (gensym (string (st-symbol sd))) (st-type sd)))))) +(defun c-arguments (c-arguments) + "Find the arguments passed to the C function. This is a poor + quality code walker, but is sufficient for actual usage of defmfun." + (mapcan (lambda (s) + (let ((val (st-symbol s))) + (if (listp val) + ;; walk only a top-level function call + (copy-list (rest val)) + (list val)))) + (remove :mode c-arguments))) + (defun expand-defmfun-plain (name arglist gsl-name c-arguments key-args) + "The main function for expansion of defmfun." (with-defmfun-key-args key-args (let* ((cargs (substitute '(mode sf-mode) :mode c-arguments)) - (carg-symbs - (remove-if-not #'symbolp - (mapcar #'st-symbol (remove :mode c-arguments)))) + (carg-symbs (c-arguments cargs)) (clargs (or arglist carg-symbs)) - (arglist-symbs - (when arglist ; can be method, so get symbol - (mapcar (lambda (x) (if (listp x) (first x) x)) arglist))) + (arglist-symbs (arglist-plain-and-categories arglist nil)) (cret-type (if (member c-return *special-c-return*) :int (if (listp c-return) (st-type c-return) c-return))) @@ -481,7 +499,8 @@ (if global (append noaux (cons '&aux global)) noaux)) - ,(declaration-form clargs-types) + ,(declaration-form + clargs-types (set-difference arglist-symbs carg-symbs)) ,@(when documentation (list documentation)) (,@(if (or allocated-decl complex-args) `(cffi:with-foreign-objects diff --git a/init/interface.lisp b/init/interface.lisp index 85e218d3a9fb9e026ad1e712b6baa51ecf94399a..54bd2cd0108c0f268632c60a2b0439e7ede7ad83 100644 --- a/init/interface.lisp +++ b/init/interface.lisp @@ -1,6 +1,6 @@ ;; Macros to interface GSL functions, including definitions necessary for defmfun. ;; Liam Healy -;; Time-stamp: <2008-07-10 21:39:43EDT interface.lisp> +;; Time-stamp: <2008-08-07 20:53:59EDT interface.lisp> ;; $Id$ (in-package :gsl) @@ -107,9 +107,12 @@ (when (and cl-type (member (st-symbol sd) (cl-symbols cl-arguments))) (list (list (st-symbol sd) cl-type))))) -(defun declaration-form (cl-argument-types) +(defun declaration-form (cl-argument-types &optional ignores) (cons 'declare - (mapcar (lambda (v) (cons 'type (reverse v))) cl-argument-types))) + (append + (mapcar (lambda (v) (cons 'type (reverse v))) + cl-argument-types) + (when ignores (list (cons 'ignore ignores)))))) ;;;;**************************************************************************** ;;;; Returns