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

[Git][cmucl/cmucl] Pushed new branch issue-171-readable-unspecific-pathnames
by Raymond Toy (＠rtoy) 17 Mar '23

17 Mar '23

Raymond Toy pushed new branch issue-171-readable-unspecific-pathnames at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-171-readable-unspec… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-120-move-misc-first] Add new file misc-doc.lisp
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch issue-120-move-misc-first at cmucl / cmucl Commits: 6751cc90 by Raymond Toy at 2023-03-16T12:18:09-07:00 Add new file misc-doc.lisp Forgot to chech this in. - - - - - 1 changed file: - + src/code/misc-doc.lisp Changes: ===================================== src/code/misc-doc.lisp ===================================== @@ -0,0 +1,119 @@ +;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/misc.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; Documentation functions. Needed by pclcom.lisp +(in-package "LISP") +(intl:textdomain "cmucl") + +(export '(documentation)) + +;;; cobbled from stuff in describe.lisp. +(defun function-doc (x) + (let ((name + (case (kernel:get-type x) + (#.vm:closure-header-type + (kernel:%function-name (%closure-function x))) + ((#.vm:function-header-type #.vm:closure-function-header-type) + (kernel:%function-name x)) + (#.vm:funcallable-instance-header-type + (typecase x + (kernel:byte-function + (c::byte-function-name x)) + (kernel:byte-closure + (c::byte-function-name (byte-closure-function x))) + (eval:interpreted-function + (multiple-value-bind + (exp closure-p dname) + (eval:interpreted-function-lambda-expression x) + (declare (ignore exp closure-p)) + dname)) + (t ;; funcallable-instance + (kernel:%function-name + (kernel:funcallable-instance-function x)))))))) + (when (and name (typep name '(or symbol cons))) + (values (info function documentation name))))) + +(defun documentation (x doc-type) + "Returns the documentation string of Doc-Type for X, or NIL if + none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, + SETF, and T." + (flet (;; CMUCL random-documentation. + (try-cmucl-random-doc (x doc-type) + (declare (symbol doc-type)) + (cdr (assoc doc-type + (values (info random-documentation stuff x)))))) + (case doc-type + (variable + (typecase x + (symbol (values (info variable documentation x))))) + (function + (typecase x + (symbol (values (info function documentation x))) + (function (function-doc x)) + (list ;; Must be '(setf symbol) + (values (info function documentation (cadr x)))))) + (structure + (typecase x + (symbol (when (eq (info type kind x) :instance) + (values (info type documentation x)))))) + (type + (typecase x + (kernel::structure-class (values (info type documentation (%class-name x)))) + (t (and (typep x 'symbol) (values (info type documentation x)))))) + (setf (info setf documentation x)) + ((t) + (typecase x + (function (function-doc x)) + (package (package-doc-string x)) + (kernel::structure-class (values (info type documentation (%class-name x)))) + (symbol (try-cmucl-random-doc x doc-type)))) + (t + (typecase x + (symbol (try-cmucl-random-doc x doc-type))))))) + +(defun (setf documentation) (string name doc-type) + #-no-docstrings + (case doc-type + (variable + #+nil + (when string + (%primitive print "Set variable text domain") + (%primitive print (symbol-name name)) + (%primitive print intl::*default-domain*)) + (setf (info variable textdomain name) intl::*default-domain*) + (setf (info variable documentation name) string)) + (function + #+nil + (when intl::*default-domain* + (%primitive print "Set function text domain") + (%primitive print (symbol-name name)) + (%primitive print intl::*default-domain*)) + (setf (info function textdomain name) intl::*default-domain*) + (setf (info function documentation name) string)) + (structure + (unless (eq (info type kind name) :instance) + (error (intl:gettext "~S is not the name of a structure type.") name)) + (setf (info type textdomain name) intl::*default-domain*) + (setf (info type documentation name) string)) + (type + (setf (info type textdomain name) intl::*default-domain*) + (setf (info type documentation name) string)) + (setf + (setf (info setf textdomain name) intl::*default-domain*) + (setf (info setf documentation name) string)) + (t + (let ((pair (assoc doc-type (info random-documentation stuff name)))) + (if pair + (setf (cdr pair) string) + (push (cons doc-type string) + (info random-documentation stuff name)))))) + string) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6751cc9068596eddfffbfc8… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6751cc9068596eddfffbfc8… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-120-move-misc-first
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed new branch issue-120-move-misc-first at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-120-move-misc-first 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] Add some comments and indent code neatly.
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 07cc6791 by Raymond Toy at 2023-03-16T10:26:24-07:00 Add some comments and indent code neatly. - - - - - 1 changed file: - src/compiler/srctran.lisp Changes: ===================================== src/compiler/srctran.lisp ===================================== @@ -3537,6 +3537,11 @@ (deftransform > ((x y) (real real) * :when :both) (ir1-transform-< y x x y '<)) +;;; Ir1-transform->=-helper -- Internal +;;; +;;; Derives the result type of the comparison X >= Y returning two +;;; values: the first true if X >= Y, and the second true if X < Y. +;;; This is the equivalent of ir1-transform-<-helper, but for >=. #+(and x86) (defun ir1-transform->=-helper (x y) (flet ((maybe-convert (type) @@ -3558,34 +3563,33 @@ (interval-< x-arg y-arg))))) (values definitely-true definitely-false)))) +;;; IR1-TRANSFORM->= -- Internal +;;; +;;; Like IR1-TRANSFORM-< but for >=. This is needed so that the +;;; compiler can statically determine (>= X Y) using type information. #+(and x86) (defun ir1-transform->= (x y first second inverse) - (if (same-leaf-ref-p x y) - 't - (multiple-value-bind (definitely-true definitely-false) - (ir1-transform->=-helper x y) - (cond (definitely-true - t) - (definitely-false - nil) - ((and (constant-continuation-p first) - (not (constant-continuation-p second))) - #+nil - (format t "swapping ~A~%" inverse) - `(,inverse y x)) - (t - (give-up)))))) + ;; If the leaves are the same, the (>= X Y) is true. + (if (same-leaf-ref-p x y) + 't + (multiple-value-bind (definitely-true definitely-false) + (ir1-transform->=-helper x y) + (cond (definitely-true + t) + (definitely-false + nil) + ((and (constant-continuation-p first) + (not (constant-continuation-p second))) + `(,inverse y x)) + (t + (give-up)))))) #+(and x86) (deftransform <= ((x y) (real real) * :when :both) - #+nli - (format t "transform <=~%") (ir1-transform->= y x x y '>=)) #+(and x86) (deftransform >= ((x y) (real real) * :when :both) - #+nil - (format t "transform >=~%") (ir1-transform->= x y x y '<=)) @@ -3605,7 +3609,6 @@ ;; (<= x y) is the same as (not (> x y)) `(not (> x y))) - (deftransform >= ((x y) (integer integer) * :when :both) ;; (>= x y) is the same as (not (< x y)) `(not (< x y)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/07cc6791a1b285aca7d733f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/07cc6791a1b285aca7d733f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Fix some typos
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: b329b385 by Raymond Toy at 2023-03-16T10:18:39-07:00 Fix some typos - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -56,7 +56,7 @@ public domain. * ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid. * ~~#128~~ `QUIT` accepts an exit code * ~~#130~~ Move file-author to C - * ~~#132~~ Ansi test `RENAME-FILE.1` no fails + * ~~#132~~ Ansi test `RENAME-FILE.1` no longer fails * ~~#134~~ Handle the case of `(expt complex complex-rational)` * ~~#136~~ `ensure-directories-exist` should return the given pathspec * #139 `*default-external-format*` defaults to `:utf-8`; add alias for `:locale` external format @@ -69,13 +69,13 @@ public domain. * ~~#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 + * ~~#163~~ Add command-line 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. + * ~~#166~~ Fix incorrect type declaration for exponent from `integer-decode-float` + * ~~#167~~ Low 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` - * ~~#172~~ Declare `pathname-match-p` as returning a null or pathname + * ~~#172~~ Declare `pathname-match-p` as returning `nil` or `pathname`. * ~~#173~~ Add pprinter for `define-assembly-routine` * Other changes: * Improvements to the PCL implementation of CLOS: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b329b3853e0686f175dfb0f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b329b3853e0686f175dfb0f… 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] 2 commits: Add ir1 transform for >=
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: cd340ff8 by Raymond Toy at 2023-03-16T10:10:00-07:00 Add ir1 transform for >= Without this, the compiler can't statically determine if x >= y is always T or NIL, like it can for x < y (and x > y). We choose >= because only `interval-<` and `interval->=` are implemented so >= is a natural choice. - - - - - 49d36d2d by Raymond Toy at 2023-03-16T10:12:24-07:00 Update cmucl.pot - - - - - 2 changed files: - src/compiler/srctran.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/compiler/srctran.lisp ===================================== @@ -3537,8 +3537,59 @@ (deftransform > ((x y) (real real) * :when :both) (ir1-transform-< y x x y '<)) +#+(and x86) +(defun ir1-transform->=-helper (x y) + (flet ((maybe-convert (type) + (numeric-type->interval + (cond ((numeric-type-p type) type) + ((member-type-p type) (convert-member-type type)) + (t (give-up)))))) + (let ((xi (mapcar #'maybe-convert + (prepare-arg-for-derive-type (continuation-type x)))) + (yi (mapcar #'maybe-convert + (prepare-arg-for-derive-type (continuation-type y)))) + (definitely-true t) + (definitely-false t)) + (dolist (x-arg xi) + (dolist (y-arg yi) + (setf definitely-true (and definitely-true + (interval->= x-arg y-arg))) + (setf definitely-false (and definitely-false + (interval-< x-arg y-arg))))) + (values definitely-true definitely-false)))) -#+x86 +#+(and x86) +(defun ir1-transform->= (x y first second inverse) + (if (same-leaf-ref-p x y) + 't + (multiple-value-bind (definitely-true definitely-false) + (ir1-transform->=-helper x y) + (cond (definitely-true + t) + (definitely-false + nil) + ((and (constant-continuation-p first) + (not (constant-continuation-p second))) + #+nil + (format t "swapping ~A~%" inverse) + `(,inverse y x)) + (t + (give-up)))))) + +#+(and x86) +(deftransform <= ((x y) (real real) * :when :both) + #+nli + (format t "transform <=~%") + (ir1-transform->= y x x y '>=)) + +#+(and x86) +(deftransform >= ((x y) (real real) * :when :both) + #+nil + (format t "transform >=~%") + (ir1-transform->= x y x y '<=)) + + +#+(and nil x86) (progn ;; When x and y are integers, we want to transform <= to > and >= to ;; <. But we don't want to do this for floats because it messes up ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -21588,3 +21588,9 @@ msgid "" "Unicode replacement character." msgstr "" +transform <= +transform >= +transform <= +transform >= +transform >= +transform <= View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/29cd008228a0d93a40a380… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/29cd008228a0d93a40a380… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #172: Declare pathname-match-p to return NIL or a pathname
by Raymond Toy (＠rtoy) 16 Mar '23

16 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6b3ceb28 by Raymond Toy at 2023-03-16T17:08:32+00:00 Fix #172: Declare pathname-match-p to return NIL or a pathname - - - - - 0b9e41a4 by Raymond Toy at 2023-03-16T17:08:35+00:00 Merge branch 'issue-172-pathname-match-p-return-type' into 'master' Fix #172: Declare pathname-match-p to return NIL or a pathname Closes #172 See merge request cmucl/cmucl!131 - - - - - 2 changed files: - src/compiler/fndb.lisp - src/general-info/release-21e.md Changes: ===================================== src/compiler/fndb.lisp ===================================== @@ -1027,7 +1027,10 @@ :type :version)) boolean (flushable)) -(defknown pathname-match-p (pathnamelike pathnamelike) boolean +(defknown pathname-match-p (pathnamelike pathnamelike) + ;; CLHS says the return type is a generalized boolean. We currently + ;; return a pathname on a match. + (or null pathname) (flushable)) (defknown translate-pathname (pathnamelike pathnamelike pathnamelike &key) pathname ===================================== src/general-info/release-21e.md ===================================== @@ -75,6 +75,7 @@ public domain. * ~~#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` + * ~~#172~~ Declare `pathname-match-p` as returning a null or pathname * ~~#173~~ Add pprinter for `define-assembly-routine` * Other changes: * Improvements to the PCL implementation of CLOS: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/75e0b7e3ff1c8f52fd5aad… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/75e0b7e3ff1c8f52fd5aad… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #177: Add pprinter for deftransform and defoptimizer
by Raymond Toy (＠rtoy) 15 Mar '23

15 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 6b28a906 by Raymond Toy at 2023-03-15T14:06:28+00:00 Fix #177: Add pprinter for deftransform and defoptimizer - - - - - 75e0b7e3 by Raymond Toy at 2023-03-15T14:06:31+00:00 Merge branch 'issue-177-pprint-deftransform' into 'master' Fix #177: Add pprinter for deftransform and defoptimizer Closes #177 See merge request cmucl/cmucl!132 - - - - - 1 changed file: - src/code/pprint.lisp Changes: ===================================== src/code/pprint.lisp ===================================== @@ -2074,7 +2074,9 @@ When annotations are present, invoke them at the right positions." (lisp::with-array-data pprint-with-like) (c:define-vop pprint-define-vop) (c:sc-case pprint-sc-case) - (c:define-assembly-routine pprint-define-assembly))) + (c:define-assembly-routine pprint-define-assembly) + (c:deftransform pprint-defun) + (c:defoptimizer pprint-defun))) (defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a7237e1d632c5d13ed5266… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a7237e1d632c5d13ed5266… 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] Add more NaN tests
by Raymond Toy (＠rtoy) 14 Mar '23

14 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 29cd0082 by Raymond Toy at 2023-03-14T13:02:52-07:00 Add more NaN tests Add tests to verify that we handle NaNs correctly in comparisons. This includes adding tests for <= and >=, and also updating the existing tests for < and > to handle NaN in the second or third arg. - - - - - 1 changed file: - tests/nan.lisp Changes: ===================================== tests/nan.lisp ===================================== @@ -34,7 +34,11 @@ (frob double-float <) (frob double-float >) (frob single-float =) - (frob double-float =))) + (frob double-float =) + (frob single-float >=) + (frob double-float >=) + (frob single-float <=) + (frob double-float <=))) (define-test nan-single.< (:tag :nan) @@ -101,7 +105,10 @@ (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)))) + (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0)) + (assert-false (stst-<3 1f0 2f0 *single-float-nan*)) + (assert-false (stst-<3 1f0 *single-float-nan* 3f0)) + (assert-false (stst-<3 1f0 *single-float-nan* *single-float-nan*)))) (define-test nan-double.<3 (:tag :nan) @@ -120,7 +127,10 @@ (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)))) + (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0)) + (assert-false (dtst-<3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst-<3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst-<3 1d0 *double-float-nan* *double-float-nan*)))) (define-test nan-single.>3 (:tag :nan) @@ -139,7 +149,10 @@ (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)))) + (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0)) + (assert-false (stst->3 1f0 2f0 *single-float-nan*)) + (assert-false (stst->3 1f0 *single-float-nan* 3f0)) + (assert-false (stst->3 1f0 *single-float-nan* *single-float-nan*)))) (define-test nan-double.>3 (:tag :nan) @@ -158,7 +171,118 @@ (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)))) + (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0)) + (assert-false (dtst->3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst->3 1d0 *double-float-nan* 3d0)) + (assert-false (dtst->3 1d0 *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.>= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst->= 1f0 1f0)) + (assert-true (stst->= 2f0 1f0)) + (assert-false (stst->= 0f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->= 1f0 *single-float-nan*)) + (assert-false (stst->= *single-float-nan* 1f0)) + (assert-false (stst->= *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.<= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst-<= 1f0 1f0)) + (assert-true (stst-<= 1f0 2f0)) + (assert-false (stst-<= 2f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<= 1f0 *single-float-nan*)) + (assert-false (stst-<= *single-float-nan* 1f0)) + (assert-false (stst-<= *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.>=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst->=3 1f0 1f0 1f0)) + (assert-true (stst->=3 2f0 1f0 1f0)) + (assert-false (stst->=3 0f0 1f0 1f0)) + (assert-false (stst->=3 2f0 0f0 1f0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (stst->=3 1f0 *single-float-nan* 2f0)) + (assert-false (stst->=3 *single-float-nan* 1f0 2f0)) + (assert-false (stst->=3 *single-float-nan* *single-float-nan* 2f0)) + (assert-false (stst->=3 2f0 1f0 *single-float-nan*)) + (assert-false (stst->=3 2f0 *single-float-nan* 1f0)) + (assert-false (stst->=3 2f0 *single-float-nan* *single-float-nan*)))) + +(define-test nan-single.<=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (stst-<=3 1f0 1f0 1f0)) + (assert-true (stst-<=3 1f0 2f0 2f0)) + (assert-false (stst-<=3 1f0 3f0 2f0)) + (assert-false (stst-<=3 2f0 1f0 1f0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-<=3 1f0 *single-float-nan* 2f0)) + (assert-false (stst-<=3 *single-float-nan* 1f0 2f0)) + (assert-false (stst-<=3 *single-float-nan* *single-float-nan* 2f0)) + (assert-false (stst-<=3 1f0 2f0 *single-float-nan*)) + (assert-false (stst-<=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-<=3 1f0 *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.>= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst->= 1f0 1f0)) + (assert-true (dtst->= 2f0 1f0)) + (assert-false (dtst->= 0f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->= 1f0 *double-float-nan*)) + (assert-false (dtst->= *double-float-nan* 1f0)) + (assert-false (dtst->= *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.<= + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst-<= 1f0 1f0)) + (assert-true (dtst-<= 1f0 2f0)) + (assert-false (dtst-<= 2f0 1f0)) + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<= 1f0 *double-float-nan*)) + (assert-false (dtst-<= *double-float-nan* 1f0)) + (assert-false (dtst-<= *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.>=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst->=3 1d0 1d0 1d0)) + (assert-true (dtst->=3 2d0 1d0 1d0)) + (assert-false (dtst->=3 0d0 1d0 1d0)) + (assert-false (dtst->=3 2d0 0d0 1d0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst->=3 1d0 *double-float-nan* 2d0)) + (assert-false (dtst->=3 *double-float-nan* 1d0 2d0)) + (assert-false (dtst->=3 *double-float-nan* *double-float-nan* 2d0)) + (assert-false (dtst->=3 2d0 1d0 *double-float-nan*)) + (assert-false (dtst->=3 2d0 *double-float-nan* 1d0)) + (assert-false (dtst->=3 2d0 *double-float-nan* *double-float-nan*)))) + +(define-test nan-double.<=3 + (:tag :nan) + :Basic tests with regular numbers + (assert-true (dtst-<=3 1d0 1d0 1d0)) + (assert-true (dtst-<=3 1d0 2d0 2d0)) + (assert-false (dtst-<=3 1d0 3d0 2d0)) + (assert-false (dtst-<=3 2d0 1d0 1d0)) + + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-<=3 1d0 *double-float-nan* 2d0)) + (assert-false (dtst-<=3 *double-float-nan* 1d0 2d0)) + (assert-false (dtst-<=3 *double-float-nan* *double-float-nan* 2d0)) + (assert-false (dtst-<=3 1d0 2d0 *double-float-nan*)) + (assert-false (dtst-<=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-<=3 1d0 *double-float-nan* *double-float-nan*)))) (define-test nan-single.= (:tag :nan) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/29cd008228a0d93a40a3803… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/29cd008228a0d93a40a3803… 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 bug in two-arg->= and two-arg-<=
by Raymond Toy (＠rtoy) 14 Mar '23

14 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 8bb4ed86 by Raymond Toy at 2023-03-14T11:56:27-07:00 Fix bug in two-arg->= and two-arg-<= We were handling comparisons of a ratio to an integer and vice versa incorrectly. Use the floor/ceiling appropriately. Now `(kernel::two-arg->= 4e-8 1)` returns `NIL` as expected instead of `T`. - - - - - 1 changed file: - src/code/numbers.lisp Changes: ===================================== src/code/numbers.lisp ===================================== @@ -1038,7 +1038,7 @@ ;; issue #156. #+x86 (progn - (two-arg-</> two-arg-<= <= floor ceiling + (two-arg-</> two-arg-<= <= ceiling floor ((fixnum bignum) (bignum-plus-p y)) ((bignum fixnum) @@ -1046,7 +1046,7 @@ ((bignum bignum) (not (plusp (bignum-compare x y))))) - (two-arg-</> two-arg->= >= ceiling floor + (two-arg-</> two-arg->= >= floor ceiling ((fixnum bignum) (not (bignum-plus-p y))) ((bignum fixnum) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8bb4ed863f8dcf1ac5c49c8… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8bb4ed863f8dcf1ac5c49c8… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0