suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/fasl: switch to version-independent format

Browse Source 
Make `s-exp->fasl` generate an encoding that can be parsed by any
future version of `fasl->s-exp`. The new format does not rely on the
runtime system's bytecode writer and reader.
This commit is contained in:
Matthew Flatt 2018-03-13 13:52:30 -06:00
parent 2195efa08d
commit 85ff4eee74
6 changed files with 667 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -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]))

51
pkgs/racket-doc/scribblings/reference/fasl.scrbl
View File

@ -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.}]}
@; ----------------------------------------------------------------------

1
pkgs/racket-test-core/tests/racket/all.rktl
View File

@ -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")

104
pkgs/racket-test-core/tests/racket/fasl.rktl Normal file
View File

@ -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)

543
racket/collects/racket/fasl.rkt
View File

@ -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))

4
racket/src/racket/src/schvers.h
View File

@ -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)