cmucl-cvs March 2023

cmucl-cvs@common-lisp.net

1 participants
73 discussions

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] 2 commits: For float <, allow x to be a descriptor instead of y.
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: d10df309 by Raymond Toy at 2023-03-09T13:18:24-08:00 For float <, allow x to be a descriptor instead of y. Since the implementation of x < y reverses args to do y > x, it can be helpful if x can be a descriptor. Make it so. - - - - - e89872a2 by Raymond Toy at 2023-03-10T08:14:14-08:00 Replace cond with simple if The cond expression can be replaced by a much simpler if, which mirrors how the sparc and ppc ports handle the not-p jumps. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -963,19 +963,17 @@ (inst ,inst x y)) (descriptor-reg (inst ,inst x (,ea y)))) - (cond (not-p - ;; Instead of x > y, we're doing x <= y and want - ;; to jmp when x <= y. If NaN occurrs we also - ;; want to jump. x <= y means CF = 1 or ZF = 1. - ;; When NaN occurs, ZF, PF, and CF are all set. - ;; Hence, we can just test for x <= y. - (inst jmp :be target)) - (t - ;; If there's NaN, the ZF, PF, and CF bits are - ;; set. We only want to jmp to the target when - ;; x > y. This happens if CF = 0. Hence, we - ;; will not jmp to the target if NaN occurred. - (inst jmp :a target)))))))) + ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In + ;; the normal case (not-p false), we want to jump to the + ;; target when x > y. This happens when CF = 0. Hence, + ;; we won't jump to the target when there's a NaN, as + ;; desired. + ;; + ;; For the not-p case, we want to jump to target when x + ;; <= y. This means CF = 1 or ZF = 1. But NaN sets + ;; these bits too, so we jump to the target for NaN or x + ;; <= y, as desired. + (inst jmp (if (not not-p) :a :be) target)))))) (frob > single comiss) (frob > double comisd)) @@ -990,29 +988,22 @@ (sc-type (symbolicate size "-REG")) (inherit (symbolicate size "-FLOAT-COMPARE"))) `(define-vop (,name ,inherit) + (:args (x :scs (,sc-type descriptor-reg)) + (y :scs (,sc-type))) (:translate ,op) (:info target not-p) - (:temporary (:sc ,sc-type) load-y) + (:temporary (:sc ,sc-type) load-x) (:generator 3 - (sc-case y + ;; Note: x < y is the same as y > x. We reverse the + ;; args to reduce the number of jump instructions + ;; needed. Then the logic for the branches is the same + ;; as for the case y > x above. + (sc-case x (,sc-type (inst ,inst y x)) (descriptor-reg - (inst ,mover load-y (,ea y)) - (inst ,inst load-y x))) - (cond (not-p - ;; Instead of x < y, we're doing x >= y and want - ;; to jmp when x >= y. But x >=y is the same as - ;; y <= x, so if we swap the args, we can apply - ;; the same logic we use for > not-p case above. - (inst jmp :be target)) - (t - ;; We want to jump when x < y. This is the same - ;; as jumping when y > x. So if we reverse the - ;; args, we can apply the same logic as we did - ;; above for the > vop. - - (inst jmp :a target)))))))) + (inst ,inst y (,ea x)))) + (inst jmp (if (not not-p) :a :be) target)))))) (frob < single comiss movss) (frob < double comisd movsd)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9cb12348b64546ee281c5f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9cb12348b64546ee281c5f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-156-take-2-nan-comparison] Fix errors in dd >= and <= implmeentation
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 64c9296f by Raymond Toy at 2023-03-09T19:49:21-08:00 Fix errors in dd >= and <= implmeentation For `dd<=`, we accidentally used `dd>` instead of `dd<`. Oops. The deftransforms had swapped the args because of a previous implementation that we changed, but we forgot to revert the swapping. Now `(describe decode-float)` correctly returns ``` (VALUES (OR (SINGLE-FLOAT 0.5 (1.0)) (DOUBLE-FLOAT 0.5d0 (1.0d0)) (DOUBLE-DOUBLE-FLOAT 0.5w0 (1.0w0))) KERNEL:DOUBLE-FLOAT-EXPONENT (OR (SINGLE-FLOAT 1.0 1.0) (SINGLE-FLOAT -1.0 -1.0) (DOUBLE-FLOAT -1.0d0 -1.0d0) (DOUBLE-FLOAT 1.0d0 1.0d0) (DOUBLE-DOUBLE-FLOAT -1.0w0 -1.0w0) (DOUBLE-DOUBLE-FLOAT 1.0w0 1.0w0))) ``` like we used to. - - - - - 1 changed file: - src/compiler/float-tran-dd.lisp Changes: ===================================== src/compiler/float-tran-dd.lisp ===================================== @@ -670,7 +670,7 @@ (declaim (inline dd<=)) (defun dd<= (a0 a1 b0 b1) - (or (dd> a0 a1 b0 b1) + (or (dd< a0 a1 b0 b1) (dd= a0 a1 b0 b1))) (declaim (inline dd>=)) @@ -699,15 +699,15 @@ (kernel:double-double-lo b))) (deftransform <= ((a b) (vm::double-double-float vm::double-double-float) *) - `(dd<= (kernel:double-double-hi b) - (kernel:double-double-lo b) - (kernel:double-double-hi a) - (kernel:double-double-lo a))) + `(dd<= (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) (deftransform >= ((a b) (vm::double-double-float vm::double-double-float) *) - `(dd>= (kernel:double-double-hi b) - (kernel:double-double-lo b) - (kernel:double-double-hi a) - (kernel:double-double-lo a))) + `(dd>= (kernel:double-double-hi a) + (kernel:double-double-lo a) + (kernel:double-double-hi b) + (kernel:double-double-lo b))) ) ; end progn View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/64c9296fa3ff2c5a0b8fd5d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/64c9296fa3ff2c5a0b8fd5d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update release notes with recently closed bugs
by Raymond Toy (＠rtoy) 09 Mar '23

09 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 0038d3d9 by Raymond Toy at 2023-03-09T11:18:21-08:00 Update release notes with recently closed bugs - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -65,7 +65,17 @@ public domain. * ~~#142~~ `(random 0)` signals incorrect error * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream` * ~~#149~~ Call setlocale(3C) on startup + * ~~#150~~ Add aliases for external format cp949 and euckr + * ~~#151~~ Change `*default-external-format*` to `:utf-8`. * ~~#155~~ Wrap help strings neatly + * ~~#157~~ `(directory "foo/**/")` only returns directories now + * ~~#163~~ Add commandline option `-version` and `--version` to get lisp version + * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT` + * ~~#166~~ Fix incorect type declaration for exponent from `integer-decode-float` + * ~~#167~~ Lowe bound for `decode-float-exponent` type was off by one. + * ~~#168~~ Don't use negated forms for jmp instructions when possible + * ~~#169~~ Add pprinter for `define-vop` and `sc-case` + * ~~#173~~ Add pprinter for `define-assembly-routine` * 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/0038d3d9a489ffcf47bb155… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/0038d3d9a489ffcf47bb155… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] Just remove some trailing whitespace
by Raymond Toy (＠rtoy) 09 Mar '23

09 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: d8f99abf by Raymond Toy at 2023-03-09T06:50:32-08:00 Just remove some trailing whitespace - - - - - 1 changed file: - src/lisp/os-common.c Changes: ===================================== src/lisp/os-common.c ===================================== @@ -814,7 +814,7 @@ os_get_locale_codeset() #define UNAME_RELEASE_AND_VERSION #else #undef UNAME_RELEASE_AND_VERSION -#endif +#endif char* os_software_version() @@ -822,7 +822,7 @@ os_software_version() int status; struct utsname uts; char *version = NULL; - + status = uname(&uts); if (status == 0) { int version_length; @@ -836,7 +836,7 @@ os_software_version() } #else version = strdup(uts.version); -#endif +#endif } return version; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d8f99abf569c7ae830abeb2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d8f99abf569c7ae830abeb2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #157: (directory "**/") only returns directories
by Raymond Toy (＠rtoy) 09 Mar '23

09 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b3de9354 by Raymond Toy at 2023-03-09T14:46:48+00:00 Fix #157: (directory "**/") only returns directories - - - - - 39e30fad by Raymond Toy at 2023-03-09T14:46:48+00:00 Merge branch 'issue-157-directory-no-magic-wildcarding' into 'master' Fix #157: (directory "**/") only returns directories Closes #157 See merge request cmucl/cmucl!127 - - - - - 2 changed files: - src/code/filesys.lisp - tests/pathname.lisp Changes: ===================================== src/code/filesys.lisp ===================================== @@ -1122,11 +1122,7 @@ optionally keeping some of the most recent old versions." (let ((results nil)) (enumerate-search-list (pathname (merge-pathnames pathname - (make-pathname :name :wild - :type :wild - :version :wild - :defaults *default-pathname-defaults*) - :wild)) + *default-pathname-defaults*)) (enumerate-matches (name pathname nil :follow-links follow-links) (when (or all (let ((slash (position #\/ name :from-end t))) ===================================== tests/pathname.lisp ===================================== @@ -72,4 +72,14 @@ :directory '(:absolute "system2" "module4") :name nil :type nil) (parse-namestring "ASDFTEST:system2;module4;")))) - + + + +(define-test directory.dirs + (let ((files (directory "src/assembly/**/"))) + ;; Verify that we only returned directories + (loop for f in files + for name = (pathname-name f) + and type = (pathname-type f) + do + (assert-true (and (null name) (null type)) f)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/7a15c46492914989dc85c5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/7a15c46492914989dc85c5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] 64 commits: Fix #132: Ansi test RENAME-FILE.1 fails
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: cdd7d328 by Raymond Toy at 2022-10-15T14:39:32+00:00 Fix #132: Ansi test RENAME-FILE.1 fails - - - - - e0e9f62d by Raymond Toy at 2022-10-15T14:39:35+00:00 Merge branch 'issue-132-ansi-test-rename-files' into 'master' Fix #132: Ansi test RENAME-FILE.1 fails Closes #132 See merge request cmucl/cmucl!90 - - - - - a05277c7 by Raymond Toy at 2022-10-15T20:53:20+00:00 Fix #134: Handle the case of (expt complex complex-rational) - - - - - 4dacd5ac by Raymond Toy at 2022-10-15T20:53:20+00:00 Merge branch 'issue-134-expt-bug' into 'master' Fix #134: Handle the case of (expt complex complex-rational) Closes #134 See merge request cmucl/cmucl!91 - - - - - 8719b21c by Raymond Toy at 2022-10-15T23:27:33+00:00 Fix #146: CI passes incorrectly - - - - - 9c0f63ff by Raymond Toy at 2022-10-15T23:27:34+00:00 Merge branch 'issue-146-ci-passes-incorrectly' into 'master' Fix #146: CI passes incorrectly Closes #146 See merge request cmucl/cmucl!100 - - - - - cde14045 by Raymond Toy at 2022-10-16T14:26:39+00:00 Fix #142: (random 0) signals incorrect error - - - - - 4c9cbf43 by Raymond Toy at 2022-10-16T14:26:41+00:00 Merge branch 'issue-142-random-0-wrong-error' into 'master' Fix #142: (random 0) signals incorrect error Closes #142 See merge request cmucl/cmucl!99 - - - - - b59185fc by Raymond Toy at 2022-10-16T14:27:39+00:00 Fix #136: ensure-directories-exist should return the given pathspec - - - - - 49ecc858 by Raymond Toy at 2022-10-16T14:27:39+00:00 Merge branch 'issue-136-ansi-test-ensure-directories-exist.8' into 'master' Fix #136: ensure-directories-exist should return the given pathspec Closes #136 See merge request cmucl/cmucl!92 - - - - - 08e5370a by Raymond Toy at 2022-10-16T07:33:23-07:00 Update release notes based on recent merges Forgot to update the release notes with recent merges that fixed a few issues. Hence update the notes now. Also testing see if we need to add a strikeout for closed issues, so didn't add strikeout for these. - - - - - 556b1a5b by Raymond Toy at 2022-10-16T07:35:57-07:00 Add strikeout for closed issues Nope, gitlab doesn't mark closed issues in anyway, unlike Trac that would automatically strikeout references to closed issues. We have to do it ourselves. - - - - - 95b4fc5c by Raymond Toy at 2022-10-16T13:05:09-07:00 Fix #146: CI passes incorrectly We forgot to update the script for macos to use separate `grep` commands like we did for linux. - - - - - 4a7207b6 by Raymond Toy at 2022-10-17T18:58:45+00:00 Fix #130: Implement file_author in C - - - - - ba5c5d2a by Raymond Toy at 2022-10-17T18:58:45+00:00 Merge branch 'issue-130-file-author-in-c' into 'master' Fix #130: Implement file_author in C Closes #130 See merge request cmucl/cmucl!88 - - - - - e8a0cc6c by Raymond Toy at 2022-10-30T15:03:27+00:00 Fix #147: Add method for stream-line-column - - - - - 0dad5a1a by Raymond Toy at 2022-10-30T15:03:28+00:00 Merge branch 'issue-147-stream-line-column-impl' into 'master' Fix #147: Add method for stream-line-column Closes #147 See merge request cmucl/cmucl!104 - - - - - 1300830b by Raymond Toy at 2022-10-31T17:12:48+00:00 Address #139: *default-external-format* is :utf-8 - - - - - 649a4f1e by Raymond Toy at 2022-10-31T17:12:49+00:00 Merge branch 'issue-139-default-external-format-utf8' into 'master' Address #139: *default-external-format* is :utf-8 See merge request cmucl/cmucl!103 - - - - - 88f6852f by Raymond Toy at 2022-11-01T12:04:55-07:00 Change :iso-8859-1 to :iso8859-1 in find-encoding While there's an alias for `:iso-8859-1`, it's safer to use `:iso8859-1` which is builtin. Using `:iso-8859-1` requires the alias database to be loaded, which isn't (currently) guaranteed when `find-encoding` is called. Thus use the builtin name instead. Besides, `:iso8859-1` is used in other places in "intl.lisp". (This is hard to test, but I noticed it when running ``` LANG=ko_KR.utf8 lisp ``` on the branch `issue-139-add-alias-local-external-format`.) - - - - - d5f1aa5e by Raymond Toy at 2022-11-01T20:35:49+00:00 Update release-21e.md with closed issues. - - - - - 402c0c01 by Raymond Toy at 2022-11-02T01:00:20+00:00 Fix #150: add aliases cp949 euckr - - - - - d825aa54 by Raymond Toy at 2022-11-02T01:00:20+00:00 Merge branch 'issue-150-add-aliases-cp949-euckr' into 'master' Fix #150: add aliases cp949 euckr Closes #150 See merge request cmucl/cmucl!106 - - - - - 33c760fa by Raymond Toy at 2022-11-03T04:47:09+00:00 Fix #149: Call setlocale(3C) on startup - - - - - 317a33f8 by Raymond Toy at 2022-11-03T04:47:10+00:00 Merge branch 'issue-149-add-setlocale' into 'master' Fix #149: Call setlocale(3C) on startup Closes #149 See merge request cmucl/cmucl!105 - - - - - 7bbb4843 by Raymond Toy at 2022-11-08T03:19:19+00:00 Fix #155: Wrap help strings neatly - - - - - 68f4ec70 by Raymond Toy at 2022-11-08T03:19:21+00:00 Merge branch 'issue-155-wrap-help-strings' into 'master' Fix #155: Wrap help strings neatly Closes #155 See merge request cmucl/cmucl!107 - - - - - 23f66902 by Raymond Toy at 2022-11-14T05:09:37+00:00 Fix #141: Use setlocale to handle localization settings - - - - - 6764053d by Raymond Toy at 2022-11-14T05:09:38+00:00 Merge branch 'issue-141-locale' into 'master' Fix #141: Use setlocale to handle localization settings Closes #141, #136, #142, #146, #134, and #132 See merge request cmucl/cmucl!101 - - - - - e7459829 by Raymond Toy at 2022-11-25T15:35:51+00:00 Fix #140: External format for streams that are not file-streams - - - - - 88843edc by Raymond Toy at 2022-11-25T15:35:52+00:00 Merge branch 'issue-140-stream-element-type-two-way-stream' into 'master' Fix #140: External format for streams that are not file-streams Closes #140 See merge request cmucl/cmucl!97 - - - - - 225940e4 by Raymond Toy at 2022-11-25T16:07:57+00:00 Address #139: Add :locale external format - - - - - bea34994 by Raymond Toy at 2022-11-25T16:07:57+00:00 Merge branch 'issue-139-add-alias-local-external-format' into 'master' Address #139: Add :locale external format See merge request cmucl/cmucl!102 - - - - - 1af83384 by Raymond Toy at 2022-12-08T14:57:43+00:00 Address #139: Set terminal format to :locale - - - - - 6fc2e38e by Raymond Toy at 2022-12-08T14:57:45+00:00 Merge branch 'issue-139-set-terminal-to-utf8' into 'master' Address #139: Set terminal format to :locale See merge request cmucl/cmucl!108 - - - - - dbdec3a5 by Raymond Toy at 2023-01-13T23:33:47+00:00 Address #139: Set filename encoding to :utf-8 - - - - - d004986e by Raymond Toy at 2023-01-13T23:33:49+00:00 Merge branch 'issue-139-set-filename-encoding-to-utf8' into 'master' Address #139: Set filename encoding to :utf-8 See merge request cmucl/cmucl!109 - - - - - d01f2cf9 by Raymond Toy at 2023-01-18T08:00:32-08:00 Fix #162: Change *filename-encoding* to use :no-encoding Instead of using `NIL` to indicate that `*filename-encoding*` is not to be done, use `:no-encoding` to indicate that. This makes it a bit clearer what `*filename-encoding*` means. - - - - - 7c44d848 by Raymond Toy at 2023-01-19T15:30:06-08:00 Use :null instead of :no-encoding for no filename encoding The advantage of using `:null` is that it's a recognized external format (that aliases to `:void`). So if we inadvertently use `:null` as a filename encoding somewhere unexpected, it will cause an error (because the `:void` encoding does). - - - - - ce202074 by Raymond Toy at 2023-02-10T08:29:32-08:00 Fix stupid typos Really stupid typos/thinkos: * Forgot to change initial value if `*filename-encoding*` from `:no-encoding` to `:null`. (Stupid!) * Fix typo: `:nul` instead of `:null` in `%name->file`. Update cmucl-unix.pot too for the change in the docstring for `*filename-encoding*`. - - - - - 9eb801f6 by Raymond Toy at 2023-02-15T13:01:43-08:00 Disable issue.41.1 when running CI This test was previously disabled only for Linux when running the CI. However, it's now also failing when running the CI for Darwin. Thus disable it whenever we're running the CI. I just manually tested this on my Linux and Mac boxes. This test passes without any problem. Not sure what's going on. - - - - - 4be1d90c by Raymond Toy at 2023-02-15T21:23:15+00:00 Merge branch 'issue-162-filename-encoding-no-encoding' into 'master' Fix #162: Change *filename-encoding* to use :null Closes #162 See merge request cmucl/cmucl!111 - - - - - be8cb5d0 by Tarn W. Burton at 2023-02-21T07:48:12-05:00 Avoid inserting NIL into simple LOOP from FORMAT - - - - - 0d3cbc39 by Raymond Toy at 2023-02-21T23:25:27+00:00 Merge branch 'fix-format-nil' into 'master' Fix #165: Avoid inserting NIL into simple LOOP from FORMAT See merge request cmucl/cmucl!114 - - - - - 1c99e654 by Raymond Toy at 2023-02-24T20:47:11+00:00 Fix #159: Don't use /tmp as a path for temp files - - - - - ba0d43d1 by Raymond Toy at 2023-02-24T20:47:11+00:00 Merge branch 'issue-159-use-local-tmp-dir' into 'master' Fix #159: Don't use /tmp as a path for temp files Closes #159 See merge request cmucl/cmucl!116 - - - - - cb945c68 by Raymond Toy at 2023-02-27T15:33:25+00:00 Fix #166: integer-decode-float has incorrect type for exponent - - - - - bb43504b by Raymond Toy at 2023-02-27T15:33:25+00:00 Merge branch 'issue-166-integer-decode-float-min-float' into 'master' Fix #166: integer-decode-float has incorrect type for exponent Closes #166 See merge request cmucl/cmucl!117 - - - - - 404e4b28 by Raymond Toy at 2023-02-27T20:18:24+00:00 Fix #168: Use positive forms for conditional jmp. - - - - - 27979066 by Raymond Toy at 2023-02-27T20:18:27+00:00 Merge branch 'issue-168-no-negated-forms-for-jmp' into 'master' Fix #168: Use positive forms for conditional jmp. Closes #168 See merge request cmucl/cmucl!119 - - - - - be6a7f01 by Raymond Toy at 2023-02-28T14:39:15+00:00 Fix #169: pprint define-vop neatly - - - - - 797e2e17 by Raymond Toy at 2023-02-28T14:39:17+00:00 Merge branch 'issue-169-pprint-define-vop' into 'master' Fix #169: pprint define-vop neatly Closes #169 See merge request cmucl/cmucl!120 - - - - - eb943b50 by Raymond Toy at 2023-02-28T15:50:59+00:00 Fix #167: double-float-exponent off by one - - - - - 6ba270b2 by Raymond Toy at 2023-02-28T15:51:05+00:00 Merge branch 'issue-167-exponent-bounds-off-by-one' into 'master' Fix #167: double-float-exponent off by one See merge request cmucl/cmucl!121 - - - - - a25354e9 by Raymond Toy at 2023-03-01T03:08:58+00:00 Fix #170: reduce duplicated code for x86 float-compares - - - - - 68ef4c5b by Raymond Toy at 2023-03-01T03:09:00+00:00 Merge branch 'issue-170-clean-up-x86-float-compare' into 'master' Fix #170: reduce duplicated code for x86 float-compares Closes #170 See merge request cmucl/cmucl!122 - - - - - ca9b6e0c by Raymond Toy at 2023-03-01T03:43:18+00:00 Fix #163: Add -version command line switch - - - - - 3f4e2d0c by Raymond Toy at 2023-03-01T03:43:19+00:00 Merge branch 'issue-163-add-command-line-version' into 'master' Fix #163: Add -version command line switch Closes #163 See merge request cmucl/cmucl!112 - - - - - 80f89a62 by Raymond Toy at 2023-02-28T21:20:02-08:00 Update cmucl.pot We forgot to update this when adding --version command line option. - - - - - d55e32fa by Raymond Toy at 2023-03-02T10:48:44-08:00 Add x86 reader conditional This bootstrap file only applies to x86, so add reader conditionals so that this can be loaded for other architectures without having any effect. One less thing to worry about when bootstrapping. - - - - - 9d32d69a by Raymond Toy at 2023-03-05T07:43:06-08:00 Indent let in %time correctly. A `let` sexp in `%time` was not indented correctly. Indent it correctly now. - - - - - b2f6ab4c by Raymond Toy at 2023-03-06T17:07:46+00:00 Fix #173: Add pprinter for define-assembly-routine - - - - - 7a15c464 by Raymond Toy at 2023-03-06T17:07:49+00:00 Merge branch 'issue-173-pprint-def-assem-routine' into 'master' Fix #173: Add pprinter for define-assembly-routine Closes #173 See merge request cmucl/cmucl!126 - - - - - 07572a7a by Raymond Toy at 2023-03-08T12:52:21-08:00 Merge branch 'master' into issue-120-software-type-in-c - - - - - 30 changed files: - .gitlab-ci.yml - bin/build.sh - + src/bootfiles/21d/boot-2021-07-1.lisp - + src/bootfiles/21d/boot-2021-07-2.lisp - src/code/commandline.lisp - src/code/exports.lisp - src/code/extfmts.lisp - src/code/fd-stream.lisp - src/code/format.lisp - src/code/intl.lisp - src/code/lispinit.lisp - src/code/pprint.lisp - src/code/save.lisp - src/code/stream.lisp - src/code/time.lisp - src/code/unix.lisp - src/compiler/float-tran.lisp - src/compiler/fndb.lisp - src/compiler/generic/vm-type.lisp - src/compiler/x86/float-sse2.lisp - src/compiler/x86/insts.lisp - src/general-info/release-21e.md - src/i18n/locale/cmucl-unix.pot - src/i18n/locale/cmucl.pot - src/lisp/os-common.c - src/pcl/gray-streams.lisp - src/pcl/simple-streams/external-formats/aliases - + tests/.gitignore - tests/issues.lisp - tests/printer.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/c7eedc4ec8441f2dcca388… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/c7eedc4ec8441f2dcca388… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-software-type-in-c] 9 commits: Fix #132: Ansi test RENAME-FILE.1 fails
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: 2591a201 by Raymond Toy at 2023-03-08T12:46:10-08:00 Fix #132: Ansi test RENAME-FILE.1 fails - - - - - 34a865ec by Raymond Toy at 2023-03-08T12:46:10-08:00 Fix #134: Handle the case of (expt complex complex-rational) - - - - - 70e6cf5b by Raymond Toy at 2023-03-08T12:46:10-08:00 Fix #146: CI passes incorrectly - - - - - 44fcc4af by Raymond Toy at 2023-03-08T12:46:10-08:00 Fix #142: (random 0) signals incorrect error - - - - - 34e2da7c by Raymond Toy at 2023-03-08T12:46:10-08:00 Fix #136: ensure-directories-exist should return the given pathspec - - - - - 270cd610 by Raymond Toy at 2023-03-08T12:46:10-08:00 Update release notes based on recent merges Forgot to update the release notes with recent merges that fixed a few issues. Hence update the notes now. Also testing see if we need to add a strikeout for closed issues, so didn't add strikeout for these. - - - - - 351339d3 by Raymond Toy at 2023-03-08T12:46:10-08:00 Add strikeout for closed issues Nope, gitlab doesn't mark closed issues in anyway, unlike Trac that would automatically strikeout references to closed issues. We have to do it ourselves. - - - - - 84aced83 by Raymond Toy at 2023-03-08T12:46:10-08:00 Fix #146: CI passes incorrectly We forgot to update the script for macos to use separate `grep` commands like we did for linux. - - - - - c7eedc4e by Raymond Toy at 2023-03-08T12:48:14-08:00 Fix #130: Implement file_author in C - - - - - 9 changed files: - .gitlab-ci.yml - src/code/filesys.lisp - src/code/irrat.lisp - src/code/rand-xoroshiro.lisp - src/general-info/release-21e.md - src/lisp/os-common.c - tests/filesys.lisp - tests/issues.lisp - + tests/안녕하십니까.txt Changes: ===================================== .gitlab-ci.yml ===================================== @@ -80,7 +80,8 @@ linux:ansi-test: script: - cd ansi-test - make LISP="../dist/bin/lisp -batch -noinit -nositeinit" - - grep 'No unexpected \(successes\|failures\)' test.out + # There should be no unexpected successes or failures; check these separately. + - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out linux:benchmark: stage: benchmark @@ -166,7 +167,8 @@ osx:ansi-test: script: - cd ansi-test - make LISP="../dist/bin/lisp -batch -noinit -nositeinit" - - grep 'No unexpected \(successes\|failures\)' test.out + # There should be no unexpected successes or failures; check these separately. + - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out osx:benchmark: stage: benchmark ===================================== src/code/filesys.lisp ===================================== @@ -950,7 +950,11 @@ File after it was renamed." (let* ((original (truename file)) (original-namestring (unix-namestring original t)) - (new-name (merge-pathnames new-name file)) + ;; First, merge NEW-FILE-NAME with *DEFAULT-PATHNAME-DEFAULTS* to + ;; fill in the missing components and then merge again with + ;; the FILE to get any missing components from FILE. + (new-name (merge-pathnames (merge-pathnames new-name) + file)) (new-namestring (unix-namestring new-name nil))) (unless new-namestring (error 'simple-file-error @@ -1075,13 +1079,21 @@ optionally keeping some of the most recent old versions." :pathname file :format-control (intl:gettext "~S doesn't exist.") :format-arguments (list file))) - (multiple-value-bind (winp dev ino mode nlink uid) - (unix:unix-stat name) - (declare (ignore dev ino mode nlink)) - (when winp - (let ((user-info (unix:unix-getpwuid uid))) - (when user-info - (unix:user-info-name user-info)))))))) + ;; unix-namestring converts "." to "". Convert it back to + ;; "." so we can stat the current directory. (Perhaps + ;; that's a bug in unix-namestring?) + (when (zerop (length name)) + (setf name ".")) + (let (author) + (unwind-protect + (progn + (setf author (alien:alien-funcall + (alien:extern-alien "os_file_author" + (function (alien:* c-call:c-string) c-call:c-string)) + (unix::%name->file name))) + (unless (alien:null-alien author) + (alien:cast author c-call:c-string))) + (alien:free-alien author)))))) ;;;; DIRECTORY. @@ -1474,4 +1486,4 @@ optionally keeping some of the most recent old versions." (retry () :report "Try to create the directory again" (go retry)))))) ;; Only the first path in a search-list is considered. - (return (values pathname created-p)))))) + (return (values pathspec created-p)))))) ===================================== src/code/irrat.lisp ===================================== @@ -510,12 +510,12 @@ (* base power) (exp (* power (* (log2 base 1w0) (log 2w0)))))) (((foreach fixnum (or bignum ratio) single-float) - (foreach (complex single-float))) + (foreach (complex rational) (complex single-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (exp (* power (log base))))) (((foreach (complex rational) (complex single-float)) - (foreach single-float (complex single-float))) + (foreach single-float (complex rational) (complex single-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm (coerce base '(complex single-float)) power) @@ -537,7 +537,7 @@ (exp (* power (log (coerce base '(complex double-double-float)))))))) (((foreach (complex double-float)) (foreach single-float double-float - (complex single-float) (complex double-float))) + (complex rational) (complex single-float) (complex double-float))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm base power) @@ -552,7 +552,7 @@ (exp (* power (log (coerce base '(complex double-double-float)))))))) #+double-double (((foreach (complex double-double-float)) - (foreach float (complex float))) + (foreach float (complex float) (complex rational))) (if (and (zerop base) (plusp (realpart power))) (* base power) (or (expt-xfrm base power) ===================================== src/code/rand-xoroshiro.lisp ===================================== @@ -491,8 +491,8 @@ (t (error 'simple-type-error :expected-type '(or (integer 1) (float (0.0))) :datum arg - :format-control _"Argument is not a positive integer or a positive float: ~S") - :format-arguments (list arg)))) + :format-control _"Argument is not a positive integer or a positive float: ~S" + :format-arguments (list arg))))) ;; Jump function for the generator. See the jump function in ;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c ===================================== src/general-info/release-21e.md ===================================== @@ -50,8 +50,13 @@ public domain. * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF.. * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM * ~~#122~~ gcc 11 can't build cmucl + * ~~#125~~ Linux `unix-stat` returning incorrect values * ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid.. * ~~#128~~ `QUIT` accepts an exit code + * ~~#132~~ Ansi test `RENAME-FILE.1` no fails + * ~~#134~~ Handle the case of `(expt complex complex-rational)` + * ~~#136~~ `ensure-directories-exist` should return the given pathspec + * ~~#142~~ `(random 0)` signals incorrect error * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/lisp/os-common.c ===================================== @@ -5,13 +5,17 @@ */ +#include <assert.h> #include <errno.h> #include <math.h> #include <netdb.h> +#include <pwd.h> #include <stdio.h> +#include <stdlib.h> #include <string.h> #include <sys/stat.h> #include <sys/utsname.h> +#include <unistd.h> #include <time.h> #include "os.h" @@ -717,6 +721,59 @@ os_lstat(const char* path, u_int64_t *dev, u_int64_t *ino, unsigned int *mode, u return rc; } +/* + * Interface for file-author. Given a pathname, returns a new string + * holding the author of the file or NULL if some error occurred. The + * caller is responsible for freeing the memory used by the string. + */ +char * +os_file_author(const char *path) +{ + struct stat sb; + char initial[1024]; + char *buffer, *obuffer; + size_t size; + struct passwd pwd; + struct passwd *ppwd; + char *result; + + if (stat(path, &sb) != 0) { + return NULL; + } + + result = NULL; + buffer = initial; + obuffer = NULL; + size = sizeof(initial) / sizeof(initial[0]); + + /* + * Keep trying with larger buffers until a maximum is reached. We + * assume (1 << 20) is large enough for any OS. + */ + while (size <= (1 << 20)) { + switch (getpwuid_r(sb.st_uid, &pwd, buffer, size, &ppwd)) { + case 0: + /* Success, though we might not have a matching entry */ + result = (ppwd == NULL) ? NULL : strdup(pwd.pw_name); + goto exit; + case ERANGE: + /* Buffer is too small, double its size and try again */ + size *= 2; + obuffer = (buffer == initial) ? NULL : buffer; + if ((buffer = realloc(obuffer, size)) == NULL) { + goto exit; + } + continue; + default: + /* All other errors */ + goto exit; + } + } +exit: + free(obuffer); + + return result; +} /* * For Linux and solaris, software-version returns the concatenation * of the uname release and version fields. For BSD (including @@ -769,4 +826,3 @@ os_software_type() return os_name; } - ===================================== tests/filesys.lisp ===================================== @@ -10,7 +10,7 @@ (define-test unix-namestring.1.exists ;; Make sure the desired directories exist. - (assert-equal #P"/tmp/foo/bar/hello.txt" + (assert-equal "/tmp/foo/bar/hello.txt" (ensure-directories-exist "/tmp/foo/bar/hello.txt")) (dolist (path '("/tmp/hello.txt" "/tmp/foo/" @@ -27,7 +27,7 @@ (define-test unix-namestring.1.non-existent ;; Make sure the desired directories exist. - (assert-equal #P"/tmp/foo/bar/hello.txt" + (assert-equal "/tmp/foo/bar/hello.txt" (ensure-directories-exist "/tmp/foo/bar/hello.txt")) ;; These paths contain directories that don't exist. (dolist (path '("/tmp/oops/" @@ -42,7 +42,7 @@ (define-test unix-namestring.2 ;; Make sure the desired directories exist. - (assert-equal #P"/tmp/foo/bar/hello.txt" + (assert-equal "/tmp/foo/bar/hello.txt" (ensure-directories-exist "/tmp/foo/bar/hello.txt")) (unwind-protect (progn ===================================== tests/issues.lisp ===================================== @@ -579,3 +579,101 @@ with user-info = (unix:unix-getpwuid uid) while user-info finally (assert-false user-info))) + +(define-test issue.132.1 + (:tag :issues) + ;; From a message on cmucl-imp 2008/06/01. If "d1" is a directory, + ;; (rename "d1" "d2") should rename the directory "d1" to "d2". + ;; Previously that produced an error trying to rename "d1" to + ;; "d1/d2". + ;; + ;; Create the test directory (that is a subdirectory of "dir"). + (assert-true (ensure-directories-exist "dir/orig-dir/")) + (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory)))) + (multiple-value-bind (defaulted-new-name old-truename new-truename) + ;; Rename "dir/orig-dir" to "orig/new-dir". + (rename-file "orig-dir/" "new-dir") + (let ((orig (merge-pathnames + (make-pathname :directory '(:relative "orig-dir")))) + (new (merge-pathnames + (make-pathname :directory '(:relative "new-dir"))))) + ;; Ensure that the rename worked and that the returned values + ;; have the expected values. + (assert-true defaulted-new-name) + (assert-equalp old-truename orig) + (assert-equalp new-truename new))))) + +(define-test issue.132.2 + (:tag :issues) + (assert-true (ensure-directories-exist "dir/orig.dir/")) + (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory)))) + (multiple-value-bind (defaulted-new-name old-truename new-truename) + ;; Rename "dir/orig.dir" to "orig/new-dir". Since the + ;; original name has a pathname-name of "orig" and a + ;; pathname-type of "dir", the new file name is merged to + ;; produce a pathname-name of "new" with a pathname-type of + ;; "dir". + (rename-file "orig.dir" "new") + (let ((orig (merge-pathnames + (make-pathname :directory '(:relative "orig.dir")))) + (new (merge-pathnames + (make-pathname :directory '(:relative "new.dir"))))) + ;; Ensure that the rename worked and that the returned values + ;; have the expected values. + (assert-true defaulted-new-name) + (assert-equalp old-truename orig) + (assert-equalp new-truename new))))) + +(define-test issue.132.3 + (:tag :issues) + (assert-true (ensure-directories-exist "dir/orig.dir/")) + (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory)))) + (multiple-value-bind (defaulted-new-name old-truename new-truename) + ;; Rename "dir/orig.dir/" to "orig/new". Note that the + ;; original name is "orig.dir/" which marks a directory so + ;; that when we merge the new name with the old to fill in + ;; missing components, there are none because the old name is + ;; a directory with no pathname-name or pathname-type, so the + ;; new name stays the same. + (rename-file "orig.dir/" "new") + (let ((orig (merge-pathnames + (make-pathname :directory '(:relative "orig.dir")))) + (new (merge-pathnames + (make-pathname :directory '(:relative "new"))))) + ;; Ensure that the rename worked and that the returned values + ;; have the expected values. + (assert-true defaulted-new-name) + (assert-equalp old-truename orig) + (assert-equalp new-truename new))))) + +(define-test issue.134 + (:tag :issues) + ;; Verify that we can compute (3+4*%i)^%i (in Maxima format). This + ;; can be written analytically as + ;; %i*%e^-atan(4/3)*sin(log(5))+%e^-atan(4/3)*cos(log(5)), so use + ;; %this as the reference value. + (let ((answer (complex (* (cos (log 5w0)) + (exp (- (atan (float (/ 4 3) 0w0))))) + (* (sin (log 5w0)) + (exp (- (atan (float (/ 4 3) 0w0)))))))) + (flet ((relerr (actual true) + ;; Return the relative error between ACTUAL and TRUE + (/ (abs (- actual true)) + (abs true)))) + (dolist (test '((#c(3 4) 3.5918w-8) + (#c(3.0 4) 3.5918w-8) + (#c(3d0 4) 9.2977w-17) + (#c(3w0 4) 0w0))) + (destructuring-bind (base eps) + test + (let* ((value (expt base #c(0 1))) + (err (relerr value answer))) + (assert-true (<= err eps) base err eps))))))) + +(define-test issue.130 + (:tag :issues) + ;; Just verify that file-author works. In particular "." should + ;; work and not return NIL. + (assert-true (file-author ".")) + (assert-true (file-author "bin/build.sh")) + (assert-true (file-author "tests/안녕하십니까.txt"))) ===================================== tests/안녕하십니까.txt ===================================== @@ -0,0 +1,3 @@ +The file name of this file is "안녕하십니까.txt" ("Hello" in Korean.) + + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/51d4f25b5c61298d978e7d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/51d4f25b5c61298d978e7d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] Add tests for =, for completeness.
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 9cb12348 by Raymond Toy at 2023-03-08T10:33:46-08:00 Add tests for =, for completeness. - - - - - 1 changed file: - tests/nan.lisp Changes: ===================================== tests/nan.lisp ===================================== @@ -32,7 +32,9 @@ (frob single-float <) (frob single-float >) (frob double-float <) - (frob double-float >))) + (frob double-float >) + (frob single-float =) + (frob double-float =))) (define-test nan-single.< (:tag :nan) @@ -158,3 +160,50 @@ (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) +(define-test nan-single.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1f0 1f0)) + (assert-false (stst-= 2f0 1f0)) + (assert-false (stst-= 0f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *single-float-nan* 1f0)) + (assert-false (stst-= 1f0 *single-float-nan*)) + (assert-false (stst-= *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1d0 1d0)) + (assert-false (stst-= 2d0 1d0)) + (assert-false (stst-= 0d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *double-float-nan* 1d0)) + (assert-false (stst-= 1d0 *double-float-nan*)) + (assert-false (stst-= *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-=3 1f0 1f0 1f0)) + (assert-false (stst-=3 1f0 1f0 0f0)) + (assert-false (stst-=3 0f0 1f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-=3 *single-float-nan* 1f0 1f0)) + (assert-false (stst-=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-=3 1f0 1f0 *single-float-nan*)))) + +(define-test nan-double.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (dtst-=3 1d0 1d0 1d0)) + (assert-false (dtst-=3 1d0 1d0 0d0)) + (assert-false (dtst-=3 0d0 1d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-=3 *double-float-nan* 1d0 1d0)) + (assert-false (dtst-=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-=3 1d0 1d0 *double-float-nan*)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9cb12348b64546ee281c5ff… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/9cb12348b64546ee281c5ff… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] 2 commits: Simplify the vops to need just one jmp instead of two.
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 6ff1b068 by Raymond Toy at 2023-03-08T10:16:58-08:00 Simplify the vops to need just one jmp instead of two. - - - - - 8ff33374 by Raymond Toy at 2023-03-08T10:17:51-08:00 Add tests for NaN comparisons. - - - - - 2 changed files: - src/compiler/x86/float-sse2.lisp - + tests/nan.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -964,18 +964,23 @@ (descriptor-reg (inst ,inst x (,ea y)))) (cond (not-p - (inst jmp :p target) - (inst jmp :na target)) + ;; Instead of x > y, we're doing x <= y and want + ;; to jmp when x <= y. If NaN occurrs we also + ;; want to jump. x <= y means CF = 1 or ZF = 1. + ;; When NaN occurs, ZF, PF, and CF are all set. + ;; Hence, we can just test for x <= y. + (inst jmp :be target)) (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :a target) - (emit-label not-lab))))))))) + ;; If there's NaN, the ZF, PF, and CF bits are + ;; set. We only want to jmp to the target when + ;; x > y. This happens if CF = 0. Hence, we + ;; will not jmp to the target if NaN occurred. + (inst jmp :a target)))))))) (frob > single comiss) (frob > double comisd)) (macrolet - ((frob (op size inst) + ((frob (op size inst mover) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -987,22 +992,29 @@ `(define-vop (,name ,inherit) (:translate ,op) (:info target not-p) + (:temporary (:sc ,sc-type) load-y) (:generator 3 (sc-case y (,sc-type - (inst ,inst x y)) + (inst ,inst y x)) (descriptor-reg - (inst ,inst x (,ea y)))) + (inst ,mover load-y (,ea y)) + (inst ,inst load-y x))) (cond (not-p - (inst jmp :p target) - (inst jmp :nb target)) + ;; Instead of x < y, we're doing x >= y and want + ;; to jmp when x >= y. But x >=y is the same as + ;; y <= x, so if we swap the args, we can apply + ;; the same logic we use for > not-p case above. + (inst jmp :be target)) (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp :b target) - (emit-label not-lab))))))))) - (frob < single comiss) - (frob < double comisd)) + ;; We want to jump when x < y. This is the same + ;; as jumping when y > x. So if we reverse the + ;; args, we can apply the same logic as we did + ;; above for the > vop. + + (inst jmp :a target)))))))) + (frob < single comiss movss) + (frob < double comisd movsd)) ;;;; Conversion: ===================================== tests/nan.lisp ===================================== @@ -0,0 +1,160 @@ +;;; Tests for NaN comparisons. +(defpackage :nan-tests + (:use :cl :lisp-unit)) + +(in-package :nan-tests) + +(defparameter *single-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + +(defparameter *double-float-nan* + (ext:with-float-traps-masked (:invalid :divide-by-zero) + (/ 0d0 0d0))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (macrolet + ((frob (ntype op) + (let* ((name (ext:symbolicate (if (eq ntype 'single-float) + "S" + "D") + "TST-" op)) + (name3 (ext:symbolicate name "3"))) + + `(progn + (defun ,name (x y) + (declare (,ntype x y)) + (,op x y)) + (defun ,name3 (x y z) + (declare (,ntype x y z)) + (,op x y z)))))) + (frob single-float <) + (frob single-float >) + (frob double-float <) + (frob double-float >))) + +(define-test nan-single.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-< 1f0 2f0)) + (assert-false (stst-< 1f0 1f0)) + (assert-false (stst-< 1f0 0f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-< *single-float-nan* 1f0)) + (assert-false (stst-< 1f0 *single-float-nan*)) + (assert-false (stst-< *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.< + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-< 1d0 2d0)) + (assert-false (dtst-< 1d0 1d0)) + (assert-false (dtst-< 1d0 0d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-< *double-float-nan* 1d0)) + (assert-false (dtst-< 1d0 *double-float-nan*)) + (assert-false (dtst-< *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-> 2f0 1f0)) + (assert-false (stst-> 1f0 1f0)) + (assert-false (stst-> 0f0 1f0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-> *single-float-nan* 1f0)) + (assert-false (stst-> 1f0 *single-float-nan*)) + (assert-false (stst-> *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.> + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (dtst-> 2d0 1d0)) + (assert-false (dtst-> 1d0 1d0)) + (assert-false (dtst-> 0d0 1d0)) + ;; Now try NaN. All comparisons should be false. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-> *double-float-nan* 1d0)) + (assert-false (dtst-> 1d0 *double-float-nan*)) + (assert-false (dtst-> *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.<3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst-<3 1f0 2f0 3f0)) + (assert-false (stst-<3 1f0 2f0 2f0)) + (assert-false (stst-<3 1f0 1f0 2f0)) + (assert-false (stst-<3 1f0 0f0 2f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<3 *single-float-nan* 2f0 3f0)) + (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) + (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.<3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst-<3 1d0 2d0 3d0)) + (assert-false (dtst-<3 1d0 2d0 2d0)) + (assert-false (dtst-<3 1d0 1d0 2d0)) + (assert-false (dtst-<3 1d0 0d0 2d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)))) + +(define-test nan-single.>3 + (:tag :nan) + ;; First just make sure it works with regular single-floats + (assert-true (stst->3 3f0 2f0 1f0)) + (assert-false (stst->3 3f0 1f0 1f0)) + (assert-false (stst->3 2f0 2f0 1f0)) + (assert-false (stst->3 0f0 2f0 1f0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->3 *single-float-nan* 2f0 3f0)) + (assert-false (stst->3 1f0 *single-float-nan* 3f0)) + (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)))) + +(define-test nan-double.>3 + (:tag :nan) + ;; First just make sure it works with regular double-floats + (assert-true (dtst->3 3d0 2d0 1d0)) + (assert-false (dtst->3 3d0 1d0 1d0)) + (assert-false (dtst->3 2d0 2d0 1d0)) + (assert-false (dtst->3 0d0 2d0 1d0)) + ;; Now try NaN. Currently we can only test if there's NaN in the + ;; first two args. When NaN is the last arg, we return the + ;; incorrect value because of how multi-compare converts multiple + ;; args into paris of comparisons. + ;; + ;; When that is fixed, we can add additional tests. Nevertheless, + ;; this is useful because it tests the not-p case of the vops. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->3 *double-float-nan* 2d0 3d0)) + (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/87906cf27d0fa2d30ccc4d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/87906cf27d0fa2d30ccc4d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-175-simplify-float-compare-vops
by Raymond Toy (＠rtoy) 08 Mar '23

08 Mar '23

Raymond Toy pushed new branch issue-175-simplify-float-compare-vops at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-175-simplify-float-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs March 2023