Artifact eeadc083abb386ddbee8c6b8976dc93feddf8740:
- File srfi/s25/ix-ctor.scm — part of check-in [80c8c83034] at 2016-07-07 18:11:39 on branch trunk — initial import (user: ovenpasta@pizzahack.eu size: 3221)
0000: 28 64 65 66 69 6e 65 20 28 61 72 72 61 79 2d 72 (define (array-r 0010: 65 66 20 61 20 2e 20 78 73 29 0a 20 20 28 6f 72 ef a . xs). (or 0020: 20 28 61 72 72 61 79 3a 61 72 72 61 79 3f 20 61 (array:array? a 0030: 29 0a 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 ). (error " 0040: 6e 6f 74 20 61 6e 20 61 72 72 61 79 22 29 29 0a not an array")). 0050: 20 20 28 6c 65 74 20 28 28 73 68 61 70 65 20 28 (let ((shape ( 0060: 61 72 72 61 79 3a 73 68 61 70 65 20 61 29 29 29 array:shape a))) 0070: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null? 0080: 78 73 29 0a 20 20 20 20 20 20 20 20 28 61 72 72 xs). (arr 0090: 61 79 3a 63 68 65 63 6b 2d 69 6e 64 69 63 65 73 ay:check-indices 00a0: 20 22 61 72 72 61 79 2d 72 65 66 22 20 78 73 20 "array-ref" xs 00b0: 73 68 61 70 65 29 0a 20 20 20 20 20 20 20 20 28 shape). ( 00c0: 6c 65 74 20 28 28 78 20 28 63 61 72 20 78 73 29 let ((x (car xs) 00d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if 00e0: 20 28 76 65 63 74 6f 72 3f 20 78 29 0a 20 20 20 (vector? x). 00f0: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 72 61 (arra 0100: 79 3a 63 68 65 63 6b 2d 69 6e 64 65 78 2d 76 65 y:check-index-ve 0110: 63 74 6f 72 20 22 61 72 72 61 79 2d 72 65 66 22 ctor "array-ref" 0120: 20 78 20 73 68 61 70 65 29 0a 20 20 20 20 20 20 x shape). 0130: 20 20 20 20 20 20 20 20 28 69 66 20 28 69 6e 74 (if (int 0140: 65 67 65 72 3f 20 78 29 0a 20 20 20 20 20 20 20 eger? x). 0150: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 72 61 (arra 0160: 79 3a 63 68 65 63 6b 2d 69 6e 64 69 63 65 73 20 y:check-indices 0170: 22 61 72 72 61 79 2d 72 65 66 22 20 78 73 20 73 "array-ref" xs s 0180: 68 61 70 65 29 0a 20 20 20 20 20 20 20 20 20 20 hape). 0190: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 72 72 (if (arr 01a0: 61 79 3a 61 72 72 61 79 3f 20 78 29 0a 20 20 20 ay:array? x). 01b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 01c0: 20 20 20 28 61 72 72 61 79 3a 63 68 65 63 6b 2d (array:check- 01d0: 69 6e 64 65 78 2d 61 63 74 6f 72 20 22 61 72 72 index-actor "arr 01e0: 61 79 2d 72 65 66 22 20 78 20 73 68 61 70 65 29 ay-ref" x shape) 01f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 0200: 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 6e (error "n 0210: 6f 74 20 61 6e 20 69 6e 64 65 78 20 6f 62 6a 65 ot an index obje 0220: 63 74 22 29 29 29 29 29 29 0a 20 20 20 20 28 76 ct")))))). (v 0230: 65 63 74 6f 72 2d 72 65 66 0a 20 20 20 20 20 28 ector-ref. ( 0240: 61 72 72 61 79 3a 76 65 63 74 6f 72 20 61 29 0a array:vector a). 0250: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null? 0260: 78 73 29 0a 20 20 20 20 20 20 20 20 20 28 76 65 xs). (ve 0270: 63 74 6f 72 2d 72 65 66 20 28 61 72 72 61 79 3a ctor-ref (array: 0280: 69 6e 64 65 78 20 61 29 20 30 29 0a 20 20 20 20 index a) 0). 0290: 20 20 20 20 20 28 6c 65 74 20 28 28 78 20 28 63 (let ((x (c 02a0: 61 72 20 78 73 29 29 29 0a 20 20 20 20 20 20 20 ar xs))). 02b0: 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f (if (vector? 02c0: 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x). 02d0: 20 20 20 28 61 72 72 61 79 3a 69 6e 64 65 78 2f (array:index/ 02e0: 76 65 63 74 6f 72 0a 20 20 20 20 20 20 20 20 20 vector. 02f0: 20 20 20 20 20 20 20 28 71 75 6f 74 69 65 6e 74 (quotient 0300: 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 (vector-length 0310: 73 68 61 70 65 29 20 32 29 0a 20 20 20 20 20 20 shape) 2). 0320: 20 20 20 20 20 20 20 20 20 20 28 61 72 72 61 79 (array 0330: 3a 69 6e 64 65 78 20 61 29 0a 20 20 20 20 20 20 :index a). 0340: 20 20 20 20 20 20 20 20 20 20 78 29 0a 20 20 20 x). 0350: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 0360: 28 69 6e 74 65 67 65 72 3f 20 78 29 0a 20 20 20 (integer? x). 0370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0380: 28 61 72 72 61 79 3a 76 65 63 74 6f 72 2d 69 6e (array:vector-in 0390: 64 65 78 20 28 61 72 72 61 79 3a 69 6e 64 65 78 dex (array:index 03a0: 20 61 29 20 78 73 29 0a 20 20 20 20 20 20 20 20 a) xs). 03b0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 03c0: 61 72 72 61 79 3a 61 72 72 61 79 3f 20 78 29 0a array:array? x). 03d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 03e0: 20 20 20 20 20 20 20 28 61 72 72 61 79 3a 69 6e (array:in 03f0: 64 65 78 2f 61 72 72 61 79 0a 20 20 20 20 20 20 dex/array. 0400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0410: 20 20 28 71 75 6f 74 69 65 6e 74 20 28 76 65 63 (quotient (vec 0420: 74 6f 72 2d 6c 65 6e 67 74 68 20 73 68 61 70 65 tor-length shape 0430: 29 20 32 29 0a 20 20 20 20 20 20 20 20 20 20 20 ) 2). 0440: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 72 (ar 0450: 72 61 79 3a 69 6e 64 65 78 20 61 29 0a 20 20 20 ray:index a). 0460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0470: 20 20 20 20 20 28 61 72 72 61 79 3a 76 65 63 74 (array:vect 0480: 6f 72 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 or x). 0490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a 04a0: 72 72 61 79 3a 69 6e 64 65 78 20 78 29 29 0a 20 rray:index x)). 04b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 04c0: 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 61 72 (error "ar 04d0: 72 61 79 2d 72 65 66 3a 20 62 61 64 20 69 6e 64 ray-ref: bad ind 04e0: 65 78 20 6f 62 6a 65 63 74 22 29 29 29 29 29 29 ex object")))))) 04f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 72 )))..(define (ar 0500: 72 61 79 2d 73 65 74 21 20 61 20 78 20 2e 20 78 ray-set! a x . x 0510: 73 29 0a 20 20 28 6f 72 20 28 61 72 72 61 79 3a s). (or (array: 0520: 61 72 72 61 79 3f 20 61 29 0a 20 20 20 20 20 20 array? a). 0530: 28 65 72 72 6f 72 20 22 61 72 72 61 79 2d 73 65 (error "array-se 0540: 74 21 3a 20 6e 6f 74 20 61 6e 20 61 72 72 61 79 t!: not an array 0550: 22 29 29 0a 20 20 28 6c 65 74 20 28 28 73 68 61 ")). (let ((sha 0560: 70 65 20 28 61 72 72 61 79 3a 73 68 61 70 65 20 pe (array:shape 0570: 61 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 a))). (if (nu 0580: 6c 6c 3f 20 78 73 29 0a 20 20 20 20 20 20 20 20 ll? xs). 0590: 28 61 72 72 61 79 3a 63 68 65 63 6b 2d 69 6e 64 (array:check-ind 05a0: 69 63 65 73 20 22 61 72 72 61 79 2d 73 65 74 21 ices "array-set! 05b0: 22 20 27 28 29 20 73 68 61 70 65 29 0a 20 20 20 " '() shape). 05c0: 20 20 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 (if (vector 05d0: 3f 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 ? x). 05e0: 20 28 61 72 72 61 79 3a 63 68 65 63 6b 2d 69 6e (array:check-in 05f0: 64 65 78 2d 76 65 63 74 6f 72 20 22 61 72 72 61 dex-vector "arra 0600: 79 2d 73 65 74 21 22 20 78 20 73 68 61 70 65 29 y-set!" x shape) 0610: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 . (if 0620: 20 28 69 6e 74 65 67 65 72 3f 20 78 29 0a 20 20 (integer? x). 0630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a 0640: 72 72 61 79 3a 63 68 65 63 6b 2d 69 6e 64 69 63 rray:check-indic 0650: 65 73 2e 6f 20 22 61 72 72 61 79 2d 73 65 74 21 es.o "array-set! 0660: 22 20 28 63 6f 6e 73 20 78 20 78 73 29 20 73 68 " (cons x xs) sh 0670: 61 70 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ape). 0680: 20 20 20 20 20 28 69 66 20 28 61 72 72 61 79 3a (if (array: 0690: 61 72 72 61 79 3f 20 78 29 0a 20 20 20 20 20 20 array? x). 06a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a 06b0: 72 72 61 79 3a 63 68 65 63 6b 2d 69 6e 64 65 78 rray:check-index 06c0: 2d 61 63 74 6f 72 20 22 61 72 72 61 79 2d 73 65 -actor "array-se 06d0: 74 21 22 20 78 20 73 68 61 70 65 29 0a 20 20 20 t!" x shape). 06e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 06f0: 20 28 65 72 72 6f 72 20 22 6e 6f 74 20 61 6e 20 (error "not an 0700: 69 6e 64 65 78 20 6f 62 6a 65 63 74 22 29 29 29 index object"))) 0710: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c )). (if (null 0720: 3f 20 78 73 29 0a 20 20 20 20 20 20 20 20 28 76 ? xs). (v 0730: 65 63 74 6f 72 2d 73 65 74 21 20 28 61 72 72 61 ector-set! (arra 0740: 79 3a 76 65 63 74 6f 72 20 61 29 20 28 76 65 63 y:vector a) (vec 0750: 74 6f 72 2d 72 65 66 20 28 61 72 72 61 79 3a 69 tor-ref (array:i 0760: 6e 64 65 78 20 61 29 20 30 29 20 78 29 0a 20 20 ndex a) 0) x). 0770: 20 20 20 20 20 20 28 69 66 20 28 76 65 63 74 6f (if (vecto 0780: 72 3f 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 r? x). 0790: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 28 (vector-set! ( 07a0: 61 72 72 61 79 3a 76 65 63 74 6f 72 20 61 29 0a array:vector a). 07b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 07c0: 20 20 20 20 20 20 20 20 20 28 61 72 72 61 79 3a (array: 07d0: 69 6e 64 65 78 2f 76 65 63 74 6f 72 0a 20 20 20 index/vector. 07e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 07f0: 20 20 20 20 20 20 20 28 71 75 6f 74 69 65 6e 74 (quotient 0800: 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 (vector-length 0810: 73 68 61 70 65 29 20 32 29 0a 20 20 20 20 20 20 shape) 2). 0820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0830: 20 20 20 20 28 61 72 72 61 79 3a 69 6e 64 65 78 (array:index 0840: 20 61 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 a). 0850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 78 29 x) 0860: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 0870: 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 78 (car x 0880: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)). 0890: 28 69 66 20 28 69 6e 74 65 67 65 72 3f 20 78 29 (if (integer? x) 08a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 08b0: 20 28 6c 65 74 20 28 28 76 20 28 61 72 72 61 79 (let ((v (array 08c0: 3a 76 65 63 74 6f 72 20 61 29 29 0a 20 20 20 20 :vector a)). 08d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 08e0: 20 20 28 69 20 28 61 72 72 61 79 3a 69 6e 64 65 (i (array:inde 08f0: 78 20 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 x a)). 0900: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 20 28 (r ( 0910: 71 75 6f 74 69 65 6e 74 20 28 76 65 63 74 6f 72 quotient (vector 0920: 2d 6c 65 6e 67 74 68 20 73 68 61 70 65 29 20 32 -length shape) 2 0930: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 0940: 20 20 20 20 20 20 28 64 6f 20 28 28 73 75 6d 20 (do ((sum 0950: 28 2a 20 28 76 65 63 74 6f 72 2d 72 65 66 20 69 (* (vector-ref i 0960: 20 30 29 20 78 29 0a 20 20 20 20 20 20 20 20 20 0) x). 0970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0980: 20 20 20 28 2b 20 73 75 6d 20 28 2a 20 28 76 65 (+ sum (* (ve 0990: 63 74 6f 72 2d 72 65 66 20 69 20 6b 29 20 28 63 ctor-ref i k) (c 09a0: 61 72 20 6b 73 29 29 29 29 0a 20 20 20 20 20 20 ar ks)))). 09b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 09c0: 20 28 6b 73 20 78 73 20 28 63 64 72 20 6b 73 29 (ks xs (cdr ks) 09d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 09e0: 20 20 20 20 20 20 20 20 20 28 6b 20 31 20 28 2b (k 1 (+ 09f0: 20 6b 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 k 1))). 0a00: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 3d 20 ((= 0a10: 6b 20 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 k r). 0a20: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f (vecto 0a30: 72 2d 73 65 74 21 20 76 20 28 2b 20 73 75 6d 20 r-set! v (+ sum 0a40: 28 76 65 63 74 6f 72 2d 72 65 66 20 69 20 6b 29 (vector-ref i k) 0a50: 29 20 28 63 61 72 20 6b 73 29 29 29 29 29 0a 20 ) (car ks))))). 0a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 0a70: 69 66 20 28 61 72 72 61 79 3a 61 72 72 61 79 3f if (array:array? 0a80: 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x). 0a90: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector- 0aa0: 73 65 74 21 20 28 61 72 72 61 79 3a 76 65 63 74 set! (array:vect 0ab0: 6f 72 20 61 29 0a 20 20 20 20 20 20 20 20 20 20 or a). 0ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0ad0: 20 20 20 20 20 20 20 28 61 72 72 61 79 3a 69 6e (array:in 0ae0: 64 65 78 2f 61 72 72 61 79 0a 20 20 20 20 20 20 dex/array. 0af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b00: 20 20 20 20 20 20 20 20 20 20 20 20 28 71 75 6f (quo 0b10: 74 69 65 6e 74 20 28 76 65 63 74 6f 72 2d 6c 65 tient (vector-le 0b20: 6e 67 74 68 20 73 68 61 70 65 29 20 32 29 0a 20 ngth shape) 2). 0b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b50: 20 28 61 72 72 61 79 3a 69 6e 64 65 78 20 61 29 (array:index a) 0b60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0b80: 20 20 20 28 61 72 72 61 79 3a 76 65 63 74 6f 72 (array:vector 0b90: 20 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 x). 0ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0bb0: 20 20 20 20 20 20 28 61 72 72 61 79 3a 69 6e 64 (array:ind 0bc0: 65 78 20 78 29 29 0a 20 20 20 20 20 20 20 20 20 ex x)). 0bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0be0: 20 20 20 20 20 20 20 20 28 63 61 72 20 78 73 29 (car xs) 0bf0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 0c00: 20 20 20 20 20 20 28 65 72 72 6f 72 20 28 73 74 (error (st 0c10: 72 69 6e 67 2d 61 70 70 65 6e 64 0a 20 20 20 20 ring-append. 0c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0c30: 20 20 20 20 20 20 20 20 22 61 72 72 61 79 2d 73 "array-s 0c40: 65 74 21 3a 20 62 61 64 20 69 6e 64 65 78 20 6f et!: bad index o 0c50: 62 6a 65 63 74 3a 20 22 0a 20 20 20 20 20 20 20 bject: ". 0c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0c70: 20 20 20 20 20 28 61 72 72 61 79 3a 74 68 69 6e (array:thin 0c80: 67 2d 3e 73 74 72 69 6e 67 20 78 29 29 29 29 29 g->string x))))) 0c90: 29 29 29 29 0a )))).