Raymond Toy pushed to branch issue-425-correctly-rounded-math-functions at cmucl / cmucl Commits: e65f9f5c by Raymond Toy at 2025-12-17T07:04:10-08:00 Fix #457: delete-directory signals errors - - - - - 6034f935 by Raymond Toy at 2025-12-17T07:04:10-08:00 Merge branch 'issue-457-delete-directory-signals-errors' into 'master' Fix #457: delete-directory signals errors Closes #457 See merge request cmucl/cmucl!336 - - - - - 10efd37c by Raymond Toy at 2025-12-17T07:12:47-08:00 Remove extra blank lines Addresses comment from !337: https://gitlab.common-lisp.net/cmucl/cmucl/-/merge_requests/337#note_18529 Don't need to run CI for this. [skip-ci] - - - - - 885baf0f by Raymond Toy at 2025-12-24T12:43:58-08:00 Merge branch 'master' into issue-425-correctly-rounded-math-functions - - - - - 99d8540a by Raymond Toy at 2026-01-02T10:05:16-08:00 Fix #460: Exit with error if main unit-tests fail - - - - - 28de6c68 by Raymond Toy at 2026-01-02T10:05:17-08:00 Merge branch 'issue-460-ci-fails-if-unit-tests-do' into 'master' Fix #460: Exit with error if main unit-tests fail Closes #460 See merge request cmucl/cmucl!340 - - - - - c97ae992 by Raymond Toy at 2026-01-02T14:03:03-08:00 Merge branch 'master' into issue-425-correctly-rounded-math-functions - - - - - 8 changed files: - bin/run-unit-tests.sh - src/code/exports.lisp - src/code/extensions.lisp - src/i18n/locale/cmucl.pot - tests/float-x86.lisp - tests/float.lisp - tests/os.lisp - tests/pathname.lisp Changes: ===================================== bin/run-unit-tests.sh ===================================== @@ -9,8 +9,8 @@ usage() { echo "run-tests.sh [-?h] [-d test-dir] [-l lisp] [tests]" echo " -d test-dir Directory containing the unit test files" echo " -l lisp Lisp to use for the tests; defaults to lisp" - echo " -u Skip lisp-unit tests" echo " -p Skip package-local-nicknames test" + echo " -u Skip lisp-unit tests" echo " -? This help message" echo " -h This help message" echo "" @@ -27,13 +27,13 @@ usage() { } LISP=lisp -while getopts "uph?l:d:" arg +while getopts "puh?l:d:" arg do case $arg in l) LISP=$OPTARG ;; d) TESTDIR=$OPTARG ;; - u) SKIP_UNIT=yes ;; p) SKIP_PLN=yes ;; + u) SKIP_UNIT=yes ;; h|\?) usage ;; esac done @@ -47,12 +47,19 @@ mkdir test-tmp ln -s /bin/ls test-tmp/ls-link # Set the timestamps on 64-bit-timestamp-2038.txt and -# 64-bit-timestamp-2106.txt. The time for the first file is a -# negative value for a 32-bit time_t. The second file won't fit in a -# 32-bit time_t value. It's ok if this doesn't work in general, as -# long as it works on Linux for the stat test in tests/os.lisp. -touch -d "1 April 2038" tests/resources/64-bit-timestamp-2038.txt -touch -d "1 April 2106" tests/resources/64-bit-timestamp-2106.txt +# 64-bit-timestamp-2106.txt, but only for OSes where we know this +# works. (This is so we don't an annoying error message from touch +# that doesn't accept the -d option, like MacOS 10.13.) The time for +# the first file is a negative value for a 32-bit time_t. The second +# file won't fit in a 32-bit time_t value. It's ok if this doesn't +# work in general, as long as it works on Linux for the stat test in +# tests/os.lisp. +case `uname -s` in + Linux) + touch -d "1 April 2038" tests/resources/64-bit-timestamp-2038.txt + touch -d "1 April 2106" tests/resources/64-bit-timestamp-2106.txt + ;; +esac # Cleanup temp files and directories that we created during testing. function cleanup { @@ -95,8 +102,6 @@ if [ "$SKIP_UNIT" != "yes" ]; then fi ## Now run tests for trivial-package-local-nicknames -echo SKIP_PLN = $SKIP_PLN - if [ "$SKIP_PLN" != "yes" ]; then REPO=trivial-package-local-nicknames BRANCH=cmucl-updates ===================================== src/code/exports.lisp ===================================== @@ -1213,7 +1213,8 @@ "INVALID-FASL" "WITH-TEMPORARY-DIRECTORY" - "WITH-TEMPORARY-FILE") + "WITH-TEMPORARY-FILE" + "DELETE-DIRECTORY") ;; gencgc features #+gencgc (:export "GET-GC-ASSERTIONS" ===================================== src/code/extensions.lisp ===================================== @@ -673,9 +673,9 @@ (defun delete-directory (dirname &key recursive) _N"Delete the directory Dirname. If the Recursive is non-NIL, recursively delete the directory Dirname including all files and - subdirectories. Dirname must be a pathname to a directory. Any NAME - or TYPE components in Dirname are ignored." - (declare (type pathname dirname)) + subdirectories. Dirname must name a directory. Any NAME or TYPE + components in Dirname are ignored. A FILE-ERROR is signaled if any + directory cannot be deleted." (when recursive ;; Find all the files or directories in DIRNAME. (dolist (path (directory (merge-pathnames "*.*" dirname))) @@ -685,8 +685,15 @@ (delete-directory path :recursive t) (delete-file path)))) ;; Finally delete the directory. - (unix:unix-rmdir (namestring dirname)) - (values)) + (multiple-value-bind (ok errno) + (unix:unix-rmdir (namestring dirname)) + (unless ok + (error 'kernel:simple-file-error + :pathname dirname + :format-control (intl:gettext "Could not remove directory \"~A\": ~A.") + :format-arguments (list dirname + (unix:get-unix-error-msg errno)))) + ok)) ;;; WITH-TEMPORARY-DIRECTORY -- Public ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -6011,8 +6011,13 @@ msgstr "" msgid "" "Delete the directory Dirname. If the Recursive is non-NIL,\n" " recursively delete the directory Dirname including all files and\n" -" subdirectories. Dirname must be a pathname to a directory. Any NAME\n" -" or TYPE components in Dirname are ignored." +" subdirectories. Dirname must name a directory. Any NAME or TYPE\n" +" components in Dirname are ignored. A FILE-ERROR is signaled if any\n" +" directory cannot be deleted." +msgstr "" + +#: src/code/extensions.lisp +msgid "Could not remove directory \"~A\": ~A." msgstr "" #: src/code/extensions.lisp ===================================== tests/float-x86.lisp ===================================== @@ -5,6 +5,11 @@ (in-package "FLOAT-X86-TESTS") +;; This tests the floating-point modes for x86. This works only if we +;; have the feature :sse2 but not :darwin since darwin has always used +;; sse2 and not x87. But see also how FLOATING-POINT-MODES is +;; implemented in src/code/float-trap.lisp. +#+(and sse2 (not darwin)) (define-test set-floating-point-modes (let ((old-x87-modes (x86::x87-floating-point-modes)) (old-sse2-modes (x86::sse2-floating-point-modes)) ===================================== tests/float.lisp ===================================== @@ -343,8 +343,6 @@ (assert-true (typep new-mode 'x86::float-modes)) (assert-equal new-mode (setf (x86::x87-floating-point-modes) new-mode)))) - - ;; Issue #458 (define-test dd-mult-overflow (:tag :issues) ===================================== tests/os.lisp ===================================== @@ -51,6 +51,7 @@ (assert-equal 2153718000 st-atime) (assert-equal 2153718000 st-mtime)))) +#+linux (define-test stat.64-bit-timestamp-2106 (:tag :issues) (let ((test-file #.(merge-pathnames "resources/64-bit-timestamp-2106.txt" ===================================== tests/pathname.lisp ===================================== @@ -144,14 +144,13 @@ (assert-equal dir-tilde dir-home)))) (define-test delete-directory - (let ((dir (ensure-directories-exist "tmp/a/b/c/"))) - ;; Verify that the directories were created. - (assert-equal "tmp/a/b/c/" - dir) - ;; Try to delete the directory. It should fail, which we verify - ;; by noting the directory listing is not empty. - (ext::delete-directory (pathname "tmp/")) - (assert-true (directory "tmp/")) - ;; Now recursively delete the directory. - (ext::delete-directory (pathname "tmp/") :recursive t) - (assert-false (directory "tmp/")))) + (:tag :issues) + (ext:with-temporary-directory (path) + (let ((dir (ensure-directories-exist (merge-pathnames "tmp/a/b/c/" path)))) + ;; Try to delete the directory. It should fail.. + (assert-error 'kernel:simple-file-error + (ext:delete-directory (merge-pathnames "tmp/" path))) + ;; Now recursively delete the directory. + (assert-true (ext:delete-directory (merge-pathnames "tmp/" path) + :recursive t)) + (assert-false (directory "tmp/"))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9c16379a168976b4d96b245... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9c16379a168976b4d96b245... You're receiving this email because of your account on gitlab.common-lisp.net.