Raymond Toy pushed to branch issue-454-signal-error-for-bad-pathname-parts at cmucl / cmucl Commits: b04aaec6 by Raymond Toy at 2025-12-03T18:30:46-08:00 Dummy commit to run pipeline Just removed an extra line at the end of the file. - - - - - 16c334b0 by Raymond Toy at 2025-12-04T15:46:41-08:00 Undo previous change that deleted a blank line Dummy commit to get CI to run to test out concurrent builds. (concurrent=2). - - - - - 25cd44a2 by Raymond Toy at 2025-12-04T17:57:49-08:00 Fix #455: Allow manual pipeline runs - - - - - ae1bdde7 by Raymond Toy at 2025-12-04T17:57:50-08:00 Merge branch 'issue-455-manual-pipeline-run' into 'master' Fix #455: Allow manual pipeline runs Closes #455 See merge request cmucl/cmucl!334 - - - - - fd2e83a1 by Raymond Toy at 2025-12-12T15:38:35-08:00 Fix two important typos in unix-get-username and delete-directory In `unix-get-username`, we were freeing `name` instead of `result`. In `delete-directory`, we misspelled `recursive` as `recusive`. Fix these typos. - - - - - b9494595 by Raymond Toy at 2025-12-12T15:54:05-08:00 Add some tests for unix-get-username and delete-directory Add a simple test that unix-get-username returns something useful. Add a test for delete-directory that tests it deletes directories as specified, include recursively. - - - - - e2b4641a by Raymond Toy at 2025-12-13T14:24:22-08:00 Fix #458: Fix spurious overflow in double-double multiply - - - - - 16097f45 by Raymond Toy at 2025-12-13T14:24:22-08:00 Merge branch 'issue-458-double-double-mult-overflow' into 'master' Fix #458: Fix spurious overflow in double-double multiply Closes #458 See merge request cmucl/cmucl!337 - - - - - f146f87f by Raymond Toy at 2025-12-13T15:11:21-08:00 Add fixed issue #458 to release notes Forgot to do that. [skip-ci] - - - - - 2c36bac8 by Raymond Toy at 2025-12-15T17:34:46-08:00 Use (new) Ubuntu VM to run CI instead of OpenSUSE - - - - - 7ebc2654 by Raymond Toy at 2025-12-15T17:34:46-08:00 Merge branch 'rtoy-add-ubuntu-runner' into 'master' Use (new) Ubuntu VM to run CI instead of OpenSUSE See merge request cmucl/cmucl!339 - - - - - 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] - - - - - 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 - - - - - 66899cbc by Raymond Toy at 2026-01-02T12:59:03-08:00 Apply suggested change to use SOME and signal error not cerror - - - - - 266283df by Raymond Toy at 2026-01-02T13:15:03-08:00 Merge branch 'master' into issue-454-signal-error-for-bad-pathname-parts Fix merge conflict in tests/pathname.lisp - - - - - 14 changed files: - .gitlab-ci.yml - bin/run-unit-tests.sh - src/code/exports.lisp - src/code/extensions.lisp - src/code/pathname.lisp - src/code/unix.lisp - src/compiler/float-tran-dd.lisp - src/general-info/release-22a.md - src/i18n/locale/cmucl.pot - tests/float-x86.lisp - tests/float.lisp - tests/os.lisp - tests/pathname.lisp - tests/unix.lisp Changes: ===================================== .gitlab-ci.yml ===================================== @@ -19,6 +19,8 @@ variables: script: - echo PATH = $PATH - ls -F /usr/local/bin + # Make sure gitlab-runner is available because it's needed by the + # VM to upload artifacts. - type -all gitlab-runner # Download binaries. (Do we really need the extras tarball?) - $CURL -o cmucl-$version-$osname.tar.$tar_ext $download_url/cmucl-$version-$osname.tar.$tar_ext @@ -133,6 +135,7 @@ linux:install: - if: $CI_PIPELINE_SOURCE == "push" - if: $CI_PIPELINE_SOURCE == "merge_request_event" - if: $CI_PIPELINE_SOURCE == "branch" + - if: $CI_PIPELINE_SOURCE == "web" linux:build: <<: *build_configuration @@ -148,6 +151,7 @@ linux:build: - if: $CI_PIPELINE_SOURCE == "schedule" - if: $CI_PIPELINE_SOURCE == "push" - if: $CI_PIPELINE_SOURCE == "merge_request_event" + - if: $CI_PIPELINE_SOURCE == "web" linux:cross-build: stage: build @@ -316,38 +320,38 @@ linux:static-analyzer: - make -C build-4/lisp ANALYZER=-fanalyzer > analyzer.log 2>&1 #### OpenSUSE jobs #### -opensuse:install: +ubuntu:install: <<: *install_configuration tags: - - opensuse + - ubuntu variables: osname: "linux" CURL: "curl" -opensuse:build: +ubuntu:build: <<: *build_configuration tags: - - opensuse + - ubuntu needs: - - job: opensuse:install + - job: ubuntu:install artifacts: true -opensuse:test: +ubuntu:test: <<: *unit_test_configuration tags: - - opensuse + - ubuntu needs: # Needs artifacts from build (dist/) - - job: opensuse:build + - job: ubuntu:build artifacts: true -opensuse:ansi-test: +ubuntu:ansi-test: <<: *ansi_test_configuration tags: - - opensuse + - ubuntu needs: # Needs artifacts from build (dist/) - - job: opensuse:build + - job: ubuntu:build artifacts: true # Optional job that runs the markdown link checker. This is optional ===================================== bin/run-unit-tests.sh ===================================== @@ -9,6 +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 " -p Skip package-local-nicknames test" + echo " -u Skip lisp-unit tests" echo " -? This help message" echo " -h This help message" echo "" @@ -25,11 +27,13 @@ usage() { } LISP=lisp -while getopts "h?l:d:" arg +while getopts "puh?l:d:" arg do case $arg in l) LISP=$OPTARG ;; d) TESTDIR=$OPTARG ;; + p) SKIP_PLN=yes ;; + u) SKIP_UNIT=yes ;; h|\?) usage ;; esac done @@ -43,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 { @@ -69,39 +80,47 @@ fi # gcc since clang isn't always available. (cd "$TESTDIR" || exit 1 ; gcc -m32 -O3 -c test-return.c) -if [ $# -eq 0 ]; then - # Test directory arg for run-all-tests if a non-default - # No args so run all the tests - $LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(cmucl-test-runner:run-all-tests ${TESTDIRARG})" -else - # Run selected files. Convert each file name to uppercase and append "-TESTS" - result="" - for f in "$@" - do - new=$(echo "$f" | tr '[:lower:]' '[:upper:]') - result="$result "\"$new-TESTS\" - done - $LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test $result))" +if [ "$SKIP_UNIT" != "yes" ]; then + if [ $# -eq 0 ]; then + # Test directory arg for run-all-tests if a non-default + # No args so run all the tests + $LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(cmucl-test-runner:run-all-tests ${TESTDIRARG})" || + exit 1 + else + # Run selected files. Convert each file name to uppercase and append "-TESTS" + result="" + for f in "$@" + do + new=$(echo "$f" | tr '[:lower:]' '[:upper:]') + result="$result "\"$new-TESTS\" + done + # Run unit tests. Exits with a non-zero code if there's a failure. + + $LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test $result))" || + exit 1 + fi fi ## Now run tests for trivial-package-local-nicknames -REPO=trivial-package-local-nicknames -BRANCH=cmucl-updates +if [ "$SKIP_PLN" != "yes" ]; then + REPO=trivial-package-local-nicknames + BRANCH=cmucl-updates -set -x -if [ -d ../$REPO ]; then - (cd ../$REPO || exit 1; git stash; git checkout $BRANCH; git pull --rebase) -else - (cd ..; git clone https://gitlab.common-lisp.net/cmucl/$REPO.git) -fi + set -x + if [ -d ../$REPO ]; then + (cd ../$REPO || exit 1; git stash; git checkout $BRANCH; git pull --rebase) + else + (cd ..; git clone https://gitlab.common-lisp.net/cmucl/$REPO.git) + fi -LISP=$PWD/$LISP -cd ../$REPO || exit 1 -git checkout $BRANCH + LISP=$PWD/$LISP + cd ../$REPO || exit 1 + git checkout $BRANCH -# Run the tests. Exits with a non-zero code if there's a failure. -$LISP -noinit -nositeinit -batch <<'EOF' + # Run the tests. Exits with a non-zero code if there's a failure. + $LISP -noinit -nositeinit -batch <<'EOF' (require :asdf) (push (default-directory) asdf:*central-registry*) (asdf:test-system :trivial-package-local-nicknames) EOF +fi ===================================== 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,10 +673,10 @@ (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)) - (when recusive + 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))) ;; If the path is a directory, recursively delete the directory. @@ -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/code/pathname.lisp ===================================== @@ -843,13 +843,12 @@ a host-structure or string." (flet ((check-component-validity (name name-or-type) (when (stringp name) (when (eq host (%pathname-host *default-pathname-defaults*)) - (when (find-if #'(lambda (c) - ;; Illegal characters are a slash or NUL. - (or (char= c #\/) - (char= c #\nul))) + (when (some #'(lambda (c) + ;; Illegal characters are a slash or NUL. + (case c + ((#\/ #\null) t))) name) - (cerror _"Continue anyway" - _"Pathname component ~A cannot contain a slash or nul character: ~S" + (error _"Pathname component ~A cannot contain a slash or nul character: ~S" name-or-type name)))))) (check-component-validity name :pathname-name) (check-component-validity type :pathname-type) ===================================== src/code/unix.lisp ===================================== @@ -2564,5 +2564,5 @@ (cast result c-call:c-string) nil) status)) - (free-alien name))))) + (free-alien result))))) ===================================== src/compiler/float-tran-dd.lisp ===================================== @@ -290,10 +290,10 @@ (optimize (speed 3))) ;; If the numbers are too big, scale them done so SPLIT doesn't overflow. (multiple-value-bind (aa bb) - (values (if (> a +two970+) + (values (if (> (abs a) +two970+) (* a +two-53+) a) - (if (> b +two970+) + (if (> (abs b) +two970+) (* b +two-53+) b)) (let ((p (* aa bb))) @@ -314,10 +314,10 @@ (declare (optimize (inhibit-warnings 3))) ;; If the numbers was scaled down, we need to scale the ;; result back up. - (when (> a +two970+) + (when (> (abs a) +two970+) (setf p (* p +two53+) e (* e +two53+))) - (when (> b +two970+) + (when (> (abs b) +two970+) (setf p (* p +two53+) e (* e +two53+))) (values p e)))))))) ===================================== src/general-info/release-22a.md ===================================== @@ -34,6 +34,7 @@ public domain. * #446: Use C compiler to get errno values to update UNIX defpackage with errno symbols * #453: Use correct flags for analyzer and always save logs. + * #458: Spurious overflow in double-double-float multiply * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== 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 ===================================== @@ -342,3 +342,9 @@ (x86::x87-floating-point-modes))))) (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) + (assert-equal -2w300 + (* -2w300 1w0))) ===================================== 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 ===================================== @@ -143,6 +143,18 @@ :truenamep nil :follow-links nil))) (assert-equal dir-tilde dir-home)))) +(define-test delete-directory + (: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 (merge-pathnames "tmp/" path)))))) + (define-test issue.454.illegal-pathname-chars (:tag :issues) ;; A slash (Unix directory separater) is not allowed. @@ -167,3 +179,4 @@ (make-pathname :name ".")) (assert-error 'simple-error (make-pathname :name ".."))) + ===================================== tests/unix.lisp ===================================== @@ -88,4 +88,7 @@ (assert-false result) (assert-true (and (integerp errno) (plusp errno))))) - +(define-test unix-get-username + (let ((uid (unix:unix-getuid))) + (assert-true uid) + (assert-true (unix::unix-get-username uid)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b2c51c988f73c44824b5d9f... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b2c51c988f73c44824b5d9f... You're receiving this email because of your account on gitlab.common-lisp.net.