spook

srfi-25.scm (42123B)

---

 ;;;; srfi-25.scm - Jussi Piitulainen's array library
 
 
 (define array:array-tag (list 'array))
 
 (define (array:make vec ind shp) (vector array:array-tag vec ind shp))
 (define (array:array? x) (and (vector? x) (eq? (vector-ref x 0) array:array-tag)))
 (define (array:vector a) (vector-ref a 1))
 (define (array:index a) (vector-ref a 2))
 (define (array:shape a) (vector-ref a 3))
 
 
 ;;; array
 ;;; 1997 - 2001 Jussi Piitulainen
 
 
 ;;; --- Intro ---
 
 ;;; This interface to arrays is based on Alan Bawden's array.scm of
 ;;; 1993 (earlier version in the Internet Repository and another
 ;;; version in SLIB). This is a complete rewrite, to be consistent
 ;;; with the rest of Scheme and to make arrays independent of lists.
 
 ;;; Some modifications are due to discussion in srfi-25 mailing list.
 
 ;;; (array? obj)
 ;;; (make-array shape [obj])             changed arguments
 ;;; (shape bound ...)                    new
 ;;; (array shape obj ...)                new
 ;;; (array-rank array)                   changed name back
 ;;; (array-start array dimension)        new
 ;;; (array-end array dimension)          new
 ;;; (array-ref array k ...)
 ;;; (array-ref array index)              new variant
 ;;; (array-set! array k ... obj)         changed argument order
 ;;; (array-set! array index obj)         new variant
 ;;; (share-array array shape proc)       changed arguments
 
 ;;; All other variables in this file have names in "array:".
 
 ;;; Should there be a way to make arrays with initial values mapped
 ;;; from indices? Sure. The current "initial object" is lame.
 ;;;
 ;;; Removed (array-shape array) from here. There is a new version
 ;;; in arlib though.
 
 ;;; --- Representation type dependencies ---
 
 ;;; The mapping from array indices to the index to the underlying vector
 ;;; is whatever array:optimize returns. The file "opt" provides three
 ;;; representations:
 ;;; 
 ;;; mbda) mapping is a procedure that allows an optional argument
 ;;; tter) mapping is two procedures that takes exactly the indices
 ;;; ctor) mapping is a vector of a constant term and coefficients
 ;;;
 ;;; Choose one in "opt" to make the optimizer. Then choose the matching
 ;;; implementation of array-ref and array-set!.
 ;;;
 ;;; These should be made macros to inline them. Or have a good compiler
 ;;; and plant the package as a module.
 
 ;;; 1. Pick an optimizer.
 ;;; 2. Pick matching index representation.
 ;;; 3. Pick a record implementation; as-procedure is generic; syntax inlines.
 ;;; 3. This file is otherwise portable.
 
 ;;; --- Portable R5RS (R4RS and multiple values) ---
 
 ;;; (array? obj)
 ;;; returns #t if `obj' is an array and #t or #f otherwise.
 
 (define (array? obj)
    (array:array? obj))
 
 (define-syntax check-array
   (syntax-rules ()
     ((_ x loc)
      (let ((var x))
        (or (##core#check (array:array? var))
 	   (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not an array") var) ) ) ) ) )
 
 ;;; (make-array shape)
 ;;; (make-array shape obj)
 ;;; makes array of `shape' with each cell containing `obj' initially.
 
 (define (make-array shape . rest)
   (or (##core#check (array:good-shape? shape))
       (##sys#signal-hook #:type-error 'make-array "bad argument type - not a valid shape" shape))
   (apply array:make-array shape rest))
 
 (define (array:make-array shape . rest)
   (let ((size (array:size shape)))
     (array:make
      (if (pair? rest)
          (apply (lambda (o) (make-vector size o)) rest)
          (make-vector size))
      (if (= size 0)
          (array:optimize-empty
           (vector-ref (array:shape shape) 1))
          (array:optimize
           (array:make-index shape)
           (vector-ref (array:shape shape) 1)))
      (array:shape->vector shape))))
 
 ;;; (shape bound ...)
 ;;; makes a shape. Bounds must be an even number of exact, pairwise
 ;;; non-decreasing integers. Note that any such array can be a shape.
 
 (define (shape . bounds)
   (let ((v (list->vector bounds)))
     (or (##core#check (even? (vector-length v)))
         (##sys#error 'shape "uneven number of bounds" bounds) )
     (let ((shp (array:make
                 v
                 (if (pair? bounds)
                     (array:shape-index)
                     (array:empty-shape-index))
                 (vector 0 (quotient (vector-length v) 2)
                         0 2))))
       (or (##core#check (array:good-shape? shp))
           (##sys#signal-hook #:type-error 'shape "bounds are not pairwise non-decreasing exact integers" bounds) )
       shp)))
 
 ;;; (array shape obj ...)
 ;;; is analogous to `vector'.
 
 (define (array shape . elts)
   (or (##core#check (array:good-shape? shape))
       (##sys#signal-hook #:type-error 'array "bad argument type - not a valid shape" shape) )
   (let ((size (array:size shape)))
     (let ((vector (list->vector elts)))
       (or (##core#check (= (vector-length vector) size))
           (##sys#error 'array "bad number of elements" shape elts) )
       (array:make
        vector
        (if (= size 0)
            (array:optimize-empty
             (vector-ref (array:shape shape) 1))
            (array:optimize
             (array:make-index shape)
             (vector-ref (array:shape shape) 1)))
        (array:shape->vector shape)))))
 
 ;;; (array-rank array)
 ;;; returns the number of dimensions of `array'.
 
 (define (array-rank array)
   (check-array array 'array-rank)
   (quotient (vector-length (array:shape array)) 2))
 
 ;;; (array-start array k)
 ;;; returns the lower bound index of array along dimension k. This is
 ;;; the least valid index along that dimension if the dimension is not
 ;;; empty.
 
 (define (array-start array d)
   (check-array array 'array-start)
   (vector-ref (array:shape array) (+ d d)))
 
 ;;; (array-end array k)
 ;;; returns the upper bound index of array along dimension k. This is
 ;;; not a valid index. If the dimension is empty, this is the same as
 ;;; the lower bound along it.
 
 (define (array-end array d)
   (check-array array 'array-end)
   (vector-ref (array:shape array) (+ d d 1)))
 
 ;;; (share-array array shape proc)
 ;;; makes an array that shares elements of `array' at shape `shape'.
 ;;; The arguments to `proc' are indices of the result.  The values of
 ;;; `proc' are indices of `array'.
 
 ;;; Todo: in the error message, should recognise the mapping and show it.
 
 (define (share-array array subshape f)
   (check-array array 'share-array)
   (or (##core#check (array:good-shape? subshape))
       (##sys#signal-hook #:type-error 'share-array "not a shape" subshape) )
   (let ((subsize (array:size subshape)))
     (or (##core#check (array:good-share? subshape subsize f (array:shape array)))
         (##sys#error 'share-array "subshape does not map into supershape" subshape shape) )
     (let ((g (array:index array)))
       (array:make
        (array:vector array)
        (if (= subsize 0)
            (array:optimize-empty
             (vector-ref (array:shape subshape) 1))
            (array:optimize
             (lambda ks
               (call-with-values
                (lambda () (apply f ks))
                (lambda ks (array:vector-index g ks))))
             (vector-ref (array:shape subshape) 1)))
        (array:shape->vector subshape)))))
 
 ;;; --- Hrmph ---
 
 ;;; (array:share/index! ...)
 ;;; reuses a user supplied index object when recognising the
 ;;; mapping. The mind balks at the very nasty side effect that
 ;;; exposes the implementation. So this is not in the spec.
 ;;; But letting index objects in at all creates a pressure
 ;;; to go the whole hog. Arf.
 
 ;;; Use array:optimize-empty for an empty array to get a
 ;;; clearly invalid vector index.
 
 ;;; Surely it's perverse to use an actor for index here? But
 ;;; the possibility is provided for completeness.
 
 (define (array:share/index! array subshape proc index)
   (array:make
    (array:vector array)
    (if (= (array:size subshape) 0)
        (array:optimize-empty
         (quotient (vector-length (array:shape array)) 2))
        ((if (vector? index)
             array:optimize/vector
             array:optimize/actor)
         (lambda (subindex)
           (let ((superindex (proc subindex)))
             (if (vector? superindex)
                 (array:index/vector
                  (quotient (vector-length (array:shape array)) 2)
                  (array:index array)
                  superindex)
                 (array:index/array
                  (quotient (vector-length (array:shape array)) 2)
                  (array:index array)
                  (array:vector superindex)
                  (array:index superindex)))))
         index))
    (array:shape->vector subshape)))
 
 (define (array:optimize/vector f v)
   (let ((r (vector-length v)))
     (do ((k 0 (+ k 1)))
       ((= k r))
       (vector-set! v k 0))
     (let ((n0 (f v))
           (cs (make-vector (+ r 1)))
           (apply (array:applier-to-vector (+ r 1))))
       (vector-set! cs 0 n0)
       (let wok ((k 0))
         (if (< k r)
             (let ((k1 (+ k 1)))
               (vector-set! v k 1)
               (let ((nk (- (f v) n0)))
                 (vector-set! v k 0)
                 (vector-set! cs k1 nk)
                 (wok k1)))))
       (apply (array:maker r) cs))))
 
 (define (array:optimize/actor f a)
   (let ((r (array-end a 0))
         (v (array:vector a))
         (i (array:index a)))
     (do ((k 0 (+ k 1)))
       ((= k r))
       (vector-set! v (array:actor-index i k) 0))
     (let ((n0 (f a))
           (cs (make-vector (+ r 1)))
           (apply (array:applier-to-vector (+ r 1))))
       (vector-set! cs 0 n0)
       (let wok ((k 0))
         (if (< k r)
             (let ((k1 (+ k 1))
                   (t (array:actor-index i k)))
               (vector-set! v t 1)
               (let ((nk (- (f a) n0)))
                 (vector-set! v t 0)
                 (vector-set! cs k1 nk)
                 (wok k1)))))
       (apply (array:maker r) cs))))
 
 ;;; --- Internals ---
 
 (define (array:shape->vector shape)
   (let ((idx (array:index shape))
         (shv (array:vector shape))
         (rnk (vector-ref (array:shape shape) 1)))
     (let ((vec (make-vector (* rnk 2))))
       (do ((k 0 (+ k 1)))
         ((= k rnk)
          vec)
         (vector-set! vec (+ k k)
                      (vector-ref shv (array:shape-vector-index idx k 0)))
         (vector-set! vec (+ k k 1)
                      (vector-ref shv (array:shape-vector-index idx k 1)))))))
 
 ;;; (array:size shape)
 ;;; returns the number of elements in arrays of shape `shape'.
 
 (define (array:size shape)
    (let ((idx (array:index shape))
          (shv (array:vector shape))
          (rnk (vector-ref (array:shape shape) 1)))
      (do   ((k 0 (+ k 1))
             (s 1 (* s
                     (- (vector-ref shv (array:shape-vector-index idx k 1))
                        (vector-ref shv (array:shape-vector-index idx k 0))))))
        ((= k rnk) s))))
 
 ;;; (array:make-index shape)
 ;;; returns an index function for arrays of shape `shape'. This is a
 ;;; runtime composition of several variable arity procedures, to be
 ;;; passed to array:optimize for recognition as an affine function of
 ;;; as many variables as there are dimensions in arrays of this shape.
 
 (define (array:make-index shape)
    (let ((idx (array:index shape))
          (shv (array:vector shape))
          (rnk (vector-ref (array:shape shape) 1)))
      (do ((f (lambda () 0)
              (lambda (k . ks)
                (+ (* s (- k (vector-ref
                              shv
                              (array:shape-vector-index idx (- j 1) 0))))
                   (apply f ks))))
           (s 1 (* s (- (vector-ref
                         shv
                         (array:shape-vector-index idx (- j 1) 1))
                        (vector-ref
                         shv
                         (array:shape-vector-index idx (- j 1) 0)))))
           (j rnk (- j 1)))
        ((= j 0)
         f))))
 
 
 ;;; --- Error checking ---
 
 ;;; (array:good-shape? shape)
 ;;; returns true if `shape' is an array of the right shape and its
 ;;; elements are exact integers that pairwise bound intervals `[lo..hi)´.
 
 (define (array:good-shape? shape)
   (and (array:array? shape)
        (let ((u (array:shape shape))
              (v (array:vector shape))
              (x (array:index shape)))
          (and (= (vector-length u) 4)
               (= (vector-ref u 0) 0)
               (= (vector-ref u 2) 0)
               (= (vector-ref u 3) 2))
          (let ((p (vector-ref u 1)))
            (do ((k 0 (+ k 1))
                 (true #t (let ((lo (vector-ref
                                     v
                                     (array:shape-vector-index x k 0)))
                                (hi (vector-ref
                                     v
                                     (array:shape-vector-index x k 1))))
                            (and true
                                 (integer? lo)
                                 (exact? lo)
                                 (integer? hi)
                                 (exact? hi)
                                 (<= lo hi)))))
              ((= k p) true))))))
 
 ;;; (array:good-share? subv subsize mapping superv)
 ;;; returns true if the extreme indices in the subshape vector map
 ;;; into the bounds in the supershape vector.
 
 ;;; If some interval in `subv' is empty, then `subv' is empty and its
 ;;; image under `f' is empty and it is trivially alright.  One must
 ;;; not call `f', though.
 
 (define (array:good-share? subshape subsize f super)
   (or (zero? subsize)
       (letrec
           ((sub (array:vector subshape))
            (dex (array:index subshape))
            (ck (lambda (k ks)
 		 (if (zero? k)
                      (call-with-values
                       (lambda () (apply f ks))
                       (lambda qs (array:good-indices? qs super)))
                      (and (ck (- k 1)
                               (cons (vector-ref
                                      sub
                                      (array:shape-vector-index
                                       dex
                                       (- k 1)
                                       0))
                                     ks))
                           (ck (- k 1)
                               (cons (- (vector-ref
                                         sub
                                         (array:shape-vector-index
                                          dex
                                          (- k 1)
                                          1))
                                        1)
                                     ks)))))))
         (let ((rnk (vector-ref (array:shape subshape) 1)))
           (or (array:unchecked-share-depth? rnk)
               (ck rnk '()))))))
 
 ;;; Check good-share on 10 dimensions at most. The trouble is,
 ;;; the cost of this check is exponential in the number of dimensions.
 
 (define (array:unchecked-share-depth? rank)
   (if (> rank 10)
       (begin
         (display `(warning: unchecked depth in share:
                             ,rank subdimensions))
         (newline)
         #t)
       #f))
 
 ;;; (array:check-indices caller indices shape-vector)
 ;;; (array:check-indices.o caller indices shape-vector)
 ;;; (array:check-index-vector caller index-vector shape-vector)
 ;;; return if the index is in bounds, else signal error.
 ;;;
 ;;; Shape-vector is the internal representation, with
 ;;; b and e for dimension k at 2k and 2k + 1.
 
 (define (array:check-indices who ks shv)
   (or (array:good-indices? ks shv)
       (##sys#signal-hook #:bounds-error (array:not-in who ks shv))))
 
 (define (array:check-indices.o who ks shv)
   (or (array:good-indices.o? ks shv)
       (##sys#signal-hook #:bounds-error (array:not-in who (reverse (cdr (reverse ks))) shv))))
 
 (define (array:check-index-vector who ks shv)
   (or (array:good-index-vector? ks shv)
       (##sys#signal-hook #:bounds-error (array:not-in who (vector->list ks) shv))))
 
 (define (array:check-index-actor who ks shv)
   (let ((shape (array:shape ks)))
     (or (and (= (vector-length shape) 2)
              (= (vector-ref shape 0) 0))
         (##sys#signal-hook #:type-error "not an actor"))
     (or (array:good-index-actor?
          (vector-ref shape 1)
          (array:vector ks)
          (array:index ks)
          shv)
         (array:not-in who (do ((k (vector-ref shape 1) (- k 1))
                                (m '() (cons (vector-ref
                                              (array:vector ks)
                                              (array:actor-index
                                               (array:index ks)
                                               (- k 1)))
                                             m)))
                             ((= k 0) m))
                       shv))))
 
 (define (array:good-indices? ks shv)
    (let ((d2 (vector-length shv)))
       (do ((kp ks (if (pair? kp)
                       (cdr kp)))
            (k 0 (+ k 2))
            (true #t (and true (pair? kp)
                          (array:good-index? (car kp) shv k))))
         ((= k d2)
          (and true (null? kp))))))
 
 (define (array:good-indices.o? ks.o shv)
    (let ((d2 (vector-length shv)))
      (do   ((kp ks.o (if (pair? kp)
                          (cdr kp)))
             (k 0 (+ k 2))
             (true #t (and true (pair? kp)
                           (array:good-index? (car kp) shv k))))
        ((= k d2)
         (and true (pair? kp) (null? (cdr kp)))))))
 
 (define (array:good-index-vector? ks shv)
   (let ((r2 (vector-length shv)))
     (and (= (* 2 (vector-length ks)) r2)
          (do ((j 0 (+ j 1))
               (k 0 (+ k 2))
               (true #t (and true
                             (array:good-index? (vector-ref ks j) shv k))))
            ((= k r2) true)))))
 
 (define (array:good-index-actor? r v i shv)
   (and (= (* 2 r) (vector-length shv))
        (do ((j 0 (+ j 1))
             (k 0 (+ k 2))
             (true #t (and true
                           (array:good-index? (vector-ref
                                               v
                                               (array:actor-index i j))
                                              shv
                                              k))))
          ((= j r) true))))
 
 ;;; (array:good-index? index shape-vector 2d)
 ;;; returns true if index is within bounds for dimension 2d/2.
 
 (define (array:good-index? w shv k)
   (and (integer? w)
        (exact? w)
        (<= (vector-ref shv k) w)
        (< w (vector-ref shv (+ k 1)))))
 
 (define (array:not-in who ks shv)
   (##sys#signal-hook #:bounds-error (string-append who ": index not in bounds") ks shv) )
 
 
 (begin
   (define (array:coefficients f n0 vs vp)
     (case vp
       ((()) '())
       (else
        (set-car! vp 1)
        (let ((n (- (apply f vs) n0)))
          (set-car! vp 0)
          (cons n (array:coefficients f n0 vs (cdr vp)))))))
   (define (array:vector-index x ks)
     (do ((sum 0 (+ sum (* (vector-ref x k) (car ks))))
          (ks ks (cdr ks))
          (k 0 (+ k 1)))
         ((null? ks) (+ sum (vector-ref x k)))))
   (define (array:shape-index) '#(2 1 0))
   (define (array:empty-shape-index) '#(0 0 -1))
   (define (array:shape-vector-index x r k)
     (+
      (* (vector-ref x 0) r)
      (* (vector-ref x 1) k)
      (vector-ref x 2)))
   (define (array:actor-index x k)
     (+ (* (vector-ref x 0) k) (vector-ref x 1)))
   (define (array:0 n0) (vector n0))
   (define (array:1 n0 n1) (vector n1 n0))
   (define (array:2 n0 n1 n2) (vector n1 n2 n0))
   (define (array:3 n0 n1 n2 n3) (vector n1 n2 n3 n0))
   (define (array:n n0 n1 n2 n3 n4 . ns)
     (apply vector n1 n2 n3 n4 (append ns (list n0))))
   (define (array:maker r)
     (case r
       ((0) array:0)
       ((1) array:1)
       ((2) array:2)
       ((3) array:3)
       (else array:n)))
   (define array:indexer/vector
     (let ((em
            (vector
 	    (lambda (x i) (+ (vector-ref x 0)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (vector-ref x 1)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (* (vector-ref x 1) (vector-ref i 1))
 	       (vector-ref x 2)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (* (vector-ref x 1) (vector-ref i 1))
 	       (* (vector-ref x 2) (vector-ref i 2))
 	       (vector-ref x 3)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (* (vector-ref x 1) (vector-ref i 1))
 	       (* (vector-ref x 2) (vector-ref i 2))
 	       (* (vector-ref x 3) (vector-ref i 3))
 	       (vector-ref x 4)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (* (vector-ref x 1) (vector-ref i 1))
 	       (* (vector-ref x 2) (vector-ref i 2))
 	       (* (vector-ref x 3) (vector-ref i 3))
 	       (* (vector-ref x 4) (vector-ref i 4))
 	       (vector-ref x 5)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (* (vector-ref x 1) (vector-ref i 1))
 	       (* (vector-ref x 2) (vector-ref i 2))
 	       (* (vector-ref x 3) (vector-ref i 3))
 	       (* (vector-ref x 4) (vector-ref i 4))
 	       (* (vector-ref x 5) (vector-ref i 5))
 	       (vector-ref x 6)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (* (vector-ref x 1) (vector-ref i 1))
 	       (* (vector-ref x 2) (vector-ref i 2))
 	       (* (vector-ref x 3) (vector-ref i 3))
 	       (* (vector-ref x 4) (vector-ref i 4))
 	       (* (vector-ref x 5) (vector-ref i 5))
 	       (* (vector-ref x 6) (vector-ref i 6))
 	       (vector-ref x 7)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (* (vector-ref x 1) (vector-ref i 1))
 	       (* (vector-ref x 2) (vector-ref i 2))
 	       (* (vector-ref x 3) (vector-ref i 3))
 	       (* (vector-ref x 4) (vector-ref i 4))
 	       (* (vector-ref x 5) (vector-ref i 5))
 	       (* (vector-ref x 6) (vector-ref i 6))
 	       (* (vector-ref x 7) (vector-ref i 7))
 	       (vector-ref x 8)))
 	    (lambda (x i)
 	      (+
 	       (* (vector-ref x 0) (vector-ref i 0))
 	       (* (vector-ref x 1) (vector-ref i 1))
 	       (* (vector-ref x 2) (vector-ref i 2))
 	       (* (vector-ref x 3) (vector-ref i 3))
 	       (* (vector-ref x 4) (vector-ref i 4))
 	       (* (vector-ref x 5) (vector-ref i 5))
 	       (* (vector-ref x 6) (vector-ref i 6))
 	       (* (vector-ref x 7) (vector-ref i 7))
 	       (* (vector-ref x 8) (vector-ref i 8))
 	       (vector-ref x 9)))))
           (it
            (lambda (w)
              (lambda (x i)
                (+
                 (* (vector-ref x 0) (vector-ref i 0))
                 (* (vector-ref x 1) (vector-ref i 1))
                 (* (vector-ref x 2) (vector-ref i 2))
                 (* (vector-ref x 3) (vector-ref i 3))
                 (* (vector-ref x 4) (vector-ref i 4))
                 (* (vector-ref x 5) (vector-ref i 5))
                 (* (vector-ref x 6) (vector-ref i 6))
                 (* (vector-ref x 7) (vector-ref i 7))
                 (* (vector-ref x 8) (vector-ref i 8))
                 (* (vector-ref x 9) (vector-ref i 9))
                 (do ((xi
                       0
                       (+
                        (* (vector-ref x u) (vector-ref i u))
                        xi))
                      (u (- w 1) (- u 1)))
                     ((< u 10) xi))
                 (vector-ref x w))))))
       (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
   (define array:indexer/array
     (let ((em
            (vector
 	    (lambda (x v i) (+ (vector-ref x 0)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (vector-ref x 1)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (*
 		(vector-ref x 1)
 		(vector-ref v (array:actor-index i 1)))
 	       (vector-ref x 2)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (*
 		(vector-ref x 1)
 		(vector-ref v (array:actor-index i 1)))
 	       (*
 		(vector-ref x 2)
 		(vector-ref v (array:actor-index i 2)))
 	       (vector-ref x 3)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (*
 		(vector-ref x 1)
 		(vector-ref v (array:actor-index i 1)))
 	       (*
 		(vector-ref x 2)
 		(vector-ref v (array:actor-index i 2)))
 	       (*
 		(vector-ref x 3)
 		(vector-ref v (array:actor-index i 3)))
 	       (vector-ref x 4)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (*
 		(vector-ref x 1)
 		(vector-ref v (array:actor-index i 1)))
 	       (*
 		(vector-ref x 2)
 		(vector-ref v (array:actor-index i 2)))
 	       (*
 		(vector-ref x 3)
 		(vector-ref v (array:actor-index i 3)))
 	       (*
 		(vector-ref x 4)
 		(vector-ref v (array:actor-index i 4)))
 	       (vector-ref x 5)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (*
 		(vector-ref x 1)
 		(vector-ref v (array:actor-index i 1)))
 	       (*
 		(vector-ref x 2)
 		(vector-ref v (array:actor-index i 2)))
 	       (*
 		(vector-ref x 3)
 		(vector-ref v (array:actor-index i 3)))
 	       (*
 		(vector-ref x 4)
 		(vector-ref v (array:actor-index i 4)))
 	       (*
 		(vector-ref x 5)
 		(vector-ref v (array:actor-index i 5)))
 	       (vector-ref x 6)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (*
 		(vector-ref x 1)
 		(vector-ref v (array:actor-index i 1)))
 	       (*
 		(vector-ref x 2)
 		(vector-ref v (array:actor-index i 2)))
 	       (*
 		(vector-ref x 3)
 		(vector-ref v (array:actor-index i 3)))
 	       (*
 		(vector-ref x 4)
 		(vector-ref v (array:actor-index i 4)))
 	       (*
 		(vector-ref x 5)
 		(vector-ref v (array:actor-index i 5)))
 	       (*
 		(vector-ref x 6)
 		(vector-ref v (array:actor-index i 6)))
 	       (vector-ref x 7)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (*
 		(vector-ref x 1)
 		(vector-ref v (array:actor-index i 1)))
 	       (*
 		(vector-ref x 2)
 		(vector-ref v (array:actor-index i 2)))
 	       (*
 		(vector-ref x 3)
 		(vector-ref v (array:actor-index i 3)))
 	       (*
 		(vector-ref x 4)
 		(vector-ref v (array:actor-index i 4)))
 	       (*
 		(vector-ref x 5)
 		(vector-ref v (array:actor-index i 5)))
 	       (*
 		(vector-ref x 6)
 		(vector-ref v (array:actor-index i 6)))
 	       (*
 		(vector-ref x 7)
 		(vector-ref v (array:actor-index i 7)))
 	       (vector-ref x 8)))
 	    (lambda (x v i)
 	      (+
 	       (*
 		(vector-ref x 0)
 		(vector-ref v (array:actor-index i 0)))
 	       (*
 		(vector-ref x 1)
 		(vector-ref v (array:actor-index i 1)))
 	       (*
 		(vector-ref x 2)
 		(vector-ref v (array:actor-index i 2)))
 	       (*
 		(vector-ref x 3)
 		(vector-ref v (array:actor-index i 3)))
 	       (*
 		(vector-ref x 4)
 		(vector-ref v (array:actor-index i 4)))
 	       (*
 		(vector-ref x 5)
 		(vector-ref v (array:actor-index i 5)))
 	       (*
 		(vector-ref x 6)
 		(vector-ref v (array:actor-index i 6)))
 	       (*
 		(vector-ref x 7)
 		(vector-ref v (array:actor-index i 7)))
 	       (*
 		(vector-ref x 8)
 		(vector-ref v (array:actor-index i 8)))
 	       (vector-ref x 9)))))
           (it
            (lambda (w)
              (lambda (x v i)
                (+
                 (*
                  (vector-ref x 0)
                  (vector-ref v (array:actor-index i 0)))
                 (*
                  (vector-ref x 1)
                  (vector-ref v (array:actor-index i 1)))
                 (*
                  (vector-ref x 2)
                  (vector-ref v (array:actor-index i 2)))
                 (*
                  (vector-ref x 3)
                  (vector-ref v (array:actor-index i 3)))
                 (*
                  (vector-ref x 4)
                  (vector-ref v (array:actor-index i 4)))
                 (*
                  (vector-ref x 5)
                  (vector-ref v (array:actor-index i 5)))
                 (*
                  (vector-ref x 6)
                  (vector-ref v (array:actor-index i 6)))
                 (*
                  (vector-ref x 7)
                  (vector-ref v (array:actor-index i 7)))
                 (*
                  (vector-ref x 8)
                  (vector-ref v (array:actor-index i 8)))
                 (*
                  (vector-ref x 9)
                  (vector-ref v (array:actor-index i 9)))
                 (do ((xi
                       0
                       (+
                        (*
                         (vector-ref x u)
                         (vector-ref
 			 v
 			 (array:actor-index i u)))
                        xi))
                      (u (- w 1) (- u 1)))
                     ((< u 10) xi))
                 (vector-ref x w))))))
       (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
   (define array:applier-to-vector
     (let ((em
            (vector
 	    (lambda (p v) (p))
 	    (lambda (p v) (p (vector-ref v 0)))
 	    (lambda (p v)
 	      (p (vector-ref v 0) (vector-ref v 1)))
 	    (lambda (p v)
 	      (p
 	       (vector-ref v 0)
 	       (vector-ref v 1)
 	       (vector-ref v 2)))
 	    (lambda (p v)
 	      (p
 	       (vector-ref v 0)
 	       (vector-ref v 1)
 	       (vector-ref v 2)
 	       (vector-ref v 3)))
 	    (lambda (p v)
 	      (p
 	       (vector-ref v 0)
 	       (vector-ref v 1)
 	       (vector-ref v 2)
 	       (vector-ref v 3)
 	       (vector-ref v 4)))
 	    (lambda (p v)
 	      (p
 	       (vector-ref v 0)
 	       (vector-ref v 1)
 	       (vector-ref v 2)
 	       (vector-ref v 3)
 	       (vector-ref v 4)
 	       (vector-ref v 5)))
 	    (lambda (p v)
 	      (p
 	       (vector-ref v 0)
 	       (vector-ref v 1)
 	       (vector-ref v 2)
 	       (vector-ref v 3)
 	       (vector-ref v 4)
 	       (vector-ref v 5)
 	       (vector-ref v 6)))
 	    (lambda (p v)
 	      (p
 	       (vector-ref v 0)
 	       (vector-ref v 1)
 	       (vector-ref v 2)
 	       (vector-ref v 3)
 	       (vector-ref v 4)
 	       (vector-ref v 5)
 	       (vector-ref v 6)
 	       (vector-ref v 7)))
 	    (lambda (p v)
 	      (p
 	       (vector-ref v 0)
 	       (vector-ref v 1)
 	       (vector-ref v 2)
 	       (vector-ref v 3)
 	       (vector-ref v 4)
 	       (vector-ref v 5)
 	       (vector-ref v 6)
 	       (vector-ref v 7)
 	       (vector-ref v 8)))))
           (it
            (lambda (r)
              (lambda (p v)
                (apply
                 p
                 (vector-ref v 0)
                 (vector-ref v 1)
                 (vector-ref v 2)
                 (vector-ref v 3)
                 (vector-ref v 4)
                 (vector-ref v 5)
                 (vector-ref v 6)
                 (vector-ref v 7)
                 (vector-ref v 8)
                 (vector-ref v 9)
                 (do ((k r (- k 1))
                      (r
                       '()
                       (cons (vector-ref v (- k 1)) r)))
                     ((= k 10) r)))))))
       (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
   (define array:applier-to-actor
     (let ((em
            (vector
 	    (lambda (p a) (p))
 	    (lambda (p a) (p (array-ref a 0)))
 	    (lambda (p a)
 	      (p (array-ref a 0) (array-ref a 1)))
 	    (lambda (p a)
 	      (p
 	       (array-ref a 0)
 	       (array-ref a 1)
 	       (array-ref a 2)))
 	    (lambda (p a)
 	      (p
 	       (array-ref a 0)
 	       (array-ref a 1)
 	       (array-ref a 2)
 	       (array-ref a 3)))
 	    (lambda (p a)
 	      (p
 	       (array-ref a 0)
 	       (array-ref a 1)
 	       (array-ref a 2)
 	       (array-ref a 3)
 	       (array-ref a 4)))
 	    (lambda (p a)
 	      (p
 	       (array-ref a 0)
 	       (array-ref a 1)
 	       (array-ref a 2)
 	       (array-ref a 3)
 	       (array-ref a 4)
 	       (array-ref a 5)))
 	    (lambda (p a)
 	      (p
 	       (array-ref a 0)
 	       (array-ref a 1)
 	       (array-ref a 2)
 	       (array-ref a 3)
 	       (array-ref a 4)
 	       (array-ref a 5)
 	       (array-ref a 6)))
 	    (lambda (p a)
 	      (p
 	       (array-ref a 0)
 	       (array-ref a 1)
 	       (array-ref a 2)
 	       (array-ref a 3)
 	       (array-ref a 4)
 	       (array-ref a 5)
 	       (array-ref a 6)
 	       (array-ref a 7)))
 	    (lambda (p a)
 	      (p
 	       (array-ref a 0)
 	       (array-ref a 1)
 	       (array-ref a 2)
 	       (array-ref a 3)
 	       (array-ref a 4)
 	       (array-ref a 5)
 	       (array-ref a 6)
 	       (array-ref a 7)
 	       (array-ref a 8)))))
           (it
            (lambda (r)
              (lambda (p a)
                (apply
                 a
                 (array-ref a 0)
                 (array-ref a 1)
                 (array-ref a 2)
                 (array-ref a 3)
                 (array-ref a 4)
                 (array-ref a 5)
                 (array-ref a 6)
                 (array-ref a 7)
                 (array-ref a 8)
                 (array-ref a 9)
                 (do ((k r (- k 1))
                      (r '() (cons (array-ref a (- k 1)) r)))
                     ((= k 10) r)))))))
       (lambda (r)
         "These are high level, hiding implementation at call site."
         (if (< r 10) (vector-ref em r) (it r)))))
   (define array:applier-to-backing-vector
     (let ((em
            (vector
 	    (lambda (p ai av) (p))
 	    (lambda (p ai av)
 	      (p (vector-ref av (array:actor-index ai 0))))
 	    (lambda (p ai av)
 	      (p
 	       (vector-ref av (array:actor-index ai 0))
 	       (vector-ref av (array:actor-index ai 1))))
 	    (lambda (p ai av)
 	      (p
 	       (vector-ref av (array:actor-index ai 0))
 	       (vector-ref av (array:actor-index ai 1))
 	       (vector-ref av (array:actor-index ai 2))))
 	    (lambda (p ai av)
 	      (p
 	       (vector-ref av (array:actor-index ai 0))
 	       (vector-ref av (array:actor-index ai 1))
 	       (vector-ref av (array:actor-index ai 2))
 	       (vector-ref av (array:actor-index ai 3))))
 	    (lambda (p ai av)
 	      (p
 	       (vector-ref av (array:actor-index ai 0))
 	       (vector-ref av (array:actor-index ai 1))
 	       (vector-ref av (array:actor-index ai 2))
 	       (vector-ref av (array:actor-index ai 3))
 	       (vector-ref av (array:actor-index ai 4))))
 	    (lambda (p ai av)
 	      (p
 	       (vector-ref av (array:actor-index ai 0))
 	       (vector-ref av (array:actor-index ai 1))
 	       (vector-ref av (array:actor-index ai 2))
 	       (vector-ref av (array:actor-index ai 3))
 	       (vector-ref av (array:actor-index ai 4))
 	       (vector-ref av (array:actor-index ai 5))))
 	    (lambda (p ai av)
 	      (p
 	       (vector-ref av (array:actor-index ai 0))
 	       (vector-ref av (array:actor-index ai 1))
 	       (vector-ref av (array:actor-index ai 2))
 	       (vector-ref av (array:actor-index ai 3))
 	       (vector-ref av (array:actor-index ai 4))
 	       (vector-ref av (array:actor-index ai 5))
 	       (vector-ref av (array:actor-index ai 6))))
 	    (lambda (p ai av)
 	      (p
 	       (vector-ref av (array:actor-index ai 0))
 	       (vector-ref av (array:actor-index ai 1))
 	       (vector-ref av (array:actor-index ai 2))
 	       (vector-ref av (array:actor-index ai 3))
 	       (vector-ref av (array:actor-index ai 4))
 	       (vector-ref av (array:actor-index ai 5))
 	       (vector-ref av (array:actor-index ai 6))
 	       (vector-ref av (array:actor-index ai 7))))
 	    (lambda (p ai av)
 	      (p
 	       (vector-ref av (array:actor-index ai 0))
 	       (vector-ref av (array:actor-index ai 1))
 	       (vector-ref av (array:actor-index ai 2))
 	       (vector-ref av (array:actor-index ai 3))
 	       (vector-ref av (array:actor-index ai 4))
 	       (vector-ref av (array:actor-index ai 5))
 	       (vector-ref av (array:actor-index ai 6))
 	       (vector-ref av (array:actor-index ai 7))
 	       (vector-ref av (array:actor-index ai 8))))))
           (it
            (lambda (r)
              (lambda (p ai av)
                (apply
                 p
                 (vector-ref av (array:actor-index ai 0))
                 (vector-ref av (array:actor-index ai 1))
                 (vector-ref av (array:actor-index ai 2))
                 (vector-ref av (array:actor-index ai 3))
                 (vector-ref av (array:actor-index ai 4))
                 (vector-ref av (array:actor-index ai 5))
                 (vector-ref av (array:actor-index ai 6))
                 (vector-ref av (array:actor-index ai 7))
                 (vector-ref av (array:actor-index ai 8))
                 (vector-ref av (array:actor-index ai 9))
                 (do ((k r (- k 1))
                      (r
                       '()
                       (cons
                        (vector-ref
 			av
 			(array:actor-index ai (- k 1)))
                        r)))
                     ((= k 10) r)))))))
       (lambda (r)
         "These are low level, exposing implementation at call site."
         (if (< r 10) (vector-ref em r) (it r)))))
   (define (array:index/vector r x v)
     ((array:indexer/vector r) x v))
   (define (array:index/array r x av ai)
     ((array:indexer/array r) x av ai))
   (define (array:apply-to-actor r p a)
     ((array:applier-to-actor r) p a))
   (define (array:apply-to-vector r p v)
     ((array:applier-to-vector r) p v))
   (define (array:optimize f r)
     (case r
       ((0) (let ((n0 (f))) (array:0 n0)))
       ((1) (let ((n0 (f 0))) (array:1 n0 (- (f 1) n0))))
       ((2)
        (let ((n0 (f 0 0)))
 	 (array:2 n0 (- (f 1 0) n0) (- (f 0 1) n0))))
       ((3)
        (let ((n0 (f 0 0 0)))
          (array:3
            n0
            (- (f 1 0 0) n0)
            (- (f 0 1 0) n0)
            (- (f 0 0 1) n0))))
       (else
        (let ((v
 	      (do ((k 0 (+ k 1)) (v '() (cons 0 v)))
 		  ((= k r) v))))
 	 (let ((n0 (apply f v)))
 	   (apply
 	    array:n
 	    n0
 	    (array:coefficients f n0 v v)))))))
   (define (array:optimize-empty r)
     (let ((x (make-vector (+ r 1) 0)))
       (vector-set! x r -1)
       x)))
 
 
 (define (array-ref a . xs)
   (or (##core#check (array:array? a))
       (##sys#signal-hook #:type-error 'array-ref "not an array" a))
   (let ((shape (array:shape a)))
     (##core#check
      (if (null? xs)
 	 (array:check-indices "array-ref" xs shape)
 	 (let ((x (car xs)))
 	   (if (vector? x)
               (array:check-index-vector "array-ref" x shape)
               (if (integer? x)
                   (array:check-indices "array-ref" xs shape)
                   (if (array:array? x)
                       (array:check-index-actor "array-ref" x shape)
                       (##sys#signal-hook #:type-error 'array-ref "not an index object" x)))))))
     (vector-ref
      (array:vector a)
      (if (null? xs)
          (vector-ref (array:index a) 0)
          (let ((x (car xs)))
            (if (vector? x)
                (array:index/vector
                 (quotient (vector-length shape) 2)
                 (array:index a)
                 x)
                (if (integer? x)
                    (array:vector-index (array:index a) xs)
                    (if (##core#check (array:array? x))
                        (array:index/array
                         (quotient (vector-length shape) 2)
                         (array:index a)
                         (array:vector x)
                         (array:index x))
                        (##sys#signal-hook #:type-error 'array-ref "bad index object" x)))))))))
 
 (define (array-set! a x . xs)
   (or (##core#check (array:array? a))
       (##sys#signal-hook #:type-error 'array-set! "not an array" a))
   (let ((shape (array:shape a)))
     (##core#check
      (if (null? xs)
 	 (array:check-indices "array-set!" '() shape)
 	 (if (vector? x)
             (array:check-index-vector "array-set!" x shape)
             (if (integer? x)
                 (array:check-indices.o "array-set!" (cons x xs) shape)
                 (if (array:array? x)
                     (array:check-index-actor "array-set!" x shape)
                     (##sys#signal-hook #:type-error 'array-set! "not an index object" x))))))
     (if (null? xs)
         (vector-set! (array:vector a) (vector-ref (array:index a) 0) x)
         (if (vector? x)
             (vector-set! (array:vector a)
                          (array:index/vector
                           (quotient (vector-length shape) 2)
                           (array:index a)
                           x)
                          (car xs))
             (if (integer? x)
                 (let ((v (array:vector a))
                       (i (array:index a))
                       (r (quotient (vector-length shape) 2)))
                   (do ((sum (* (vector-ref i 0) x)
                             (+ sum (* (vector-ref i k) (car ks))))
                        (ks xs (cdr ks))
                        (k 1 (+ k 1)))
                     ((= k r)
                      (vector-set! v (+ sum (vector-ref i k)) (car ks)))))
                 (if (##core#check (array:array? x))
                     (vector-set! (array:vector a)
                                  (array:index/array
                                   (quotient (vector-length shape) 2)
                                   (array:index a)
                                   (array:vector x)
                                   (array:index x))
                                  (car xs))
                     (##sys#signal-hook
 		     #:type-error 'array-set!
 		     "bad index object: "
 		     x)))))))
 
 (define (array:make-locative a x weak?)
   (or (##core#check (array:array? a))
       (##sys#signal-hook #:type-error 'array:make-locative "not an array"))
   (let ((shape (array:shape a)))
     (##core#check
      (if (vector? x)
 	 (array:check-index-vector "array:make-locative" x shape)
 	 (if (integer? x)
 	     (array:check-indices.o "array:make-locative" (list x) shape)
 	     (if (array:array? x)
 		 (array:check-index-actor "array:make-locative" x shape)
 		 (##sys#signal-hook #:type-error 'array:make-locative "not an index object" x)))))
     (if (vector? x)
 	(##core#inline_allocate
 	 ("C_a_i_make_locative" 5)
 	 0
 	 (array:vector a)
 	 (array:index/vector
 	  (quotient (vector-length shape) 2)
 	  (array:index a)
 	  x) 
 	 weak?)
 	(if (##core#check (array:array? x))
 	    (##core#inline_allocate
 	     ("C_a_i_make_locative" 5)
 	     0
 	     (array:vector a)
 	     (array:index/array
 	      (quotient (vector-length shape) 2)
 	      (array:index a)
 	      (array:vector x)
 	      (array:index x)) 
 	     weak?)
 	    (##sys#signal-hook #:type-error 'array:make-locative "bad index object: " x)))))