Raymond Toy pushed to branch issue-141-locale at cmucl / cmucl

Commits:

7 changed files:

Changes:

  • .gitlab-ci.yml
    ... ... @@ -80,7 +80,8 @@ linux:ansi-test:
    80 80 
       script:
    81 81 
         - cd ansi-test
    82 82 
         - make LISP="../dist/bin/lisp -batch -noinit -nositeinit"
    83 
    -    - grep 'No unexpected \(successes\|failures\)' test.out
    83 
    +    # There should be no unexpected successes or failures; check these separately.
    84 
    +    - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out
    84 85
    85 86 
     linux:benchmark:
    86 87 
       stage: benchmark

  • src/code/filesys.lisp
    ... ... @@ -950,7 +950,11 @@
    950 950 
       File after it was renamed."
    951 951 
       (let* ((original (truename file))
    952 952 
     	 (original-namestring (unix-namestring original t))
    953 
    -	 (new-name (merge-pathnames new-name file))
    953 
    +	 ;; First, merge NEW-FILE-NAME with *DEFAULT-PATHNAME-DEFAULTS* to
    954 
    +	 ;; fill in the missing components and then merge again with
    955 
    +	 ;; the FILE to get any missing components from FILE.
    956 
    +	 (new-name (merge-pathnames (merge-pathnames new-name)
    957 
    +				    file))
    954 958 
     	 (new-namestring (unix-namestring new-name nil)))
    955 959 
         (unless new-namestring
    956 960 
           (error 'simple-file-error
    ... ... @@ -1474,4 +1478,4 @@ optionally keeping some of the most recent old versions."
    1474 1478 
     			 (retry () :report "Try to create the directory again"
    1475 1479 
     				(go retry))))))
    1476 1480 
     	 ;; Only the first path in a search-list is considered.
    1477 
    -	 (return (values pathname created-p))))))
    1481 
    +	 (return (values pathspec created-p))))))

  • src/code/irrat.lisp
    ... ... @@ -510,12 +510,12 @@
    510 510 
     	     (* base power)
    511 511 
     	     (exp (* power (* (log2 base 1w0) (log 2w0))))))
    512 512 
     	(((foreach fixnum (or bignum ratio) single-float)
    513 
    -	  (foreach (complex single-float)))
    513 
    +	  (foreach (complex rational) (complex single-float)))
    514 514 
     	 (if (and (zerop base) (plusp (realpart power)))
    515 515 
     	     (* base power)
    516 516 
     	     (exp (* power (log base)))))
    517 517 
     	(((foreach (complex rational) (complex single-float))
    518 
    -	  (foreach single-float (complex single-float)))
    518 
    +	  (foreach single-float (complex rational) (complex single-float)))
    519 519 
     	 (if (and (zerop base) (plusp (realpart power)))
    520 520 
     	     (* base power)
    521 521 
     	     (or (expt-xfrm (coerce base '(complex single-float)) power)
    ... ... @@ -537,7 +537,7 @@
    537 537 
     		 (exp (* power (log (coerce base '(complex double-double-float))))))))
    538 538 
     	(((foreach (complex double-float))
    539 539 
     	  (foreach single-float double-float
    540 
    -		   (complex single-float) (complex double-float)))
    540 
    +		   (complex rational) (complex single-float) (complex double-float)))
    541 541 
     	 (if (and (zerop base) (plusp (realpart power)))
    542 542 
     	     (* base power)
    543 543 
     	     (or (expt-xfrm base power)
    ... ... @@ -552,7 +552,7 @@
    552 552 
     		 (exp (* power (log (coerce base '(complex double-double-float))))))))
    553 553 
     	#+double-double
    554 554 
     	(((foreach (complex double-double-float))
    555 
    -	  (foreach float (complex float)))
    555 
    +	  (foreach float (complex float) (complex rational)))
    556 556 
     	 (if (and (zerop base) (plusp (realpart power)))
    557 557 
     	     (* base power)
    558 558 
     	     (or (expt-xfrm base power)

  • src/code/rand-xoroshiro.lisp
    ... ... @@ -491,8 +491,8 @@
    491 491 
         (t
    492 492 
          (error 'simple-type-error
    493 493 
     	    :expected-type '(or (integer 1) (float (0.0))) :datum arg
    494 
    -	    :format-control _"Argument is not a positive integer or a positive float: ~S")
    495 
    -	    :format-arguments (list arg))))
    494 
    +	    :format-control _"Argument is not a positive integer or a positive float: ~S"
    495 
    +	    :format-arguments (list arg)))))
    496 496
    497 497 
     ;; Jump function for the generator.  See the jump function in
    498 498 
     ;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c

  • src/general-info/release-21e.md
    ... ... @@ -50,8 +50,13 @@ public domain.
    50 50 
         * ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF.
    51 51 
         * ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM
    52 52 
         * ~~#122~~ gcc 11 can't build cmucl
    53 
    +    * ~~#125~~ Linux `unix-stat` returning incorrect values
    53 54 
         * ~~#127~~ Linux unix-getpwuid segfaults when given non-existent uid.
    54 55 
         * ~~#128~~ `QUIT` accepts an exit code
    56 
    +    * ~~#132~~ Ansi test `RENAME-FILE.1` no fails
    57 
    +    * ~~#134~~ Handle the case of `(expt complex complex-rational)`
    58 
    +    * ~~#136~~ `ensure-directories-exist` should return the given pathspec
    59 
    +    * ~~#142~~ `(random 0)` signals incorrect error
    55 60 
       * Other changes:
    56 61 
       * Improvements to the PCL implementation of CLOS:
    57 62 
       * Changes to building procedure:

  • tests/filesys.lisp
    ... ... @@ -10,7 +10,7 @@
    10 10
    11 11 
     (define-test unix-namestring.1.exists
    12 12 
       ;; Make sure the desired directories exist.
    13 
    -  (assert-equal #P"/tmp/foo/bar/hello.txt"
    13 
    +  (assert-equal "/tmp/foo/bar/hello.txt"
    14 14 
     		(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
    15 15 
       (dolist (path '("/tmp/hello.txt"
    16 16 
     		  "/tmp/foo/"
    ... ... @@ -27,7 +27,7 @@
    27 27
    28 28 
     (define-test unix-namestring.1.non-existent
    29 29 
       ;; Make sure the desired directories exist.
    30 
    -  (assert-equal #P"/tmp/foo/bar/hello.txt"
    30 
    +  (assert-equal "/tmp/foo/bar/hello.txt"
    31 31 
     		(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
    32 32 
       ;; These paths contain directories that don't exist.
    33 33 
       (dolist (path '("/tmp/oops/"
    ... ... @@ -42,7 +42,7 @@
    42 42
    43 43 
     (define-test unix-namestring.2
    44 44 
       ;; Make sure the desired directories exist.
    45 
    -  (assert-equal #P"/tmp/foo/bar/hello.txt"
    45 
    +  (assert-equal "/tmp/foo/bar/hello.txt"
    46 46 
     		(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
    47 47 
       (unwind-protect
    48 48 
            (progn

  • tests/issues.lisp
    ... ... @@ -579,3 +579,94 @@
    579 579 
     	with user-info = (unix:unix-getpwuid uid)
    580 580 
     	while user-info
    581 581 
     	finally (assert-false user-info)))
    582 
    +
    583 
    +(define-test issue.132.1
    584 
    +    (:tag :issues)
    585 
    +  ;; From a message on cmucl-imp 2008/06/01.  If "d1" is a directory,
    586 
    +  ;; (rename "d1" "d2") should rename the directory "d1" to "d2".
    587 
    +  ;; Previously that produced an error trying to rename "d1" to
    588 
    +  ;; "d1/d2".
    589 
    +  ;;
    590 
    +  ;; Create the test directory (that is a subdirectory of "dir").
    591 
    +  (assert-true (ensure-directories-exist "dir/orig-dir/"))
    592 
    +  (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory))))
    593 
    +    (multiple-value-bind (defaulted-new-name old-truename new-truename)
    594 
    +	;; Rename "dir/orig-dir" to "orig/new-dir".
    595 
    +	(rename-file "orig-dir/" "new-dir")
    596 
    +      (let ((orig (merge-pathnames
    597 
    +		   (make-pathname :directory '(:relative "orig-dir"))))
    598 
    +	    (new (merge-pathnames
    599 
    +		  (make-pathname :directory '(:relative "new-dir")))))
    600 
    +	;; Ensure that the rename worked and that the returned values
    601 
    +	;; have the expected values.
    602 
    +	(assert-true defaulted-new-name)
    603 
    +	(assert-equalp old-truename orig)
    604 
    +	(assert-equalp new-truename new)))))
    605 
    +
    606 
    +(define-test issue.132.2
    607 
    +    (:tag :issues)
    608 
    +  (assert-true (ensure-directories-exist "dir/orig.dir/"))
    609 
    +  (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory))))
    610 
    +    (multiple-value-bind (defaulted-new-name old-truename new-truename)
    611 
    +	;; Rename "dir/orig.dir" to "orig/new-dir".  Since the
    612 
    +	;; original name has a pathname-name of "orig" and a
    613 
    +	;; pathname-type of "dir", the new file name is merged to
    614 
    +	;; produce a pathname-name of "new" with a pathname-type of
    615 
    +	;; "dir".
    616 
    +	(rename-file "orig.dir" "new")
    617 
    +      (let ((orig (merge-pathnames
    618 
    +		   (make-pathname :directory '(:relative "orig.dir"))))
    619 
    +	    (new (merge-pathnames
    620 
    +		  (make-pathname :directory '(:relative "new.dir")))))
    621 
    +	;; Ensure that the rename worked and that the returned values
    622 
    +	;; have the expected values.
    623 
    +	(assert-true defaulted-new-name)
    624 
    +	(assert-equalp old-truename orig)
    625 
    +	(assert-equalp new-truename new)))))
    626 
    +
    627 
    +(define-test issue.132.3
    628 
    +    (:tag :issues)
    629 
    +  (assert-true (ensure-directories-exist "dir/orig.dir/"))
    630 
    +  (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory))))
    631 
    +    (multiple-value-bind (defaulted-new-name old-truename new-truename)
    632 
    +	;; Rename "dir/orig.dir/" to "orig/new".  Note that the
    633 
    +	;; original name is "orig.dir/" which marks a directory so
    634 
    +	;; that when we merge the new name with the old to fill in
    635 
    +	;; missing components, there are none because the old name is
    636 
    +	;; a directory with no pathname-name or pathname-type, so the
    637 
    +	;; new name stays the same.
    638 
    +	(rename-file "orig.dir/" "new")
    639 
    +      (let ((orig (merge-pathnames
    640 
    +		   (make-pathname :directory '(:relative "orig.dir"))))
    641 
    +	    (new (merge-pathnames
    642 
    +		  (make-pathname :directory '(:relative "new")))))
    643 
    +	;; Ensure that the rename worked and that the returned values
    644 
    +	;; have the expected values.
    645 
    +	(assert-true defaulted-new-name)
    646 
    +	(assert-equalp old-truename orig)
    647 
    +	(assert-equalp new-truename new)))))
    648 
    +
    649 
    +(define-test issue.134
    650 
    +    (:tag :issues)
    651 
    +  ;; Verify that we can compute (3+4*%i)^%i (in Maxima format).  This
    652 
    +  ;; can be written analytically as
    653 
    +  ;; %i*%e^-atan(4/3)*sin(log(5))+%e^-atan(4/3)*cos(log(5)), so use
    654 
    +  ;; %this as the reference value.
    655 
    +  (let ((answer (complex (* (cos (log 5w0))
    656 
    +			    (exp (- (atan (float (/ 4 3) 0w0)))))
    657 
    +			 (* (sin (log 5w0))
    658 
    +			    (exp (- (atan (float (/ 4 3) 0w0))))))))
    659 
    +    (flet ((relerr (actual true)
    660 
    +	     ;; Return the relative error between ACTUAL and TRUE
    661 
    +	     (/ (abs (- actual true))
    662 
    +		(abs true))))
    663 
    +      (dolist (test '((#c(3 4) 3.5918w-8)
    664 
    +		      (#c(3.0 4) 3.5918w-8)
    665 
    +		      (#c(3d0 4) 9.2977w-17)
    666 
    +		      (#c(3w0 4) 0w0)))
    667 
    +	(destructuring-bind (base eps)
    668 
    +	    test
    669 
    +	  (let* ((value (expt base #c(0 1)))
    670 
    +		 (err (relerr value answer)))
    671 
    +	    (assert-true (<= err eps) base err eps)))))))
    672 
    +

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