Raymond Toy pushed to branch issue-456-more-accurate-complex-div at cmucl / cmucl Commits: 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 - - - - - 58358927 by Raymond Toy at 2026-01-02T14:27:25-08:00 Fix #454 and #138: Signal errors for bad components for make-pathname - - - - - 97824b42 by Raymond Toy at 2026-01-02T14:27:25-08:00 Merge branch 'issue-454-signal-error-for-bad-pathname-parts' into 'master' Fix #454 and #138: Signal errors for bad components for make-pathname Closes #454 and #138 See merge request cmucl/cmucl!333 - - - - - 1f8eb92e by Raymond Toy at 2026-01-07T08:00:45-08:00 Merge branch 'master' into issue-456-more-accurate-complex-div - - - - - 7457eadb by Raymond Toy at 2026-01-07T10:21:05-08:00 Block compile cdiv with two-arg-/ To reduce consing, block compile cdiv-double-float and friends with two-arg-/. This allows two-arg-/ to use the local-call convention to jump directly to the no-arg parsing section, skipping the parsing of the args. - - - - - 7 changed files: - bin/run-unit-tests.sh - src/code/numbers.lisp - src/code/pathname.lisp - src/i18n/locale/cmucl.pot - tests/float-x86.lisp - tests/os.lisp - tests/pathname.lisp Changes: ===================================== 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/numbers.lisp ===================================== @@ -602,154 +602,156 @@ ;; In particular iteration 1 and 3 are added. Iteration 2 and 4 were ;; not added. The test examples from iteration 2 and 4 didn't change ;; with or without changes added. -(let* ((+rmin+ least-positive-normalized-double-float) - (+rbig+ (/ most-positive-double-float 2)) - (+rmin2+ (scale-float 1d0 -53)) - (+rminscal+ (scale-float 1d0 51)) - (+rmax2+ (* +rbig+ +rmin2+)) - ;; The value of %eps in Scilab - (+eps+ (scale-float 1d0 -52)) - (+be+ (/ 2 (* +eps+ +eps+))) - (+2/eps+ (/ 2 +eps+))) - (declare (double-float +rmin+ +rbig+ +rmin2+ +rminscal+ +rmax2+ - +eps+ +be+ +2/eps+)) - (defun cdiv-double-float (x y) - (declare (type (complex double-float) x y) - (optimize (speed 3) (safety 0))) - (labels - ((internal-compreal (a b c d r tt) - (declare (double-float a b c d r tt)) - ;; Compute the real part of the complex division - ;; (a+ib)/(c+id), assuming |d| <= |c|. r = d/c and tt = 1/(c+d*r). - ;; - ;; The realpart is (a*c+b*d)/(c^2+d^2). - ;; - ;; c^2+d^2 = c*(c+d*(d/c)) = c*(c+d*r) - ;; - ;; Then - ;; - ;; (a*c+b*d)/(c^2+d^2) = (a*c+b*d)/(c*(c+d*r)) - ;; = (a + b*d/c)/(c+d*r) - ;; = (a + b*r)/(c + d*r). - ;; - ;; Thus tt = (c + d*r). - (cond ((>= (abs r) +rmin+) - (let ((br (* b r))) - (if (/= br 0d0) - (/ (+ a br) tt) - ;; b*r underflows. Instead, compute - ;; - ;; (a + b*r)*tt = a*tt + b*tt*r - ;; = a*tt + (b*tt)*r - ;; (a + b*r)/tt = a/tt + b/tt*r - ;; = a*tt + (b*tt)*r - (+ (/ a tt) - (* (/ b tt) - r))))) - (t - ;; r = 0 so d is very tiny compared to c. - ;; - (/ (+ a (* d (/ b c))) - tt)))) - (robust-subinternal (a b c d) - (declare (double-float a b c d)) - (let* ((r (/ d c)) - (tt (+ c (* d r)))) - ;; e is the real part and f is the imaginary part. We - ;; can use internal-compreal for the imaginary part by - ;; noticing that the imaginary part of (a+i*b)/(c+i*d) is - ;; the same as the real part of (b-i*a)/(c+i*d). - (let ((e (internal-compreal a b c d r tt)) - (f (internal-compreal b (- a) c d r tt))) - (values e - f)))) +(defconstant +cdiv-rmin+ least-positive-normalized-double-float) +(defconstant +cdiv-rbig+ (/ most-positive-double-float 2)) +(defconstant +cdiv-rmin2+ (scale-float 1d0 -53)) +(defconstant +cdiv-rminscal+ (scale-float 1d0 51)) +(defconstant +cdiv-rmax2+ (* +cdiv-rbig+ +cdiv-rmin2+)) +;; This is the value of %eps from Scilab +(defconstant +cdiv-eps+ (scale-float 1d0 -52)) +(defconstant +cdiv-be+ (/ 2 (* +cdiv-eps+ +cdiv-eps+))) +(defconstant +cdiv-2/eps+ (/ 2 +cdiv-eps+)) + +(declaim (ext:start-block cdiv-double-float cdiv-single-float two-arg-/)) + +(defun cdiv-double-float (x y) + (declare (type (complex double-float) x y) + (optimize (speed 3) (safety 0))) + (labels + ((internal-compreal (a b c d r tt) + (declare (double-float a b c d r tt)) + ;; Compute the real part of the complex division + ;; (a+ib)/(c+id), assuming |c| <= |d|. r = d/c and tt = 1/(c+d*r). + ;; + ;; The realpart is (a*c+b*d)/(c^2+d^2). + ;; + ;; c^2+d^2 = c*(c+d*(d/c)) = c*(c+d*r) + ;; + ;; Then + ;; + ;; (a*c+b*d)/(c^2+d^2) = (a*c+b*d)/(c*(c+d*r)) + ;; = (a + b*d/c)/(c+d*r) + ;; = (a + b*r)/(c + d*r). + ;; + ;; Thus tt = (c + d*r). + (cond ((>= (abs r) +cdiv-rmin+) + (let ((br (* b r))) + (if (/= br 0) + (/ (+ a br) tt) + ;; b*r underflows. Instead, compute + ;; + ;; (a + b*r)*tt = a*tt + b*tt*r + ;; = a*tt + (b*tt)*r + ;; (a + b*r)/tt = a/tt + b/tt*r + ;; = a*tt + (b*tt)*r + (+ (/ a tt) + (* (/ b tt) + r))))) + (t + ;; r = 0 so d is very tiny compared to c. + ;; + (/ (+ a (* d (/ b c))) + tt)))) + (robust-subinternal (a b c d) + (declare (double-float a b c d)) + (let* ((r (/ d c)) + (tt (+ c (* d r)))) + ;; e is the real part and f is the imaginary part. We + ;; can use internal-compreal for the imaginary part by + ;; noticing that the imaginary part of (a+i*b)/(c+i*d) is + ;; the same as the real part of (b-i*a)/(c+i*d). + (let ((e (internal-compreal a b c d r tt)) + (f (internal-compreal b (- a) c d r tt))) + (values e + f)))) - (robust-internal (x y) - (declare (type (complex double-float) x y)) - (let ((a (realpart x)) - (b (imagpart x)) - (c (realpart y)) - (d (imagpart y))) - (declare (double-float a b c d)) - (flet ((maybe-scale (abs-tst a b c d) - (declare (double-float a b c d)) - ;; This implements McGehearty's iteration 3 to - ;; handle the case when some values are too big - ;; and should be scaled down. Also if some - ;; values are too tiny, scale them up. - (let ((abs-a (abs a)) - (abs-b (abs b))) - (if (or (> abs-tst +rbig+) - (> abs-a +rbig+) - (> abs-b +rbig+)) - (setf a (* a 0.5d0) - b (* b 0.5d0) - c (* c 0.5d0) - d (* d 0.5d0)) - (if (< abs-tst +rmin2+) - (setf a (* a +rminscal+) - b (* b +rminscal+) - c (* c +rminscal+) - d (* d +rminscal+)) - (if (or (and (< abs-a +rmin+) - (< abs-b +rmax2+) - (< abs-tst +rmax2+)) - (and (< abs-b +rmin+) - (< abs-a +rmax2+) - (< abs-tst +rmax2+))) - (setf a (* a +rminscal+) - b (* b +rminscal+) - c (* c +rminscal+) - d (* d +rminscal+))))) - (values a b c d)))) - (cond - ((<= (abs d) (abs c)) - ;; |d| <= |c|, so we can use robust-subinternal to - ;; perform the division. - (multiple-value-bind (a b c d) - (maybe-scale (abs c) a b c d) - (multiple-value-bind (e f) - (robust-subinternal a b c d) - (complex e f)))) - (t - ;; |d| > |c|. So, instead compute - ;; - ;; (b + i*a)/(d + i*c) - ;; = ((b*d+a*c) + (a*d-b*c)*i)/(d^2+c^2) - ;; - ;; Compare this to (a+i*b)/(c+i*d) and we see that - ;; realpart of the former is the same, but the - ;; imagpart of the former is the negative of the - ;; desired division. - (multiple-value-bind (a b c d) - (maybe-scale (abs d) a b c d) - (multiple-value-bind (e f) - (robust-subinternal b a d c) - (complex e (- f)))))))))) - (let* ((max-ab (max (abs (realpart x)) - (abs (imagpart x)))) - (max-cd (max (abs (realpart y)) - (abs (imagpart y)))) - (s 1d0)) - (declare (double-float s)) - ;; If a or b is big, scale down a and b. - (when (>= max-ab +rbig+) - (setf x (/ x 2d0) - s (* s 2d0))) - ;; If c or d is big, scale down c and d. - (when (>= max-cd +rbig+) - (setf y (/ y 2d0) - s (/ s 2d0))) - ;; If a or b is tiny, scale up a and b. - (when (<= max-ab (* +rmin+ +2/eps+)) - (setf x (* x +be+) - s (/ s +be+))) - ;; If c or d is tiny, scale up c and d. - (when (<= max-cd (* +rmin+ +2/eps+)) - (setf y (* y +be+) - s (* s +be+))) - (* s - (robust-internal x y)))))) + (robust-internal (x y) + (declare (type (complex double-float) x y)) + (let ((a (realpart x)) + (b (imagpart x)) + (c (realpart y)) + (d (imagpart y))) + (declare (double-float a b c d)) + (flet ((maybe-scale (abs-tst a b c d) + (declare (double-float a b c d)) + ;; This implements McGehearty's iteration 3 to + ;; handle the case when some values are too big + ;; and should be scaled down. Also if some + ;; values are too tiny, scale them up. + (let ((abs-a (abs a)) + (abs-b (abs b))) + (if (or (> abs-tst +cdiv-rbig+) + (> abs-a +cdiv-rbig+) + (> abs-b +cdiv-rbig+)) + (setf a (* a 0.5d0) + b (* b 0.5d0) + c (* c 0.5d0) + d (* d 0.5d0)) + (if (< abs-tst +cdiv-rmin2+) + (setf a (* a +cdiv-rminscal+) + b (* b +cdiv-rminscal+) + c (* c +cdiv-rminscal+) + d (* d +cdiv-rminscal+)) + (if (or (and (< abs-a +cdiv-rmin+) + (< abs-b +cdiv-rmax2+) + (< abs-tst +cdiv-rmax2+)) + (and (< abs-b +cdiv-rmin+) + (< abs-a +cdiv-rmax2+) + (< abs-tst +cdiv-rmax2+))) + (setf a (* a +cdiv-rminscal+) + b (* b +cdiv-rminscal+) + c (* c +cdiv-rminscal+) + d (* d +cdiv-rminscal+))))) + (values a b c d)))) + (cond + ((<= (abs d) (abs c)) + ;; |d| <= |c|, so we can use robust-subinternal to + ;; perform the division. + (multiple-value-bind (a b c d) + (maybe-scale (abs c) a b c d) + (multiple-value-bind (e f) + (robust-subinternal a b c d) + (complex e f)))) + (t + ;; |d| > |c|. So, instead compute + ;; + ;; (b + i*a)/(d + i*c) = ((b*d+a*c) + (a*d-b*c)*i)/(d^2+c^2) + ;; + ;; Compare this to (a+i*b)/(c+i*d) and we see that + ;; realpart of the former is the same, but the + ;; imagpart of the former is the negative of the + ;; desired division. + (multiple-value-bind (a b c d) + (maybe-scale (abs d) a b c d) + (multiple-value-bind (e f) + (robust-subinternal b a d c) + (complex e (- f)))))))))) + (let* ((a (realpart x)) + (b (imagpart x)) + (c (realpart y)) + (d (imagpart y)) + (ab (max (abs a) (abs b))) + (cd (max (abs c) (abs d))) + (s 1d0)) + (declare (double-float s)) + ;; If a or b is big, scale down a and b. + (when (>= ab +cdiv-rbig+) + (setf x (/ x 2) + s (* s 2))) + ;; If c or d is big, scale down c and d. + (when (>= cd +cdiv-rbig+) + (setf y (/ y 2) + s (/ s 2))) + ;; If a or b is tiny, scale up a and b. + (when (<= ab (* +cdiv-rmin+ +cdiv-2/eps+)) + (setf x (* x +cdiv-be+) + s (/ s +cdiv-be+))) + ;; If c or d is tiny, scale up c and d. + (when (<= cd (* +cdiv-rmin+ +cdiv-2/eps+)) + (setf y (* y +cdiv-be+) + s (* s +cdiv-be+))) + (* s + (robust-internal x y))))) ;; Smith's algorithm for complex division for (complex single-float). ;; We convert the parts to double-floats before computing the result. @@ -850,7 +852,7 @@ (((complex rational) (complex rational)) ;; We probably don't need to do Smith's algorithm for rationals. - ;; A naive implementation of complex division has no issues. + ;; A naive implementation of coplex division has no issues. (let ((a (realpart x)) (b (imagpart x)) (c (realpart y)) @@ -907,6 +909,7 @@ (build-ratio (maybe-truncate nx gcd) (* (maybe-truncate y gcd) (denominator x))))))) +(declaim (ext:end-block)) (defun %negate (n) (number-dispatch ((n number)) ===================================== src/code/pathname.lisp ===================================== @@ -838,14 +838,18 @@ a host-structure or string." (%pathname-directory defaults) diddle-defaults))) - ;; A bit of sanity checking on user arguments. + ;; A bit of sanity checking on user arguments. We don't allow a + ;; "/" or NUL in any string that's part of a pathname object. (flet ((check-component-validity (name name-or-type) (when (stringp name) - (let ((unix-directory-separator #\/)) - (when (eq host (%pathname-host *default-pathname-defaults*)) - (when (find unix-directory-separator name) - (warn (intl:gettext "Silly argument for a unix ~A: ~S") - name-or-type name))))))) + (when (eq host (%pathname-host *default-pathname-defaults*)) + (when (some #'(lambda (c) + ;; Illegal characters are a slash or NUL. + (case c + ((#\/ #\null) t))) + name) + (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) (mapc #'(lambda (d) @@ -856,8 +860,9 @@ a host-structure or string." (not type)) (and (string= name ".") (not type)))) - ;; - (warn (intl:gettext "Silly argument for a unix PATHNAME-NAME: ~S") name))) + ;; + (cerror _"Continue anyway" + _"PATHNAME-NAME cannot be \".\" or \"..\""))) ;; More sanity checking (when dir ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -7717,7 +7717,7 @@ msgstr "" msgid ", type=" msgstr "" -#: src/code/print.lisp +#: src/code/pathname.lisp src/code/print.lisp msgid "Continue anyway" msgstr "" @@ -9785,17 +9785,17 @@ msgid "~S is not allowed as a directory component." msgstr "" #: src/code/pathname.lisp -msgid "" -"Makes a new pathname from the component arguments. Note that host is\n" -"a host-structure or string." +msgid "Pathname component ~A cannot contain a slash or nul character: ~S" msgstr "" #: src/code/pathname.lisp -msgid "Silly argument for a unix ~A: ~S" +msgid "PATHNAME-NAME cannot be \".\" or \"..\"" msgstr "" #: src/code/pathname.lisp -msgid "Silly argument for a unix PATHNAME-NAME: ~S" +msgid "" +"Makes a new pathname from the component arguments. Note that host is\n" +"a host-structure or string." msgstr "" #: src/code/pathname.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/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 ===================================== @@ -153,4 +153,30 @@ ;; Now recursively delete the directory. (assert-true (ext:delete-directory (merge-pathnames "tmp/" path) :recursive t)) - (assert-false (directory "tmp/"))))) + (assert-false (directory (merge-pathnames "tmp/" path)))))) + +(define-test issue.454.illegal-pathname-chars + (:tag :issues) + ;; A slash (Unix directory separater) is not allowed. + (assert-error 'simple-error + (make-pathname :name "a/b")) + (assert-error 'simple-error + (make-pathname :type "a/b")) + (assert-error 'simple-error + (make-pathname :directory '(:relative "a/b"))) + ;; ASCII NUL characters are not allowed in Unix pathnames. + (let ((string-with-nul (concatenate 'string "a" (string #\nul) "b"))) + (assert-error 'simple-error + (make-pathname :name string-with-nul)) + (assert-error 'simple-error + (make-pathname :type string-with-nul)) + (assert-error 'simple-error + (make-pathname :directory (list :relative string-with-nul))))) + +(define-test issue.454.illegal-pathname-dot + (:tag :issues) + (assert-error 'simple-error + (make-pathname :name ".")) + (assert-error 'simple-error + (make-pathname :name ".."))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ef99f00954a34ece65ebdb8... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ef99f00954a34ece65ebdb8... You're receiving this email because of your account on gitlab.common-lisp.net.