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.
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.
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.
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.
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.
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.
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.
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.