1#lang racket/base
2(require racket/fixnum
3         racket/flonum
4         "config.rkt"
5         "special.rkt"
6         "sequence.rkt"
7         "wrap.rkt"
8         "error.rkt"
9         "consume.rkt"
10         "digit.rkt"
11         "parameter.rkt"
12         "accum-string.rkt"
13         "fixnum-flonum.rkt")
14
15(provide read-vector
16         read-fixnum-or-flonum-vector)
17
18(define (read-vector read-one opener-c opener closer in config
19                     #:mode [vector-mode 'any]
20                     #:length [expected-len #f])
21  (define read-one-element
22    (case vector-mode
23      [(any) read-one]
24      [(fixnum) (lambda (init-c in config) (read-fixnum read-one init-c in config))]
25      [(flonum) (lambda (init-c in config) (read-flonum read-one init-c in config))]))
26
27  (define seq (read-unwrapped-sequence read-one-element
28                                       opener-c opener closer in config
29                                       #:whitespace-read-one read-one
30                                       #:dot-mode #f))
31
32  ;; Extend `seq` as needed to match the declared length
33  (define vec
34    (cond
35     [(not expected-len)
36      (case vector-mode
37        [(any) (list->vector seq)]
38        [(fixnum) (for/fxvector #:length (length seq) ([e (in-list seq)]) e)]
39        [(flonum) (for/flvector #:length (length seq) ([e (in-list seq)]) e)])]
40     [else
41      (define len (length seq))
42      (cond
43       [(= expected-len len) (list->vector seq)]
44       [(expected-len . < . len)
45        (reader-error in config
46                      "~avector length ~a is too small, ~a values provided"
47                      (case vector-mode
48                        [(any) ""]
49                        [(fixnum) "fx"]
50                        [(flonum) "fl"])
51                      expected-len len)]
52       [else
53        (define (last-or v)
54          (if (null? seq)
55              (wrap v in config #f)
56              (let loop ([seq seq])
57                (if (null? (cdr seq)) (car seq) (loop (cdr seq))))))
58        (when ((integer-length expected-len) . >= . 48)
59          ;; implausibly large
60          (raise (exn:fail:out-of-memory "out of memory" (current-continuation-marks))))
61        (define vec
62          (case vector-mode
63            [(any) (make-vector expected-len (last-or 0))]
64            [(fixnum) (make-fxvector expected-len (last-or 0))]
65            [(flonum) (make-flvector expected-len (last-or 0.0))]))
66        (case vector-mode
67          [(any) (for ([e (in-list seq)]
68                       [i (in-naturals)])
69                   (vector-set! vec i e))]
70          [(fixnum) (for ([e (in-list seq)]
71                          [i (in-naturals)])
72                      (fxvector-set! vec i e))]
73          [(flonum) (for ([e (in-list seq)]
74                          [i (in-naturals)])
75                      (flvector-set! vec i e))])
76        vec])]))
77
78  (wrap (if (read-config-for-syntax? config)
79            (vector->immutable-vector vec)
80            vec)
81        in
82        config
83        opener))
84
85;; ----------------------------------------
86
87(define (read-fixnum-or-flonum-vector read-one dispatch-c c c2 in config)
88  (define vector-mode (if (char=? c2 #\x) 'fixnum 'flonum))
89  (consume-char in c2)
90  (when (read-config-for-syntax? config)
91    (reader-error in config "literal f~avectors not allowed" c2))
92
93  (define c3 (read-char/special in config))
94  (define-values (vector-len len-str c4)
95    (cond
96     [(decimal-digit? c3) (read-simple-number in config c3)]
97     [else (values #f "" c3)]))
98
99  (define-syntax-rule (guard-legal e c body ...)
100    (cond
101     [e body ...]
102     [else (bad-syntax-error in config (format "~a~a" dispatch-c c))]))
103
104  (case c4
105    [(#\()
106     (read-vector read-one #\( #\( #\) in config #:mode vector-mode #:length vector-len)]
107    [(#\[)
108     (guard-legal
109      (check-parameter read-square-bracket-as-paren config)
110      (format "~a~a" c c2)
111      (read-vector read-one #\[ #\[ #\] in config #:mode vector-mode #:length vector-len))]
112    [(#\{)
113     (guard-legal
114      (check-parameter read-curly-brace-as-paren config)
115      (format "~a~a" c c2)
116      (read-vector read-one #\{ #\{ #\} in config #:mode vector-mode #:length vector-len))]
117    [else
118     (reader-error in config #:due-to c4
119                   "expected `(`, `[`, or `{` after `#~a~a~a`"
120                   c c2 len-str)]))
121
122
123(define (read-simple-number in config init-c)
124  (define accum-str (accum-string-init! config))
125  (accum-string-add! accum-str init-c)
126  (define init-v (digit->number init-c))
127  (define v (read-digits in config accum-str
128                         #:base 10 #:max-count +inf.0
129                         #:init init-v
130                         #:zero-digits-result init-v))
131  (values v
132          (accum-string-get! accum-str config)
133          ;; We could avoid some peeks vising init-c
134          ;; and having `read-digit` return its peek
135          ;; result, but we don't for now
136          (read-char/special in config)))
137