Changeset 9531 in project


Ignore:
Timestamp:
03/13/08 05:13:30 (12 years ago)
Author:
Kon Lovett
Message:

Save of SRFI-58 support.

Location:
release/3/array-lib
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • release/3/array-lib/matrix.scm

    r6513 r9531  
    11;Translation of srfi-25 arlib.scm transpose operation
     2
     3(eval-when (compile)
     4  (declare
     5    (usual-integrations)
     6    (inline)
     7    (fixnum)
     8    (no-bound-checks)
     9    (no-procedure-checks)
     10    (export
     11      array-transpose ) ) )
    212
    313(use srfi-1)
     
    2232;; matrix but matrix multiplication is not exported.
    2333
    24 (define (array-matrix-times a b)
     34(define (array-matrix-fx* a b)
    2535  (unless (and (= 2 (array-rank a)) (= 2 (array-rank b)))
    26     (error 'array-matrix-times "arrays are not matrices" a b) )
     36    (error 'array-matrix-fx* "arrays are not matrices" a b) )
    2737  (let ([r0 (array-start a 0)]  [rn (array-end a 0)]
    2838        [t0 (array-start a 1)]  [tn (array-end a 1)]
    29         [u0 (array-start b 0)]  [un (array-end b 0)] 
     39        [u0 (array-start b 0)]  [un (array-end b 0)]
    3040        [k0 (array-start b 1)]  [kn (array-end b 1)])
    3141    (unless (= (- tn t0) (- un u0))
    32       (error 'array-matrix-times "matrices are not compatible" a b) )
     42      (error 'array-matrix-fx* "matrices are not compatible" a b) )
    3343    (let ([ab (make-array (array-prototype a) (make-array-shape r0 rn k0 kn))])
    3444      (do ([r r0 (+ r 1)])
     
    4050               [s 0 (+ s (* (array-ref a r t) (array-ref b u k)))])
    4151              [(and (= t tn) (= u un))
    42                (set! (array-ref ab r k) s)])))
     52               (set! (array-ref ab r k) s)] ) ) )
    4353      ab ) ) )
    4454
    45 ; This is a generalized array-transpose. It can permute the dimensions any which 
     55; This is a generalized array-transpose. It can permute the dimensions any which
    4656; way. The permutation is provided by a permutation matrix: a square matrix
    4757; of zeros and ones, with exactly one one in each row and column, or a
     
    8191                                                 (lambda (r k)
    8292                                                   ;; array-transpose
    83                                                    (list k r) )
     93                                                   `(,k ,r) )
    8494                                                 (array-shape-object permutation)) ] )
    8595    (apply make-shared-array
    8696     arr
    8797     (lambda ks0
     98       ; Need the list "flattened"
    8899       (map! car
    89100             (array->list
    90               (array-matrix-times inverse-permutation
    91                                   (apply array (A:fixZ32b) idxshp ks0)))))
     101              (array-matrix-fx* inverse-permutation
     102                                (apply array (A:fixZ32b) idxshp ks0)))))
    92103     (array->list
    93       (array-matrix-times permutation (array-shape-matrix arr)))) ) )
     104      (array-matrix-fx* permutation (array-shape-matrix arr)))) ) )
  • release/3/array-lib/trunk/array-lib-eggdoc.scm

    r6513 r9531  
    756756
    757757          (p (tt "PROCEDURE") " has a signature "
    758           (code "(-> (ROW-NO fixnum) (SEED-1 object) ... (SEED-N object)
    759                      (values (ELEMENT-1 object) ... (ELEMENT-N object)))") ". "
     758          (code "((ROW-NO fixnum) (SEED-1 object) ... (SEED-N object) -> (values (ELEMENT-1 object) ... (ELEMENT-N object)))") ". "
    760759          "The values of the previous invocation are the arguments of the next.") )
    761760
     
    850849          "prototype.") )
    851850
    852         (procedure "(A:floQ128b [INITIAL])"
     851        (procedure "(A:floQ128d [INITIAL])"
    853852          (p "Returns an exact 128 bit decimal flonum rational "
    854853          "uniform-array prototype.") )
    855854
    856         (procedure "(A:floQ64b [INITIAL])"
     855        (procedure "(A:floQ64d [INITIAL])"
    857856          (p "Returns an exact 64 bit decimal flonum rational "
    858857          "uniform-array prototype.") )
    859858
    860         (procedure "(A:floQ32b [INITIAL])"
     859        (procedure "(A:floQ32d [INITIAL])"
    861860          (p "Returns an exact 32 bit decimal flonum rational "
    862861          "uniform-array prototype.") )
     
    998997      (p "The 128-bit & 64-bit prototypes are currently implemented as unpacked vectors.")
    999998
    1000       (p "Partial SRFI-58 implementation.")
     999      (p "Full SRFI-58 implementation except for the '#<dimensions>...' form.")
     1000
     1001      (p "Doesn't print full SRFI-58 form.")
    10011002    )
    10021003
     
    10101011
    10111012    (history
     1013      (version "3.1.0" "Bug fix for SRFI-63 prototype names & more SRFI-58 support.")
    10121014      (version "3.001" "Bug fix for SRFI-63 prototype names.")
    10131015      (version "3.0" "Bug fix for dimensions of 0 - these should result in an empty array - and not be treated as a synonym of dimension 1. Added 'array-dimensions-object' & 'array-shape-object'.")
  • release/3/array-lib/trunk/array-lib-sem.scm

    r6513 r9531  
    9292      A:floR32b
    9393      A:floR16b
    94       A:floQ128b
    95       A:floQ64b
    96       A:floQ32b
     94      A:floQ128d
     95      A:floQ64d
     96      A:floQ32d
    9797      A:floC16b
    9898      A:fixZ64b
     
    10411041;;@args
    10421042;;Returns an exact 128 bit decimal rational uniform-array prototype.
    1043 (define A:floQ128b (make-prototype-checker 'A:floQ128b exact-rational? vector))
     1043(define A:floQ128d (make-prototype-checker 'A:floQ128d exact-rational? vector))
    10441044;;@args z
    10451045;;@args
    10461046;;Returns an exact 64 bit decimal rational uniform-array prototype.
    1047 (define A:floQ64b (make-prototype-checker 'A:floQ64b exact-rational? vector))
     1047(define A:floQ64d (make-prototype-checker 'A:floQ64d exact-rational? vector))
    10481048;;@args z
    10491049;;@args
    10501050;;Returns an exact 32 bit decimal rational uniform-array prototype.
    1051 (define A:floQ32b (make-prototype-checker 'A:floQ32b exact-rational? vector))
     1051(define A:floQ32d (make-prototype-checker 'A:floQ32d exact-rational? vector))
    10521052
    10531053;;@args n
     
    11241124(define a:flor32b A:floR32b)
    11251125(define a:flor16b A:floR16b)
    1126 (define a:floq128b A:floQ128b)
    1127 (define a:floq64b A:floQ64b)
    1128 (define a:floq32b A:floQ32b)
     1126(define a:floq128b A:floQ128d)
     1127(define a:floq64b A:floQ64d)
     1128(define a:floq32b A:floQ32d)
    11291129(define a:fixz64b A:fixZ64b)
    11301130(define a:fixz32b A:fixZ32b)
  • release/3/array-lib/trunk/array-lib-syn.scm

    r6513 r9531  
    9090;; An empty range has low == high
    9191
     92#; ;UNUSED
    9293(define-inline (arr$range-empty? l h)
    93   (= l h) )
     94  #;
     95  (= l h)
     96  (or (= l h)
     97      (< h l) ) )
    9498
    9599;; Bounds object (closed interval)
     
    106110;; An empty bounds has an empty range
    107111
     112#; ;UNUSED
    108113(define-inline (arr$bounds-empty? bnds)
    109114  (arr$range-empty? (arr$bounds-low bnds) (arr$bounds-high bnds)) )
     
    119124  (list (arr$bounds-low bnds) (+ (arr$bounds-high bnds) 1)) )
    120125
    121 #; ;NO ZERO DIMENSIONS
    122 (define-inline (arr$bounds->interval bnds)
    123   (let ([l (arr$bounds-low bnds)]
    124         [h (arr$bounds-high bnds)])
    125     (list l (if (arr$range-empty? l h) h (+ h 1))) ) )
    126 
    127126;; Open interval -> closed interval (bounds object)
    128127
     
    130129  (arr$make-bounds l (- h 1)) )
    131130
    132 #; ;NO ZERO DIMENSIONS
    133 (define-inline (arr$interval->bounds l h)
    134   (arr$make-bounds l (if (arr$range-empty? l h) h (- h 1))) )
    135 
    136131;; Simple within bound test
    137132
    138133(define-inline (arr$index-in-bound? idx bnds)
    139   (<= (arr$bounds-low bnds) idx (arr$bounds-high bnds)) )
     134  (and (<= (arr$bounds-low bnds) idx)
     135       (let ([h (arr$bounds-high bnds)])
     136         (or (and (= 0 idx) (= -1 h))
     137             (<= idx h) ) ) ) )
    140138
    141139;; Handle case of empty indices treated as '(0), fixup for rank 0.
     
    159157(define-inline (arr$lengths->length lens)
    160158  (apply * lens) )
    161 
    162 #; ;NO ZERO DIMENSIONS
    163 (define-inline (arr$lengths->length lens)
    164   ; Inlined version of
    165   ; (reduce (lambda (tot len) (if (= 0 len) tot (* tot len))) 1 lens)
    166   (let loop ([lens lens] [tot 1])
    167     (if (null? lens)
    168       tot
    169       (loop (cdr lens) (let ([len (car lens)]) (if (= 0 len) tot (* tot len)))) ) ) )
    170159
    171160;; Calculate the number of linear elements for each dimension
     
    187176;; Backend array element index computation
    188177
    189 #; ; This version does not use an indexer procedure
     178#; ;UNUSED This version does not use an indexer procedure
    190179(define-inline (arr$array-store-index arr idxs)
    191180  (apply + (arr$array-offset arr) (map * (arr$array-scales arr) idxs)))
  • release/3/array-lib/trunk/array-lib.html

    r6513 r9531  
    498498<p>Returns a new array from the <tt>PROTOTYPE</tt>, the dimensionality <tt>RANK/SHAPE/DIMENSIONS</tt>, and elements from the result values of interated invocations of <tt>PROCEDURE</tt>.</p>
    499499<p>The number of seeds must equal the number of elements in the inner-most row of the new array.</p>
    500 <p><tt>PROCEDURE</tt> has a signature <code>(-&gt; (ROW-NO fixnum) (SEED-1 object) ... (SEED-N object)
    501                      (values (ELEMENT-1 object) ... (ELEMENT-N object)))</code>. The values of the previous invocation are the arguments of the next.</p></dd>
     500<p><tt>PROCEDURE</tt> has a signature <code>((ROW-NO fixnum) (SEED-1 object) ... (SEED-N object) -&gt; (values (ELEMENT-1 object) ... (ELEMENT-N object)))</code>. The values of the previous invocation are the arguments of the next.</p></dd>
    502501<dt class="definition"><strong>procedure:</strong> (array-reshape PROTOTYPE RANK/SHAPE/DIMENSIONS PROCEDURE ARRAY)</dt>
    503502<dd>
     
    552551<dd>
    553552<p>Returns an inexact 16 bit flonum real uniform-array prototype.</p></dd>
    554 <dt class="definition"><strong>procedure:</strong> (A:floQ128b [INITIAL])</dt>
     553<dt class="definition"><strong>procedure:</strong> (A:floQ128d [INITIAL])</dt>
    555554<dd>
    556555<p>Returns an exact 128 bit decimal flonum rational uniform-array prototype.</p></dd>
    557 <dt class="definition"><strong>procedure:</strong> (A:floQ64b [INITIAL])</dt>
     556<dt class="definition"><strong>procedure:</strong> (A:floQ64d [INITIAL])</dt>
    558557<dd>
    559558<p>Returns an exact 64 bit decimal flonum rational uniform-array prototype.</p></dd>
    560 <dt class="definition"><strong>procedure:</strong> (A:floQ32b [INITIAL])</dt>
     559<dt class="definition"><strong>procedure:</strong> (A:floQ32d [INITIAL])</dt>
    561560<dd>
    562561<p>Returns an exact 32 bit decimal flonum rational uniform-array prototype.</p></dd>
     
    672671<p>The SRFI-42 general dispatcher <code>(: ...)</code> does not recognize arrays.</p>
    673672<p>The 128-bit &amp; 64-bit prototypes are currently implemented as unpacked vectors.</p>
    674 <p>Partial SRFI-58 implementation.</p></div>
     673<p>Full SRFI-58 implementation except for the '#&lt;dimensions&gt;...' form.</p>
     674<p>Doesn't print full SRFI-58 form.</p></div>
    675675<div class="section">
    676676<h3>Examples</h3>
     
    771771<h3>Version</h3>
    772772<ul>
     773<li>3.1.0 Bug fix for SRFI-63 prototype names &amp; more SRFI-58 support.</li>
    773774<li>3.001 Bug fix for SRFI-63 prototype names.</li>
    774775<li>3.0 Bug fix for dimensions of 0 - these should result in an empty array - and not be treated as a synonym of dimension 1. Added 'array-dimensions-object' &amp; 'array-shape-object'.</li>
  • release/3/array-lib/trunk/array-lib.scm

    r6499 r9531  
    124124      array->list
    125125      list->array
     126      list->uniform-array
    126127      array->vector
    127128      vector->array
     
    622623    (when (pair? rest)
    623624      (let ([itm (car rest)])
    624         (when (arr$ako-array? itm)
    625           (set! proto itm)
    626           (set! dims (cdr rest)) ) ) )
     625        (cond [(not itm)
     626               #;(set! proto arr$*empty-vector*)
     627               (set! dims (cdr rest)) ]
     628              [(arr$ako-array? itm)
     629               (set! proto itm)
     630               (set! dims (cdr rest)) ] ) ) )
    627631    ; Build array
    628632    (let ([shp (arr$optional-dimensionality dims 'make-array)])
     
    642646        [elms rest])
    643647    ; Handle optional prototype argument
    644     (if (arr$ako-array? proto)
    645         (if (pair? rest)
    646             (begin
    647               (set! dims (car rest))
    648               (set! elms (cdr rest)) )
    649             (arr$error/type/dimensionality 'array rest))
    650         (begin
    651           (set! dims proto)
    652           (set! proto arr$*empty-vector*)))
     648    (cond [(or (not proto) (arr$ako-array? proto))
     649           (if (pair? rest)
     650               (begin
     651                 (set! dims (car rest))
     652                 (set! elms (cdr rest)) )
     653               (arr$error/type/dimensionality 'array rest)) ]
     654          [else
     655           (set! dims proto)
     656           (set! proto arr$*empty-vector*) ] )
     657    ; Fixup
     658    (when (not proto)
     659      (set! proto arr$*empty-vector*) )
    653660    ; Build array
    654661    (let* ([elmcnt (length elms)]
     
    761768    (when (pair? rest)
    762769      (let ([itm (car rest)])
    763         (if (arr$ako-array? itm)
    764             (begin
    765               (set! proto itm)
    766               (set! lst (cadr rest)) )
    767             (set! lst itm) ) ) )
     770        (cond [(not itm)
     771               #;(set! proto arr$*empty-vector*)
     772               (set! lst (cadr rest)) ]
     773              [(arr$ako-array? itm)
     774               (set! proto itm)
     775               (set! lst (cadr rest)) ]
     776              [else
     777               (set! lst itm) ] ) ) )
    768778    ; Make an array from the list
    769779    (if (and (null? lst) (null? dims))
    770       ; then special case of empty array
    771       (arr$new-empty-array proto '() 'list->array)
    772       ; else have elements
    773       (let ([rank->dimensions
    774               (lambda (rnk)
    775                 (let loop ([dims '()] [rnk (- rnk 1)] [row lst])
    776                   (if (< rnk 0)
    777                     (reverse dims)
    778                     (loop (cons (length row) dims) (- rnk 1) (car row)))))])
    779         (let ([shp
    780                 (arr$dimensionality->shape-list
    781                   (if (arr$rank? dims) (rank->dimensions dims) dims)
    782                   'list->array)])
    783           ; Handle special cases
    784                 ; rank-0
    785           (cond [(null? shp)
    786                   (array proto 0 lst)]
    787                 ; 1-dim & 0-origin
    788                 [(and (null? (cdr shp)) (= 0 (caar shp)))
    789                   ((arr$storedef-from-list (arr$storedef proto)) lst)]
    790                 ; Has non-degenerate shape
    791                 [else
    792                   (let ([arr (arr$new-array proto shp 'list->array)])
    793                     (let loop ([shp shp] [idxs '()] [row lst])
    794                       (if (null? shp)
    795                           (arr$unchecked-set! arr row (arr$reverse-index-list idxs)
    796                             'list->array)
    797                           (let ([bnd (car shp)])
    798                             (unless (= (arr$bounds-length bnd) (length row))
    799                               (arr$error 'list->array "non-rectangular array" shp))
    800                             (let ([h (cdr bnd)])
    801                               (do ([idx (car bnd) (+ 1 idx)]
    802                                    [rest row (cdr rest)])
    803                                   [(> idx h)]
    804                                 (loop (cdr shp) (cons idx idxs) (car rest)))))))
    805                     ; Return constructed array
    806                     arr)] ) ) ) ) ) )
     780        ; then special case of empty array
     781        (arr$new-empty-array proto '() 'list->array)
     782        ; else have elements
     783        (let ([rank->dimensions
     784                (lambda (rnk)
     785                  (let loop ([dims '()] [rnk (- rnk 1)] [row lst])
     786                    (if (< rnk 0)
     787                        (reverse dims)
     788                        (loop (cons (length row) dims) (- rnk 1) (car row)) ) ) ) ] )
     789          (let ([shp
     790                  (arr$dimensionality->shape-list
     791                   (if (arr$rank? dims) (rank->dimensions dims) dims)
     792                   'list->array) ] )
     793            ; Handle special cases
     794                  ; rank-0
     795            (cond [(null? shp)
     796                    (array proto 0 lst)]
     797                  ; 1-dim & 0-origin
     798                  [(and (null? (cdr shp)) (= 0 (caar shp)))
     799                    ((arr$storedef-from-list (arr$storedef proto)) lst)]
     800                  ; Has non-degenerate shape
     801                  [else
     802                    (let ([arr (arr$new-array proto shp 'list->array)])
     803                      (let loop ([shp shp] [idxs '()] [row lst])
     804                        (if (null? shp)
     805                            (arr$unchecked-set! arr row (arr$reverse-index-list idxs)
     806                             'list->array)
     807                            (let ([bnd (car shp)])
     808                              (unless (= (arr$bounds-length bnd) (length row))
     809                                (arr$error 'list->array
     810                                           "non-rectangular array" shp (length row)))
     811                              (let ([h (cdr bnd)])
     812                                (do ([idx (car bnd) (+ 1 idx)]
     813                                     [rest row (cdr rest)])
     814                                    [(> idx h)]
     815                                  (loop (cdr shp) (cons idx idxs) (car rest)) ) ) ) ) )
     816                      ; Return constructed array
     817                      arr ) ] ) ) ) ) ) )
    807818
    808819;;@args array
     
    844855        ((arr$storedef-to-list storedef) arr) ) ) )
    845856
     857;;@args rank type width list
     858;;
     859;;@4 must be a rank-nested list consisting of all the elements, in
     860;;row-major order, of the array to be created.
     861;;
     862;;@0 returns an array of rank @1 consisting of all the
     863;;elements, in row-major order, of @4. When @1 is 0, @4 is the lone
     864;;array element; not necessarily a list.
     865;;
     866;;@2 is the symbol (floc, flor, floq, fixz, fixn, char, bool) or #f.
     867;;
     868;;@3 is a positive integer (128, 64, 32, 16, 8) or #f.
     869;;
     870;;The array prototype is determined from @2 & @3.
     871;;
     872;;The rank @1 may also be a list of dimensions or an array-shape.
     873
     874(define (list->uniform-array dims typ wid lyst)
     875  (let ([proto-proc
     876          (case typ
     877            [(floc)
     878             (case wid
     879               [(128) A:floC128b]
     880               [(64)  A:floC64b]
     881               [(32)  A:floC32b]
     882               [(16)  A:floC16b]
     883               [else  #f ] ) ]
     884            [(flor)
     885             (case wid
     886               [(128) A:floR128b]
     887               [(64)  A:floR64b]
     888               [(32)  A:floR32b]
     889               [(16)  A:floR16b]
     890               [else  #f ] ) ]
     891            [(floq)
     892             (case wid
     893               [(128) A:floQ128d]
     894               [(64)  A:floQ64d]
     895               [(32)  A:floQ32d]
     896               [else  #f ] ) ]
     897            [(fixz)
     898             (case wid
     899               [(64)  A:fixZ64b]
     900               [(32)  A:fixZ32b]
     901               [(16)  A:fixZ16b]
     902               [(8)   A:fixZ8b]
     903               [else  #f ] ) ]
     904            [(fixn)
     905             (case wid
     906               [(64)  A:fixN64b]
     907               [(32)  A:fixN32b]
     908               [(16)  A:fixN16b]
     909               [(8)   A:fixN8b]
     910               [else  #f ] ) ]
     911            [(char)
     912             string ]
     913            [(bool)
     914             A:bool ]
     915            [else
     916             #f ] ) ] )
     917    (list->array dims (and proto-proc (proto-proc)) lyst) ) )
     918
    846919;;@args vect prototype dim1 @dots{}
    847920;;@1 must be a vector of length equal to the product of exact
     
    865938    (when (pair? rest)
    866939      (let ([itm (car rest)])
    867         (when (arr$ako-array? itm)
    868           (set! proto itm)
    869           (set! dims (cdr rest)) ) ) )
     940        (cond [(not itm)
     941               #;(set! proto arr$*empty-vector*)
     942               (set! dims (cdr rest)) ]
     943              [(arr$ako-array? itm)
     944               (set! proto itm)
     945               (set! dims (cdr rest)) ] ) ) )
    870946    ; Make an array from the vector
    871947    (let ([vdx (vector-length vec)])
     
    10471123              (let ([rnk (length shp)])
    10481124                (display "#" out) (write rnk out) (display #\A out)
    1049                 (when (= 0 rnk) (display #\space out))
     1125                (when (= 0 rnk)
     1126                  (display #\space out))
    10501127                (array-print arr (current-array-print-count) out shp) ) ] ) )
    10511128        ; else not printing array info
     
    10631140    (arr$array-length arr)) )
    10641141
    1065 ;; Srfi-10 reader
     1142;; SRFI-10 reader
    10661143
    10671144(define-reader-ctor 'array
     
    10691146    (list->array shp (arr$storedef-prototype (arr$storedef-for-kind knd)) elms)))
    10701147
    1071 ;; #<rank>A<value> reader
    1072 
    1073 (set-parameterized-read-syntax! #\A
    1074   (lambda (port rnk)
    1075     (let ([obj (read port)])
    1076       (list->array rnk arr$*empty-vector* obj))))
    1077 
    1078 ;; #A<rank><value> reader
    1079 
    1080 (set-sharp-read-syntax! #\A
    1081   (lambda (port)
    1082     (let* ([rnk (read port)]
    1083            [obj (read port)])
    1084       (list->array rnk arr$*empty-vector* obj))))
     1148;; #A readers support
     1149;; From SRFI-58 reference implementation
     1150
     1151(define read:try-number
     1152  (let ([chr0 (char->integer #\0)])
     1153    (lambda (port . ic)
     1154      (let loop ([arg (and (not (null? ic))
     1155                           (- (char->integer (car ic)) chr0))])
     1156        (let ([c (peek-char port)])
     1157          (cond [(eof-object? c)
     1158                 #f ]
     1159                [(char-numeric? c)
     1160                 (loop (+ (* 10 (or arg 0))
     1161                          (- (char->integer (read-char port)) chr0))) ]
     1162                [else
     1163                 arg ] ) ) ) ) ) )
     1164
     1165(define read:array-type
     1166  (let ([array-type-specifier-error
     1167          (lambda (typ wid chr)
     1168            (arr$error/type/array '|#A|
     1169                                  "type specifier"
     1170                                  (conc ":" (or typ "") (or wid "") (or chr ""))) ) ]
     1171        [proto-temps
     1172          '((floc 128 64 32 16)
     1173            (flor 128 64 32 16)
     1174            (floq 128 64 32)
     1175            (fixz 64 32 16 8)
     1176            (fixn 64 32 16 8)
     1177            (char)
     1178            (bool)) ] )
     1179    (lambda (port)
     1180      (case (peek-char port)
     1181        [(#\:)
     1182         (read-char port)
     1183         (let* ([typ (let loop ([arg '()])
     1184                       (if (= 4 (length arg))
     1185                           (string->symbol (list->string (reverse! arg)))
     1186                           (let ([c (read-char port)])
     1187                             (and (not (eof-object? c))
     1188                                  (loop (cons (char-downcase c) arg)) ) ) ) ) ]
     1189                [wid (and typ
     1190                          (read:try-number port)) ] )
     1191           (let* ([proto (assq typ proto-temps) ]
     1192                  [wids (and proto
     1193                             (cdr proto)) ] )
     1194             (cond [(pair? wids)
     1195                    (when wid
     1196                      (let ([chr (read-char port)])
     1197                        (when (or (not (memv wid wids))
     1198                                  (and (char? chr)
     1199                                       (not (memv (char-downcase chr) '(#\b #\d)))))
     1200                          (array-type-specifier-error typ wid chr) ) ) ) ]
     1201                   [(and typ (not proto))
     1202                    (array-type-specifier-error typ wid #f) ] )
     1203             (values typ wid) )  ) ]
     1204        [else
     1205         (values #f #f) ] ) ) ) )
     1206
     1207(define (read:array rnk dims port)
     1208  (let loop ([dims dims])
     1209    (let ([dim (read:try-number port)])
     1210      (if dim
     1211          (loop (cons dim dims))
     1212          (if (char=? #\* (peek-char port))
     1213              (begin
     1214                (read-char port)
     1215                (loop dims) )
     1216              (let ([dims (reverse! dims)])
     1217                (let-values ([(typ wid) (read:array-type port)])
     1218                  (list->uniform-array
     1219                   (cond [(not rnk)              dims]
     1220                         [(null? dims)           rnk]
     1221                         [(= rnk (length dims))  dims]
     1222                         [else
     1223                          (arr$error/type/dimensionality '|#A| rnk dims) ] )
     1224                   typ wid
     1225                   (read port)) ) ) ) ) ) ) )
     1226
     1227;; #<rank>A... reader
     1228
     1229(define (param-sharp-a-reader port rnk)
     1230  (read:array rnk '() port) )
     1231
     1232(set-parameterized-read-syntax! #\a param-sharp-a-reader)
     1233
     1234(set-parameterized-read-syntax! #\A param-sharp-a-reader)
     1235
     1236;; #A... reader
     1237
     1238(define (sharp-a-reader port)
     1239  (read:array #f '() port ) )
     1240
     1241(set-sharp-read-syntax! #\a sharp-a-reader)
     1242
     1243(set-sharp-read-syntax! #\A sharp-a-reader)
  • release/3/array-lib/trunk/tests/array-lib-test.scm

    r6513 r9531  
    194194  )
    195195
    196   #;
    197196  (test/case "O Dimension" (
    198197      [arr1 (make-array '#(#f) 2 1 3)]
     
    316315;;
    317316
     317(define-test array-srfi-58-test "SRFI 58"
     318  (expect-true (array? '#2A:fixN16b((0 1 2) (3 5 4))))
     319  (expect-true (array? '#2A2*3:fixN16b((0 1 2) (3 5 4))))
     320  (expect-true (array? '#A2*3:fixN16b((0 1 2) (3 5 4))))
     321  (expect-true (array? '#0a sym))
     322  (expect-true (array? '#0A:floR32b 237.0))
     323  (expect-true (array? '#A0*2()))
     324  (expect-true (array? '#A2*0(() ())))
     325  (expect-true (array? '#A2*0*3(() ())))
     326  (expect-true (array? '#A2*3*0((() () ()) (() () ()))))
     327)
     328
     329;;
     330
    318331(define-test array-examples-test "Examples"
    319332  (initial
Note: See TracChangeset for help on using the changeset viewer.