diff --git a/pkgs/racket-doc/scribblings/reference/fixnums.scrbl b/pkgs/racket-doc/scribblings/reference/fixnums.scrbl index 0028ce1332..f63da787de 100644 --- a/pkgs/racket-doc/scribblings/reference/fixnums.scrbl +++ b/pkgs/racket-doc/scribblings/reference/fixnums.scrbl @@ -104,6 +104,10 @@ Two @tech{fxvectors} are @racket[equal?] if they have the same length, and if the values in corresponding slots of the @tech{fxvectors} are @racket[equal?]. +A printed @tech{fxvector} starts with @litchar{#fx(}, optionally with +a number between the @litchar{#fx} and +@litchar{(}. @see-read-print["vector" #:print "vectors"]{fxvectors} + @defproc[(fxvector? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is a @tech{fxvector}, @racket[#f] otherwise.} diff --git a/pkgs/racket-doc/scribblings/reference/flonums.scrbl b/pkgs/racket-doc/scribblings/reference/flonums.scrbl index d4fc72b233..377d66455f 100644 --- a/pkgs/racket-doc/scribblings/reference/flonums.scrbl +++ b/pkgs/racket-doc/scribblings/reference/flonums.scrbl @@ -163,6 +163,10 @@ Two @tech{flvectors} are @racket[equal?] if they have the same length, and if the values in corresponding slots of the @tech{flvectors} are @racket[equal?]. +A printed @tech{flvector} starts with @litchar{#fl(}, optionally with +a number between the @litchar{#fl} and +@litchar{(}. @see-read-print["vector" #:print "vectors"]{flvectors} + @defproc[(flvector? [v any/c]) boolean?]{ Returns @racket[#t] if @racket[v] is a @tech{flvector}, @racket[#f] otherwise.} diff --git a/pkgs/racket-doc/scribblings/reference/printer.scrbl b/pkgs/racket-doc/scribblings/reference/printer.scrbl index 3c63fc7041..4d479715a4 100644 --- a/pkgs/racket-doc/scribblings/reference/printer.scrbl +++ b/pkgs/racket-doc/scribblings/reference/printer.scrbl @@ -288,7 +288,7 @@ all @tech{quotable}, then the vector @racket[print]s as and a closing @litchar{)}. A vector is @tech{quotable} when all of its elements are @tech{quotable}. -In @racket[write] or @racket[display] mode, an @tech{flvector} prints +In @racket[write] or @racket[display] mode, a @tech{flvector} prints like a @tech{vector}, but with a @litchar{#fl} prefix instead of @litchar{#}. A @tech{fxvector} similarly prints with a @litchar{#fx} prefix instead of @litchar{#}. The @racket[print-vector-length] diff --git a/pkgs/racket-doc/scribblings/reference/reader.scrbl b/pkgs/racket-doc/scribblings/reference/reader.scrbl index f01f408323..84ff9248cb 100644 --- a/pkgs/racket-doc/scribblings/reference/reader.scrbl +++ b/pkgs/racket-doc/scribblings/reference/reader.scrbl @@ -631,7 +631,7 @@ The elements of the vector are recursively read until a matching lists (see @secref["parse-pair"]). A delimited @litchar{.} is not allowed among the vector elements. In the case of @tech{flvectors}, the recursive read for element is implicitly prefixed with @litchar{#i} -and must produce a @tech{flonum}. In the case of @tech{flvectors}, +and must produce a @tech{flonum}. In the case of @tech{fxvectors}, the recursive read for element is implicitly prefixed with @litchar{#e} and must produce a @tech{fixnum}. diff --git a/pkgs/racket-doc/scribblings/reference/readtables.scrbl b/pkgs/racket-doc/scribblings/reference/readtables.scrbl index 9c7ba4ee26..2f32fc32ae 100644 --- a/pkgs/racket-doc/scribblings/reference/readtables.scrbl +++ b/pkgs/racket-doc/scribblings/reference/readtables.scrbl @@ -67,7 +67,7 @@ otherwise. } -@defproc[(make-readtable [readtable readtable?] +@defproc[(make-readtable [readtable (or/c readtable? #f)] [key (or/c char? #f)] [mode (or/c (or/c 'terminating-macro 'non-terminating-macro diff --git a/pkgs/racket-test-core/tests/racket/read.rktl b/pkgs/racket-test-core/tests/racket/read.rktl index 8348d7783e..c974f2a63f 100644 --- a/pkgs/racket-test-core/tests/racket/read.rktl +++ b/pkgs/racket-test-core/tests/racket/read.rktl @@ -2,7 +2,7 @@ (load-relative "loadtest.rktl") (Section 'reading) -(define readstr +(define core-readstr (lambda (s) (let* ([o (open-input-string s)] [read (lambda () (read o))]) @@ -12,6 +12,37 @@ last (loop v))))))) +(define (readstr s) + (if (current-readtable) + (core-readstr s) + ;; Try using a readtable that behaves the same as the default, + ;; since that triggers some different paths in the reader: + (let* ([normal (with-handlers ([exn:fail? values]) + (core-readstr s))] + [c-normal (adjust-result-to-compare normal)] + [rt (adjust-result-to-compare + (with-handlers ([exn:fail? values]) + (parameterize ([current-readtable (make-readtable (current-readtable))]) + (core-readstr s))))]) + (if (equal? c-normal rt) + (if (exn? normal) + (raise normal) + normal) + (list "different with readtable" s c-normal rt))))) + +(define (adjust-result-to-compare v) + ;; Make results from two readstrs comparable + (cond + [(hash? v) + (for/fold ([ht (hash)]) ([(k hv) (in-hash v)]) + (hash-update ht + (if (eq? k v) 'SELF k) + (lambda (vht) + (hash-set vht hv #t)) + (hash)))] + [(exn? v) (exn-message v)] + [else v])) + (define readerrtype (lambda (x) x)) @@ -54,6 +85,9 @@ (err/rt-test (readstr "(8 . 9 . ]") exn:fail:read?) (err/rt-test (readstr "(8 . 9 . 1 . )") exn:fail:read?) (err/rt-test (readstr "(8 . 9 . 1 . 10)") exn:fail:read?) +(err/rt-test (readstr "(8 . 9 . #;1)") exn:fail:read?) +(err/rt-test (readstr "(8 . 9 . ;\n)") exn:fail:read?) +(err/rt-test (readstr "(8 . 9 . #|x|#)") exn:fail:read?) (let ([w-suffix (lambda (s) @@ -857,7 +891,31 @@ (err/rt-test (read (make-p (list #"|x" a-special #"y|") (lambda (x) 1) void)) exn:fail:read:non-char?)) (run-delim-special a-special) (run-delim-special special-comment) +(parameterize ([current-readtable (make-readtable #f)]) + (run-delim-special special-comment)) +(require racket/flonum + racket/fixnum) + +(define (run-comment-special) + (test (list 5) read (make-p (list #"(" special-comment #"5)") (lambda (x) 1) void)) + (test (list 5) read (make-p (list #"(5" special-comment #")") (lambda (x) 1) void)) + (test (cons 1 5) read (make-p (list #"(1 . " special-comment #"5)") (lambda (x) 1) void)) + (test (cons 1 5) read (make-p (list #"(1 . 5" special-comment #")") (lambda (x) 1) void)) + (err/rt-test (read (make-p (list #"(1 . " special-comment #")") (lambda (x) 1) void)) exn:fail:read?) + (test (list 2 1 5) read (make-p (list #"(1 . 2 . " special-comment #"5)") (lambda (x) 1) void)) + (test (list 2 1 a-special 5) read (make-p (list #"(1 . 2 ." a-special #"5)") (lambda (x) 1) void)) + (test (list 2 1 5) read (make-p (list #"(1 . " special-comment #"2 . 5)") (lambda (x) 1) void)) + (test (list 2 1 5) read (make-p (list #"(1 . 2 " special-comment #" . 5)") (lambda (x) 1) void)) + (test (vector 1 2 5) read (make-p (list #"#(1 2 " special-comment #"5)") (lambda (x) 1) void)) + (test (flvector 1.0) read (make-p (list #"#fl(1.0 " special-comment #")") (lambda (x) 1) void)) + (test (fxvector 1) read (make-p (list #"#fx(1 " special-comment #")") (lambda (x) 1) void)) + (err/rt-test (read (make-p (list #"#fl(1.0 " a-special #")") (lambda (x) 1) void)) exn:fail:read?) + (err/rt-test (read (make-p (list #"#fx(1 " a-special #")") (lambda (x) 1) void)) exn:fail:read?)) +(run-comment-special) +(parameterize ([current-readtable (make-readtable #f)]) + (run-comment-special)) + ;; Test read-char-or-special: (let ([p (make-p (list #"x" a-special #"y") (lambda (x) 5) void)]) (test #\x peek-char-or-special p) @@ -1134,6 +1192,9 @@ (test #t equal? (fxvector 1000 76 100000 100000 100000 100000 100000 100000 100000 100000) (readstr "#fx10(1000 76 100000)")) (test #t equal? (flvector 0.0 0.0 0.0) (readstr "#fl3()")) (test #t equal? (flvector 2.0 1.0 1.0) (readstr "#fl3(2 1)")) +(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 #;5 1)")) +(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 #|5|# 1)")) +(test #t equal? (flvector 2.0 1.0) (readstr "#fl(2 ;5\n 1)")) (test #t equal? (fxvector 0 0 0) (readstr "#fx3()")) (test #t equal? (fxvector 2 1 1) (readstr "#fx3(2 1)")) @@ -1151,6 +1212,11 @@ (err/rt-test (read-syntax 'x (open-input-string "#fx()")) exn:fail:read?) (err/rt-test (read-syntax 'x (open-input-string "#fl()")) exn:fail:read?) +(parameterize ([current-readtable (make-readtable + #f + #f 'non-terminating-macro (lambda args 3.0))]) + (test #t equal? (flvector 3.0) (readstr "#fl(3)"))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require racket/extflonum) diff --git a/racket/src/racket/src/hash.c b/racket/src/racket/src/hash.c index b7fd3672aa..ab9d0fd289 100644 --- a/racket/src/racket/src/hash.c +++ b/racket/src/racket/src/hash.c @@ -1331,7 +1331,12 @@ static uintptr_t equal_hash_key(Scheme_Object *o, uintptr_t k, Hash_Info *hi) t = SCHEME_TYPE(o); if (t == scheme_hash_tree_indirection_type) { - o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + if (SAME_OBJ(o, orig_obj)) { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + orig_obj = o; + } else { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + } t = SCHEME_TYPE(o); } @@ -2064,10 +2069,16 @@ static uintptr_t equal_hash_key2(Scheme_Object *o, Hash_Info *hi) return k; } - case scheme_hash_tree_type: + case scheme_hash_tree_indirection_type: + if (!SAME_OBJ(o, orig_obj)) { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + } else { + o = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)o); + orig_obj = o; + } + case scheme_hash_tree_type: /* ^^^ fallthrough ^^^ */ case scheme_eq_hash_tree_type: case scheme_eqv_hash_tree_type: - case scheme_hash_tree_indirection_type: { Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o; Scheme_Object *iv, *ik; diff --git a/racket/src/racket/src/read.c b/racket/src/racket/src/read.c index f9126e2fca..2de0929d48 100644 --- a/racket/src/racket/src/read.c +++ b/racket/src/racket/src/read.c @@ -311,7 +311,8 @@ static int next_is_delim(Scheme_Object *port, static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, Scheme_Object *indentation, - ReadParams *params, Readtable *table); + ReadParams *params, Readtable *table, + Scheme_Object **prefetched); static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, ReadParams *params, Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, @@ -448,6 +449,7 @@ void scheme_init_read(Scheme_Env *env) } builtin_fast[';'] = READTABLE_TERMINATING; builtin_fast['\''] = READTABLE_TERMINATING; + builtin_fast['`'] = READTABLE_TERMINATING; builtin_fast[','] = READTABLE_TERMINATING; builtin_fast['"'] = READTABLE_TERMINATING; builtin_fast['|'] = READTABLE_MULTIPLE_ESCAPE; @@ -874,14 +876,17 @@ static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mz } if (!(*overflow)) { - intptr_t old_len; + uintptr_t old_len; + uintptr_t new_len; if (*vector_length < 0) *vector_length = 0; old_len = *vector_length; - *vector_length = ((*vector_length) * 10) + ((*ch) - 48); - if ((*vector_length < 0)|| ((*vector_length / 10) != old_len)) { + new_len = *vector_length; + new_len = ((new_len) * 10) + ((*ch) - 48); + *vector_length = new_len; + if ((*vector_length < 0) || ((new_len / 10) != old_len)) { *overflow = 1; } } @@ -894,6 +899,11 @@ static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mz vecbuf[j] = 0; tagbuf[i] = 0; + if (!j) { + vecbuf[j] = '0'; + vecbuf[0] = 0; + } + return readtable_effective_char(table, (*ch)); } @@ -1847,7 +1857,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * if (!ph) { scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: no #%ld= preceding #%ld#", + "read: no #%d= preceding #%d#", vector_length, vector_length); return scheme_void; } @@ -1874,7 +1884,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * if (*ht) { if (scheme_hash_get(*ht, scheme_make_integer(vector_length))) { scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: multiple #%ld= tags", + "read: multiple #%d= tags", vector_length); return NULL; } @@ -2662,7 +2672,7 @@ read_list(Scheme_Object *port, else if (got_ch_already) got_ch_already = 0; else - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); + ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL); if ((ch == EOF) && (closer != EOF)) { char *suggestion = ""; @@ -2754,9 +2764,11 @@ read_list(Scheme_Object *port, switch (shape) { case mz_shape_fl_vec: car = read_flonum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); + MZ_ASSERT(SCHEME_DBLP(car)); break; case mz_shape_fx_vec: car = read_fixnum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); + MZ_ASSERT(SCHEME_INTP(car)); break; default: car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); @@ -2770,7 +2782,7 @@ read_list(Scheme_Object *port, retry_before_dot: - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); + ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, NULL); effective_ch = readtable_effective_char(table, ch); if (effective_ch == closer) { if (shape == mz_shape_hash_elem) { @@ -2819,7 +2831,7 @@ read_list(Scheme_Object *port, /* can't be eof, due to check above: */ cdr = read_inner(port, stxsrc, ht, indentation, params, 0); - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); + ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched); effective_ch = readtable_effective_char(table, ch); if ((effective_ch != closer) || (shape == mz_shape_vec_plus_infix)) { if (params->can_read_infix_dot @@ -2848,14 +2860,15 @@ read_list(Scheme_Object *port, last = pair; /* Make sure there's not a closing paren immediately after the dot: */ - ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table); + ch = skip_whitespace_comments(port, stxsrc, ht, indentation, params, table, &prefetched); effective_ch = readtable_effective_char(table, ch); if ((effective_ch == closer) || (ch == EOF)) { scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, "read: illegal use of `%c'", ch); return NULL; } - got_ch_already = 1; + if (!prefetched) + got_ch_already = 1; } else { scheme_read_err(port, stxsrc, dotline, dotcol, dotpos, 1, (ch == EOF) ? EOF : 0, indentation, "read: illegal use of `%c'", @@ -2880,14 +2893,25 @@ read_list(Scheme_Object *port, return list; } } else { - if ((ch == SCHEME_SPECIAL) - || (table && (ch != EOF) && (shape != mz_shape_hash_list))) { + if ((ch == SCHEME_SPECIAL) + || (table + && (ch != EOF) + && (shape != mz_shape_hash_list) + && (shape != mz_shape_fl_vec) + && (shape != mz_shape_fx_vec))) { /* We have to try the read, because it might be a comment. */ scheme_ungetc(ch, port); prefetched = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); if (!prefetched) goto retry_before_dot; + if ((shape == mz_shape_fl_vec) && !SCHEME_DBLP(prefetched)) { + scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, + "read: stream produced a non-flonum for flvector"); + } else if ((shape == mz_shape_fx_vec) && !SCHEME_INTP(prefetched)) { + scheme_read_err(port, stxsrc, startline, startcol, start, SPAN(port, start), ch, indentation, + "read: stream produced a non-fixnum for fxvector"); + } } else { got_ch_already = 1; } @@ -4111,9 +4135,12 @@ Scheme_Object *scheme_read_intern(Scheme_Object *o) static int skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, Scheme_Object *indentation, - ReadParams *params, Readtable *table) + ReadParams *params, Readtable *table, + Scheme_Object **_prefetched) +/* If `_prefetched` is non_NULL, then a SCHEME_SPECIAL result means that + the special value has already been read, and it wasn't a comment. */ { - int ch; + int ch, effective_ch; int blockc_1, blockc_2; blockc_1 = '#'; @@ -4126,21 +4153,23 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, if (!(readtable_kind(table, ch, params) & READTABLE_WHITESPACE)) break; } - return ch; } else { while ((ch = scheme_getc_special_ok(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {} } - if (ch == ';') { + effective_ch = readtable_effective_char(table, ch); + if (effective_ch == ';') { do { ch = scheme_getc_special_ok(port); - if (ch == SCHEME_SPECIAL) + effective_ch = readtable_effective_char(table, ch); + if (effective_ch == SCHEME_SPECIAL) scheme_get_ready_read_special(port, stxsrc, ht); - } while (!is_line_comment_end(ch) && ch != EOF); + } while (!is_line_comment_end(effective_ch) && (effective_ch != EOF)); goto start_over; } - if (ch == blockc_1 && (scheme_peekc_special_ok(port) == blockc_2)) { + if ((effective_ch == blockc_1) + && (readtable_effective_char(table, scheme_peekc_special_ok(port)) == blockc_2)) { int depth = 0; int ch2 = 0; intptr_t col, pos, line; @@ -4150,27 +4179,29 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, (void)scheme_getc(port); /* re-read '|' */ do { ch = scheme_getc_special_ok(port); - - if (ch == EOF) + effective_ch = readtable_effective_char(table, ch); + + if (effective_ch == EOF) scheme_read_err(port, stxsrc, line, col, pos, MINSPAN(port, pos, 2), EOF, indentation, "read: end of file in #| comment"); - else if (ch == SCHEME_SPECIAL) + else if (effective_ch == SCHEME_SPECIAL) scheme_get_ready_read_special(port, stxsrc, ht); - if ((ch2 == blockc_2) && (ch == blockc_1)) { + if ((ch2 == blockc_2) && (effective_ch == blockc_1)) { if (!(depth--)) goto start_over; - ch = 0; /* So we don't count '#' toward an opening "#|" */ + effective_ch = 0; /* So we don't count '#' toward an opening "#|" */ } else if ((ch2 == blockc_1) && (ch == blockc_2)) { depth++; - ch = 0; /* So we don't count '|' toward a closing "|#" */ + effective_ch = 0; /* So we don't count '|' toward a closing "|#" */ } - ch2 = ch; + ch2 = effective_ch; } while (1); goto start_over; } - if (ch == '#' && (scheme_peekc_special_ok(port) == ';')) { + if ((effective_ch == '#') + && (readtable_effective_char(table, scheme_peekc_special_ok(port)) == ';')) { Scheme_Object *skipped; intptr_t col, pos, line; @@ -4198,6 +4229,20 @@ skip_whitespace_comments(Scheme_Object *port, Scheme_Object *stxsrc, goto start_over; } + if ((ch == SCHEME_SPECIAL) && _prefetched) { + Scheme_Object *v; + intptr_t col, pos, line; + + scheme_tell_all(port, &line, &col, &pos); + v = scheme_get_special(port, stxsrc, line, col, pos, 0, ht); + if (!scheme_special_comment_value(v)) { + *_prefetched = v; + return SCHEME_SPECIAL; + } + + goto start_over; + } + return ch; } @@ -6303,7 +6348,7 @@ static void check_proc_either_arity(const char *who, int a1, int a2, int which, { if (!scheme_check_proc_arity(NULL, a1, which, argc, argv) && !scheme_check_proc_arity(NULL, a2, which, argc, argv)) { - char buffer[60]; + char buffer[256]; sprintf(buffer, "(or (procedure-arity-includes/c %d) (procedure-arity-includes/c %d))", a1, a2); scheme_wrong_contract(who, buffer, which, argc, argv); }