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

add path-extension, path-has-extension? and path-{add,replace}-extension

Browse Source 
Provide a cleaned-up set up path-extension functions. In contrast
to `path-{add,replace}-suffix` and `filename-extension`, a dot
at the beginning of a path element is not treated as an extension
separator. Also, `path-extension` returns an extension including
its separator, which is more consistent with other extension
functions.

The new `path-has-extension?` function replaces many uses of
regexp matching in the base collections.

Closes #1307
This commit is contained in:
Matthew Flatt 2016-04-16 15:39:41 -06:00
parent 1e597a885c
commit 4d9427af44
36 changed files with 1940 additions and 1751 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 collection 'multi)
(define version "6.5.0.2") (define version "6.5.0.3")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

122
pkgs/racket-doc/scribblings/reference/paths.scrbl
View File

@ -527,29 +527,73 @@ proportional to the length of @racket[path] (unlike a loop in that
uses @racket[split-path], which must allocate intermediate paths).} uses @racket[split-path], which must allocate intermediate paths).}
@defproc[(path-replace-suffix [path (or/c path-string? path-for-some-system?)] @defproc[(path-replace-extension [path (or/c path-string? path-for-some-system?)]
[suffix (or/c string? bytes?)]) [ext (or/c string? bytes?)])
path-for-some-system?]{ path-for-some-system?]{
Returns a path that is the same as @racket[path], except that the Returns a path that is the same as @racket[path], except that the
suffix for the last element of the path is changed to extension for the last element of the path (including the extension
@racket[suffix]. If the last element of @racket[path] has no suffix, separator) is changed to @racket[ext]. If the last element of
then @racket[suffix] is added to the path. A suffix is defined as a @racket[path] has no extension, then @racket[ext] is added to the
@litchar{.} followed by any number of non-@litchar{.} characters/bytes path.
at the end of the @tech{path element}, as long as the path element is not
@racket[".."] or @racket["."]. The @racket[path] argument can be a
path for any platform, and the result is for the same platform. If
@racket[path] represents a root, the @exnraise[exn:fail:contract].}
@defproc[(path-add-suffix [path (or/c path-string? path-for-some-system?)] An extension is defined as a @litchar{.} that is not at the start of
[suffix (or/c string? bytes?)]) the path element followed by any number of non-@litchar{.}
characters/bytes at the end of the @tech{path element}, as long as the
path element is not a directory indicator like @racket[".."].
The @racket[path] argument can be a path for any platform, and the
result is for the same platform. If @racket[path] represents a root,
the @exnraise[exn:fail:contract]. The given @racket[ext] typically
starts with @litchar{.}, but it is not required to start with an
extension separator.
@examples[
(path-replace-extension "x/y.ss" #".rkt")
(path-replace-extension "x/y.ss" #"")
(path-replace-extension "x/y" #".rkt")
(path-replace-extension "x/y.tar.gz" #".rkt")
(path-replace-extension "x/.racketrc" #".rkt")
]
@history[#:added "6.5.0.3"]}
@defproc[(path-add-extension [path (or/c path-string? path-for-some-system?)]
[ext (or/c string? bytes?)])
path-for-some-system?]{ path-for-some-system?]{
Similar to @racket[path-replace-suffix], but any existing suffix on Similar to @racket[path-replace-extension], but any existing extension on
@racket[path] is preserved by replacing the @litchar{.} before the suffix @racket[path] is preserved by replacing the @litchar{.} before the extension
with @litchar{_}, and then the @racket[suffix] is added with @litchar{_}, and then the @racket[ext] is added
to the end.} to the end.
@examples[
(path-add-extension "x/y.ss" #".rkt")
(path-add-extension "x/y" #".rkt")
(path-add-extension "x/y.tar.gz" #".rkt")
(path-add-extension "x/.racketrc" #".rkt")
]
@history[#:added "6.5.0.3"]}
@defproc[(path-replace-suffix [path (or/c path-string? path-for-some-system?)]
[ext (or/c string? bytes?)])
path-for-some-system?]{
@deprecated[#:what "function" @racket[path-replace-extension]]
Like @racket[path-replace-extension], but treats a leading @litchar{.}
in a path element as an extension separator.}
@defproc[(path-add-suffix [path (or/c path-string? path-for-some-system?)]
[ext (or/c string? bytes?)])
path-for-some-system?]{
@deprecated[#:what "function" @racket[path-add-extension]]
Like @racket[path-add-extension], but treats a leading @litchar{.}
in a path element as an extension separator.}
@defproc[(reroot-path [path (or/c path-string? path-for-some-system?)] @defproc[(reroot-path [path (or/c path-string? path-for-some-system?)]
[root-path (or/c path-string? path-for-some-system?)]) [root-path (or/c path-string? path-for-some-system?)])
@ -590,14 +634,60 @@ Returns the last element of @racket[path]. If @racket[path] is
syntactically a directory path (see @racket[split-path]), then the syntactically a directory path (see @racket[split-path]), then the
result is @racket[#f].} result is @racket[#f].}
@defproc[(path-extension [path (or/c path-string? path-for-some-system?)])
(or/c bytes? #f)]{
Returns a byte string that is the extension part of the filename in
@racket[path], including the @litchar{.} separator. If the path has no
extension, @racket[#f] is returned.
See @racket[path-replace-extension] for the definition of a filename
extension.
@examples[#:eval path-eval
(path-extension "x/y.rkt")
(path-extension "x/y")
(path-extension "x/y.tar.gz")
(path-extension "x/.racketrc")
]
@history[#:added "6.5.0.3"]}
@defproc[(path-has-extension? [path (or/c path-string? path-for-some-system?)]
[ext (or/c bytes? string?)])
(or/c bytes? #f)]{
Determines whether the last element of @racket[path] ends with
@racket[ext] but is not exactly the same as @racket[ext].
If @racket[ext] is a @tech{byte string} with the shape of an extension
(i.e., starting with @litchar{.}), this check is equivalent to
checking whether @racket[(path-extension path)] produces @racket[ext].
@examples[#:eval path-eval
(path-has-extension? "x/y.rkt" #".rkt")
(path-has-extension? "x/y.ss" #".rkt")
(path-has-extension? "x/y" #".rkt")
(path-has-extension? "x/.racketrc" #".racketrc")
(path-has-extension? "x/compiled/y_rkt.zo" #"_rkt.zo")
]
@history[#:added "6.5.0.3"]}
@defproc[(filename-extension [path (or/c path-string? path-for-some-system?)]) @defproc[(filename-extension [path (or/c path-string? path-for-some-system?)])
(or/c bytes? #f)]{ (or/c bytes? #f)]{
@deprecated[#:what "function" @racket[path-extension]]
Returns a byte string that is the extension part of the filename in Returns a byte string that is the extension part of the filename in
@racket[path] without the @litchar{.} separator. If @racket[path] is @racket[path] without the @litchar{.} separator. If @racket[path] is
syntactically a directory (see @racket[split-path]) or if the path has syntactically a directory (see @racket[split-path]) or if the path has
no extension, @racket[#f] is returned.} no extension, @racket[#f] is returned.}
@defproc[(find-relative-path [base (or/c path-string? path-for-some-system?)] @defproc[(find-relative-path [base (or/c path-string? path-for-some-system?)]
[path (or/c path-string? path-for-some-system?)] [path (or/c path-string? path-for-some-system?)]
[#:more-than-root? more-than-root? any/c #f]) [#:more-than-root? more-than-root? any/c #f])

55
pkgs/racket-test-core/tests/racket/path.rktl
View File

@ -12,24 +12,47 @@
(test #t path<? (bytes->path #"a") (bytes->path #"aa")) (test #t path<? (bytes->path #"a") (bytes->path #"aa"))
(test #f path<? (bytes->path #"aa") (bytes->path #"a")) (test #f path<? (bytes->path #"aa") (bytes->path #"a"))
(test (string->path "x.zo") path-replace-suffix "x.rkt" ".zo") (define (test-basic-extension path-replace-extension
(test (string->path "x.zo") path-replace-suffix "x.rkt" #".zo") path-add-extension)
(test (string->path "x.zo") path-replace-suffix "x" #".zo") (test (string->path "x.zo") path-replace-extension "x.rkt" ".zo")
(test (string->path "x.o.zo") path-replace-suffix "x.o.rkt" #".zo") (test (string->path "x.zo") path-replace-extension "x.rkt" #".zo")
(test (string->some-system-path "p/x.zo" 'unix) (test (string->path "x.zo") path-replace-extension "x" #".zo")
path-replace-suffix (string->some-system-path "p/x.rkt" 'unix) ".zo") (test (string->path "x.o.zo") path-replace-extension "x.o.rkt" #".zo")
(test (string->some-system-path "p/x.zo" 'windows) (test (string->some-system-path "p/x.zo" 'unix)
path-replace-suffix (string->some-system-path "p/x.rkt" 'windows) ".zo") path-replace-extension (string->some-system-path "p/x.rkt" 'unix) ".zo")
(test (string->path "x_rkt.zo") path-add-suffix "x.rkt" ".zo") (test (string->some-system-path "p/x.zo" 'windows)
(test (string->path "x_rkt.zo") path-add-suffix "x.rkt" #".zo") path-replace-extension (string->some-system-path "p/x.rkt" 'windows) ".zo")
(test (string->path "x.zo") path-add-suffix "x" #".zo") (test (string->path "x_rkt.zo") path-add-extension "x.rkt" ".zo")
(test (string->path "x.o_rkt.zo") path-add-suffix "x.o.rkt" #".zo") (test (string->path "x_rkt.zo") path-add-extension "x.rkt" #".zo")
(test (string->some-system-path "p/x.zo" 'unix) (test (string->path "x.zo") path-add-extension "x" #".zo")
path-add-suffix (string->some-system-path "p/x" 'unix) ".zo") (test (string->path "x.o_rkt.zo") path-add-extension "x.o.rkt" #".zo")
(test (string->some-system-path "p/x.zo" 'windows) (test (string->some-system-path "p/x.zo" 'unix)
path-add-suffix (string->some-system-path "p/x" 'windows) ".zo") path-add-extension (string->some-system-path "p/x" 'unix) ".zo")
(test (string->some-system-path "p/x.zo" 'windows)
path-add-extension (string->some-system-path "p/x" 'windows) ".zo"))
(test-basic-extension path-replace-extension
path-add-extension)
(test-basic-extension path-replace-suffix
path-add-suffix)
(test (string->path ".zo.y") path-replace-extension ".zo" ".y")
(test (string->path ".zo.y") path-replace-extension ".zo" #".y")
(test (string->path ".zo") path-replace-extension ".zo" "")
(test (string->path ".zo") path-replace-extension ".zo" #"")
(test (string->path ".zo.y") path-add-extension ".zo" ".y")
(test (string->path ".zo.y") path-add-extension ".zo" #".y")
(test (string->path ".tar_gz.y") path-add-extension ".tar.gz" ".y")
(test (string->path ".tar_gz.y") path-add-extension ".tar.gz" #".y")
(test (string->path ".y") path-replace-suffix ".zo" ".y")
(test (string->path ".y") path-replace-suffix ".zo" #".y")
(test (string->path "_zo.y") path-add-suffix ".zo" ".y")
(test (string->path "_zo.y") path-add-suffix ".zo" #".y")
(err/rt-test (path-replace-suffix ".zo" "")) (err/rt-test (path-replace-suffix ".zo" ""))
(err/rt-test (path-replace-suffix ".zo" #"")) (err/rt-test (path-replace-suffix ".zo" #""))
(test (string->path ".tar_gz.y") path-add-suffix ".tar.gz" ".y")
(test (string->path ".tar_gz.y") path-add-suffix ".tar.gz" #".y")
(define (make-/tf p exn?) (define (make-/tf p exn?)
(lambda args (lambda args

13
pkgs/racket-test-core/tests/racket/pathlib.rktl
View File

@ -52,10 +52,23 @@
;; ---------------------------------------- ;; ----------------------------------------
(rtest path-extension "a" #f)
(rtest path-extension "a.sls" #".sls")
(rtest path-extension (bytes->path #"b/a.sls" 'unix) #".sls")
(rtest path-extension (bytes->path #"b\\a.sls" 'windows) #".sls")
(rtest path-extension ".sls" #f)
(test #t path-has-extension? "a.sls" #".sls")
(test #t path-has-extension? "a.sls" ".sls")
(test #f path-has-extension? ".sls" #".sls")
(test #t path-has-extension? "a_sls" #"_sls")
(test #t path-has-extension? "x/a.sls/" #".sls")
(rtest filename-extension "a" #f) (rtest filename-extension "a" #f)
(rtest filename-extension "a.sls" #"sls") (rtest filename-extension "a.sls" #"sls")
(rtest filename-extension (bytes->path #"b/a.sls" 'unix) #"sls") (rtest filename-extension (bytes->path #"b/a.sls" 'unix) #"sls")
(rtest filename-extension (bytes->path #"b\\a.sls" 'windows) #"sls") (rtest filename-extension (bytes->path #"b\\a.sls" 'windows) #"sls")
(rtest filename-extension ".sls" #"sls")
;; ---------------------------------------- ;; ----------------------------------------

38
racket/collects/compiler/cm.rkt
View File

@ -116,7 +116,7 @@
(build-path (build-path
(reroot-path* base root) (reroot-path* base root)
mode mode
(path-add-suffix name #".zo")) (path-add-extension name #".zo"))
#f #f
(lambda () #f))]) (lambda () #f))])
(and v (list* v mode root)))) (and v (list* v mode root))))
@ -134,10 +134,10 @@
[get-zo-path (lambda () [get-zo-path (lambda ()
(let-values ([(name mode root) (let-values ([(name mode root)
(if main-zo-date+mode (if main-zo-date+mode
(values (path-add-suffix name #".zo") (values (path-add-extension name #".zo")
(cadr main-zo-date+mode) (cadr main-zo-date+mode)
(cddr main-zo-date+mode)) (cddr main-zo-date+mode))
(values (path-add-suffix (rkt->ss name) #".zo") (values (path-add-extension (rkt->ss name) #".zo")
(cadr alt-zo-date+mode) (cadr alt-zo-date+mode)
(cddr alt-zo-date+mode)))]) (cddr alt-zo-date+mode)))])
(build-path (reroot-path* base root) mode name)))]) (build-path (reroot-path* base root) mode name)))])
@ -262,8 +262,8 @@
(define (get-source-sha1 p) (define (get-source-sha1 p)
(with-handlers ([exn:fail:filesystem? (lambda (exn) (with-handlers ([exn:fail:filesystem? (lambda (exn)
(and (regexp-match? #rx#"[.]rkt$" p) (and (path-has-extension? p #".rkt")
(get-source-sha1 (path-replace-suffix p #".ss"))))]) (get-source-sha1 (path-replace-extension p #".ss"))))])
(call-with-input-file* p sha1))) (call-with-input-file* p sha1)))
(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen) (define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen)
@ -304,7 +304,7 @@
(define (write-deps code path->mode roots path src-sha1 (define (write-deps code path->mode roots path src-sha1
external-deps external-module-deps reader-deps external-deps external-module-deps reader-deps
up-to-date collection-cache read-src-syntax) up-to-date collection-cache read-src-syntax)
(let ([dep-path (path-add-suffix (get-compilation-path path->mode roots path) #".dep")] (let ([dep-path (path-add-extension (get-compilation-path path->mode roots path) #".dep")]
[deps (remove-duplicates (append (get-deps code path) [deps (remove-duplicates (append (get-deps code path)
external-module-deps ; can create cycles if misused! external-module-deps ; can create cycles if misused!
reader-deps))] reader-deps))]
@ -539,7 +539,7 @@
(trace-printf "maybe-compile-zo starting ~a" actual-path)) (trace-printf "maybe-compile-zo starting ~a" actual-path))
(begin0 (begin0
(parameterize ([indent (+ 2 (indent))]) (parameterize ([indent (+ 2 (indent))])
(let* ([zo-name (path-add-suffix (get-compilation-path path->mode roots path) #".zo")] (let* ([zo-name (path-add-extension (get-compilation-path path->mode roots path) #".zo")]
[zo-exists? (file-exists? zo-name)]) [zo-exists? (file-exists? zo-name)])
(if (and zo-exists? (trust-existing-zos)) (if (and zo-exists? (trust-existing-zos))
(begin (begin
@ -593,9 +593,9 @@
(define (get-compiled-time path->mode roots path) (define (get-compiled-time path->mode roots path)
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
(or (try-file-time (build-path dir "native" (system-library-subpath) (or (try-file-time (build-path dir "native" (system-library-subpath)
(path-add-suffix name (system-type (path-add-extension name (system-type
'so-suffix)))) 'so-suffix))))
(try-file-time (build-path dir (path-add-suffix name #".zo"))))) (try-file-time (build-path dir (path-add-extension name #".zo")))))
(define (try-file-sha1 path dep-path) (define (try-file-sha1 path dep-path)
(with-module-reading-parameterization (with-module-reading-parameterization
@ -608,18 +608,18 @@
(define (get-compiled-sha1 path->mode roots path) (define (get-compiled-sha1 path->mode roots path)
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)) (define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
(let ([dep-path (build-path dir (path-add-suffix name #".dep"))]) (let ([dep-path (build-path dir (path-add-extension name #".dep"))])
(or (try-file-sha1 (build-path dir "native" (system-library-subpath) (or (try-file-sha1 (build-path dir "native" (system-library-subpath)
(path-add-suffix name (system-type (path-add-extension name (system-type
'so-suffix))) 'so-suffix)))
dep-path) dep-path)
(try-file-sha1 (build-path dir (path-add-suffix name #".zo")) (try-file-sha1 (build-path dir (path-add-extension name #".zo"))
dep-path) dep-path)
""))) "")))
(define (rkt->ss p) (define (rkt->ss p)
(if (regexp-match? #rx#"[.]rkt$" p) (if (path-has-extension? p #".rkt")
(path-replace-suffix p #".ss") (path-replace-extension p #".ss")
p)) p))
(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen) (define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen)
@ -629,7 +629,7 @@
(with-module-reading-parameterization (with-module-reading-parameterization
(lambda () (lambda ()
(call-with-input-file (call-with-input-file
(path-add-suffix (get-compilation-path path->mode roots path) #".dep") (path-add-extension (get-compilation-path path->mode roots path) #".dep")
read))))) read)))))
(define (do-check) (define (do-check)
(let* ([main-path orig-path] (let* ([main-path orig-path]
@ -776,7 +776,7 @@
(file-exists? p2))))) (file-exists? p2)))))
(trace-printf "skipping: ~a file does not exist" path) (trace-printf "skipping: ~a file does not exist" path)
(when delete-zos-when-rkt-file-does-not-exist? (when delete-zos-when-rkt-file-does-not-exist?
(define to-delete (path-add-suffix (get-compilation-path path->mode roots path) #".zo")) (define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo"))
(when (file-exists? to-delete) (when (file-exists? to-delete)
(trace-printf "deleting: ~s" to-delete) (trace-printf "deleting: ~s" to-delete)
(with-compiler-security-guard (delete-file to-delete))))] (with-compiler-security-guard (delete-file to-delete))))]
@ -827,7 +827,7 @@
;; Exported: ;; Exported:
(define (get-compiled-file-sha1 path) (define (get-compiled-file-sha1 path)
(try-file-sha1 path (path-replace-suffix path #".dep"))) (try-file-sha1 path (path-replace-extension path #".dep")))
(define (get-file-sha1 path) (define (get-file-sha1 path)
(get-source-sha1 path)) (get-source-sha1 path))

4
racket/collects/compiler/distribute.rkt
View File

@ -96,7 +96,7 @@
"generic" "generic"
(let-values ([(base name dir?) (let-values ([(base name dir?)
(split-path (car binaries))]) (split-path (car binaries))])
(path-replace-suffix name #""))))] (path-replace-extension name #""))))]
[relative-collects-dir [relative-collects-dir
(or collects-path (or collects-path
(build-path specific-lib-dir (build-path specific-lib-dir
@ -702,6 +702,6 @@
b)))) b))))
(let ([no-app (let ([no-app
(let-values ([(base name dir?) (split-path b)]) (let-values ([(base name dir?) (split-path b)])
(path-replace-suffix name #""))]) (path-replace-extension name #""))])
(build-path b "Contents" "MacOS" no-app)) (build-path b "Contents" "MacOS" no-app))
b))) b)))

46
racket/collects/compiler/embed.rkt
View File

@ -103,11 +103,11 @@
[fixup (lambda (re sfx) [fixup (lambda (re sfx)
(if (regexp-match re (path->bytes path)) (if (regexp-match re (path->bytes path))
path path
(path-replace-suffix path sfx)))]) (path-replace-extension path sfx)))])
(case (cross-system-type) (case (cross-system-type)
[(windows) (fixup #rx#"[.][eE][xX][eE]$" #".exe")] [(windows) (fixup #rx#".[.][eE][xX][eE]$" #".exe")]
[(macosx) (if mred? [(macosx) (if mred?
(fixup #rx#"[.][aA][pP][pP]$" #".app") (fixup #rx#".[.][aA][pP][pP]$" #".app")
path)] path)]
[else path]))) [else path])))
@ -116,7 +116,7 @@
(let-values ([(base name dir?) (split-path dest)]) (let-values ([(base name dir?) (split-path dest)])
(build-path dest (build-path dest
"Contents" "MacOS" "Contents" "MacOS"
(path-replace-suffix name #""))) (path-replace-extension name #"")))
dest)) dest))
(define exe-suffix? (define exe-suffix?
@ -149,7 +149,7 @@
(define (prepare-macosx-mred exec-name dest aux variant) (define (prepare-macosx-mred exec-name dest aux variant)
(let* ([name (let-values ([(base name dir?) (split-path dest)]) (let* ([name (let-values ([(base name dir?) (split-path dest)])
(path-replace-suffix name #""))] (path-replace-extension name #""))]
[src (build-path (find-lib-dir) "Starter.app")] [src (build-path (find-lib-dir) "Starter.app")]
[creator (let ([c (assq 'creator aux)]) [creator (let ([c (assq 'creator aux)])
(or (and c (or (and c
@ -383,16 +383,16 @@
(values (reverse dirs) (car l)) (values (reverse dirs) (car l))
(loop (cdr l) (cons (car l) dirs))))) (loop (cdr l) (cons (car l) dirs)))))
(define (adjust-ss/rkt-suffix path) (define (adjust-ss/rkt-extension path)
(cond (cond
[(file-exists? path) path] [(file-exists? path) path]
[(regexp-match? #rx"[.]ss$" path) [(path-has-extension? path #".ss")
(define rkt-path (path-replace-suffix path #".rkt")) (define rkt-path (path-replace-extension path #".rkt"))
(if (file-exists? rkt-path) (if (file-exists? rkt-path)
rkt-path rkt-path
path)] path)]
[(regexp-match? #rx"[.]rkt$" path) [(path-has-extension? path #".rkt")
(define ss-path (path-replace-suffix path #".ss")) (define ss-path (path-replace-extension path #".ss"))
(if (file-exists? ss-path) (if (file-exists? ss-path)
ss-path ss-path
path)] path)]
@ -405,7 +405,7 @@
(let ([p (build-path collects-dest (let ([p (build-path collects-dest
(apply build-path dir) (apply build-path dir)
"compiled" "compiled"
(path-add-suffix file #".zo"))]) (path-add-extension file #".zo"))])
(let-values ([(base name dir?) (split-path p)]) (let-values ([(base name dir?) (split-path p)])
(make-directory* base) (make-directory* base)
p)))) p))))
@ -426,7 +426,7 @@
;; main module even if a submodule is include in `filename`. ;; main module even if a submodule is include in `filename`.
[use-source? [use-source?
(and (not a) (and (not a)
(src-filter (adjust-ss/rkt-suffix (strip-submod filename))))] (src-filter (adjust-ss/rkt-extension (strip-submod filename))))]
;; When using source or writing to collects, keep full modules: ;; When using source or writing to collects, keep full modules:
[keep-full? (or use-source? collects-dest)] [keep-full? (or use-source? collects-dest)]
;; When keeping a full module, strip away submodule paths: ;; When keeping a full module, strip away submodule paths:
@ -467,9 +467,9 @@
null)] null)]
[just-filename (strip-submod filename)] [just-filename (strip-submod filename)]
[root-module-path (strip-submod module-path)] [root-module-path (strip-submod module-path)]
[actual-filename just-filename] ; `set!'ed below to adjust file suffix [actual-filename just-filename] ; `set!'ed below to adjust file extension
[name (let-values ([(base name dir?) (split-path just-filename)]) [name (let-values ([(base name dir?) (split-path just-filename)])
(path->string (path-replace-suffix name #"")))] (path->string (path-replace-extension name #"")))]
[prefix (let ([a (assoc just-filename prefixes)]) [prefix (let ([a (assoc just-filename prefixes)])
(if a (if a
(cdr a) (cdr a)
@ -785,7 +785,7 @@
(if (regexp-match #rx"^[^/.]*$" (cadr path)) (if (regexp-match #rx"^[^/.]*$" (cadr path))
(string-append (cadr path) "/main.ss") (string-append (cadr path) "/main.ss")
(if (regexp-match #rx"^[^.]*$" (cadr path)) (if (regexp-match #rx"^[^.]*$" (cadr path))
;; need a suffix: ;; need an extension:
(string-append (cadr path) ".ss") (string-append (cadr path) ".ss")
(cadr path))))] (cadr path))))]
[else [else
@ -898,7 +898,7 @@
(if (regexp-match #rx"^[^/.]*$" (cadr name)) (if (regexp-match #rx"^[^/.]*$" (cadr name))
(string-append (cadr name) "/main.rkt") (string-append (cadr name) "/main.rkt")
(if (regexp-match #rx"^[^.]*$" (cadr name)) (if (regexp-match #rx"^[^.]*$" (cadr name))
;; need a suffix: ;; need an extension:
(string-append (cadr name) ".rkt") (string-append (cadr name) ".rkt")
(ss->rkt (cadr name))))) (ss->rkt (cadr name)))))
;; old-style multi-string ;; old-style multi-string
@ -909,7 +909,7 @@
(ss->rkt (cadr name)))) (ss->rkt (cadr name))))
(if (eq? 'planet (car name)) (if (eq? 'planet (car name))
(letrec-values ([(split) (letrec-values ([(split)
(lambda (s rx suffix-after) (lambda (s rx extension-after)
(let-values ([(m) (regexp-match-positions (let-values ([(m) (regexp-match-positions
rx rx
s)]) s)])
@ -917,9 +917,9 @@
(cons (substring s 0 (caar m)) (cons (substring s 0 (caar m))
(split (substring s (cdar m)) (split (substring s (cdar m))
rx rx
(- suffix-after 1))) (- extension-after 1)))
(list (list
(if (suffix-after . <= . 0) (if (extension-after . <= . 0)
(if (regexp-match? #rx"[.]" s) (if (regexp-match? #rx"[.]" s)
s s
(string-append s ".rkt")) (string-append s ".rkt"))
@ -1098,13 +1098,13 @@
(define (ss<->rkt path mk-full) (define (ss<->rkt path mk-full)
(cond (cond
[(regexp-match? #rx#"[.]ss$" path) [(path-has-extension? path #".ss")
(ss<->rkt (path-replace-suffix path #".rkt") mk-full)] (ss<->rkt (path-replace-extension path #".rkt") mk-full)]
[(regexp-match? #rx#"[.]rkt$" path) [(path-has-extension? path #".rkt")
(define full-path (mk-full path)) (define full-path (mk-full path))
(if (file-exists? full-path) (if (file-exists? full-path)
full-path full-path
(let ([p2 (mk-full (path-replace-suffix path #".ss"))]) (let ([p2 (mk-full (path-replace-extension path #".ss"))])
(if (file-exists? p2) (if (file-exists? p2)
p2 p2
full-path)))] full-path)))]

14
racket/collects/compiler/private/xform.rkt
View File

@ -36,8 +36,8 @@
(define source-is-c++? (regexp-match #rx"([.]cc$)|([.]cxx$)" file-in)) (define source-is-c++? (regexp-match #rx"([.]cc$)|([.]cxx$)" file-in))
(define (change-suffix filename new) (define (change-extension filename new)
(path-replace-suffix filename new)) (path-replace-extension filename new))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; "AST" structures ;; "AST" structures
@ -488,10 +488,10 @@
(define recorded-cpp-out (define recorded-cpp-out
(and precompiling-header? (and precompiling-header?
(open-output-file (change-suffix file-out #".e") #:exists 'truncate))) (open-output-file (change-extension file-out #".e") #:exists 'truncate)))
(define recorded-cpp-in (define recorded-cpp-in
(and precompiled-header (and precompiled-header
(open-input-file (change-suffix precompiled-header #".e")))) (open-input-file (change-extension precompiled-header #".e"))))
(define re:boring #rx#"^(?:(?:[ \t]*)|(?:# .*)|(?:#line .*)|(?:#pragma implementation.*)|(?:#pragma interface.*)|(?:#pragma once)|(?:#pragma warning.*)|(?:#ident.*))$") (define re:boring #rx#"^(?:(?:[ \t]*)|(?:# .*)|(?:#line .*)|(?:#pragma implementation.*)|(?:#pragma interface.*)|(?:#pragma once)|(?:#pragma warning.*)|(?:#ident.*))$")
(define re:uninteresting #rx#"^(?:(?:[ \t]*)|(?:# .*)|(?:#line .*)|(?:#pragma implementation.*)|(?:#pragma interface.*)|(?:#pragma once)|(?:#pragma GCC diagnostic.*)|(?:#pragma warning.*)|(?:#ident.*))$") (define re:uninteresting #rx#"^(?:(?:[ \t]*)|(?:# .*)|(?:#line .*)|(?:#pragma implementation.*)|(?:#pragma interface.*)|(?:#pragma once)|(?:#pragma GCC diagnostic.*)|(?:#pragma warning.*)|(?:#ident.*))$")
(define (skip-to-interesting-line p) (define (skip-to-interesting-line p)
@ -1111,7 +1111,7 @@
(namespace-set-variable-value! (car v) (cdr v)))) (namespace-set-variable-value! (car v) (cdr v))))
(namespace-set-variable-value! 'make-short-tok make-short-tok) (namespace-set-variable-value! 'make-short-tok make-short-tok)
;; Load the pre-compiled-header-as-.zo: ;; Load the pre-compiled-header-as-.zo:
(let ([l (load (change-suffix precompiled-header #".zo"))]) (let ([l (load (change-extension precompiled-header #".zo"))])
(for-each (lambda (x) (for-each (lambda (x)
(hash-set! used-symbols (car x) (hash-set! used-symbols (car x)
(+ (+
@ -4168,7 +4168,7 @@
non-gcing-functions non-gcing-functions
non-aliasing-functions non-aliasing-functions
(list 'quote gc-var-stack-mode))]) (list 'quote gc-var-stack-mode))])
(with-output-to-file (change-suffix file-out #".zo") (with-output-to-file (change-extension file-out #".zo")
(lambda () (lambda ()
(let ([orig (current-namespace)]) (let ([orig (current-namespace)])
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
@ -4194,7 +4194,7 @@
(error 'xform "Errors converting")) (error 'xform "Errors converting"))
(when output-depends-info? (when output-depends-info?
(with-output-to-file (change-suffix file-out #".sdep") (with-output-to-file (change-extension file-out #".sdep")
(lambda () (lambda ()
(write (hash-map depends-files (lambda (k v) k))) (write (hash-map depends-files (lambda (k v) k)))
(newline)) (newline))

16
racket/collects/dynext/file.rkt
View File

@ -15,21 +15,21 @@
extract-base-filename/ext) extract-base-filename/ext)
(define (append-zo-suffix s) (define (append-zo-suffix s)
(path-add-suffix s #".zo")) (path-add-extension s #".zo"))
(define (append-c-suffix s) (define (append-c-suffix s)
(path-add-suffix s #".c")) (path-add-extension s #".c"))
(define (append-constant-pool-suffix s) (define (append-constant-pool-suffix s)
(path-add-suffix s #".kp")) (path-add-extension s #".kp"))
(define (append-object-suffix s) (define (append-object-suffix s)
(path-add-suffix s (case (system-type) (path-add-extension s (case (system-type)
[(unix macosx) #".o"] [(unix macosx) #".o"]
[(windows) #".obj"]))) [(windows) #".obj"])))
(define (append-extension-suffix s) (define (append-extension-suffix s)
(path-add-suffix s (system-type 'so-suffix))) (path-add-extension s (system-type 'so-suffix)))
(define (extract-suffix appender) (define (extract-suffix appender)
(subbytes (path->bytes (appender (bytes->path #"x"))) 1)) (subbytes (path->bytes (appender (bytes->path #"x"))) 1))
@ -47,7 +47,7 @@
(if simple (if simple
(error program "not a ~a filename (doesn't end with ~a): ~a" (error program "not a ~a filename (doesn't end with ~a): ~a"
kind simple s) kind simple s)
(path-replace-suffix s #""))] (path-replace-extension s #""))]
[else #f])) [else #f]))
(define module-suffix-regexp (define module-suffix-regexp

20
racket/collects/launcher/launcher.rkt
View File

@ -174,13 +174,13 @@
[(macosx) (and mred? (not (script-variant? variant)))]))]) [(macosx) (and mred? (not (script-variant? variant)))]))])
(if (string=? "" s) (if (string=? "" s)
path path
(path-replace-suffix (path-replace-extension
path path
(string->bytes/utf-8 (string->bytes/utf-8
(if (and (eq? 'windows (cross-system-type)) (if (and (eq? 'windows (cross-system-type))
(regexp-match #rx#"[.]exe$" (path->bytes path))) (path-has-extension? path #".exe"))
(format "~a.exe" s) (format "~a.exe" s)
s)))))) s))))))
(define (string-append/spaces f flags) (define (string-append/spaces f flags)
(string-append* (append-map (lambda (x) (list (f x) " ")) flags))) (string-append* (append-map (lambda (x) (list (f x) " ")) flags)))
@ -515,8 +515,8 @@
(define dir (if user? (define dir (if user?
(find-user-apps-dir) (find-user-apps-dir)
(find-apps-dir))) (find-apps-dir)))
(path-replace-suffix (build-path dir (file-name-from-path dest)) (path-replace-extension (build-path dir (file-name-from-path dest))
#".desktop")) #".desktop"))
(define (installed-desktop-path->icon-path dest user? extension) (define (installed-desktop-path->icon-path dest user? extension)
;; We put icons files in "share" so that `setup/unixstyle-install' ;; We put icons files in "share" so that `setup/unixstyle-install'
@ -532,7 +532,7 @@
(build-path (if user? (build-path (if user?
(find-user-share-dir) (find-user-share-dir)
(find-share-dir)) (find-share-dir))
(path-replace-suffix (path-replace-extension
(file-name-from-path dest) (file-name-from-path dest)
(bytes-append (bytes-append
#"-exe-icon." #"-exe-icon."
@ -770,7 +770,7 @@
[else flags])) [else flags]))
(define (strip-suffix s) (define (strip-suffix s)
(path-replace-suffix s #"")) (path-replace-extension s #""))
(define (extract-aux-from-path path) (define (extract-aux-from-path path)
(define path-bytes (path->bytes (if (string? path) (define path-bytes (path->bytes (if (string? path)
@ -879,7 +879,7 @@
(define (build-aux-from-path aux-root) (define (build-aux-from-path aux-root)
(let ([aux-root (if (string? aux-root) (string->path aux-root) aux-root)]) (let ([aux-root (if (string? aux-root) (string->path aux-root) aux-root)])
(define (try suffix) (define (try suffix)
(let ([p (path-replace-suffix aux-root suffix)]) (let ([p (path-replace-extension aux-root suffix)])
(if (file-exists? p) (if (file-exists? p)
(extract-aux-from-path p) (extract-aux-from-path p)
null))) null)))
@ -950,7 +950,7 @@
mred?)]) mred?)])
(if (and (eq? (cross-system-type) 'macosx) (if (and (eq? (cross-system-type) 'macosx)
(not (script-variant? variant))) (not (script-variant? variant)))
(path-replace-suffix p #".app") (path-replace-extension p #".app")
p)))) p))))
(define (gracket-program-launcher-path name #:user? [user? #f] #:tethered? [tethered? #f]) (define (gracket-program-launcher-path name #:user? [user? #f] #:tethered? [tethered? #f])

11
racket/collects/pkg/name.rkt
View File

@ -3,6 +3,7 @@
racket/contract racket/contract
racket/format racket/format
racket/string racket/string
racket/path
net/url) net/url)
(provide (provide
@ -45,9 +46,9 @@
(validate-name (validate-name
(and name+ext (and name+ext
(path->string (path->string
(if (regexp-match #rx#"[.]tar[.]gz$" name+ext) (if (path-has-extension? name+ext #".tar.gz")
(path-replace-suffix (path-replace-suffix name+ext #"") #"") (path-replace-extension (path-replace-extension name+ext #"") #"")
(path-replace-suffix name+ext #"")))) (path-replace-extension name+ext #""))))
complain complain
#t)) #t))
@ -102,7 +103,7 @@
(and (cor (path-string? s) (and (cor (path-string? s)
(complain "ill-formed path")) (complain "ill-formed path"))
(cor (regexp-match rx:archive s) (cor (regexp-match rx:archive s)
(complain "path does not end with a recognized archive suffix")) (complain "path does not end with a recognized archive extension"))
(let () (let ()
(define-values (base name+ext dir?) (if (path-string? s) (define-values (base name+ext dir?) (if (path-string? s)
(split-path s) (split-path s)
@ -231,7 +232,7 @@
(and (cor (pair? p) (and (cor (pair? p)
(complain "URL path is empty")) (complain "URL path is empty"))
(cor (string-and-regexp-match? rx:archive (path/param-path (last p))) (cor (string-and-regexp-match? rx:archive (path/param-path (last p)))
(complain "URL does not end with a recognized archive suffix")) (complain "URL does not end with a recognized archive extension"))
(extract-archive-name (last-non-empty p) complain-name))) (extract-archive-name (last-non-empty p) complain-name)))
(values name 'file-url)] (values name 'file-url)]
[(if type [(if type

2
racket/collects/pkg/private/addl-installs.rkt
View File

@ -76,7 +76,7 @@
(string-foldcase (string-foldcase
(if ((length doc) . < . 4) (if ((length doc) . < . 4)
(let-values ([(base name dir?) (split-path (car doc))]) (let-values ([(base name dir?) (split-path (car doc))])
(path->string (path-replace-suffix name #""))) (path->string (path-replace-extension name #"")))
(list-ref doc 3))))])))) (list-ref doc 3))))]))))
(define (extract-paths i tag keys) (define (extract-paths i tag keys)
(define (get k) (define (get k)

2
racket/collects/pkg/private/archive.rkt
View File

@ -123,7 +123,7 @@
(match-define (pkg-info _ checksum _) pkg-i) (match-define (pkg-info _ checksum _) pkg-i)
(with-handlers ([exn:fail? (λ (exn) (package-exn-handler name exn))]) (with-handlers ([exn:fail? (λ (exn) (package-exn-handler name exn))])
(define pkg-file (build-path dest-dir "pkgs" (format "~a.zip" name))) (define pkg-file (build-path dest-dir "pkgs" (format "~a.zip" name)))
(define pkg-checksum-file (path-replace-suffix pkg-file #".zip.CHECKSUM")) (define pkg-checksum-file (path-replace-extension pkg-file #".zip.CHECKSUM"))
(define pkg-dir (pkg-directory name)) (define pkg-dir (pkg-directory name))
(unless pkg-dir (unless pkg-dir

2
racket/collects/pkg/private/catalog-archive.rkt
View File

@ -66,7 +66,7 @@
(and (= 1 (length l)) (and (= 1 (length l))
(db:pkg-checksum (car l)))))) (db:pkg-checksum (car l))))))
(define pkg-file (build-path dest-dir "pkgs" (format "~a.zip" name))) (define pkg-file (build-path dest-dir "pkgs" (format "~a.zip" name)))
(define pkg-checksum-file (path-replace-suffix pkg-file #".zip.CHECKSUM")) (define pkg-checksum-file (path-replace-extension pkg-file #".zip.CHECKSUM"))
(unless (and current-checksum (unless (and current-checksum
(equal? current-checksum (db:pkg-checksum pkg)) (equal? current-checksum (db:pkg-checksum pkg))
(file-exists? pkg-file) (file-exists? pkg-file)

2
racket/collects/pkg/private/catalog.rkt
View File

@ -21,7 +21,7 @@
db-path?) db-path?)
(define (db-path? p) (define (db-path? p)
(regexp-match? #rx"[.]sqlite$" (path->bytes p))) (path-has-extension? p #".sqlite"))
(define (catalog-dispatch i server db dir) (define (catalog-dispatch i server db dir)
(cond (cond

4
racket/collects/pkg/private/check-will-exist.rkt
View File

@ -26,9 +26,9 @@
#:deleted-result [deleted-result #f]) #:deleted-result [deleted-result #f])
(define v (define v
(or (file-exists? f) (or (file-exists? f)
(file-exists? (path-replace-suffix f #".ss")) (file-exists? (path-replace-extension f #".ss"))
(and (or (file-exists? (get-compilation-bytecode-file f)) (and (or (file-exists? (get-compilation-bytecode-file f))
(file-exists? (get-compilation-bytecode-file (path-replace-suffix f #".ss")))) (file-exists? (get-compilation-bytecode-file (path-replace-extension f #".ss"))))
;; found bytecode; make sure it won't be deleted by `raco setup` ;; found bytecode; make sure it won't be deleted by `raco setup`
(or (bytecode-will-stick-around? f mp metadata-ns) (or (bytecode-will-stick-around? f mp metadata-ns)
deleted-result)))) deleted-result))))

8
racket/collects/racket/include.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base (require (for-syntax racket/base
racket/path
syntax/path-spec syntax/path-spec
"private/increader.rkt" "private/increader.rkt"
compiler/cm-accomplice)) compiler/cm-accomplice))
@ -20,10 +21,9 @@
[reader (syntax reader)] [reader (syntax reader)]
[orig-stx (syntax orig-stx)] [orig-stx (syntax orig-stx)]
[rkt->ss (lambda (p) [rkt->ss (lambda (p)
(let ([b (path->bytes p)]) (if (path-has-extension? p #".rkt")
(if (regexp-match? #rx#"[.]rkt$" b) (path-replace-extension p #".ss")
(path-replace-suffix p #".ss") p))])
p)))])
(let ([c-file (if (file-exists? orig-c-file) (let ([c-file (if (file-exists? orig-c-file)
orig-c-file orig-c-file

25
racket/collects/racket/path.rkt
View File

@ -3,6 +3,8 @@
(provide find-relative-path (provide find-relative-path
simple-form-path simple-form-path
normalize-path normalize-path
path-has-extension?
path-extension
filename-extension filename-extension
file-name-from-path file-name-from-path
path-only path-only
@ -163,7 +165,28 @@
[(path-for-some-system? base) base] [(path-for-some-system? base) base]
[else #f]))) [else #f])))
;; name can be any string; we just look for a dot (define (path-has-extension? name sfx)
(unless (path-string? name)
(raise-argument-error 'path-extension=? "path-string?" name))
(unless (or (bytes? sfx) (string? sfx))
(raise-argument-error 'path-extension=? "(or/c bytes? string?)" name))
(let-values ([(base file dir?) (split-path name)])
(and base
(path? file)
(let* ([bs (path-element->bytes file)]
[sfx (if (bytes? sfx) sfx (string->bytes/utf-8 sfx))]
[len (bytes-length bs)]
[slen (bytes-length sfx)])
(and (len . > . slen)
(bytes=? sfx (subbytes bs (- len slen))))))))
(define (path-extension name)
(let* ([name (file-name 'filename-extension name)]
[name (and name (path->bytes name))])
(cond [(and name (regexp-match #rx#"(?<=.)([.][^.]+)$" name)) => cadr]
[else #f])))
;; This old variant doesn't correctly handle filenames that start with ".":
(define (filename-extension name) (define (filename-extension name)
(let* ([name (file-name 'filename-extension name)] (let* ([name (file-name 'filename-extension name)]
[name (and name (path->bytes name))]) [name (and name (path->bytes name))])

6
racket/collects/racket/private/misc.rkt
View File

@ -4,7 +4,7 @@
(module misc '#%kernel (module misc '#%kernel
(#%require '#%utils ; built into racket (#%require '#%utils ; built into racket
"small-scheme.rkt" "define.rkt" "small-scheme.rkt" "define.rkt" "path.rkt"
(for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt")) (for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt"))
;; ------------------------------------------------------------------------- ;; -------------------------------------------------------------------------
@ -245,7 +245,9 @@
(#%provide define-syntax-rule (#%provide define-syntax-rule
rationalize rationalize
path-string? path-replace-suffix path-add-suffix path-string?
path-replace-suffix path-add-suffix
path-replace-extension path-add-extension
normal-case-path reroot-path normal-case-path reroot-path
read-eval-print-loop read-eval-print-loop
load/cd load/cd

70
racket/collects/racket/private/path.rkt Normal file
View File

@ -0,0 +1,70 @@
;; Old variants of `path-replace-extension` and
;; `path-add-extension` that do the wrong thing with
;; file names that start "."
(module path '#%kernel
(#%require '#%min-stx)
(#%provide path-replace-suffix
path-add-suffix)
(define-values (path-string?)
(lambda (s)
(or (path? s)
(and (string? s)
(or (relative-path? s)
(absolute-path? s))))))
(define-values (check-suffix-call)
(lambda (s sfx who)
(unless (or (path-for-some-system? s)
(path-string? s))
(raise-argument-error who "(or/c path-for-some-system? path-string?)" 0 s sfx))
(unless (or (string? sfx) (bytes? sfx))
(raise-argument-error who "(or/c string? bytes?)" 1 s sfx))
(let-values ([(base name dir?) (split-path s)])
(when (not base)
(raise-mismatch-error who "cannot add a suffix to a root path: " s))
(values base name))))
(define-values (path-adjust-suffix)
(lambda (name sep rest-bytes s sfx)
(let-values ([(base name) (check-suffix-call s sfx name)])
(define bs (path-element->bytes name))
(define finish
(lambda (i sep i2)
(bytes->path-element
(let ([res (bytes-append
(subbytes bs 0 i)
sep
(rest-bytes bs i2)
(if (string? sfx)
(string->bytes/locale sfx (char->integer #\?))
sfx))])
(if (zero? (bytes-length res))
(raise-arguments-error 'path-replace-suffix
"removing suffix makes path element empty"
"given path" s)
res))
(if (path-for-some-system? s)
(path-convention-type s)
(system-path-convention-type)))))
(let ([new-name (letrec-values ([(loop)
(lambda (i)
(if (zero? i)
(finish (bytes-length bs) #"" (bytes-length bs))
(let-values ([(i) (sub1 i)])
(if (eq? (char->integer #\.) (bytes-ref bs i))
(finish i sep (add1 i))
(loop i)))))])
(loop (bytes-length bs)))])
(if (path-for-some-system? base)
(build-path base new-name)
new-name)))))
(define-values (path-replace-suffix)
(lambda (s sfx)
(path-adjust-suffix 'path-replace-suffix #"" (lambda (bs i) #"") s sfx)))
(define-values (path-add-suffix)
(lambda (s sfx)
(path-adjust-suffix 'path-add-suffix #"_" subbytes s sfx))))

2
racket/collects/racket/private/pre-base.rkt
View File

@ -159,7 +159,7 @@
collection collection
#:check-compiled? [check-compiled? #:check-compiled? [check-compiled?
(and (path-string? file-name) (and (path-string? file-name)
(regexp-match? #rx"[.]rkt$" file-name))] (regexp-match? #rx".[.]rkt$" file-name))]
#:fail [fail (lambda (s) #:fail [fail (lambda (s)
(raise (raise
(exn:fail:filesystem (exn:fail:filesystem

7
racket/collects/racket/rerequire.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require syntax/modcode) (require syntax/modcode
racket/path)
(provide dynamic-rerequire) (provide dynamic-rerequire)
@ -76,8 +77,8 @@
(let ([ts (file-or-directory-modify-seconds path #f (lambda () #f))]) (let ([ts (file-or-directory-modify-seconds path #f (lambda () #f))])
(if ts (if ts
(values ts path) (values ts path)
(if (regexp-match? #rx#"[.]rkt$" (path->bytes path)) (if (path-has-extension? path #".rkt")
(let* ([alt-path (path-replace-suffix path #".ss")] (let* ([alt-path (path-replace-extension path #".ss")]
[ts (file-or-directory-modify-seconds alt-path #f (lambda () #f))]) [ts (file-or-directory-modify-seconds alt-path #f (lambda () #f))])
(if ts (if ts
(values ts alt-path) (values ts alt-path)

4
racket/collects/racket/runtime-path.rkt
View File

@ -113,7 +113,7 @@
(append (cddr p) (drop-right strs 1)))]) (append (cddr p) (drop-right strs 1)))])
(let ([file (if (regexp-match? #rx#"[.]ss$" file) (let ([file (if (regexp-match? #rx#"[.]ss$" file)
;; normalize to ".rkt": ;; normalize to ".rkt":
(path-replace-suffix file #".rkt") (path-replace-extension file #".rkt")
file)]) file)])
(let ([p (apply collection-file-path (let ([p (apply collection-file-path
file file
@ -124,7 +124,7 @@
;; Try ".ss": ;; Try ".ss":
(define p2 (apply collection-file-path (define p2 (apply collection-file-path
#:check-compiled? #f #:check-compiled? #f
(path-replace-suffix file #".ss") (path-replace-extension file #".ss")
coll)) coll))
(if (file-exists? p2) (if (file-exists? p2)
p2 p2

2
racket/collects/setup/main.rkt
View File

@ -146,7 +146,7 @@
;; We do not currently support "external" dependencies ;; We do not currently support "external" dependencies
;; (via cm-accomplice) during bootstrap. ;; (via cm-accomplice) during bootstrap.
(let ([deps (with-input-from-file (let ([deps (with-input-from-file
(bytes->path (regexp-replace #"[.]zo$" (path->bytes path) #".dep")) (path-replace-extension path #".dep")
read)]) read)])
(for-each (lambda (dep) (for-each (lambda (dep)
(let ([dep (let ([dep

2
racket/collects/setup/private/command-name.rkt
View File

@ -9,7 +9,7 @@
(lambda () (lambda ()
(let-values ([(p) (find-system-path 'run-file)]) (let-values ([(p) (find-system-path 'run-file)])
(let-values ([(p) (if (eq? (system-type) 'windows) (let-values ([(p) (if (eq? (system-type) 'windows)
(path-replace-suffix p #"") (path-replace-extension p #"")
p)]) p)])
(let-values ([(base name dir?) (split-path p)]) (let-values ([(base name dir?) (split-path p)])
(if (current-command-name) (if (current-command-name)

10
racket/collects/setup/private/pkg-deps.rkt
View File

@ -307,7 +307,7 @@
'core)) 'core))
(when src-pkg (when src-pkg
(unless (check-dep! pkg src-pkg mode) (unless (check-dep! pkg src-pkg mode)
(define key (list pkg src-pkg (path-replace-suffix f #"") mod)) (define key (list pkg src-pkg (path-replace-extension f #"") mod))
(unless (hash-ref reported key #f) (unless (hash-ref reported key #f)
(hash-set! reported key #t) (hash-set! reported key #t)
(setup-fprintf* (current-error-port) #f (setup-fprintf* (current-error-port) #f
@ -360,7 +360,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (check-bytecode-deps f dir coll-path pkg) (define (check-bytecode-deps f dir coll-path pkg)
(define zo-f (path-replace-suffix f #".zo")) (define zo-f (path-replace-extension f #".zo"))
(when (file-exists? (build-path dir zo-f)) (when (file-exists? (build-path dir zo-f))
(define base (let ([m (regexp-match #rx#"^(.*)_[a-z]+[.]zo$" (define base (let ([m (regexp-match #rx#"^(.*)_[a-z]+[.]zo$"
(path-element->bytes zo-f))]) (path-element->bytes zo-f))])
@ -426,7 +426,7 @@
(define name (if ((length s) . > . 3) (define name (if ((length s) . > . 3)
(list-ref s 3) (list-ref s 3)
(path-element->string (path-element->string
(path-replace-suffix (file-name-from-path src) #"")))) (path-replace-extension (file-name-from-path src) #""))))
(define dest-dir (if main? (define dest-dir (if main?
(build-path (find-doc-dir) name) (build-path (find-doc-dir) name)
(build-path path "doc" name))) (build-path path "doc" name)))
@ -477,11 +477,11 @@
(not (hash-ref skip-pkgs pkg #f))) (not (hash-ref skip-pkgs pkg #f)))
(for ([f (directory-list dir)]) (for ([f (directory-list dir)])
;; A ".dep" file triggers a check: ;; A ".dep" file triggers a check:
(when (regexp-match? #rx#"[.]dep$" (path-element->bytes f)) (when (path-has-extension? f #".dep")
;; Decide whether the file is inherently 'build or 'run mode: ;; Decide whether the file is inherently 'build or 'run mode:
(define mode (define mode
(if (or (eq? coll-mode 'build) (if (or (eq? coll-mode 'build)
(regexp-match? #rx#"_scrbl[.]dep$" (path-element->bytes f))) (path-has-extension? f #"_scrbl.dep"))
'build 'build
'run)) 'run))
;; Look at the actual module for 'run mode (dropping ;; Look at the actual module for 'run mode (dropping

16
racket/collects/setup/setup-core.rkt
View File

@ -731,7 +731,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (delete-file/record-dependency path dependencies) (define (delete-file/record-dependency path dependencies)
(when (regexp-match-positions #rx"[.]dep$" (path->bytes path)) (when (path-has-extension? path #".dep")
(define deps (define deps
(with-handlers ([exn:fail? (lambda (x) null)]) (with-handlers ([exn:fail? (lambda (x) null)])
(with-input-from-file path read))) (with-input-from-file path read)))
@ -828,8 +828,8 @@
old-dependencies old-dependencies
(lambda (file _) (lambda (file _)
(define-values [dir name dir?] (split-path file)) (define-values [dir name dir?] (split-path file))
(define zo (build-path dir mode-dir (path-add-suffix name #".zo"))) (define zo (build-path dir mode-dir (path-add-extension name #".zo")))
(define dep (build-path dir mode-dir (path-add-suffix name #".dep"))) (define dep (build-path dir mode-dir (path-add-extension name #".dep")))
(when (and (file-exists? dep) (file-exists? zo)) (when (and (file-exists? dep) (file-exists? zo))
(set! did-something? #t) (set! did-something? #t)
(setup-printf "deleting" "~a" (path->relative-string/setup zo #:cache pkg-path-cache)) (setup-printf "deleting" "~a" (path->relative-string/setup zo #:cache pkg-path-cache))
@ -991,13 +991,13 @@
;; appear in a "compiled" directory: ;; appear in a "compiled" directory:
(make-immutable-hash (make-immutable-hash
(map (lambda (p) (map (lambda (p)
(cons (path-add-suffix p #".zo") #t)) (cons (path-add-extension p #".zo") #t))
(append (directory-list dir) (append (directory-list dir)
(info 'virtual-sources (lambda () null))))))]) (info 'virtual-sources (lambda () null))))))])
;; Check each file in `c` to see whether it can stay: ;; Check each file in `c` to see whether it can stay:
(for ([p (directory-list c)]) (for ([p (directory-list c)])
(when (and (regexp-match #rx#".(zo|dep)$" (path-element->bytes p)) (when (and (regexp-match? #rx#".[.](zo|dep)$" (path-element->bytes p))
(not (hash-ref ok-zo-files (path-replace-suffix p #".zo") #f))) (not (hash-ref ok-zo-files (path-replace-extension p #".zo") #f)))
(setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p)) (setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p))
(delete-file (build-path c p)))) (delete-file (build-path c p))))
ok-zo-files)] ok-zo-files)]
@ -1371,7 +1371,7 @@
(doc:setup-scribblings tmp-dir #f) (doc:setup-scribblings tmp-dir #f)
(parameterize ([current-directory tmp-dir]) (parameterize ([current-directory tmp-dir])
(for ([f (directory-list)] (for ([f (directory-list)]
#:when (regexp-match? #rx#"[.]tex$" (path-element->bytes f))) #:when (path-has-extension? f #".tex"))
(define pdf (scr:call 'run-pdflatex f (define pdf (scr:call 'run-pdflatex f
(lambda (fmt . xs) (lambda (fmt . xs)
(apply setup-printf #f fmt xs)))) (apply setup-printf #f fmt xs))))
@ -1468,7 +1468,7 @@
(if (cc-main? cc) 'main 'user))) (if (cc-main? cc) 'main 'user)))
,@(build-aux-from-path ,@(build-aux-from-path
(build-path (cc-path cc) (build-path (cc-path cc)
(path-replace-suffix (or mzll mzln) #"")))))) (path-replace-extension (or mzll mzln) #""))))))
(unless (up-to-date? p aux) (unless (up-to-date? p aux)
(setup-printf (setup-printf
"launcher" "launcher"

8
racket/collects/syntax/modcode.rkt
View File

@ -74,7 +74,7 @@
(error 'read-one "empty file; expected a module declaration in: ~a" path)) (error 'read-one "empty file; expected a module declaration in: ~a" path))
(define sym (define sym
(string->symbol (string->symbol
(bytes->string/utf-8 (path->bytes (path-replace-suffix name #"")) #\?))) (bytes->string/utf-8 (path->bytes (path-replace-extension name #"")) #\?)))
(define checked-v (check-module-form unchecked-v sym path)) (define checked-v (check-module-form unchecked-v sym path))
(unless (eof-object? (read p)) (unless (eof-object? (read p))
(error 'read-one (error 'read-one
@ -156,18 +156,18 @@
sub-path sub-path
"native" "native"
(system-library-subpath) (system-library-subpath)
(path-add-suffix file (system-type 'so-suffix)))) (path-add-extension file (system-type 'so-suffix))))
(define zo (define zo
(get-metadata-path #:roots roots (get-metadata-path #:roots roots
path0-base path0-base
sub-path sub-path
(path-add-suffix src-file #".zo"))) (path-add-extension src-file #".zo")))
(define alt-zo (define alt-zo
(and try-alt? (and try-alt?
(get-metadata-path #:roots roots (get-metadata-path #:roots roots
path0-base path0-base
sub-path sub-path
(path-add-suffix alt-src-file #".zo")))) (path-add-extension alt-src-file #".zo"))))
(define so (get-so src-file)) (define so (get-so src-file))
(define alt-so (and try-alt? (get-so alt-src-file))) (define alt-so (and try-alt? (get-so alt-src-file)))
(define prefer (choose src-path zo so)) (define prefer (choose src-path zo so))

9
racket/collects/syntax/modresolve.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require racket/contract/base (require racket/contract/base
racket/path
"private/modhelp.rkt") "private/modhelp.rkt")
(define (force-relto relto dir? #:path? [path? #t]) (define (force-relto relto dir? #:path? [path? #t])
@ -34,11 +35,9 @@
[else (values (and path? (current-directory)) submod)]))) [else (values (and path? (current-directory)) submod)])))
(define (path-ss->rkt p) (define (path-ss->rkt p)
(let-values ([(base name dir?) (split-path p)]) (if (path-has-extension? p #".ss")
(if (and (path? name) (path-replace-extension p #".rkt")
(regexp-match #rx"[.]ss$" (path->bytes name))) p))
(path-replace-suffix p #".rkt")
p)))
(define (combine-submod v p) (define (combine-submod v p)
(if (null? p) (if (null? p)

2
racket/collects/syntax/module-reader.rkt
View File

@ -202,7 +202,7 @@
[name (if (path? p-name) [name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)]) (let-values ([(base name dir?) (split-path p-name)])
(string->symbol (string->symbol
(path->string (path-replace-suffix name #"")))) (path->string (path-replace-extension name #""))))
'anonymous-module)] 'anonymous-module)]
[tag-src (lambda (v) [tag-src (lambda (v)
(if stx? (if stx?

10
racket/collects/syntax/private/modcollapse-noctc.rkt
View File

@ -10,6 +10,7 @@ Use syntax/modcollapse instead.
(require racket/string (require racket/string
racket/list racket/list
racket/path
"modhelp.rkt") "modhelp.rkt")
(define (collapse-module-path s relto-mp) (define (collapse-module-path s relto-mp)
@ -54,16 +55,15 @@ Use syntax/modcollapse instead.
(define (ss->rkt s) (define (ss->rkt s)
(let ([len (string-length s)]) (let ([len (string-length s)])
(if (and (len . >= . 3) (if (and (len . > . 3)
(string=? ".ss" (substring s (- len 3)))) (string=? ".ss" (substring s (- len 3))))
(string-append (substring s 0 (- len 3)) ".rkt") (string-append (substring s 0 (- len 3)) ".rkt")
s))) s)))
(define (path-ss->rkt p) (define (path-ss->rkt p)
(let-values ([(base name dir?) (split-path p)]) (if (path-has-extension? p #".ss")
(if (regexp-match #rx"[.]ss$" (path->bytes name)) (path-replace-extension p #".rkt")
(path-replace-suffix p #".rkt") p))
p)))
(define (flatten-relto-mp!) (define (flatten-relto-mp!)
(when (procedure? relto-mp) (set! relto-mp (relto-mp))) (when (procedure? relto-mp) (set! relto-mp (relto-mp)))

2
racket/src/racket/gc2/check-sdep.rkt
View File

@ -11,7 +11,7 @@
(cond (cond
[(regexp-match? #rx"[.][ch]$" path) [(regexp-match? #rx"[.][ch]$" path)
(define-values (ts) (file-or-directory-modify-seconds path)) (define-values (ts) (file-or-directory-modify-seconds path))
(define-values (sdep) (path-replace-suffix path ".sdep")) (define-values (sdep) (path-replace-extension path ".sdep"))
(call-with-escape-continuation (call-with-escape-continuation
(lambda (esc) (lambda (esc)
(with-continuation-mark (with-continuation-mark

3053
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "6.5.0.2" #define MZSCHEME_VERSION "6.5.0.3"
#define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 5 #define MZSCHEME_VERSION_Y 5
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -147,8 +147,8 @@
"(#%require '#%min-stx '#%paramz)" "(#%require '#%min-stx '#%paramz)"
"(#%provide path-string?" "(#%provide path-string?"
" normal-case-path" " normal-case-path"
" path-replace-suffix" " path-replace-extension"
" path-add-suffix" " path-add-extension"
" reroot-path" " reroot-path"
" find-col-file" " find-col-file"
" collection-path" " collection-path"
@ -754,7 +754,7 @@
"(lambda(dir path check-compiled?)" "(lambda(dir path check-compiled?)"
"(or(file-exists?(build-path dir path))" "(or(file-exists?(build-path dir path))"
"(and check-compiled?" "(and check-compiled?"
" (let ((try-path (path-add-suffix path #\".zo\"))" " (let ((try-path (path-add-extension path #\".zo\"))"
"(modes(use-compiled-file-paths))" "(modes(use-compiled-file-paths))"
"(roots(current-compiled-file-roots)))" "(roots(current-compiled-file-roots)))"
"(ormap(lambda(d)" "(ormap(lambda(d)"
@ -767,7 +767,7 @@
"(else(reroot-path p d))))))" "(else(reroot-path p d))))))"
" modes))" " modes))"
" roots))))))" " roots))))))"
"(define-values(check-suffix-call)" "(define-values(check-extension-call)"
"(lambda(s sfx who)" "(lambda(s sfx who)"
"(unless(or(path-for-some-system? s)" "(unless(or(path-for-some-system? s)"
"(path-string? s))" "(path-string? s))"
@ -776,27 +776,22 @@
" (raise-argument-error who \"(or/c string? bytes?)\" 1 s sfx))" " (raise-argument-error who \"(or/c string? bytes?)\" 1 s sfx))"
"(let-values(((base name dir?)(split-path s)))" "(let-values(((base name dir?)(split-path s)))"
"(when(not base)" "(when(not base)"
" (raise-mismatch-error who \"cannot add a suffix to a root path: \" s))" " (raise-mismatch-error who \"cannot add an extension to a root path: \" s))"
"(values base name))))" "(values base name))))"
"(define-values(path-adjust-suffix)" "(define-values(path-adjust-extension)"
"(lambda(name sep rest-bytes s sfx)" "(lambda(name sep rest-bytes s sfx)"
"(let-values(((base name)(check-suffix-call s sfx name)))" "(let-values(((base name)(check-extension-call s sfx name)))"
"(define bs(path-element->bytes name))" "(define bs(path-element->bytes name))"
"(define finish" "(define finish"
"(lambda(i sep i2)" "(lambda(i sep i2)"
"(bytes->path-element" "(bytes->path-element"
"(let((res(bytes-append" "(bytes-append"
"(subbytes bs 0 i)" "(subbytes bs 0 i)"
" sep" " sep"
"(rest-bytes bs i2)" "(rest-bytes bs i2)"
"(if(string? sfx)" "(if(string? sfx)"
"(string->bytes/locale sfx(char->integer #\\?))" "(string->bytes/locale sfx(char->integer #\\?))"
" sfx))))" " sfx))"
"(if(zero?(bytes-length res))"
"(raise-arguments-error 'path-replace-suffix"
" \"removing suffix makes path element empty\""
" \"given path\" s)"
" res))"
"(if(path-for-some-system? s)" "(if(path-for-some-system? s)"
"(path-convention-type s)" "(path-convention-type s)"
"(system-path-convention-type)))))" "(system-path-convention-type)))))"
@ -805,19 +800,20 @@
"(if(zero? i)" "(if(zero? i)"
" (finish (bytes-length bs) #\"\" (bytes-length bs))" " (finish (bytes-length bs) #\"\" (bytes-length bs))"
"(let-values(((i)(sub1 i)))" "(let-values(((i)(sub1 i)))"
"(if(eq?(char->integer #\\.)(bytes-ref bs i))" "(if(and(not(zero? i))"
"(eq?(char->integer #\\.)(bytes-ref bs i)))"
"(finish i sep(add1 i))" "(finish i sep(add1 i))"
"(loop i)))))))" "(loop i)))))))"
"(loop(bytes-length bs)))))" "(loop(bytes-length bs)))))"
"(if(path-for-some-system? base)" "(if(path-for-some-system? base)"
"(build-path base new-name)" "(build-path base new-name)"
" new-name)))))" " new-name)))))"
"(define-values(path-replace-suffix)" "(define-values(path-replace-extension)"
"(lambda(s sfx)" "(lambda(s sfx)"
" (path-adjust-suffix 'path-replace-suffix #\"\" (lambda (bs i) #\"\") s sfx)))" " (path-adjust-extension 'path-replace-extension #\"\" (lambda (bs i) #\"\") s sfx)))"
"(define-values(path-add-suffix)" "(define-values(path-add-extension)"
"(lambda(s sfx)" "(lambda(s sfx)"
" (path-adjust-suffix 'path-replace-suffix #\"_\" subbytes s sfx)))" " (path-adjust-extension 'path-add-extension #\"_\" subbytes s sfx)))"
"(define-values(load/use-compiled)" "(define-values(load/use-compiled)"
"(lambda(f)((current-load/use-compiled) f #f)))" "(lambda(f)((current-load/use-compiled) f #f)))"
"(define-values(find-library-collection-paths)" "(define-values(find-library-collection-paths)"
@ -990,18 +986,18 @@
" \"native\"" " \"native\""
"(system-library-subpath)" "(system-library-subpath)"
"(if rep-sfx?" "(if rep-sfx?"
"(path-add-suffix" "(path-add-extension"
" file" " file"
" dll-suffix)" " dll-suffix)"
" file)))))" " file)))))"
"(zo(lambda(root-dir compiled-dir)" "(zo(lambda(root-dir compiled-dir)"
"(build-path(reroot base root-dir)" "(build-path(reroot base root-dir)"
" compiled-dir" " compiled-dir"
" (path-add-suffix file #\".zo\"))))" " (path-add-extension file #\".zo\"))))"
"(alt-zo(lambda(root-dir compiled-dir)" "(alt-zo(lambda(root-dir compiled-dir)"
"(build-path(reroot base root-dir)" "(build-path(reroot base root-dir)"
" compiled-dir" " compiled-dir"
" (path-add-suffix alt-file #\".zo\"))))" " (path-add-extension alt-file #\".zo\"))))"
"(so(get-so file #t))" "(so(get-so file #t))"
"(alt-so(get-so alt-file #t))" "(alt-so(get-so alt-file #t))"
"(try-main?(or main-path-d(not alt-path-d)))" "(try-main?(or main-path-d(not alt-path-d)))"
@ -1251,7 +1247,7 @@
"(path-ss->rkt(lambda(p)" "(path-ss->rkt(lambda(p)"
"(let-values(((base name dir?)(split-path p)))" "(let-values(((base name dir?)(split-path p)))"
" (if (regexp-match #rx\"[.]ss$\" (path->bytes name))" " (if (regexp-match #rx\"[.]ss$\" (path->bytes name))"
" (path-replace-suffix p #\".rkt\")" " (path-replace-extension p #\".rkt\")"
" p))))" " p))))"
"(s(if(and(pair? s)(eq? 'submod(car s)))" "(s(if(and(pair? s)(eq? 'submod(car s)))"
"(let((v(cadr s)))" "(let((v(cadr s)))"
@ -1377,7 +1373,7 @@
"(split-path filename))))" "(split-path filename))))"
"(let*((no-sfx(if(vector? s-parsed)" "(let*((no-sfx(if(vector? s-parsed)"
"(vector-ref s-parsed 3)" "(vector-ref s-parsed 3)"
" (path-replace-suffix name #\"\"))))" " (path-replace-extension name #\"\"))))"
"(let*((root-modname(if(vector? s-parsed)" "(let*((root-modname(if(vector? s-parsed)"
"(vector-ref s-parsed 4)" "(vector-ref s-parsed 4)"
"(make-resolved-module-path filename)))" "(make-resolved-module-path filename)))"

54
racket/src/racket/src/startup.rktl
View File

@ -195,8 +195,8 @@
(#%provide path-string? (#%provide path-string?
normal-case-path normal-case-path
path-replace-suffix path-replace-extension
path-add-suffix path-add-extension
reroot-path reroot-path
find-col-file find-col-file
collection-path collection-path
@ -886,7 +886,7 @@
(lambda (dir path check-compiled?) (lambda (dir path check-compiled?)
(or (file-exists? (build-path dir path)) (or (file-exists? (build-path dir path))
(and check-compiled? (and check-compiled?
(let ([try-path (path-add-suffix path #".zo")] (let ([try-path (path-add-extension path #".zo")]
[modes (use-compiled-file-paths)] [modes (use-compiled-file-paths)]
[roots (current-compiled-file-roots)]) [roots (current-compiled-file-roots)])
(ormap (lambda (d) (ormap (lambda (d)
@ -900,7 +900,7 @@
modes)) modes))
roots)))))) roots))))))
(define-values (check-suffix-call) (define-values (check-extension-call)
(lambda (s sfx who) (lambda (s sfx who)
(unless (or (path-for-some-system? s) (unless (or (path-for-some-system? s)
(path-string? s)) (path-string? s))
@ -909,28 +909,23 @@
(raise-argument-error who "(or/c string? bytes?)" 1 s sfx)) (raise-argument-error who "(or/c string? bytes?)" 1 s sfx))
(let-values ([(base name dir?) (split-path s)]) (let-values ([(base name dir?) (split-path s)])
(when (not base) (when (not base)
(raise-mismatch-error who "cannot add a suffix to a root path: " s)) (raise-mismatch-error who "cannot add an extension to a root path: " s))
(values base name)))) (values base name))))
(define-values (path-adjust-suffix) (define-values (path-adjust-extension)
(lambda (name sep rest-bytes s sfx) (lambda (name sep rest-bytes s sfx)
(let-values ([(base name) (check-suffix-call s sfx name)]) (let-values ([(base name) (check-extension-call s sfx name)])
(define bs (path-element->bytes name)) (define bs (path-element->bytes name))
(define finish (define finish
(lambda (i sep i2) (lambda (i sep i2)
(bytes->path-element (bytes->path-element
(let ([res (bytes-append (bytes-append
(subbytes bs 0 i) (subbytes bs 0 i)
sep sep
(rest-bytes bs i2) (rest-bytes bs i2)
(if (string? sfx) (if (string? sfx)
(string->bytes/locale sfx (char->integer #\?)) (string->bytes/locale sfx (char->integer #\?))
sfx))]) sfx))
(if (zero? (bytes-length res))
(raise-arguments-error 'path-replace-suffix
"removing suffix makes path element empty"
"given path" s)
res))
(if (path-for-some-system? s) (if (path-for-some-system? s)
(path-convention-type s) (path-convention-type s)
(system-path-convention-type))))) (system-path-convention-type)))))
@ -939,7 +934,8 @@
(if (zero? i) (if (zero? i)
(finish (bytes-length bs) #"" (bytes-length bs)) (finish (bytes-length bs) #"" (bytes-length bs))
(let-values ([(i) (sub1 i)]) (let-values ([(i) (sub1 i)])
(if (eq? (char->integer #\.) (bytes-ref bs i)) (if (and (not (zero? i))
(eq? (char->integer #\.) (bytes-ref bs i)))
(finish i sep (add1 i)) (finish i sep (add1 i))
(loop i)))))]) (loop i)))))])
(loop (bytes-length bs)))]) (loop (bytes-length bs)))])
@ -947,13 +943,13 @@
(build-path base new-name) (build-path base new-name)
new-name))))) new-name)))))
(define-values (path-replace-suffix) (define-values (path-replace-extension)
(lambda (s sfx) (lambda (s sfx)
(path-adjust-suffix 'path-replace-suffix #"" (lambda (bs i) #"") s sfx))) (path-adjust-extension 'path-replace-extension #"" (lambda (bs i) #"") s sfx)))
(define-values (path-add-suffix) (define-values (path-add-extension)
(lambda (s sfx) (lambda (s sfx)
(path-adjust-suffix 'path-replace-suffix #"_" subbytes s sfx))) (path-adjust-extension 'path-add-extension #"_" subbytes s sfx)))
(define-values (load/use-compiled) (define-values (load/use-compiled)
(lambda (f) ((current-load/use-compiled) f #f))) (lambda (f) ((current-load/use-compiled) f #f)))
@ -1146,18 +1142,18 @@
"native" "native"
(system-library-subpath) (system-library-subpath)
(if rep-sfx? (if rep-sfx?
(path-add-suffix (path-add-extension
file file
dll-suffix) dll-suffix)
file))))] file))))]
[zo (lambda (root-dir compiled-dir) [zo (lambda (root-dir compiled-dir)
(build-path (reroot base root-dir) (build-path (reroot base root-dir)
compiled-dir compiled-dir
(path-add-suffix file #".zo")))] (path-add-extension file #".zo")))]
[alt-zo (lambda (root-dir compiled-dir) [alt-zo (lambda (root-dir compiled-dir)
(build-path (reroot base root-dir) (build-path (reroot base root-dir)
compiled-dir compiled-dir
(path-add-suffix alt-file #".zo")))] (path-add-extension alt-file #".zo")))]
[so (get-so file #t)] [so (get-so file #t)]
[alt-so (get-so alt-file #t)] [alt-so (get-so alt-file #t)]
[try-main? (or main-path-d (not alt-path-d))] [try-main? (or main-path-d (not alt-path-d))]
@ -1427,7 +1423,7 @@
[path-ss->rkt (lambda (p) [path-ss->rkt (lambda (p)
(let-values ([(base name dir?) (split-path p)]) (let-values ([(base name dir?) (split-path p)])
(if (regexp-match #rx"[.]ss$" (path->bytes name)) (if (regexp-match #rx"[.]ss$" (path->bytes name))
(path-replace-suffix p #".rkt") (path-replace-extension p #".rkt")
p)))] p)))]
[s (if (and (pair? s) (eq? 'submod (car s))) [s (if (and (pair? s) (eq? 'submod (car s)))
(let ([v (cadr s)]) (let ([v (cadr s)])
@ -1559,7 +1555,7 @@
(split-path filename))]) (split-path filename))])
(let* ([no-sfx (if (vector? s-parsed) (let* ([no-sfx (if (vector? s-parsed)
(vector-ref s-parsed 3) (vector-ref s-parsed 3)
(path-replace-suffix name #""))]) (path-replace-extension name #""))])
(let* ([root-modname (if (vector? s-parsed) (let* ([root-modname (if (vector? s-parsed)
(vector-ref s-parsed 4) (vector-ref s-parsed 4)
(make-resolved-module-path filename))] (make-resolved-module-path filename))]