share/guile/1.6.0/ice-9/arrays.scm

   1 ;;; installed-scm-file
   2
   3 ;;;; Copyright (C) 1999, 2001 Free Software Foundation, Inc.
   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)
  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)))
  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)))
  50             '(#\a #\u #\e #\s #\i #\c #\y   #\h #\l)
  51             '(#\a 1   -1  1.0 1/3 0+i #\nul s   l)))
  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))
  82       (list->uniform-array 1 proto (read port))))