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