Commit dc506a1d authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

More pathname tweaks, found thanks to LispWorks, CMUCL.

parent 2a48eb41
Loading
Loading
Loading
Loading
+5 −6
Original line number Diff line number Diff line
@@ -3,13 +3,10 @@
(assert
 (every #'directory-pathname-p
  (list
   (make-pathname* :name nil :type "" :directory '(:absolute "tmp"))
   (make-pathname* :name "" :directory '(:absolute "tmp"))
   (make-pathname* :type "" :directory '(:absolute "tmp"))
   (make-pathname* :name nil :type nil :directory '(:absolute "tmp"))
   ;; 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* :name *unspecific-pathname-type* :directory '(:absolute "tmp"))
   (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp")))))
(assert
 (every (complement #'directory-pathname-p)
@@ -17,6 +14,8 @@
   (make-pathname* :name "foo" :type nil :directory '(:absolute "tmp"))
   (make-pathname* :name nil :type "bar" :directory '(:absolute "tmp")))))
;; 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 "" :directory '(:absolute "tmp"))
(macrolet ((ts (x y)
+5 −4
Original line number Diff line number Diff line
@@ -307,7 +307,7 @@ actually-existing directory."
      ;; ill-formed. [2014/02/10:rpg]
      (let ((pathname (pathname pathname)))
        (flet ((check-one (x)
                 (member x '(nil :unspecific "") :test 'equal)))
                 (member x '(nil :unspecific) :test 'equal)))
          (and (not (wild-pathname-p pathname))
               (check-one (pathname-name pathname))
               (check-one (pathname-type pathname))
@@ -483,13 +483,14 @@ or if it is a PATHNAME but some of its components are not recognized."
      ((or null string) pathname)
      (pathname
       (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)))
                  (name (pathname-name pathname))
                  (name (and (not (eq name :unspecific)) name))
                  (type (pathname-type pathname))
                  (type (and (not (eq type :unspecific)) type)))
             (cond
               ((eq dir ()))
               ((member dir '(nil :unspecific)))
               ((eq dir '(:relative)) (princ "./" s))
               ((consp 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."
               (t (err)))
             (cond
               (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))
               (t
                (or (null type) (err)))))))))))