Commit 22f2a25f authored by Liam Healy's avatar Liam Healy

Include #'make-ffa

Include #'make-ffa from Tamas Papp's ffa/ffa.lisp to
foreign-friendly.lisp and eliminate the call to
#'match-array-element-type, so that 'element-type must be a CL type.
Temporarily rename this to #'make-ffa*; once I no longer load or
import ffa, it can be renamed back to #'make-ffa.
parent d9e5bb32
;; Use the foreign-friendly arrays package.
;; Liam Healy 2008-03-22 15:40:08EDT ffa.lisp
;; Time-stamp: <2008-11-11 20:42:01EST foreign-friendly.lisp>
;; Time-stamp: <2008-11-11 22:13:20EST foreign-friendly.lisp>
;; $Id$
;;; Use Papp's Foreign-friendly arrays
......@@ -28,11 +28,45 @@
(if (and (subtypep element-type 'complex)
(= (length initial-contents)
(* 2 (if (listp dimensions) (apply #'* dimensions) dimensions))))
(ffa:make-ffa dimensions element-type
(make-ffa* dimensions element-type
:initial-contents
(loop for (re im) on initial-contents by #'cddr
collect (complex re im)))
(ffa:make-ffa dimensions element-type :initial-contents initial-contents))
(make-ffa* dimensions element-type :initial-contents initial-contents))
(if initial-element-p
(ffa:make-ffa dimensions element-type :initial-element initial-element)
(ffa:make-ffa dimensions element-type))))
(make-ffa* dimensions element-type :initial-element initial-element)
(make-ffa* dimensions element-type))))
;;; From Tamas Papp's foreign-friendly arrays (FFA)
(defun make-ffa* (dimensions element-type &key
(initial-element 0 initial-element-p)
(initial-contents nil initial-contents-p))
"Make an array that is either one-dimensional or displaced to a
one-dimensional array. Array is filled with initial-element or
initial-contents, coerced to the given type."
;; element-type is a type spec in CL form
(assert (or (atom dimensions) (and (listp dimensions) (car dimensions))))
(let* ((dimensions (if (atom dimensions) (list dimensions) dimensions))
(length (reduce #'* dimensions))
(array (cond
((and initial-element-p initial-contents-p)
(error "you can't supply both initial-element and ~
initial-contents"))
;; initial element given
(initial-element-p
(make-array length :element-type element-type
:initial-element (coerce initial-element
element-type)))
;; contents given, copy or coerce
(initial-contents-p
(assert (= (length initial-contents) length))
(if (typep initial-contents (list 'vector element-type))
(copy-seq initial-contents)
(map (list 'vector element-type)
(lambda (x) (coerce x element-type)) initial-contents)))
;; neither
(t (make-array length :element-type element-type)))))
(if (cdr dimensions)
(make-array dimensions :element-type element-type
:displaced-to array)
array)))
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