From 492167c23f0bac167da24ef1d66fa0f1f9657767 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Thu, 29 Nov 2012 05:27:19 -0700 Subject: [PATCH] read and write support for fxvectors and flvectors --- collects/racket/pretty.rkt | 125 +++++- collects/scribblings/reference/reader.scrbl | 35 +- collects/tests/racket/print.rktl | 7 + collects/tests/racket/read.rktl | 19 + src/racket/src/Makefile.in | 6 +- src/racket/src/numstr.c | 26 +- src/racket/src/print.c | 168 ++++--- src/racket/src/print_vector.inc | 69 +++ src/racket/src/read.c | 466 ++++++++++++++------ src/racket/src/read_vector.inc | 94 ++++ src/racket/src/schpriv.h | 1 + 11 files changed, 792 insertions(+), 224 deletions(-) create mode 100644 src/racket/src/print_vector.inc create mode 100644 src/racket/src/read_vector.inc diff --git a/collects/racket/pretty.rkt b/collects/racket/pretty.rkt index 835a00310c..158fe68137 100644 --- a/collects/racket/pretty.rkt +++ b/collects/racket/pretty.rkt @@ -10,7 +10,9 @@ ;; (current-print pretty-print-handler) (module pretty racket/base - (require racket/private/port) + (require racket/private/port + racket/flonum + racket/fixnum) (provide pretty-print pretty-write @@ -429,24 +431,31 @@ (define long-bools? (print-boolean-long-form)) - (define vector->repeatless-list - (if print-vec-length? - (lambda (v) - (let ([len (vector-length v)]) - (if (zero? len) - null - (let ([last (vector-ref v (sub1 len))]) - (let loop ([i (- len 2)]) - (if (i . < . 0) - (list last) - (let ([e (vector-ref v i)]) - (if (eq? e last) - (loop (sub1 i)) - (let loop ([i (sub1 i)][r (list e last)]) - (if (i . < . 0) - r - (loop (sub1 i) (cons (vector-ref v i) r)))))))))))) - vector->list)) + (define-syntax-rule (mkvector->repeatless-list name v-length v-ref equal-op? ->list) + (define name + (if print-vec-length? + (lambda (v) + (let ([len (v-length v)]) + (if (zero? len) + null + (let ([last (v-ref v (sub1 len))]) + (let loop ([i (- len 2)]) + (if (i . < . 0) + (list last) + (let ([e (v-ref v i)]) + (if (equal-op? e last) + (loop (sub1 i)) + (let loop ([i (sub1 i)][r (list e last)]) + (if (i . < . 0) + r + (loop (sub1 i) (cons (v-ref v i) r)))))))))))) + ->list))) + + (mkvector->repeatless-list vector->repeatless-list vector-length vector-ref eq? vector->list) + (mkvector->repeatless-list flvector->repeatless-list flvector-length flvector-ref equal? + (lambda (v) (for/list ([x (in-flvector v)]) x))) + (mkvector->repeatless-list fxvector->repeatless-list fxvector-length fxvector-ref eq? + (lambda (v) (for/list ([x (in-fxvector v)]) x))) (define (extract-sub-objects obj pport) (let ([p (open-output-nowhere 'null (port-writes-special? pport))] @@ -583,6 +592,24 @@ (escapes! obj)) (vloop (or (loop (vector-ref obj i)) esc?) (add1 i)))))] + [(flvector? obj) + (is-compound! obj) + (let ([len (flvector-length obj)]) + (let vloop ([esc? #f][i 0]) + (if (= i len) + (and esc? + (escapes! obj)) + (vloop (or (loop (flvector-ref obj i)) esc?) + (add1 i)))))] + [(fxvector? obj) + (is-compound! obj) + (let ([len (fxvector-length obj)]) + (let vloop ([esc? #f][i 0]) + (if (= i len) + (and esc? + (escapes! obj)) + (vloop (or (loop (fxvector-ref obj i)) esc?) + (add1 i)))))] [(pair? obj) (is-compound! obj) (and (orf (loop (car obj)) @@ -841,6 +868,36 @@ (when print-vec-length? (out (number->string (vector-length obj)))) (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] + [(flvector? obj) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let ([qd (to-quoted out qd obj)] + [vecl (flvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (wr-lst (cons (make-unquoted 'flvector) vecl) + #f depth pair? car cdr "(" ")" qd) + (begin + (out "#fl") + (when print-vec-length? + (out (number->string (flvector-length obj)))) + (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] + [(fxvector? obj) + (check-expr-found + obj pport #t + #f #f + (lambda () + (let ([qd (to-quoted out qd obj)] + [vecl (fxvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (wr-lst (cons (make-unquoted 'fxvector) vecl) + #f depth pair? car cdr "(" ")" qd) + (begin + (out "#fx") + (when print-vec-length? + (out (number->string (fxvector-length obj)))) + (wr-lst vecl #f depth pair? car cdr "(" ")" qd))))))] [(and (box? obj) print-box?) (check-expr-found @@ -976,6 +1033,8 @@ (or (pair? obj) (mpair? obj) (vector? obj) + (flvector? obj) + (fxvector? obj) (and (box? obj) print-box?) (and (custom-write? obj) (not (struct-type? obj))) @@ -1045,6 +1104,34 @@ (pp-list vecl extra pp-expr #f depth pair? car cdr pair-open pair-close qd))))] + [(flvector? obj) + (let ([qd (to-quoted out qd obj)] + [vecl (flvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (pp-pair (cons (make-unquoted 'flvector) vecl) + pair? car cdr pair-open pair-close + qd) + (begin + (out "#fl") + (when print-vec-length? + (out (number->string (flvector-length obj)))) + (pp-list vecl extra pp-expr #f depth + pair? car cdr pair-open pair-close + qd))))] + [(fxvector? obj) + (let ([qd (to-quoted out qd obj)] + [vecl (fxvector->repeatless-list obj)]) + (if (and qd (zero? qd)) + (pp-pair (cons (make-unquoted 'fxvector) vecl) + pair? car cdr pair-open pair-close + qd) + (begin + (out "#fx") + (when print-vec-length? + (out (number->string (fxvector-length obj)))) + (pp-list vecl extra pp-expr #f depth + pair? car cdr pair-open pair-close + qd))))] [(and (custom-write? obj) (not (struct-type? obj))) (let ([qd (let ([kind (if (custom-print-quotable? obj) diff --git a/collects/scribblings/reference/reader.scrbl b/collects/scribblings/reference/reader.scrbl index 46d6a1cd62..94ec594aa8 100644 --- a/collects/scribblings/reference/reader.scrbl +++ b/collects/scribblings/reference/reader.scrbl @@ -113,6 +113,14 @@ on the next character or characters in the input stream as follows: @dispatch[@litchar{#[}]{starts a @tech{vector}; see @secref["parse-vector"]} @dispatch[@litchar["#{"]]{starts a @tech{vector}; see @secref["parse-vector"]} + @dispatch[@litchar{#fx(}]{starts a @tech{fxvector}; see @secref["parse-vector"]} + @dispatch[@litchar{#fx[}]{starts a @tech{fxvector}; see @secref["parse-vector"]} + @dispatch[@litchar["#fx{"]]{starts a @tech{fxvector}; see @secref["parse-vector"]} + + @dispatch[@litchar{#fl(}]{starts a @tech{flvector}; see @secref["parse-vector"]} + @dispatch[@litchar{#fl[}]{starts a @tech{flvector}; see @secref["parse-vector"]} + @dispatch[@litchar["#fl{"]]{starts a @tech{flvector}; see @secref["parse-vector"]} + @dispatch[@litchar{#s(}]{starts a @tech{structure} literal; see @secref["parse-structure"]} @dispatch[@litchar{#s[}]{starts a @tech{structure} literal; see @secref["parse-structure"]} @dispatch[@litchar["#s{"]]{starts a @tech{structure} literal; see @secref["parse-structure"]} @@ -157,6 +165,16 @@ on the next character or characters in the input stream as follows: @dispatch[@elem{@litchar{#}@kleeneplus{@nonterm{digit@sub{10}}}@litchar{(}}]{starts a vector; see @secref["parse-vector"]} @dispatch[@elem{@litchar{#}@kleeneplus{@nonterm{digit@sub{10}}}@litchar{[}}]{starts a vector; see @secref["parse-vector"]} @dispatch[@elem{@litchar{#}@kleeneplus{@nonterm{digit@sub{10}}}@litchar["{"]}]{starts a vector; see @secref["parse-vector"]} + + @dispatch[@elem{@litchar{#fx}@kleeneplus{@nonterm{digit@sub{10}}}@litchar{(}}]{starts a fxvector; see @secref["parse-vector"]} + @dispatch[@elem{@litchar{#fx}@kleeneplus{@nonterm{digit@sub{10}}}@litchar{[}}]{starts a fxvector; see @secref["parse-vector"]} + @dispatch[@elem{@litchar{#fx}@kleeneplus{@nonterm{digit@sub{10}}}@litchar["{"]}]{starts a fxvector; see @secref["parse-vector"]} + + @dispatch[@elem{@litchar{#fl}@kleeneplus{@nonterm{digit@sub{10}}}@litchar{(}}]{starts a flvector; see @secref["parse-vector"]} + @dispatch[@elem{@litchar{#fl}@kleeneplus{@nonterm{digit@sub{10}}}@litchar{[}}]{starts a flvector; see @secref["parse-vector"]} + @dispatch[@elem{@litchar{#fl}@kleeneplus{@nonterm{digit@sub{10}}}@litchar["{"]}]{starts a flvector; see @secref["parse-vector"]} + + @dispatch[@graph-defn[]]{binds a graph tag; see @secref["parse-graph"]} @dispatch[@graph-ref[]]{uses a graph tag; see @secref["parse-graph"]} @@ -578,16 +596,25 @@ file. When the reader encounters a @litchar{#(}, @litchar{#[}, or @litchar["#{"], it starts parsing a @tech{vector}; see @secref["vectors"] for -information on vectors. The @litchar{#[} and @litchar["#{"] forms can -be disabled through the @racket[read-square-bracket-as-paren] and +information on vectors. +When the reader encounters a @litchar{#fl(}, @litchar{#fl[}, or +@litchar["#fl{"], it starts parsing a @tech{flvector}; see @secref["flvectors"] for +information on flvectors. +When the reader encounters a @litchar{#fx(}, @litchar{#fx[}, or +@litchar["#fx{"], it starts parsing a @tech{fxvector}; see @secref["fxvectors"] for +information on flvectors. +The @litchar{#[}, @litchar["#{"], @litchar{#fl[}, @litchar["#fl{"], +@litchar{#fx[}, and @litchar["#fx{"] forms can be disabled through +the @racket[read-square-bracket-as-paren] and @racket[read-curly-brace-as-paren] @tech{parameters}. The elements of the vector are recursively read until a matching @litchar{)}, @litchar{]}, or @litchar["}"] is found, just as for lists (see @secref["parse-pair"]). A delimited @litchar{.} is not -allowed among the vector elements. +allowed among the vector elements. The @tech{fxvector} and @tech{flvector} forms +only accept @tech{flonum}s and @tech{fixnum}s respectively. -An optional vector length can be specified between the @litchar{#} and +An optional vector length can be specified between @litchar{#}, @litchar{#fl}, @litchar{#fx} and @litchar{(}, @litchar{[}, or @litchar["{"]. The size is specified using a sequence of decimal digits, and the number of elements provided for the vector must be no more than the specified size. If diff --git a/collects/tests/racket/print.rktl b/collects/tests/racket/print.rktl index e0c10613b0..9f59b3b5d2 100644 --- a/collects/tests/racket/print.rktl +++ b/collects/tests/racket/print.rktl @@ -5,6 +5,9 @@ (Section 'printing) +(require racket/flonum + racket/fixnum) + (let ([ptest (lambda (s v) (define (to-string v) (format "~v" v)) @@ -190,6 +193,9 @@ (ptest "'`,#,#`a" '`,#,#`a) (ptest "'`,#,#`,@#,@a" '`,#,#`,@#,@a) + (ptest "'#fx(1 10000 3)" (fxvector 1 10000 3)) + (ptest "'#fl(1.1 10000.1 3.1)" (flvector 1.1 10000.1 3.1)) + (void)) (let ([in-string (lambda (f v) @@ -250,4 +256,5 @@ ;; ---------------------------------------- + (report-errs) diff --git a/collects/tests/racket/read.rktl b/collects/tests/racket/read.rktl index 776a5141b2..a9486b0eb6 100644 --- a/collects/tests/racket/read.rktl +++ b/collects/tests/racket/read.rktl @@ -1121,6 +1121,25 @@ (err/rt-test (read-language p) (lambda (exn) (regexp-match? #rx"read-language" (exn-message exn))))) +(require racket/flonum + racket/fixnum) +(test #t flvector? (readstr "#fl(1.5 0.33 0.3)")) +(test #t fxvector? (readstr "#fx(1000 76 100000)")) +(test #t fxvector? (readstr "#fx(#x10 #X10 #d9 #D9 #b111 #B111 #o77 #O77 #e1 #E1)")) +(err/rt-test (readstr "#fx(#i4.2235 #I4.2235)") exn:fail:read?) +(test #t equal? (flvector 1.5 0.33 0.3 0.3 0.3 0.3 0.3 0.3 0.3 0.3) (readstr "#fl10(1.5 0.33 0.3)")) +(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? (fxvector 0 0 0 ) (readstr "#fx3()")) +(err/rt-test (readstr "#fl(1.5 0.33 0.3 (1 2))") exn:fail:read?) +(err/rt-test (readstr "#fx(1000 76 100000 (1 2))") exn:fail:read?) +(err/rt-test (readstr "#fl(1.5 0.33 0.3 'a)") exn:fail:read?) +(err/rt-test (readstr "#fx(1000 76 100000 'a)") exn:fail:read?) +(err/rt-test (readstr "#fli(1.5 0.33 0.3 'a)") exn:fail:read?) +(err/rt-test (readstr "#fxi(1000 76 100000 'a)") exn:fail:read?) +(err/rt-test (readstr "#fi(1000 76 100000 'a)") exn:fail:read?) +(err/rt-test (readstr "#fx(1 . 2)") exn:fail:read?) +(err/rt-test (readstr "#fx(1 . 2 . 3)") exn:fail:read?) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/racket/src/Makefile.in b/src/racket/src/Makefile.in index c04180cd7e..7c839723d8 100644 --- a/src/racket/src/Makefile.in +++ b/src/racket/src/Makefile.in @@ -378,14 +378,16 @@ port.@LTO@: $(COMMON_HEADERS) \ portfun.@LTO@: $(COMMON_HEADERS) $(srcdir)/schvers.h \ $(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark_portfun.inc print.@LTO@: $(COMMON_HEADERS) $(srcdir)/../src/stypes.h $(srcdir)/../src/schcpt.h \ - $(srcdir)/schvers.h $(SCONFIG) $(srcdir)/mzmark_print.inc + $(srcdir)/schvers.h $(SCONFIG) $(srcdir)/mzmark_print.inc \ + $(srcdir)/print_vector.inc thread.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark_thread.inc rational.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h read.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/schcpt.h $(srcdir)/schvers.h $(srcdir)/schminc.h \ - $(srcdir)/../src/stypes.h $(srcdir)/mzmark_read.inc + $(srcdir)/../src/stypes.h $(srcdir)/mzmark_read.inc \ + $(srcdir)/read_vector.inc regexp.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark_regexp.inc $(srcdir)/schrx.h resolve.@LTO@: $(COMMON_HEADERS) \ diff --git a/src/racket/src/numstr.c b/src/racket/src/numstr.c index b7dc024f2f..8d840095fd 100644 --- a/src/racket/src/numstr.c +++ b/src/racket/src/numstr.c @@ -1531,12 +1531,8 @@ string_to_number (int argc, Scheme_Object *argv[]) return v; } - -static char *double_to_string (double d, int alloc, int was_single) +char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer) { - char buffer[100], *s; - int l, i, digits; - if (MZ_IS_NAN(d)) #ifdef MZ_USE_SINGLE_FLOATS if (was_single) @@ -1581,13 +1577,15 @@ static char *double_to_string (double d, int alloc, int was_single) (single). That's big enough to get most right, small enough to avoid nonsense digits. But we'll loop in case it's not precise enough to get read-write invariance: */ + int i, l, digits; GC_CAN_IGNORE char *loc; + char *buffer = s; if (was_single) digits = 6; else digits = 14; loc = scheme_push_c_numeric_locale(); - while (digits < 30) { + while (digits < 30 && digits < slen) { double check; GC_CAN_IGNORE char *ptr; @@ -1637,7 +1635,20 @@ static char *double_to_string (double d, int alloc, int was_single) } } #endif - + *used_buffer = 1; + } + + return s; +} + +static char *double_to_string (double d, int alloc, int was_single) +{ + char buffer[100]; + char *s; + int used_buffer = 0; + s = scheme_double_to_string(d, buffer, 100, was_single, &used_buffer); + + if (used_buffer) { s = (char *)scheme_malloc_atomic(strlen(buffer) + 1); strcpy(s, buffer); alloc = 0; @@ -1645,6 +1656,7 @@ static char *double_to_string (double d, int alloc, int was_single) if (alloc) { char *s2; + int l; l = strlen(s) + 1; s2 = (char *)scheme_malloc_atomic(l); memcpy(s2, s, l); diff --git a/src/racket/src/print.c b/src/racket/src/print.c index 094888f60e..080a86c421 100644 --- a/src/racket/src/print.c +++ b/src/racket/src/print.c @@ -64,6 +64,20 @@ ROSYM Scheme_Object *qq_ellipses; #define REASONABLE_QQ_DEPTH (1 << 29) + +/* notdisplay + +enum NOTDISPLAY { + NOTDISPLAY_DISPLAY = 0, + NOTDISPLAY_WRITE = 1, + NOTDISPLAY_PRINT = 2, + NOTDISPLAY_AS_EXPRESSION = 3, +}; + +*/ + + + /* locals */ #define MAX_PRINT_BUFFER 500 @@ -121,6 +135,16 @@ static void print_vector(Scheme_Object *vec, int notdisplay, int compact, Scheme_Marshal_Tables *mt, PrintParams *pp, int as_prefab); +static void print_flvector(Scheme_Object *vec, int notdisplay, int compact, + Scheme_Hash_Table *ht, + Scheme_Marshal_Tables *mt, + PrintParams *pp, + int as_prefab); +static void print_fxvector(Scheme_Object *vec, int notdisplay, int compact, + Scheme_Hash_Table *ht, + Scheme_Marshal_Tables *mt, + PrintParams *pp, + int as_prefab); static void print_char(Scheme_Object *chobj, int notdisplay, PrintParams *pp); static char *print_to_string(Scheme_Object *obj, intptr_t * volatile len, int write, Scheme_Object *port, intptr_t maxl, @@ -2225,6 +2249,18 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, print_vector(obj, notdisplay, compact, ht, mt, pp, 0); closed = 1; } + else if (SCHEME_FLVECTORP(obj)) + { + notdisplay = to_quoted(obj, pp, notdisplay); + print_flvector(obj, notdisplay, compact, ht, mt, pp, 0); + closed = 1; + } + else if (SCHEME_FXVECTORP(obj)) + { + notdisplay = to_quoted(obj, pp, notdisplay); + print_fxvector(obj, notdisplay, compact, ht, mt, pp, 0); + closed = 1; + } else if ((compact || pp->print_box) && SCHEME_CHAPERONE_BOXP(obj)) { if (compact && !pp->print_box) { @@ -3713,67 +3749,81 @@ print_pair(Scheme_Object *pair, int notdisplay, int compact, } } -static void -print_vector(Scheme_Object *vec, int notdisplay, int compact, - Scheme_Hash_Table *ht, - Scheme_Marshal_Tables *mt, - PrintParams *pp, - int as_prefab) -{ - int i, size, common = 0; - Scheme_Object **elems, *elem; +#define FUNC_NAME print_vector +#define DEFINEEXTRA +#define ELMS_TYPE Scheme_Object ** +#define ELM_TYPE Scheme_Object * +#define DO_COMPACT() do { \ + print_compact(pp, CPT_VECTOR); \ + print_compact_number(pp, size); \ +} while(0); +#define DO_VEC_SIZE() do { \ + if (SCHEME_VECTORP(vec)) \ + size = SCHEME_VEC_SIZE(vec); \ + else \ + size = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec)); \ +} while(0); +#define DO_ELMS_SELECTOR() do { \ + if (SCHEME_VECTORP(vec)) \ + elems = SCHEME_VEC_ELS(vec); \ + else \ + elems = SCHEME_VEC_ELS(SCHEME_CHAPERONE_VAL(vec)); \ +} while(0); +#define DO_ELM_SELECTOR() do { \ + if (SCHEME_VECTORP(vec)) \ + elem = SCHEME_VEC_ELS(vec)[i]; \ + else \ + elem = scheme_chaperone_vector_ref(vec, i); \ +} while(0); +#define F_0 print_utf8_string(pp, "#0(", 0, 3) +#define F_D sprintf(buffer, "#%d(", size) +#define F_VECTOR print_utf8_string(pp, "(vector ", 0, 8) +#define F_ print_utf8_string(pp, "#(", 0, 2) +#define PRINT_ELM() do {\ + print(elem, notdisplay, compact, ht, mt, pp); \ +} while(0); +#include "print_vector.inc" - if (SCHEME_VECTORP(vec)) - size = SCHEME_VEC_SIZE(vec); - else - size = SCHEME_VEC_SIZE(SCHEME_CHAPERONE_VAL(vec)); +#define FUNC_NAME print_flvector +#define DEFINEEXTRA int used_buffer = 0; char buffer[100]; +#define ELMS_TYPE double * +#define ELM_TYPE double +#define DO_COMPACT() do { \ + print_escaped(pp, notdisplay, vec, ht, mt, 1); \ + return; \ +} while(0); +#define DO_VEC_SIZE() size = SCHEME_FLVEC_SIZE(vec); +#define DO_ELMS_SELECTOR() elems = SCHEME_FLVEC_ELS(vec); +#define DO_ELM_SELECTOR() elem = SCHEME_FLVEC_ELS(vec)[i]; +#define F_0 print_utf8_string(pp, "#fl0(", 0, 5) +#define F_D sprintf(buffer, "#fl%d(", size) +#define F_VECTOR print_utf8_string(pp, "(flvector ", 0, 10) +#define F_ print_utf8_string(pp, "#fl(", 0, 4) +#define PRINT_ELM() do {\ + scheme_double_to_string(elem, buffer, 100, 0, &used_buffer); \ + print_utf8_string(pp, buffer, 0, -1); \ +} while(0); +#include "print_vector.inc" - if (compact) { - print_compact(pp, CPT_VECTOR); - print_compact_number(pp, size); - } else { - if (SCHEME_VECTORP(vec)) - elems = SCHEME_VEC_ELS(vec); - else - elems = SCHEME_VEC_ELS(SCHEME_CHAPERONE_VAL(vec)); - for (i = size; i--; common++) { - if (!i || (elems[i] != elems[i - 1])) - break; - } - elems = NULL; /* Precise GC: because VEC_ELS is not aligned */ - - if (as_prefab) { - print_utf8_string(pp, "#s(", 0, 3); - } else if (notdisplay && pp->print_vec_shorthand && (notdisplay != 3)) { - if (size == 0) { - print_utf8_string(pp, "#0(", 0, 3); - } else { - char buffer[100]; - sprintf(buffer, "#%d(", size); - print_utf8_string(pp, buffer, 0, -1); - size -= common; - } - } else if (notdisplay == 3) - print_utf8_string(pp, "(vector ", 0, 8); - else - print_utf8_string(pp, "#(", 0, 2); - } - - for (i = 0; i < size; i++) { - if (SCHEME_VECTORP(vec)) - elem = SCHEME_VEC_ELS(vec)[i]; - else - elem = scheme_chaperone_vector_ref(vec, i); - print(elem, notdisplay, compact, ht, mt, pp); - if (i < (size - 1)) { - if (!compact) - print_utf8_string(pp, " ", 0, 1); - } - } - - if (!compact) - print_utf8_string(pp, ")", 0, 1); -} +#define FUNC_NAME print_fxvector +#define DEFINEEXTRA +#define ELMS_TYPE Scheme_Object ** +#define ELM_TYPE Scheme_Object * +#define DO_COMPACT() do { \ + print_escaped(pp, notdisplay, vec, ht, mt, 1); \ + return; \ +} while(0); +#define DO_VEC_SIZE() size = SCHEME_FXVEC_SIZE(vec); +#define DO_ELMS_SELECTOR() elems = SCHEME_FXVEC_ELS(vec); +#define DO_ELM_SELECTOR() elem = SCHEME_FXVEC_ELS(vec)[i]; +#define F_0 print_utf8_string(pp, "#fx0(", 0, 5) +#define F_D sprintf(buffer, "#fx%d(", size) +#define F_VECTOR print_utf8_string(pp, "(fxvector ", 0, 10) +#define F_ print_utf8_string(pp, "#fx(", 0, 4) +#define PRINT_ELM() do {\ + print(elem, notdisplay, compact, ht, mt, pp); \ +} while(0); +#include "print_vector.inc" static void print_char(Scheme_Object *charobj, int notdisplay, PrintParams *pp) diff --git a/src/racket/src/print_vector.inc b/src/racket/src/print_vector.inc new file mode 100644 index 0000000000..bd405f2242 --- /dev/null +++ b/src/racket/src/print_vector.inc @@ -0,0 +1,69 @@ +static void +FUNC_NAME (Scheme_Object *vec, int notdisplay, int compact, + Scheme_Hash_Table *ht, + Scheme_Marshal_Tables *mt, + PrintParams *pp, + int as_prefab) +{ + int i, size, common = 0; + ELMS_TYPE elems; + ELM_TYPE elem; + DEFINEEXTRA + + DO_VEC_SIZE() + if (compact) { + DO_COMPACT() + } else { + DO_ELMS_SELECTOR() + for (i = size; i--; common++) { + if (!i || (elems[i] != elems[i - 1])) + break; + } + elems = NULL; /* Precise GC: because VEC_ELS is not aligned */ + + if (as_prefab) { + print_utf8_string(pp, "#s(", 0, 3); + } else if (notdisplay && pp->print_vec_shorthand && (notdisplay != 3)) { + if (size == 0) { + F_0; + } else { + char buffer[100]; + F_D; + print_utf8_string(pp, buffer, 0, -1); + size -= common; + } + } else if (notdisplay == 3) + F_VECTOR; + else + F_; + } + + for (i = 0; i < size; i++) { + DO_ELM_SELECTOR() + PRINT_ELM() + if (i < (size - 1)) { + if (!compact) + print_utf8_string(pp, " ", 0, 1); + } + } + + if (!compact) + print_utf8_string(pp, ")", 0, 1); +} + +#undef FUNC_NAME +#undef DEFINEEXTRA +#undef ELMS_TYPE +#undef ELM_TYPE +#undef DO_COMPACT +#undef DO_VEC_SIZE +#undef DO_ELMS_SELECTOR +#undef DO_ELM_SELECTOR +#undef F_0 +#undef F_D +#undef F_VECTOR +#undef F_ +#undef PRINT_ELM + +/* vim: ft=c +*/ diff --git a/src/racket/src/read.c b/src/racket/src/read.c index f2e5335617..5aab5de4a9 100644 --- a/src/racket/src/read.c +++ b/src/racket/src/read.c @@ -142,6 +142,8 @@ static MZ_INLINE intptr_t SPAN(Scheme_Object *port, intptr_t pos) { #define mz_shape_hash_list 2 #define mz_shape_hash_elem 3 #define mz_shape_vec_plus_infix 4 +#define mz_shape_fl_vec 5 +#define mz_shape_fx_vec 6 typedef struct Readtable { Scheme_Object so; @@ -207,6 +209,20 @@ static Scheme_Object *read_vector(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params, int allow_infix); +static Scheme_Object *read_flvector (Scheme_Object *port, Scheme_Object *stxsrc, + intptr_t line, intptr_t col, intptr_t pos, + int opener, char closer, + intptr_t requestLength, const mzchar *reqBuffer, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, int allow_infix); +static Scheme_Object *read_fxvector (Scheme_Object *port, Scheme_Object *stxsrc, + intptr_t line, intptr_t col, intptr_t pos, + int opener, char closer, + intptr_t requestLength, const mzchar *reqBuffer, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, int allow_infix); static Scheme_Object *read_number(int init_ch, Scheme_Object *port, Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, @@ -291,6 +307,25 @@ static Scheme_Object *readtable_call(int w_char, int ch, Scheme_Object *proc, Re Scheme_Object *port, Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, int get_info, Scheme_Hash_Table **ht, Scheme_Object *modpath_stx); +static Scheme_Object *read_flonum(Scheme_Object *port, + Scheme_Object *stxsrc, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, + int comment_mode); +static Scheme_Object *read_fixnum(Scheme_Object *port, + Scheme_Object *stxsrc, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, + int comment_mode); +static Scheme_Object *read_number_literal(Scheme_Object *port, + Scheme_Object *stxsrc, + int is_float, int is_not_float, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, + int comment_mode); #define READTABLE_WHITESPACE 0x1 #define READTABLE_CONTINUING 0x2 @@ -831,6 +866,86 @@ static Scheme_Object *read_inner_inner_k(void) #define MAX_GRAPH_ID_DIGITS 8 +static int read_vector_length(Scheme_Object *port, Readtable *table, int *ch, mzchar *tagbuf, mzchar *vecbuf, int *vector_length, int *digits, int *overflow) +{ + int i = 0, j = 0, nch; + *vector_length = -1; + *overflow = 0; + *digits = 0; + + while (NOT_EOF_OR_SPECIAL((*ch)) && isdigit_ascii((*ch))) { + if (*digits <= MAX_GRAPH_ID_DIGITS) + (*digits)++; + + /* For vector error msgs, want to drop leading zeros: */ + if (j || ((*ch) != '0')) { + if (j < 60) { + vecbuf[j++] = (*ch); + } else if (j == 60) { + vecbuf[j++] = '.'; + vecbuf[j++] = '.'; + vecbuf[j++] = '.'; + vecbuf[j] = 0; + } + } + + /* For tag error msgs, want to keep zeros: */ + if (i < 60) { + tagbuf[i++] = (*ch); + } else if (i == 60) { + tagbuf[i++] = '.'; + tagbuf[i++] = '.'; + tagbuf[i++] = '.'; + tagbuf[i] = 0; + } + + if (!(*overflow)) { + intptr_t old_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)) { + *overflow = 1; + } + } + nch = scheme_getc_special_ok(port); + (*ch) = nch; + } + + if (*overflow) + *vector_length = -2; + vecbuf[j] = 0; + tagbuf[i] = 0; + + return readtable_effective_char(table, (*ch)); +} + +static Scheme_Object * +read_plus_minus_period_leading_number(Scheme_Object *port, Scheme_Object *stxsrc, + int ch, intptr_t line, intptr_t col, intptr_t pos, + int is_float, int is_not_float, + Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params, + Readtable *table) +{ + int ch2; + Scheme_Object *special_value; + ch2 = scheme_peekc_special_ok(port); + if ((NOT_EOF_OR_SPECIAL(ch2) && isdigit_ascii(ch2)) || (ch2 == '.') + || ((ch2 == 'i') || (ch2 == 'I') /* Maybe inf */ + || (ch2 == 'n') || (ch2 == 'N') /* Maybe nan*/ )) { + /* read_number tries to get a number, but produces a symbol if number parsing doesn't work: */ + special_value = read_number(ch, port, stxsrc, line, col, pos, + is_float, is_not_float, 10, 0, ht, indentation, params, table); + } else { + special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table); + } + return special_value; +} + + static Scheme_Object * read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht, Scheme_Object *indentation, ReadParams *params, @@ -1027,15 +1142,7 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * case '+': case '-': case '.': /* ^^^ fallthrough ^^^ */ - ch2 = scheme_peekc_special_ok(port); - if ((NOT_EOF_OR_SPECIAL(ch2) && isdigit_ascii(ch2)) || (ch2 == '.') - || ((ch2 == 'i') || (ch2 == 'I') /* Maybe inf */ - || (ch2 == 'n') || (ch2 == 'N') /* Maybe nan*/ )) { - /* read_number tries to get a number, but produces a symbol if number parsing doesn't work: */ - special_value = read_number(ch, port, stxsrc, line, col, pos, 0, 0, 10, 0, ht, indentation, params, table); - } else { - special_value = read_symbol(ch, 0, port, stxsrc, line, col, pos, ht, indentation, params, table); - } + special_value = read_plus_minus_period_leading_number(port, stxsrc, ch, line, col, pos, 0, 0, ht, indentation, params, table); break; case '#': ch = scheme_getc_special_ok(port); @@ -1143,9 +1250,65 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * ? scheme_make_stx_w_offset(scheme_false, line, col, pos, 2, stxsrc, STX_SRCTAG) : scheme_false); } else { - GC_CAN_IGNORE const mzchar str[] = { 'f', 'a', 'l', 's', 'e', 0 }; - return read_delimited_constant(ch, str, scheme_false, port, stxsrc, line, col, pos, - indentation, params, table); + int next; + next = scheme_peekc_special_ok(port); + switch (next) { + case 'l': + case 'x': + { + int vector_length = -1; + int overflow = 0, digits = 0, effective_ch; + mzchar tagbuf[64], vecbuf[64]; /* just for errors */ + int ch; + ch = scheme_getc_special_ok(port); + ch = scheme_getc_special_ok(port); + if (isdigit_ascii(ch)) { + effective_ch = read_vector_length(port, table, &ch, tagbuf, vecbuf, &vector_length, &digits, &overflow); + } + else { + effective_ch = ch; + } + switch (effective_ch) + { + case '(': + if (next == 'l') + return read_flvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, 0); + else + return read_fxvector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, 0); + break; + case '[': + if (!params->square_brackets_are_parens) { + scheme_read_err(port, stxsrc, line, col, pos, 2, effective_ch, indentation, "read: bad syntax `#f%c['", next); + return NULL; + } else + if (next == 'l') + return read_flvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, 0); + else + return read_fxvector(port, stxsrc, line, col, pos, ch, ']', vector_length, vecbuf, ht, indentation, params, 0); + break; + case '{': + if (!params->curly_braces_are_parens) { + scheme_read_err(port, stxsrc, line, col, pos, 2, effective_ch, indentation, "read: bad syntax `#f%c{'", next); + return NULL; + } else + if (next == 'l') + return read_flvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, 0); + else + return read_fxvector(port, stxsrc, line, col, pos, ch, '}', vector_length, vecbuf, ht, indentation, params, 0); + break; + default: + scheme_read_err(port, stxsrc, line, col, pos, 2, effective_ch, indentation, + "read: expected `(' `[' or `{' after #f%c", next); + } + } + default: + { + GC_CAN_IGNORE const mzchar str[] = { 'f', 'a', 'l', 's', 'e', 0 }; + return read_delimited_constant(ch, str, scheme_false, port, stxsrc, line, col, pos, + indentation, params, table); + } + } + } case 'c': case 'C': @@ -1671,56 +1834,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * default: { int vector_length = -1; - int i = 0, j = 0, overflow = 0, digits = 0, effective_ch; + int overflow = 0, digits = 0, effective_ch; mzchar tagbuf[64], vecbuf[64]; /* just for errors */ - - while (NOT_EOF_OR_SPECIAL(ch) && isdigit_ascii(ch)) { - if (digits <= MAX_GRAPH_ID_DIGITS) - digits++; - - /* For vector error msgs, want to drop leading zeros: */ - if (j || (ch != '0')) { - if (j < 60) { - vecbuf[j++] = ch; - } else if (j == 60) { - vecbuf[j++] = '.'; - vecbuf[j++] = '.'; - vecbuf[j++] = '.'; - vecbuf[j] = 0; - } - } - - /* For tag error msgs, want to keep zeros: */ - if (i < 60) { - tagbuf[i++] = ch; - } else if (i == 60) { - tagbuf[i++] = '.'; - tagbuf[i++] = '.'; - tagbuf[i++] = '.'; - tagbuf[i] = 0; - } - - if (!overflow) { - intptr_t old_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)) { - overflow = 1; - } - } - ch = scheme_getc_special_ok(port); - } - - if (overflow) - vector_length = -2; - vecbuf[j] = 0; - tagbuf[i] = 0; - - effective_ch = readtable_effective_char(table, ch); + effective_ch = read_vector_length(port, table, &ch, tagbuf, vecbuf, &vector_length, &digits, &overflow); if (effective_ch == '(') return read_vector(port, stxsrc, line, col, pos, ch, ')', vector_length, vecbuf, ht, indentation, params, 0); @@ -2646,8 +2762,16 @@ read_list(Scheme_Object *port, prefetched = NULL; } else { scheme_ungetc(ch, port); - car = read_inner(port, stxsrc, ht, indentation, params, - RETURN_FOR_SPECIAL_COMMENT); + switch (shape) { + case mz_shape_fl_vec: + car = read_flonum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); + break; + case mz_shape_fx_vec: + car = read_fixnum(port, NULL, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); + break; + default: + car = read_inner(port, stxsrc, ht, indentation, params, RETURN_FOR_SPECIAL_COMMENT); + } if (!car) continue; /* special was a comment */ } /* can't be eof, due to check above */ @@ -2810,6 +2934,116 @@ static Scheme_Object *attach_shape_property(Scheme_Object *list, return list; } +static Scheme_Object *read_flonum(Scheme_Object *port, + Scheme_Object *stxsrc, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, + int comment_mode) +{ + intptr_t line = 0, col = 0, pos = 0; + intptr_t line2 = 0, col2 = 0, pos2 = 0; + Scheme_Object *n; + scheme_tell_all(port, &line, &col, &pos); + n = read_number_literal(port, stxsrc, 1, 0, ht, indentation, params, comment_mode); + if (SCHEME_DBLP(n)) + return n; + else { + scheme_tell_all(port, &line2, &col2, &pos2); + //printf("%d %d %d %d %d %d\n", line, col, pos, line2, col2, pos2); + scheme_read_err(port, stxsrc, line, col, pos, pos2-pos, -1, indentation, "read: expected flonum, got %V", n); + } + return NULL; +} + +static Scheme_Object *read_fixnum(Scheme_Object *port, + Scheme_Object *stxsrc, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, + int comment_mode) +{ + intptr_t line = 0, col = 0, pos = 0; + intptr_t line2 = 0, col2 = 0, pos2 = 0; + Scheme_Object *n; + scheme_tell_all(port, &line, &col, &pos); + n = read_number_literal(port, stxsrc, 0, 1, ht, indentation, params, comment_mode); + if (SCHEME_INTP(n)) + return n; + else + scheme_tell_all(port, &line2, &col2, &pos2); + scheme_read_err(port, stxsrc, line, col, pos, pos2-pos, -1, indentation, "read: expected fixnum, got %V", n); + return NULL; +} + +static Scheme_Object *read_number_literal(Scheme_Object *port, + Scheme_Object *stxsrc, + int is_float, int is_not_float, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, + ReadParams *params, + int comment_mode) +{ + int ch, ch2; + intptr_t line = 0, col = 0, pos = 0; + Scheme_Object *special_value = NULL; + Readtable *table; + + table = params->table; + scheme_tell_all(port, &line, &col, &pos); + ch = scheme_getc_special_ok(port); + switch (ch) { + case '+': + case '-': + case '.': /* ^^^ fallthrough ^^^ */ + special_value = read_plus_minus_period_leading_number(port, stxsrc, ch, line, col, pos, is_float, is_not_float, ht, indentation, params, table); + break; + case '#': + ch = scheme_getc_special_ok(port); + switch (ch ) { + case 'X': + case 'x': + /* 0 0 */ + return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 16, 1, ht, indentation, params, table); + break; + case 'B': + case 'b': + /* 0 0 */ + return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 2, 1, ht, indentation, params, table); + break; + case 'O': + case 'o': + /* 0 0 */ + return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 8, 1, ht, indentation, params, table); + break; + case 'D': + case 'd': + /* 0 0 */ + return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 10, 1, ht, indentation, params, table); + break; + case 'E': + case 'e': + /* 0 1 */ + return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 10, 0, ht, indentation, params, table); + break; + case 'I': + case 'i': + /* 1 0 */ + return read_number(-1, port, stxsrc, line, col, pos, is_float, is_not_float, 10, 0, ht, indentation, params, table); + break; + default: + scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, "read: expected one of [XxBbOoDdEeII]"); + } + default: + if (isdigit_ascii(ch)) + /* 0 0 */ + special_value = read_number(ch, port, stxsrc, line, col, pos, is_float, is_not_float, 10, 0, ht, indentation, params, table); + else + scheme_read_err(port, stxsrc, line, col, pos, 2, ch, indentation, "read: expected digit"); + } + return special_value; +} + /*========================================================================*/ /* string reader */ /*========================================================================*/ @@ -3205,78 +3439,44 @@ char *scheme_extract_indentation_suggestions(Scheme_Object *indentation) /*========================================================================*/ /* vector reader */ /*========================================================================*/ +#define FUNC_NAME read_vector +#define VTYPE_STR "vector" +#define VEC_TYPE Scheme_Object +#define ELMS_TYPE Scheme_Object ** +#define ELM_TYPE Scheme_Object * +#define MZ_SHAPE allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec +#define MK_VEC() (Scheme_Object *) scheme_make_vector(requestLength, NULL) +#define ELMS_SELECTOR SCHEME_VEC_ELS +#define ELM_SELECTOR +#define ELM_MAKE_ZERO scheme_make_integer(0) +#define VEC_SIZE SCHEME_VEC_SIZE +#include "read_vector.inc" -/* "#(" has been read */ -static Scheme_Object * -read_vector (Scheme_Object *port, - Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, - int opener, char closer, - intptr_t requestLength, const mzchar *reqBuffer, - Scheme_Hash_Table **ht, - Scheme_Object *indentation, ReadParams *params, int allow_infix) -/* requestLength == -1 => no request - requestLength == -2 => overflow */ -{ - Scheme_Object *lresult, *obj, *vec, **els; - int len, i; +#define FUNC_NAME read_fxvector +#define VTYPE_STR "fxvector" +#define VEC_TYPE Scheme_Object +#define ELMS_TYPE Scheme_Object ** +#define ELM_TYPE Scheme_Object * +#define MZ_SHAPE mz_shape_fx_vec +#define MK_VEC() (Scheme_Object *) scheme_alloc_fxvector(requestLength) +#define ELMS_SELECTOR SCHEME_FXVEC_ELS +#define ELM_SELECTOR +#define ELM_MAKE_ZERO scheme_make_integer(0) +#define VEC_SIZE SCHEME_FXVEC_SIZE +#include "read_vector.inc" - lresult = read_list(port, stxsrc, line, col, pos, opener, closer, - allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec, - 1, ht, indentation, params); - - if (requestLength == -2) { - scheme_raise_out_of_memory("read", "making vector of size %5", reqBuffer); - return NULL; - } - - if (stxsrc) - obj = ((Scheme_Stx *)lresult)->val; - else - obj = lresult; - - len = scheme_list_length(obj); - if (requestLength >= 0 && len > requestLength) { - char buffer[20]; - sprintf(buffer, "%" PRIdPTR, requestLength); - scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, - "read: vector length %ld is too small, " - "%d values provided", - requestLength, len); - return NULL; - } - if (requestLength < 0) - requestLength = len; - vec = scheme_make_vector(requestLength, NULL); - els = SCHEME_VEC_ELS(vec); - for (i = 0; i < len ; i++) { - els[i] = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - } - els = NULL; - if (i < requestLength) { - if (len) - obj = SCHEME_VEC_ELS(vec)[len - 1]; - else { - obj = scheme_make_integer(0); - if (stxsrc) - obj = scheme_make_stx_w_offset(obj, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); - } - - els = SCHEME_VEC_ELS(vec); - for (; i < requestLength; i++) { - els[i] = obj; - } - els = NULL; - } - - if (stxsrc) { - if (SCHEME_VEC_SIZE(vec) > 0) - SCHEME_SET_VECTOR_IMMUTABLE(vec); - ((Scheme_Stx *)lresult)->val = vec; - return lresult; - } else - return vec; -} +#define FUNC_NAME read_flvector +#define VTYPE_STR "flvector" +#define VEC_TYPE Scheme_Double_Vector +#define ELMS_TYPE double * +#define ELM_TYPE double +#define MZ_SHAPE mz_shape_fl_vec +#define MK_VEC() scheme_alloc_flvector(requestLength) +#define ELMS_SELECTOR SCHEME_FLVEC_ELS +#define ELM_SELECTOR SCHEME_DBL_VAL +#define ELM_MAKE_ZERO 0.0 +#define VEC_SIZE SCHEME_FLVEC_SIZE +#include "read_vector.inc" /*========================================================================*/ /* symbol reader */ diff --git a/src/racket/src/read_vector.inc b/src/racket/src/read_vector.inc new file mode 100644 index 0000000000..9182b3c537 --- /dev/null +++ b/src/racket/src/read_vector.inc @@ -0,0 +1,94 @@ +/* "#(" has been read */ +/* or "#fl(" has been read */ +/* or "#fx(" has been read */ +static Scheme_Object * +FUNC_NAME (Scheme_Object *port, + Scheme_Object *stxsrc, intptr_t line, intptr_t col, intptr_t pos, + int opener, char closer, + intptr_t requestLength, const mzchar *reqBuffer, + Scheme_Hash_Table **ht, + Scheme_Object *indentation, ReadParams *params, int allow_infix) +/* requestLength == -1 => no request + requestLength == -2 => overflow */ +{ + Scheme_Object *lresult, *obj; + VEC_TYPE *vec; + ELMS_TYPE els; + ELM_TYPE elm; + int len, i; + char *vtype_str; + + vtype_str = VTYPE_STR; + + lresult = read_list(port, stxsrc, line, col, pos, opener, closer, + MZ_SHAPE, + 1, ht, indentation, params); + + if (requestLength == -2) { + scheme_raise_out_of_memory("read", "making %s of size %5", vtype_str, reqBuffer); + return NULL; + } + + if (stxsrc) + obj = ((Scheme_Stx *)lresult)->val; + else + obj = lresult; + + len = scheme_list_length(obj); + if (requestLength >= 0 && len > requestLength) { + char buffer[20]; + sprintf(buffer, "%" PRIdPTR, requestLength); + scheme_read_err(port, stxsrc, line, col, pos, SPAN(port, pos), 0, indentation, + "read: %s length %ld is too small, " + "%d values provided", + vtype_str, requestLength, len); + return NULL; + } + if (requestLength < 0) + requestLength = len; + + vec = MK_VEC(); + els = ELMS_SELECTOR(vec); + for (i = 0; i < len ; i++) { + els[i] = ELM_SELECTOR(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + } + els = NULL; + if (i < requestLength) { + if (len) + elm = ELMS_SELECTOR(vec)[len - 1]; + else { + elm = ELM_MAKE_ZERO; + if (stxsrc) + obj = scheme_make_stx_w_offset(obj, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG); + } + + els = ELMS_SELECTOR(vec); + for (; i < requestLength; i++) { + els[i] = elm; + } + els = NULL; + } + + if (stxsrc) { + if (VEC_SIZE(vec) > 0) + SCHEME_SET_VECTOR_IMMUTABLE(vec); + ((Scheme_Stx *)lresult)->val = (Scheme_Object *) vec; + return lresult; + } else + return (Scheme_Object *) vec; +} +#undef FUNC_NAME +#undef VTYPE_STR +#undef VEC_TYPE +#undef ELMS_TYPE +#undef ELM_TYPE +#undef MZ_SHAPE +#undef MK_VEC +#undef ELMS_SELECTOR +#undef ELM_SELECTOR +#undef ELM_MAKE_ZERO +#undef VEC_SIZE + +/* vim: ft=c +*/ diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index cf5fa39b3d..503764e402 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -1878,6 +1878,7 @@ typedef struct { XFORM_NONGCING Scheme_Object *scheme_make_small_bignum(intptr_t v, Small_Bignum *s); char *scheme_number_to_string(int radix, Scheme_Object *obj); +char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer); Scheme_Object *scheme_bignum_copy(const Scheme_Object *n);