From 22f2a25feb64a4bfa64888e642bee2bb48a9ffe3 Mon Sep 17 00:00:00 2001
From: Liam Healy <liam@thinkpad.local>
Date: Tue, 11 Nov 2008 22:22:16 -0500
Subject: [PATCH] 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.
---
 data/foreign-friendly.lisp | 44 +++++++++++++++++++++++++++++++++-----
 1 file changed, 39 insertions(+), 5 deletions(-)

diff --git a/data/foreign-friendly.lisp b/data/foreign-friendly.lisp
index a0eea160..b4c1675e 100644
--- a/data/foreign-friendly.lisp
+++ b/data/foreign-friendly.lisp
@@ -1,6 +1,6 @@
 ;; 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)))
-- 
GitLab