diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index c02dc2c069..55ea4558b5 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.90.0.20") +(define version "6.90.0.21") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/reference/fasl.scrbl b/pkgs/racket-doc/scribblings/reference/fasl.scrbl index 84bd774431..54e3057c59 100644 --- a/pkgs/racket-doc/scribblings/reference/fasl.scrbl +++ b/pkgs/racket-doc/scribblings/reference/fasl.scrbl @@ -9,33 +9,62 @@ @note-lib-only[racket/fasl] @deftogether[( -@defproc[(s-exp->fasl [v any/c] [out (or/c output-port? #f) #f]) (or/c (void) bytes?)] -@defproc[(fasl->s-exp [in (or/c input-port? bytes?)]) any/c] +@defproc[(s-exp->fasl [v any/c] + [out (or/c output-port? #f) #f] + [#:keep-mutable? keep-mutable? any/c #f]) + (or/c (void) bytes?)] +@defproc[(fasl->s-exp [in (or/c input-port? bytes?)] + [#:datum-intern? datum-intern? any/c #t]) + any/c] )]{ The @racket[s-exp->fasl] function serializes @racket[v] to a byte string, printing it directly to @racket[out] if @racket[out] is an -output port or return the byte string otherwise. The +output port or returning the byte string otherwise. The @racket[fasl->s-exp] function decodes a value from a byte string (supplied either directly or as an input port) that was encoded with @racket[s-exp->fasl]. The @racket[v] argument must be a value that could be @racket[quote]d -as a literal, because @racket[s-exp->fasl] essentially uses -@racket[(compile `(quote ,v))] to encode the value using Racket's -built-in fast-load format for bytecode. +as a literal---that is, something for which @racket[(compile `(quote +,v))] would work and be @racket[read]able after @racket[write]. The +byte string produced by @racket[s-exp->fasl] does not use the same +format as compiled code, however. -The byte-string encoding produced by @racket[s-exp->fasl] is specific -to a version of Racket. That is, the resulting byte string can be -decoded back to @racket[v] only using the same version with which it -was encoded. +Like @racket[(compile `(quote ,v))], @racket[s-exp->fasl] does not +preserve graph structure, support cycles, or handle non-@tech{prefab} +structures. Compose @racket[s-exp->fasl] with @racket[serialize] to +preserve graph structure, handle cyclic data, and encode serializable +structures. The @racket[s-exp->fasl] and @racket[fasl->s-exp] +functions consult @racket[current-write-relative-directory] and +@racket[current-load-relative-directory], respectively, in the same +way as bytecode saving and loading to store paths in relative form. + +Unless @racket[keep-mutable?] is provided as true to +@racket[s-exp->fasl], then mutable values in @racket[v] are replaced +by immutable values when the result is decoded by +@racket[fasl->s-exp]. Unless @racket[datum-intern?] is provided as +@racket[#f], then any immutable value produced by @racket[fasl->s-exp] +is filtered by @racket[datum-intern-literal]. The defaults make the +composition of @racket[s-exp->fasl] and @racket[fasl->s-exp] behave +like the composition of @racket[write] and @racket[read]. + +The byte-string encoding produced by @racket[s-exp->fasl] is +independent of the Racket version, except as future Racket versions +introduce extensions that are not currently recognized. In particular, +the result of @racket[s-exp->fasl] will be valid as input to any +future version of @racket[s-exp->fasl]. @mz-examples[ #:eval fasl-eval (define fasl (s-exp->fasl (list #("speed") 'racer #\!))) fasl (fasl->s-exp fasl) -]} +] + +@history[#:changed "6.90.0.21" @elem{Made @racket[s-exp->fasl] format version-independent + and added the @racket[#:keep-mutable?] + and @racket[#:datum-intern?] arguments.}]} @; ---------------------------------------------------------------------- diff --git a/pkgs/racket-test-core/tests/racket/all.rktl b/pkgs/racket-test-core/tests/racket/all.rktl index 5f05f0cca3..f3b3552397 100644 --- a/pkgs/racket-test-core/tests/racket/all.rktl +++ b/pkgs/racket-test-core/tests/racket/all.rktl @@ -15,6 +15,7 @@ (load-in-sandbox "flonum.rktl") (load-in-sandbox "extflonum.rktl") (load-in-sandbox "string.rktl") +(load-in-sandbox "fasl.rktl") (load-in-sandbox "async-channel.rktl") (load-in-sandbox "pathlib.rktl") diff --git a/pkgs/racket-test-core/tests/racket/fasl.rktl b/pkgs/racket-test-core/tests/racket/fasl.rktl new file mode 100644 index 0000000000..658027c390 --- /dev/null +++ b/pkgs/racket-test-core/tests/racket/fasl.rktl @@ -0,0 +1,104 @@ + +(load-relative "loadtest.rktl") + +(Section 'fasl) + +(require racket/fasl) + +(define immutables + ;; If you update this list, then also update `immutable-regression-bstr`: + `(0 #t #f ,(void) ,eof + 1 #\2 three "four" #"five" #:six #&7 #(8 9 10) (11 . 12) (13 14 . fifteen) + #hash((sixteen . 17) (18 . nineteen)) + #hasheq((20 . "twenty-one") (22 . "twenty-three")) + #hasheqv((24 . 25) (26 . 27)) + #s(twenty-eight 29 30 "31") + -32 + 3300 + 34000 + 350000 + 3600000 + 370000000 + 38000000000 + 390000000000000 + 4000000000000000000 + 41.0 + 4.2 + 43/100 + 44+100i + 45.0+100.0i + 46f0)) + +;; The fasl format is meant to be forward-compatible: +(define immutables-regression-bstr + #"rkt:\0\200\371\0\34\"n\4\3\6\ao\r2\16\5three\23\4four\25\4five\21\3six\"u \3vwx\36yz\35\2{|\16\afifteen%\1\2\200\16\bnineteen\16\asixteen\177%\0\2\202\23\ntwenty-one\204\23\ftwenty-three%\2\2\206\207\210\211#\16\ftwenty-eight\3\213\214\23\00231\b\340\b\200\344\f\b\201\320\204\0\0\b\2010W\5\0\b\201\200\3566\0\b\201\200\300\r\26\b\202\0\374\371\330\b\0\0\0\b\202\0`v\363\263b\1\0\b\202\0\0\220\235\316\332\2027\t\0\0\0\0\0\200D@\t\315\314\314\314\314\314\20@\v\231\322\f\232\322\f\t\0\0\0\0\0\200F@\t\0\0\0\0\0\0Y@\n\0\08B") + +(for ([i (in-list immutables)]) + (test i fasl->s-exp (s-exp->fasl i))) + +(test immutables fasl->s-exp (s-exp->fasl immutables)) +(test (list immutables immutables) fasl->s-exp (s-exp->fasl (list immutables immutables))) + +(test immutables-regression-bstr s-exp->fasl immutables) + +(let* ([g (gensym)]) + (define s-exp (fasl->s-exp (s-exp->fasl (list g g g)))) + (test #f eq? g (car s-exp)) + (test #t eq? (car s-exp) (cadr s-exp)) + (test #t eq? (car s-exp) (caddr s-exp))) + +(let* ([u (string->unreadable-symbol "unread")]) + (define s-exp (fasl->s-exp (s-exp->fasl (list u u)))) + (test #t eq? u (car s-exp)) + (test #t eq? u (cadr s-exp))) + +;; check uses datum-intern-literal: +(test #t eq? "hello" (fasl->s-exp (s-exp->fasl "hello"))) +(test #t eq? #"hello" (fasl->s-exp (s-exp->fasl #"hello"))) + +(test #f eq? "hello" (fasl->s-exp (s-exp->fasl "hello") #:datum-intern? #f)) +(test #f eq? #"hello" (fasl->s-exp (s-exp->fasl #"hello") #:datum-intern? #f)) +(test #f eq? #rx"hello" (fasl->s-exp (s-exp->fasl #rx"hello") #:datum-intern? #f)) +(test #f eq? #px"hello" (fasl->s-exp (s-exp->fasl #px"hello") #:datum-intern? #f)) +(test #f eq? #rx#"hello" (fasl->s-exp (s-exp->fasl #rx#"hello") #:datum-intern? #f)) +(test #f eq? #px#"hello" (fasl->s-exp (s-exp->fasl #px#"hello") #:datum-intern? #f)) + +(define (check-hash make-hash hash) + (let ([mut (make-hash)] + [immut (hash 'one 2 'three 4)]) + (for ([(k v) (in-hash immut)]) + (hash-set! mut k v)) + (test immut fasl->s-exp (s-exp->fasl immut)) + (test #t equal? immut (fasl->s-exp (s-exp->fasl mut))) + (test #f equal? mut (fasl->s-exp (s-exp->fasl mut))) + (test #t equal? mut (fasl->s-exp (s-exp->fasl mut #:keep-mutable? #t))))) + +(check-hash make-hash hash) +(check-hash make-hasheq hasheq) +(check-hash make-hasheqv hasheqv) + +(define (check-mutable make-x) + (test #t immutable? (fasl->s-exp (s-exp->fasl (make-x 3)))) + (test #f immutable? (fasl->s-exp (s-exp->fasl (make-x 3) #:keep-mutable? #t)))) +(check-mutable make-vector) +(check-mutable make-string) +(check-mutable make-bytes) + +(test (current-directory) fasl->s-exp (s-exp->fasl (current-directory))) +(parameterize ([current-write-relative-directory #f]) + (let ([unix-path (bytes->path #"here" 'unix)] + [windows-path (bytes->path #"there" 'windows)]) + (test unix-path fasl->s-exp (s-exp->fasl unix-path)) + (test windows-path fasl->s-exp (s-exp->fasl windows-path)))) + +(let* ([rel-p (build-path "nested" "data.rktd")] + [p (build-path (current-directory) rel-p)]) + (define bstr + (parameterize ([current-write-relative-directory (current-directory)]) + (s-exp->fasl p))) + (parameterize ([current-load-relative-directory #f]) + (test rel-p fasl->s-exp bstr)) + (parameterize ([current-load-relative-directory (current-directory)]) + (test p fasl->s-exp bstr))) + +(report-errs) diff --git a/racket/collects/racket/fasl.rkt b/racket/collects/racket/fasl.rkt index c9bbba4413..dae38e51bc 100644 --- a/racket/collects/racket/fasl.rkt +++ b/racket/collects/racket/fasl.rkt @@ -1,30 +1,525 @@ #lang racket/base +(require (for-syntax racket/base)) (provide s-exp->fasl fasl->s-exp) -(define (s-exp->fasl v [out #f]) - (when out - (unless (output-port? out) - (raise-argument-error 'fasl->s-exp "(or/c output-port? #f)" out))) - (let ([p (or out - (open-output-bytes))]) - (parameterize ([current-namespace (make-base-namespace)]) - (write (compile `(quote ,v)) p)) - (if out - (void) - (get-output-bytes p)))) +;; ---------------------------------------- -(define (fasl->s-exp b) - (unless (or (bytes? b) - (input-port? b)) - (raise-arguments-error 'fasl->s-exp "(or/c bytes? input-port?)" b)) - (let ([p (if (bytes? b) - (open-input-bytes b) - b)]) - (let ([e (parameterize ([read-accept-compiled #t]) - (read p))]) - (if (compiled-expression? e) - (parameterize ([current-namespace (make-base-namespace)]) - (eval e)) - e)))) +(define-for-syntax constants (make-hasheq)) + +(define-syntax (define-constants stx) + (syntax-case stx () + [(_ [id n] ...) + (begin + (for ([id (in-list (syntax->list #'(id ...)))] + [n (in-list (syntax->list #'(n ...)))]) + (hash-set! constants (syntax-e id) (syntax-e n))) + #'(begin + (define id n) ...))])) + +(define-syntax (constant-case stx) + (syntax-case stx (else) + [(_ e [(id ...) rhs ...] ... [else else-rhs ...]) + (with-syntax ([((n ...) ...) + (for/list ([ids (in-list (syntax->list #'((id ...) ...)))]) + (for/list ([id (in-list (syntax->list ids))]) + (hash-ref constants (syntax-e id))))]) + #'(case e [(n ...) rhs ...] ... [else else-rhs ...]))])) + +;; ---------------------------------------- + +;; There is no versioning of the fasl format, so don't change the +;; numbers below --- only add to the set + +(define-constants + (fasl-graph-def-type 1) + (fasl-graph-ref-type 2) + + (fasl-false-type 3) + (fasl-true-type 4) + (fasl-null-type 5) + (fasl-void-type 6) + (fasl-eof-type 7) + + (fasl-integer-type 8) + (fasl-flonum-type 9) + (fasl-single-flonum-type 10) + (fasl-rational-type 11) + (fasl-complex-type 12) + (fasl-char-type 13) + + (fasl-symbol-type 14) + (fasl-unreadable-symbol-type 15) + (fasl-uninterned-symbol-type 16) + (fasl-keyword-type 17) + (fasl-string-type 18) + (fasl-immutable-string-type 19) + (fasl-bytes-type 20) + (fasl-immutable-bytes-type 21) + (fasl-path-type 22) + (fasl-relative-path-type 23) + + (fasl-pregexp-type 24) + (fasl-regexp-type 25) + (fasl-byte-pregexp-type 26) + (fasl-byte-regexp-type 27) + + (fasl-list-type 28) + (fasl-list*-type 29) + (fasl-pair-type 30) + (fasl-vector-type 31) + (fasl-immutable-vector-type 32) + (fasl-box-type 33) + (fasl-immutable-box-type 34) + (fasl-prefab-type 35) + (fasl-hash-type 36) + (fasl-immutable-hash-type 37) + + ;; Unallocated numbers here are for future extensions + + ;; 100 to 255 is used for small integers: + (fasl-small-integer-start 100)) + +(define fasl-lowest-small-integer -10) +(define fasl-highest-small-integer (- 255 (- fasl-small-integer-start fasl-lowest-small-integer) 1)) + +(define-constants + (fasl-hash-eq-variant 0) + (fasl-hash-equal-variant 1) + (fasl-hash-eqv-variant 2)) + +;; ---------------------------------------- + +(define (s-exp->fasl v + [orig-o #f] + #:keep-mutable? [keep-mutable? #f]) + (when orig-o + (unless (output-port? orig-o) + (raise-argument-error 'fasl->s-exp "(or/c output-port? #f)" orig-o))) + (define o (or orig-o (open-output-bytes))) + (define shared (make-hasheq)) + (define shared-counter 0) + ;; Find shared symbols and similar for compactness. We don't try to + ;; save general graph structure, leaving that to `serialize`. + (let loop ([v v]) + (cond + [(or (symbol? v) + (keyword? v) + (string? v) + (bytes? v) + (path? v)) + (hash-update! shared v add1 0)] + [(pair? v) + (loop (car v)) + (loop (cdr v))] + [(vector? v) + (for ([e (in-vector v)]) + (loop e))] + [(box? v) + (loop (unbox v))] + [(prefab-struct-key v) + (loop (struct->vector v))] + [else (void)])) + (define exploded-wrt-dir 'not-ready) + (define (treat-immutable? v) (or (not keep-mutable?) (immutable? v))) + ;; The fasl formal prefix: + (write-bytes #"rkt:" o) + ;; Write content to a string, so we can measure it + (define bstr + (let ([o (open-output-bytes)]) + (let loop ([v v]) + (cond + [(not (eq? (hash-ref shared v 1) 1)) + (define c (hash-ref shared v)) + (cond + [(negative? c) + (write-byte fasl-graph-ref-type o) + (write-fasl-integer (sub1 (- c)) o)] + [else + (define pos shared-counter) + (set! shared-counter (add1 shared-counter)) + (write-byte fasl-graph-def-type o) + (write-fasl-integer pos o) + (hash-remove! shared v) + (loop v) + (hash-set! shared v (- (add1 pos)))])] + [(not v) + (write-byte fasl-false-type o)] + [(eq? v #t) + (write-byte fasl-true-type o)] + [(null? v) + (write-byte fasl-null-type o)] + [(void? v) + (write-byte fasl-void-type o)] + [(eof-object? v) + (write-byte fasl-eof-type o)] + [(exact-integer? v) + (cond + [(<= fasl-lowest-small-integer v fasl-highest-small-integer) + (write-byte (+ fasl-small-integer-start (- v fasl-lowest-small-integer)) o)] + [else + (write-byte fasl-integer-type o) + (write-fasl-integer v o)])] + [(flonum? v) + (write-byte fasl-flonum-type o) + (write-bytes (real->floating-point-bytes v 8 #f) o)] + [(single-flonum? v) + (write-byte fasl-single-flonum-type o) + (write-bytes (real->floating-point-bytes v 4 #f) o)] + [(rational? v) + (write-byte fasl-rational-type o) + (loop (numerator v)) + (loop (denominator v))] + [(complex? v) + (write-byte fasl-complex-type o) + (loop (real-part v)) + (loop (imag-part v))] + [(char? v) + (write-byte fasl-char-type o) + (write-fasl-integer (char->integer v) o)] + [(symbol? v) + (cond + [(symbol-interned? v) + (write-byte fasl-symbol-type o)] + [(symbol-unreadable? v) + (write-byte fasl-unreadable-symbol-type o)] + [else + (write-byte fasl-uninterned-symbol-type o)]) + (define bstr (string->bytes/utf-8 (symbol->string v))) + (write-fasl-integer (bytes-length bstr) o) + (write-bytes bstr o)] + [(keyword? v) + (write-byte fasl-keyword-type o) + (define bstr (string->bytes/utf-8 (keyword->string v))) + (write-fasl-integer (bytes-length bstr) o) + (write-bytes bstr o)] + [(string? v) + (write-fasl-integer (if (treat-immutable? v) fasl-immutable-string-type fasl-string-type) o) + (write-fasl-string v o)] + [(bytes? v) + (write-fasl-integer (if (treat-immutable? v) fasl-immutable-bytes-type fasl-bytes-type) o) + (write-fasl-bytes v o)] + [(path-for-some-system? v) + (when (and (eq? exploded-wrt-dir 'not-ready) + (path? v)) + (define wrt-dir (current-write-relative-directory)) + (set! exploded-wrt-dir (and wrt-dir (explode-path wrt-dir)))) + (define rel-elems + (and exploded-wrt-dir + (path? v) + (let ([exploded (explode-path v)]) + (and (for/and ([wrt-p (in-list exploded-wrt-dir)] + [p (in-list exploded)]) + (equal? wrt-p p)) + (list-tail exploded (length exploded-wrt-dir)))))) + (cond + [rel-elems + (write-byte fasl-relative-path-type o) + (loop (for/list ([p (in-list rel-elems)]) + (if (path? p) (path-element->bytes p) p)))] + [else + (write-byte fasl-path-type o) + (write-fasl-bytes (path->bytes v) o) + (loop (path-convention-type v))])] + [(pair? v) + (cond + [(pair? (cdr v)) + (define-values (n normal-list?) + (let loop ([v v] [len 0]) + (cond + [(null? v) (values len #t)] + [(pair? v) (loop (cdr v) (add1 len))] + [else (values len #f)]))) + (write-byte (if normal-list? fasl-list-type fasl-list*-type) o) + (write-fasl-integer n o) + (let ploop ([v v]) + (cond + [(pair? v) + (loop (car v)) + (ploop (cdr v))] + [else + (unless normal-list? + (loop v))]))] + [else + (write-byte fasl-pair-type o) + (loop (car v)) + (loop (cdr v))])] + [(vector? v) + (write-byte (if (treat-immutable? v) fasl-immutable-vector-type fasl-vector-type) o) + (write-fasl-integer (vector-length v) o) + (for ([e (in-vector v)]) + (loop e))] + [(box? v) + (write-byte (if (treat-immutable? v) fasl-immutable-box-type fasl-box-type) o) + (loop (unbox v))] + [(prefab-struct-key v) + => (lambda (k) + (write-byte fasl-prefab-type o) + (loop k) + (define vec (struct->vector v)) + (write-fasl-integer (sub1 (vector-length vec)) o) + (for ([e (in-vector vec 1)]) + (loop e)))] + [(hash? v) + (write-byte (if (treat-immutable? v) fasl-immutable-hash-type fasl-hash-type) o) + (write-byte (cond + [(hash-eq? v) fasl-hash-eq-variant] + [(hash-eqv? v) fasl-hash-eqv-variant] + [else fasl-hash-equal-variant]) + o) + (write-fasl-integer (hash-count v) o) + (hash-for-each v (lambda (k v) (loop k) (loop v)) #t)] + [(regexp? v) + (write-byte (if (pregexp? v) fasl-pregexp-type fasl-regexp-type)) + (write-fasl-string (object-name v) o)] + [(byte-regexp? v) + (write-byte (if (byte-pregexp? v) fasl-byte-pregexp-type fasl-byte-regexp-type)) + (write-fasl-bytes (object-name v) o)] + [else + (raise-arguments-error 'fasl-write + "cannot write value" + "value" v)])) + (get-output-bytes o #t))) + ;; Record the number of entries in the shared-value table that is + ;; used by `fasl-graph-ref-type` and `fasl-graph-ref-type`: + (write-fasl-integer shared-counter o) + ;; Record the byte-string size of the encoded data: + (write-fasl-integer (bytes-length bstr) o) + ;; Write the encoded data to `o` + (write-bytes bstr o) + (if orig-o + (void) + (get-output-bytes o))) + +;; ---------------------------------------- + +;; For input parsing internally, in place of an input port, use a +;; mutable pair containing a byte string and position + +(define (fasl->s-exp orig-i + #:datum-intern? [intern? #t]) + (define init-i (cond + [(bytes? orig-i) (mcons orig-i 0)] + [(input-port? orig-i) orig-i] + [else (raise-argument-error 'fasl->s-exp "(or/c bytes? input-port?)" orig-i)])) + (unless (bytes=? (read-bytes/exactly 4 init-i) #"rkt:") + (read-error "unrecognized prefix")) + (define shared-count (read-fasl-integer init-i)) + (define shared (make-vector shared-count)) + (define len (read-fasl-integer init-i)) + + (define i (if (mpair? init-i) + init-i + ;; Faster to work with a byte string: + (let ([bstr (read-bytes/exactly len init-i)]) + (mcons bstr 0)))) + + (define (intern v) (if intern? (datum-intern-literal v) v)) + (let loop () + (define type (read-byte/no-eof i)) + (constant-case + type + [(fasl-graph-def-type) + (define pos (read-fasl-integer i)) + (define v (loop)) + (unless (pos . < . shared-count) + (read-error "bad graph index")) + (vector-set! shared pos v) + v] + [(fasl-graph-ref-type) + (define pos (read-fasl-integer i)) + (unless (pos . < . shared-count) + (read-error "bad graph index")) + (vector-ref shared pos)] + [(fasl-false-type) #f] + [(fasl-true-type) #t] + [(fasl-null-type) null] + [(fasl-void-type) (void)] + [(fasl-eof-type) eof] + [(fasl-integer-type) (intern (read-fasl-integer i))] + [(fasl-flonum-type) (floating-point-bytes->real (read-bytes/exactly 8 i) #f)] + [(fasl-single-flonum-type) (real->single-flonum (floating-point-bytes->real (read-bytes/exactly 4 i) #f))] + [(fasl-rational-type) (intern (/ (loop) (loop)))] + [(fasl-complex-type) (intern (make-rectangular (loop) (loop)))] + [(fasl-char-type) (intern (integer->char (read-fasl-integer i)))] + [(fasl-symbol-type) (string->symbol (read-fasl-string i))] + [(fasl-unreadable-symbol-type) (string->unreadable-symbol (read-fasl-string i))] + [(fasl-uninterned-symbol-type) (string->uninterned-symbol (read-fasl-string i))] + [(fasl-keyword-type) (string->keyword (read-fasl-string i))] + [(fasl-string-type) (read-fasl-string i)] + [(fasl-immutable-string-type) (intern (string->immutable-string (read-fasl-string i)))] + [(fasl-bytes-type) (read-fasl-bytes i)] + [(fasl-immutable-bytes-type) (intern (bytes->immutable-bytes (read-fasl-bytes i)))] + [(fasl-path-type) (bytes->path (read-fasl-bytes i) + (loop))] + [(fasl-relative-path-type) + (define wrt-dir (current-load-relative-directory)) + (define rel-elems (for/list ([p (in-list (loop))]) + (if (bytes? p) (bytes->path-element p) p))) + (cond + [wrt-dir (apply build-path wrt-dir rel-elems)] + [(null? rel-elems) (build-path 'same)] + [else (apply build-path rel-elems)])] + [(fasl-pregexp-type) (intern (pregexp (read-fasl-string i)))] + [(fasl-regexp-type) (intern (regexp (read-fasl-string i)))] + [(fasl-byte-pregexp-type) (intern (byte-pregexp (read-fasl-bytes i)))] + [(fasl-byte-regexp-type) (intern (byte-regexp (read-fasl-bytes i)))] + [(fasl-list-type) + (define len (read-fasl-integer i)) + (for/list ([j (in-range len)]) + (loop))] + [(fasl-pair-type) + (cons (loop) (loop))] + [(fasl-list*-type) + (define len (read-fasl-integer i)) + (let ploop ([len len]) + (if (zero? len) + (loop) + (cons (loop) (ploop (sub1 len)))))] + [(fasl-vector-type fasl-immutable-vector-type) + (define len (read-fasl-integer i)) + (define vec (for/vector #:length len ([j (in-range len)]) + (loop))) + (if (eqv? type fasl-immutable-vector-type) + (vector->immutable-vector vec) + vec)] + [(fasl-box-type) (box (loop))] + [(fasl-immutable-box-type) (box-immutable (loop))] + [(fasl-prefab-type) + (define key (loop)) + (define len (read-fasl-integer i)) + (apply make-prefab-struct + key + (for/list ([j (in-range len)]) + (loop)))] + [(fasl-hash-type) + (define ht (constant-case + (read-byte/no-eof i) + [(fasl-hash-eq-variant) (make-hasheq)] + [(fasl-hash-eqv-variant) (make-hasheqv)] + [else (make-hash)])) + (define len (read-fasl-integer i)) + (for ([j (in-range len)]) + (hash-set! ht (loop) (loop))) + ht] + [(fasl-immutable-hash-type) + (define ht (constant-case + (read-byte/no-eof i) + [(fasl-hash-eq-variant) #hasheq()] + [(fasl-hash-eqv-variant) #hasheqv()] + [else #hash()])) + (define len (read-fasl-integer i)) + (for/fold ([ht ht]) ([j (in-range len)]) + (hash-set ht (loop) (loop)))] + [else + (cond + [(type . >= . fasl-small-integer-start) + (+ (- type fasl-small-integer-start) fasl-lowest-small-integer)] + [else + (read-error "unrecognized fasl tag" "tag" type)])]))) + +;; ---------------------------------------- + +;; Integer encoding: +;; -124 to 127 = direct (as 2's complement) +;; 128 => 2-byte little-endian integer +;; 129 => 4-byte little-endian integer +;; 130 => 8-byte little-endian integer +;; 131 => # of ASCII hex digits followed by digits + +(define (write-fasl-integer i o) + (cond + [(<= -124 i 127) + (if (negative? i) + (write-byte (+ i 256) o) + (write-byte i o))] + [(<= -32768 i 32767) + (write-byte 128 o) + (write-bytes (integer->integer-bytes i 2 #t #f) o)] + [(<= -2147483648 i 2147483647) + (write-byte 129 o) + (write-bytes (integer->integer-bytes i 4 #t #f) o)] + [(<= -9223372036854775808 i 9223372036854775807) + (write-byte 130 o) + (write-bytes (integer->integer-bytes i 8 #t #f) o)] + [else + (write-byte 131 o) + (define s (format "~x" i)) ; always ASCII + (write-fasl-integer (string-length s) o) + (write-string s o)])) + +(define (write-fasl-string v o) + (define bstr (string->bytes/utf-8 v)) + (write-fasl-integer (bytes-length bstr) o) + (write-bytes bstr o)) + +(define (write-fasl-bytes v o) + (write-fasl-integer (bytes-length v) o) + (write-bytes v o)) + +;; ---------------------------------------- + +(define (read-error s . args) + (apply raise-arguments-error + 'fasl-read + (string-append "error parsing fasl stream;\n" + " " s) + args)) + +(define (read-byte/no-eof i) + (cond + [(mpair? i) + (define pos (mcdr i)) + (unless (pos . < . (bytes-length (mcar i))) + (read-error "truncated stream")) + (set-mcdr! i (add1 pos)) + (bytes-ref (mcar i) pos)] + [else + (define b (read-byte i)) + (when (eof-object? b) + (read-error "truncated stream")) + b])) + +(define (read-bytes/exactly n i) + (cond + [(mpair? i) + (define pos (mcdr i)) + (unless ((+ pos n) . <= . (bytes-length (mcar i))) + (read-error "truncated stream")) + (set-mcdr! i (+ pos n)) + (subbytes (mcar i) pos (+ pos n))] + [else + (define bstr (read-bytes n i)) + (unless (and (bytes? bstr) (= n (bytes-length bstr))) + (read-error "truncated stream")) + bstr])) + +(define (read-fasl-integer i) + (define b (read-byte/no-eof i)) + (cond + [(<= b 127) b] + [(>= b 132) (- b 256)] + [(eqv? b 128) + (integer-bytes->integer (read-bytes/exactly 2 i) #f #f)] + [(eqv? b 129) + (integer-bytes->integer (read-bytes/exactly 4 i) #f #f)] + [(eqv? b 130) + (integer-bytes->integer (read-bytes/exactly 8 i) #f #f)] + [(eqv? b 131) + (define len (read-fasl-integer i)) + (define str (read-string len i)) + (unless (and (string? str) (= len (string-length str))) + (read-error "truncated stream at number")) + (string->number str 16)] + [else + (read-error "internal error on integer mode")])) + +(define (read-fasl-string i) + (define len (read-fasl-integer i)) + (define bstr (read-bytes/exactly len i)) + (bytes->string/utf-8 bstr)) + +(define (read-fasl-bytes i) + (define len (read-fasl-integer i)) + (read-bytes/exactly len i)) diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 5d78419c03..ec39750b46 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.90.0.20" +#define MZSCHEME_VERSION "6.90.0.21" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 90 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 20 +#define MZSCHEME_VERSION_W 21 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)