cmucl-cvs

cmucl-cvs@common-lisp.net

2904 discussions

[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

[Git][cmucl/cmucl] Pushed new branch issue-177-pprint-deftransform
by Raymond Toy (＠rtoy) 14 Mar '23

14 Mar '23

Raymond Toy pushed new branch issue-177-pprint-deftransform at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-177-pprint-deftrans… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-172-pathname-match-p-return-type] Update release notes.
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-172-pathname-match-p-return-type at cmucl / cmucl Commits: 8211fa9d by Raymond Toy at 2023-03-13T10:20:45-07:00 Update release notes. - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== 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/-/commit/8211fa9da9e6aaed592a4bc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8211fa9da9e6aaed592a4bc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-172-pathname-match-p-return-type
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed new branch issue-172-pathname-match-p-return-type at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-172-pathname-match-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-176-site-name-is-nil] Update release notes for this issue
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-176-site-name-is-nil at cmucl / cmucl Commits: d749f539 by Raymond Toy at 2023-03-13T07:50:12-07:00 Update release notes for this issue - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -76,6 +76,7 @@ public domain. * ~~#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` + * ~~#176~~ `SHORT-SITE-NAME` and `LONG-SITE-NAME` return `NIL`. * 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/d749f53994ce1d318aafd09… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d749f53994ce1d318aafd09… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-176-site-name-is-nil
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed new branch issue-176-site-name-is-nil at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-176-site-name-is-nil 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] Update release notes
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: 6e59b0b2 by Raymond Toy at 2023-03-13T07:36:59-07:00 Update release notes - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -49,6 +49,7 @@ public domain. * ~~#108~~ Update ASDF * ~~#112~~ CLX can't connect to X server via inet sockets * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF. + * ~~#120~~ `SOFTWARE-TYPE` and `SOFTWARE-VERSION` are implemented in C. * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM * ~~#122~~ gcc 11 can't build cmucl * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6e59b0b21eabe3bf27347bf… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6e59b0b21eabe3bf27347bf… 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] 2 commits: Use static buffer to hold results
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl Commits: a47e8963 by Raymond Toy at 2023-03-13T07:31:19-07:00 Use static buffer to hold results Instead of dynamically allocating space to the the results for `software-type` and `software-version`, use a static string in each function. Fill the string with desired result and return it. The Lisp interface needs to be updated not to free the memory now since it's not dynamically allocated. - - - - - 98ae551c by Raymond Toy at 2023-03-13T07:33:45-07:00 Update pot files. The location of the docstrings have moved and have changed, so the pot files need to be updated. - - - - - 4 changed files: - src/code/misc.lisp - src/i18n/locale/cmucl-linux-os.pot - src/i18n/locale/cmucl.pot - src/lisp/os-common.c Changes: ===================================== src/code/misc.lisp ===================================== @@ -199,9 +199,7 @@ (alien:extern-alien "os_software_type" (function (alien:* c-call:c-string))))) (unless (zerop (sap-int (alien:alien-sap software-type))) - (alien:cast software-type c-call:c-string))) - (when software-type - (alien:free-alien software-type)))))) + (alien:cast software-type c-call:c-string))))))) *software-type*) (defvar *software-version* nil @@ -219,9 +217,7 @@ (alien:extern-alien "os_software_version" (function (alien:* c-call:c-string))))) (unless (zerop (sap-int (alien:alien-sap version))) - (alien:cast version c-call:c-string))) - (when version - (alien:free-alien version))))) + (alien:cast version c-call:c-string)))))) *software-version*)) (defvar *short-site-name* (intl:gettext "Unknown") ===================================== src/i18n/locale/cmucl-linux-os.pot ===================================== @@ -15,10 +15,6 @@ msgstr "" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" -#: src/code/linux-os.lisp -msgid "Returns a string describing version of the supporting software." -msgstr "" - #: src/code/linux-os.lisp msgid "Unix system call getrusage failed: ~A." msgstr "" ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -5605,14 +5605,14 @@ msgid "" " NIL if no such character exists." msgstr "" -#: src/code/misc.lisp +#: src/code/misc-doc.lisp src/code/misc.lisp msgid "" "Returns the documentation string of Doc-Type for X, or NIL if\n" " none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,\n" " SETF, and T." msgstr "" -#: src/code/misc.lisp +#: src/code/misc-doc.lisp src/code/misc.lisp msgid "~S is not the name of a structure type." msgstr "" @@ -5643,13 +5643,21 @@ msgid "Returns a string giving the name of the local machine." msgstr "" #: src/code/misc.lisp -msgid "The value of SOFTWARE-TYPE. Set in FOO-os.lisp." +msgid "The value of SOFTWARE-TYPE." msgstr "" #: src/code/misc.lisp msgid "Returns a string describing the supporting software." msgstr "" +#: src/code/misc.lisp +msgid "Version string for supporting software" +msgstr "" + +#: src/code/misc.lisp +msgid "Returns a string describing version of the supporting software." +msgstr "" + #: src/code/misc.lisp msgid "The value of SHORT-SITE-NAME. Set in library:site-init.lisp." msgstr "" ===================================== src/lisp/os-common.c ===================================== @@ -817,43 +817,47 @@ os_get_locale_codeset() #endif char* -os_software_version() +os_software_version(void) { - int status; struct utsname uts; - char *version = NULL; + /* + * Buffer large enough to hold the release and version that's used + * for Linux and Solaris. + */ + static char result[sizeof(uts.release) + sizeof(uts.version)]; + + int status; status = uname(&uts); - if (status == 0) { - int version_length; + if (status != 0) { + return NULL; + } + #if defined(UNAME_RELEASE_AND_VERSION) - version_length = strlen(uts.release) + strlen(uts.version) + 2; - version = malloc(version_length); - if (version) { - strcpy(version, uts.release); - strcat(version, " "); - strcat(version, uts.version); - } + strcpy(result, uts.release); + strcat(result, " "); + strcat(result, uts.version); #else - version = strdup(uts.version); + strcpy(result, uts.version); #endif - } - return version; + return result; } #undef UNAME_RELEASE_AND_VERSION char* -os_software_type() +os_software_type(void) { int status; struct utsname uts; - char *os_name = NULL; + static char os_name[sizeof(uts.sysname)]; status = uname(&uts); - if (status == 0) { - os_name = strdup(uts.sysname); + if (status != 0) { + return NULL; } + + strcpy(os_name, uts.sysname); return os_name; } View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d8f99abf569c7ae830abeb… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d8f99abf569c7ae830abeb… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-158-darwin-pathnames-utf8] Disable darwin test
by Raymond Toy (＠rtoy) 13 Mar '23

13 Mar '23

Raymond Toy pushed to branch issue-158-darwin-pathnames-utf8 at cmucl / cmucl Commits: 623caa85 by Raymond Toy at 2023-03-12T16:57:42-07:00 Disable darwin test The test assumes that we're normalizing pathnames on Darwin, but we're not currently doing that. Hence disable the test for now, but leave it in. - - - - - 1 changed file: - tests/issues.lisp Changes: ===================================== tests/issues.lisp ===================================== @@ -838,7 +838,8 @@ (path (make-pathname :directory (list :relative name) :name name :type name))) - #+darwin + ;; Enable this when we implement normalization for Darwin + #+(and nil darwin) (let ((expected '(4352 4456 4543))) ;; Tests that on Darwin the Hangul pathname has been normalized ;; correctly. We fill in the directory, name, and type components View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/623caa858be07f609f666a1… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/623caa858be07f609f666a1… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs