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

expander: fix ".zo" mismatch errors to be exn:fail:read

Browse Source
This commit is contained in:
Matthew Flatt 2019-01-29 16:35:12 -07:00
parent ed301f8a7c
commit b9a28b368f
2 changed files with 101 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
racket/src/expander/compile/read-linklet.rkt
View File

@ -13,7 +13,7 @@
(define vers-len (min 63 (read-byte in)))
(define vers (read-bytes vers-len in))
(unless (equal? vers version-bytes)
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"version mismatch"
"expected" (version)
"found" (bytes->string/utf-8 vers #\?)
@ -27,7 +27,7 @@
(define as-correlated-linklet? (equal? vm correlated-linklet-vm-bytes))
(unless (or as-correlated-linklet?
(equal? vm vm-bytes))
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"virtual-machine mismatch"
"expected" (bytes->string/utf-8 vm-bytes)
"found" (bytes->string/utf-8 vm #\?)
@ -44,7 +44,7 @@
(read-correlated-linklet-bundle-hash in)
(read-linklet-bundle-hash in)))
(unless (hash? b-ht)
(raise-arguments-error 'read-linklet-bundle-hash
(raise-read-error 'read-linklet-bundle-hash
"bad read result"
"expected" "hash/c"
"found" (format "~s" b-ht)
@ -60,11 +60,11 @@
sha-1))]
[(eqv? tag (char->integer #\D))
(unless initial?
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"expected a linklet bundle"))
(read-bundle-directory start-pos)]
[else
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"expected a `B` or `D`")]))
(define (read-bundle-directory pos)
@ -89,7 +89,7 @@
[else
(define name (hash-ref position-to-name (- (file-position in) pos) #f))
(unless name
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"bundle not at an expected file position"))
(define bstr (read-bytes 2 in))
(define bundle
@ -99,7 +99,7 @@
[(equal? #"#f" bstr)
#f]
[else
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"expected a `#~` or `#f` for a bundle")]))
(loop (sub1 count)
(cons (cons (decode-name name 0) bundle) accum))])))
@ -113,7 +113,7 @@
(define (decode-name bstr pos)
(define blen (bytes-length bstr))
(define (bad-bundle)
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"malformed bundle"))
(cond
[(= pos blen)
@ -138,14 +138,14 @@
;; bottom-up
(let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)])
(when (null? l)
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"invalid bundle sequence"))
(let* ([p (car l)]
[path (car p)]
[v (cdr p)]
[len (length path)])
(when (< len prev-len)
(raise-arguments-error 'read-compiled-linklet
(raise-read-error 'read-compiled-linklet
"invalid bundle sequence"))
(let sloop ([prev-len prev-len] [stack stack] [accum accum])
(cond
@ -190,3 +190,19 @@
(if (bytes=? sha-1 #"\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0")
b-ht
(hash-set b-ht 'hash-code sha-1)))
(define (raise-read-error who msg . details)
(raise
(exn:fail:read
(apply
string-append
(format "~a: ~a" who msg)
(let loop ([details details])
(cond
[(null? details) null]
[else
(list*
" " (car details) ": " (format "~v" (cadr details))
(loop (cddr details)))])))
(current-continuation-marks)
null)))

56
racket/src/racket/src/startup.inc
View File

@ -53,6 +53,7 @@ static const char *startup_source =
"(1/namespace-require namespace-require)"
"(1/namespace-syntax-introduce namespace-syntax-introduce)"
"(1/namespace-variable-value namespace-variable-value)"
"(path-list-string->path-list path-list-string->path-list)"
"(1/read read)"
"(1/read-accept-compiled read-accept-compiled)"
"(1/read-syntax read-syntax)"
@ -60769,7 +60770,7 @@ static const char *startup_source =
"(if(equal? vers_0 version-bytes$1)"
"(void)"
"(let-values()"
"(raise-arguments-error"
"(raise-read-error"
" 'read-compiled-linklet"
" \"version mismatch\""
" \"expected\""
@ -60792,7 +60793,7 @@ static const char *startup_source =
"(if or-part_0 or-part_0(equal? vm_0 vm-bytes$1)))"
"(void)"
"(let-values()"
"(raise-arguments-error"
"(raise-read-error"
" 'read-compiled-linklet"
" \"virtual-machine mismatch\""
" \"expected\""
@ -60817,7 +60818,7 @@ static const char *startup_source =
"(if(hash? b-ht_0)"
"(void)"
"(let-values()"
"(raise-arguments-error"
"(raise-read-error"
" 'read-linklet-bundle-hash"
" \"bad read result\""
" \"expected\""
@ -60837,12 +60838,12 @@ static const char *startup_source =
"(if initial?_0"
"(void)"
"(let-values()"
"(raise-arguments-error"
"(raise-read-error"
" 'read-compiled-linklet"
" \"expected a linklet bundle\")))"
"(read-bundle-directory_0 start-pos_0)))"
"(let-values()"
"(raise-arguments-error"
"(raise-read-error"
" 'read-compiled-linklet"
" \"expected a `B` or `D`\"))))))))))))))))"
"((read-bundle-directory_0)"
@ -60892,7 +60893,7 @@ static const char *startup_source =
"(if name_0"
"(void)"
"(let-values()"
"(raise-arguments-error"
"(raise-read-error"
" 'read-compiled-linklet"
" \"bundle not at an expected file position\")))"
"(values))))"
@ -60904,7 +60905,7 @@ static const char *startup_source =
" (if (equal? #\"#f\" bstr_0)"
"(let-values() #f)"
"(let-values()"
"(raise-arguments-error"
"(raise-read-error"
" 'read-compiled-linklet"
" \"expected a `#~` or `#f` for a bundle\"))))))"
"(loop_0"
@ -60923,8 +60924,7 @@ static const char *startup_source =
"(begin"
"(let-values(((blen_0)(bytes-length bstr_0)))"
"(let-values(((bad-bundle_0)"
"(lambda()"
" (begin 'bad-bundle (raise-arguments-error 'read-compiled-linklet \"malformed bundle\")))))"
" (lambda () (begin 'bad-bundle (raise-read-error 'read-compiled-linklet \"malformed bundle\")))))"
"(if(= pos_0 blen_0)"
"(let-values() '())"
"(if(> pos_0 blen_0)"
@ -60955,7 +60955,7 @@ static const char *startup_source =
" 'loop"
"(begin"
"(if(null? l_1)"
" (let-values () (raise-arguments-error 'read-compiled-linklet \"invalid bundle sequence\"))"
" (let-values () (raise-read-error 'read-compiled-linklet \"invalid bundle sequence\"))"
"(void))"
"(let-values(((p_0)(car l_1)))"
"(let-values(((path_0)(car p_0)))"
@ -60964,7 +60964,7 @@ static const char *startup_source =
"(begin"
"(if(< len_0 prev-len_0)"
"(let-values()"
" (raise-arguments-error 'read-compiled-linklet \"invalid bundle sequence\"))"
" (raise-read-error 'read-compiled-linklet \"invalid bundle sequence\"))"
"(void))"
"((letrec-values(((sloop_0)"
"(lambda(prev-len_1 stack_1 accum_1)"
@ -61029,6 +61029,32 @@ static const char *startup_source =
"(begin"
" (if (bytes=? sha-1_0 #\"\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0\") b-ht_0 (hash-set b-ht_0 'hash-code sha-1_0)))))"
"(define-values"
"(raise-read-error)"
"(lambda(who_0 msg_0 . details_0)"
"(begin"
"(raise"
"(exn:fail:read"
"(apply"
" string-append"
" (format \"~a: ~a\" who_0 msg_0)"
"((letrec-values(((loop_0)"
"(lambda(details_1)"
"(begin"
" 'loop"
"(if(null? details_1)"
"(let-values() null)"
"(let-values()"
"(list*"
" \" \""
"(car details_1)"
" \": \""
" (format \"~v\" (cadr details_1))"
"(loop_0(cddr details_1)))))))))"
" loop_0)"
" details_0))"
"(current-continuation-marks)"
" null)))))"
"(define-values"
"(read-syntax$1)"
"(lambda(src_0 in_0)"
"(begin"
@ -64185,6 +64211,7 @@ static const char *startup_source =
"(lambda(file_1 rep-sfx?_0)"
"(begin"
" 'get-so"
"(if(eq? 'racket(system-type 'vm))"
"(lambda(root-dir_0 compiled-dir_0)"
"(build-path"
"(reroot_0 base_1 root-dir_0)"
@ -64193,7 +64220,8 @@ static const char *startup_source =
"(system-library-subpath)"
"(if rep-sfx?_0"
"(path-add-extension file_1 dll-suffix)"
" file_1)))))))"
" file_1)))"
" #f)))))"
"(let-values(((zo_0)"
"(lambda(root-dir_0 compiled-dir_0)"
"(begin"
@ -64230,12 +64258,14 @@ static const char *startup_source =
" 'with-dir"
"(with-dir*_0 base_1 t_0)))))"
"(let-values(((c4_0)"
"(if so_0"
"(if try-main?_0"
"(date>=?_0"
" modes_0"
" roots_0"
" so_0"
" path-d_0)"
" #f)"
" #f)))"
"(if c4_0"
"((lambda(so-d_0)"
@ -64255,12 +64285,14 @@ static const char *startup_source =
" expect-module_0))))))"
" c4_0)"
"(let-values(((c3_0)"
"(if alt-so_0"
"(if try-alt?_0"
"(date>=?_0"
" modes_0"
" roots_0"
" alt-so_0"
" alt-path-d_0)"
" #f)"
" #f)))"
"(if c3_0"
"((lambda(so-d_0)"