(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "E-ARRAY")

(il:filecreated "19-Nov-88 12:59:41" il:{qv}<idl>next>e-array.\;9
 4482   

      il:|changes| il:|to:|  (il:vars il:e-arraycoms) (xcl:file-environments "E-ARRAY")

      il:|previous| il:|date:| "15-Nov-88 18:24:27" il:{qv}<idl>next>e-array.\;8)


; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:e-arraycoms)

(il:rpaqq il:e-arraycoms ((il:functions scalarp total-size rank element-type dimension dimensions scan-dims) (il:functions linearize make-scalar as-list as-vector) (il:functions number-type-of number-subtype-p arith-type conformable-p common-type) (il:functions test-result use-float-p) (il:functions permute-list) (il:commands "K-LOAD" "MAKE-DEFUN") (xcl:file-environments "E-ARRAY")))

(defmacro scalarp (object) (il:bquote (not (arrayp (il:\\\, object)))))

(defun total-size (array) (if (scalarp array) 1 (array-total-size array)))

(defun rank (array) (if (scalarp array) 0 (array-rank array)))

(defun element-type (array) (if (scalarp array) (number-type-of array) (array-element-type array)))

(defun dimension (array dimension) (if (scalarp array) (error "Scalar's have no dimensions: ~s" array) (array-dimension array dimension)))

(defun dimensions (array) (and (arrayp array) (array-dimensions array)))

(defun scan-dims (array) (let ((result (reverse (dimensions array))) (prod 1)) (do ((next-term result (cdr next-term))) ((null next-term)) (setf (car next-term) (prog1 prod (setq prod (* prod (car next-term)))))) (nreverse result)))

(defun linearize (array) (case (rank array) (0 array) (1 array) (otherwise (make-array (array-total-size array) :element-type (array-element-type array) :displaced-to array))))

(defun make-scalar (array) (if (scalarp array) array (aref (linearize array) 0)))

(defun as-list (array) (if (scalarp array) array (let ((linarray (linearize array))) (with-collection (dotimes (i (total-size linarray)) (collect (aref linarray i)))))))

(defun as-vector (list &optional element-type) (if (null element-type) (setq element-type (let ((current-type (number-type-of (car list))) next-type) (dolist (elt (cdr list) current-type) (setq next-type (number-type-of elt)) (cond ((number-subtype-p current-type next-type) (setq current-type next-type)) ((not (number-subtype-p next-type current-type)) (setq current-type t))) (if (eq current-type t) (return t)))))) (make-array (length list) :element-type element-type :initial-contents list))

(defun number-type-of (scalar) (typecase scalar (float (quote float)) (integer (quote integer)) (number (quote number)) (t t)))

(defun number-subtype-p (sub super) (or (eq sub super) (case sub ((float integer) (and (member super (quote (number t)) :test (function eq)) t)) (number (eq super t)) (t nil))))

(defun arith-type (type1 type2) (if (or (eq type1 (quote single-float)) (eq type2 (quote single-float))) (quote single-float) (common-type type1 type2)))

(defun conformable-p (array1 array2) (or (scalarp array1) (scalarp array2) (eq (total-size array1) (total-size array2))))

(defun common-type (type1 type2) (if (equal type1 type2) type1 t))

(defun test-result (result-array result-dims &optional (result-type t)) (cond ((null result-array) (setq result-array (and result-dims (make-array result-dims :element-type result-type)))) ((not (equal (dimensions result-array) result-dims)) (error "Invalid result: ~s" result-array))) result-array)

(defun use-float-p (array1 array2) (and (or (eq (element-type array1) (quote single-float)) (integerp array1)) (or (eq (element-type array2) (quote single-float)) (integerp array2))))

(defun permute-list (list permutation) (let* ((length (length list)) (result (make-list length))) (if (not (eq length (length permutation))) (error "List and Permutation not of equal length")) (do ((index permutation (cdr index)) (value list (cdr value))) ((null index)) (setf (nth (car index) result) (car value))) result))

(xcl:defcommand "K-LOAD" (file) (let ((il:litatom-package-conversion-enabled t)) (il:load file (quote il:prop))))

(xcl:defcommand "MAKE-DEFUN" (old new) (let ((def (il:getdef old (quote il:fns)))) (il:putdef new (quote il:functions) (il:bquote (defun (il:\\\, new) (il:\\\, (second def)) (il:\\\,@ (nthcdr 2 def)))))))

(xcl:define-file-environment "E-ARRAY" :readtable "XCL" :package "E-ARRAY" :compiler :compile-file)
(il:putprops il:e-array il:copyright ("Xerox Corporation" 1987 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop