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

BLAS1 function #'2norm compiles; not tested.

git-svn-id: svn+ssh://common-lisp.net/project/gsll/svn/branches/ffa@70 af03a46b-e846-0410-96e5-d5653c316fd0
parent a945e9c1
No related branches found
No related tags found
No related merge requests found
;; Data using ffa ;; Data using ffa
;; Liam Healy 2008-04-06 21:23:41EDT data-ffa.lisp ;; Liam Healy 2008-04-06 21:23:41EDT data-ffa.lisp
;; Time-stamp: <2008-07-12 14:19:59EDT data.lisp> ;; Time-stamp: <2008-07-20 22:28:15EDT data.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -130,10 +130,7 @@ ...@@ -130,10 +130,7 @@
;;;;**************************************************************************** ;;;;****************************************************************************
(defun component-type (eltype) (defun component-type (eltype)
(if (subtypep eltype 'complex) (cl-ffa (component-float-type eltype)))
;; complex: use the component type
(cl-ffa (second eltype))
(cl-ffa eltype)))
(defun component-size (object) (defun component-size (object)
(if (subtypep (element-type object) 'complex) (if (subtypep (element-type object) 'complex)
......
;; 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-07-17 22:46:01EDT defmfun.lisp> ;; Time-stamp: <2008-07-20 22:33:28EDT defmfun.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -34,8 +34,10 @@ ...@@ -34,8 +34,10 @@
;;; element-types ;;; element-types
;;; Permissible types for elements of arrays. May be ;;; Permissible types for elements of arrays. May be
;;; NIL meaning all of *array-element-types*, :no-complex ;;; NIL meaning all of *array-element-types*, :no-complex
;;; meaning that list without the complex types, or a list ;;; meaning that list without the complex types,
;;; of element types. ;;; :float meaning only the float types, :complex only
;;; the complex types, :float-complex both float and complex,
;;; or a list of element types.
;;; index Name under which this function should be cross-referenced; t ;;; index Name under which this function should be cross-referenced; t
;;; to use name, nil to not index. ;;; to use name, nil to not index.
;;; export Whether to export the symbol. ;;; export Whether to export the symbol.
...@@ -241,6 +243,8 @@ ...@@ -241,6 +243,8 @@
(remf key-args :documentation) (remf key-args :documentation)
(when (eq c-return :element-c-type) (when (eq c-return :element-c-type)
(setf (getf key-args :c-return) (cl-ffa eltype))) (setf (getf key-args :c-return) (cl-ffa eltype)))
(when (eq c-return :component-float-type)
(setf (getf key-args :c-return) (cl-ffa (component-type eltype))))
(expand-defmfun-plain (expand-defmfun-plain
(if (eq new-definition :method) (list nil name) name) (if (eq new-definition :method) (list nil name) name)
(actual-class-arglist arglist eltype replace-both) (actual-class-arglist arglist eltype replace-both)
...@@ -255,6 +259,7 @@ ...@@ -255,6 +259,7 @@
((nil t) *array-element-types*) ((nil t) *array-element-types*)
(:no-complex *array-element-types-no-complex*) (:no-complex *array-element-types-no-complex*)
(:float *float-types*) (:float *float-types*)
(:complex *complex-types*)
(:float-complex *float-complex-types*) (:float-complex *float-complex-types*)
(t element-types))))) (t element-types)))))
...@@ -269,13 +274,17 @@ ...@@ -269,13 +274,17 @@
(substitute (substitute
(if (subtypep type 'complex) "u" "") :suffix (if (subtypep type 'complex) "u" "") :suffix
(substitute (substitute
(cl-gsl type t blas) :type (cl-gsl type
(unless ; should really check it preceeds
(member :component-float-type base-name))
blas) :type
(substitute (substitute
(string-downcase (symbol-name category)) (if (subtypep type 'complex)
:category (cl-gsl (component-float-type type) t blas)
base-name))))))) "") :component-float-type
(substitute
(defun blas-name-final-token ()) (string-downcase (symbol-name category)) :category
base-name))))))))
(defun actual-class-arglist (arglist element-type &optional replace-both) (defun actual-class-arglist (arglist element-type &optional replace-both)
"Replace the prototype arglist with an actual arglist." "Replace the prototype arglist with an actual arglist."
...@@ -328,8 +337,11 @@ ...@@ -328,8 +337,11 @@
actual element type." actual element type."
(mapcar (mapcar
(lambda (v) (lambda (v)
(if (eq (st-type v) :element-c-type) (if (member (st-type v) '(:element-c-type :component-float-type))
(make-st (st-symbol v) (cl-ffa element-type)) (make-st (st-symbol v)
(if (eq (st-type v) :component-float-type)
(component-type element-type)
(cl-ffa element-type)))
v)) v))
c-arguments)) c-arguments))
......
;; Mapping of element type names ;; Mapping of element type names
;; Liam Healy 2008-04-13 11:22:46EDT element-types.lisp ;; Liam Healy 2008-04-13 11:22:46EDT element-types.lisp
;; Time-stamp: <2008-07-17 22:29:47EDT element-types.lisp> ;; Time-stamp: <2008-07-20 22:34:41EDT element-types.lisp>
;; $Id$ ;; $Id$
;;; The different element type forms: ;;; The different element type forms:
...@@ -245,6 +245,13 @@ ...@@ -245,6 +245,13 @@
(cffi:mem-aref datslot comptype 1) (imagpart number)) (cffi:mem-aref datslot comptype 1) (imagpart number))
gsl)) gsl))
(defun component-float-type (eltype)
"The float type of this type."
(if (subtypep eltype 'complex)
;; complex: use the component type
(second eltype)
eltype))
;;; Use GSL to create the complex. This actually does work on ;;; Use GSL to create the complex. This actually does work on
;;; SBCL/amd64, but it shouldn't. ;;; SBCL/amd64, but it shouldn't.
#+(or) #+(or)
...@@ -288,6 +295,10 @@ ...@@ -288,6 +295,10 @@
(remove-if-not (lambda (tp) (subtypep tp 'float)) *array-element-types*) (remove-if-not (lambda (tp) (subtypep tp 'float)) *array-element-types*)
"All the array element types supported except for complex types.") "All the array element types supported except for complex types.")
(defparameter *complex-types*
(remove-if-not (lambda (tp) (subtypep tp 'complex)) *array-element-types*)
"All the supported complex array element types.")
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Types for CFFI (will eventually be in CFFI) ;;;; Types for CFFI (will eventually be in CFFI)
;;;;**************************************************************************** ;;;;****************************************************************************
......
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