scheme-srfi/srfi/25.op-ctor.upstream.scm

;;; Copyright (C) Jussi Piitulainen (2001). All Rights Reserved.

;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to
;;; deal in the Software without restriction, including without limitation the
;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
;;; sell copies of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:

;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.

(begin
  (define array:opt-args '(ctor (4)))
  (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: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-vector r p v)
    ((array:applier-to-vector r) p v))
  (define (array:apply-to-actor r p a)
    ((array:applier-to-actor r) p a)))