home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / array.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  35.3 KB  |  981 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: array.lisp,v 1.16 92/03/24 11:03:16 phg Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Functions to implement arrays for CMU Common Lisp.
  15. ;;; Written by Skef Wholey.
  16. ;;; Worked over for the MIPS port by William Lott.
  17. ;;;
  18. (in-package "LISP")
  19.  
  20. (export '(array-rank-limit array-dimension-limit array-total-size-limit
  21.       make-array vector aref array-element-type array-rank
  22.       array-dimension array-dimensions array-in-bounds-p
  23.       array-row-major-index array-total-size svref bit sbit
  24.       bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
  25.       bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p
  26.       fill-pointer vector-push vector-push-extend vector-pop adjust-array
  27.           adjustable-array-p row-major-aref))
  28.  
  29. (in-package "KERNEL")
  30. (export '(%with-array-data))
  31. (in-package "LISP")
  32.  
  33. (defconstant array-rank-limit 65529
  34.   "The exclusive upper bound on the rank of an array.")
  35.  
  36. (defconstant array-dimension-limit most-positive-fixnum
  37.   "The exclusive upper bound any given dimension of an array.")
  38.  
  39. (defconstant array-total-size-limit most-positive-fixnum
  40.   "The exclusive upper bound on the total number of elements in an array.")
  41.  
  42.  
  43.  
  44. ;;;; Random accessor functions.
  45.  
  46. ;;; These functions are needed by the interpreter, 'cause the compiler inlines
  47. ;;; them.
  48.  
  49. (macrolet ((frob (name)
  50.          `(progn
  51.         (defun ,name (array)
  52.           (,name array))
  53.         (defun (setf ,name) (value array)
  54.           (setf (,name array) value)))))
  55.   (frob %array-fill-pointer)
  56.   (frob %array-fill-pointer-p)
  57.   (frob %array-available-elements)
  58.   (frob %array-data-vector)
  59.   (frob %array-displacement)
  60.   (frob %array-displaced-p))
  61.  
  62. (defun %array-rank (array)
  63.   (%array-rank array))
  64.  
  65. (defun %array-dimension (array axis)
  66.   (%array-dimension array axis))
  67.  
  68. (defun %set-array-dimension (array axis value)
  69.   (%set-array-dimension array axis value))
  70.  
  71. (defun %check-bound (array bound index)
  72.   (declare (type index bound)
  73.        (fixnum index))
  74.   (%check-bound array bound index))
  75.  
  76. ;;; %WITH-ARRAY-DATA  --  Interface
  77. ;;;
  78. ;;;    The guts of the WITH-ARRAY-DATA macro (in sysmacs).  Note that this
  79. ;;; function is only called if we have an array header or an error, so it
  80. ;;; doesn't have to be too tense.
  81. ;;;
  82. (defun %with-array-data (array start end)
  83.   (declare (array array) (type index start) (type (or index null) end)
  84.        (values (simple-array * (*)) index index index))
  85.   (let* ((size (array-total-size array))
  86.      (end (cond (end
  87.              (unless (<= end size)
  88.                (error "End ~D is greater than total size ~D."
  89.                   end size))
  90.              end)
  91.             (t size))))
  92.     (when (> start end)
  93.       (error "Start ~D is greater than end ~D." start end))
  94.     (do ((data array (%array-data-vector data))
  95.      (cumulative-offset 0
  96.                 (+ cumulative-offset
  97.                    (%array-displacement data))))
  98.     ((not (array-header-p data))
  99.      (values data
  100.          (+ cumulative-offset start)
  101.          (+ cumulative-offset end)
  102.          cumulative-offset))
  103.       (declare (type index cumulative-offset)))))
  104.  
  105.  
  106. ;;;; MAKE-ARRAY
  107.  
  108. (eval-when (compile eval)
  109.  
  110. (defmacro pick-type (type &rest specs)
  111.   `(cond ,@(mapcar #'(lambda (spec)
  112.                `(,(if (eq (car spec) t)
  113.                   t
  114.                   `(subtypep ,type ',(car spec)))
  115.              ,@(cdr spec)))
  116.            specs)))
  117.  
  118. ); eval-when
  119.  
  120.  
  121. (defun %vector-type-code (type)
  122.   (pick-type type
  123.     (base-char (values #.vm:simple-string-type #.vm:byte-bits))
  124.     (bit (values #.vm:simple-bit-vector-type 1))
  125.     ((unsigned-byte 2) (values #.vm:simple-array-unsigned-byte-2-type 2))
  126.     ((unsigned-byte 4) (values #.vm:simple-array-unsigned-byte-4-type 4))
  127.     ((unsigned-byte 8) (values #.vm:simple-array-unsigned-byte-8-type 8))
  128.     ((unsigned-byte 16) (values #.vm:simple-array-unsigned-byte-16-type 16))
  129.     ((unsigned-byte 32) (values #.vm:simple-array-unsigned-byte-32-type 32))
  130.     (single-float (values #.vm:simple-array-single-float-type 32))
  131.     (double-float (values #.vm:simple-array-double-float-type 64))
  132.     (t (values #.vm:simple-vector-type #.vm:word-bits))))
  133.  
  134. (defun %complex-vector-type-code (type)
  135.   (pick-type type
  136.     (base-char #.vm:complex-string-type)
  137.     (bit #.vm:complex-bit-vector-type)
  138.     (t #.vm:complex-vector-type)))
  139.  
  140. (defun make-array (dimensions &key
  141.                   (element-type t)
  142.                   (initial-element nil initial-element-p)
  143.                   initial-contents adjustable fill-pointer
  144.                   displaced-to displaced-index-offset)
  145.   "Creates an array of the specified Dimensions.  See manual for details."
  146.   (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
  147.      (array-rank (length (the list dimensions)))
  148.      (simple (and (null fill-pointer)
  149.               (not adjustable)
  150.               (null displaced-to))))
  151.     (declare (fixnum array-rank))
  152.     (when (and displaced-index-offset (null displaced-to))
  153.       (error "Can't specify :displaced-index-offset without :displaced-to"))
  154.     (if (and simple (= array-rank 1))
  155.     ;; Its a (simple-array * (*))
  156.     (multiple-value-bind (type bits)
  157.                  (%vector-type-code element-type)
  158.       (declare (type (unsigned-byte 8) type)
  159.            (type (integer 1 64) bits))
  160.       (let* ((length (car dimensions))
  161.          (array (allocate-vector
  162.              type
  163.              length
  164.              (ceiling (* (if (= type vm:simple-string-type)
  165.                      (1+ length)
  166.                      length)
  167.                      bits)
  168.                   vm:word-bits))))
  169.         (declare (type index length))
  170.         (when initial-element-p
  171.           (fill array initial-element))
  172.         (when initial-contents
  173.           (when initial-element
  174.         (error "Cannot specify both :initial-element and ~
  175.         :initial-contents"))
  176.           (unless (= length (length initial-contents))
  177.         (error "~D elements in the initial-contents, but the ~
  178.         vector length is ~D."
  179.                (length initial-contents)
  180.                length))
  181.           (replace array initial-contents))
  182.         array))
  183.     ;; It's either a complex array or a multidimensional array.
  184.     (let* ((total-size (reduce #'* dimensions))
  185.            (data (or displaced-to
  186.              (data-vector-from-inits
  187.               dimensions total-size element-type
  188.               initial-contents initial-element initial-element-p)))
  189.            (array (make-array-header
  190.                (cond ((= array-rank 1)
  191.                   (%complex-vector-type-code element-type))
  192.                  (simple vm:simple-array-type)
  193.                  (t vm:complex-array-type))
  194.                array-rank)))
  195.       (cond (fill-pointer
  196.          (unless (= array-rank 1)
  197.            (error "Only vectors can have fill pointers."))
  198.          (setf (%array-fill-pointer array)
  199.                (if (eq fill-pointer t)
  200.                (car dimensions)
  201.                fill-pointer))
  202.          (setf (%array-fill-pointer-p array) t))
  203.         (t
  204.          (setf (%array-fill-pointer array) total-size)
  205.          (setf (%array-fill-pointer-p array) nil)))
  206.       (setf (%array-available-elements array) total-size)
  207.       (setf (%array-data-vector array) data)
  208.       (cond (displaced-to
  209.          (when (or initial-element-p initial-contents)
  210.            (error "Neither :initial-element nor :initial-contents ~
  211.            can be specified along with :displaced-to"))
  212.          (let ((offset (or displaced-index-offset 0)))
  213.            (when (> (+ offset total-size)
  214.                 (array-total-size displaced-to))
  215.              (error "~S doesn't have enough elements." displaced-to))
  216.            (setf (%array-displacement array) offset)
  217.            (setf (%array-displaced-p array) t)))
  218.         (t
  219.          (setf (%array-displaced-p array) nil)))
  220.       (let ((axis 0))
  221.         (dolist (dim dimensions)
  222.           (setf (%array-dimension array axis) dim)
  223.           (incf axis)))
  224.       array))))
  225.     
  226. ;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array
  227. ;;; characteristics.  Dimensions is only used to pass to FILL-DATA-VECTOR
  228. ;;; for error checking on the structure of initial-contents.
  229. ;;;
  230. (defun data-vector-from-inits (dimensions total-size element-type
  231.                    initial-contents initial-element
  232.                    initial-element-p)
  233.   (when (and initial-contents initial-element-p)
  234.     (error "Cannot supply both :initial-contents and :initial-element to
  235.             either make-array or adjust-array."))
  236.   (let ((data (if initial-element-p
  237.           (make-array total-size
  238.                   :element-type element-type
  239.                   :initial-element initial-element)
  240.           (make-array total-size
  241.                   :element-type element-type))))
  242.     (cond (initial-element-p
  243.        (unless (simple-vector-p data)
  244.          (unless (typep initial-element element-type)
  245.            (error "~S cannot be used to initialize an array of type ~S."
  246.               initial-element element-type))
  247.          (fill (the vector data) initial-element)))
  248.       (initial-contents
  249.        (fill-data-vector data dimensions initial-contents)))
  250.     data))
  251.  
  252.  
  253. (defun fill-data-vector (vector dimensions initial-contents)
  254.   (let ((index 0))
  255.     (labels ((frob (axis dims contents)
  256.            (cond ((null dims)
  257.               (setf (aref vector index) contents)
  258.               (incf index))
  259.              (t
  260.               (unless (typep contents 'sequence)
  261.             (error "Malformed :initial-contents.  ~S is not a ~
  262.                     sequence, but ~D more layer~:P needed."
  263.                    contents
  264.                    (- (length dimensions) axis)))
  265.               (unless (= (length contents) (car dims))
  266.             (error "Malformed :initial-contents.  Dimension of ~
  267.                     axis ~D is ~D, but ~S is ~D long."
  268.                    axis (car dims) contents (length contents)))
  269.               (if (listp contents)
  270.               (dolist (content contents)
  271.                 (frob (1+ axis) (cdr dims) content))
  272.               (dotimes (i (length contents))
  273.                 (frob (1+ axis) (cdr dims) (aref contents i))))))))
  274.       (frob 0 dimensions initial-contents))))
  275.  
  276.  
  277. ;;; Some people out there are still calling MAKE-VECTOR:
  278. ;;;
  279. (setf (symbol-function 'make-vector) #'make-array)
  280.  
  281.  
  282. (defun vector (&rest objects)
  283.   "Constructs a simple-vector from the given objects."
  284.   (coerce (the list objects) 'simple-vector))
  285.  
  286.  
  287.  
  288. ;;;; Accessor/Setter functions.
  289.  
  290. (defun data-vector-ref (array index)
  291.   (with-array-data ((vector array) (index index) (end))
  292.     (declare (ignore end) (optimize (safety 3)))
  293.     (macrolet ((dispatch (&rest stuff)
  294.          `(etypecase vector
  295.             ,@(mapcar #'(lambda (type)
  296.                   (let ((atype `(simple-array ,type (*))))
  297.                     `(,atype
  298.                       (data-vector-ref (the ,atype vector)
  299.                                index))))
  300.                   stuff))))
  301.       (dispatch
  302.        t
  303.        bit
  304.        character
  305.        (unsigned-byte 2)
  306.        (unsigned-byte 4)
  307.        (unsigned-byte 8)
  308.        (unsigned-byte 16)
  309.        (unsigned-byte 32)
  310.        single-float
  311.        double-float))))
  312.  
  313. (defun data-vector-set (array index new-value)
  314.   (with-array-data ((vector array) (index index) (end))
  315.     (declare (ignore end) (optimize (safety 3)))
  316.     (macrolet ((dispatch (&rest stuff)
  317.          `(etypecase vector
  318.             ,@(mapcar #'(lambda (type)
  319.                   (let ((atype `(simple-array ,type (*))))
  320.                     `(,atype
  321.                       (data-vector-set (the ,atype vector)
  322.                                index
  323.                                (the ,type new-value)))))
  324.                   stuff))))
  325.       (dispatch
  326.        t
  327.        bit
  328.        character
  329.        (unsigned-byte 2)
  330.        (unsigned-byte 4)
  331.        (unsigned-byte 8)
  332.        (unsigned-byte 16)
  333.        (unsigned-byte 32)
  334.        single-float
  335.        double-float))))
  336.  
  337.  
  338.  
  339. (defun %array-row-major-index (array subscripts
  340.                      &optional (invalid-index-error-p t))
  341.   (declare (array array)
  342.        (list subscripts))
  343.   (let ((rank (array-rank array)))
  344.     (unless (= rank (length subscripts))
  345.       (error "Wrong number of subscripts, ~D, for array of rank ~D"
  346.          (length subscripts) rank))
  347.     (if (array-header-p array)
  348.     (do ((subs (nreverse subscripts) (cdr subs))
  349.          (axis (1- (array-rank array)) (1- axis))
  350.          (chunk-size 1)
  351.          (result 0))
  352.         ((null subs) result)
  353.       (declare (list subs) (fixnum axis chunk-size result))
  354.       (let ((index (car subs))
  355.         (dim (%array-dimension array axis)))
  356.         (declare (fixnum index dim))
  357.         (unless (< -1 index dim)
  358.           (if invalid-index-error-p
  359.           (error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
  360.              index axis array)
  361.           (return-from %array-row-major-index nil)))
  362.         (incf result (* chunk-size index))
  363.         (setf chunk-size (* chunk-size dim))))
  364.     (let ((index (first subscripts)))
  365.       (unless (< -1 index (length (the (simple-array * (*)) array)))
  366.         (if invalid-index-error-p
  367.         (error "Invalid index ~D in ~S" index array)
  368.         (return-from %array-row-major-index nil)))
  369.       index))))
  370.  
  371. (defun array-in-bounds-p (array &rest subscripts)
  372.   "Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
  373.   (if (%array-row-major-index array subscripts nil)
  374.       t))
  375.  
  376. (defun array-row-major-index (array &rest subscripts)
  377.   (%array-row-major-index array subscripts))
  378.  
  379. (defun aref (array &rest subscripts)
  380.   "Returns the element of the Array specified by the Subscripts."
  381.   (row-major-aref array (%array-row-major-index array subscripts)))
  382.  
  383. (defun %aset (array &rest stuff)
  384.   (let ((subscripts (butlast stuff))
  385.     (new-value (car (last stuff))))
  386.     (setf (row-major-aref array (%array-row-major-index array subscripts))
  387.       new-value)))
  388.  
  389. (declaim (inline (setf aref)))
  390. (defun (setf aref) (new-value array &rest subscripts)
  391.   (declare (type array array))
  392.   (setf (row-major-aref array (%array-row-major-index array subscripts))
  393.     new-value))
  394.  
  395. (defun row-major-aref (array index)
  396.   "Returns the element of array corressponding to the row-major index.  This is
  397.    SETF'able."
  398.   (declare (optimize (safety 1)))
  399.   (row-major-aref array index))
  400.  
  401.  
  402. (defun %set-row-major-aref (array index new-value)
  403.   (declare (optimize (safety 1)))
  404.   (setf (row-major-aref array index) new-value))
  405.  
  406. (defun svref (simple-vector index)
  407.   "Returns the Index'th element of the given Simple-Vector."
  408.   (declare (optimize (safety 1)))
  409.   (aref simple-vector index))
  410.  
  411. (defun %svset (simple-vector index new)
  412.   (declare (optimize (safety 1)))
  413.   (setf (aref simple-vector index) new))
  414.  
  415.  
  416. (defun bit (bit-array &rest subscripts)
  417.   "Returns the bit from the Bit-Array at the specified Subscripts."
  418.   (declare (type (array bit) bit-array) (optimize (safety 1)))
  419.   (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
  420.  
  421.  
  422. (defun %bitset (bit-array &rest stuff)
  423.   (declare (type (array bit) bit-array) (optimize (safety 1)))
  424.   (let ((subscripts (butlast stuff))
  425.     (new-value (car (last stuff))))
  426.     (setf (row-major-aref bit-array
  427.               (%array-row-major-index bit-array subscripts))
  428.       new-value)))
  429.  
  430. (declaim (inline (setf bit)))
  431. (defun (setf bit) (new-value bit-array &rest subscripts)
  432.   (declare (type (array bit) bit-array) (optimize (safety 1)))
  433.   (setf (row-major-aref bit-array
  434.             (%array-row-major-index bit-array subscripts))
  435.     new-value))
  436.  
  437. (defun sbit (simple-bit-array &rest subscripts)
  438.   "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
  439.   (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
  440.   (row-major-aref simple-bit-array
  441.           (%array-row-major-index simple-bit-array subscripts)))
  442.  
  443. (defun %sbitset (simple-bit-array &rest stuff)
  444.   (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
  445.   (let ((subscripts (butlast stuff))
  446.     (new-value (car (last stuff))))
  447.     (setf (row-major-aref simple-bit-array
  448.               (%array-row-major-index simple-bit-array subscripts))
  449.       new-value)))
  450.  
  451. (declaim (inline (setf sbit)))
  452. (defun (setf sbit) (new-value bit-array &rest subscripts)
  453.   (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
  454.   (setf (row-major-aref bit-array
  455.             (%array-row-major-index bit-array subscripts))
  456.     new-value))
  457.  
  458.  
  459. ;;;; Random array properties.
  460.  
  461. (defun array-element-type (array)
  462.   "Returns the type of the elements of the array"
  463.   (let ((type (get-type array)))
  464.     (macrolet ((pick-element-type (&rest stuff)
  465.          `(cond ,@(mapcar #'(lambda (stuff)
  466.                       (cons
  467.                        (let ((item (car stuff)))
  468.                      (cond ((eq item t)
  469.                         t)
  470.                            ((listp item)
  471.                         (cons 'or
  472.                               (mapcar #'(lambda (x)
  473.                                   `(= type ,x))
  474.                                   item)))
  475.                            (t
  476.                         `(= type ,item))))
  477.                        (cdr stuff)))
  478.                            stuff))))
  479.       (pick-element-type
  480.        ((vm:simple-string-type vm:complex-string-type) 'base-char)
  481.        ((vm:simple-bit-vector-type vm:complex-bit-vector-type) 'bit)
  482.        (vm:simple-vector-type t)
  483.        (vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2))
  484.        (vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4))
  485.        (vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8))
  486.        (vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16))
  487.        (vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32))
  488.        (vm:simple-array-single-float-type 'single-float)
  489.        (vm:simple-array-double-float-type 'double-float)
  490.        ((vm:simple-array-type vm:complex-vector-type vm:complex-array-type)
  491.     (with-array-data ((array array) (start) (end))
  492.       (declare (ignore start end))
  493.       (array-element-type array)))
  494.        (t
  495.     (error "~S is not an array." array))))))
  496.  
  497.  
  498. (defun array-rank (array)
  499.   "Returns the number of dimensions of the Array."
  500.   (cond ((array-header-p array)
  501.      (%array-rank array))
  502.     ((vectorp array)
  503.      1)
  504.     (t
  505.      (error "~S is not an array." array))))
  506.  
  507. (defun array-dimension (array axis-number)
  508.   "Returns length of dimension Axis-Number of the Array."
  509.   (declare (array array) (type index axis-number))
  510.   (when (>= axis-number (array-rank array))
  511.     (error "~D is too big; ~S only has ~D dimension~:P"
  512.        axis-number array (array-rank array)))
  513.   (if (array-header-p array)
  514.       (%array-dimension array axis-number)
  515.       (length (the (simple-array * (*)) array))))
  516.  
  517. (defun array-dimensions (array)
  518.   "Returns a list whose elements are the dimensions of the array"
  519.   (declare (array array))
  520.   (if (array-header-p array)
  521.       (do ((results nil (cons (array-dimension array index) results))
  522.        (index (1- (array-rank array)) (1- index)))
  523.       ((minusp index) results))
  524.       (list (array-dimension array 0))))
  525.  
  526. (defun array-total-size (array)
  527.   "Returns the total number of elements in the Array."
  528.   (declare (array array))
  529.   (if (array-header-p array)
  530.       (%array-available-elements array)
  531.       (length (the vector array))))
  532.  
  533. (defun array-displacement (array)
  534.   "Returns values of :displaced-to and :displaced-index-offset options to
  535.    make-array, or the defaults nil and 0 if not a displaced array."
  536.   (declare (array array))
  537.   (values (%array-data-vector array) (%array-displacement array)))
  538.  
  539. (defun adjustable-array-p (array)
  540.   "Returns T if (adjust-array array...) would return an array identical
  541.    to the argument, this happens for complex arrays."
  542.   (declare (array array))
  543.   (not (typep array '(simple-array * (*)))))
  544.  
  545.  
  546. ;;;; Fill pointer frobbing stuff.
  547.  
  548. (defun array-has-fill-pointer-p (array)
  549.   "Returns T if the given Array has a fill pointer, or Nil otherwise."
  550.   (declare (array array))
  551.   (and (array-header-p array) (%array-fill-pointer-p array)))
  552.  
  553. (defun fill-pointer (vector)
  554.   "Returns the Fill-Pointer of the given Vector."
  555.   (declare (vector vector))
  556.   (if (and (array-header-p vector) (%array-fill-pointer-p vector))
  557.       (%array-fill-pointer vector)
  558.       (error "~S is not an array with a fill-pointer." vector)))
  559.  
  560. (defun %set-fill-pointer (vector new)
  561.   (declare (vector vector) (fixnum new))
  562.   (if (and (array-header-p vector) (%array-fill-pointer-p vector))
  563.       (if (> new (%array-available-elements vector))
  564.     (error "New fill pointer, ~S, is larger than the length of the vector."
  565.            new)
  566.     (setf (%array-fill-pointer vector) new))
  567.       (error "~S is not an array with a fill-pointer." vector)))
  568.  
  569. (defun vector-push (new-el array)
  570.   "Attempts to set the element of Array designated by the fill pointer
  571.    to New-El and increment fill pointer by one.  If the fill pointer is
  572.    too large, Nil is returned, otherwise the index of the pushed element is 
  573.    returned."
  574.   (declare (vector array))
  575.   (let ((fill-pointer (fill-pointer array)))
  576.     (declare (fixnum fill-pointer))
  577.     (cond ((= fill-pointer (%array-available-elements array))
  578.        nil)
  579.       (t
  580.        (setf (aref array fill-pointer) new-el)
  581.        (setf (%array-fill-pointer array) (1+ fill-pointer))
  582.        fill-pointer))))
  583.  
  584. (defun vector-push-extend (new-el array &optional
  585.                   (extension (if (zerop (length array))
  586.                          1
  587.                          (length array))))
  588.   "Like Vector-Push except that if the fill pointer gets too large, the
  589.    Array is extended rather than Nil being returned."
  590.   (declare (vector array) (fixnum extension))
  591.   (let ((fill-pointer (fill-pointer array)))
  592.     (declare (fixnum fill-pointer))
  593.     (when (= fill-pointer (%array-available-elements array))
  594.       (adjust-array array (+ fill-pointer extension)))
  595.     (setf (aref array fill-pointer) new-el)
  596.     (setf (%array-fill-pointer array) (1+ fill-pointer))
  597.     fill-pointer))
  598.  
  599. (defun vector-pop (array)
  600.   "Attempts to decrease the fill-pointer by 1 and return the element
  601.    pointer to by the new fill pointer.  If the original value of the fill
  602.    pointer is 0, an error occurs."
  603.   (declare (vector array))
  604.   (let ((fill-pointer (fill-pointer array)))
  605.     (declare (fixnum fill-pointer))
  606.     (if (zerop fill-pointer)
  607.     (error "Nothing left to pop.")
  608.     (aref array
  609.           (setf (%array-fill-pointer array)
  610.             (1- fill-pointer))))))
  611.  
  612.  
  613. ;;;; Adjust-array
  614.  
  615. (defun adjust-array (array dimensions &key
  616.                (element-type (array-element-type array))
  617.                (initial-element nil initial-element-p)
  618.                initial-contents fill-pointer
  619.                displaced-to displaced-index-offset)
  620.   "Adjusts the Array's dimensions to the given Dimensions and stuff."
  621.   (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
  622.     (cond ((/= (the fixnum (length (the list dimensions)))
  623.            (the fixnum (array-rank array)))
  624.        (error "Number of dimensions not equal to rank of array."))
  625.       ((not (subtypep element-type (array-element-type array)))
  626.        (error "New element type, ~S, is incompatible with old."
  627.           element-type)))
  628.     (let ((array-rank (length (the list dimensions))))
  629.       (declare (fixnum array-rank))
  630.       (when (and fill-pointer (> array-rank 1))
  631.     (error "Multidimensional arrays can't have fill pointers."))
  632.       (cond (initial-contents
  633.          ;; Array former contents replaced by initial-contents.
  634.          (if (or initial-element-p displaced-to)
  635.          (error "Initial contents may not be specified with ~
  636.          the :initial-element or :displaced-to option."))
  637.          (let* ((array-size (apply #'* dimensions))
  638.             (array-data (data-vector-from-inits
  639.                  dimensions array-size element-type
  640.                  initial-contents initial-element
  641.                  initial-element-p)))
  642.            (if (adjustable-array-p array)
  643.            (set-array-header array array-data array-size
  644.                  (get-new-fill-pointer array array-size
  645.                                fill-pointer)
  646.                  0 dimensions nil)
  647.            (if (array-header-p array)
  648.                ;; Simple multidimensional or single dimensional array.
  649.                (make-array dimensions
  650.                    :element-type element-type
  651.                    :initial-contents initial-contents)
  652.                array-data))))
  653.         (displaced-to
  654.          ;; No initial-contents supplied is already established.
  655.          (when initial-element
  656.            (error "The :initial-element option may not be specified ~
  657.            with :displaced-to."))
  658.          (unless (subtypep element-type (array-element-type displaced-to))
  659.            (error "One can't displace an array of type ~S into another of ~
  660.                    type ~S."
  661.               element-type (array-element-type displaced-to)))
  662.          (let ((displacement (or displaced-index-offset 0))
  663.            (array-size (apply #'* dimensions)))
  664.            (declare (fixnum displacement array-size))
  665.            (if (< (the fixnum (array-total-size displaced-to))
  666.               (the fixnum (+ displacement array-size)))
  667.            (error "The :displaced-to array is too small."))
  668.            (if (adjustable-array-p array)
  669.            ;; None of the original contents appear in adjusted array.
  670.            (set-array-header array displaced-to array-size
  671.                      (get-new-fill-pointer array array-size
  672.                                fill-pointer)
  673.                      displacement dimensions t)
  674.            ;; Simple multidimensional or single dimensional array.
  675.            (make-array dimensions
  676.                    :element-type element-type
  677.                    :displaced-to displaced-to
  678.                    :displaced-index-offset
  679.                    displaced-index-offset))))
  680.         ((= array-rank 1)
  681.          (let ((old-length (array-total-size array))
  682.            (new-length (car dimensions))
  683.            new-data)
  684.            (declare (fixnum old-length new-length))
  685.            (with-array-data ((old-data array) (old-start)
  686.                  (old-end old-length))
  687.          (cond ((or (%array-displaced-p array)
  688.                 (< old-length new-length))
  689.             (setf new-data
  690.                   (data-vector-from-inits
  691.                    dimensions new-length element-type
  692.                    initial-contents initial-element
  693.                    initial-element-p))
  694.             (replace new-data old-data
  695.                  :start2 old-start :end2 old-end))
  696.                (t (setf new-data
  697.                 (shrink-vector old-data new-length))))
  698.          (if (adjustable-array-p array)
  699.              (set-array-header array new-data new-length
  700.                        (get-new-fill-pointer array new-length
  701.                                  fill-pointer)
  702.                        0 dimensions nil)
  703.              new-data))))
  704.         (t
  705.          (let ((old-length (%array-available-elements array))
  706.            (new-length (apply #'* dimensions)))
  707.            (declare (fixnum old-length new-length))
  708.            (with-array-data ((old-data array) (old-start)
  709.                  (old-end old-length))
  710.          (declare (ignore old-end))
  711.          (let ((new-data (if (or (%array-displaced-p array)
  712.                      (> new-length old-length))
  713.                      (data-vector-from-inits
  714.                       dimensions new-length
  715.                       element-type () initial-element
  716.                       initial-element-p)
  717.                      old-data)))
  718.            (zap-array-data old-data (array-dimensions array) old-start
  719.                    new-data dimensions new-length element-type
  720.                    initial-element initial-element-p)
  721.            (set-array-header array new-data new-length
  722.                      new-length 0 dimensions nil)))))))))
  723.  
  724. (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
  725.   (cond ((not fill-pointer)
  726.      (when (array-has-fill-pointer-p old-array)
  727.        (when (> (%array-fill-pointer old-array) new-array-size)
  728.          (error "Cannot adjust-array an array (~S) to a size (~S) that is ~
  729.                 smaller than it's fill pointer (~S)."
  730.             old-array new-array-size (fill-pointer old-array)))
  731.        (%array-fill-pointer old-array)))
  732.     ((not (array-has-fill-pointer-p old-array))
  733.      (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~
  734.                 in adjust-array unless the array (~S) was originally ~
  735.              created with a fill pointer."
  736.                fill-pointer
  737.                old-array))
  738.     ((numberp fill-pointer)
  739.      (when (> fill-pointer new-array-size)
  740.        (error "Cannot supply a value for :fill-pointer (~S) that is larger ~
  741.               than the new length of the vector (~S)."
  742.           fill-pointer new-array-size))
  743.      fill-pointer)
  744.     ((eq fill-pointer t)
  745.      new-array-size)
  746.     (t
  747.      (error "Bogus value for :fill-pointer in adjust-array: ~S"
  748.         fill-pointer))))
  749.  
  750. (defun shrink-vector (vector new-size)
  751.   "Destructively alters the Vector, changing its length to New-Size, which
  752.    must be less than or equal to its current size."
  753.   (declare (vector vector))
  754.   (unless (array-header-p vector)
  755.     (macrolet ((frob (name &rest things)
  756.          `(etypecase ,name
  757.             ,@(mapcar #'(lambda (thing)
  758.                   `(,(car thing)
  759.                     (fill (truly-the ,(car thing) ,name)
  760.                       ,(cadr thing)
  761.                       :start new-size)))
  762.                   things))))
  763.       (frob vector
  764.     (simple-vector 0)
  765.     (simple-base-string (code-char 0))
  766.     (simple-bit-vector 0)
  767.     ((simple-array (unsigned-byte 2) (*)) 0)
  768.     ((simple-array (unsigned-byte 4) (*)) 0)
  769.     ((simple-array (unsigned-byte 8) (*)) 0)
  770.     ((simple-array (unsigned-byte 16) (*)) 0)
  771.     ((simple-array (unsigned-byte 32) (*)) 0)
  772.     ((simple-array single-float (*)) (coerce 0 'single-float))
  773.     ((simple-array double-float (*)) (coerce 0 'double-float)))))
  774.   ;; Only arrays have fill-pointers, but vectors have their length parameter
  775.   ;; in the same place.
  776.   (setf (%array-fill-pointer vector) new-size)
  777.   vector)
  778.  
  779. (defun set-array-header (array data length fill-pointer displacement dimensions
  780.              &optional displacedp)
  781.   "Fills in array header with provided information.  Returns array."
  782.   (setf (%array-data-vector array) data)
  783.   (setf (%array-available-elements array) length)
  784.   (cond (fill-pointer
  785.      (setf (%array-fill-pointer array) fill-pointer)
  786.      (setf (%array-fill-pointer-p array) t))
  787.     (t
  788.      (setf (%array-fill-pointer array) length)
  789.      (setf (%array-fill-pointer-p array) nil)))
  790.   (setf (%array-displacement array) displacement)
  791.   (if (listp dimensions)
  792.       (dotimes (axis (array-rank array))
  793.     (declare (type index axis))
  794.     (setf (%array-dimension array axis) (pop dimensions)))
  795.       (setf (%array-dimension array 0) dimensions))
  796.   (setf (%array-displaced-p array) displacedp)
  797.   array)
  798.  
  799.  
  800.  
  801. ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY.
  802.  
  803. ;;; Make a temporary to be used when old-data and new-data are EQ.
  804. ;;;
  805. (defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
  806.  
  807. (defun zap-array-data-temp (length element-type initial-element
  808.                 initial-element-p)
  809.   (declare (fixnum length))
  810.   (when (> length (the fixnum (length *zap-array-data-temp*)))
  811.     (setf *zap-array-data-temp*
  812.       (make-array length :initial-element t)))
  813.   (when initial-element-p
  814.     (unless (typep initial-element element-type)
  815.       (error "~S cannot be used to initialize an array of type ~S."
  816.          initial-element element-type))
  817.     (fill (the simple-vector *zap-array-data-temp*) initial-element
  818.       :end length))
  819.   *zap-array-data-temp*)
  820.  
  821.  
  822. ;;; ZAP-ARRAY-DATA  --  Internal.
  823. ;;;
  824. ;;; This does the grinding work for ADJUST-ARRAY.  It zaps the data from the
  825. ;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an
  826. ;;; arrangement specified by the New-Dims.  Offset is a displaced offset to be
  827. ;;; added to computed indexes of Old-Data.  New-Length, Element-Type,
  828. ;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data
  829. ;;; are EQ; in this case, a temporary must be used and filled appropriately.
  830. ;;; When Old-Data and New-Data are not EQ, New-Data has already been filled
  831. ;;; with any specified initial-element.
  832. ;;;
  833. (defun zap-array-data (old-data old-dims offset new-data new-dims new-length
  834.                element-type initial-element initial-element-p)
  835.   (declare (list old-dims new-dims))
  836.   (setq old-dims (nreverse old-dims))
  837.   (setq new-dims (reverse new-dims))
  838.   (if (eq old-data new-data)
  839.       (let ((temp (zap-array-data-temp new-length element-type
  840.                        initial-element initial-element-p)))
  841.     (zap-array-data-aux old-data old-dims offset temp new-dims)
  842.     (dotimes (i new-length) (setf (aref new-data i) (aref temp i))))
  843.       (zap-array-data-aux old-data old-dims offset new-data new-dims)))
  844.       
  845. (defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
  846.   (declare (fixnum offset))
  847.   (let ((limits (mapcar #'(lambda (x y)
  848.                 (declare (fixnum x y))
  849.                 (1- (the fixnum (min x y))))
  850.             old-dims new-dims)))
  851.     (macrolet ((bump-index-list (index limits)
  852.          `(do ((subscripts ,index (cdr subscripts))
  853.                (limits ,limits (cdr limits)))
  854.               ((null subscripts) nil)
  855.             (cond ((< (the fixnum (car subscripts))
  856.                   (the fixnum (car limits)))
  857.                (rplaca subscripts
  858.                    (1+ (the fixnum (car subscripts))))
  859.                (return ,index))
  860.               (t (rplaca subscripts 0))))))
  861.       (do ((index (make-list (length old-dims) :initial-element 0)
  862.           (bump-index-list index limits)))
  863.       ((null index))
  864.     (setf (aref new-data (row-major-index-from-dims index new-dims))
  865.           (aref old-data
  866.             (+ (the fixnum (row-major-index-from-dims index old-dims))
  867.                offset)))))))
  868.  
  869. ;;; ROW-MAJOR-INDEX-FROM-DIMS  --  Internal.
  870. ;;;
  871. ;;; This figures out the row-major-order index of an array reference from a
  872. ;;; list of subscripts and a list of dimensions.  This is for internal calls
  873. ;;; only, and the subscripts and dim-list variables are assumed to be reversed
  874. ;;; from what the user supplied.
  875. ;;;
  876. (defun row-major-index-from-dims (rev-subscripts rev-dim-list)
  877.   (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
  878.        (rev-dim-list rev-dim-list (cdr rev-dim-list))
  879.        (chunk-size 1)
  880.        (result 0))
  881.       ((null rev-dim-list) result)
  882.     (declare (fixnum chunk-size result))
  883.     (setq result (+ result
  884.             (the fixnum (* (the fixnum (car rev-subscripts))
  885.                    chunk-size))))
  886.     (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
  887.  
  888.  
  889.  
  890. ;;;; Some bit stuff.
  891.  
  892. (defun bit-array-same-dimensions-p (array1 array2)
  893.   (declare (type (array bit) array1 array2))
  894.   (and (= (array-rank array1)
  895.       (array-rank array2))
  896.        (dotimes (index (array-rank array1) t)
  897.      (when (/= (array-dimension array1 index)
  898.            (array-dimension array2 index))
  899.        (return nil)))))
  900.  
  901. (defun pick-result-array (result-bit-array bit-array-1)
  902.   (case result-bit-array
  903.     ((t) bit-array-1)
  904.     ((nil) (make-array (array-dimensions bit-array-1)
  905.                :element-type 'bit
  906.                :initial-element 0))
  907.     (t
  908.      (unless (bit-array-same-dimensions-p bit-array-1
  909.                       result-bit-array)
  910.        (error "~S and ~S do not have the same dimensions."
  911.           bit-array-1 result-bit-array))
  912.      result-bit-array)))
  913.  
  914. (defmacro def-bit-array-op (name function)
  915.   `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
  916.      ,(format nil
  917.           "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
  918.           BIT-ARRAY-2,~%  putting the results in RESULT-BIT-ARRAY.  ~
  919.           If RESULT-BIT-ARRAY is T,~%  BIT-ARRAY-1 is used.  If ~
  920.           RESULT-BIT-ARRAY is NIL or omitted, a new array is~%  created.  ~
  921.           All the arrays must have the same rank and dimensions."
  922.           (symbol-name function))
  923.      (declare (type (array bit) bit-array-1 bit-array-2)
  924.           (type (or (array bit) (member t nil)) result-bit-array))
  925.      (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
  926.        (error "~S and ~S do not have the same dimensions."
  927.           bit-array-1 bit-array-2))
  928.      (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
  929.        (if (and (simple-bit-vector-p bit-array-1)
  930.         (simple-bit-vector-p bit-array-2)
  931.         (simple-bit-vector-p result-bit-array))
  932.        (locally (declare (optimize (speed 3) (safety 0)))
  933.          (,name bit-array-1 bit-array-2 result-bit-array))
  934.        (with-array-data ((data1 bit-array-1) (start1) (end1))
  935.          (declare (ignore end1))
  936.          (with-array-data ((data2 bit-array-2) (start2) (end2))
  937.            (declare (ignore end2))
  938.            (with-array-data ((data3 result-bit-array) (start3) (end3))
  939.          (do ((index-1 start1 (1+ index-1))
  940.               (index-2 start2 (1+ index-2))
  941.               (index-3 start3 (1+ index-3)))
  942.              ((>= index-3 end3) result-bit-array)
  943.            (declare (type index index-1 index-2 index-3))
  944.            (setf (sbit data3 index-3)
  945.              (logand (,function (sbit data1 index-1)
  946.                         (sbit data2 index-2))
  947.                  1))))))))))
  948.  
  949. (def-bit-array-op bit-and logand)
  950. (def-bit-array-op bit-ior logior)
  951. (def-bit-array-op bit-xor logxor)
  952. (def-bit-array-op bit-eqv logeqv)
  953. (def-bit-array-op bit-nand lognand)
  954. (def-bit-array-op bit-nor lognor)
  955. (def-bit-array-op bit-andc1 logandc1)
  956. (def-bit-array-op bit-andc2 logandc2)
  957. (def-bit-array-op bit-orc1 logorc1)
  958. (def-bit-array-op bit-orc2 logorc2)
  959.  
  960. (defun bit-not (bit-array &optional result-bit-array)
  961.   "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
  962.   putting the results in RESULT-BIT-ARRAY.  If RESULT-BIT-ARRAY is T,
  963.   BIT-ARRAY is used.  If RESULT-BIT-ARRAY is NIL or omitted, a new array is
  964.   created.  Both arrays must have the same rank and dimensions."
  965.   (declare (type (array bit) bit-array)
  966.        (type (or (array bit) (member t nil)) result-bit-array))
  967.   (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
  968.     (if (and (simple-bit-vector-p bit-array)
  969.          (simple-bit-vector-p result-bit-array))
  970.     (locally (declare (optimize (speed 3) (safety 0)))
  971.       (bit-not bit-array result-bit-array))
  972.     (with-array-data ((src bit-array) (src-start) (src-end))
  973.       (declare (ignore src-end))
  974.       (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
  975.         (do ((src-index src-start (1+ src-index))
  976.          (dst-index dst-start (1+ dst-index)))
  977.         ((>= dst-index dst-end) result-bit-array)
  978.           (declare (type index src-index dst-index))
  979.           (setf (sbit dst dst-index)
  980.             (logxor (sbit src src-index) 1))))))))
  981.