projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix equality between #p"~" and (user-homedir-pathname) on Win32.
[sbcl.git]
/
src
/
code
/
win32-pathname.lisp
diff --git
a/src/code/win32-pathname.lisp
b/src/code/win32-pathname.lisp
index
169f384
..
72bb09d
100644
(file)
--- a/
src/code/win32-pathname.lisp
+++ b/
src/code/win32-pathname.lisp
@@
-291,17
+291,26
@@
(ecase (pop directory)
(:absolute
(let ((next (pop directory)))
(ecase (pop directory)
(:absolute
(let ((next (pop directory)))
+ ;; Don't use USER-HOMEDIR-NAMESTRING, since
+ ;; it can be specified as C:/User/user
+ ;; and (native-namestring (user-homedir-pathname))
+ ;; will be not equal to it, because it's parsed first.
(cond ((eq :home next)
(cond ((eq :home next)
- (write-string (user-homedir-namestring) s))
+ (write-string (native-namestring (user-homedir-pathname))
+ s))
((and (consp next) (eq :home (car next)))
((and (consp next) (eq :home (car next)))
- (let ((where (user-homedir-namestring (second next))))
+ (let ((where (user-homedir-pathname (second next))))
(if where
(if where
- (write-string where s)
+ (write-string (native-namestring where) s)
(error "User homedir unknown for: ~S"
(second next)))))
(error "User homedir unknown for: ~S"
(second next)))))
+ ;; namestring of user-homedir-pathname already has
+ ;; // at the end
(next
(next
- (push next directory)))
- (write-char #\\ s)))
+ (write-char #\\ s)
+ (push next directory))
+ (t
+ (write-char #\\ s)))))
(:relative)))
(loop for (piece . subdirs) on directory
do (typecase piece
(:relative)))
(loop for (piece . subdirs) on directory
do (typecase piece
@@
-324,7
+333,7
@@
(error "ungood type component in NATIVE-NAMESTRING: ~S" type))
(write-char #\. s)
(write-string type-string s)))
(error "ungood type component in NATIVE-NAMESTRING: ~S" type))
(write-char #\. s)
(write-string type-string s)))
- (when type-present-p ;
+ (when type-present-p
(error
"type component without a name component in NATIVE-NAMESTRING: ~S"
type)))
(error
"type component without a name component in NATIVE-NAMESTRING: ~S"
type)))