Commit a945e9c1 authored by lhealy's avatar lhealy Committed by Liam Healy

Start BLAS port, so make appopriate generalization to element type

mapping and #'actual-gsl-function-name.


git-svn-id: svn+ssh://common-lisp.net/project/gsll/svn/branches/ffa@69 af03a46b-e846-0410-96e5-d5653c316fd0
parent f1facf7e
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2008-07-08 21:37:09EDT defmfun.lisp>
;; Time-stamp: <2008-07-17 22:46:01EDT defmfun.lisp>
;; $Id$
(in-package :gsl)
......@@ -254,6 +254,8 @@
(case element-types
((nil t) *array-element-types*)
(:no-complex *array-element-types-no-complex*)
(:float *float-types*)
(:float-complex *float-complex-types*)
(t element-types)))))
(defun actual-gsl-function-name (base-name category type)
......@@ -261,13 +263,19 @@
;; (actual-gsl-function-name
;; '("gsl_" :category :type "_swap") 'vector '(unsigned-byte 16))
;; "gsl_vector_ushort_swap"
(if (listp base-name)
(apply #'concatenate 'string
(substitute (cl-gsl type t) :type
(substitute
(string-downcase (symbol-name category))
:category
base-name)))))
(let ((blas (search "blas" (first base-name) :test 'string-equal)))
(if (listp base-name)
(apply #'concatenate 'string
(substitute
(if (subtypep type 'complex) "u" "") :suffix
(substitute
(cl-gsl type t blas) :type
(substitute
(string-downcase (symbol-name category))
:category
base-name)))))))
(defun blas-name-final-token ())
(defun actual-class-arglist (arglist element-type &optional replace-both)
"Replace the prototype arglist with an actual arglist."
......
;; Mapping of element type names
;; Liam Healy 2008-04-13 11:22:46EDT element-types.lisp
;; Time-stamp: <2008-07-12 14:21:59EDT element-types.lisp>
;; Time-stamp: <2008-07-17 22:29:47EDT element-types.lisp>
;; $Id$
;;; The different element type forms:
......@@ -97,6 +97,12 @@
in the C standard; in that case, the C type is the GSL struct
definition.")
(defmacro floating-point-association (splice-list)
`(mapcar
#'cons
(mapcar #'first *fp-type-mapping*)
(subseq ,splice-list 0 (length *fp-type-mapping*))))
(defparameter *cstd-gsl-mapping*
(append
;; The integer types
......@@ -120,12 +126,23 @@
;; The floating types are associated by order, so it is important that
;; order of *fp-type-mapping* and *gsl-splice-fp-types* match,
;; though the latter may be longer.
(mapcar
#'cons
(mapcar #'first *fp-type-mapping*)
(subseq *gsl-splice-fp-types* 0 (length *fp-type-mapping*))))
(floating-point-association *gsl-splice-fp-types*))
"Mapping the C standard types to the GSL splice name.")
(defparameter *blas-splice-fp-types*
;; Ordered by: real shortest to longest, then complex shortest to longest.
;; Must match *fp-type-mapping*.
'("s" "d" #+long-double nil
"c" "z" #+long-double nil)
"The list of floating point types that can be spliced into BLAS function names.")
(defparameter *cstd-blas-mapping*
;; The floating types are associated by order, so it is important that
;; order of *fp-type-mapping* and *blas-splice-fp-types* match,
;; though the latter may be longer.
(floating-point-association *blas-splice-fp-types*)
"Mapping the C standard types to the BLAS splice name.")
;;;;****************************************************************************
;;;; Conversions
;;;;****************************************************************************
......@@ -154,12 +171,12 @@
;;; (cl-gsl '(unsigned-byte 8))
;;; "uchar"
(defun cl-gsl (cl-type &optional prepend-underscore)
(defun cl-gsl (cl-type &optional prepend-underscore blas)
"The GSL splice string from the CL type."
(let ((string
(lookup-type
(lookup-type cl-type *cstd-cl-type-mapping* t)
*cstd-gsl-mapping*)))
(if blas *cstd-blas-mapping* *cstd-gsl-mapping*))))
(if (and prepend-underscore (plusp (length string)))
(concatenate 'string "_" string)
string)))
......@@ -251,7 +268,7 @@
|#
;;;;****************************************************************************
;;;; Element types
;;;; Common element type groups for generic functions
;;;;****************************************************************************
(defparameter *array-element-types*
......@@ -263,6 +280,14 @@
(remove-if (lambda (tp) (subtypep tp 'complex)) *array-element-types*)
"All the array element types supported except for complex types.")
(defparameter *float-complex-types*
(remove-if (lambda (tp) (subtypep tp 'integer)) *array-element-types*)
"All the array element types supported except for complex types.")
(defparameter *float-types*
(remove-if-not (lambda (tp) (subtypep tp 'float)) *array-element-types*)
"All the array element types supported except for complex types.")
;;;;****************************************************************************
;;;; Types for CFFI (will eventually be in CFFI)
;;;;****************************************************************************
......
;; BLAS level 1, Vector operations
;; Liam Healy, Wed Apr 26 2006 - 15:23
;; Time-stamp: <2008-03-28 10:35:04EDT blas1.lisp>
;; Time-stamp: <2008-07-17 23:00:36EDT blas1.lisp>
;; $Id$
(in-package :gsl)
;;; new ffa
(defmfun dot ((vec1 vector) (vec2 vector))
("gsl_blas" :type "dot" :suffix)
(((mpointer vec1) :pointer) ((mpointer vec2) :pointer) (result :float))
:definition :generic
:element-types :float-complex
:documentation "Dot, or inner, product between vectors.")
;;; gsl_blas_sdsdot doesn't make much sense, but here it is.
(defmfun sdot (result alpha vec1 vec2)
"gsl_blas_sdsdot"
((alpha :float) ((mpointer vec1) :pointer) ((mpointer vec2) :pointer)
(result :pointer))
:outputs (result)
:documentation "Sum of a scalar and a dot product for single-floats.")
;;; Not porting gsl_blas_dsdot, stupid.
;;;;;;;;;;;;;;;;; OLD ;;;;;;;;;;;;;;;;;;;;
;;; Currently only includes vector-single-float and vector-double-float routines.
;;; Not ported: routines that use raw vectors gsl_blas_drotg, gsl_blas_drotmg, gsl_blas_drotm
......@@ -17,6 +38,10 @@
(defgeneric dot (vector1 vector2)
(:documentation "Dot, or inner, product between vectors."))
(defgeneric norm (x)
(:documentation ; FDL
"The Euclidean norm ||x||_2 = \sqrt {\sum x_i^2} of the vector x."))
......
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