Raymond Toy pushed to branch issue-120-software-type-in-c at cmucl / cmucl

Commits:

9 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
    ... ... @@ -166,7 +167,8 @@ osx:ansi-test:
    166 167 
       script:
    167 168 
         - cd ansi-test
    168 169 
         - make LISP="../dist/bin/lisp -batch -noinit -nositeinit"
    169 
    -    - grep 'No unexpected \(successes\|failures\)' test.out
    170 
    +    # There should be no unexpected successes or failures; check these separately.
    171 
    +    - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out
    170 172
    171 173 
     osx:benchmark:
    172 174 
       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
    ... ... @@ -1075,13 +1079,21 @@ optionally keeping some of the most recent old versions."
    1075 1079 
     		 :pathname file
    1076 1080 
     		 :format-control (intl:gettext "~S doesn't exist.")
    1077 1081 
     		 :format-arguments (list file)))
    1078 
    -	(multiple-value-bind (winp dev ino mode nlink uid)
    1079 
    -			     (unix:unix-stat name)
    1080 
    -	  (declare (ignore dev ino mode nlink))
    1081 
    -	  (when winp
    1082 
    -            (let ((user-info (unix:unix-getpwuid uid)))
    1083 
    -              (when user-info
    1084 
    -                (unix:user-info-name user-info))))))))
    1082 
    +	;; unix-namestring converts "." to "".  Convert it back to
    1083 
    +	;; "." so we can stat the current directory.  (Perhaps
    1084 
    +	;; that's a bug in unix-namestring?)
    1085 
    +	(when (zerop (length name))
    1086 
    +	  (setf name "."))
    1087 
    +	(let (author)
    1088 
    +	  (unwind-protect
    1089 
    +	       (progn
    1090 
    +		 (setf author (alien:alien-funcall
    1091 
    +			       (alien:extern-alien "os_file_author"
    1092 
    +						   (function (alien:* c-call:c-string) c-call:c-string))
    1093 
    +			       (unix::%name->file name)))
    1094 
    +		 (unless (alien:null-alien author)
    1095 
    +		   (alien:cast author c-call:c-string)))
    1096 
    +	    (alien:free-alien author))))))
    1085 1097
    1086 1098
    1087 1099 
     ;;;; DIRECTORY.
    ... ... @@ -1474,4 +1486,4 @@ optionally keeping some of the most recent old versions."
    1474 1486 
     			 (retry () :report "Try to create the directory again"
    1475 1487 
     				(go retry))))))
    1476 1488 
     	 ;; Only the first path in a search-list is considered.
    1477 
    -	 (return (values pathname created-p))))))
    1489 
    +	 (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:

  • src/lisp/os-common.c
    ... ... @@ -5,13 +5,17 @@
    5 5
    6 6 
     */
    7 7
    8 
    +#include <assert.h>
    8 9 
     #include <errno.h>
    9 10 
     #include <math.h>
    10 11 
     #include <netdb.h>
    12 
    +#include <pwd.h>
    11 13 
     #include <stdio.h>
    14 
    +#include <stdlib.h>
    12 15 
     #include <string.h>
    13 16 
     #include <sys/stat.h>
    14 17 
     #include <sys/utsname.h>
    18 
    +#include <unistd.h>
    15 19 
     #include <time.h>
    16 20
    17 21 
     #include "os.h"
    ... ... @@ -717,6 +721,59 @@ os_lstat(const char* path, u_int64_t *dev, u_int64_t *ino, unsigned int *mode, u
    717 721 
         return rc;
    718 722 
     }
    719 723
    724 
    +/*
    725 
    + * Interface for file-author.  Given a pathname, returns a new string
    726 
    + * holding the author of the file or NULL if some error occurred.  The
    727 
    + * caller is responsible for freeing the memory used by the string.
    728 
    + */
    729 
    +char *
    730 
    +os_file_author(const char *path)
    731 
    +{
    732 
    +    struct stat sb;
    733 
    +    char initial[1024];
    734 
    +    char *buffer, *obuffer;
    735 
    +    size_t size;
    736 
    +    struct passwd pwd;
    737 
    +    struct passwd *ppwd;
    738 
    +    char *result;
    739 
    +
    740 
    +    if (stat(path, &sb) != 0) {
    741 
    +        return NULL;
    742 
    +    }
    743 
    +
    744 
    +    result = NULL;
    745 
    +    buffer = initial;
    746 
    +    obuffer = NULL;
    747 
    +    size = sizeof(initial) / sizeof(initial[0]);
    748 
    +
    749 
    +    /*
    750 
    +     * Keep trying with larger buffers until a maximum is reached.  We
    751 
    +     * assume (1 << 20) is large enough for any OS.
    752 
    +     */
    753 
    +    while (size <= (1 << 20)) {
    754 
    +        switch (getpwuid_r(sb.st_uid, &pwd, buffer, size, &ppwd)) {
    755 
    +          case 0:
    756 
    +              /* Success, though we might not have a matching entry */
    757 
    +              result = (ppwd == NULL) ? NULL : strdup(pwd.pw_name);
    758 
    +              goto exit;
    759 
    +          case ERANGE:
    760 
    +              /* Buffer is too small, double its size and try again */
    761 
    +              size *= 2;
    762 
    +              obuffer = (buffer == initial) ? NULL : buffer;
    763 
    +              if ((buffer = realloc(obuffer, size)) == NULL) {
    764 
    +                  goto exit;
    765 
    +              }
    766 
    +              continue;
    767 
    +          default:
    768 
    +              /* All other errors */
    769 
    +              goto exit;
    770 
    +        }
    771 
    +    }
    772 
    +exit:
    773 
    +    free(obuffer);
    774 
    +
    775 
    +    return result;
    776 
    +}
    720 777 
     /*
    721 778 
      * For Linux and solaris, software-version returns the concatenation
    722 779 
      * of the uname release and version fields.  For BSD (including
    ... ... @@ -769,4 +826,3 @@ os_software_type()
    769 826
    770 827 
         return os_name;
    771 828 
     }
    772 
    -

  • 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,101 @@
    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 
    +
    673 
    +(define-test issue.130
    674 
    +    (:tag :issues)
    675 
    +  ;; Just verify that file-author works.  In particular "." should
    676 
    +  ;; work and not return NIL.
    677 
    +  (assert-true (file-author "."))
    678 
    +  (assert-true (file-author "bin/build.sh"))
    679 
    +  (assert-true (file-author "tests/안녕하십니까.txt")))

  • tests/안녕하십니까.txt
    1 
    +The file name of this file is "안녕하십니까.txt" ("Hello" in Korean.)
    2 
    +
    3 
    +

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