Skip to content
Snippets Groups Projects
Commit dc506a1d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

More pathname tweaks, found thanks to LispWorks, CMUCL.

parent 2a48eb41
No related branches found
No related tags found
No related merge requests found
...@@ -3,13 +3,10 @@ ...@@ -3,13 +3,10 @@
(assert (assert
(every #'directory-pathname-p (every #'directory-pathname-p
(list (list
(make-pathname* :name nil :type "" :directory '(:absolute "tmp")) (make-pathname* :name nil :type nil :directory '(:absolute "tmp"))
(make-pathname* :name "" :directory '(:absolute "tmp")) ;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here,
(make-pathname* :type "" :directory '(:absolute "tmp")) ;; and some implementations will enforce it.
;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here,
;; and some implementations will enforce it.
(make-pathname* :type *unspecific-pathname-type* :directory '(:absolute "tmp")) (make-pathname* :type *unspecific-pathname-type* :directory '(:absolute "tmp"))
(make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp"))
(make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp"))))) (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp")))))
(assert (assert
(every (complement #'directory-pathname-p) (every (complement #'directory-pathname-p)
...@@ -17,6 +14,8 @@ ...@@ -17,6 +14,8 @@
(make-pathname* :name "foo" :type nil :directory '(:absolute "tmp")) (make-pathname* :name "foo" :type nil :directory '(:absolute "tmp"))
(make-pathname* :name nil :type "bar" :directory '(:absolute "tmp"))))) (make-pathname* :name nil :type "bar" :directory '(:absolute "tmp")))))
;; These are funky and non portable, omit from tests: ;; These are funky and non portable, omit from tests:
;; (make-pathname* :name "" :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name nil :type "" :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp")) ;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp")) ;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp"))
(macrolet ((ts (x y) (macrolet ((ts (x y)
......
...@@ -307,7 +307,7 @@ actually-existing directory." ...@@ -307,7 +307,7 @@ actually-existing directory."
;; ill-formed. [2014/02/10:rpg] ;; ill-formed. [2014/02/10:rpg]
(let ((pathname (pathname pathname))) (let ((pathname (pathname pathname)))
(flet ((check-one (x) (flet ((check-one (x)
(member x '(nil :unspecific "") :test 'equal))) (member x '(nil :unspecific) :test 'equal)))
(and (not (wild-pathname-p pathname)) (and (not (wild-pathname-p pathname))
(check-one (pathname-name pathname)) (check-one (pathname-name pathname))
(check-one (pathname-type pathname)) (check-one (pathname-type pathname))
...@@ -483,13 +483,14 @@ or if it is a PATHNAME but some of its components are not recognized." ...@@ -483,13 +483,14 @@ or if it is a PATHNAME but some of its components are not recognized."
((or null string) pathname) ((or null string) pathname)
(pathname (pathname
(with-output-to-string (s) (with-output-to-string (s)
(flet ((err () (error "Not a valid unix-namestring ~S" pathname))) (flet ((err () #+lispworks (describe pathname) (error "Not a valid unix-namestring ~S" pathname)))
(let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
(name (pathname-name pathname)) (name (pathname-name pathname))
(name (and (not (eq name :unspecific)) name))
(type (pathname-type pathname)) (type (pathname-type pathname))
(type (and (not (eq type :unspecific)) type))) (type (and (not (eq type :unspecific)) type)))
(cond (cond
((eq dir ())) ((member dir '(nil :unspecific)))
((eq dir '(:relative)) (princ "./" s)) ((eq dir '(:relative)) (princ "./" s))
((consp dir) ((consp dir)
(destructuring-bind (relabs &rest dirs) dir (destructuring-bind (relabs &rest dirs) dir
...@@ -505,7 +506,7 @@ or if it is a PATHNAME but some of its components are not recognized." ...@@ -505,7 +506,7 @@ or if it is a PATHNAME but some of its components are not recognized."
(t (err))) (t (err)))
(cond (cond
(name (name
(or (and (stringp name) (or (null type) (stringp type))) (err)) (unless (and (stringp name) (or (null type) (stringp type))) (err))
(format s "~A~@[.~A~]" name type)) (format s "~A~@[.~A~]" name type))
(t (t
(or (null type) (err))))))))))) (or (null type) (err)))))))))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment