Skip to content
Snippets Groups Projects
Commit e098af31 authored by Liam Healy's avatar Liam Healy
Browse files

Merge and clean up the changes to defmfun

Merge and clean up the changes to defmfun.
parent dfda5c5b
No related branches found
No related tags found
No related merge requests found
;; Macro for defining GSL functions. ;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2008-08-17 16:27:48EDT defmfun.lisp> ;; Time-stamp: <2008-08-17 16:50:24EDT defmfun.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -71,6 +71,12 @@ ...@@ -71,6 +71,12 @@
(special indexed-functions)) (special indexed-functions))
,@body)) ,@body))
(defparameter *defmfun-llk* '(&optional))
(defun llkp (arglist)
"There is a lambda-list keyword present."
(intersection *defmfun-llk* arglist))
(defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args) (defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args)
(let (indexed-functions) (let (indexed-functions)
(with-defmfun-key-args key-args (with-defmfun-key-args key-args
...@@ -83,7 +89,7 @@ ...@@ -83,7 +89,7 @@
(expand-defmfun-method name arglist gsl-name c-arguments key-args)) (expand-defmfun-method name arglist gsl-name c-arguments key-args))
((eq definition :methods) ((eq definition :methods)
(expand-defmfun-defmethods name arglist gsl-name c-arguments key-args)) (expand-defmfun-defmethods name arglist gsl-name c-arguments key-args))
((and (member '&optional arglist) (listp gsl-name)) ((and (llkp arglist) (listp gsl-name))
(expand-defmfun-optional name arglist gsl-name c-arguments key-args)) (expand-defmfun-optional name arglist gsl-name c-arguments key-args))
((eq definition :function) ((eq definition :function)
(complete-definition 'cl:defun name arglist gsl-name c-arguments key-args))) (complete-definition 'cl:defun name arglist gsl-name c-arguments key-args)))
...@@ -229,24 +235,43 @@ ...@@ -229,24 +235,43 @@
(defn category name arglist gsl-name c-arguments key-args (defn category name arglist gsl-name c-arguments key-args
&optional replace-both) &optional replace-both)
"Create all the methods for a generic function." "Create all the methods for a generic function."
;; Methods may have &optional in two ways: the optional argument(s)
;; are defaulted if not supplied and a single GSL function called,
;; or the presence/absence of optional arguments switches between two
;; GSL functions.
(with-defmfun-key-args key-args (with-defmfun-key-args key-args
(mapcar (lambda (eltype) (mapcar (lambda (eltype)
(remf key-args :documentation) (flet ((actual-gfn (gslname)
(when (eq c-return :element-c-type) (let ((gsl-function-name
(setf (getf key-args :c-return) (cl-ffa eltype))) (actual-gsl-function-name
(when (eq c-return :component-float-type) gslname category eltype)))
(setf (getf key-args :c-return) (cl-ffa (component-type eltype)))) (push gsl-function-name indexed-functions)
(complete-definition gsl-function-name)))
defn (remf key-args :documentation)
(if (eq defn :method) (list nil name) name) (when (eq c-return :element-c-type)
(actual-class-arglist arglist eltype replace-both) (setf (getf key-args :c-return) (cl-ffa eltype)))
(let ((gsl-function-name (when (eq c-return :component-float-type)
(actual-gsl-function-name (setf (getf key-args :c-return) (cl-ffa (component-type eltype))))
gsl-name category eltype))) (if (and (llkp arglist) (listp (first gsl-name))) ; ad-hoc detection!
(push gsl-function-name indexed-functions) ;; The methods have optional argument(s) and
gsl-function-name) ;; multiple GSL functions for presence/absence of
(actual-element-c-type eltype c-arguments) ;; options
key-args)) (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)
key-args)
(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))))
(case element-types (case element-types
((nil t) *array-element-types*) ((nil t) *array-element-types*)
(:no-complex *array-element-types-no-complex*) (:no-complex *array-element-types-no-complex*)
...@@ -294,7 +319,7 @@ ...@@ -294,7 +319,7 @@
(loop for arg in arglist (loop for arg in arglist
with replacing = t with replacing = t
do do
(when (and replacing (member arg '(&optional))) (when (and replacing (member arg *defmfun-llk*))
(setf replacing nil)) (setf replacing nil))
collect collect
(if (and replacing (listp arg)) (if (and replacing (listp arg))
...@@ -315,8 +340,6 @@ ...@@ -315,8 +340,6 @@
(coerce (second arg) element-type)) (coerce (second arg) element-type))
arg)))) arg))))
(defparameter *defmfun-llk* '(&optional))
(defun arglist-plain-and-categories (defun arglist-plain-and-categories
(arglist &optional (include-llk t)) (arglist &optional (include-llk t))
"Get arglist without classes and a list of categories." "Get arglist without classes and a list of categories."
...@@ -402,21 +425,23 @@ ...@@ -402,21 +425,23 @@
(optional-arglist (subseq arglist (1+ optpos)))) (optional-arglist (subseq arglist (1+ optpos))))
(remf key-args :documentation) (remf key-args :documentation)
(setf indexed-functions gsl-name) (setf indexed-functions gsl-name)
`((defun ,name ,arglist (let ((body
,documentation `(if ,(first optional-arglist)
(if ,(first optional-arglist) ,(expand-defmfun-body
,(expand-defmfun-body nil
name (append mandatory-arglist optional-arglist)
(append mandatory-arglist optional-arglist) (second gsl-name)
(second gsl-name) (second c-arguments)
(second c-arguments) key-args)
key-args) ,(expand-defmfun-body
,(expand-defmfun-body nil
name mandatory-arglist
mandatory-arglist (first gsl-name)
(first gsl-name) (first c-arguments)
(first c-arguments) key-args))))
key-args))))))))) (if (defgeneric-method-p name)
body
`((defun ,name ,arglist ,documentation ,@body)))))))))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; A single function ;;;; A single function
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment