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

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

@ -13,29 +13,29 @@
(define vers-len (min 63 (read-byte in))) (define vers-len (min 63 (read-byte in)))
(define vers (read-bytes vers-len in)) (define vers (read-bytes vers-len in))
(unless (equal? vers version-bytes) (unless (equal? vers version-bytes)
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"version mismatch" "version mismatch"
"expected" (version) "expected" (version)
"found" (bytes->string/utf-8 vers #\?) "found" (bytes->string/utf-8 vers #\?)
"in" (let ([n (object-name in)]) "in" (let ([n (object-name in)])
(if (path? n) (if (path? n)
(unquoted-printing-string (unquoted-printing-string
(path->string n)) (path->string n))
in)))) in))))
(define vm-len (min 63 (read-byte in))) (define vm-len (min 63 (read-byte in)))
(define vm (read-bytes vm-len in)) (define vm (read-bytes vm-len in))
(define as-correlated-linklet? (equal? vm correlated-linklet-vm-bytes)) (define as-correlated-linklet? (equal? vm correlated-linklet-vm-bytes))
(unless (or as-correlated-linklet? (unless (or as-correlated-linklet?
(equal? vm vm-bytes)) (equal? vm vm-bytes))
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"virtual-machine mismatch" "virtual-machine mismatch"
"expected" (bytes->string/utf-8 vm-bytes) "expected" (bytes->string/utf-8 vm-bytes)
"found" (bytes->string/utf-8 vm #\?) "found" (bytes->string/utf-8 vm #\?)
"in" (let ([n (object-name in)]) "in" (let ([n (object-name in)])
(if (path? n) (if (path? n)
(unquoted-printing-string (unquoted-printing-string
(path->string n)) (path->string n))
in)))) in))))
(define tag (read-byte in)) (define tag (read-byte in))
(cond (cond
[(eqv? tag (char->integer #\B)) [(eqv? tag (char->integer #\B))
@ -44,14 +44,14 @@
(read-correlated-linklet-bundle-hash in) (read-correlated-linklet-bundle-hash in)
(read-linklet-bundle-hash in))) (read-linklet-bundle-hash in)))
(unless (hash? b-ht) (unless (hash? b-ht)
(raise-arguments-error 'read-linklet-bundle-hash (raise-read-error 'read-linklet-bundle-hash
"bad read result" "bad read result"
"expected" "hash/c" "expected" "hash/c"
"found" (format "~s" b-ht) "found" (format "~s" b-ht)
"in" (let ([n (object-name in)]) "in" (let ([n (object-name in)])
(if (path? n) (if (path? n)
(path->string n) (path->string n)
in)))) in))))
(hash->linklet-bundle (hash->linklet-bundle
(add-hash-code (if initial? (add-hash-code (if initial?
@ -60,12 +60,12 @@
sha-1))] sha-1))]
[(eqv? tag (char->integer #\D)) [(eqv? tag (char->integer #\D))
(unless initial? (unless initial?
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"expected a linklet bundle")) "expected a linklet bundle"))
(read-bundle-directory start-pos)] (read-bundle-directory start-pos)]
[else [else
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"expected a `B` or `D`")])) "expected a `B` or `D`")]))
(define (read-bundle-directory pos) (define (read-bundle-directory pos)
(define count (read-int in)) (define count (read-int in))
@ -89,8 +89,8 @@
[else [else
(define name (hash-ref position-to-name (- (file-position in) pos) #f)) (define name (hash-ref position-to-name (- (file-position in) pos) #f))
(unless name (unless name
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"bundle not at an expected file position")) "bundle not at an expected file position"))
(define bstr (read-bytes 2 in)) (define bstr (read-bytes 2 in))
(define bundle (define bundle
(cond (cond
@ -99,8 +99,8 @@
[(equal? #"#f" bstr) [(equal? #"#f" bstr)
#f] #f]
[else [else
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"expected a `#~` or `#f` for a bundle")])) "expected a `#~` or `#f` for a bundle")]))
(loop (sub1 count) (loop (sub1 count)
(cons (cons (decode-name name 0) bundle) accum))]))) (cons (cons (decode-name name 0) bundle) accum))])))
@ -113,8 +113,8 @@
(define (decode-name bstr pos) (define (decode-name bstr pos)
(define blen (bytes-length bstr)) (define blen (bytes-length bstr))
(define (bad-bundle) (define (bad-bundle)
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"malformed bundle")) "malformed bundle"))
(cond (cond
[(= pos blen) [(= pos blen)
'()] '()]
@ -138,15 +138,15 @@
;; bottom-up ;; bottom-up
(let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)]) (let loop ([l l] [prev-len 0] [stack '()] [accum (hasheq)])
(when (null? l) (when (null? l)
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"invalid bundle sequence")) "invalid bundle sequence"))
(let* ([p (car l)] (let* ([p (car l)]
[path (car p)] [path (car p)]
[v (cdr p)] [v (cdr p)]
[len (length path)]) [len (length path)])
(when (< len prev-len) (when (< len prev-len)
(raise-arguments-error 'read-compiled-linklet (raise-read-error 'read-compiled-linklet
"invalid bundle sequence")) "invalid bundle sequence"))
(let sloop ([prev-len prev-len] [stack stack] [accum accum]) (let sloop ([prev-len prev-len] [stack stack] [accum accum])
(cond (cond
[(> len (add1 prev-len)) [(> len (add1 prev-len))
@ -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") (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 b-ht
(hash-set b-ht 'hash-code sha-1))) (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)))

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

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