~ chicken-core (chicken-5) 972d399b59a383c46b11f74c7388258b7f533f45
commit 972d399b59a383c46b11f74c7388258b7f533f45
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jun 18 13:12:38 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Jun 18 13:12:38 2011 +0200
tried to make make-pathname more sensible (thanks to Jim Ursetto)
diff --git a/files.scm b/files.scm
index 5496e949..a9c37e77 100644
--- a/files.scm
+++ b/files.scm
@@ -159,55 +159,48 @@ EOF
(define-inline (*char-pds? ch) (memq ch '(#\\ #\/)))
-(define (chop-pds str pds)
+(define (chop-pds str)
(and str
- (let ((len (##sys#size str))
- (pdslen (if pds (##sys#size pds) 1)))
+ (let ((len (##sys#size str)))
(if (and (fx>= len 1)
- (if pds
- (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
- (*char-pds? (##core#inline "C_subchar" str (fx- len pdslen)) ) ) )
- (##sys#substring str 0 (fx- len pdslen))
+ (*char-pds? (##core#inline "C_subchar" str (fx- len 1)) ) )
+ (##sys#substring str 0 (fx- len 1))
str) ) ) )
(define make-pathname)
(define make-absolute-pathname)
-(let ([def-pds "/"] )
+(let ()
- (define (conc-dirs dirs pds)
+ (define (conc-dirs dirs)
(##sys#check-list dirs 'make-pathname)
- (let loop ([strs dirs])
+ (let loop ((strs dirs))
(if (null? strs)
""
(let ((s1 (car strs)))
(if (zero? (string-length s1))
(loop (cdr strs))
(string-append
- (chop-pds (car strs) pds)
- (or pds def-pds)
+ (chop-pds (car strs))
+ "/"
(loop (cdr strs))) ) ) ) ) )
- (define (canonicalize-dirs dirs pds)
- (cond [(or (not dirs) (null? dirs)) ""]
- [(string? dirs) (conc-dirs (list dirs) pds)]
- [else (conc-dirs dirs pds)] ) )
+ (define (canonicalize-dirs dirs)
+ (cond ((or (not dirs) (null? dirs)) "")
+ ((string? dirs) (conc-dirs (list dirs)))
+ (else (conc-dirs dirs)) ) )
- (define (_make-pathname loc dir file ext pds)
- (let ([ext (or ext "")]
- [file (or file "")]
- [pdslen (if pds (##sys#size pds) 1)] )
+ (define (_make-pathname loc dir file ext)
+ (let ((ext (or ext ""))
+ (file (or file "")))
(##sys#check-string dir loc)
(##sys#check-string file loc)
(##sys#check-string ext loc)
- (when pds (##sys#check-string pds loc))
(string-append
dir
- (if (and (fx>= (##sys#size file) pdslen)
- (if pds
- (##core#inline "C_substring_compare" pds file 0 0 pdslen)
- (*char-pds? (##core#inline "C_subchar" file 0))))
- (##sys#substring file pdslen (##sys#size file))
+ (if (and (fx>= (##sys#size file) 1)
+ (*char-pds? (##core#inline "C_subchar" file 0)))
+ (##sys#substring file 1 (##sys#size file))
file)
(if (and (fx> (##sys#size ext) 0)
(not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
@@ -217,17 +210,17 @@ EOF
(set! make-pathname
(lambda (dirs file #!optional ext)
- (_make-pathname 'make-pathname (canonicalize-dirs dirs def-pds) file ext def-pds)))
+ (_make-pathname 'make-pathname (canonicalize-dirs dirs) file ext)))
(set! make-absolute-pathname
(lambda (dirs file #!optional ext)
(_make-pathname
'make-absolute-pathname
- (let ([dir (canonicalize-dirs dirs def-pds)])
+ (let ((dir (canonicalize-dirs dirs)))
(if (absolute-pathname? dir)
dir
- (##sys#string-append def-pds dir)) )
- file ext def-pds) ) ) )
+ (##sys#string-append "/"dir)) )
+ file ext) ) ) )
(define decompose-pathname
(let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
@@ -239,7 +232,7 @@ EOF
(and dir
(if (member dir '("/" "\\"))
dir
- (chop-pds dir #f) ) ) )] )
+ (chop-pds dir) ) ) )] )
(lambda (pn)
(##sys#check-string pn 'decompose-pathname)
(if (fx= 0 (##sys#size pn))
diff --git a/manual/Unit files b/manual/Unit files
index bdbc3e58..1c4c3d59 100644
--- a/manual/Unit files
+++ b/manual/Unit files
@@ -30,14 +30,10 @@ For any component that is not contained in {{PATHNAME}}, {{#f}} is returned.
<procedure>(make-pathname DIRECTORY FILENAME [EXTENSION])</procedure><br>
<procedure>(make-absolute-pathname DIRECTORY FILENAME [EXTENSION])</procedure>
-Returns a string that names the file with the
-components {{DIRECTORY, FILENAME}} and (optionally)
-{{EXTENSION}} with {{SEPARATOR}} being the directory separation indicator
-(usually {{/}} on UNIX systems and {{\}} on Windows, defaulting to whatever
-platform this is running on).
-{{DIRECTORY}} can be {{#f}} (meaning no
-directory component), a string or a list of strings. {{FILENAME}}
-and {{EXTENSION}} should be strings or {{#f}}.
+Returns a string that names the file with the components {{DIRECTORY,
+FILENAME}} and (optionally) {{EXTENSION}}. {{DIRECTORY}} can be
+{{#f}} (meaning no directory component), a string or a list of
+strings. {{FILENAME}} and {{EXTENSION}} should be strings or {{#f}}.
{{make-absolute-pathname}} returns always an absolute pathname.
==== pathname-directory
diff --git a/tests/path-tests.scm b/tests/path-tests.scm
index a1d5ee64..72975ea8 100644
--- a/tests/path-tests.scm
+++ b/tests/path-tests.scm
@@ -1,30 +1,26 @@
(use files)
-(assert (equal? "/" (pathname-directory "/")))
-(assert (equal? "/" (pathname-directory "/abc")))
-(assert (equal? "abc" (pathname-directory "abc/")))
-(assert (equal? "abc" (pathname-directory "abc/def")))
-(assert (equal? "abc" (pathname-directory "abc/def.ghi")))
-(assert (equal? "abc" (pathname-directory "abc/.def.ghi")))
-(assert (equal? "abc" (pathname-directory "abc/.ghi")))
-(assert (equal? "/abc" (pathname-directory "/abc/")))
-(assert (equal? "/abc" (pathname-directory "/abc/def")))
-(assert (equal? "/abc" (pathname-directory "/abc/def.ghi")))
-(assert (equal? "/abc" (pathname-directory "/abc/.def.ghi")))
-(assert (equal? "/abc" (pathname-directory "/abc/.ghi")))
-(assert (equal? "q/abc" (pathname-directory "q/abc/")))
-(assert (equal? "q/abc" (pathname-directory "q/abc/def")))
-(assert (equal? "q/abc" (pathname-directory "q/abc/def.ghi")))
-(assert (equal? "q/abc" (pathname-directory "q/abc/.def.ghi")))
-(assert (equal? "q/abc" (pathname-directory "q/abc/.ghi")))
-
(define-syntax test
(syntax-rules ()
- ((_ expected exp)
- (let ((result exp)
- (expd expected))
- (unless (equal? result expd)
- (error "test failed" result expd 'exp))))))
+ ((_ r x) (let ((y x)) (print y) (assert (equal? r y))))))
+
+(test "/" (pathname-directory "/"))
+(test "/" (pathname-directory "/abc"))
+(test "abc" (pathname-directory "abc/"))
+(test "abc" (pathname-directory "abc/def"))
+(test "abc" (pathname-directory "abc/def.ghi"))
+(test "abc" (pathname-directory "abc/.def.ghi"))
+(test "abc" (pathname-directory "abc/.ghi"))
+(test "/abc" (pathname-directory "/abc/"))
+(test "/abc" (pathname-directory "/abc/def"))
+(test "/abc" (pathname-directory "/abc/def.ghi"))
+(test "/abc" (pathname-directory "/abc/.def.ghi"))
+(test "/abc" (pathname-directory "/abc/.ghi"))
+(test "q/abc" (pathname-directory "q/abc/"))
+(test "q/abc" (pathname-directory "q/abc/def"))
+(test "q/abc" (pathname-directory "q/abc/def.ghi"))
+(test "q/abc" (pathname-directory "q/abc/.def.ghi"))
+(test "q/abc" (pathname-directory "q/abc/.ghi"))
(test "./" (normalize-pathname "" 'unix))
(test ".\\" (normalize-pathname "" 'windows))
@@ -72,3 +68,11 @@
(test '(#f "/" ("foo" "bar")) (receive (decompose-directory "//foo//bar")))
(test '(#f #f (" " "foo" "bar")) (receive (decompose-directory " //foo//bar")))
(test '(#f #f ("foo" "bar")) (receive (decompose-directory "foo//bar/")))
+
+(test "x/y/z.q" (make-pathname "x/y" "z" "q"))
+(test "x/y/z.q" (make-pathname "x/y" "z.q"))
+(test "x/y/z.q" (make-pathname "x/y/" "z.q"))
+(test "x/y/z.q" (make-pathname "x/y/" "z.q"))
+(test "x/y/z.q" (make-pathname "x/y\\" "z.q"))
+(test "x//y/z.q" (make-pathname "x//y/" "z.q"))
+(test "x\\y/z.q" (make-pathname "x\\y" "z.q"))
Trap