December 2025 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl] Pushed new branch rtoy-add-ubuntu-runner
by Raymond Toy (＠rtoy) 15 Dec '25

15 Dec '25

Raymond Toy pushed new branch rtoy-add-ubuntu-runner at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/rtoy-add-ubuntu-runner You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-457-delete-directory-signals-errors] 5 commits: Fix #458: Fix spurious overflow in double-double multiply
by Raymond Toy (＠rtoy) 14 Dec '25

14 Dec '25

Raymond Toy pushed to branch issue-457-delete-directory-signals-errors at cmucl / cmucl Commits: 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] - - - - - 50d2569d by Raymond Toy at 2025-12-14T08:27:27-08:00 Merge branch 'master' into issue-457-delete-directory-signals-errors - - - - - 3099b050 by Raymond Toy at 2025-12-14T12:29:22-08:00 Minor cleanups Fix typo in exports.lisp so DELETE-DIRECTORY is actually exported. Update docstring for DELETE-DIRECTORY and the pot file. For tests/pathname.lisp, use WITH-TEMPORARY-DIRECTORY to create a temp directory which we'll populate with some subdirectories to test how DELETE-DIRECTORY works. - - - - - 7 changed files: - src/code/exports.lisp - src/code/extensions.lisp - src/compiler/float-tran-dd.lisp - src/general-info/release-22a.md - src/i18n/locale/cmucl.pot - tests/float.lisp - tests/pathname.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1214,7 +1214,7 @@ "INVALID-FASL" "WITH-TEMPORARY-DIRECTORY" "WITH-TEMPORARY-FILE" - "DELETE-DIRETORY") + "DELETE-DIRECTORY") ;; gencgc features #+gencgc (:export "GET-GC-ASSERTIONS" ===================================== src/code/extensions.lisp ===================================== @@ -673,8 +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." + 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))) ===================================== 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,9 @@ 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 ===================================== tests/float.lisp ===================================== @@ -342,3 +342,11 @@ (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/pathname.lisp ===================================== @@ -144,13 +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.. - (assert-error 'kernel:simple-file-error - (ext:delete-directory (pathname "tmp/"))) - ;; Now recursively delete the directory. - (assert-true (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/d427507d77f6dcdf899f2a… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d427507d77f6dcdf899f2a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-457-delete-directory-signals-errors] Export DELETE-DIRECTORY
by Raymond Toy (＠rtoy) 14 Dec '25

14 Dec '25

Raymond Toy pushed to branch issue-457-delete-directory-signals-errors at cmucl / cmucl Commits: d427507d by Raymond Toy at 2025-12-13T20:34:27-08:00 Export DELETE-DIRECTORY Update tests to use exported symbol. - - - - - 2 changed files: - src/code/exports.lisp - tests/pathname.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1213,7 +1213,8 @@ "INVALID-FASL" "WITH-TEMPORARY-DIRECTORY" - "WITH-TEMPORARY-FILE") + "WITH-TEMPORARY-FILE" + "DELETE-DIRETORY") ;; gencgc features #+gencgc (:export "GET-GC-ASSERTIONS" ===================================== tests/pathname.lisp ===================================== @@ -150,7 +150,7 @@ dir) ;; Try to delete the directory. It should fail.. (assert-error 'kernel:simple-file-error - (ext::delete-directory (pathname "tmp/"))) + (ext:delete-directory (pathname "tmp/"))) ;; Now recursively delete the directory. - (assert-true (ext::delete-directory (pathname "tmp/") :recursive t)) + (assert-true (ext:delete-directory (pathname "tmp/") :recursive t)) (assert-false (directory "tmp/")))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d427507d77f6dcdf899f2ad… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d427507d77f6dcdf899f2ad… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-456-more-accurate-complex-div] Fix typo in release notes: item was incorrectly indented
by Raymond Toy (＠rtoy) 14 Dec '25

14 Dec '25

Raymond Toy pushed to branch issue-456-more-accurate-complex-div at cmucl / cmucl Commits: 2e3981c0 by Raymond Toy at 2025-12-13T20:26:41-08:00 Fix typo in release notes: item was incorrectly indented [skip-ci] - - - - - 1 changed file: - src/general-info/release-22a.md Changes: ===================================== src/general-info/release-22a.md ===================================== @@ -35,7 +35,7 @@ public domain. defpackage with errno symbols * #453: Use correct flags for analyzer and always save logs. * #456: Improve accuracy for division of complex double-floats - * #458: Spurious overflow in double-double-float multiply + * #458: Spurious overflow in double-double-float multiply * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2e3981c0c75cb3332919f5c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2e3981c0c75cb3332919f5c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-456-more-accurate-complex-div] 8 commits: Fix two important typos in unix-get-username and delete-directory
by Raymond Toy (＠rtoy) 13 Dec '25

13 Dec '25

Raymond Toy pushed to branch issue-456-more-accurate-complex-div at cmucl / cmucl Commits: 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] - - - - - 4a4c853d by Raymond Toy at 2025-12-13T15:13:26-08:00 Merge branch 'master' into issue-456-more-accurate-complex-div - - - - - 07341fe5 by Raymond Toy at 2025-12-13T15:15:36-08:00 Add issue number for cdiv test [skip-ci] - - - - - 1dfe13cb by Raymond Toy at 2025-12-13T15:17:17-08:00 Add #456 to release notes - - - - - 7 changed files: - src/code/extensions.lisp - src/code/unix.lisp - src/compiler/float-tran-dd.lisp - src/general-info/release-22a.md - tests/float.lisp - tests/pathname.lisp - tests/unix.lisp Changes: ===================================== src/code/extensions.lisp ===================================== @@ -676,7 +676,7 @@ subdirectories. Dirname must be a pathname to a directory. Any NAME or TYPE components in Dirname are ignored." (declare (type pathname dirname)) - (when recusive + (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. ===================================== 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,8 @@ 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. + * #456: Improve accuracy for division of complex double-floats + * #458: Spurious overflow in double-double-float multiply * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== tests/float.lisp ===================================== @@ -343,6 +343,16 @@ (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))) + + + ;; Rudimentary code to read C %a formatted numbers that look like ;; "-0x1.c4dba4ba1ee79p-620". We assume STRING is exactly in this ;; format. No error-checking is done. @@ -477,6 +487,7 @@ (min (rerr (realpart computed) (realpart expected)) (rerr (imagpart computed) (imagpart expected))))) +;; Issue #456: improve accuracy of division of complex double-floats. (define-test complex-division.double (:tag :issues) (loop for k from 1 ===================================== tests/pathname.lisp ===================================== @@ -142,3 +142,16 @@ "/*.*") :truenamep nil :follow-links nil))) (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/")))) ===================================== 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/6f6a87580e30627db10894… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/6f6a87580e30627db10894… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Add fixed issue #458 to release notes
by Raymond Toy (＠rtoy) 13 Dec '25

13 Dec '25

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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] - - - - - 1 changed file: - src/general-info/release-22a.md Changes: ===================================== 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: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/f146f87fb993732381ecfcc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/f146f87fb993732381ecfcc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-459-more-accurate-dd-complex-div] 6 commits: Fix two important typos in unix-get-username and delete-directory
by Raymond Toy (＠rtoy) 13 Dec '25

13 Dec '25

Raymond Toy pushed to branch issue-459-more-accurate-dd-complex-div at cmucl / cmucl Commits: 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 - - - - - 7d9f2c5e by Raymond Toy at 2025-12-13T14:27:29-08:00 Add comments. - - - - - 9f881b52 by Raymond Toy at 2025-12-13T14:28:58-08:00 Merge branch 'master' into issue-459-more-accurate-dd-complex-div - - - - - 6 changed files: - src/code/extensions.lisp - src/code/unix.lisp - src/compiler/float-tran-dd.lisp - tests/float.lisp - tests/pathname.lisp - tests/unix.lisp Changes: ===================================== src/code/extensions.lisp ===================================== @@ -676,7 +676,7 @@ subdirectories. Dirname must be a pathname to a directory. Any NAME or TYPE components in Dirname are ignored." (declare (type pathname dirname)) - (when recusive + (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. ===================================== 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 ===================================== @@ -701,6 +701,10 @@ ;; 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. +;; +;; This is a pretty straightforward change of +;; kernel::cdiv-double-float for double-double-float. The constants +;; may need some tweaking. (let* ((+dd-eps+ (scale-float 1w0 -104)) (+dd-rmin+ least-positive-normalized-double-double-float) (+dd-rbig+ (/ most-positive-double-double-float 2)) ===================================== tests/float.lisp ===================================== @@ -548,3 +548,10 @@ (coerce y '(complex single-float))) x y))) + + +;; Issue #458 +(define-test dd-mult-overflow + (:tag :issues) + (assert-equal -2w300 + (* -2w300 1w0))) ===================================== tests/pathname.lisp ===================================== @@ -142,3 +142,16 @@ "/*.*") :truenamep nil :follow-links nil))) (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/")))) ===================================== 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/8d0c23e1afb107921adbe5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/8d0c23e1afb107921adbe5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #458: Fix spurious overflow in double-double multiply
by Raymond Toy (＠rtoy) 13 Dec '25

13 Dec '25

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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 - - - - - 2 changed files: - src/compiler/float-tran-dd.lisp - tests/float.lisp Changes: ===================================== 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)))))))) ===================================== tests/float.lisp ===================================== @@ -342,3 +342,11 @@ (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))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b949459585f80e579ac7b3… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b949459585f80e579ac7b3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-459-more-accurate-dd-complex-div] 2 commits: Move cdiv-dd-float to float-tran-dd.lisp
by Raymond Toy (＠rtoy) 13 Dec '25

13 Dec '25

Raymond Toy pushed to branch issue-459-more-accurate-dd-complex-div at cmucl / cmucl Commits: a6ea12d7 by Raymond Toy at 2025-12-13T08:32:38-08:00 Move cdiv-dd-float to float-tran-dd.lisp Move the implementation of cdiv-double-double-float from numbers.lisp to float-tran-dd.lisp. First, we wanted a closure for the constants like we do for cdiv-double-float. However, this requires all the dd routines to be defined and numbers.lisp is compiled too soon. Moving the code to float-tran-dd.lisp makes sure all the functions are ready. Add a deftransform for / to call cdiv-double-double-float. Update two-arg-/ to call cdiv-double-double-float appropriately. - - - - - 8d0c23e1 by Raymond Toy at 2025-12-13T08:35:34-08:00 Import cdiv-dd-float into kernel package and update tests This mean exporting cdiv-double-double-float so that the kernel can import the symbol and use it. Thus, cdiv-dd-float and cdiv-double-float both exist in the kernel package for two-arg-/. Update the float tests to call / instead of cdiv-double-double-float. - - - - - 4 changed files: - src/code/exports.lisp - src/code/numbers.lisp - src/compiler/float-tran-dd.lisp - tests/float.lisp Changes: ===================================== src/code/exports.lisp ===================================== @@ -1669,6 +1669,7 @@ "TRUST-DYNAMIC-EXTENT-DECLARATION-P" "IR2-STACK-ALLOCATE" "%DYNAMIC-EXTENT" "%DYNAMIC-EXTENT-START" "%DYNAMIC-EXTENT-END") + (:export "CDIV-DOUBLE-DOUBLE-FLOAT") ) (defpackage "XREF" (:export "INIT-XREF-DATABASE" @@ -1918,6 +1919,8 @@ (:import-from "LISP" "BOOLEAN") (:import-from "C-CALL" "VOID") (:import-from "CONDITIONS" "PARSE-UNKNOWN-TYPE-SPECIFIER") + #+double-double + (:import-from "C" "CDIV-DOUBLE-DOUBLE-FLOAT") (:shadow "CLASS" "STRUCTURE-CLASS" "BUILT-IN-CLASS" "STANDARD-CLASS" "FIND-CLASS" "CLASS-OF") (:export "%CLASS-LAYOUT" "%CLASS-STATE" "%CLASS-DIRECT-SUPERCLASSES" ===================================== src/code/numbers.lisp ===================================== @@ -752,157 +752,6 @@ (* s (robust-internal x y)))))) -;;; Same algorithm as for doubles, but the constants here are -;;; different. I'm guessing here for the appropriate values for -;;; +eps+, +rmin2+, and +rminscal+. -(defconstant +dd-eps+ (scale-float 1w0 -104)) -(defconstant +dd-rmin+ least-positive-normalized-double-double-float) -(defconstant +dd-rbig+ (/ most-positive-double-double-float 2)) -(defconstant +dd-rmin2+ (scale-float 1w0 -105)) -(defconstant +dd-rminscal+ (scale-float 1w0 102)) -(defconstant +dd-rmax2+ (* +dd-rbig+ +dd-rmin2+)) -(defconstant +dd-be+ (/ 2 (* +dd-eps+ +dd-eps+))) -(defconstant +dd-2/eps+ (/ 2 +dd-eps+)) - -(defun cdiv-double-double-float (x y) - (declare (type (complex vm::double-double-float) x y) - (optimize (speed 3) (safety 0))) - (labels - ((internal-compreal (a b c d r tt) - (declare (vm::double-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) +dd-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 (vm::double-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 vm::double-double-float) x y)) - (let ((a (realpart x)) - (b (imagpart x)) - (c (realpart y)) - (d (imagpart y))) - (declare (vm::double-double-float a b c d)) - (flet ((maybe-scale (abs-tst a b c d) - (declare (vm::double-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 +dd-rbig+) - (> abs-a +dd-rbig+) - (> abs-b +dd-rbig+)) - (setf a (* a 0.5d0) - b (* b 0.5d0) - c (* c 0.5d0) - d (* d 0.5d0)) - (if (< abs-tst +dd-rmin2+) - (setf a (* a +dd-rminscal+) - b (* b +dd-rminscal+) - c (* c +dd-rminscal+) - d (* d +dd-rminscal+)) - (if (or (and (< abs-a +dd-rmin+) - (< abs-b +dd-rmax2+) - (< abs-tst +dd-rmax2+)) - (and (< abs-b +dd-rmin+) - (< abs-a +dd-rmax2+) - (< abs-tst +dd-rmax2+))) - (setf a (* a +dd-rminscal+) - b (* b +dd-rminscal+) - c (* c +dd-rminscal+) - d (* d +dd-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 1w0)) - (declare (vm::double-double-float s)) - ;; If a or b is big, scale down a and b. - (when (>= ab +dd-rbig+) - (setf x (/ x 2) - s (* s 2))) - ;; If c or d is big, scale down c and d. - (when (>= cd +dd-rbig+) - (setf y (/ y 2) - s (/ s 2))) - ;; If a or b is tiny, scale up a and b. - (when (<= ab (* +dd-rmin+ +dd-2/eps+)) - (setf x (* x +dd-be+) - s (/ s +dd-be+))) - ;; If c or d is tiny, scale up c and d. - (when (<= cd (* +dd-rmin+ +dd-2/eps+)) - (setf y (* y +dd-be+) - s (* s +dd-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. (defun cdiv-single-float (x y) @@ -948,7 +797,10 @@ (((complex double-double-float) (foreach (complex rational) (complex single-float) (complex double-float) (complex double-double-float))) + (c::cdiv-double-double-float x + (coerce y '(complex double-double-float))) ;; We should do something better for double-double floats. + #+nil (let ((a (realpart x)) (b (imagpart x)) (c (realpart y)) @@ -969,6 +821,9 @@ (((foreach integer ratio single-float double-float double-double-float (complex rational) (complex single-float) (complex double-float)) (complex double-double-float)) + (c::cdiv-double-double-float (coerce x '(complex double-double-float)) + y) + #+nil (let ((a (realpart x)) (b (imagpart x)) (c (realpart y)) ===================================== src/compiler/float-tran-dd.lisp ===================================== @@ -691,4 +691,166 @@ (kernel:double-double-lo a) (kernel:double-double-hi b) (kernel:double-double-lo b))) + +;; An implementation of Baudin and Smith's robust complex division for +;; double-floats. This is a pretty straightforward translation of the +;; original in https://arxiv.org/pdf/1210.4539. +;; +;; This also includes improvements mentioned in +;; https://lpc.events/event/11/contributions/1005/attachments/856/1625/Complex…. +;; 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* ((+dd-eps+ (scale-float 1w0 -104)) + (+dd-rmin+ least-positive-normalized-double-double-float) + (+dd-rbig+ (/ most-positive-double-double-float 2)) + (+dd-rmin2+ (scale-float 1w0 -105)) + (+dd-rminscal+ (scale-float 1w0 102)) + (+dd-rmax2+ (* +dd-rbig+ +dd-rmin2+)) + (+dd-be+ (/ 2 (* +dd-eps+ +dd-eps+))) + (+dd-2/eps+ (/ 2 +dd-eps+))) + (declare (double-double-float +dd-eps+ +dd-rmin+ +dd-rbig+ +dd-rmin2+ + +dd-rminscal+ +dd-rmax2+ +dd-be+ +dd-2/eps+)) + (defun cdiv-double-double-float (x y) + (declare (type (complex double-double-float) x y) + (optimize (speed 2) (safety 0))) + (labels + ((internal-compreal (a b c d r tt) + (declare (double-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) +dd-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-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-double-float) x y)) + (let ((a (realpart x)) + (b (imagpart x)) + (c (realpart y)) + (d (imagpart y))) + (declare (double-double-float a b c d)) + (flet ((maybe-scale (abs-tst a b c d) + (declare (double-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 +dd-rbig+) + (> abs-a +dd-rbig+) + (> abs-b +dd-rbig+)) + (setf a (* a 0.5d0) + b (* b 0.5d0) + c (* c 0.5d0) + d (* d 0.5d0)) + (if (< abs-tst +dd-rmin2+) + (setf a (* a +dd-rminscal+) + b (* b +dd-rminscal+) + c (* c +dd-rminscal+) + d (* d +dd-rminscal+)) + (if (or (and (< abs-a +dd-rmin+) + (< abs-b +dd-rmax2+) + (< abs-tst +dd-rmax2+)) + (and (< abs-b +dd-rmin+) + (< abs-a +dd-rmax2+) + (< abs-tst +dd-rmax2+))) + (setf a (* a +dd-rminscal+) + b (* b +dd-rminscal+) + c (* c +dd-rminscal+) + d (* d +dd-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 1w0)) + (declare (double-double-float s)) + ;; If a or b is big, scale down a and b. + (when (>= ab +dd-rbig+) + (setf x (/ x 2) + s (* s 2))) + ;; If c or d is big, scale down c and d. + (when (>= cd +dd-rbig+) + (setf y (/ y 2) + s (/ s 2))) + ;; If a or b is tiny, scale up a and b. + (when (<= ab (* +dd-rmin+ +dd-2/eps+)) + (setf x (* x +dd-be+) + s (/ s +dd-be+))) + ;; If c or d is tiny, scale up c and d. + (when (<= cd (* +dd-rmin+ +dd-2/eps+)) + (setf y (* y +dd-be+) + s (* s +dd-be+))) + (* s + (robust-internal x y)))))) + +(deftransform / ((x y) ((complex double-double-float) (complex double-double-float)) + *) + `(cdiv-double-double-float x y)) ) ; end progn ===================================== tests/float.lisp ===================================== @@ -509,9 +509,8 @@ (complex (rational (realpart b)) (rational (imagpart b)))) '(complex ext:double-double-float)))) - (let* ((z (kernel::cdiv-double-double-float - (coerce x '(complex ext:double-double-float)) - (coerce y '(complex ext:double-double-float)))) + (let* ((z (/ (coerce x '(complex ext:double-double-float)) + (coerce y '(complex ext:double-double-float)))) (z-true (compute-true x y)) (rel (rel-err z z-true))) (assert-equal expected-rel-w View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/fd4a7a8b0a8d1109e09d89… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/fd4a7a8b0a8d1109e09d89… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-459-more-accurate-dd-complex-div
by Raymond Toy (＠rtoy) 13 Dec '25

13 Dec '25

Raymond Toy pushed new branch issue-459-more-accurate-dd-complex-div at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-459-more-accurate-d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0