3 ;;;; Copyright (C) 1999 Free Software Foundation, Inc.
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.
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.
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
21 (define uniform-vector? array?)
22 (define make-uniform-vector dimensions->uniform-array)
24 ;; (define uniform-vector-ref array-ref)
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)
32 (define (make-array fill . args)
33 (dimensions->uniform-array args () fill))
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)))
44 (let ((make-array-proc (lambda (template)
46 (read:uniform-vector template port)))))
47 (for-each (lambda (char template)
48 (read-hash-extend char
49 (make-array-proc template)))
50 '(#\b #\a #\u #\e #\s #\i #\c #\y #\h #\l)
51 '(#t #\a 1 -1 1.0 1/3 0+i #\nul s l)))
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)))
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)))
65 (prot (if (eq? #\( (peek-char port))
67 (let ((c (read-char port)))
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"))))
80 (define (read:uniform-vector proto port)
81 (if (eq? #\( (peek-char port))
82 (list->uniform-array 1 proto (read port))
83 (error "read:uniform-vector list not found")))