source: project/release/4/srfi-25/srfi-25.scm @ 15208

Last change on this file since 15208 was 15208, checked in by felix winkelmann, 11 years ago

ported srfi-25 to r4

File size: 41.4 KB
Line 
1;;;; srfi-25.scm - Jussi Piitulainen's array library
2
3
4(declare
5  (usual-integrations)
6  (fixnum))
7
8
9(module srfi-25 (array?
10                 make-array
11                 shape 
12                 array
13                 array-rank
14                 array-start
15                 array-end
16                 array-ref
17                 array-set!
18                 array-set!
19                 share-array
20                 array:make-locative)
21  (import scheme chicken)
22
23(define-inline (array:make vec ind shp) (##sys#make-structure 'array vec ind shp))
24(define-inline (array:array? x) (##sys#structure? x 'array))
25(define-inline (array:vector a) (##sys#slot a 1))
26(define-inline (array:index a) (##sys#slot a 2))
27(define-inline (array:shape a) (##sys#slot a 3))
28
29
30;;; array
31;;; 1997 - 2001 Jussi Piitulainen
32
33
34;;; --- Intro ---
35
36;;; This interface to arrays is based on Alan Bawden's array.scm of
37;;; 1993 (earlier version in the Internet Repository and another
38;;; version in SLIB). This is a complete rewrite, to be consistent
39;;; with the rest of Scheme and to make arrays independent of lists.
40
41;;; Some modifications are due to discussion in srfi-25 mailing list.
42
43;;; (array? obj)
44;;; (make-array shape [obj])             changed arguments
45;;; (shape bound ...)                    new
46;;; (array shape obj ...)                new
47;;; (array-rank array)                   changed name back
48;;; (array-start array dimension)        new
49;;; (array-end array dimension)          new
50;;; (array-ref array k ...)
51;;; (array-ref array index)              new variant
52;;; (array-set! array k ... obj)         changed argument order
53;;; (array-set! array index obj)         new variant
54;;; (share-array array shape proc)       changed arguments
55
56;;; All other variables in this file have names in "array:".
57
58;;; Should there be a way to make arrays with initial values mapped
59;;; from indices? Sure. The current "initial object" is lame.
60;;;
61;;; Removed (array-shape array) from here. There is a new version
62;;; in arlib though.
63
64;;; --- Representation type dependencies ---
65
66;;; The mapping from array indices to the index to the underlying vector
67;;; is whatever array:optimize returns. The file "opt" provides three
68;;; representations:
69;;;
70;;; mbda) mapping is a procedure that allows an optional argument
71;;; tter) mapping is two procedures that takes exactly the indices
72;;; ctor) mapping is a vector of a constant term and coefficients
73;;;
74;;; Choose one in "opt" to make the optimizer. Then choose the matching
75;;; implementation of array-ref and array-set!.
76;;;
77;;; These should be made macros to inline them. Or have a good compiler
78;;; and plant the package as a module.
79
80;;; 1. Pick an optimizer.
81;;; 2. Pick matching index representation.
82;;; 3. Pick a record implementation; as-procedure is generic; syntax inlines.
83;;; 3. This file is otherwise portable.
84
85;;; --- Portable R5RS (R4RS and multiple values) ---
86
87;;; (array? obj)
88;;; returns #t if `obj' is an array and #t or #f otherwise.
89
90(define (array? obj)
91   (array:array? obj))
92
93(define-syntax check-array
94  (syntax-rules ()
95    ((_ x loc)
96     (let ((var x))
97       (or (##core#check (array:array? var))
98           (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not an array") var) ) ) ) ) )
99
100;;; (make-array shape)
101;;; (make-array shape obj)
102;;; makes array of `shape' with each cell containing `obj' initially.
103
104(define (make-array shape . rest)
105  (or (##core#check (array:good-shape? shape))
106      (##sys#signal-hook #:type-error 'make-array "bad argument type - not a valid shape" shape))
107  (apply array:make-array shape rest))
108
109(define (array:make-array shape . rest)
110  (let ((size (array:size shape)))
111    (array:make
112     (if (pair? rest)
113         (apply (lambda (o) (make-vector size o)) rest)
114         (make-vector size))
115     (if (= size 0)
116         (array:optimize-empty
117          (vector-ref (array:shape shape) 1))
118         (array:optimize
119          (array:make-index shape)
120          (vector-ref (array:shape shape) 1)))
121     (array:shape->vector shape))))
122
123;;; (shape bound ...)
124;;; makes a shape. Bounds must be an even number of exact, pairwise
125;;; non-decreasing integers. Note that any such array can be a shape.
126
127(define (shape . bounds)
128  (let ((v (list->vector bounds)))
129    (or (##core#check (even? (vector-length v)))
130        (##sys#error 'shape "uneven number of bounds" bounds) )
131    (let ((shp (array:make
132                v
133                (if (pair? bounds)
134                    (array:shape-index)
135                    (array:empty-shape-index))
136                (vector 0 (quotient (vector-length v) 2)
137                        0 2))))
138      (or (##core#check (array:good-shape? shp))
139          (##sys#signal-hook #:type-error 'shape "bounds are not pairwise non-decreasing exact integers" bounds) )
140      shp)))
141
142;;; (array shape obj ...)
143;;; is analogous to `vector'.
144
145(define (array shape . elts)
146  (or (##core#check (array:good-shape? shape))
147      (##sys#signal-hook #:type-error 'array "bad argument type - not a valid shape" shape) )
148  (let ((size (array:size shape)))
149    (let ((vector (list->vector elts)))
150      (or (##core#check (= (vector-length vector) size))
151          (##sys#error 'array "bad number of elements" shape elts) )
152      (array:make
153       vector
154       (if (= size 0)
155           (array:optimize-empty
156            (vector-ref (array:shape shape) 1))
157           (array:optimize
158            (array:make-index shape)
159            (vector-ref (array:shape shape) 1)))
160       (array:shape->vector shape)))))
161
162;;; (array-rank array)
163;;; returns the number of dimensions of `array'.
164
165(define (array-rank array)
166  (check-array array 'array-rank)
167  (quotient (vector-length (array:shape array)) 2))
168
169;;; (array-start array k)
170;;; returns the lower bound index of array along dimension k. This is
171;;; the least valid index along that dimension if the dimension is not
172;;; empty.
173
174(define (array-start array d)
175  (check-array array 'array-start)
176  (vector-ref (array:shape array) (+ d d)))
177
178;;; (array-end array k)
179;;; returns the upper bound index of array along dimension k. This is
180;;; not a valid index. If the dimension is empty, this is the same as
181;;; the lower bound along it.
182
183(define (array-end array d)
184  (check-array array 'array-end)
185  (vector-ref (array:shape array) (+ d d 1)))
186
187;;; (share-array array shape proc)
188;;; makes an array that shares elements of `array' at shape `shape'.
189;;; The arguments to `proc' are indices of the result.  The values of
190;;; `proc' are indices of `array'.
191
192;;; Todo: in the error message, should recognise the mapping and show it.
193
194(define (share-array array subshape f)
195  (check-array array 'share-array)
196  (or (##core#check (array:good-shape? subshape))
197      (##sys#signal-hook #:type-error 'share-array "not a shape" subshape) )
198  (let ((subsize (array:size subshape)))
199    (or (##core#check (array:good-share? subshape subsize f (array:shape array)))
200        (##sys#error 'share-array "subshape does not map into supershape" subshape shape) )
201    (let ((g (array:index array)))
202      (array:make
203       (array:vector array)
204       (if (= subsize 0)
205           (array:optimize-empty
206            (vector-ref (array:shape subshape) 1))
207           (array:optimize
208            (lambda ks
209              (call-with-values
210               (lambda () (apply f ks))
211               (lambda ks (array:vector-index g ks))))
212            (vector-ref (array:shape subshape) 1)))
213       (array:shape->vector subshape)))))
214
215;;; --- Hrmph ---
216
217;;; (array:share/index! ...)
218;;; reuses a user supplied index object when recognising the
219;;; mapping. The mind balks at the very nasty side effect that
220;;; exposes the implementation. So this is not in the spec.
221;;; But letting index objects in at all creates a pressure
222;;; to go the whole hog. Arf.
223
224;;; Use array:optimize-empty for an empty array to get a
225;;; clearly invalid vector index.
226
227;;; Surely it's perverse to use an actor for index here? But
228;;; the possibility is provided for completeness.
229
230(define (array:share/index! array subshape proc index)
231  (array:make
232   (array:vector array)
233   (if (= (array:size subshape) 0)
234       (array:optimize-empty
235        (quotient (vector-length (array:shape array)) 2))
236       ((if (vector? index)
237            array:optimize/vector
238            array:optimize/actor)
239        (lambda (subindex)
240          (let ((superindex (proc subindex)))
241            (if (vector? superindex)
242                (array:index/vector
243                 (quotient (vector-length (array:shape array)) 2)
244                 (array:index array)
245                 superindex)
246                (array:index/array
247                 (quotient (vector-length (array:shape array)) 2)
248                 (array:index array)
249                 (array:vector superindex)
250                 (array:index superindex)))))
251        index))
252   (array:shape->vector subshape)))
253
254(define (array:optimize/vector f v)
255  (let ((r (vector-length v)))
256    (do ((k 0 (+ k 1)))
257      ((= k r))
258      (vector-set! v k 0))
259    (let ((n0 (f v))
260          (cs (make-vector (+ r 1)))
261          (apply (array:applier-to-vector (+ r 1))))
262      (vector-set! cs 0 n0)
263      (let wok ((k 0))
264        (if (< k r)
265            (let ((k1 (+ k 1)))
266              (vector-set! v k 1)
267              (let ((nk (- (f v) n0)))
268                (vector-set! v k 0)
269                (vector-set! cs k1 nk)
270                (wok k1)))))
271      (apply (array:maker r) cs))))
272
273(define (array:optimize/actor f a)
274  (let ((r (array-end a 0))
275        (v (array:vector a))
276        (i (array:index a)))
277    (do ((k 0 (+ k 1)))
278      ((= k r))
279      (vector-set! v (array:actor-index i k) 0))
280    (let ((n0 (f a))
281          (cs (make-vector (+ r 1)))
282          (apply (array:applier-to-vector (+ r 1))))
283      (vector-set! cs 0 n0)
284      (let wok ((k 0))
285        (if (< k r)
286            (let ((k1 (+ k 1))
287                  (t (array:actor-index i k)))
288              (vector-set! v t 1)
289              (let ((nk (- (f a) n0)))
290                (vector-set! v t 0)
291                (vector-set! cs k1 nk)
292                (wok k1)))))
293      (apply (array:maker r) cs))))
294
295;;; --- Internals ---
296
297(define (array:shape->vector shape)
298  (let ((idx (array:index shape))
299        (shv (array:vector shape))
300        (rnk (vector-ref (array:shape shape) 1)))
301    (let ((vec (make-vector (* rnk 2))))
302      (do ((k 0 (+ k 1)))
303        ((= k rnk)
304         vec)
305        (vector-set! vec (+ k k)
306                     (vector-ref shv (array:shape-vector-index idx k 0)))
307        (vector-set! vec (+ k k 1)
308                     (vector-ref shv (array:shape-vector-index idx k 1)))))))
309
310;;; (array:size shape)
311;;; returns the number of elements in arrays of shape `shape'.
312
313(define (array:size shape)
314   (let ((idx (array:index shape))
315         (shv (array:vector shape))
316         (rnk (vector-ref (array:shape shape) 1)))
317     (do   ((k 0 (+ k 1))
318            (s 1 (* s
319                    (- (vector-ref shv (array:shape-vector-index idx k 1))
320                       (vector-ref shv (array:shape-vector-index idx k 0))))))
321       ((= k rnk) s))))
322
323;;; (array:make-index shape)
324;;; returns an index function for arrays of shape `shape'. This is a
325;;; runtime composition of several variable arity procedures, to be
326;;; passed to array:optimize for recognition as an affine function of
327;;; as many variables as there are dimensions in arrays of this shape.
328
329(define (array:make-index shape)
330   (let ((idx (array:index shape))
331         (shv (array:vector shape))
332         (rnk (vector-ref (array:shape shape) 1)))
333     (do ((f (lambda () 0)
334             (lambda (k . ks)
335               (+ (* s (- k (vector-ref
336                             shv
337                             (array:shape-vector-index idx (- j 1) 0))))
338                  (apply f ks))))
339          (s 1 (* s (- (vector-ref
340                        shv
341                        (array:shape-vector-index idx (- j 1) 1))
342                       (vector-ref
343                        shv
344                        (array:shape-vector-index idx (- j 1) 0)))))
345          (j rnk (- j 1)))
346       ((= j 0)
347        f))))
348
349
350;;; --- Error checking ---
351
352;;; (array:good-shape? shape)
353;;; returns true if `shape' is an array of the right shape and its
354;;; elements are exact integers that pairwise bound intervals `[lo..hi)Ž.
355
356(define (array:good-shape? shape)
357  (and (array:array? shape)
358       (let ((u (array:shape shape))
359             (v (array:vector shape))
360             (x (array:index shape)))
361         (and (= (vector-length u) 4)
362              (= (vector-ref u 0) 0)
363              (= (vector-ref u 2) 0)
364              (= (vector-ref u 3) 2))
365         (let ((p (vector-ref u 1)))
366           (do ((k 0 (+ k 1))
367                (true #t (let ((lo (vector-ref
368                                    v
369                                    (array:shape-vector-index x k 0)))
370                               (hi (vector-ref
371                                    v
372                                    (array:shape-vector-index x k 1))))
373                           (and true
374                                (integer? lo)
375                                (exact? lo)
376                                (integer? hi)
377                                (exact? hi)
378                                (<= lo hi)))))
379             ((= k p) true))))))
380
381;;; (array:good-share? subv subsize mapping superv)
382;;; returns true if the extreme indices in the subshape vector map
383;;; into the bounds in the supershape vector.
384
385;;; If some interval in `subv' is empty, then `subv' is empty and its
386;;; image under `f' is empty and it is trivially alright.  One must
387;;; not call `f', though.
388
389(define (array:good-share? subshape subsize f super)
390  (or (zero? subsize)
391      (letrec
392          ((sub (array:vector subshape))
393           (dex (array:index subshape))
394           (ck (lambda (k ks)
395                 (if (zero? k)
396                     (call-with-values
397                      (lambda () (apply f ks))
398                      (lambda qs (array:good-indices? qs super)))
399                     (and (ck (- k 1)
400                              (cons (vector-ref
401                                     sub
402                                     (array:shape-vector-index
403                                      dex
404                                      (- k 1)
405                                      0))
406                                    ks))
407                          (ck (- k 1)
408                              (cons (- (vector-ref
409                                        sub
410                                        (array:shape-vector-index
411                                         dex
412                                         (- k 1)
413                                         1))
414                                       1)
415                                    ks)))))))
416        (let ((rnk (vector-ref (array:shape subshape) 1)))
417          (or (array:unchecked-share-depth? rnk)
418              (ck rnk '()))))))
419
420;;; Check good-share on 10 dimensions at most. The trouble is,
421;;; the cost of this check is exponential in the number of dimensions.
422
423(define (array:unchecked-share-depth? rank)
424  (if (> rank 10)
425      (begin
426        (display `(warning: unchecked depth in share:
427                            ,rank subdimensions))
428        (newline)
429        #t)
430      #f))
431
432;;; (array:check-indices caller indices shape-vector)
433;;; (array:check-indices.o caller indices shape-vector)
434;;; (array:check-index-vector caller index-vector shape-vector)
435;;; return if the index is in bounds, else signal error.
436;;;
437;;; Shape-vector is the internal representation, with
438;;; b and e for dimension k at 2k and 2k + 1.
439
440(define (array:check-indices who ks shv)
441  (or (array:good-indices? ks shv)
442      (##sys#signal-hook #:bounds-error (array:not-in who ks shv))))
443
444(define (array:check-indices.o who ks shv)
445  (or (array:good-indices.o? ks shv)
446      (##sys#signal-hook #:bounds-error (array:not-in who (reverse (cdr (reverse ks))) shv))))
447
448(define (array:check-index-vector who ks shv)
449  (or (array:good-index-vector? ks shv)
450      (##sys#signal-hook #:bounds-error (array:not-in who (vector->list ks) shv))))
451
452(define (array:check-index-actor who ks shv)
453  (let ((shape (array:shape ks)))
454    (or (and (= (vector-length shape) 2)
455             (= (vector-ref shape 0) 0))
456        (##sys#signal-hook #:type-error "not an actor"))
457    (or (array:good-index-actor?
458         (vector-ref shape 1)
459         (array:vector ks)
460         (array:index ks)
461         shv)
462        (array:not-in who (do ((k (vector-ref shape 1) (- k 1))
463                               (m '() (cons (vector-ref
464                                             (array:vector ks)
465                                             (array:actor-index
466                                              (array:index ks)
467                                              (- k 1)))
468                                            m)))
469                            ((= k 0) m))
470                      shv))))
471
472(define (array:good-indices? ks shv)
473   (let ((d2 (vector-length shv)))
474      (do ((kp ks (if (pair? kp)
475                      (cdr kp)))
476           (k 0 (+ k 2))
477           (true #t (and true (pair? kp)
478                         (array:good-index? (car kp) shv k))))
479        ((= k d2)
480         (and true (null? kp))))))
481
482(define (array:good-indices.o? ks.o shv)
483   (let ((d2 (vector-length shv)))
484     (do   ((kp ks.o (if (pair? kp)
485                         (cdr kp)))
486            (k 0 (+ k 2))
487            (true #t (and true (pair? kp)
488                          (array:good-index? (car kp) shv k))))
489       ((= k d2)
490        (and true (pair? kp) (null? (cdr kp)))))))
491
492(define (array:good-index-vector? ks shv)
493  (let ((r2 (vector-length shv)))
494    (and (= (* 2 (vector-length ks)) r2)
495         (do ((j 0 (+ j 1))
496              (k 0 (+ k 2))
497              (true #t (and true
498                            (array:good-index? (vector-ref ks j) shv k))))
499           ((= k r2) true)))))
500
501(define (array:good-index-actor? r v i shv)
502  (and (= (* 2 r) (vector-length shv))
503       (do ((j 0 (+ j 1))
504            (k 0 (+ k 2))
505            (true #t (and true
506                          (array:good-index? (vector-ref
507                                              v
508                                              (array:actor-index i j))
509                                             shv
510                                             k))))
511         ((= j r) true))))
512
513;;; (array:good-index? index shape-vector 2d)
514;;; returns true if index is within bounds for dimension 2d/2.
515
516(define (array:good-index? w shv k)
517  (and (integer? w)
518       (exact? w)
519       (<= (vector-ref shv k) w)
520       (< w (vector-ref shv (+ k 1)))))
521
522(define (array:not-in who ks shv)
523  (##sys#signal-hook #:bounds-error (string-append who ": index not in bounds") ks shv) )
524
525
526(begin
527  (define (array:coefficients f n0 vs vp)
528    (case vp
529      ((()) '())
530      (else
531       (set-car! vp 1)
532       (let ((n (- (apply f vs) n0)))
533         (set-car! vp 0)
534         (cons n (array:coefficients f n0 vs (cdr vp)))))))
535  (define (array:vector-index x ks)
536    (do ((sum 0 (+ sum (* (vector-ref x k) (car ks))))
537         (ks ks (cdr ks))
538         (k 0 (+ k 1)))
539        ((null? ks) (+ sum (vector-ref x k)))))
540  (define (array:shape-index) '#(2 1 0))
541  (define (array:empty-shape-index) '#(0 0 -1))
542  (define (array:shape-vector-index x r k)
543    (+
544     (* (vector-ref x 0) r)
545     (* (vector-ref x 1) k)
546     (vector-ref x 2)))
547  (define (array:actor-index x k)
548    (+ (* (vector-ref x 0) k) (vector-ref x 1)))
549  (define (array:0 n0) (vector n0))
550  (define (array:1 n0 n1) (vector n1 n0))
551  (define (array:2 n0 n1 n2) (vector n1 n2 n0))
552  (define (array:3 n0 n1 n2 n3) (vector n1 n2 n3 n0))
553  (define (array:n n0 n1 n2 n3 n4 . ns)
554    (apply vector n1 n2 n3 n4 (append ns (list n0))))
555  (define (array:maker r)
556    (case r
557      ((0) array:0)
558      ((1) array:1)
559      ((2) array:2)
560      ((3) array:3)
561      (else array:n)))
562  (define array:indexer/vector
563    (let ((em
564           (vector
565            (lambda (x i) (+ (vector-ref x 0)))
566            (lambda (x i)
567              (+
568               (* (vector-ref x 0) (vector-ref i 0))
569               (vector-ref x 1)))
570            (lambda (x i)
571              (+
572               (* (vector-ref x 0) (vector-ref i 0))
573               (* (vector-ref x 1) (vector-ref i 1))
574               (vector-ref x 2)))
575            (lambda (x i)
576              (+
577               (* (vector-ref x 0) (vector-ref i 0))
578               (* (vector-ref x 1) (vector-ref i 1))
579               (* (vector-ref x 2) (vector-ref i 2))
580               (vector-ref x 3)))
581            (lambda (x i)
582              (+
583               (* (vector-ref x 0) (vector-ref i 0))
584               (* (vector-ref x 1) (vector-ref i 1))
585               (* (vector-ref x 2) (vector-ref i 2))
586               (* (vector-ref x 3) (vector-ref i 3))
587               (vector-ref x 4)))
588            (lambda (x i)
589              (+
590               (* (vector-ref x 0) (vector-ref i 0))
591               (* (vector-ref x 1) (vector-ref i 1))
592               (* (vector-ref x 2) (vector-ref i 2))
593               (* (vector-ref x 3) (vector-ref i 3))
594               (* (vector-ref x 4) (vector-ref i 4))
595               (vector-ref x 5)))
596            (lambda (x i)
597              (+
598               (* (vector-ref x 0) (vector-ref i 0))
599               (* (vector-ref x 1) (vector-ref i 1))
600               (* (vector-ref x 2) (vector-ref i 2))
601               (* (vector-ref x 3) (vector-ref i 3))
602               (* (vector-ref x 4) (vector-ref i 4))
603               (* (vector-ref x 5) (vector-ref i 5))
604               (vector-ref x 6)))
605            (lambda (x i)
606              (+
607               (* (vector-ref x 0) (vector-ref i 0))
608               (* (vector-ref x 1) (vector-ref i 1))
609               (* (vector-ref x 2) (vector-ref i 2))
610               (* (vector-ref x 3) (vector-ref i 3))
611               (* (vector-ref x 4) (vector-ref i 4))
612               (* (vector-ref x 5) (vector-ref i 5))
613               (* (vector-ref x 6) (vector-ref i 6))
614               (vector-ref x 7)))
615            (lambda (x i)
616              (+
617               (* (vector-ref x 0) (vector-ref i 0))
618               (* (vector-ref x 1) (vector-ref i 1))
619               (* (vector-ref x 2) (vector-ref i 2))
620               (* (vector-ref x 3) (vector-ref i 3))
621               (* (vector-ref x 4) (vector-ref i 4))
622               (* (vector-ref x 5) (vector-ref i 5))
623               (* (vector-ref x 6) (vector-ref i 6))
624               (* (vector-ref x 7) (vector-ref i 7))
625               (vector-ref x 8)))
626            (lambda (x i)
627              (+
628               (* (vector-ref x 0) (vector-ref i 0))
629               (* (vector-ref x 1) (vector-ref i 1))
630               (* (vector-ref x 2) (vector-ref i 2))
631               (* (vector-ref x 3) (vector-ref i 3))
632               (* (vector-ref x 4) (vector-ref i 4))
633               (* (vector-ref x 5) (vector-ref i 5))
634               (* (vector-ref x 6) (vector-ref i 6))
635               (* (vector-ref x 7) (vector-ref i 7))
636               (* (vector-ref x 8) (vector-ref i 8))
637               (vector-ref x 9)))))
638          (it
639           (lambda (w)
640             (lambda (x i)
641               (+
642                (* (vector-ref x 0) (vector-ref i 0))
643                (* (vector-ref x 1) (vector-ref i 1))
644                (* (vector-ref x 2) (vector-ref i 2))
645                (* (vector-ref x 3) (vector-ref i 3))
646                (* (vector-ref x 4) (vector-ref i 4))
647                (* (vector-ref x 5) (vector-ref i 5))
648                (* (vector-ref x 6) (vector-ref i 6))
649                (* (vector-ref x 7) (vector-ref i 7))
650                (* (vector-ref x 8) (vector-ref i 8))
651                (* (vector-ref x 9) (vector-ref i 9))
652                (do ((xi
653                      0
654                      (+
655                       (* (vector-ref x u) (vector-ref i u))
656                       xi))
657                     (u (- w 1) (- u 1)))
658                    ((< u 10) xi))
659                (vector-ref x w))))))
660      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
661  (define array:indexer/array
662    (let ((em
663           (vector
664            (lambda (x v i) (+ (vector-ref x 0)))
665            (lambda (x v i)
666              (+
667               (*
668                (vector-ref x 0)
669                (vector-ref v (array:actor-index i 0)))
670               (vector-ref x 1)))
671            (lambda (x v i)
672              (+
673               (*
674                (vector-ref x 0)
675                (vector-ref v (array:actor-index i 0)))
676               (*
677                (vector-ref x 1)
678                (vector-ref v (array:actor-index i 1)))
679               (vector-ref x 2)))
680            (lambda (x v i)
681              (+
682               (*
683                (vector-ref x 0)
684                (vector-ref v (array:actor-index i 0)))
685               (*
686                (vector-ref x 1)
687                (vector-ref v (array:actor-index i 1)))
688               (*
689                (vector-ref x 2)
690                (vector-ref v (array:actor-index i 2)))
691               (vector-ref x 3)))
692            (lambda (x v i)
693              (+
694               (*
695                (vector-ref x 0)
696                (vector-ref v (array:actor-index i 0)))
697               (*
698                (vector-ref x 1)
699                (vector-ref v (array:actor-index i 1)))
700               (*
701                (vector-ref x 2)
702                (vector-ref v (array:actor-index i 2)))
703               (*
704                (vector-ref x 3)
705                (vector-ref v (array:actor-index i 3)))
706               (vector-ref x 4)))
707            (lambda (x v i)
708              (+
709               (*
710                (vector-ref x 0)
711                (vector-ref v (array:actor-index i 0)))
712               (*
713                (vector-ref x 1)
714                (vector-ref v (array:actor-index i 1)))
715               (*
716                (vector-ref x 2)
717                (vector-ref v (array:actor-index i 2)))
718               (*
719                (vector-ref x 3)
720                (vector-ref v (array:actor-index i 3)))
721               (*
722                (vector-ref x 4)
723                (vector-ref v (array:actor-index i 4)))
724               (vector-ref x 5)))
725            (lambda (x v i)
726              (+
727               (*
728                (vector-ref x 0)
729                (vector-ref v (array:actor-index i 0)))
730               (*
731                (vector-ref x 1)
732                (vector-ref v (array:actor-index i 1)))
733               (*
734                (vector-ref x 2)
735                (vector-ref v (array:actor-index i 2)))
736               (*
737                (vector-ref x 3)
738                (vector-ref v (array:actor-index i 3)))
739               (*
740                (vector-ref x 4)
741                (vector-ref v (array:actor-index i 4)))
742               (*
743                (vector-ref x 5)
744                (vector-ref v (array:actor-index i 5)))
745               (vector-ref x 6)))
746            (lambda (x v i)
747              (+
748               (*
749                (vector-ref x 0)
750                (vector-ref v (array:actor-index i 0)))
751               (*
752                (vector-ref x 1)
753                (vector-ref v (array:actor-index i 1)))
754               (*
755                (vector-ref x 2)
756                (vector-ref v (array:actor-index i 2)))
757               (*
758                (vector-ref x 3)
759                (vector-ref v (array:actor-index i 3)))
760               (*
761                (vector-ref x 4)
762                (vector-ref v (array:actor-index i 4)))
763               (*
764                (vector-ref x 5)
765                (vector-ref v (array:actor-index i 5)))
766               (*
767                (vector-ref x 6)
768                (vector-ref v (array:actor-index i 6)))
769               (vector-ref x 7)))
770            (lambda (x v i)
771              (+
772               (*
773                (vector-ref x 0)
774                (vector-ref v (array:actor-index i 0)))
775               (*
776                (vector-ref x 1)
777                (vector-ref v (array:actor-index i 1)))
778               (*
779                (vector-ref x 2)
780                (vector-ref v (array:actor-index i 2)))
781               (*
782                (vector-ref x 3)
783                (vector-ref v (array:actor-index i 3)))
784               (*
785                (vector-ref x 4)
786                (vector-ref v (array:actor-index i 4)))
787               (*
788                (vector-ref x 5)
789                (vector-ref v (array:actor-index i 5)))
790               (*
791                (vector-ref x 6)
792                (vector-ref v (array:actor-index i 6)))
793               (*
794                (vector-ref x 7)
795                (vector-ref v (array:actor-index i 7)))
796               (vector-ref x 8)))
797            (lambda (x v i)
798              (+
799               (*
800                (vector-ref x 0)
801                (vector-ref v (array:actor-index i 0)))
802               (*
803                (vector-ref x 1)
804                (vector-ref v (array:actor-index i 1)))
805               (*
806                (vector-ref x 2)
807                (vector-ref v (array:actor-index i 2)))
808               (*
809                (vector-ref x 3)
810                (vector-ref v (array:actor-index i 3)))
811               (*
812                (vector-ref x 4)
813                (vector-ref v (array:actor-index i 4)))
814               (*
815                (vector-ref x 5)
816                (vector-ref v (array:actor-index i 5)))
817               (*
818                (vector-ref x 6)
819                (vector-ref v (array:actor-index i 6)))
820               (*
821                (vector-ref x 7)
822                (vector-ref v (array:actor-index i 7)))
823               (*
824                (vector-ref x 8)
825                (vector-ref v (array:actor-index i 8)))
826               (vector-ref x 9)))))
827          (it
828           (lambda (w)
829             (lambda (x v i)
830               (+
831                (*
832                 (vector-ref x 0)
833                 (vector-ref v (array:actor-index i 0)))
834                (*
835                 (vector-ref x 1)
836                 (vector-ref v (array:actor-index i 1)))
837                (*
838                 (vector-ref x 2)
839                 (vector-ref v (array:actor-index i 2)))
840                (*
841                 (vector-ref x 3)
842                 (vector-ref v (array:actor-index i 3)))
843                (*
844                 (vector-ref x 4)
845                 (vector-ref v (array:actor-index i 4)))
846                (*
847                 (vector-ref x 5)
848                 (vector-ref v (array:actor-index i 5)))
849                (*
850                 (vector-ref x 6)
851                 (vector-ref v (array:actor-index i 6)))
852                (*
853                 (vector-ref x 7)
854                 (vector-ref v (array:actor-index i 7)))
855                (*
856                 (vector-ref x 8)
857                 (vector-ref v (array:actor-index i 8)))
858                (*
859                 (vector-ref x 9)
860                 (vector-ref v (array:actor-index i 9)))
861                (do ((xi
862                      0
863                      (+
864                       (*
865                        (vector-ref x u)
866                        (vector-ref
867                         v
868                         (array:actor-index i u)))
869                       xi))
870                     (u (- w 1) (- u 1)))
871                    ((< u 10) xi))
872                (vector-ref x w))))))
873      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
874  (define array:applier-to-vector
875    (let ((em
876           (vector
877            (lambda (p v) (p))
878            (lambda (p v) (p (vector-ref v 0)))
879            (lambda (p v)
880              (p (vector-ref v 0) (vector-ref v 1)))
881            (lambda (p v)
882              (p
883               (vector-ref v 0)
884               (vector-ref v 1)
885               (vector-ref v 2)))
886            (lambda (p v)
887              (p
888               (vector-ref v 0)
889               (vector-ref v 1)
890               (vector-ref v 2)
891               (vector-ref v 3)))
892            (lambda (p v)
893              (p
894               (vector-ref v 0)
895               (vector-ref v 1)
896               (vector-ref v 2)
897               (vector-ref v 3)
898               (vector-ref v 4)))
899            (lambda (p v)
900              (p
901               (vector-ref v 0)
902               (vector-ref v 1)
903               (vector-ref v 2)
904               (vector-ref v 3)
905               (vector-ref v 4)
906               (vector-ref v 5)))
907            (lambda (p v)
908              (p
909               (vector-ref v 0)
910               (vector-ref v 1)
911               (vector-ref v 2)
912               (vector-ref v 3)
913               (vector-ref v 4)
914               (vector-ref v 5)
915               (vector-ref v 6)))
916            (lambda (p v)
917              (p
918               (vector-ref v 0)
919               (vector-ref v 1)
920               (vector-ref v 2)
921               (vector-ref v 3)
922               (vector-ref v 4)
923               (vector-ref v 5)
924               (vector-ref v 6)
925               (vector-ref v 7)))
926            (lambda (p v)
927              (p
928               (vector-ref v 0)
929               (vector-ref v 1)
930               (vector-ref v 2)
931               (vector-ref v 3)
932               (vector-ref v 4)
933               (vector-ref v 5)
934               (vector-ref v 6)
935               (vector-ref v 7)
936               (vector-ref v 8)))))
937          (it
938           (lambda (r)
939             (lambda (p v)
940               (apply
941                p
942                (vector-ref v 0)
943                (vector-ref v 1)
944                (vector-ref v 2)
945                (vector-ref v 3)
946                (vector-ref v 4)
947                (vector-ref v 5)
948                (vector-ref v 6)
949                (vector-ref v 7)
950                (vector-ref v 8)
951                (vector-ref v 9)
952                (do ((k r (- k 1))
953                     (r
954                      '()
955                      (cons (vector-ref v (- k 1)) r)))
956                    ((= k 10) r)))))))
957      (lambda (r) (if (< r 10) (vector-ref em r) (it r)))))
958  (define array:applier-to-actor
959    (let ((em
960           (vector
961            (lambda (p a) (p))
962            (lambda (p a) (p (array-ref a 0)))
963            (lambda (p a)
964              (p (array-ref a 0) (array-ref a 1)))
965            (lambda (p a)
966              (p
967               (array-ref a 0)
968               (array-ref a 1)
969               (array-ref a 2)))
970            (lambda (p a)
971              (p
972               (array-ref a 0)
973               (array-ref a 1)
974               (array-ref a 2)
975               (array-ref a 3)))
976            (lambda (p a)
977              (p
978               (array-ref a 0)
979               (array-ref a 1)
980               (array-ref a 2)
981               (array-ref a 3)
982               (array-ref a 4)))
983            (lambda (p a)
984              (p
985               (array-ref a 0)
986               (array-ref a 1)
987               (array-ref a 2)
988               (array-ref a 3)
989               (array-ref a 4)
990               (array-ref a 5)))
991            (lambda (p a)
992              (p
993               (array-ref a 0)
994               (array-ref a 1)
995               (array-ref a 2)
996               (array-ref a 3)
997               (array-ref a 4)
998               (array-ref a 5)
999               (array-ref a 6)))
1000            (lambda (p a)
1001              (p
1002               (array-ref a 0)
1003               (array-ref a 1)
1004               (array-ref a 2)
1005               (array-ref a 3)
1006               (array-ref a 4)
1007               (array-ref a 5)
1008               (array-ref a 6)
1009               (array-ref a 7)))
1010            (lambda (p a)
1011              (p
1012               (array-ref a 0)
1013               (array-ref a 1)
1014               (array-ref a 2)
1015               (array-ref a 3)
1016               (array-ref a 4)
1017               (array-ref a 5)
1018               (array-ref a 6)
1019               (array-ref a 7)
1020               (array-ref a 8)))))
1021          (it
1022           (lambda (r)
1023             (lambda (p a)
1024               (apply
1025                a
1026                (array-ref a 0)
1027                (array-ref a 1)
1028                (array-ref a 2)
1029                (array-ref a 3)
1030                (array-ref a 4)
1031                (array-ref a 5)
1032                (array-ref a 6)
1033                (array-ref a 7)
1034                (array-ref a 8)
1035                (array-ref a 9)
1036                (do ((k r (- k 1))
1037                     (r '() (cons (array-ref a (- k 1)) r)))
1038                    ((= k 10) r)))))))
1039      (lambda (r)
1040        "These are high level, hiding implementation at call site."
1041        (if (< r 10) (vector-ref em r) (it r)))))
1042  (define array:applier-to-backing-vector
1043    (let ((em
1044           (vector
1045            (lambda (p ai av) (p))
1046            (lambda (p ai av)
1047              (p (vector-ref av (array:actor-index ai 0))))
1048            (lambda (p ai av)
1049              (p
1050               (vector-ref av (array:actor-index ai 0))
1051               (vector-ref av (array:actor-index ai 1))))
1052            (lambda (p ai av)
1053              (p
1054               (vector-ref av (array:actor-index ai 0))
1055               (vector-ref av (array:actor-index ai 1))
1056               (vector-ref av (array:actor-index ai 2))))
1057            (lambda (p ai av)
1058              (p
1059               (vector-ref av (array:actor-index ai 0))
1060               (vector-ref av (array:actor-index ai 1))
1061               (vector-ref av (array:actor-index ai 2))
1062               (vector-ref av (array:actor-index ai 3))))
1063            (lambda (p ai av)
1064              (p
1065               (vector-ref av (array:actor-index ai 0))
1066               (vector-ref av (array:actor-index ai 1))
1067               (vector-ref av (array:actor-index ai 2))
1068               (vector-ref av (array:actor-index ai 3))
1069               (vector-ref av (array:actor-index ai 4))))
1070            (lambda (p ai av)
1071              (p
1072               (vector-ref av (array:actor-index ai 0))
1073               (vector-ref av (array:actor-index ai 1))
1074               (vector-ref av (array:actor-index ai 2))
1075               (vector-ref av (array:actor-index ai 3))
1076               (vector-ref av (array:actor-index ai 4))
1077               (vector-ref av (array:actor-index ai 5))))
1078            (lambda (p ai av)
1079              (p
1080               (vector-ref av (array:actor-index ai 0))
1081               (vector-ref av (array:actor-index ai 1))
1082               (vector-ref av (array:actor-index ai 2))
1083               (vector-ref av (array:actor-index ai 3))
1084               (vector-ref av (array:actor-index ai 4))
1085               (vector-ref av (array:actor-index ai 5))
1086               (vector-ref av (array:actor-index ai 6))))
1087            (lambda (p ai av)
1088              (p
1089               (vector-ref av (array:actor-index ai 0))
1090               (vector-ref av (array:actor-index ai 1))
1091               (vector-ref av (array:actor-index ai 2))
1092               (vector-ref av (array:actor-index ai 3))
1093               (vector-ref av (array:actor-index ai 4))
1094               (vector-ref av (array:actor-index ai 5))
1095               (vector-ref av (array:actor-index ai 6))
1096               (vector-ref av (array:actor-index ai 7))))
1097            (lambda (p ai av)
1098              (p
1099               (vector-ref av (array:actor-index ai 0))
1100               (vector-ref av (array:actor-index ai 1))
1101               (vector-ref av (array:actor-index ai 2))
1102               (vector-ref av (array:actor-index ai 3))
1103               (vector-ref av (array:actor-index ai 4))
1104               (vector-ref av (array:actor-index ai 5))
1105               (vector-ref av (array:actor-index ai 6))
1106               (vector-ref av (array:actor-index ai 7))
1107               (vector-ref av (array:actor-index ai 8))))))
1108          (it
1109           (lambda (r)
1110             (lambda (p ai av)
1111               (apply
1112                p
1113                (vector-ref av (array:actor-index ai 0))
1114                (vector-ref av (array:actor-index ai 1))
1115                (vector-ref av (array:actor-index ai 2))
1116                (vector-ref av (array:actor-index ai 3))
1117                (vector-ref av (array:actor-index ai 4))
1118                (vector-ref av (array:actor-index ai 5))
1119                (vector-ref av (array:actor-index ai 6))
1120                (vector-ref av (array:actor-index ai 7))
1121                (vector-ref av (array:actor-index ai 8))
1122                (vector-ref av (array:actor-index ai 9))
1123                (do ((k r (- k 1))
1124                     (r
1125                      '()
1126                      (cons
1127                       (vector-ref
1128                        av
1129                        (array:actor-index ai (- k 1)))
1130                       r)))
1131                    ((= k 10) r)))))))
1132      (lambda (r)
1133        "These are low level, exposing implementation at call site."
1134        (if (< r 10) (vector-ref em r) (it r)))))
1135  (define (array:index/vector r x v)
1136    ((array:indexer/vector r) x v))
1137  (define (array:index/array r x av ai)
1138    ((array:indexer/array r) x av ai))
1139  (define (array:apply-to-actor r p a)
1140    ((array:applier-to-actor r) p a))
1141  (define (array:apply-to-vector r p v)
1142    ((array:applier-to-vector r) p v))
1143  (define (array:optimize f r)
1144    (case r
1145      ((0) (let ((n0 (f))) (array:0 n0)))
1146      ((1) (let ((n0 (f 0))) (array:1 n0 (- (f 1) n0))))
1147      ((2)
1148       (let ((n0 (f 0 0)))
1149         (array:2 n0 (- (f 1 0) n0) (- (f 0 1) n0))))
1150      ((3)
1151       (let ((n0 (f 0 0 0)))
1152         (array:3
1153           n0
1154           (- (f 1 0 0) n0)
1155           (- (f 0 1 0) n0)
1156           (- (f 0 0 1) n0))))
1157      (else
1158       (let ((v
1159              (do ((k 0 (+ k 1)) (v '() (cons 0 v)))
1160                  ((= k r) v))))
1161         (let ((n0 (apply f v)))
1162           (apply
1163            array:n
1164            n0
1165            (array:coefficients f n0 v v)))))))
1166  (define (array:optimize-empty r)
1167    (let ((x (make-vector (+ r 1) 0)))
1168      (vector-set! x r -1)
1169      x)))
1170
1171
1172(define (array-ref a . xs)
1173  (or (##core#check (array:array? a))
1174      (##sys#signal-hook #:type-error 'array-ref "not an array" a))
1175  (let ((shape (array:shape a)))
1176    (##core#check
1177     (if (null? xs)
1178         (array:check-indices "array-ref" xs shape)
1179         (let ((x (car xs)))
1180           (if (vector? x)
1181              (array:check-index-vector "array-ref" x shape)
1182              (if (integer? x)
1183                  (array:check-indices "array-ref" xs shape)
1184                  (if (array:array? x)
1185                      (array:check-index-actor "array-ref" x shape)
1186                      (##sys#signal-hook #:type-error 'array-ref "not an index object" x)))))))
1187    (vector-ref
1188     (array:vector a)
1189     (if (null? xs)
1190         (vector-ref (array:index a) 0)
1191         (let ((x (car xs)))
1192           (if (vector? x)
1193               (array:index/vector
1194                (quotient (vector-length shape) 2)
1195                (array:index a)
1196                x)
1197               (if (integer? x)
1198                   (array:vector-index (array:index a) xs)
1199                   (if (##core#check (array:array? x))
1200                       (array:index/array
1201                        (quotient (vector-length shape) 2)
1202                        (array:index a)
1203                        (array:vector x)
1204                        (array:index x))
1205                       (##sys#signal-hook #:type-error 'array-ref "bad index object" x)))))))))
1206
1207(define (array-set! a x . xs)
1208  (or (##core#check (array:array? a))
1209      (##sys#signal-hook #:type-error 'array-set! "not an array" a))
1210  (let ((shape (array:shape a)))
1211    (##core#check
1212     (if (null? xs)
1213         (array:check-indices "array-set!" '() shape)
1214         (if (vector? x)
1215            (array:check-index-vector "array-set!" x shape)
1216            (if (integer? x)
1217                (array:check-indices.o "array-set!" (cons x xs) shape)
1218                (if (array:array? x)
1219                    (array:check-index-actor "array-set!" x shape)
1220                    (##sys#signal-hook #:type-error 'array-set! "not an index object" x))))))
1221    (if (null? xs)
1222        (vector-set! (array:vector a) (vector-ref (array:index a) 0) x)
1223        (if (vector? x)
1224            (vector-set! (array:vector a)
1225                         (array:index/vector
1226                          (quotient (vector-length shape) 2)
1227                          (array:index a)
1228                          x)
1229                         (car xs))
1230            (if (integer? x)
1231                (let ((v (array:vector a))
1232                      (i (array:index a))
1233                      (r (quotient (vector-length shape) 2)))
1234                  (do ((sum (* (vector-ref i 0) x)
1235                            (+ sum (* (vector-ref i k) (car ks))))
1236                       (ks xs (cdr ks))
1237                       (k 1 (+ k 1)))
1238                    ((= k r)
1239                     (vector-set! v (+ sum (vector-ref i k)) (car ks)))))
1240                (if (##core#check (array:array? x))
1241                    (vector-set! (array:vector a)
1242                                 (array:index/array
1243                                  (quotient (vector-length shape) 2)
1244                                  (array:index a)
1245                                  (array:vector x)
1246                                  (array:index x))
1247                                 (car xs))
1248                    (##sys#signal-hook
1249                     #:type-error 'array-set!
1250                     "bad index object: "
1251                     x)))))))
1252
1253(define (array:make-locative a x weak?)
1254  (or (##core#check (array:array? a))
1255      (##sys#signal-hook #:type-error 'array:make-locative "not an array"))
1256  (let ((shape (array:shape a)))
1257    (##core#check
1258     (if (vector? x)
1259         (array:check-index-vector "array:make-locative" x shape)
1260         (if (integer? x)
1261             (array:check-indices.o "array:make-locative" (list x) shape)
1262             (if (array:array? x)
1263                 (array:check-index-actor "array:make-locative" x shape)
1264                 (##sys#signal-hook #:type-error 'array:make-locative "not an index object" x)))))
1265    (if (vector? x)
1266        (##core#inline_allocate
1267         ("C_a_i_make_locative" 5)
1268         0
1269         (array:vector a)
1270         (array:index/vector
1271          (quotient (vector-length shape) 2)
1272          (array:index a)
1273          x) 
1274         weak?)
1275        (if (##core#check (array:array? x))
1276            (##core#inline_allocate
1277             ("C_a_i_make_locative" 5)
1278             0
1279             (array:vector a)
1280             (array:index/array
1281              (quotient (vector-length shape) 2)
1282              (array:index a)
1283              (array:vector x)
1284              (array:index x)) 
1285             weak?)
1286            (##sys#signal-hook #:type-error 'array:make-locative "bad index object: " x)))))
1287
1288)
Note: See TracBrowser for help on using the repository browser.