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

cs & io: fix simplify-path for 'up relative to a root

Browse Source 
Closes #3716
This commit is contained in:
Matthew Flatt 2021-03-06 09:36:33 -07:00
parent 07c7ff51ff
commit a3bf702ac9
3 changed files with 24 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -944,6 +944,8 @@
(test (bytes->path #"../") simplify-path (bytes->path #"../") #f)
(test (bytes->path #"../") simplify-path (bytes->path #"..//") #f)
(test (bytes->path #"../") simplify-path (bytes->path #"..//./") #f)
(test (bytes->path #"/x") simplify-path (bytes->path #"/../../x") #f)
(test (bytes->path #"/") simplify-path (bytes->path #"/x/../..") #f)
(test (bytes->path #"x/") path->directory-path (bytes->path #"x"))
(test (bytes->path #"x/") path->directory-path (bytes->path #"x/"))
(test (bytes->path #"x/./") path->directory-path (bytes->path #"x/."))

17
racket/src/cs/schemified/io.scm
View File

@ -25003,11 +25003,20 @@
accum_0)
(if (eq? 'up (car l_1))
(if (pair? accum_0)
(let ((app_0
(cdr l_1)))
(if (if (null?
(cdr
accum_0))
(1/absolute-path?
(car accum_0))
#f)
(loop_0
app_0
(cdr accum_0)))
(cdr l_1)
accum_0)
(let ((app_0
(cdr l_1)))
(loop_0
app_0
(cdr accum_0))))
(cons
'up
(loop_0

11
racket/src/io/path/simplify-nofs.rkt
View File

@ -8,7 +8,8 @@
"directory-path.rkt"
"complete.rkt"
"parameter.rkt"
"windows.rkt")
"windows.rkt"
"relativity.rkt")
(provide simplify-path-syntactically)
@ -52,7 +53,13 @@
[(eq? 'up (car l))
(cond
[(pair? accum)
(loop (cdr l) (cdr accum))]
(cond
[(and (null? (cdr accum))
(absolute-path? (car accum)))
;; for 'up at root, just keep the root
(loop (cdr l) accum)]
[else
(loop (cdr l) (cdr accum))])]
[else
(cons 'up (loop (cdr l) null))])]
[else (loop (cdr l) (cons (car l) accum))])))