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

[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) 12 Mar '23

12 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

[Git][cmucl/cmucl][issue-158-darwin-pathnames-utf8] Disable Darwin path normalization stuff.
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-158-darwin-pathnames-utf8 at cmucl / cmucl Commits: 2fb8db98 by Raymond Toy at 2023-03-12T16:17:13-07:00 Disable Darwin path normalization stuff. Don't set up Unicode stuff needed for Darwin path normalization. The code remains, but initialization and enabling of these items are removed from the initial function. - - - - - 2 changed files: - src/code/lispinit.lisp - src/code/save.lisp Changes: ===================================== src/code/lispinit.lisp ===================================== @@ -308,8 +308,7 @@ ;;; in Unwind-Protects will get executed. (declaim (special *lisp-initialization-functions* - *load-time-values* - *enable-darwin-path-normalization*)) + *load-time-values*)) (eval-when (compile) (defmacro print-and-call (name) @@ -345,7 +344,6 @@ (setf *type-system-initialized* nil) (setf *break-on-signals* nil) (setf unix::*filename-encoding* :null) - (setf *enable-darwin-path-normalization* nil) #+gengc (setf conditions::*handler-clusters* nil) (setq intl::*default-domain* "cmucl") (setq intl::*locale* "C") ===================================== src/code/save.lisp ===================================== @@ -316,17 +316,6 @@ ;; we've possibly changed the environment variables and ;; pathnames. (environment-init) - #+darwin - (progn - ;; Get some unicode stuff needed for decomposing strings. - ;; This is needed on Darwin to normalize pathname - ;; objects, which needs this information. If we don't, - ;; we'll load the information at runtime when creating - ;; the path to "unidata.dat", which then calls decompose - ;; again, and so on. - (lisp::load-decomp) - (lisp::load-combining) - (setf *enable-darwin-path-normalization* t)) ;; Set the locale for lisp (intl::setlocale) (ext::process-command-strings process-command-line) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2fb8db98f6766d5d38c8c2c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2fb8db98f6766d5d38c8c2c… 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] 6 commits: Fix #157: (directory "**/") only returns directories
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison 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 - - - - - 0038d3d9 by Raymond Toy at 2023-03-09T11:18:21-08:00 Update release notes with recently closed bugs - - - - - d51eb4b8 by Raymond Toy at 2023-03-12T19:05:39+00:00 Fix #175: Simplify branching in x86 float compare vops - - - - - a7237e1d by Raymond Toy at 2023-03-12T19:05:39+00:00 Merge branch 'issue-175-simplify-float-compare-vops' into 'master' Fix #175: Simplify branching in x86 float compare vops Closes #175 See merge request cmucl/cmucl!129 - - - - - a61a38a6 by Raymond Toy at 2023-03-12T12:32:24-07:00 Merge branch 'master' into issue-156-take-2-nan-comparison - - - - - 5 changed files: - src/code/filesys.lisp - src/compiler/x86/float-sse2.lisp - src/general-info/release-21e.md - + tests/nan.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))) ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -945,7 +945,7 @@ (frob double ucomisd)) (macrolet - ((frob (op size inst yep nope) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -953,28 +953,52 @@ 'ea-for-df-desc))) (name (symbolicate op "/" size "-FLOAT")) (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) + (inherit (symbolicate size "-FLOAT-COMPARE")) + (reverse-args-p (eq op '<))) `(define-vop (,name ,inherit) + ;; The compare instructions take a reg argument for the + ;; first arg and reg or mem argument for the second. When + ;; inverting the arguments we must also invert which of + ;; the argument can be a mem argument. + (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg))) + (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg)))) (:translate ,op) (:info target not-p) (:generator 3 - (sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp ,nope target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp ,yep target) - (emit-label not-lab))))))))) - (frob < single comiss :b :nb) - (frob > single comiss :a :na) - (frob < double comisd :b :nb) - (frob > double comisd :a :na)) + ;; Note: x < y is the same as y > x. We reverse the + ;; args to reduce the number of jump instructions + ;; needed. + ,(if reverse-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y))))) + ;; Consider the case of x > y. + ;; + ;; 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. + ;; + ;; For the case of x < y, we can use the equivalent y > + ;; x. Thus if we swap the args, the same logic applies. + (inst jmp (if (not not-p) :a :be) target)))))) + (frob > single comiss) + (frob > double comisd) + (frob < single comiss) + (frob < double comisd)) ===================================== 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: ===================================== tests/nan.lisp ===================================== @@ -0,0 +1,209 @@ +;;; 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 >) + (frob single-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)))) + +(define-test nan-single.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1f0 1f0)) + (assert-false (stst-= 2f0 1f0)) + (assert-false (stst-= 0f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *single-float-nan* 1f0)) + (assert-false (stst-= 1f0 *single-float-nan*)) + (assert-false (stst-= *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1d0 1d0)) + (assert-false (stst-= 2d0 1d0)) + (assert-false (stst-= 0d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *double-float-nan* 1d0)) + (assert-false (stst-= 1d0 *double-float-nan*)) + (assert-false (stst-= *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-=3 1f0 1f0 1f0)) + (assert-false (stst-=3 1f0 1f0 0f0)) + (assert-false (stst-=3 0f0 1f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-=3 *single-float-nan* 1f0 1f0)) + (assert-false (stst-=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-=3 1f0 1f0 *single-float-nan*)))) + +(define-test nan-double.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (dtst-=3 1d0 1d0 1d0)) + (assert-false (dtst-=3 1d0 1d0 0d0)) + (assert-false (dtst-=3 0d0 1d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-=3 *double-float-nan* 1d0 1d0)) + (assert-false (dtst-=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-=3 1d0 1d0 *double-float-nan*)))) ===================================== 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/dd3bbe83eeb868486a31d4… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/dd3bbe83eeb868486a31d4… 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 deftransforms for >= for floats and rationals
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: dd3bbe83 by Raymond Toy at 2023-03-11T15:25:33-08:00 Add deftransforms for >= for floats and rationals Add a deftransform for >= (and <=) to hande when the two args are different types of floats, just like how < is done. Likewise, add a deftransform to handle comparisons between a float and rational. This is the same as how it's handled for < and friends. - - - - - 1 changed file: - src/compiler/float-tran.lisp Changes: ===================================== src/compiler/float-tran.lisp ===================================== @@ -568,7 +568,7 @@ (%deftransform x '(function (rational float) *) #'float-contagion-arg1) (%deftransform x '(function (float rational) *) #'float-contagion-arg2)) -(dolist (x '(= < > + * / -)) +(dolist (x '(= < > + * / - #+x86 <= #+x86 >=)) (%deftransform x '(function (single-float double-float) *) #'float-contagion-arg1) (%deftransform x '(function (double-float single-float) *) @@ -591,7 +591,11 @@ `(,',op x (float y x))))) (frob <) (frob >) - (frob =)) + (frob =) + #+x86 + (frob <=) + #+x86 + (frob >=)) ;; Convert (/ x n) to (* x (/ n)) when x is a float and n is a power ;; of two, because (/ n) can be reprsented exactly. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dd3bbe83eeb868486a31d46… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dd3bbe83eeb868486a31d46… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #175: Simplify branching in x86 float compare vops
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d51eb4b8 by Raymond Toy at 2023-03-12T19:05:39+00:00 Fix #175: Simplify branching in x86 float compare vops - - - - - a7237e1d by Raymond Toy at 2023-03-12T19:05:39+00:00 Merge branch 'issue-175-simplify-float-compare-vops' into 'master' Fix #175: Simplify branching in x86 float compare vops Closes #175 See merge request cmucl/cmucl!129 - - - - - 2 changed files: - src/compiler/x86/float-sse2.lisp - + tests/nan.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -945,7 +945,7 @@ (frob double ucomisd)) (macrolet - ((frob (op size inst yep nope) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -953,28 +953,52 @@ 'ea-for-df-desc))) (name (symbolicate op "/" size "-FLOAT")) (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) + (inherit (symbolicate size "-FLOAT-COMPARE")) + (reverse-args-p (eq op '<))) `(define-vop (,name ,inherit) + ;; The compare instructions take a reg argument for the + ;; first arg and reg or mem argument for the second. When + ;; inverting the arguments we must also invert which of + ;; the argument can be a mem argument. + (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg))) + (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg)))) (:translate ,op) (:info target not-p) (:generator 3 - (sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))) - (cond (not-p - (inst jmp :p target) - (inst jmp ,nope target)) - (t - (let ((not-lab (gen-label))) - (inst jmp :p not-lab) - (inst jmp ,yep target) - (emit-label not-lab))))))))) - (frob < single comiss :b :nb) - (frob > single comiss :a :na) - (frob < double comisd :b :nb) - (frob > double comisd :a :na)) + ;; Note: x < y is the same as y > x. We reverse the + ;; args to reduce the number of jump instructions + ;; needed. + ,(if reverse-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y))))) + ;; Consider the case of x > y. + ;; + ;; 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. + ;; + ;; For the case of x < y, we can use the equivalent y > + ;; x. Thus if we swap the args, the same logic applies. + (inst jmp (if (not not-p) :a :be) target)))))) + (frob > single comiss) + (frob > double comisd) + (frob < single comiss) + (frob < double comisd)) ;;;; Conversion: ===================================== tests/nan.lisp ===================================== @@ -0,0 +1,209 @@ +;;; 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 >) + (frob single-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)))) + +(define-test nan-single.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1f0 1f0)) + (assert-false (stst-= 2f0 1f0)) + (assert-false (stst-= 0f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *single-float-nan* 1f0)) + (assert-false (stst-= 1f0 *single-float-nan*)) + (assert-false (stst-= *single-float-nan* *single-float-nan*)))) + +(define-test nan-double.= + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-= 1d0 1d0)) + (assert-false (stst-= 2d0 1d0)) + (assert-false (stst-= 0d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-= *double-float-nan* 1d0)) + (assert-false (stst-= 1d0 *double-float-nan*)) + (assert-false (stst-= *double-float-nan* *double-float-nan*)))) + +(define-test nan-single.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (stst-=3 1f0 1f0 1f0)) + (assert-false (stst-=3 1f0 1f0 0f0)) + (assert-false (stst-=3 0f0 1f0 1f0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (stst-=3 *single-float-nan* 1f0 1f0)) + (assert-false (stst-=3 1f0 *single-float-nan* 1f0)) + (assert-false (stst-=3 1f0 1f0 *single-float-nan*)))) + +(define-test nan-double.=3 + (:tag :nan) + ;; Basic tests with regular numbers. + (assert-true (dtst-=3 1d0 1d0 1d0)) + (assert-false (dtst-=3 1d0 1d0 0d0)) + (assert-false (dtst-=3 0d0 1d0 1d0)) + ;; Tests with NaN, where = should fail. + (ext:with-float-traps-masked (:invalid) + (assert-false (dtst-=3 *double-float-nan* 1d0 1d0)) + (assert-false (dtst-=3 1d0 *double-float-nan* 1d0)) + (assert-false (dtst-=3 1d0 1d0 *double-float-nan*)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0038d3d9a489ffcf47bb15… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0038d3d9a489ffcf47bb15… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] Address review comments
by Raymond Toy (＠rtoy) 12 Mar '23

12 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 183e2ad0 by Raymond Toy at 2023-03-12T10:53:28-07:00 Address review comments - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -945,23 +945,7 @@ (frob double ucomisd)) (macrolet - ((gen-code (op sc-type inst ea) - ;; When the operation is >, the second arg (y) can be a - ;; register or a descriptor. When the operation is <, the args - ;; are swapped and we want to allow x to be a register or - ;; descriptor. - (if (eq op '<) - `(sc-case x - (,sc-type - (inst ,inst y x)) - (descriptor-reg - (inst ,inst y (,ea x)))) - `(sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))))) - (frob (op size inst) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -969,21 +953,32 @@ 'ea-for-df-desc))) (name (symbolicate op "/" size "-FLOAT")) (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) + (inherit (symbolicate size "-FLOAT-COMPARE")) + (reverse-args-p (eq op '<))) `(define-vop (,name ,inherit) - ;; When the operation is <, we want to rewrite x < y to y - ;; > x. In that case, we want to allow x to be in a - ;; descriptor. For >, y is allowed to be a descriptor. - ,@(when (eq op '<) - `((:args (x :scs (,sc-type descriptor-reg)) - (y :scs (,sc-type))))) + ;; The compare instructions take a reg argument for the + ;; first arg and reg or mem argument for the second. When + ;; inverting the arguments we must also invert which of + ;; the argument can be a mem argument. + (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg))) + (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg)))) (:translate ,op) (:info target not-p) (:generator 3 ;; Note: x < y is the same as y > x. We reverse the ;; args to reduce the number of jump instructions ;; needed. - (gen-code ,op ,sc-type ,inst ,ea) + ,(if reverse-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y))))) ;; Consider the case of x > y. ;; ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/183e2ad0845d1a7c12c4312… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/183e2ad0845d1a7c12c4312… 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 deftransform for >= and <= for integers.
by Raymond Toy (＠rtoy) 11 Mar '23

11 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 7ae79da6 by Raymond Toy at 2023-03-10T18:37:11-08:00 Add deftransform for >= and <= for integers. See the comments in the code for this change. I'm not sure this is what we want, but the testsuite passes now when it was previously failing. The failure had something to do with utf-16-be external format and there were warnings about `(>= foo 0)` having to use `generic->=` because the first type was `unsigned-byte`. This doesn't happen anymore. - - - - - 1 changed file: - src/compiler/srctran.lisp Changes: ===================================== src/compiler/srctran.lisp ===================================== @@ -3537,6 +3537,29 @@ (deftransform > ((x y) (real real) * :when :both) (ir1-transform-< y x x y '<)) + +#+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 + ;; comparisons with NaN. + ;; + ;; I'm not sure about this. The transformation is right, but + ;; perhaps what we really need is an ir-transform-<= to determine x + ;; <= y is definitely true or false, like for ir1-transform-<. + ;; + ;; For now this allows the testsuite to pass. Perhaps there's a bug + ;; in generic->=? + (deftransform <= ((x y) (integer integer) * :when :both) + ;; (<= 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)))) + + ;; Like IR1-TRANSFORM-< but for CHAR<. This is needed so that the ;; vops for base-char comparison with a constant gets used when the ;; first arg is the constant. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7ae79da601d4a56ba939417… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/7ae79da601d4a56ba939417… 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] Split the <= and >= macros from the others
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl Commits: 60c39207 by Raymond Toy at 2023-03-10T14:51:32-08:00 Split the <= and >= macros from the others When !129 lands we'll probably need to rework the vops for <= and >=, so let's split these out now, even if they're basically duplicating the code. The < and > vops are going to be replaced, and I have not thought exactly how these will fit with < and > yet. But since <= and >= don't quite fully work, keep them separate. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -972,12 +972,42 @@ (inst jmp ,yep target) (emit-label not-lab))))))))) (frob < single comiss :b :nb) - (frob <= single comiss :be :nbe) (frob > single comiss :a :na) - (frob >= single comiss :ae :nae) (frob < double comisd :b :nb) + (frob > double comisd :a :na)) + + + +(macrolet + ((frob (op size inst yep nope) + (let ((ea (ecase size + (single + 'ea-for-sf-desc) + (double + 'ea-for-df-desc))) + (name (symbolicate op "/" size "-FLOAT")) + (sc-type (symbolicate size "-REG")) + (inherit (symbolicate size "-FLOAT-COMPARE"))) + `(define-vop (,name ,inherit) + (:translate ,op) + (:info target not-p) + (:generator 3 + (sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))) + (cond (not-p + (inst jmp :p target) + (inst jmp ,nope target)) + (t + (let ((not-lab (gen-label))) + (inst jmp :p not-lab) + (inst jmp ,yep target) + (emit-label not-lab))))))))) + (frob <= single comiss :be :nbe) + (frob >= single comiss :ae :nae) (frob <= double comisd :be :nbe) - (frob > double comisd :a :na) (frob >= double comisd :ae :nae)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/60c3920704106eef2bc45ee… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/60c3920704106eef2bc45ee… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] Remove old macros for < and >.
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 1e7d1ddc by Raymond Toy at 2023-03-10T12:09:54-08:00 Remove old macros for < and >. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -944,87 +944,6 @@ (frob single ucomiss) (frob double ucomisd)) -#+nil -(macrolet - ((gen-code (swap-args-p sc-type inst ea) - (if swap-args-p - `(sc-case x - (,sc-type - (inst ,inst y x)) - (descriptor-reg - (inst ,inst y (,ea x)))) - `(sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))))) - (frob (op size inst swap-args-p) - (let ((ea (ecase size - (single - 'ea-for-sf-desc) - (double - 'ea-for-df-desc))) - (name (symbolicate op "/" size "-FLOAT")) - (sc-type (symbolicate size "-REG")) - (inherit (symbolicate size "-FLOAT-COMPARE"))) - `(define-vop (,name ,inherit) - (:translate ,op) - (:info target not-p) - (:generator 3 - (gen-code ,swap-args-p ,sc-type ,inst ,ea) - ;; 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 nil) - (frob > double comisd nil)) - -#+nil -(macrolet - ((gen-code (swap-args-p sc-type inst ea) - (if swap-args-p - `(sc-case x - (,sc-type - (inst ,inst y x)) - (descriptor-reg - (inst ,inst y (,ea x)))) - `(sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))))) - (frob (op size inst swap-args-p) - (let ((ea (ecase size - (single - 'ea-for-sf-desc) - (double - 'ea-for-df-desc))) - (name (symbolicate op "/" size "-FLOAT")) - (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-x) - (:generator 3 - ;; 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. - (gen-code ,swap-args-p ,sc-type ,inst ,ea) - (inst jmp (if (not not-p) :a :be) target)))))) - (frob < single comiss t) - (frob < double comisd t)) - (macrolet ((gen-code (op sc-type inst ea) ;; When the operation is >, the second arg (y) can be a View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/1e7d1ddcf57f37b66262f21… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/1e7d1ddcf57f37b66262f21… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] 3 commits: First cut at using a common macro for both > and <.
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 225335b5 by Raymond Toy at 2023-03-10T11:42:37-08:00 First cut at using a common macro for both > and <. This works, but I think it should be cleaned up a bit. - - - - - 1ef34feb by Raymond Toy at 2023-03-10T12:05:04-08:00 Refactor comparison vops into one macro to handle them all. Previously we had two macros: one for < and one for >. They are very similar so we combine them into one macro to handle both operations. - - - - - 552d91f3 by Raymond Toy at 2023-03-10T12:06:57-08:00 Remove unused swap-args-p arg to frob We can determine whether we want to swap or not from the operation, so we don't need this arg to frob anymore. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -944,8 +944,21 @@ (frob single ucomiss) (frob double ucomisd)) +#+nil (macrolet - ((frob (op size inst) + ((gen-code (swap-args-p sc-type inst ea) + (if swap-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))))) + (frob (op size inst swap-args-p) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -958,11 +971,7 @@ (:translate ,op) (:info target not-p) (:generator 3 - (sc-case y - (,sc-type - (inst ,inst x y)) - (descriptor-reg - (inst ,inst x (,ea y)))) + (gen-code ,swap-args-p ,sc-type ,inst ,ea) ;; 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, @@ -974,11 +983,24 @@ ;; 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)) + (frob > single comiss nil) + (frob > double comisd nil)) +#+nil (macrolet - ((frob (op size inst) + ((gen-code (swap-args-p sc-type inst ea) + (if swap-args-p + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))))) + (frob (op size inst swap-args-p) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -998,12 +1020,69 @@ ;; 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 ,inst y (,ea x)))) + (gen-code ,swap-args-p ,sc-type ,inst ,ea) + (inst jmp (if (not not-p) :a :be) target)))))) + (frob < single comiss t) + (frob < double comisd t)) + +(macrolet + ((gen-code (op sc-type inst ea) + ;; When the operation is >, the second arg (y) can be a + ;; register or a descriptor. When the operation is <, the args + ;; are swapped and we want to allow x to be a register or + ;; descriptor. + (if (eq op '<) + `(sc-case x + (,sc-type + (inst ,inst y x)) + (descriptor-reg + (inst ,inst y (,ea x)))) + `(sc-case y + (,sc-type + (inst ,inst x y)) + (descriptor-reg + (inst ,inst x (,ea y)))))) + (frob (op size inst) + (let ((ea (ecase size + (single + 'ea-for-sf-desc) + (double + 'ea-for-df-desc))) + (name (symbolicate op "/" size "-FLOAT")) + (sc-type (symbolicate size "-REG")) + (inherit (symbolicate size "-FLOAT-COMPARE"))) + `(define-vop (,name ,inherit) + ;; When the operation is <, we want to rewrite x < y to y + ;; > x. In that case, we want to allow x to be in a + ;; descriptor. For >, y is allowed to be a descriptor. + ,@(when (eq op '<) + `((:args (x :scs (,sc-type descriptor-reg)) + (y :scs (,sc-type))))) + (:translate ,op) + (:info target not-p) + (:generator 3 + ;; Note: x < y is the same as y > x. We reverse the + ;; args to reduce the number of jump instructions + ;; needed. + (gen-code ,op ,sc-type ,inst ,ea) + ;; Consider the case of x > y. + ;; + ;; 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. + ;; + ;; For the case of x < y, we can use the equivalent y > + ;; x. Thus if we swap the args, the same logic applies. (inst jmp (if (not not-p) :a :be) target)))))) + (frob > single comiss) + (frob > double comisd) (frob < single comiss) (frob < double comisd)) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5ad9f2d825f2e986e04fa2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5ad9f2d825f2e986e04fa2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-175-simplify-float-compare-vops] Remove unused mover arg from the macro for < comparisons
by Raymond Toy (＠rtoy) 10 Mar '23

10 Mar '23

Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl Commits: 5ad9f2d8 by Raymond Toy at 2023-03-10T09:25:46-08:00 Remove unused mover arg from the macro for < comparisons We don't need the mover arg anymore since we've changed x to be a descriptor instead of y. - - - - - 1 changed file: - src/compiler/x86/float-sse2.lisp Changes: ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -978,7 +978,7 @@ (frob > double comisd)) (macrolet - ((frob (op size inst mover) + ((frob (op size inst) (let ((ea (ecase size (single 'ea-for-sf-desc) @@ -1004,8 +1004,8 @@ (descriptor-reg (inst ,inst y (,ea x)))) (inst jmp (if (not not-p) :a :be) target)))))) - (frob < single comiss movss) - (frob < double comisd movsd)) + (frob < single comiss) + (frob < double comisd)) ;;;; Conversion: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5ad9f2d825f2e986e04fa2d… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5ad9f2d825f2e986e04fa2d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

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

10 Mar '23

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

1 0

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

10 Mar '23

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

1 0

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

09 Mar '23

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

1 0

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

09 Mar '23

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

1 0

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

09 Mar '23

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

1 0

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

08 Mar '23

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

1 0

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

08 Mar '23

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

1 0

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

08 Mar '23

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

1 0

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

08 Mar '23

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

1 0

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

08 Mar '23

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

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs March 2023