Raymond Toy pushed to branch issue-156-take-2-nan-comparison at cmucl / cmucl

Commits:

5 changed files:

Changes:

  • src/code/filesys.lisp
    ... ... @@ -1122,11 +1122,7 @@ optionally keeping some of the most recent old versions."
    1122 1122 
         (let ((results nil))
    1123 1123 
           (enumerate-search-list
    1124 1124 
     	  (pathname (merge-pathnames pathname
    1125 
    -				     (make-pathname :name :wild
    1126 
    -						    :type :wild
    1127 
    -						    :version :wild
    1128 
    -						    :defaults *default-pathname-defaults*)
    1129 
    -				     :wild))
    1125 
    +				     *default-pathname-defaults*))
    1130 1126 
     	(enumerate-matches (name pathname nil :follow-links follow-links)
    1131 1127 
     	  (when (or all
    1132 1128 
     		    (let ((slash (position #\/ name :from-end t)))

  • src/compiler/x86/float-sse2.lisp
    ... ... @@ -945,7 +945,7 @@
    945 945 
       (frob double ucomisd))
    946 946
    947 947 
     (macrolet
    948 
    -    ((frob (op size inst yep nope)
    948 
    +    ((frob (op size inst)
    949 949 
            (let ((ea (ecase size
    950 950 
     		   (single
    951 951 
     		    'ea-for-sf-desc)
    ... ... @@ -953,28 +953,52 @@
    953 953 
     		    'ea-for-df-desc)))
    954 954 
     	     (name (symbolicate op "/" size "-FLOAT"))
    955 955 
     	     (sc-type (symbolicate size "-REG"))
    956 
    -	     (inherit (symbolicate size "-FLOAT-COMPARE")))
    956 
    +	     (inherit (symbolicate size "-FLOAT-COMPARE"))
    957 
    +	     (reverse-args-p (eq op '<)))
    957 958 
     	 `(define-vop (,name ,inherit)
    959 
    +	    ;; The compare instructions take a reg argument for the
    960 
    +	    ;; first arg and reg or mem argument for the second.  When
    961 
    +	    ;; inverting the arguments we must also invert which of
    962 
    +	    ;; the argument can be a mem argument.
    963 
    +	    (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg)))
    964 
    +		   (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg))))
    958 965 
     	    (:translate ,op)
    959 966 
     	    (:info target not-p)
    960 967 
     	    (:generator 3
    961 
    -	      (sc-case y
    962 
    -		(,sc-type
    963 
    -		 (inst ,inst x y))
    964 
    -		(descriptor-reg
    965 
    -		 (inst ,inst x (,ea y))))
    966 
    -	      (cond (not-p
    967 
    -		     (inst jmp :p target)
    968 
    -		     (inst jmp ,nope target))
    969 
    -		    (t
    970 
    -		     (let ((not-lab (gen-label)))
    971 
    -		       (inst jmp :p not-lab)
    972 
    -		       (inst jmp ,yep target)
    973 
    -		       (emit-label not-lab)))))))))
    974 
    -  (frob < single comiss :b :nb)
    975 
    -  (frob > single comiss :a :na)
    976 
    -  (frob < double comisd :b :nb)
    977 
    -  (frob > double comisd :a :na))
    968 
    +	      ;; Note: x < y is the same as y > x.  We reverse the
    969 
    +	      ;; args to reduce the number of jump instructions
    970 
    +	      ;; needed.
    971 
    +	      ,(if reverse-args-p
    972 
    +		   `(sc-case x
    973 
    +		      (,sc-type
    974 
    +		       (inst ,inst y x))
    975 
    +		      (descriptor-reg
    976 
    +		       (inst ,inst y (,ea x))))
    977 
    +		   `(sc-case y
    978 
    +		      (,sc-type
    979 
    +		       (inst ,inst x y))
    980 
    +		      (descriptor-reg
    981 
    +		       (inst ,inst x (,ea y)))))
    982 
    +	      ;; Consider the case of x > y.
    983 
    +	      ;;
    984 
    +	      ;; When a NaN occurs, comis sets ZF, PF, and CF = 1.  In
    985 
    +	      ;; the normal case (not-p false), we want to jump to the
    986 
    +	      ;; target when x > y.  This happens when CF = 0.  Hence,
    987 
    +	      ;; we won't jump to the target when there's a NaN, as
    988 
    +	      ;; desired.
    989 
    +	      ;;
    990 
    +	      ;; For the not-p case, we want to jump to target when x
    991 
    +	      ;; <= y.  This means CF = 1 or ZF = 1.  But NaN sets
    992 
    +	      ;; these bits too, so we jump to the target for NaN or x
    993 
    +	      ;; <= y, as desired.
    994 
    +	      ;;
    995 
    +	      ;; For the case of x < y, we can use the equivalent y >
    996 
    +	      ;; x.  Thus if we swap the args, the same logic applies.
    997 
    +	      (inst jmp (if (not not-p) :a :be) target))))))
    998 
    +  (frob > single comiss)
    999 
    +  (frob > double comisd)
    1000 
    +  (frob < single comiss)
    1001 
    +  (frob < double comisd))
    978 1002
    979 1003
    980 1004

  • src/general-info/release-21e.md
    ... ... @@ -65,7 +65,17 @@ public domain.
    65 65 
         * ~~#142~~ `(random 0)` signals incorrect error
    66 66 
         * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream`
    67 67 
         * ~~#149~~ Call setlocale(3C) on startup
    68 
    +    * ~~#150~~ Add aliases for external format cp949 and euckr
    69 
    +    * ~~#151~~ Change `*default-external-format*` to `:utf-8`.
    68 70 
         * ~~#155~~ Wrap help strings neatly
    71 
    +    * ~~#157~~ `(directory "foo/**/")` only returns directories now
    72 
    +    * ~~#163~~ Add commandline option `-version` and `--version` to get lisp version
    73 
    +    * ~~#165~~ Avoid inserting NIL into simple `LOOP` from `FORMAT`
    74 
    +    * ~~#166~~ Fix incorect type declaration for exponent from `integer-decode-float`
    75 
    +    * ~~#167~~ Lowe bound for `decode-float-exponent` type was off by one.
    76 
    +    * ~~#168~~ Don't use negated forms for jmp instructions when possible
    77 
    +    * ~~#169~~ Add pprinter for `define-vop` and `sc-case`
    78 
    +    * ~~#173~~ Add pprinter for `define-assembly-routine`
    69 79 
       * Other changes:
    70 80 
       * Improvements to the PCL implementation of CLOS:
    71 81 
       * Changes to building procedure:

  • tests/nan.lisp
    1 
    +;;; Tests for NaN comparisons.
    2 
    +(defpackage :nan-tests
    3 
    +  (:use :cl :lisp-unit))
    4 
    +
    5 
    +(in-package :nan-tests)
    6 
    +
    7 
    +(defparameter *single-float-nan*
    8 
    +  (ext:with-float-traps-masked (:invalid :divide-by-zero)
    9 
    +    (/ 0d0 0d0)))
    10 
    +
    11 
    +(defparameter *double-float-nan*
    12 
    +  (ext:with-float-traps-masked (:invalid :divide-by-zero)
    13 
    +    (/ 0d0 0d0)))
    14 
    +
    15 
    +
    16 
    +(eval-when (:compile-toplevel :load-toplevel :execute)
    17 
    +  (macrolet
    18 
    +      ((frob (ntype op)
    19 
    +	 (let* ((name (ext:symbolicate (if (eq ntype 'single-float)
    20 
    +					   "S"
    21 
    +					   "D")
    22 
    +				       "TST-" op))
    23 
    +		(name3 (ext:symbolicate name "3")))
    24 
    +
    25 
    +	   `(progn
    26 
    +	      (defun ,name (x y)
    27 
    +		(declare (,ntype x y))
    28 
    +		(,op x y))
    29 
    +	      (defun ,name3 (x y z)
    30 
    +		(declare (,ntype x y z))
    31 
    +		(,op x y z))))))
    32 
    +    (frob single-float <)
    33 
    +    (frob single-float >)
    34 
    +    (frob double-float <)
    35 
    +    (frob double-float >)
    36 
    +    (frob single-float =)
    37 
    +    (frob double-float =)))
    38 
    +
    39 
    +(define-test nan-single.<
    40 
    +    (:tag :nan)
    41 
    +  ;; First just make sure it works with regular single-floats
    42 
    +  (assert-true (stst-< 1f0 2f0))
    43 
    +  (assert-false (stst-< 1f0 1f0))
    44 
    +  (assert-false (stst-< 1f0 0f0))
    45 
    +  ;; Now try NaN.  All comparisons should be false.
    46 
    +  (ext:with-float-traps-masked (:invalid)
    47 
    +    (assert-false (stst-< *single-float-nan* 1f0))
    48 
    +    (assert-false (stst-< 1f0 *single-float-nan*))
    49 
    +    (assert-false (stst-< *single-float-nan* *single-float-nan*))))
    50 
    +
    51 
    +(define-test nan-double.<
    52 
    +    (:tag :nan)
    53 
    +  ;; First just make sure it works with regular single-floats
    54 
    +  (assert-true (dtst-< 1d0 2d0))
    55 
    +  (assert-false (dtst-< 1d0 1d0))
    56 
    +  (assert-false (dtst-< 1d0 0d0))
    57 
    +  ;; Now try NaN.  All comparisons should be false.
    58 
    +  (ext:with-float-traps-masked (:invalid)
    59 
    +    (assert-false (dtst-< *double-float-nan* 1d0))
    60 
    +    (assert-false (dtst-< 1d0 *double-float-nan*))
    61 
    +    (assert-false (dtst-< *double-float-nan* *double-float-nan*))))
    62 
    +
    63 
    +(define-test nan-single.>
    64 
    +    (:tag :nan)
    65 
    +  ;; First just make sure it works with regular single-floats
    66 
    +  (assert-true (stst-> 2f0 1f0))
    67 
    +  (assert-false (stst-> 1f0 1f0))
    68 
    +  (assert-false (stst-> 0f0 1f0))
    69 
    +  ;; Now try NaN.  All comparisons should be false.
    70 
    +  (ext:with-float-traps-masked (:invalid)
    71 
    +    (assert-false (stst-> *single-float-nan* 1f0))
    72 
    +    (assert-false (stst-> 1f0 *single-float-nan*))
    73 
    +    (assert-false (stst-> *single-float-nan* *single-float-nan*))))
    74 
    +
    75 
    +(define-test nan-double.>
    76 
    +    (:tag :nan)
    77 
    +  ;; First just make sure it works with regular single-floats
    78 
    +  (assert-true (dtst-> 2d0 1d0))
    79 
    +  (assert-false (dtst-> 1d0 1d0))
    80 
    +  (assert-false (dtst-> 0d0 1d0))
    81 
    +  ;; Now try NaN.  All comparisons should be false.
    82 
    +  (ext:with-float-traps-masked (:invalid)
    83 
    +    (assert-false (dtst-> *double-float-nan* 1d0))
    84 
    +    (assert-false (dtst-> 1d0 *double-float-nan*))
    85 
    +    (assert-false (dtst-> *double-float-nan* *double-float-nan*))))
    86 
    +
    87 
    +(define-test nan-single.<3
    88 
    +    (:tag :nan)
    89 
    +  ;; First just make sure it works with regular single-floats
    90 
    +  (assert-true (stst-<3 1f0 2f0 3f0))
    91 
    +  (assert-false (stst-<3 1f0 2f0 2f0))
    92 
    +  (assert-false (stst-<3 1f0 1f0 2f0))
    93 
    +  (assert-false (stst-<3 1f0 0f0 2f0))
    94 
    +  ;; Now try NaN.  Currently we can only test if there's NaN in the
    95 
    +  ;; first two args.  When NaN is the last arg, we return the
    96 
    +  ;; incorrect value because of how multi-compare converts multiple
    97 
    +  ;; args into paris of comparisons.
    98 
    +  ;;
    99 
    +  ;; When that is fixed, we can add additional tests.  Nevertheless,
    100 
    +  ;; this is useful because it tests the not-p case of the vops.
    101 
    +  (ext:with-float-traps-masked (:invalid)
    102 
    +    (assert-false (stst-<3 *single-float-nan* 2f0 3f0))
    103 
    +    (assert-false (stst-<3 1f0 *single-float-nan* 3f0))
    104 
    +    (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0))))
    105 
    +
    106 
    +(define-test nan-double.<3
    107 
    +    (:tag :nan)
    108 
    +  ;; First just make sure it works with regular double-floats
    109 
    +  (assert-true (dtst-<3 1d0 2d0 3d0))
    110 
    +  (assert-false (dtst-<3 1d0 2d0 2d0))
    111 
    +  (assert-false (dtst-<3 1d0 1d0 2d0))
    112 
    +  (assert-false (dtst-<3 1d0 0d0 2d0))
    113 
    +  ;; Now try NaN.  Currently we can only test if there's NaN in the
    114 
    +  ;; first two args.  When NaN is the last arg, we return the
    115 
    +  ;; incorrect value because of how multi-compare converts multiple
    116 
    +  ;; args into paris of comparisons.
    117 
    +  ;;
    118 
    +  ;; When that is fixed, we can add additional tests.  Nevertheless,
    119 
    +  ;; this is useful because it tests the not-p case of the vops.
    120 
    +  (ext:with-float-traps-masked (:invalid)
    121 
    +    (assert-false (dtst-<3 *double-float-nan* 2d0 3d0))
    122 
    +    (assert-false (dtst-<3 1d0 *double-float-nan* 3d0))
    123 
    +    (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0))))
    124 
    +
    125 
    +(define-test nan-single.>3
    126 
    +    (:tag :nan)
    127 
    +  ;; First just make sure it works with regular single-floats
    128 
    +  (assert-true (stst->3 3f0 2f0 1f0))
    129 
    +  (assert-false (stst->3 3f0 1f0 1f0))
    130 
    +  (assert-false (stst->3 2f0 2f0 1f0))
    131 
    +  (assert-false (stst->3 0f0 2f0 1f0))
    132 
    +  ;; Now try NaN.  Currently we can only test if there's NaN in the
    133 
    +  ;; first two args.  When NaN is the last arg, we return the
    134 
    +  ;; incorrect value because of how multi-compare converts multiple
    135 
    +  ;; args into paris of comparisons.
    136 
    +  ;;
    137 
    +  ;; When that is fixed, we can add additional tests.  Nevertheless,
    138 
    +  ;; this is useful because it tests the not-p case of the vops.
    139 
    +  (ext:with-float-traps-masked (:invalid)
    140 
    +    (assert-false (stst->3 *single-float-nan* 2f0 3f0))
    141 
    +    (assert-false (stst->3 1f0 *single-float-nan* 3f0))
    142 
    +    (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0))))
    143 
    +
    144 
    +(define-test nan-double.>3
    145 
    +    (:tag :nan)
    146 
    +  ;; First just make sure it works with regular double-floats
    147 
    +  (assert-true (dtst->3 3d0 2d0 1d0))
    148 
    +  (assert-false (dtst->3 3d0 1d0 1d0))
    149 
    +  (assert-false (dtst->3 2d0 2d0 1d0))
    150 
    +  (assert-false (dtst->3 0d0 2d0 1d0))
    151 
    +  ;; Now try NaN.  Currently we can only test if there's NaN in the
    152 
    +  ;; first two args.  When NaN is the last arg, we return the
    153 
    +  ;; incorrect value because of how multi-compare converts multiple
    154 
    +  ;; args into paris of comparisons.
    155 
    +  ;;
    156 
    +  ;; When that is fixed, we can add additional tests.  Nevertheless,
    157 
    +  ;; this is useful because it tests the not-p case of the vops.
    158 
    +  (ext:with-float-traps-masked (:invalid)
    159 
    +    (assert-false (dtst->3 *double-float-nan* 2d0 3d0))
    160 
    +    (assert-false (dtst->3 1d0 *double-float-nan* 3d0))
    161 
    +    (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0))))
    162 
    +
    163 
    +(define-test nan-single.=
    164 
    +    (:tag :nan)
    165 
    +  ;; Basic tests with regular numbers.
    166 
    +  (assert-true (stst-= 1f0 1f0))
    167 
    +  (assert-false (stst-= 2f0 1f0))
    168 
    +  (assert-false (stst-= 0f0 1f0))
    169 
    +  ;; Tests with NaN, where = should fail.
    170 
    +  (ext:with-float-traps-masked (:invalid)
    171 
    +    (assert-false (stst-= *single-float-nan* 1f0))
    172 
    +    (assert-false (stst-= 1f0 *single-float-nan*))
    173 
    +    (assert-false (stst-= *single-float-nan* *single-float-nan*))))
    174 
    +
    175 
    +(define-test nan-double.=
    176 
    +    (:tag :nan)
    177 
    +  ;; Basic tests with regular numbers.
    178 
    +  (assert-true (stst-= 1d0 1d0))
    179 
    +  (assert-false (stst-= 2d0 1d0))
    180 
    +  (assert-false (stst-= 0d0 1d0))
    181 
    +  ;; Tests with NaN, where = should fail.
    182 
    +  (ext:with-float-traps-masked (:invalid)
    183 
    +    (assert-false (stst-= *double-float-nan* 1d0))
    184 
    +    (assert-false (stst-= 1d0 *double-float-nan*))
    185 
    +    (assert-false (stst-= *double-float-nan* *double-float-nan*))))
    186 
    +
    187 
    +(define-test nan-single.=3
    188 
    +    (:tag :nan)
    189 
    +  ;; Basic tests with regular numbers.
    190 
    +  (assert-true (stst-=3 1f0 1f0 1f0))
    191 
    +  (assert-false (stst-=3 1f0 1f0 0f0))
    192 
    +  (assert-false (stst-=3 0f0 1f0 1f0))
    193 
    +  ;; Tests with NaN, where = should fail.
    194 
    +  (ext:with-float-traps-masked (:invalid)
    195 
    +    (assert-false (stst-=3 *single-float-nan* 1f0 1f0))
    196 
    +    (assert-false (stst-=3 1f0 *single-float-nan* 1f0))
    197 
    +    (assert-false (stst-=3 1f0 1f0 *single-float-nan*))))
    198 
    +
    199 
    +(define-test nan-double.=3
    200 
    +    (:tag :nan)
    201 
    +  ;; Basic tests with regular numbers.
    202 
    +  (assert-true (dtst-=3 1d0 1d0 1d0))
    203 
    +  (assert-false (dtst-=3 1d0 1d0 0d0))
    204 
    +  (assert-false (dtst-=3 0d0 1d0 1d0))
    205 
    +  ;; Tests with NaN, where = should fail.
    206 
    +  (ext:with-float-traps-masked (:invalid)
    207 
    +    (assert-false (dtst-=3 *double-float-nan* 1d0 1d0))
    208 
    +    (assert-false (dtst-=3 1d0 *double-float-nan* 1d0))
    209 
    +    (assert-false (dtst-=3 1d0 1d0 *double-float-nan*))))

  • tests/pathname.lisp
    ... ... @@ -72,4 +72,14 @@
    72 72 
     			       :directory '(:absolute "system2" "module4")
    73 73 
     			       :name nil :type nil)
    74 74 
     		(parse-namestring "ASDFTEST:system2;module4;"))))
    75 
    -
    75 
    +
    76 
    +
    77 
    +
    78 
    +(define-test directory.dirs
    79 
    +  (let ((files (directory "src/assembly/**/")))
    80 
    +    ;; Verify that we only returned directories
    81 
    +    (loop for f in files
    82 
    +	  for name = (pathname-name f)
    83 
    +	  and type = (pathname-type f)
    84 
    +	  do
    85 
    +	     (assert-true (and (null name) (null type)) f))))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help