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