November 2022 - cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][issue-140-stream-element-type-two-way-stream] Update release notes with clearer summary
by Raymond Toy (＠rtoy) 22 Nov '22

22 Nov '22

Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl Commits: d6bbeb16 by Raymond Toy at 2022-11-22T07:46:47-08:00 Update release notes with clearer summary - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -60,7 +60,7 @@ public domain. * ~~#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` - * ~~#140~~ External format of `two-way-stream` + * ~~#140~~ External format for streams that are not `file-stream`'s * ~~#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` View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d6bbeb1604938cff19dbac7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d6bbeb1604938cff19dbac7… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-140-stream-element-type-two-way-stream] Address review comments
by Raymond Toy (＠rtoy) 22 Nov '22

22 Nov '22

Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl Commits: 8144bada by Raymond Toy at 2022-11-22T07:43:26-08:00 Address review comments Since `two-way-stream` isn't a `file-stream`, signal an error from `stream-external-format`. Update the test to verify that `stream-external-format` for a `two-way-stream` signals a `type-error`. Add a test for `broadcast-stream`s to verify that we return the format of the last stream. - - - - - 2 changed files: - src/code/stream.lisp - tests/issues.lisp Changes: ===================================== src/code/stream.lisp ===================================== @@ -304,11 +304,7 @@ ;; Not defined by CLHS. What should happen if ;; (synonym-stream-symbol stream) is unbound? (stream-external-format - (symbol-value (synonym-stream-symbol stream)))) - (two-way-stream - ;; Not defined by CLHS, but use default for backward - ;; compatibility. - :default)) + (symbol-value (synonym-stream-symbol stream))))) ;; fundamental-stream :default)) ===================================== tests/issues.lisp ===================================== @@ -747,9 +747,7 @@ ;;; Test stream-external-format for various types of streams. -;; Test two-way-stream where both streams have the same external -;; format. -(define-test issue.140.two-way-stream-same +(define-test issue.140.two-way-stream (:tag :issues) (with-open-file (in (merge-pathnames "issues.lisp" cmucl-test-runner::*load-path*) :direction :input @@ -759,21 +757,8 @@ :external-format :utf-8 :if-exists :supersede) (let ((two-way-stream (make-two-way-stream in out))) - (assert-equal :default (stream-external-format two-way-stream)))))) - -;; Test two-way-stream where the two streams have the different -;; external formats. -(define-test issue.140.two-way-stream-diff - (:tag :issues) - (with-open-file (in (merge-pathnames "issues.lisp" cmucl-test-runner::*load-path*) - :direction :input - :external-format :iso8859-1) - (with-open-file (out "/tmp/output.tst" - :direction :output - :external-format :utf-8 - :if-exists :supersede) - (let ((two-way-stream (make-two-way-stream in out))) - (assert-equal :default (stream-external-format two-way-stream)))))) + (assert-error 'type-error + (stream-external-format two-way-stream)))))) ;; Test synonym-stream returns the format of the underlying stream. (define-test issue.140.synonym-stream @@ -785,6 +770,29 @@ (setf syn s) (assert-equal :iso8859-1 (stream-external-format syn))))) +(define-test issue.140.broadcast-stream + (:tag :issues) + ;; Create 3 output streams. The exact external formats aren't + ;; really important here as long as they're different for each file + ;; so we can tell if we got the right answer. + (with-open-file (s1 "/tmp/broad-1" + :direction :output + :if-exists :supersede + :external-format :latin1) + (with-open-file (s2 "/tmp/broad-2" + :direction :output + :if-exists :supersede + :external-format :utf-8) + (with-open-file (s3 "/tmp/broad-3" + :direction :output + :if-exists :supersede + :external-format :utf-16) + ;; The format must be the value from the last stream. + (assert-equal :utf-16 + (stream-external-format + (make-broadcast-stream s1 s2 s3))))))) + + (define-test issue.150 (:tag :issues) (let ((ext:*gc-verbose* nil) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8144bada55b3ac9880c6106… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/8144bada55b3ac9880c6106… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-139-filename-encoding-utf8] 17 commits: Fix #132: Ansi test RENAME-FILE.1 fails
by Raymond Toy (＠rtoy) 16 Nov '22

16 Nov '22

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/64fd3b43038e1c2891cf14… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/64fd3b43038e1c2891cf14… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-140-stream-element-type-two-way-stream] Handle stream-external-format of broadcast-stream
by Raymond Toy (＠rtoy) 16 Nov '22

16 Nov '22

Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl Commits: dc292bb7 by Raymond Toy at 2022-11-15T21:15:25-08:00 Handle stream-external-format of broadcast-stream Actually implement what the spec says for the external format of a `broadcast-stream`. - - - - - 1 changed file: - src/code/stream.lisp Changes: ===================================== src/code/stream.lisp ===================================== @@ -296,7 +296,10 @@ (fd-stream (fd-stream-external-format stream)) (broadcast-stream ;; See http://www.lispworks.com/documentation/HyperSpec/Body/t_broadc.htm - :default) + (let ((components (broadcast-stream-streams stream))) + (if (null components) + :default + (stream-external-format (car (last components)))))) (synonym-stream ;; Not defined by CLHS. What should happen if ;; (synonym-stream-symbol stream) is unbound? View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dc292bb73492d075ee1634c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/dc292bb73492d075ee1634c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-156-define-cmpsd-pmovmskb
by Raymond Toy (＠rtoy) 16 Nov '22

16 Nov '22

Raymond Toy pushed new branch issue-156-define-cmpsd-pmovmskb at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-156-define-cmpsd-pm… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-140-stream-element-type-two-way-stream] 7 commits: Fix #149: Call setlocale(3C) on startup
by Raymond Toy (＠rtoy) 14 Nov '22

14 Nov '22

Raymond Toy pushed to branch issue-140-stream-element-type-two-way-stream at cmucl / cmucl Commits: 33c760fa by Raymond Toy at 2022-11-03T04:47:09+00:00 Fix #149: Call setlocale(3C) on startup - - - - - 317a33f8 by Raymond Toy at 2022-11-03T04:47:10+00:00 Merge branch 'issue-149-add-setlocale' into 'master' Fix #149: Call setlocale(3C) on startup Closes #149 See merge request cmucl/cmucl!105 - - - - - 7bbb4843 by Raymond Toy at 2022-11-08T03:19:19+00:00 Fix #155: Wrap help strings neatly - - - - - 68f4ec70 by Raymond Toy at 2022-11-08T03:19:21+00:00 Merge branch 'issue-155-wrap-help-strings' into 'master' Fix #155: Wrap help strings neatly Closes #155 See merge request cmucl/cmucl!107 - - - - - 23f66902 by Raymond Toy at 2022-11-14T05:09:37+00:00 Fix #141: Use setlocale to handle localization settings - - - - - 6764053d by Raymond Toy at 2022-11-14T05:09:38+00:00 Merge branch 'issue-141-locale' into 'master' Fix #141: Use setlocale to handle localization settings Closes #141, #136, #142, #146, #134, and #132 See merge request cmucl/cmucl!101 - - - - - 4cb049f3 by Raymond Toy at 2022-11-14T14:56:45-08:00 Merge branch 'master' into issue-140-stream-element-type-two-way-stream - - - - - 7 changed files: - src/code/commandline.lisp - src/code/intl.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 Changes: ===================================== 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/intl.lisp ===================================== @@ -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/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 ===================================== @@ -2893,3 +2893,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 ===================================== @@ -61,8 +61,11 @@ public domain. * ~~#136~~ `ensure-directories-exist` should return the given pathspec * #139 `*default-external-format*` defaults to `:utf-8` * ~~#140~~ External format of `two-way-stream` + * ~~#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` + * ~~#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 ===================================== @@ -7,6 +7,7 @@ #include <assert.h> #include <errno.h> +#include <locale.h> #include <math.h> #include <netdb.h> #include <pwd.h> @@ -773,3 +774,25 @@ exit: 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; +} View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4d69dda728c54cba0ab7c9… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/4d69dda728c54cba0ab7c9… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-139-add-alias-local-external-format] 6 commits: Fix #155: Wrap help strings neatly
by Raymond Toy (＠rtoy) 14 Nov '22

14 Nov '22

Raymond Toy pushed to branch issue-139-add-alias-local-external-format at cmucl / cmucl Commits: 7bbb4843 by Raymond Toy at 2022-11-08T03:19:19+00:00 Fix #155: Wrap help strings neatly - - - - - 68f4ec70 by Raymond Toy at 2022-11-08T03:19:21+00:00 Merge branch 'issue-155-wrap-help-strings' into 'master' Fix #155: Wrap help strings neatly Closes #155 See merge request cmucl/cmucl!107 - - - - - 23f66902 by Raymond Toy at 2022-11-14T05:09:37+00:00 Fix #141: Use setlocale to handle localization settings - - - - - 6764053d by Raymond Toy at 2022-11-14T05:09:38+00:00 Merge branch 'issue-141-locale' into 'master' Fix #141: Use setlocale to handle localization settings Closes #141, #136, #142, #146, #134, and #132 See merge request cmucl/cmucl!101 - - - - - 0a2144aa by Raymond Toy at 2022-11-14T14:38:55-08:00 Merge branch 'master' into issue-139-add-alias-local-external-format - - - - - 10f6311f by Raymond Toy at 2022-11-14T14:49:31-08:00 Fix merge mistake Accidentally deleted the test issue.139-default-external-format-write-file - - - - - 6 changed files: - src/code/commandline.lisp - src/code/intl.lisp - src/code/unix.lisp - src/general-info/release-21e.md - src/lisp/os-common.c - tests/issues.lisp Changes: ===================================== 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/intl.lisp ===================================== @@ -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/unix.lisp ===================================== @@ -2900,6 +2900,22 @@ (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))))) + (defun unix-get-locale-codeset () _N"Get the codeset from the locale" (with-alien ((codeset (array c-call:char 512))) ===================================== src/general-info/release-21e.md ===================================== @@ -59,11 +59,12 @@ public domain. * ~~#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` - * #139 add alias for `:locale` external format + * #139 `*default-external-format*` defaults to `:utf-8`; add alias for `:locale` external format + * ~~#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/lisp/os-common.c ===================================== @@ -785,6 +785,19 @@ os_setlocale(void) 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; +} + void os_get_locale_codeset(char* codeset, int len) { @@ -794,4 +807,3 @@ os_get_locale_codeset(char* codeset, int len) strncpy(codeset, code, len); } - ===================================== tests/issues.lisp ===================================== @@ -720,6 +720,30 @@ (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.139-locale-external-format (:tag :issues) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/af271f0b18e636871bb970… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/af271f0b18e636871bb970… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #141: Use setlocale to handle localization settings
by Raymond Toy (＠rtoy) 14 Nov '22

14 Nov '22

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 23f66902 by Raymond Toy at 2022-11-14T05:09:37+00:00 Fix #141: Use setlocale to handle localization settings - - - - - 6764053d by Raymond Toy at 2022-11-14T05:09:38+00:00 Merge branch 'issue-141-locale' into 'master' Fix #141: Use setlocale to handle localization settings Closes #141, #136, #142, #146, #134, and #132 See merge request cmucl/cmucl!101 - - - - - 5 changed files: - src/code/intl.lisp - src/code/unix.lisp - src/general-info/release-21e.md - src/i18n/locale/cmucl-unix.pot - src/lisp/os-common.c Changes: ===================================== src/code/intl.lisp ===================================== @@ -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/unix.lisp ===================================== @@ -2899,3 +2899,19 @@ (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 ===================================== @@ -60,6 +60,7 @@ public domain. * ~~#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 ===================================== src/i18n/locale/cmucl-unix.pot ===================================== @@ -1428,3 +1428,10 @@ msgstr "" 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 ===================================== @@ -783,3 +783,16 @@ os_setlocale(void) /* 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; +} View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/68f4ec706ced2efdf3e17f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/68f4ec706ced2efdf3e17f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-141-locale] Use LC_MESSAGES for intl::*locale*
by Raymond Toy (＠rtoy) 08 Nov '22

08 Nov '22

Raymond Toy pushed to branch issue-141-locale at cmucl / cmucl Commits: b935fbf1 by Raymond Toy at 2022-11-08T14:12:08-08:00 Use LC_MESSAGES for intl::*locale* For intl::setlocale, get the information from LC_MESSAGES; that's really what intl wants to know---the language to use for translations. To make it clearer, rename os_getlocale to os_get_lc_messages, and do the corresponding change for unix-get-lc-messages. Update the translation pot file because the docstring changed. - - - - - 4 changed files: - src/code/intl.lisp - src/code/unix.lisp - src/i18n/locale/cmucl-unix.pot - src/lisp/os-common.c Changes: ===================================== src/code/intl.lisp ===================================== @@ -520,7 +520,7 @@ (defun setlocale (&optional locale) (setf *locale* (or locale - (unix::unix-getlocale) + (unix::unix-get-lc-messages) *locale*))) (defmacro textdomain (domain) ===================================== src/code/unix.lisp ===================================== @@ -2900,14 +2900,14 @@ (alien:extern-alien "os_setlocale" (function c-call:int)))) -(defun unix-getlocale () - _N"Get 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." +(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_getlocale" + (extern-alien "os_get_lc_messages" (function c-call:int (* c-call:char) c-call:int)) ===================================== src/i18n/locale/cmucl-unix.pot ===================================== @@ -1430,8 +1430,8 @@ msgstr "" #: src/code/unix.lisp msgid "" -"Get the current locale. If we can't, return NIL. A call to\n" -" UNIX-SETLOCALE must have been done previously before calling this so\n" -" that the correct locale is returned." +"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 ===================================== @@ -785,9 +785,9 @@ os_setlocale(void) } int -os_getlocale(char *buf, int len) +os_get_lc_messages(char *buf, int len) { - char *locale = setlocale(LC_ALL, NULL); + char *locale = setlocale(LC_MESSAGES, NULL); if (locale) { strncpy(buf, locale, len - 1); buf[len - 1] = '\0'; View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b935fbf1ce1807fcb5323d7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/b935fbf1ce1807fcb5323d7… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #155: Wrap help strings neatly
by Raymond Toy (＠rtoy) 08 Nov '22

08 Nov '22

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 7bbb4843 by Raymond Toy at 2022-11-08T03:19:19+00:00 Fix #155: Wrap help strings neatly - - - - - 68f4ec70 by Raymond Toy at 2022-11-08T03:19:21+00:00 Merge branch 'issue-155-wrap-help-strings' into 'master' Fix #155: Wrap help strings neatly Closes #155 See merge request cmucl/cmucl!107 - - - - - 2 changed files: - src/code/commandline.lisp - src/general-info/release-21e.md Changes: ===================================== 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/general-info/release-21e.md ===================================== @@ -63,6 +63,7 @@ public domain. * ~~#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: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/317a33f8d4031fd15c854e… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/317a33f8d4031fd15c854e… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0