[Git][cmucl/cmucl][master] 2 commits: Fix #216: enough-namestring with relative pathname fails

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch master at cmucl / cmucl


Commits:
648c1127 by Raymond Toy at 2023-05-31T03:55:52+00:00
Fix #216: enough-namestring with relative pathname fails

- - - - -
660ab4c5 by Raymond Toy at 2023-05-31T03:56:07+00:00
Merge branch 'issue-216-enough-namestring-relative-dir' into 'master'

Fix #216: enough-namestring with relative pathname fails

Closes #216

See merge request cmucl/cmucl!152
- - - - -


2 changed files:

- src/code/filesys.lisp
- tests/issues.lisp


Changes:

=====================================
src/code/filesys.lisp
=====================================
@@ -610,8 +610,8 @@
 			 ;; We are an absolute pathname, so we can just use it.
 			 pathname-directory)
 			(t
-			 ;; We are a relative directory.  So we lose.
-			 (lose)))))
+			 ;; We are a relative directory, so just return it as is.
+			 pathname-directory))))
 	    (strings (unparse-unix-directory-list result-dir)))
 	  (let* ((pathname-version (%pathname-version pathname))
 		 (version-needed (and pathname-version


=====================================
tests/issues.lisp
=====================================
@@ -977,3 +977,12 @@
   (assert-true (equal (make-pathname :version :newest)
 		      (make-pathname :version :unspecific)))
 )
+
+(define-test issue.216.enough-namestring-relative-dir
+    (:tag :issues)
+  (let ((pathname #p"foo/bar.lisp"))
+  (dolist (defaults '(#p"/tmp/zot/" #p"/tmp/zot/foo/"))
+    (let ((enough (enough-namestring pathname defaults)))
+      ;; This is the condition from the CLHS entry for enough-namestring
+      (assert-equal (merge-pathnames enough defaults)
+		    (merge-pathnames (parse-namestring pathname nil defaults) defaults))))))



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/dcb8124fa472a81202ddd820b13276b5f5ad8d51...660ab4c5fbef7b72986418732f49ca56132a63be

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/dcb8124fa472a81202ddd820b13276b5f5ad8d51...660ab4c5fbef7b72986418732f49ca56132a63be
You're receiving this email because of your account on gitlab.common-lisp.net.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230531/d21cc4c3/attachment-0001.html>