Commit d2018a78 authored by Liam Healy's avatar Liam Healy

Split defmfun.lisp; modify index.html

Split out defmfun into three files because it was getting unwieldy.
Small rearrangement of documentation with an update to adsf
instructions.  64 bit tests results as before.
parent 61b839e8
......@@ -96,7 +96,7 @@ complex conjugate scalar product</a> of two complex vectors of length 3:
#2m(49.27d0 -13.49d0 32.5d0 42.73d0 -17.24d0 43.31d0))
#C(-2940.2118d0 1861.9380999999998d0)
</pre>
<p>There are many examples available from within GSLL with the
<p>There are over 1200 examples available from within GSLL with the
function <code>examples</code>. These examples also serve
as a test suite for GSLL.
......@@ -123,13 +123,6 @@ foreign-funcall support will work
in Debian/Ubuntu)</li>
<li><a href="http://www.cliki.net/asdf">ASDF</a></li></ul>
<p>
You will need to make a link of <code>gsll.asd</code> and
optionally <code>gsll-tests.asd</code> to some directory known to ASDF.
Then in Lisp, load the system:
<pre>(asdf:operate 'asdf:compile-op :gsll)</pre>
<p>and if you wish to run the test suite,
<pre>(asdf:operate 'asdf:compile-op :gsll-tests)</pre>
<p>GSLL has been tested with
<a href="http://sbcl.sourceforge.net/">SBCL</a>
and
......@@ -141,15 +134,23 @@ Then in Lisp, load the system:
are some known failures; see the file documentation/status.text.
</p>
<h2>Download</h2>
<h2>Download and Install</h2>
<a name="getit"/>
<p>Use <a href="http://git.or.cz">git</a> to install:
<p>Use <a href="http://git.or.cz">git</a> to download:
<pre>
git clone git://repo.or.cz/gsll.git
</pre>
<p>The <a href="http://repo.or.cz/w/gsll.git"> repository web page</a>
can be used to browse or retrieve a compressed tarball (click the most
recent "snapshot" link). This software is distributed under
recent "snapshot" link).
You will need to make a link of <code>gsll.asd</code> and
optionally <code>gsll-tests.asd</code> to some directory known to ASDF.
Then in Lisp, load the system:
<pre>(asdf:operate 'asdf:load-op :gsll)</pre>
<p>and if you wish to run the test suite,
<pre>(asdf:operate 'asdf:load-op :gsll-tests)</pre>
<p>
This software is distributed under
the <a href="http://www.cliki.net/LLGPL">LLGPL</a>
and <a href="http://www.gnu.org/copyleft/fdl.html">FDL</a>; see
the file COPYING. There is absolutely no warranty.</p>
......@@ -316,7 +317,7 @@ version should still be considered alpha.
<!-- Created: Feb 25 2005 -->
<!-- hhmts start -->
<small>
Time-stamp: <2009-01-03 22:40:07EST index.html>
Time-stamp: <2009-01-07 22:25:08EST index.html>
</small>
<!-- hhmts end -->
</div>
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2009-01-04 21:44:14EST gsll.asd>
;; Time-stamp: <2009-01-07 22:09:19EST gsll.asd>
;; $Id$
(asdf:defsystem "gsll"
......@@ -22,6 +22,8 @@
(:file "interface"
:depends-on (init conditions element-types number-conversion))
(:file "defmfun" :depends-on (init element-types interface))
(:file "defmfun-array" :depends-on (defmfun))
(:file "defmfun-single" :depends-on (defmfun))
(:file "callback" :depends-on (init))
(:file "generate-examples" :depends-on (init))))
(:module floating-point
......
;; Helpers for defining GSL functions on arrays
;; Liam Healy 2009-01-07 22:01:16EST defmfun-array.lisp
;; Time-stamp: <2009-01-07 22:01:56EST defmfun-array.lisp>
;; $Id: $
(in-package :gsl)
;;;;****************************************************************************
;;;; A defgeneric with methods, or the methods alone, for vectors or matrices
;;;;****************************************************************************
(defun expand-defmfun-arrays
(defn name arglist gsl-name c-arguments categories key-args)
(setf categories
(remove-if-not
(lambda (c) (member c '(both matrix vector)))
categories))
(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
defn '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
defn '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
defn (first categories)
name arglist gsl-name c-arguments key-args)))
(defun expand-defmfun-generic (name arglist gsl-name c-arguments key-args)
"Define a generic function and methods for all kinds of arrays."
;; 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)
,@(expand-defmfun-arrays
:method name arglist gsl-name c-arguments categories key-args)))))
(defun expand-defmfun-defmethods (name arglist gsl-name c-arguments key-args)
"Define methods for all kinds of arrays."
(let ((categories (nth-value 1 (arglist-plain-and-categories arglist))))
(expand-defmfun-arrays
'cl:defmethod name arglist gsl-name c-arguments categories key-args)))
(defun generate-methods
(defn category name arglist gsl-name c-arguments key-args
&optional replace-both)
"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
(mapcar (lambda (eltype)
(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)
(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 (optional-args-to-switch-gsl-functions arglist gsl-name)
;; 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)
key-args
'body-optional-arg)
(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))))
(element-types element-types))))
(defun actual-gsl-function-name (base-name category type)
"Create the GSL or BLAS function name for data from the base name
and the CL type."
;; (actual-gsl-function-name
;; '("gsl_" :category :type "_swap") 'vector '(unsigned-byte 16))
;; "gsl_vector_ushort_swap"
(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
(substitute
(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))))))))))
(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))))
(defun actual-class-arglist (arglist element-type &optional replace-both)
"Replace the prototype arglist with an actual arglist."
(loop for arg in arglist
with replacing = t
do
(when (and replacing (member arg *defmfun-llk*))
(setf replacing nil))
collect
(if (and replacing (listp arg))
(list (first arg)
(case (second arg)
(:element-type (number-class-from-type element-type))
(:component-float-type
(number-class-from-type (component-float-type element-type)))
(otherwise
(data-class-name
(if (and (eq (second arg) 'both) replace-both)
replace-both
(second arg))
element-type))))
(cond ((and (listp arg) (numberp (second arg)))
;; Optional arg default numerical value
(list (first arg)
(coerce (second arg) element-type)))
((and (listp arg) (eql (second arg) :make-marray))
;; Optional arg replace class
(list (first arg)
`(make-marray ',element-type
:dimensions ,(fourth arg))))
((and (listp arg) (> (length arg) 4))
;; Optional arg switch default based on element type
(list (first arg)
(loop for (type sexp) on (rest arg) by #'cddr
until (subtypep element-type type)
finally (return sexp))))
(t arg)))))
(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 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 &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, then 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)))
(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)
(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)
(cl-cffi element-type)))
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)
;; Helpers that define a single GSL function interface
;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp
;; Time-stamp: <2009-01-07 22:07:52EST defmfun-single.lisp>
;; $Id: $
(in-package :gsl)
;;;;****************************************************************************
;;;; A single function
;;;;****************************************************************************
(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)))
(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)
(member (st-symbol sd)
(arglist-plain-and-categories cl-arguments)))
(list (list (st-symbol sd)
(gensym (string (st-symbol sd)))
(st-type sd))))))
(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))))))
(remove nil (remove-duplicates (scwfv sexp)))))
(defun variables-used-in-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."
(remove-duplicates
(mapcan (lambda (carg)
(stupid-code-walk-find-variables (st-symbol carg)))
c-arguments)
:from-end t))
#+native
(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))
(defun complete-definition
(definition name arglist gsl-name c-arguments key-args
&optional
(body-maker 'body-no-optional-arg)
(mapdown (eq body-maker 'body-optional-arg)))
"A complete definition form, starting with defun, :method, or defmethod."
(destructuring-bind
(&key documentation inputs outputs before after
qualifier gsl-version &allow-other-keys)
key-args
(declare (ignorable inputs outputs)) ; workaround for compiler errors that don't see it's used
(if (or (not gsl-version) (apply 'have-at-least-gsl-version gsl-version))
`(,definition
,@(when (and name (not (defgeneric-method-p name)))
(list name))
,@(when qualifier (list qualifier))
,arglist
,(declaration-form
(cl-argument-types arglist c-arguments)
(set-difference
(arglist-plain-and-categories arglist nil)
(union
(if mapdown
(apply 'union
(mapcar 'variables-used-in-c-arguments c-arguments))
(variables-used-in-c-arguments c-arguments))
;; Forms in :before, :after are checked for used variables
(stupid-code-walk-find-variables
(cons 'values (append before after))))))
,@(when documentation (list documentation))
#-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)))
`(,definition
,@(when (and name (not (defgeneric-method-p name)))
(list name))
,@(when qualifier (list qualifier))
(&rest args)
(declare (ignore args))
(error
,(apply 'format
nil
"Function ~a (~a) is not available in your current version ~
~a of GSL; it was introduced in version ~d.~d."
name gsl-name *gsl-version* gsl-version))))))
(defun body-no-optional-arg (name arglist gsl-name c-arguments key-args)
"Expand the body (computational part) of the defmfun."
(with-defmfun-key-args key-args
(let* ((cret-type (if (member c-return *special-c-return*)
:int
(if (listp c-return) (st-type c-return) c-return)))
(cret-name
(if (listp c-return) (st-symbol c-return) (make-symbol "CRETURN")))
(complex-args (complex-scalars arglist c-arguments))
(allocated ; Foreign objects to be allocated
(remove-if
(lambda (s)
(member s (arglist-plain-and-categories arglist nil)))
(variables-used-in-c-arguments c-arguments)))
(allocated-decl
(mapcar
(lambda (s) (find s c-arguments :key #'st-symbol))
allocated))
(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)
(list cret-name)))))
`(,@(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)
,@before
(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
,@(when outputs
(mapcar
(lambda (x) `(setf (cl-invalid ,x) t (c-invalid ,x) nil))
outputs))
,@(when (eq cret-type :pointer)
`((check-null-pointer
,cret-name
,@'('memory-allocation-failure "No memory allocated."))))
,@after
(values
,@(defmfun-return
c-return cret-name clret allocated return return-supplied-p
enumeration outputs)))))))
(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)
(not outputs)
(not allocated)
(not return-supplied-p))
(and (null return) return-supplied-p))
clret))))
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment