From d0b630222770621bf9f7a27ecba42409ecd3891f Mon Sep 17 00:00:00 2001 From: Liam Healy <liam@thinkpad.local> Date: Sat, 3 Jan 2009 09:51:36 -0500 Subject: [PATCH] New #'optional-args-to-switch-gsl-functions used by defmfun Instead of relying on repeated and varying checks using llkp, the new function #'optional-args-to-switch-gsl-functions provides a uniform test for determining when presence/absence of optional arguments in the defmfun form require a switch between different GSL functions. All the same test results in 64-bit CCL and SBCL. --- init/defmfun.lisp | 78 +++++++++++++++++++++++++---------------------- 1 file changed, 42 insertions(+), 36 deletions(-) diff --git a/init/defmfun.lisp b/init/defmfun.lisp index 9cdef77d..df4bf648 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-12-31 12:29:44EST defmfun.lisp> +;; Time-stamp: <2009-01-01 18:14:27EST defmfun.lisp> ;; $Id$ (in-package :gsl) @@ -78,15 +78,21 @@ (special indexed-functions)) ,@body)) -(defparameter *defmfun-llk* '(&optional &key)) +(defparameter *defmfun-llk* '(&optional &key) "Possible lambda-list keywords.") -(defun llkp (arglist) - "There is a lambda-list keyword present." - (intersection *defmfun-llk* arglist)) +(defun optional-args-to-switch-gsl-functions (arglist gsl-name) + "The presence/absence of optional arguments will switch between the + first and second listed GSL function names." + (and (intersection *defmfun-llk* arglist) + (listp gsl-name) + (or + (every 'stringp gsl-name) + (listp (first gsl-name))))) (defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args) (let (indexed-functions) - (declare (ignorable indexed-functions)) ; workaround for compiler errors that don't see it's used + ;; workaround for compiler errors that don't see 'indexed-function is used + (declare (ignorable indexed-functions)) (with-defmfun-key-args key-args (setf indexed-functions (list)) (wrap-index-export @@ -97,7 +103,7 @@ (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 (llkp arglist) (listp gsl-name)) + ((optional-args-to-switch-gsl-functions arglist gsl-name) (expand-defmfun-optional name arglist gsl-name c-arguments key-args)) ((eq definition :function) (complete-definition 'cl:defun name arglist gsl-name c-arguments key-args))) @@ -139,30 +145,32 @@ (multiple-value-bind (noclass-arglist categories) (arglist-plain-and-categories arglist) `(defgeneric ,name ,noclass-arglist - (:documentation ,documentation) - ,@(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 - ;; Multiple C arguments for an &optional argument is - ;; accomodated with the llkp call. - (generate-methods - :method 'vector - name arglist gsl-name - (actual-array-c-type 'vector c-arguments (llkp arglist)) - (copy-list key-args) 'vector) - (generate-methods - :method 'matrix - name arglist gsl-name - (actual-array-c-type 'matrix c-arguments (llkp arglist)) - (copy-list key-args) 'matrix))) - ;; Generate forms for one category - (generate-methods - :method (first categories) - name arglist gsl-name c-arguments key-args)))))) + (:documentation ,documentation) + ,@(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 + (generate-methods + :method 'vector + name arglist gsl-name + (actual-array-c-type + 'vector c-arguments + (optional-args-to-switch-gsl-functions arglist gsl-name)) + (copy-list key-args) 'vector) + (generate-methods + :method 'matrix + name arglist gsl-name + (actual-array-c-type + 'matrix c-arguments + (optional-args-to-switch-gsl-functions arglist gsl-name)) + (copy-list key-args) 'matrix))) + ;; Generate forms for one category + (generate-methods + :method (first categories) + name arglist gsl-name c-arguments key-args)))))) (defun expand-defmfun-defmethods (name arglist gsl-name c-arguments key-args) "Define methods." @@ -193,7 +201,7 @@ (setf (getf key-args :c-return) (cl-cffi eltype))) (when (eq c-return :component-float-type) (setf (getf key-args :c-return) (component-type eltype))) - (if (and (llkp arglist) (listp (first gsl-name))) ; ad-hoc detection! + (if (optional-args-to-switch-gsl-functions arglist gsl-name) ;; The methods have optional argument(s) and ;; multiple GSL functions for presence/absence of ;; options @@ -298,7 +306,7 @@ 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. + ;; argument, then map this function onto each. (mapcar (lambda (carg) (actual-array-c-type category carg nil)) c-arguments) (mapcar @@ -352,9 +360,7 @@ 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. + (if (optional-args-to-switch-gsl-functions arglist gsl-name) 'body-optional-arg 'body-no-optional-arg) (listp gsl-name))))) -- GitLab