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