Commit | Line | Data |
---|---|---|
b4ca4db3 GH |
1 | ;;; installed-scm-file |
2 | ||
8cdeee7d | 3 | ;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc. |
b4ca4db3 GH |
4 | ;;;; |
5 | ;;;; This program is free software; you can redistribute it and/or modify | |
6 | ;;;; it under the terms of the GNU General Public License as published by | |
7 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;;;; any later version. | |
9 | ;;;; | |
10 | ;;;; This program is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;;;; GNU General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU General Public License | |
16 | ;;;; along with this software; see the file COPYING. If not, write to | |
17 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
18 | ;;;; Boston, MA 02111-1307 USA | |
19 | ;;;; | |
20 | ||
21 | (define uniform-vector? array?) | |
22 | (define make-uniform-vector dimensions->uniform-array) | |
23 | ||
24 | ;; (define uniform-vector-ref array-ref) | |
25 | ||
26 | (define (uniform-vector-set! u i o) | |
27 | (uniform-array-set1! u o i)) | |
28 | (define uniform-vector-fill! array-fill!) | |
29 | (define uniform-vector-read! uniform-array-read!) | |
30 | (define uniform-vector-write uniform-array-write) | |
31 | ||
32 | (define (make-array fill . args) | |
8cdeee7d | 33 | (dimensions->uniform-array args '() fill)) |
b4ca4db3 GH |
34 | (define (make-uniform-array prot . args) |
35 | (dimensions->uniform-array args prot)) | |
36 | (define (list->array ndim lst) | |
37 | (list->uniform-array ndim '() lst)) | |
38 | (define (list->uniform-vector prot lst) | |
39 | (list->uniform-array 1 prot lst)) | |
40 | (define (array-shape a) | |
41 | (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) | |
42 | (array-dimensions a))) | |
43 | ||
44 | (let ((make-array-proc (lambda (template) | |
45 | (lambda (c port) | |
46 | (read:uniform-vector template port))))) | |
47 | (for-each (lambda (char template) | |
48 | (read-hash-extend char | |
49 | (make-array-proc template))) | |
197edeea DH |
50 | '(#\a #\u #\e #\s #\i #\c #\y #\h #\l) |
51 | '(#\a 1 -1 1.0 1/3 0+i #\nul s l))) | |
b4ca4db3 GH |
52 | |
53 | (let ((array-proc (lambda (c port) | |
54 | (read:array c port)))) | |
55 | (for-each (lambda (char) (read-hash-extend char array-proc)) | |
56 | '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))) | |
57 | ||
58 | (define (read:array digit port) | |
59 | (define chr0 (char->integer #\0)) | |
60 | (let ((rank (let readnum ((val (- (char->integer digit) chr0))) | |
61 | (if (char-numeric? (peek-char port)) | |
62 | (readnum (+ (* 10 val) | |
63 | (- (char->integer (read-char port)) chr0))) | |
64 | val))) | |
65 | (prot (if (eq? #\( (peek-char port)) | |
66 | '() | |
67 | (let ((c (read-char port))) | |
68 | (case c ((#\b) #t) | |
69 | ((#\a) #\a) | |
70 | ((#\u) 1) | |
71 | ((#\e) -1) | |
72 | ((#\s) 1.0) | |
73 | ((#\i) 1/3) | |
74 | ((#\c) 0+i) | |
75 | (else (error "read:array unknown option " c))))))) | |
76 | (if (eq? (peek-char port) #\() | |
77 | (list->uniform-array rank prot (read port)) | |
78 | (error "read:array list not found")))) | |
79 | ||
80 | (define (read:uniform-vector proto port) | |
81 | (if (eq? #\( (peek-char port)) | |
89759084 | 82 | (list->uniform-array 1 proto (read port)))) |