Raymond Toy pushed to branch issue-120-software-type-in-c 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 - - - - - 6b28a906 by Raymond Toy at 2023-03-15T14:06:28+00:00 Fix #177: Add pprinter for deftransform and defoptimizer

- - - - - 75e0b7e3 by Raymond Toy at 2023-03-15T14:06:31+00:00 Merge branch 'issue-177-pprint-deftransform' into 'master'

Fix #177: Add pprinter for deftransform and defoptimizer

Closes #177

See merge request cmucl/cmucl!132 - - - - - 6b3ceb28 by Raymond Toy at 2023-03-16T17:08:32+00:00 Fix #172: Declare pathname-match-p to return NIL or a pathname

- - - - - 0b9e41a4 by Raymond Toy at 2023-03-16T17:08:35+00:00 Merge branch 'issue-172-pathname-match-p-return-type' into 'master'

Fix #172: Declare pathname-match-p to return NIL or a pathname

Closes #172

See merge request cmucl/cmucl!131 - - - - - b329b385 by Raymond Toy at 2023-03-16T10:18:39-07:00 Fix some typos

- - - - - 4b75969a by Raymond Toy at 2023-03-16T10:42:53-07:00 Address #120: Move misc doc stuff to misc-doc.lisp

As mentioned in https://gitlab.common-lisp.net/cmucl/cmucl/-/merge_requests/93#note_11267, this moves some parts of misc.lisp to misc-doc.lisp that is needed to implement #120.

- - - - - 6751cc90 by Raymond Toy at 2023-03-16T12:18:09-07:00 Add new file misc-doc.lisp

Forgot to chech this in.

- - - - - e7fc70da by Raymond Toy at 2023-03-22T10:42:08-07:00 Merge branch 'issue-120-move-misc-first' into issue-120-software-type-in-c

- - - - -

8 changed files:

- src/code/filesys.lisp - src/code/misc.lisp - src/code/pprint.lisp - src/compiler/fndb.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/code/misc.lisp ===================================== @@ -30,109 +30,6 @@

(in-package "LISP")

-;;; cobbled from stuff in describe.lisp. -(defun function-doc (x) - (let ((name - (case (kernel:get-type x) - (#.vm:closure-header-type - (kernel:%function-name (%closure-function x))) - ((#.vm:function-header-type #.vm:closure-function-header-type) - (kernel:%function-name x)) - (#.vm:funcallable-instance-header-type - (typecase x - (kernel:byte-function - (c::byte-function-name x)) - (kernel:byte-closure - (c::byte-function-name (byte-closure-function x))) - (eval:interpreted-function - (multiple-value-bind - (exp closure-p dname) - (eval:interpreted-function-lambda-expression x) - (declare (ignore exp closure-p)) - dname)) - (t ;; funcallable-instance - (kernel:%function-name - (kernel:funcallable-instance-function x)))))))) - (when (and name (typep name '(or symbol cons))) - (values (info function documentation name))))) - -(defun documentation (x doc-type) - "Returns the documentation string of Doc-Type for X, or NIL if - none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE, - SETF, and T." - (flet (;; CMUCL random-documentation. - (try-cmucl-random-doc (x doc-type) - (declare (symbol doc-type)) - (cdr (assoc doc-type - (values (info random-documentation stuff x)))))) - (case doc-type - (variable - (typecase x - (symbol (values (info variable documentation x))))) - (function - (typecase x - (symbol (values (info function documentation x))) - (function (function-doc x)) - (list ;; Must be '(setf symbol) - (values (info function documentation (cadr x)))))) - (structure - (typecase x - (symbol (when (eq (info type kind x) :instance) - (values (info type documentation x)))))) - (type - (typecase x - (kernel::structure-class (values (info type documentation (%class-name x)))) - (t (and (typep x 'symbol) (values (info type documentation x)))))) - (setf (info setf documentation x)) - ((t) - (typecase x - (function (function-doc x)) - (package (package-doc-string x)) - (kernel::structure-class (values (info type documentation (%class-name x)))) - (symbol (try-cmucl-random-doc x doc-type)))) - (t - (typecase x - (symbol (try-cmucl-random-doc x doc-type))))))) - -(defun (setf documentation) (string name doc-type) - #-no-docstrings - (case doc-type - (variable - #+nil - (when string - (%primitive print "Set variable text domain") - (%primitive print (symbol-name name)) - (%primitive print intl::*default-domain*)) - (setf (info variable textdomain name) intl::*default-domain*) - (setf (info variable documentation name) string)) - (function - #+nil - (when intl::*default-domain* - (%primitive print "Set function text domain") - (%primitive print (symbol-name name)) - (%primitive print intl::*default-domain*)) - (setf (info function textdomain name) intl::*default-domain*) - (setf (info function documentation name) string)) - (structure - (unless (eq (info type kind name) :instance) - (error (intl:gettext "~S is not the name of a structure type.") name)) - (setf (info type textdomain name) intl::*default-domain*) - (setf (info type documentation name) string)) - (type - (setf (info type textdomain name) intl::*default-domain*) - (setf (info type documentation name) string)) - (setf - (setf (info setf textdomain name) intl::*default-domain*) - (setf (info setf documentation name) string)) - (t - (let ((pair (assoc doc-type (info random-documentation stuff name)))) - (if pair - (setf (cdr pair) string) - (push (cons doc-type string) - (info random-documentation stuff name)))))) - string) - - ;;; Register various Lisp features #+sparc-v7 (sys:register-lisp-runtime-feature :sparc-v7)

===================================== src/code/pprint.lisp ===================================== @@ -2074,7 +2074,9 @@ When annotations are present, invoke them at the right positions." (lisp::with-array-data pprint-with-like) (c:define-vop pprint-define-vop) (c:sc-case pprint-sc-case) - (c:define-assembly-routine pprint-define-assembly))) + (c:define-assembly-routine pprint-define-assembly) + (c:deftransform pprint-defun) + (c:defoptimizer pprint-defun)))

(defun pprint-init () (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))

===================================== src/compiler/fndb.lisp ===================================== @@ -1027,7 +1027,10 @@ :type :version)) boolean (flushable)) -(defknown pathname-match-p (pathnamelike pathnamelike) boolean +(defknown pathname-match-p (pathnamelike pathnamelike) + ;; CLHS says the return type is a generalized boolean. We currently + ;; return a pathname on a match. + (or null pathname) (flushable)) (defknown translate-pathname (pathnamelike pathnamelike pathnamelike &key) pathname

===================================== src/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:

===================================== src/general-info/release-21e.md ===================================== @@ -57,7 +57,7 @@ public domain. * ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid. * ~~#128~~ `QUIT` accepts an exit code * ~~#130~~ Move file-author to C - * ~~#132~~ Ansi test `RENAME-FILE.1` no fails + * ~~#132~~ Ansi test `RENAME-FILE.1` no longer fails * ~~#134~~ Handle the case of `(expt complex complex-rational)` * ~~#136~~ `ensure-directories-exist` should return the given pathspec * #139 `*default-external-format*` defaults to `:utf-8`; add alias for `:locale` external format @@ -66,7 +66,18 @@ 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 command-line option `-version` and `--version` to get lisp version + * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT` + * ~~#166~~ Fix incorrect type declaration for exponent from `integer-decode-float` + * ~~#167~~ Low bound for `decode-float-exponent` type was off by one. + * ~~#168~~ Don't use negated forms for jmp instructions when possible + * ~~#169~~ Add pprinter for `define-vop` and `sc-case` + * ~~#172~~ Declare `pathname-match-p` as returning `nil` or `pathname`. + * ~~#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/6e59b0b21eabe3bf27347bf...