LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031414. :SYSTEM-TYPE :LOGICAL :VERSION 2. :TYPE "LISP" :NAME "FILLARRAY" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758639614. :AUTHOR "REL3" :LENGTH-IN-BYTES 7083. :LENGTH-IN-BLOCKS 7. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              ; -*- Package:SYSTEM-INTERNALS; Mode:common-LISP; Base:8 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;; Copyright (c) 1986,1987 Texas Instruments Incorporated.  All Rights Reserved.;;; The following definitions of FILLARRAY and LISTARRAY should be completely;;; compatible with Maclisp.  Slow, maybe, but compatible.;;; When filling from an array, extra elements in the destination get the default initial;;; value for the array type.  When filling from a list it sticks at the last element.;;; Extra elements in the source are ignored.  copy-array-contents;;; does the right thing for one-d arrays, but for multi-dimensional arrays;;; uses column-major rather than row-major order.(defresource fillarray-index-arrays ():constructor (make-array 10):initial-copies 2)(defun ZLC:fillarray (array source)  "Fill the contents of ARRAY from SOURCE.If SOURCE is a list, its last element is repeated to fill any part of ARRAY left over.If SOURCE is an array, elements of ARRAY not filled by SOURCE are left untouched.If SOURCE is NIL, the array is filled with the default type for the array; this is 0 or NIL.If ARRAY is NIL, a new list as big as SOURCE is created."  (let ((dest (cond   ((null array)    (setq array  (make-array   (cond     ((null source) 0)     ((consp source) (length source))     ((arrayp source) (array-dimensions source))     (t (ferror () "Unable to default destination array"))))))   ((and (symbolp array) (fboundp array) (arrayp (symbol-function array)))    (symbol-function array))   (t array))))    (check-arg array (arrayp dest) "an array or a symbol FBOUND to an array")    ;; Note, I really mean LISTP here -- Maclisp does not allow NIL, and that is right.    ;; Well, there is code in the system that depends on the empty list working as a source,    ;; at least for zero-length arrays.  This code says filling from () means fill    ;; with the default initial value for the destination array type.    (check-arg source (or (arrayp source) (consp source) (null source)) "an array or a list")    (let ((dest-ndims (array-rank dest))  (source-is-an-array-p (arrayp source)))      (cond(source-is-an-array-p (let ((source-ndims (array-rank source)))   (cond     ((and (= dest-ndims 1) (= source-ndims 1))      ;; One-D array into a one-D array is in microcode!      (let ((n-elements (min (array-total-size source) (array-total-size dest))))(copy-array-portion source 0 n-elements dest 0 n-elements)))     (t      ;; Hairy case, some array is multi-dimensional.      (using-resource (source-index-array fillarray-index-arrays) (using-resource (dest-index-array fillarray-index-arrays)    (dotimes (i 10)      (setf (aref source-index-array i) 0)      (setf (aref dest-index-array i) 0))    (let ((source-elements (array-total-size source))  (dest-elements (array-total-size dest)))      (dotimes (i (min source-elements dest-elements))(fillarray-put (fillarray-get source source-index-array source-ndims)       dest dest-index-array dest-ndims)))))))))((null source) (copy-array-portion dest 0 0 dest 0 (array-total-size dest)))(t ;; Source is a list. (cond   ((= dest-ndims 1)    (dotimes (x (array-dimension dest 0))      (setf (aref dest x) (car source))      (if (not (null (cdr source)))(setq source (cdr source)))))   ((= dest-ndims 2)    (dotimes (x (array-dimension dest 0))      (dotimes (y (array-dimension dest 1))(setf (aref dest x y) (car source))(if (not (null (cdr source)))  (setq source (cdr source))))))   ((= dest-ndims 3)    (dotimes (x (array-dimension dest 0))      (dotimes (y (array-dimension dest 1))(dotimes (z (array-dimension dest 2))  (setf (aref dest x y z) (car source))  (if (not (null (cdr source)))    (setq source (cdr source)))))))   (t    (using-resource (dest-index-array fillarray-index-arrays)       (dotimes (i 10) (setf (aref dest-index-array i) 0))       (dotimes (i (array-total-size dest)) (fillarray-put (car source) dest dest-index-array dest-ndims) (if (not (null (cdr source)))   (setq source (cdr source)))))))))))  array) (defun fillarray-get (array index-array ndims)  (%assure-pdl-room ndims)  (dotimes (i ndims)    (%push (aref index-array i)))  (prog1 (%call array ndims) (fillarray-increment-index array index-array ndims)))(defun fillarray-put (value array index-array ndims)  (%assure-pdl-room (+ 2 ndims))  (%push value)  (%push array)  (dotimes (i ndims)    (%push (aref index-array i)))  (%call #'ZLC:aset (+ 2 ndims))  (fillarray-increment-index array index-array ndims))(defun fillarray-increment-index (array index-array ndims)  (do ((dim (1- ndims) (1- dim)))      ((< dim 0))    (let ((val (1+ (aref index-array dim))))      (cond((< val (array-dimension array dim)) (setf (aref index-array dim) val) (return (values)))(t (setf (aref index-array dim) 0)))))) (defun TICL:listarray (array &optional limit)  "Return a list of the elements of ARRAY, up to index LIMIT.If LIMIT is NIL, the array size is used; for one-dimensional arrays,the fill pointer is used if there is one."  (if (and (symbolp array) (fboundp array) (arrayp (symbol-function array)))    (setq array (symbol-function array)))  (check-arg array arrayp "an array or a symbol FBOUND to an array")  (check-arg limit (or (null limit) (integerp limit)) "NIL or a fixnum")  (let* ((ndims (array-rank array)) (elements (if (= ndims 1)     (array-active-length array)     (array-total-size array))) (times (if (null limit)  elements  (min limit elements))) (list (make-list times)) (l list) (count 0))    (cond      ((= ndims 1)       (dotimes (x (array-active-length array)) (setq count (1+ count)) (if (> count times)   (return (values))) (rplaca l (aref array x)) (setq l (cdr l))))      ((= ndims 2)       (dotimes (x (array-dimension array 0)) (dotimes (y (array-dimension array 1))   (setq count (1+ count))   (if (> count times)     (return (values)))   (rplaca l (aref array x y))   (setq l (cdr l)))))      ((= ndims 3)       (dotimes (x (array-dimension array 0)) (dotimes (y (array-dimension array 1))   (dotimes (z (array-dimension array 2))     (setq count (1+ count))     (if (> count times)       (return (values)))     (rplaca l (aref array x y z))     (setq l (cdr l))))))      (t       (using-resource (index-array fillarray-index-arrays)  (dotimes (i 10)    (setf (aref index-array i) 0))  (dotimes (i times)    (rplaca l (fillarray-get array index-array ndims))    (setq l (cdr l))))))    list))TRING%ENABLE-NUPI-LOCKING %ERROR-HANDLER-STACK-GROUP%EXTERNAL-VALUE-CELL%