[Git][cmucl/cmucl][issue-139-filename-encoding-utf8] 17 commits: Fix #132: Ansi test RENAME-FILE.1 fails
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Wed Nov 16 17:02:32 UTC 2022
Raymond Toy pushed to branch issue-139-filename-encoding-utf8 at cmucl / cmucl
Commits:
2079d179 by Raymond Toy at 2022-11-13T21:47:14-08:00
Fix #132: Ansi test RENAME-FILE.1 fails
- - - - -
3b1f86dc by Raymond Toy at 2022-11-13T21:49:20-08:00
Fix #134: Handle the case of (expt complex complex-rational)
- - - - -
d08f44ff by Raymond Toy at 2022-11-13T21:49:27-08:00
Fix #146: CI passes incorrectly
- - - - -
dcbd8338 by Raymond Toy at 2022-11-13T21:49:27-08:00
Fix #142: (random 0) signals incorrect error
- - - - -
e2afb5c8 by Raymond Toy at 2022-11-13T21:49:27-08:00
Fix #136: ensure-directories-exist should return the given pathspec
- - - - -
6cb2e896 by Raymond Toy at 2022-11-13T21:49:27-08:00
Update release notes based on recent merges
Forgot to update the release notes with recent merges that fixed a few
issues. Hence update the notes now.
Also testing see if we need to add a strikeout for closed issues, so
didn't add strikeout for these.
- - - - -
a03eadc1 by Raymond Toy at 2022-11-13T21:49:27-08:00
Add strikeout for closed issues
Nope, gitlab doesn't mark closed issues in anyway, unlike Trac that
would automatically strikeout references to closed issues. We have to
do it ourselves.
- - - - -
08274018 by Raymond Toy at 2022-11-13T21:49:27-08:00
Fix #146: CI passes incorrectly
We forgot to update the script for macos to use separate `grep`
commands like we did for linux.
- - - - -
c28ce164 by Raymond Toy at 2022-11-13T21:50:17-08:00
Fix #130: Implement file_author in C
- - - - -
92b3d0c6 by Raymond Toy at 2022-11-13T21:50:23-08:00
Fix #147: Add method for stream-line-column
- - - - -
3f6c10e1 by Raymond Toy at 2022-11-13T21:51:07-08:00
Address #139: *default-external-format* is :utf-8
- - - - -
1da61cd2 by Raymond Toy at 2022-11-13T21:51:12-08:00
Change :iso-8859-1 to :iso8859-1 in find-encoding
While there's an alias for `:iso-8859-1`, it's safer to use
`:iso8859-1` which is builtin. Using `:iso-8859-1` requires the alias
database to be loaded, which isn't (currently) guaranteed when
`find-encoding` is called. Thus use the builtin name instead.
Besides, `:iso8859-1` is used in other places in "intl.lisp".
(This is hard to test, but I noticed it when running
```
LANG=ko_KR.utf8 lisp
```
on the branch `issue-139-add-alias-local-external-format`.)
- - - - -
c44e775b by Raymond Toy at 2022-11-13T21:51:12-08:00
Update release-21e.md with closed issues.
- - - - -
3328947e by Raymond Toy at 2022-11-13T21:51:12-08:00
Fix #150: add aliases cp949 euckr
- - - - -
2fb7d21e by Raymond Toy at 2022-11-13T21:51:12-08:00
Fix #149: Call setlocale(3C) on startup
- - - - -
1320a82c by Raymond Toy at 2022-11-13T21:51:12-08:00
Fix #155: Wrap help strings neatly
- - - - -
fba3f3a8 by Raymond Toy at 2022-11-13T21:51:12-08:00
Fix #141: Use setlocale to handle localization settings
- - - - -
19 changed files:
- .gitlab-ci.yml
- src/code/commandline.lisp
- src/code/extfmts.lisp
- src/code/filesys.lisp
- src/code/intl.lisp
- src/code/irrat.lisp
- src/code/rand-xoroshiro.lisp
- src/code/save.lisp
- src/code/unix.lisp
- src/general-info/release-21e.md
- src/i18n/locale/cmucl-unix.pot
- src/lisp/os-common.c
- src/pcl/gray-streams.lisp
- src/pcl/simple-streams/external-formats/aliases
- + tests/.gitignore
- tests/filesys.lisp
- tests/issues.lisp
- + tests/utf8.txt
- + tests/안녕하십니까.txt
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -80,7 +80,8 @@ linux:ansi-test:
script:
- cd ansi-test
- make LISP="../dist/bin/lisp -batch -noinit -nositeinit"
- - grep 'No unexpected \(successes\|failures\)' test.out
+ # There should be no unexpected successes or failures; check these separately.
+ - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out
linux:benchmark:
stage: benchmark
@@ -166,7 +167,8 @@ osx:ansi-test:
script:
- cd ansi-test
- make LISP="../dist/bin/lisp -batch -noinit -nositeinit"
- - grep 'No unexpected \(successes\|failures\)' test.out
+ # There should be no unexpected successes or failures; check these separately.
+ - grep -a 'No unexpected successes' test.out && grep -a 'No unexpected failures' test.out
osx:benchmark:
stage: benchmark
=====================================
src/code/commandline.lisp
=====================================
@@ -339,16 +339,54 @@
(defun help-switch-demon (switch)
(declare (ignore switch))
(format t (intl:gettext "~&Usage: ~A <options>~2%") *command-line-utility-name*)
- (dolist (s (sort *legal-cmd-line-switches* #'string<
- :key #'car))
- (destructuring-bind (name doc arg)
- s
- (format t " -~A ~@[~A~]~%" name (if arg (intl:gettext arg)))
- ;; Poor man's formatting of the help string
- (with-input-from-string (stream (intl:gettext doc))
- (loop for line = (read-line stream nil nil)
- while line
- do (format t "~8T~A~%" line)))))
+ (flet
+ ((get-words (s)
+ (declare (string s))
+ ;; Return a list of all the words from S. A word is defined
+ ;; as any sequence of characters separated from others by
+ ;; whitespace consisting of space, newline, tab, formfeed, or
+ ;; carriage return.
+ (let ((end (length s)))
+ (loop for left = 0 then (+ right 1)
+ for right = (or
+ (position-if #'(lambda (c)
+ (member c
+ '(#\space #\newline #\tab #\ff #\cr)))
+ s
+ :start left)
+ end)
+ ;; Collect the word bounded by left and right in a list.
+ unless (and (= right left))
+ collect (subseq s left right) into subseqs
+ ;; Keep going until we reach the end of the string.
+ until (>= right end)
+ finally (return subseqs)))))
+
+ (dolist (s (sort *legal-cmd-line-switches* #'string<
+ :key #'car))
+ (destructuring-bind (name doc arg)
+ s
+ (format t " -~A ~@[~A~]~%" name (if arg (intl:gettext arg)))
+ ;; Poor man's formatting of the help string
+ (let ((*print-right-margin* 80))
+ ;; Extract all the words from the string and print them out
+ ;; one by one with a space between each, wrapping the output
+ ;; if needed. Each line is indented by 8 spaces.
+ ;;
+ ;; "~@< ~@;"
+ ;; per-line prefix of spaces and pass the whole arg list
+ ;; to this directive.
+ ;;
+ ;; "~{~A~^ ~}"
+ ;; loop over each word and print out the word followed by
+ ;; a space.
+ ;;
+ ;; "~:@>"
+ ;; No suffix, and insert conditional newline after each
+ ;; group of blanks if needed.
+ (format t "~@< ~@;~{~A~^ ~}~:@>"
+ (get-words (intl:gettext doc))))
+ (terpri))))
(ext:quit))
(defswitch "help" #'help-switch-demon
=====================================
src/code/extfmts.lisp
=====================================
@@ -22,8 +22,7 @@
describe-external-format))
(defvar *default-external-format*
- #-unicode :iso8859-1
- #+unicode :utf-8
+ :utf-8
"The default external format to use if no other external format is
specified")
=====================================
src/code/filesys.lisp
=====================================
@@ -950,7 +950,11 @@
File after it was renamed."
(let* ((original (truename file))
(original-namestring (unix-namestring original t))
- (new-name (merge-pathnames new-name file))
+ ;; First, merge NEW-FILE-NAME with *DEFAULT-PATHNAME-DEFAULTS* to
+ ;; fill in the missing components and then merge again with
+ ;; the FILE to get any missing components from FILE.
+ (new-name (merge-pathnames (merge-pathnames new-name)
+ file))
(new-namestring (unix-namestring new-name nil)))
(unless new-namestring
(error 'simple-file-error
@@ -1075,13 +1079,21 @@ optionally keeping some of the most recent old versions."
:pathname file
:format-control (intl:gettext "~S doesn't exist.")
:format-arguments (list file)))
- (multiple-value-bind (winp dev ino mode nlink uid)
- (unix:unix-stat name)
- (declare (ignore dev ino mode nlink))
- (when winp
- (let ((user-info (unix:unix-getpwuid uid)))
- (when user-info
- (unix:user-info-name user-info))))))))
+ ;; unix-namestring converts "." to "". Convert it back to
+ ;; "." so we can stat the current directory. (Perhaps
+ ;; that's a bug in unix-namestring?)
+ (when (zerop (length name))
+ (setf name "."))
+ (let (author)
+ (unwind-protect
+ (progn
+ (setf author (alien:alien-funcall
+ (alien:extern-alien "os_file_author"
+ (function (alien:* c-call:c-string) c-call:c-string))
+ (unix::%name->file name)))
+ (unless (alien:null-alien author)
+ (alien:cast author c-call:c-string)))
+ (alien:free-alien author))))))
;;;; DIRECTORY.
@@ -1474,4 +1486,4 @@ optionally keeping some of the most recent old versions."
(retry () :report "Try to create the directory again"
(go retry))))))
;; Only the first path in a search-list is considered.
- (return (values pathname created-p))))))
+ (return (values pathspec created-p))))))
=====================================
src/code/intl.lisp
=====================================
@@ -105,7 +105,7 @@
(defun find-encoding (domain)
(when (null (domain-entry-encoding domain))
- (setf (domain-entry-encoding domain) :iso-8859-1)
+ (setf (domain-entry-encoding domain) :iso8859-1)
;; Domain lookup can call the compiler, so set the locale to "C"
;; so things work.
(let* ((*locale* "C")
@@ -520,10 +520,7 @@
(defun setlocale (&optional locale)
(setf *locale* (or locale
- (getenv "LANGUAGE")
- (getenv "LC_ALL")
- (getenv "LC_MESSAGES")
- (getenv "LANG")
+ (unix::unix-get-lc-messages)
*locale*)))
(defmacro textdomain (domain)
=====================================
src/code/irrat.lisp
=====================================
@@ -510,12 +510,12 @@
(* base power)
(exp (* power (* (log2 base 1w0) (log 2w0))))))
(((foreach fixnum (or bignum ratio) single-float)
- (foreach (complex single-float)))
+ (foreach (complex rational) (complex single-float)))
(if (and (zerop base) (plusp (realpart power)))
(* base power)
(exp (* power (log base)))))
(((foreach (complex rational) (complex single-float))
- (foreach single-float (complex single-float)))
+ (foreach single-float (complex rational) (complex single-float)))
(if (and (zerop base) (plusp (realpart power)))
(* base power)
(or (expt-xfrm (coerce base '(complex single-float)) power)
@@ -537,7 +537,7 @@
(exp (* power (log (coerce base '(complex double-double-float))))))))
(((foreach (complex double-float))
(foreach single-float double-float
- (complex single-float) (complex double-float)))
+ (complex rational) (complex single-float) (complex double-float)))
(if (and (zerop base) (plusp (realpart power)))
(* base power)
(or (expt-xfrm base power)
@@ -552,7 +552,7 @@
(exp (* power (log (coerce base '(complex double-double-float))))))))
#+double-double
(((foreach (complex double-double-float))
- (foreach float (complex float)))
+ (foreach float (complex float) (complex rational)))
(if (and (zerop base) (plusp (realpart power)))
(* base power)
(or (expt-xfrm base power)
=====================================
src/code/rand-xoroshiro.lisp
=====================================
@@ -491,8 +491,8 @@
(t
(error 'simple-type-error
:expected-type '(or (integer 1) (float (0.0))) :datum arg
- :format-control _"Argument is not a positive integer or a positive float: ~S")
- :format-arguments (list arg))))
+ :format-control _"Argument is not a positive integer or a positive float: ~S"
+ :format-arguments (list arg)))))
;; Jump function for the generator. See the jump function in
;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c
=====================================
src/code/save.lisp
=====================================
@@ -249,6 +249,10 @@
(reinit)
(environment-init)
(dolist (f *after-save-initializations*) (funcall f))
+ ;; Set the runtime locale
+ (unless (zerop (unix::unix-setlocale))
+ (warn "os_setlocale failed"))
+ ;; Set the locale for lisp
(intl::setlocale)
(ext::process-command-strings process-command-line)
(setf *editor-lisp-p* nil)
=====================================
src/code/unix.lisp
=====================================
@@ -2896,3 +2896,25 @@
of the child in the parent if it works, or NIL and an error number if it
doesn't work."
(int-syscall ("fork")))
+
+(defun unix-setlocale ()
+ _N"Call setlocale(3c) with fixed args. Returns 0 on success."
+ (alien:alien-funcall
+ (alien:extern-alien "os_setlocale"
+ (function c-call:int))))
+
+(defun unix-get-lc-messages ()
+ _N"Get LC_MESSAGES from the current locale. If we can't, return
+ NIL. A call to UNIX-SETLOCALE must have been done previously before
+ calling this so that the correct locale is returned."
+ (with-alien ((buf (array c-call:char 256)))
+ (let ((result
+ (alien-funcall
+ (extern-alien "os_get_lc_messages"
+ (function c-call:int
+ (* c-call:char)
+ c-call:int))
+ (cast buf (* c-call:char))
+ 256)))
+ (when (zerop result)
+ (cast buf c-call:c-string)))))
=====================================
src/general-info/release-21e.md
=====================================
@@ -22,6 +22,7 @@ public domain.
* Feature enhancements
* Changes
* Update to ASDF 3.3.6
+ * The default external format is `:utf-8` instead of `:iso8859-1`
* ANSI compliance fixes:
* Bug fixes:
* ~~#97~~ Fixes stepping through the source forms in the debugger. This has been broken for quite some time, but it works now.
@@ -50,8 +51,20 @@ public domain.
* ~~#113~~ REQUIRE on contribs can pull in the wrong things via ASDF..
* ~~#121~~ Wrong column index in FILL-POINTER-OUTPUT-STREAM
* ~~#122~~ gcc 11 can't build cmucl
+ * ~~#124~~ directory with `:wild-inferiors` doesn't descend subdirectories
+ * ~~#125~~ Linux `unix-stat` returning incorrect values
* ~~#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
+ * ~~#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`
+ * ~~#141~~ Disallow locales that are pathnames to a localedef file
+ * ~~#142~~ `(random 0)` signals incorrect error
+ * ~~#147~~ `stream-line-column` method missing for `fundamental-character-output-stream`
+ * ~~#149~~ Call setlocale(3C) on startup
+ * ~~#155~~ Wrap help strings neatly
* Other changes:
* Improvements to the PCL implementation of CLOS:
* Changes to building procedure:
=====================================
src/i18n/locale/cmucl-unix.pot
=====================================
@@ -1424,3 +1424,14 @@ msgid ""
" doesn't work."
msgstr ""
+#: src/code/unix.lisp
+msgid "Call setlocale(3c) with fixed args. Returns 0 on success."
+msgstr ""
+
+#: src/code/unix.lisp
+msgid ""
+"Get LC_MESSAGES from the current locale. If we can't, return\n"
+" NIL. A call to UNIX-SETLOCALE must have been done previously before\n"
+" calling this so that the correct locale is returned."
+msgstr ""
+
=====================================
src/lisp/os-common.c
=====================================
@@ -5,12 +5,17 @@
*/
+#include <assert.h>
#include <errno.h>
+#include <locale.h>
#include <math.h>
#include <netdb.h>
+#include <pwd.h>
#include <stdio.h>
+#include <stdlib.h>
#include <string.h>
#include <sys/stat.h>
+#include <unistd.h>
#include <time.h>
#include "os.h"
@@ -715,3 +720,79 @@ os_lstat(const char* path, u_int64_t *dev, u_int64_t *ino, unsigned int *mode, u
return rc;
}
+
+/*
+ * Interface for file-author. Given a pathname, returns a new string
+ * holding the author of the file or NULL if some error occurred. The
+ * caller is responsible for freeing the memory used by the string.
+ */
+char *
+os_file_author(const char *path)
+{
+ struct stat sb;
+ char initial[1024];
+ char *buffer, *obuffer;
+ size_t size;
+ struct passwd pwd;
+ struct passwd *ppwd;
+ char *result;
+
+ if (stat(path, &sb) != 0) {
+ return NULL;
+ }
+
+ result = NULL;
+ buffer = initial;
+ obuffer = NULL;
+ size = sizeof(initial) / sizeof(initial[0]);
+
+ /*
+ * Keep trying with larger buffers until a maximum is reached. We
+ * assume (1 << 20) is large enough for any OS.
+ */
+ while (size <= (1 << 20)) {
+ switch (getpwuid_r(sb.st_uid, &pwd, buffer, size, &ppwd)) {
+ case 0:
+ /* Success, though we might not have a matching entry */
+ result = (ppwd == NULL) ? NULL : strdup(pwd.pw_name);
+ goto exit;
+ case ERANGE:
+ /* Buffer is too small, double its size and try again */
+ size *= 2;
+ obuffer = (buffer == initial) ? NULL : buffer;
+ if ((buffer = realloc(obuffer, size)) == NULL) {
+ goto exit;
+ }
+ continue;
+ default:
+ /* All other errors */
+ goto exit;
+ }
+ }
+exit:
+ free(obuffer);
+
+ return result;
+}
+
+int
+os_setlocale(void)
+{
+ char *result = setlocale(LC_ALL, "");
+
+ /* Return 0 if setlocale suceeded; otherwise -1. */
+ return result != NULL ? 0 : -1;
+}
+
+int
+os_get_lc_messages(char *buf, int len)
+{
+ char *locale = setlocale(LC_MESSAGES, NULL);
+ if (locale) {
+ strncpy(buf, locale, len - 1);
+ buf[len - 1] = '\0';
+ }
+
+ /* Return -1 if setlocale failed. */
+ return locale ? 0 : -1;
+}
=====================================
src/pcl/gray-streams.lisp
=====================================
@@ -235,6 +235,9 @@
defined for this function, although it is permissible for it to
always return NIL."))
+(defmethod stream-line-column ((stream fundamental-character-output-stream))
+ nil)
+
;;; Stream-line-length is a CMUCL extension to Gray streams.
(defgeneric stream-line-length (stream)
(:documentation _N"Return the stream line length or Nil."))
=====================================
src/pcl/simple-streams/external-formats/aliases
=====================================
@@ -223,6 +223,8 @@ windows-cp1252 cp1252
windows-latin1 cp1252
ms-ansi cp1252
+euckr euc-kr
+cp949 euc-kr
;; These are not yet implemented
;;iso-2022-jp iso2022-jp
;;iso2022jp iso2022-jp
=====================================
tests/.gitignore
=====================================
@@ -0,0 +1 @@
+/out-utf8.txt
=====================================
tests/filesys.lisp
=====================================
@@ -10,7 +10,7 @@
(define-test unix-namestring.1.exists
;; Make sure the desired directories exist.
- (assert-equal #P"/tmp/foo/bar/hello.txt"
+ (assert-equal "/tmp/foo/bar/hello.txt"
(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
(dolist (path '("/tmp/hello.txt"
"/tmp/foo/"
@@ -27,7 +27,7 @@
(define-test unix-namestring.1.non-existent
;; Make sure the desired directories exist.
- (assert-equal #P"/tmp/foo/bar/hello.txt"
+ (assert-equal "/tmp/foo/bar/hello.txt"
(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
;; These paths contain directories that don't exist.
(dolist (path '("/tmp/oops/"
@@ -42,7 +42,7 @@
(define-test unix-namestring.2
;; Make sure the desired directories exist.
- (assert-equal #P"/tmp/foo/bar/hello.txt"
+ (assert-equal "/tmp/foo/bar/hello.txt"
(ensure-directories-exist "/tmp/foo/bar/hello.txt"))
(unwind-protect
(progn
=====================================
tests/issues.lisp
=====================================
@@ -5,6 +5,12 @@
(in-package "ISSUES-TESTS")
+(defparameter *test-path*
+ (merge-pathnames (make-pathname :name :unspecific :type :unspecific
+ :version :unspecific)
+ *load-truename*)
+ "Path to where this file is.")
+
(defun square (x)
(expt x 2))
@@ -580,6 +586,96 @@
while user-info
finally (assert-false user-info)))
+(define-test issue.132.1
+ (:tag :issues)
+ ;; From a message on cmucl-imp 2008/06/01. If "d1" is a directory,
+ ;; (rename "d1" "d2") should rename the directory "d1" to "d2".
+ ;; Previously that produced an error trying to rename "d1" to
+ ;; "d1/d2".
+ ;;
+ ;; Create the test directory (that is a subdirectory of "dir").
+ (assert-true (ensure-directories-exist "dir/orig-dir/"))
+ (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory))))
+ (multiple-value-bind (defaulted-new-name old-truename new-truename)
+ ;; Rename "dir/orig-dir" to "orig/new-dir".
+ (rename-file "orig-dir/" "new-dir")
+ (let ((orig (merge-pathnames
+ (make-pathname :directory '(:relative "orig-dir"))))
+ (new (merge-pathnames
+ (make-pathname :directory '(:relative "new-dir")))))
+ ;; Ensure that the rename worked and that the returned values
+ ;; have the expected values.
+ (assert-true defaulted-new-name)
+ (assert-equalp old-truename orig)
+ (assert-equalp new-truename new)))))
+
+(define-test issue.132.2
+ (:tag :issues)
+ (assert-true (ensure-directories-exist "dir/orig.dir/"))
+ (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory))))
+ (multiple-value-bind (defaulted-new-name old-truename new-truename)
+ ;; Rename "dir/orig.dir" to "orig/new-dir". Since the
+ ;; original name has a pathname-name of "orig" and a
+ ;; pathname-type of "dir", the new file name is merged to
+ ;; produce a pathname-name of "new" with a pathname-type of
+ ;; "dir".
+ (rename-file "orig.dir" "new")
+ (let ((orig (merge-pathnames
+ (make-pathname :directory '(:relative "orig.dir"))))
+ (new (merge-pathnames
+ (make-pathname :directory '(:relative "new.dir")))))
+ ;; Ensure that the rename worked and that the returned values
+ ;; have the expected values.
+ (assert-true defaulted-new-name)
+ (assert-equalp old-truename orig)
+ (assert-equalp new-truename new)))))
+
+(define-test issue.132.3
+ (:tag :issues)
+ (assert-true (ensure-directories-exist "dir/orig.dir/"))
+ (let ((*default-pathname-defaults* (merge-pathnames "dir/" (ext:default-directory))))
+ (multiple-value-bind (defaulted-new-name old-truename new-truename)
+ ;; Rename "dir/orig.dir/" to "orig/new". Note that the
+ ;; original name is "orig.dir/" which marks a directory so
+ ;; that when we merge the new name with the old to fill in
+ ;; missing components, there are none because the old name is
+ ;; a directory with no pathname-name or pathname-type, so the
+ ;; new name stays the same.
+ (rename-file "orig.dir/" "new")
+ (let ((orig (merge-pathnames
+ (make-pathname :directory '(:relative "orig.dir"))))
+ (new (merge-pathnames
+ (make-pathname :directory '(:relative "new")))))
+ ;; Ensure that the rename worked and that the returned values
+ ;; have the expected values.
+ (assert-true defaulted-new-name)
+ (assert-equalp old-truename orig)
+ (assert-equalp new-truename new)))))
+
+(define-test issue.134
+ (:tag :issues)
+ ;; Verify that we can compute (3+4*%i)^%i (in Maxima format). This
+ ;; can be written analytically as
+ ;; %i*%e^-atan(4/3)*sin(log(5))+%e^-atan(4/3)*cos(log(5)), so use
+ ;; %this as the reference value.
+ (let ((answer (complex (* (cos (log 5w0))
+ (exp (- (atan (float (/ 4 3) 0w0)))))
+ (* (sin (log 5w0))
+ (exp (- (atan (float (/ 4 3) 0w0))))))))
+ (flet ((relerr (actual true)
+ ;; Return the relative error between ACTUAL and TRUE
+ (/ (abs (- actual true))
+ (abs true))))
+ (dolist (test '((#c(3 4) 3.5918w-8)
+ (#c(3.0 4) 3.5918w-8)
+ (#c(3d0 4) 9.2977w-17)
+ (#c(3w0 4) 0w0)))
+ (destructuring-bind (base eps)
+ test
+ (let* ((value (expt base #c(0 1)))
+ (err (relerr value answer)))
+ (assert-true (<= err eps) base err eps)))))))
+
(define-test issue-139.1
(:tag :issues)
;; Verify the value of the default external format and that system streams use :utf-8.
@@ -600,3 +696,80 @@
(with-open-file (s "test-format.txt" :direction :input)
(let ((c (read-char s)))
(assert-equal #\u+3b1 c))))
+
+(define-test issue.130
+ (:tag :issues)
+ ;; Just verify that file-author works. In particular "." should
+ ;; work and not return NIL.
+ (assert-true (file-author "."))
+ (assert-true (file-author "bin/build.sh"))
+ (let ((unix::*filename-encoding* :utf-8))
+ ;; Set filename encoding to utf-8 so that we can encode the
+ ;; filename properly.
+ (assert-true
+ (file-author
+ (merge-pathnames
+ (concatenate 'string
+ ;; Write the test file name this way so
+ ;; that it's independent of the encoding
+ ;; used to load this file. The name is
+ ;; "안녕하십니까".
+ '(#\Hangul_Syllable_An #\Hangul_Syllable_Nyeong #\Hangul_Syllable_Ha
+ #\Hangul_Syllable_Sib #\Hangul_Syllable_Ni #\Hangul_Syllable_Gga)
+ ".txt")
+ *test-path*)))))
+
+(define-test issue.139-default-external-format
+ (:tag :issues)
+ (assert-eq :utf-8 stream:*default-external-format*))
+
+(define-test issue.139-default-external-format-read-file
+ (:tag :issues)
+ (let ((string (concatenate 'string
+ ;; This is "hello" in Korean
+ '(#\Hangul_syllable_an
+ #\Hangul_Syllable_Nyeong
+ #\Hangul_Syllable_Ha
+ #\Hangul_Syllable_Se
+ #\Hangul_Syllable_Yo))))
+ ;; Test that opening a file for reading uses the the default :utf8
+ ;; encoding.
+ (with-open-file (s (merge-pathnames "utf8.txt"
+ *test-path*)
+ :direction :input)
+ ;; The first line should be "hello" in Hangul.
+ (assert-equal (map 'list #'char-name string)
+ (map 'list #'char-name (read-line s))))))
+
+(define-test issue.139-default-external-format-write-file
+ (:tag :issues)
+ ;; Test that opening a file for writing uses the default :utf8.
+ ;; First write something out to the file. Then read it back in
+ ;; using an explicit format of utf8 and verifying that we got the
+ ;; right contents.
+ (let ((string (concatenate 'string
+ ;; This is "hello" in Korean
+ '(#\Hangul_syllable_an
+ #\Hangul_Syllable_Nyeong
+ #\Hangul_Syllable_Ha
+ #\Hangul_Syllable_Se
+ #\Hangul_Syllable_Yo))))
+ (with-open-file (s (merge-pathnames "out-utf8.txt"
+ *test-path*)
+ :direction :output
+ :if-exists :supersede)
+ (write-line string s))
+ (with-open-file (s (merge-pathnames "out-utf8.txt"
+ *test-path*)
+ :direction :input
+ :external-format :utf-8)
+ (assert-equal (map 'list #'char-name string)
+ (map 'list #'char-name (read-line s))))))
+
+
+(define-test issue.150
+ (:tag :issues)
+ (let ((ext:*gc-verbose* nil)
+ (*compile-print* nil))
+ (assert-true (stream::find-external-format :euckr))
+ (assert-true (stream::find-external-format :cp949))))
=====================================
tests/utf8.txt
=====================================
@@ -0,0 +1,2 @@
+안녕하세요
+UTF8 test. The above line is "Hello" in Hangul.
=====================================
tests/안녕하십니까.txt
=====================================
@@ -0,0 +1,3 @@
+The file name of this file is "안녕하십니까.txt" ("Hello" in Korean.)
+
+
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/64fd3b43038e1c2891cf1434e4732a5058127556...fba3f3a8be47647e528683670254ea7ccef35b31
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/64fd3b43038e1c2891cf1434e4732a5058127556...fba3f3a8be47647e528683670254ea7ccef35b31
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20221116/3e87d711/attachment-0001.html>
More information about the cmucl-cvs
mailing list