[Git][cmucl/cmucl][master] 2 commits: Fix #216: enough-namestring with relative pathname fails
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Wed May 31 03:57:01 UTC 2023
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>
More information about the cmucl-cvs
mailing list