Raymond Toy pushed to branch issue-456-more-accurate-complex-div at cmucl / cmucl

Commits:

7 changed files:

Changes:

  • bin/run-unit-tests.sh
    ... ... @@ -9,6 +9,8 @@ usage() {
    9 9 
         echo "run-tests.sh [-?h] [-d test-dir] [-l lisp] [tests]"
    10 10 
         echo "    -d test-dir  Directory containing the unit test files"
    11 11 
         echo "    -l lisp      Lisp to use for the tests; defaults to lisp"
    12 
    +    echo "    -p           Skip package-local-nicknames test"
    13 
    +    echo "    -u           Skip lisp-unit tests"
    12 14 
         echo "    -?           This help message"
    13 15 
         echo "    -h           This help message"
    14 16 
         echo ""
    ... ... @@ -25,11 +27,13 @@ usage() {
    25 27 
     }
    26 28
    27 29 
     LISP=lisp
    28 
    -while getopts "h?l:d:" arg
    30 
    +while getopts "puh?l:d:" arg
    29 31 
     do
    30 32 
         case $arg in
    31 33 
           l) LISP=$OPTARG ;;
    32 34 
           d) TESTDIR=$OPTARG ;;
    35 
    +      p) SKIP_PLN=yes ;;
    36 
    +      u) SKIP_UNIT=yes ;;
    33 37 
           h|\?) usage ;;
    34 38 
         esac
    35 39 
     done
    ... ... @@ -43,12 +47,19 @@ mkdir test-tmp
    43 47 
     ln -s /bin/ls test-tmp/ls-link
    44 48
    45 49 
     # Set the timestamps on 64-bit-timestamp-2038.txt and
    46 
    -# 64-bit-timestamp-2106.txt.  The time for the first file is a
    47 
    -# negative value for a 32-bit time_t.  The second file won't fit in a
    48 
    -# 32-bit time_t value.  It's ok if this doesn't work in general, as
    49 
    -# long as it works on Linux for the stat test in tests/os.lisp.
    50 
    -touch -d "1 April 2038" tests/resources/64-bit-timestamp-2038.txt
    51 
    -touch -d "1 April 2106" tests/resources/64-bit-timestamp-2106.txt
    50 
    +# 64-bit-timestamp-2106.txt, but only for OSes where we know this
    51 
    +# works.  (This is so we don't an annoying error message from touch
    52 
    +# that doesn't accept the -d option, like MacOS 10.13.)  The time for
    53 
    +# the first file is a negative value for a 32-bit time_t.  The second
    54 
    +# file won't fit in a 32-bit time_t value.  It's ok if this doesn't
    55 
    +# work in general, as long as it works on Linux for the stat test in
    56 
    +# tests/os.lisp.
    57 
    +case `uname -s` in
    58 
    +    Linux)
    59 
    +	touch -d "1 April 2038" tests/resources/64-bit-timestamp-2038.txt
    60 
    +	touch -d "1 April 2106" tests/resources/64-bit-timestamp-2106.txt
    61 
    +	;;
    62 
    +esac
    52 63
    53 64 
     # Cleanup temp files and directories that we created during testing.
    54 65 
     function cleanup {
    ... ... @@ -69,39 +80,47 @@ fi
    69 80 
     # gcc since clang isn't always available.
    70 81 
     (cd "$TESTDIR" || exit 1 ; gcc -m32 -O3 -c test-return.c)
    71 82
    72 
    -if [ $# -eq 0 ]; then
    73 
    -    # Test directory arg for run-all-tests if a non-default
    74 
    -    # No args so run all the tests
    75 
    -    $LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(cmucl-test-runner:run-all-tests ${TESTDIRARG})"
    76 
    -else
    77 
    -    # Run selected files.  Convert each file name to uppercase and append "-TESTS"
    78 
    -    result=""
    79 
    -    for f in "$@"
    80 
    -    do
    81 
    -	new=$(echo "$f" | tr '[:lower:]' '[:upper:]')
    82 
    -        result="$result "\"$new-TESTS\"
    83 
    -    done
    84 
    -    $LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test $result))"
    83 
    +if [ "$SKIP_UNIT" != "yes" ]; then
    84 
    +    if [ $# -eq 0 ]; then
    85 
    +	# Test directory arg for run-all-tests if a non-default
    86 
    +	# No args so run all the tests
    87 
    +	$LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(cmucl-test-runner:run-all-tests ${TESTDIRARG})" ||
    88 
    +	    exit 1
    89 
    +    else
    90 
    +	# Run selected files.  Convert each file name to uppercase and append "-TESTS"
    91 
    +	result=""
    92 
    +	for f in "$@"
    93 
    +	do
    94 
    +	    new=$(echo "$f" | tr '[:lower:]' '[:upper:]')
    95 
    +            result="$result "\"$new-TESTS\"
    96 
    +	done
    97 
    +	# Run unit tests.  Exits with a non-zero code if there's a failure.
    98 
    +
    99 
    +	$LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test $result))" ||
    100 
    +	    exit 1
    101 
    +    fi
    85 102 
     fi
    86 103
    87 104 
     ## Now run tests for trivial-package-local-nicknames
    88 
    -REPO=trivial-package-local-nicknames
    89 
    -BRANCH=cmucl-updates
    105 
    +if [ "$SKIP_PLN" != "yes" ]; then
    106 
    +    REPO=trivial-package-local-nicknames
    107 
    +    BRANCH=cmucl-updates
    90 108
    91 
    -set -x
    92 
    -if [ -d ../$REPO ]; then
    93 
    -    (cd ../$REPO || exit 1; git stash; git checkout $BRANCH; git pull --rebase)
    94 
    -else
    95 
    -    (cd ..; git clone https://gitlab.common-lisp.net/cmucl/$REPO.git)
    96 
    -fi
    109 
    +    set -x
    110 
    +    if [ -d ../$REPO ]; then
    111 
    +	(cd ../$REPO || exit 1; git stash; git checkout $BRANCH; git pull --rebase)
    112 
    +    else
    113 
    +	(cd ..; git clone https://gitlab.common-lisp.net/cmucl/$REPO.git)
    114 
    +    fi
    97 115
    98 
    -LISP=$PWD/$LISP
    99 
    -cd ../$REPO || exit 1
    100 
    -git checkout $BRANCH
    116 
    +    LISP=$PWD/$LISP
    117 
    +    cd ../$REPO || exit 1
    118 
    +    git checkout $BRANCH
    101 119
    102 
    -# Run the tests.  Exits with a non-zero code if there's a failure.
    103 
    -$LISP -noinit -nositeinit -batch <<'EOF'
    120 
    +    # Run the tests.  Exits with a non-zero code if there's a failure.
    121 
    +    $LISP -noinit -nositeinit -batch <<'EOF'
    104 122 
     (require :asdf)
    105 123 
     (push (default-directory) asdf:*central-registry*)
    106 124 
     (asdf:test-system :trivial-package-local-nicknames)
    107 125 
     EOF
    126 
    +fi

  • src/code/numbers.lisp
    ... ... @@ -602,154 +602,156 @@
    602 602 
     ;; In particular iteration 1 and 3 are added.  Iteration 2 and 4 were
    603 603 
     ;; not added.  The test examples from iteration 2 and 4 didn't change
    604 604 
     ;; with or without changes added.
    605 
    -(let* ((+rmin+ least-positive-normalized-double-float)
    606 
    -       (+rbig+ (/ most-positive-double-float 2))
    607 
    -       (+rmin2+ (scale-float 1d0 -53))
    608 
    -       (+rminscal+ (scale-float 1d0 51))
    609 
    -       (+rmax2+ (* +rbig+ +rmin2+))
    610 
    -       ;; The value of %eps in Scilab
    611 
    -       (+eps+ (scale-float 1d0 -52))
    612 
    -       (+be+ (/ 2 (* +eps+ +eps+)))
    613 
    -       (+2/eps+ (/ 2 +eps+)))
    614 
    -  (declare (double-float +rmin+ +rbig+ +rmin2+ +rminscal+ +rmax2+
    615 
    -			 +eps+ +be+ +2/eps+))
    616 
    -  (defun cdiv-double-float (x y)
    617 
    -    (declare (type (complex double-float) x y)
    618 
    -	     (optimize (speed 3) (safety 0)))
    619 
    -    (labels
    620 
    -	((internal-compreal (a b c d r tt)
    621 
    -	   (declare (double-float a b c d r tt))
    622 
    -	   ;; Compute the real part of the complex division
    623 
    -	   ;; (a+ib)/(c+id), assuming |d| <= |c|.  r = d/c and tt = 1/(c+d*r).
    624 
    -	   ;;
    625 
    -	   ;; The realpart is (a*c+b*d)/(c^2+d^2).
    626 
    -	   ;;
    627 
    -	   ;;   c^2+d^2 = c*(c+d*(d/c)) = c*(c+d*r)
    628 
    -	   ;;
    629 
    -	   ;; Then
    630 
    -	   ;;
    631 
    -	   ;;   (a*c+b*d)/(c^2+d^2) = (a*c+b*d)/(c*(c+d*r))
    632 
    -	   ;;                       = (a + b*d/c)/(c+d*r)
    633 
    -	   ;;                       = (a + b*r)/(c + d*r).
    634 
    -	   ;;
    635 
    -	   ;; Thus tt = (c + d*r).
    636 
    -	   (cond ((>= (abs r) +rmin+)
    637 
    -		  (let ((br (* b r)))
    638 
    -		    (if (/= br 0d0)
    639 
    -			(/ (+ a br) tt)
    640 
    -			;; b*r underflows.  Instead, compute
    641 
    -			;;
    642 
    -			;; (a + b*r)*tt = a*tt + b*tt*r
    643 
    -			;;              = a*tt + (b*tt)*r
    644 
    -			;; (a + b*r)/tt = a/tt + b/tt*r
    645 
    -			;;              = a*tt + (b*tt)*r
    646 
    -			(+ (/ a tt)
    647 
    -			   (* (/ b tt)
    648 
    -			      r)))))
    649 
    -		 (t
    650 
    -		  ;; r = 0 so d is very tiny compared to c.
    651 
    -		  ;;
    652 
    -		  (/ (+ a (* d (/ b c)))
    653 
    -		     tt))))
    654 
    -	 (robust-subinternal (a b c d)
    655 
    -	   (declare (double-float a b c d))
    656 
    -	   (let* ((r (/ d c))
    657 
    -		  (tt (+ c (* d r))))
    658 
    -	     ;; e is the real part and f is the imaginary part.  We
    659 
    -	     ;; can use internal-compreal for the imaginary part by
    660 
    -	     ;; noticing that the imaginary part of (a+i*b)/(c+i*d) is
    661 
    -	     ;; the same as the real part of (b-i*a)/(c+i*d).
    662 
    -	     (let ((e (internal-compreal a b c d r tt))
    663 
    -		   (f (internal-compreal b (- a) c d r tt)))
    664 
    -	       (values e
    665 
    -		       f))))
    605 
    +(defconstant +cdiv-rmin+ least-positive-normalized-double-float)
    606 
    +(defconstant +cdiv-rbig+ (/ most-positive-double-float 2))
    607 
    +(defconstant +cdiv-rmin2+ (scale-float 1d0 -53))
    608 
    +(defconstant +cdiv-rminscal+ (scale-float 1d0 51))
    609 
    +(defconstant +cdiv-rmax2+ (* +cdiv-rbig+ +cdiv-rmin2+))
    610 
    +;; This is the value of %eps from Scilab
    611 
    +(defconstant +cdiv-eps+ (scale-float 1d0 -52))
    612 
    +(defconstant +cdiv-be+ (/ 2 (* +cdiv-eps+ +cdiv-eps+)))
    613 
    +(defconstant +cdiv-2/eps+ (/ 2 +cdiv-eps+))
    614 
    +
    615 
    +(declaim (ext:start-block cdiv-double-float cdiv-single-float two-arg-/))
    616 
    +
    617 
    +(defun cdiv-double-float (x y)
    618 
    +  (declare (type (complex double-float) x y)
    619 
    +	   (optimize (speed 3) (safety 0)))
    620 
    +  (labels
    621 
    +      ((internal-compreal (a b c d r tt)
    622 
    +	 (declare (double-float a b c d r tt))
    623 
    +	 ;; Compute the real part of the complex division
    624 
    +	 ;; (a+ib)/(c+id), assuming |c| <= |d|.  r = d/c and tt = 1/(c+d*r).
    625 
    +	 ;;
    626 
    +	 ;; The realpart is (a*c+b*d)/(c^2+d^2).
    627 
    +	 ;;
    628 
    +	 ;;   c^2+d^2 = c*(c+d*(d/c)) = c*(c+d*r)
    629 
    +	 ;;
    630 
    +	 ;; Then
    631 
    +	 ;;
    632 
    +	 ;;   (a*c+b*d)/(c^2+d^2) = (a*c+b*d)/(c*(c+d*r))
    633 
    +	 ;;                       = (a + b*d/c)/(c+d*r)
    634 
    +	 ;;                       = (a + b*r)/(c + d*r).
    635 
    +	 ;;
    636 
    +	 ;; Thus tt = (c + d*r).
    637 
    +	 (cond ((>= (abs r) +cdiv-rmin+)
    638 
    +		(let ((br (* b r)))
    639 
    +		  (if (/= br 0)
    640 
    +		      (/ (+ a br) tt)
    641 
    +		      ;; b*r underflows.  Instead, compute
    642 
    +		      ;;
    643 
    +		      ;; (a + b*r)*tt = a*tt + b*tt*r
    644 
    +		      ;;              = a*tt + (b*tt)*r
    645 
    +		      ;; (a + b*r)/tt = a/tt + b/tt*r
    646 
    +		      ;;              = a*tt + (b*tt)*r
    647 
    +		      (+ (/ a tt)
    648 
    +			 (* (/ b tt)
    649 
    +			    r)))))
    650 
    +	       (t
    651 
    +		;; r = 0 so d is very tiny compared to c.
    652 
    +		;;
    653 
    +		(/ (+ a (* d (/ b c)))
    654 
    +		   tt))))
    655 
    +       (robust-subinternal (a b c d)
    656 
    +	 (declare (double-float a b c d))
    657 
    +	 (let* ((r (/ d c))
    658 
    +		(tt (+ c (* d r))))
    659 
    +	   ;; e is the real part and f is the imaginary part.  We
    660 
    +	   ;; can use internal-compreal for the imaginary part by
    661 
    +	   ;; noticing that the imaginary part of (a+i*b)/(c+i*d) is
    662 
    +	   ;; the same as the real part of (b-i*a)/(c+i*d).
    663 
    +	   (let ((e (internal-compreal a b c d r tt))
    664 
    +		 (f (internal-compreal b (- a) c d r tt)))
    665 
    +	     (values e
    666 
    +		     f))))
    666 667
    667 
    -	 (robust-internal (x y)
    668 
    -	   (declare (type (complex double-float) x y))
    669 
    -	   (let ((a (realpart x))
    670 
    -		 (b (imagpart x))
    671 
    -		 (c (realpart y))
    672 
    -		 (d (imagpart y)))
    673 
    -	     (declare (double-float a b c d))
    674 
    -	     (flet ((maybe-scale (abs-tst a b c d)
    675 
    -		      (declare (double-float a b c d))
    676 
    -		      ;; This implements McGehearty's iteration 3 to
    677 
    -		      ;; handle the case when some values are too big
    678 
    -		      ;; and should be scaled down.  Also if some
    679 
    -		      ;; values are too tiny, scale them up.
    680 
    -		      (let ((abs-a (abs a))
    681 
    -			    (abs-b (abs b)))
    682 
    -			(if (or (> abs-tst +rbig+)
    683 
    -				(> abs-a +rbig+)
    684 
    -				(> abs-b +rbig+))
    685 
    -			    (setf a (* a 0.5d0)
    686 
    -				  b (* b 0.5d0)
    687 
    -				  c (* c 0.5d0)
    688 
    -				  d (* d 0.5d0))
    689 
    -			    (if (< abs-tst +rmin2+)
    690 
    -				(setf a (* a +rminscal+)
    691 
    -				      b (* b +rminscal+)
    692 
    -				      c (* c +rminscal+)
    693 
    -				      d (* d +rminscal+))
    694 
    -				(if (or (and (< abs-a +rmin+)
    695 
    -					     (< abs-b +rmax2+)
    696 
    -					     (< abs-tst +rmax2+))
    697 
    -					(and (< abs-b +rmin+)
    698 
    -					     (< abs-a +rmax2+)
    699 
    -					     (< abs-tst +rmax2+)))
    700 
    -				    (setf a (* a +rminscal+)
    701 
    -					  b (* b +rminscal+)
    702 
    -					  c (* c +rminscal+)
    703 
    -					  d (* d +rminscal+)))))
    704 
    -			(values a b c d))))
    705 
    -	       (cond
    706 
    -		 ((<= (abs d) (abs c))
    707 
    -		  ;; |d| <= |c|, so we can use robust-subinternal to
    708 
    -		  ;; perform the division.
    709 
    -		  (multiple-value-bind (a b c d)
    710 
    -		      (maybe-scale (abs c) a b c d)
    711 
    -		    (multiple-value-bind (e f)
    712 
    -			(robust-subinternal a b c d)
    713 
    -		      (complex e f))))
    714 
    -		 (t
    715 
    -		  ;; |d| > |c|.  So, instead compute
    716 
    -		  ;;
    717 
    -		  ;;   (b + i*a)/(d + i*c)
    718 
    -		  ;;     = ((b*d+a*c) + (a*d-b*c)*i)/(d^2+c^2)
    719 
    -		  ;;
    720 
    -		  ;; Compare this to (a+i*b)/(c+i*d) and we see that
    721 
    -		  ;; realpart of the former is the same, but the
    722 
    -		  ;; imagpart of the former is the negative of the
    723 
    -		  ;; desired division.
    724 
    -		  (multiple-value-bind (a b c d)
    725 
    -		      (maybe-scale (abs d) a b c d)
    726 
    -		    (multiple-value-bind (e f)
    727 
    -			(robust-subinternal b a d c)
    728 
    -		      (complex e (- f))))))))))
    729 
    -      (let* ((max-ab (max (abs (realpart x))
    730 
    -			  (abs (imagpart x))))
    731 
    -	     (max-cd (max (abs (realpart y))
    732 
    -			  (abs (imagpart y))))
    733 
    -	     (s 1d0))
    734 
    -	(declare (double-float s))
    735 
    -	;; If a or b is big, scale down a and b.
    736 
    -	(when (>= max-ab +rbig+)
    737 
    -	  (setf x (/ x 2d0)
    738 
    -		s (* s 2d0)))
    739 
    -	;; If c or d is big, scale down c and d.
    740 
    -	(when (>= max-cd +rbig+)
    741 
    -	  (setf y (/ y 2d0)
    742 
    -		s (/ s 2d0)))
    743 
    -	;; If a or b is tiny, scale up a and b.
    744 
    -	(when (<= max-ab (* +rmin+ +2/eps+))
    745 
    -	  (setf x (* x +be+)
    746 
    -		s (/ s +be+)))
    747 
    -	;; If c or d is tiny, scale up c and d.
    748 
    -	(when (<= max-cd (* +rmin+ +2/eps+))
    749 
    -	  (setf y (* y +be+)
    750 
    -		s (* s +be+)))
    751 
    -	(* s
    752 
    -	   (robust-internal x y))))))
    668 
    +       (robust-internal (x y)
    669 
    +	 (declare (type (complex double-float) x y))
    670 
    +	 (let ((a (realpart x))
    671 
    +	       (b (imagpart x))
    672 
    +	       (c (realpart y))
    673 
    +	       (d (imagpart y)))
    674 
    +	   (declare (double-float a b c d))
    675 
    +	   (flet ((maybe-scale (abs-tst a b c d)
    676 
    +		    (declare (double-float a b c d))
    677 
    +		    ;; This implements McGehearty's iteration 3 to
    678 
    +		    ;; handle the case when some values are too big
    679 
    +		    ;; and should be scaled down.  Also if some
    680 
    +		    ;; values are too tiny, scale them up.
    681 
    +		    (let ((abs-a (abs a))
    682 
    +			  (abs-b (abs b)))
    683 
    +		      (if (or (> abs-tst +cdiv-rbig+)
    684 
    +			      (> abs-a +cdiv-rbig+)
    685 
    +			      (> abs-b +cdiv-rbig+))
    686 
    +			  (setf a (* a 0.5d0)
    687 
    +				b (* b 0.5d0)
    688 
    +				c (* c 0.5d0)
    689 
    +				d (* d 0.5d0))
    690 
    +			  (if (< abs-tst +cdiv-rmin2+)
    691 
    +			      (setf a (* a +cdiv-rminscal+)
    692 
    +				    b (* b +cdiv-rminscal+)
    693 
    +				    c (* c +cdiv-rminscal+)
    694 
    +				    d (* d +cdiv-rminscal+))
    695 
    +			      (if (or (and (< abs-a +cdiv-rmin+)
    696 
    +					   (< abs-b +cdiv-rmax2+)
    697 
    +					   (< abs-tst +cdiv-rmax2+))
    698 
    +				      (and (< abs-b +cdiv-rmin+)
    699 
    +					   (< abs-a +cdiv-rmax2+)
    700 
    +					   (< abs-tst +cdiv-rmax2+)))
    701 
    +				  (setf a (* a +cdiv-rminscal+)
    702 
    +					b (* b +cdiv-rminscal+)
    703 
    +					c (* c +cdiv-rminscal+)
    704 
    +					d (* d +cdiv-rminscal+)))))
    705 
    +		      (values a b c d))))
    706 
    +	     (cond
    707 
    +	       ((<= (abs d) (abs c))
    708 
    +		;; |d| <= |c|, so we can use robust-subinternal to
    709 
    +		;; perform the division.
    710 
    +		(multiple-value-bind (a b c d)
    711 
    +		    (maybe-scale (abs c) a b c d)
    712 
    +		  (multiple-value-bind (e f)
    713 
    +		      (robust-subinternal a b c d)
    714 
    +		    (complex e f))))
    715 
    +	       (t
    716 
    +		;; |d| > |c|.  So, instead compute
    717 
    +		;;
    718 
    +		;;   (b + i*a)/(d + i*c) = ((b*d+a*c) + (a*d-b*c)*i)/(d^2+c^2)
    719 
    +		;;
    720 
    +		;; Compare this to (a+i*b)/(c+i*d) and we see that
    721 
    +		;; realpart of the former is the same, but the
    722 
    +		;; imagpart of the former is the negative of the
    723 
    +		;; desired division.
    724 
    +		(multiple-value-bind (a b c d)
    725 
    +		    (maybe-scale (abs d) a b c d)
    726 
    +		  (multiple-value-bind (e f)
    727 
    +		      (robust-subinternal b a d c)
    728 
    +		    (complex e (- f))))))))))
    729 
    +    (let* ((a (realpart x))
    730 
    +	   (b (imagpart x))
    731 
    +	   (c (realpart y))
    732 
    +	   (d (imagpart y))
    733 
    +	   (ab (max (abs a) (abs b)))
    734 
    +	   (cd (max (abs c) (abs d)))
    735 
    +	   (s 1d0))
    736 
    +      (declare (double-float s))
    737 
    +      ;; If a or b is big, scale down a and b.
    738 
    +      (when (>= ab +cdiv-rbig+)
    739 
    +	(setf x (/ x 2)
    740 
    +	      s (* s 2)))
    741 
    +      ;; If c or d is big, scale down c and d.
    742 
    +      (when (>= cd +cdiv-rbig+)
    743 
    +	(setf y (/ y 2)
    744 
    +	      s (/ s 2)))
    745 
    +      ;; If a or b is tiny, scale up a and b.
    746 
    +      (when (<= ab (* +cdiv-rmin+ +cdiv-2/eps+))
    747 
    +	(setf x (* x +cdiv-be+)
    748 
    +	      s (/ s +cdiv-be+)))
    749 
    +      ;; If c or d is tiny, scale up c and d.
    750 
    +      (when (<= cd (* +cdiv-rmin+ +cdiv-2/eps+))
    751 
    +	(setf y (* y +cdiv-be+)
    752 
    +	      s (* s +cdiv-be+)))
    753 
    +      (* s
    754 
    +	 (robust-internal x y)))))
    753 755
    754 756 
     ;; Smith's algorithm for complex division for (complex single-float).
    755 757 
     ;; We convert the parts to double-floats before computing the result.
    ... ... @@ -850,7 +852,7 @@
    850 852 
         (((complex rational)
    851 853 
           (complex rational))
    852 854 
          ;; We probably don't need to do Smith's algorithm for rationals.
    853 
    -     ;; A naive implementation of complex division has no issues.
    855 
    +     ;; A naive implementation of coplex division has no issues.
    854 856 
          (let ((a (realpart x))
    855 857 
     	   (b (imagpart x))
    856 858 
     	   (c (realpart y))
    ... ... @@ -907,6 +909,7 @@
    907 909 
            (build-ratio (maybe-truncate nx gcd)
    908 910 
     		    (* (maybe-truncate y gcd) (denominator x)))))))
    909 911
    912 
    +(declaim (ext:end-block))
    910 913
    911 914 
     (defun %negate (n)
    912 915 
       (number-dispatch ((n number))

  • src/code/pathname.lisp
    ... ... @@ -838,14 +838,18 @@ a host-structure or string."
    838 838 
     			       (%pathname-directory defaults)
    839 839 
     			       diddle-defaults)))
    840 840
    841 
    -    ;; A bit of sanity checking on user arguments.
    841 
    +    ;; A bit of sanity checking on user arguments.  We don't allow a
    842 
    +    ;; "/" or NUL in any string that's part of a pathname object.
    842 843 
         (flet ((check-component-validity (name name-or-type)
    843 844 
     	     (when (stringp name)
    844 
    -	       (let ((unix-directory-separator #\/))
    845 
    -		 (when (eq host (%pathname-host *default-pathname-defaults*))
    846 
    -		   (when (find unix-directory-separator name)
    847 
    -		     (warn (intl:gettext "Silly argument for a unix ~A: ~S")
    848 
    -			   name-or-type name)))))))
    845 
    +	       (when (eq host (%pathname-host *default-pathname-defaults*))
    846 
    +		 (when (some #'(lambda (c)
    847 
    +				 ;; Illegal characters are a slash or NUL.
    848 
    +				 (case c
    849 
    +				   ((#\/ #\null) t)))
    850 
    +				name)
    851 
    +		   (error _"Pathname component ~A cannot contain a slash or nul character: ~S"
    852 
    +			   name-or-type name))))))
    849 853 
           (check-component-validity name :pathname-name)
    850 854 
           (check-component-validity type :pathname-type)
    851 855 
           (mapc #'(lambda (d)
    ... ... @@ -856,8 +860,9 @@ a host-structure or string."
    856 860 
     			  (not type))
    857 861 
     		     (and (string= name ".")
    858 862 
     			  (not type))))
    859 
    -	;;
    860 
    -	(warn (intl:gettext "Silly argument for a unix PATHNAME-NAME: ~S") name)))
    863 
    +	;;
    864 
    +	(cerror _"Continue anyway"
    865 
    +		_"PATHNAME-NAME cannot be \".\" or \"..\"")))
    861 866
    862 867 
         ;; More sanity checking
    863 868 
         (when dir

  • src/i18n/locale/cmucl.pot
    ... ... @@ -7717,7 +7717,7 @@ msgstr ""
    7717 7717 
     msgid ", type="
    7718 7718 
     msgstr ""
    7719 7719
    7720 
    -#: src/code/print.lisp
    7720 
    +#: src/code/pathname.lisp src/code/print.lisp
    7721 7721 
     msgid "Continue anyway"
    7722 7722 
     msgstr ""
    7723 7723
    ... ... @@ -9785,17 +9785,17 @@ msgid "~S is not allowed as a directory component."
    9785 9785 
     msgstr ""
    9786 9786
    9787 9787 
     #: src/code/pathname.lisp
    9788 
    -msgid ""
    9789 
    -"Makes a new pathname from the component arguments.  Note that host is\n"
    9790 
    -"a host-structure or string."
    9788 
    +msgid "Pathname component ~A cannot contain a slash or nul character: ~S"
    9791 9789 
     msgstr ""
    9792 9790
    9793 9791 
     #: src/code/pathname.lisp
    9794 
    -msgid "Silly argument for a unix ~A: ~S"
    9792 
    +msgid "PATHNAME-NAME cannot be \".\" or \"..\""
    9795 9793 
     msgstr ""
    9796 9794
    9797 9795 
     #: src/code/pathname.lisp
    9798 
    -msgid "Silly argument for a unix PATHNAME-NAME: ~S"
    9796 
    +msgid ""
    9797 
    +"Makes a new pathname from the component arguments.  Note that host is\n"
    9798 
    +"a host-structure or string."
    9799 9799 
     msgstr ""
    9800 9800
    9801 9801 
     #: src/code/pathname.lisp

  • tests/float-x86.lisp
    ... ... @@ -5,6 +5,11 @@
    5 5
    6 6 
     (in-package "FLOAT-X86-TESTS")
    7 7
    8 
    +;; This tests the floating-point modes for x86.  This works only if we
    9 
    +;; have the feature :sse2 but not :darwin since darwin has always used
    10 
    +;; sse2 and not x87.  But see also how FLOATING-POINT-MODES is
    11 
    +;; implemented in src/code/float-trap.lisp.
    12 
    +#+(and sse2 (not darwin))
    8 13 
     (define-test set-floating-point-modes
    9 14 
       (let ((old-x87-modes (x86::x87-floating-point-modes))
    10 15 
     	(old-sse2-modes (x86::sse2-floating-point-modes))

  • tests/os.lisp
    ... ... @@ -51,6 +51,7 @@
    51 51 
           (assert-equal 2153718000 st-atime)
    52 52 
           (assert-equal 2153718000 st-mtime))))
    53 53
    54 
    +#+linux
    54 55 
     (define-test stat.64-bit-timestamp-2106
    55 56 
         (:tag :issues)
    56 57 
       (let ((test-file #.(merge-pathnames "resources/64-bit-timestamp-2106.txt"

  • tests/pathname.lisp
    ... ... @@ -153,4 +153,30 @@
    153 153 
           ;; Now recursively delete the directory.
    154 154 
           (assert-true (ext:delete-directory (merge-pathnames "tmp/" path)
    155 155 
     					 :recursive t))
    156 
    -      (assert-false (directory "tmp/")))))
    156 
    +      (assert-false (directory (merge-pathnames "tmp/" path))))))
    157 
    +
    158 
    +(define-test issue.454.illegal-pathname-chars
    159 
    +    (:tag :issues)
    160 
    +  ;; A slash (Unix directory separater) is not allowed.
    161 
    +  (assert-error 'simple-error
    162 
    +		(make-pathname :name "a/b"))
    163 
    +  (assert-error 'simple-error
    164 
    +		(make-pathname :type "a/b"))
    165 
    +  (assert-error 'simple-error
    166 
    +		(make-pathname :directory '(:relative "a/b")))
    167 
    +  ;; ASCII NUL characters are not allowed in Unix pathnames.
    168 
    +  (let ((string-with-nul (concatenate 'string "a" (string #\nul) "b")))
    169 
    +    (assert-error 'simple-error
    170 
    +		  (make-pathname :name string-with-nul))
    171 
    +    (assert-error 'simple-error
    172 
    +		  (make-pathname :type string-with-nul))
    173 
    +    (assert-error 'simple-error
    174 
    +		  (make-pathname :directory (list :relative string-with-nul)))))
    175 
    +
    176 
    +(define-test issue.454.illegal-pathname-dot
    177 
    +    (:tag :issues)
    178 
    +  (assert-error 'simple-error
    179 
    +		(make-pathname :name "."))
    180 
    +  (assert-error 'simple-error
    181 
    +		(make-pathname :name "..")))
    182 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help Notification message regarding https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ef99f00954a34ece65ebdb8bfcdd0b1dee6017a7...7457eadbdb3e9cd3198e601ad43ae782b16b1f7c at 1767810167