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

[Git][cmucl/cmucl][master] Update with closed issues
by Raymond Toy (＠rtoy) 04 Jun '24

04 Jun '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 2f9576c3 by Raymond Toy at 2024-06-03T21:02:42-07:00 Update with closed issues Forgot to add some closed issues with the merges that closed the issues. - - - - - 1 changed file: - src/general-info/release-21f.md Changes: ===================================== src/general-info/release-21f.md ===================================== @@ -30,7 +30,6 @@ public domain. * ANSI compliance fixes: * Bug fixes: * Gitlab tickets: - * * ~~#154~~ piglatin translation does not work anymore * ~~#171~~ Readably print `(make-pathname :name :unspecfic)` * ~~#180~~ Move `get-page-size` to C @@ -76,10 +75,12 @@ public domain. * ~~#297~~ Pprint `new-assem:assemble` with less indentation. * ~~#298~~ Add `with-float-rounding-mode` macro * ~~#299~~ Enable xoroshiro assembly routine + * ~~#312~~ Compiler error building motif server on Fedora 40 * ~~#314~~ tanh incorrect for large args * ~~#316~~ Support roundtrip character casing * ~~#320~~ Motif variant not defaulted for `x86_linux_clang` config * ~~#321~~ Rename Motif Config.x86 to Config.linux + * ~~#323~~ Make string casing functions compliant * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2f9576c33d38346f26cb72f… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2f9576c33d38346f26cb72f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #326: Cleanups for roundtrip casing
by Raymond Toy (＠rtoy) 04 Jun '24

04 Jun '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: db07d64f by Raymond Toy at 2024-06-04T03:52:11+00:00 Fix #326: Cleanups for roundtrip casing - - - - - 6b5da582 by Raymond Toy at 2024-06-04T03:52:16+00:00 Merge branch 'issue-326-char-casing-cleanup' into 'master' Fix #326: Cleanups for roundtrip casing Closes #326 See merge request cmucl/cmucl!225 - - - - - 4 changed files: - src/code/char.lisp - src/code/unicode.lisp - src/compiler/srctran.lisp - + tests/char.lisp Changes: ===================================== src/code/char.lisp ===================================== @@ -31,7 +31,6 @@ alphanumericp char= char/= char< char> char<= char>= char-equal char-not-equal char-lessp char-greaterp char-not-greaterp char-not-lessp character char-code code-char char-upcase - char-titlecase title-case-p char-downcase digit-char char-int char-name name-char codepoint-limit codepoint)) @@ -259,7 +258,7 @@ (declare (character char)) (and (typep char 'base-char) (let ((m (char-code (the base-char char)))) - (or (< 31 m 127) + (or (<= (char-code #\space ) m (char-code #\~)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (>= (unicode-category m) +unicode-category-graphic+)))))) @@ -270,7 +269,8 @@ argument is an alphabetic character; otherwise NIL." (declare (character char)) (let ((m (char-code char))) - (or (< 64 m 91) (< 96 m 123) + (or (<= (char-code #\A) m (char-code #\Z)) + (<= (char-code #\a) m (char-code #\z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (<= +unicode-category-letter+ (unicode-category m) @@ -282,7 +282,7 @@ argument is an upper-case character, NIL otherwise." (declare (character char)) (let ((m (char-code char))) - (or (< 64 m 91) + (or (<= (char-code #\A) m (char-code #\Z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (not (zerop (ldb +lower-case-entry+ (case-mapping-entry m)))))))) @@ -293,29 +293,19 @@ argument is a lower-case character, NIL otherwise." (declare (character char)) (let ((m (char-code char))) - (or (< 96 m 123) + (or (<= (char-code #\a) m (char-code #\z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (not (zerop (ldb +upper-case-entry+ (case-mapping-entry m)))))))) -(defun title-case-p (char) - "The argument must be a character object; title-case-p returns T if the - argument is a title-case character, NIL otherwise." - (declare (character char)) - (let ((m (char-code char))) - (or (< 64 m 91) - #+(and unicode (not unicode-bootstrap)) - (and (> m +ascii-limit+) - (= (unicode-category m) +unicode-category-title+))))) - - (defun both-case-p (char) "The argument must be a character object. Both-case-p returns T if the argument is an alphabetic character and if the character exists in both upper and lower case. For ASCII, this is the same as Alpha-char-p." (declare (character char)) (let ((m (char-code char))) - (or (< 64 m 91) (< 96 m 123) + (or (<= (char-code #\A) m (char-code #\Z)) + (<= (char-code #\a) m (char-code #\z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (not (zerop (case-mapping-entry m))))))) @@ -347,7 +337,9 @@ (declare (character char)) (let ((m (char-code char))) ;; Shortcut for ASCII digits and upper and lower case ASCII letters - (or (< 47 m 58) (< 64 m 91) (< 96 m 123) + (or (<= (char-code #\0) m (char-code #\9)) + (<= (char-code #\A) m (char-code #\Z)) + (<= (char-code #\a) m (char-code #\z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (<= +unicode-category-letter+ (unicode-category m) @@ -418,14 +410,14 @@ (defmacro equal-char-code (character) `(let ((ch (char-code ,character))) - ;; Handle ASCII separately for bootstrapping and for unidata missing. - (if (< 64 ch 91) - (+ ch 32) - #-(and unicode (not unicode-bootstrap)) - ch - #+(and unicode (not unicode-bootstrap)) - (if (> ch +ascii-limit+) (unicode-lower ch) ch)))) - + ;; Handle ASCII separately for bootstrapping. + (cond ((<= (char-code #\A) ch (char-code #\Z)) + (logxor ch #x20)) + #+(and unicode (not unicode-bootstrap)) + ((> ch +ascii-limit+) + (case-mapping-lower-case ch)) + (t + ch)))) (defun char-equal (character &rest more-characters) "Returns T if all of its arguments are the same character. @@ -504,19 +496,6 @@ (declare (character char)) (char-upcase char)) -(defun char-titlecase (char) - "Returns CHAR converted to title-case if that is possible." - (declare (character char)) - #-(and unicode (not unicode-bootstrap)) - (if (lower-case-p char) - (code-char (- (char-code char) 32)) - char) - #+(and unicode (not unicode-bootstrap)) - (let ((m (char-code char))) - (cond ((> m +ascii-limit+) (code-char (unicode-title m))) - ((< 96 m 123) (code-char (- m 32))) - (t char)))) - (defun char-downcase (char) "Returns CHAR converted to lower-case if that is possible." (declare (character char)) ===================================== src/code/unicode.lisp ===================================== @@ -488,6 +488,26 @@ (declare (ignore c)) (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) +(defun char-titlecase (char) + "Returns CHAR converted to title-case if that is possible." + (declare (character char)) + (let ((m (char-code char))) + (cond ((<= (char-code #\a) m (char-code #\z)) + (code-char (logxor m #x20))) + #+(and unicode (not unicode-bootstrap)) + ((> m +ascii-limit+) (code-char (unicode-title m))) + (t char)))) + +(defun title-case-p (char) + "The argument must be a character object; title-case-p returns T if the + argument is a title-case character, NIL otherwise." + (declare (character char)) + (let ((m (char-code char))) + (or (<= (code-char #\A) m (code-char #\Z)) + #+(and unicode (not unicode-bootstrap)) + (and (> m +ascii-limit+) + (= (unicode-category m) +unicode-category-title+))))) + (defun string-capitalize-unicode (string &key (start 0) end (casing :simple)) "Capitalize String using the Unicode word-break algorithm to find the words in String. The beginning is capitalized depending on the ===================================== src/compiler/srctran.lisp ===================================== @@ -3343,7 +3343,8 @@ x) #+(and unicode (not unicode-bootstrap)) '(let ((m (char-code x))) - (cond ((< 96 m 123) (code-char (- m 32))) + (cond ((<= (char-code #\a) m (char-code #\z)) + (code-char (logxor m #x20))) ((> m lisp::+ascii-limit+) (code-char (lisp::case-mapping-upper-case m))) (t x)))) @@ -3356,7 +3357,8 @@ x) #+(and unicode (not unicode-bootstrap)) '(let ((m (char-code x))) - (cond ((< 64 m 91) (code-char (+ m 32))) + (cond ((<= (char-code #\A) m (char-code #\Z)) + (code-char (logxor m #x20))) ((> m lisp::+ascii-limit+) (code-char (lisp::case-mapping-lower-case m))) (t x)))) ===================================== tests/char.lisp ===================================== @@ -0,0 +1,24 @@ +;; Tests of char functions + +(defpackage :char-tests + (:use :cl :lisp-unit)) + +(in-package "CHAR-TESTS") + +(define-test char-equal + (:tag :issues) + (let ((test-codes + ;; Find all the codes where the CL lower case character + ;; doesn't match the Unicode lower case character. + (loop for code from 128 below char-code-limit + for ch = (code-char code) + when (/= (char-code (char-downcase ch)) (or (lisp::unicode-lower code) code)) + collect code))) + (dolist (code test-codes) + ;; Verify that we convert to the CL lower case character instead + ;; of the Unicode lower case character for the cases where these + ;; are different. + (assert-false (char-equal (code-char (lisp::unicode-lower code)) + (code-char code)) + code + (lisp::unicode-lower code))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/57d5a21c20064990ff4717… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/57d5a21c20064990ff4717… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-326-char-casing-cleanup] More cleanup for char-titlecase and title-case-p
by Raymond Toy (＠rtoy) 04 Jun '24

04 Jun '24

Raymond Toy pushed to branch issue-326-char-casing-cleanup at cmucl / cmucl Commits: 41270e6b by Raymond Toy at 2024-06-03T19:46:29-07:00 More cleanup for char-titlecase and title-case-p Use inclusive limits for the range checks in these two functions. For `char-titlecase`, simplify the non-unicode and unicode parts together. And use `logxor` to flip the case. - - - - - 1 changed file: - src/code/unicode.lisp Changes: ===================================== src/code/unicode.lisp ===================================== @@ -401,15 +401,11 @@ (defun char-titlecase (char) "Returns CHAR converted to title-case if that is possible." (declare (character char)) - #-(and unicode (not unicode-bootstrap)) - (if (lower-case-p char) - (code-char (- (char-code char) 32)) - char) - #+(and unicode (not unicode-bootstrap)) (let ((m (char-code char))) - (cond ((> m +ascii-limit+) (code-char (unicode-title m))) - ((< (char-code #\`) m (char-code #\{)) - (code-char (- m 32))) + (cond ((<= (char-code #\a) m (char-code #\z)) + (code-char (logxor m #x20))) + #+(and unicode (not unicode-bootstrap)) + ((> m +ascii-limit+) (code-char (unicode-title m))) (t char)))) (defun title-case-p (char) @@ -417,7 +413,7 @@ argument is a title-case character, NIL otherwise." (declare (character char)) (let ((m (char-code char))) - (or (< 64 m 91) + (or (<= (code-char #\A) m (code-char #\Z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (= (unicode-category m) +unicode-category-title+))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/41270e6b15507c3493b4533… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/41270e6b15507c3493b4533… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-326-char-casing-cleanup] Use inclusive range for character ranges
by Raymond Toy (＠rtoy) 03 Jun '24

03 Jun '24

Raymond Toy pushed to branch issue-326-char-casing-cleanup at cmucl / cmucl Commits: 50f6079f by Raymond Toy at 2024-06-03T16:55:26-07:00 Use inclusive range for character ranges First, make the range checks be inclusive instead of exclusive to make it easier to reason about. Second, replace the character codes with the corresponding character so 64 becomes `(char-code #\A)`, which is much more obvious what the character is. - - - - - 2 changed files: - src/code/char.lisp - src/compiler/srctran.lisp Changes: ===================================== src/code/char.lisp ===================================== @@ -258,7 +258,7 @@ (declare (character char)) (and (typep char 'base-char) (let ((m (char-code (the base-char char)))) - (or (< 31 m 127) + (or (<= (char-code #\space ) m (char-code #\~)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (>= (unicode-category m) +unicode-category-graphic+)))))) @@ -269,7 +269,8 @@ argument is an alphabetic character; otherwise NIL." (declare (character char)) (let ((m (char-code char))) - (or (< 64 m 91) (< 96 m 123) + (or (<= (char-code #\A) m (char-code #\Z)) + (<= (char-code #\a) m (char-code #\z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (<= +unicode-category-letter+ (unicode-category m) @@ -281,7 +282,7 @@ argument is an upper-case character, NIL otherwise." (declare (character char)) (let ((m (char-code char))) - (or (< 64 m 91) + (or (<= (char-code #\A) m (char-code #\Z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (not (zerop (ldb +lower-case-entry+ (case-mapping-entry m)))))))) @@ -292,7 +293,7 @@ argument is a lower-case character, NIL otherwise." (declare (character char)) (let ((m (char-code char))) - (or (< 96 m 123) + (or (<= (char-code #\a) m (char-code #\z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (not (zerop (ldb +upper-case-entry+ (case-mapping-entry m)))))))) @@ -303,7 +304,8 @@ both upper and lower case. For ASCII, this is the same as Alpha-char-p." (declare (character char)) (let ((m (char-code char))) - (or (< 64 m 91) (< 96 m 123) + (or (<= (char-code #\A) m (char-code #\Z)) + (<= (char-code #\a) m (char-code #\z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (not (zerop (case-mapping-entry m))))))) @@ -335,7 +337,9 @@ (declare (character char)) (let ((m (char-code char))) ;; Shortcut for ASCII digits and upper and lower case ASCII letters - (or (< 47 m 58) (< 64 m 91) (< 96 m 123) + (or (<= (char-code #\0) m (char-code #\9)) + (<= (char-code #\A) m (char-code #\Z)) + (<= (char-code #\a) m (char-code #\z)) #+(and unicode (not unicode-bootstrap)) (and (> m +ascii-limit+) (<= +unicode-category-letter+ (unicode-category m) ===================================== src/compiler/srctran.lisp ===================================== @@ -3343,7 +3343,7 @@ x) #+(and unicode (not unicode-bootstrap)) '(let ((m (char-code x))) - (cond ((< (char-code #\`) m (char-code #\{)) + (cond ((<= (char-code #\a) m (char-code #\z)) (code-char (logxor m #x20))) ((> m lisp::+ascii-limit+) (code-char (lisp::case-mapping-upper-case m))) @@ -3357,7 +3357,7 @@ x) #+(and unicode (not unicode-bootstrap)) '(let ((m (char-code x))) - (cond ((< (char-code #\@) m (char-code #\[)) + (cond ((<= (char-code #\A) m (char-code #\Z)) (code-char (logxor m #x20))) ((> m lisp::+ascii-limit+) (code-char (lisp::case-mapping-lower-case m))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/50f6079f8e180a096d33025… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/50f6079f8e180a096d33025… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-326-char-casing-cleanup] Move char-titlecase and title-case-p to unicode.lisp
by Raymond Toy (＠rtoy) 03 Jun '24

03 Jun '24

Raymond Toy pushed to branch issue-326-char-casing-cleanup at cmucl / cmucl Commits: ad7b90b0 by Raymond Toy at 2024-06-03T16:16:56-07:00 Move char-titlecase and title-case-p to unicode.lisp These aren't needed for CL casing functions, so just move them as is to unicode.lisp, where they are used. - - - - - 2 changed files: - src/code/char.lisp - src/code/unicode.lisp Changes: ===================================== src/code/char.lisp ===================================== @@ -31,7 +31,6 @@ alphanumericp char= char/= char< char> char<= char>= char-equal char-not-equal char-lessp char-greaterp char-not-greaterp char-not-lessp character char-code code-char char-upcase - char-titlecase title-case-p char-downcase digit-char char-int char-name name-char codepoint-limit codepoint)) @@ -298,17 +297,6 @@ (and (> m +ascii-limit+) (not (zerop (ldb +upper-case-entry+ (case-mapping-entry m)))))))) -(defun title-case-p (char) - "The argument must be a character object; title-case-p returns T if the - argument is a title-case character, NIL otherwise." - (declare (character char)) - (let ((m (char-code char))) - (or (< 64 m 91) - #+(and unicode (not unicode-bootstrap)) - (and (> m +ascii-limit+) - (= (unicode-category m) +unicode-category-title+))))) - - (defun both-case-p (char) "The argument must be a character object. Both-case-p returns T if the argument is an alphabetic character and if the character exists in @@ -504,20 +492,6 @@ (declare (character char)) (char-upcase char)) -(defun char-titlecase (char) - "Returns CHAR converted to title-case if that is possible." - (declare (character char)) - #-(and unicode (not unicode-bootstrap)) - (if (lower-case-p char) - (code-char (- (char-code char) 32)) - char) - #+(and unicode (not unicode-bootstrap)) - (let ((m (char-code char))) - (cond ((> m +ascii-limit+) (code-char (unicode-title m))) - ((< (char-code #\`) m (char-code #\{)) - (code-char (- m 32))) - (t char)))) - (defun char-downcase (char) "Returns CHAR converted to lower-case if that is possible." (declare (character char)) ===================================== src/code/unicode.lisp ===================================== @@ -398,6 +398,30 @@ (declare (ignore c)) (lookup (+ i (if (eql widep 1) 2 1)) (left-context i)))))))) +(defun char-titlecase (char) + "Returns CHAR converted to title-case if that is possible." + (declare (character char)) + #-(and unicode (not unicode-bootstrap)) + (if (lower-case-p char) + (code-char (- (char-code char) 32)) + char) + #+(and unicode (not unicode-bootstrap)) + (let ((m (char-code char))) + (cond ((> m +ascii-limit+) (code-char (unicode-title m))) + ((< (char-code #\`) m (char-code #\{)) + (code-char (- m 32))) + (t char)))) + +(defun title-case-p (char) + "The argument must be a character object; title-case-p returns T if the + argument is a title-case character, NIL otherwise." + (declare (character char)) + (let ((m (char-code char))) + (or (< 64 m 91) + #+(and unicode (not unicode-bootstrap)) + (and (> m +ascii-limit+) + (= (unicode-category m) +unicode-category-title+))))) + (defun string-capitalize-unicode (string &key (start 0) end (casing :simple)) "Capitalize String using the Unicode word-break algorithm to find the words in String. The beginning is capitalized depending on the View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ad7b90b066dd137718e0ce4… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ad7b90b066dd137718e0ce4… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-326-char-casing-cleanup] 4 commits: Fix typo in the lower limit for char-upcase.
by Raymond Toy (＠rtoy) 03 Jun '24

03 Jun '24

Raymond Toy pushed to branch issue-326-char-casing-cleanup at cmucl / cmucl Commits: b8887cd6 by Raymond Toy at 2024-06-03T14:38:08-07:00 Fix typo in the lower limit for char-upcase. We use a lower limit of `#\a`, but we really should have used `#\``. - - - - - e4a3d3b5 by Raymond Toy at 2024-06-03T15:59:09-07:00 Fix equal-char-code to use CL lowercase Previously, `equal-char-code` used the Unicode function `unicode-lower` to convert the character to lower case. That's not what we want; we want to use the CL lower case character. Thus, use `case-mapping-lower-case` to get the desired character code. Add a test for `char-equal` that shows we've fixed this. - - - - - c3e7e0b4 by Raymond Toy at 2024-06-03T16:11:47-07:00 Simplify equal-char-code as suggested. Replace the nested `if`'s with a `cond`. Change the bounds to be inclusive to make it easier to reason about the range of characters. - - - - - 7c711f4f by Raymond Toy at 2024-06-03T16:12:48-07:00 Fix a typo and add a comment. - - - - - 3 changed files: - src/code/char.lisp - src/compiler/srctran.lisp - + tests/char.lisp Changes: ===================================== src/code/char.lisp ===================================== @@ -418,14 +418,14 @@ (defmacro equal-char-code (character) `(let ((ch (char-code ,character))) - ;; Handle ASCII separately for bootstrapping and for unidata missing. - (if (< (char-code #\@) ch (char-code #\[)) - (+ ch 32) - #-(and unicode (not unicode-bootstrap)) - ch - #+(and unicode (not unicode-bootstrap)) - (if (> ch +ascii-limit+) (unicode-lower ch) ch)))) - + ;; Handle ASCII separately for bootstrapping. + (cond ((<= (char-code #\A) ch (char-code #\Z)) + (logxor ch #x20)) + #+(and unicode (not unicode-bootstrap)) + ((> ch +ascii-limit+) + (case-mapping-lower-case ch)) + (t + ch)))) (defun char-equal (character &rest more-characters) "Returns T if all of its arguments are the same character. ===================================== src/compiler/srctran.lisp ===================================== @@ -3343,7 +3343,7 @@ x) #+(and unicode (not unicode-bootstrap)) '(let ((m (char-code x))) - (cond ((< (char-code #\a) m (char-code #\{)) + (cond ((< (char-code #\`) m (char-code #\{)) (code-char (logxor m #x20))) ((> m lisp::+ascii-limit+) (code-char (lisp::case-mapping-upper-case m))) ===================================== tests/char.lisp ===================================== @@ -0,0 +1,24 @@ +;; Tests of char functions + +(defpackage :char-tests + (:use :cl :lisp-unit)) + +(in-package "CHAR-TESTS") + +(define-test char-equal + (:tag :issues) + (let ((test-codes + ;; Find all the codes where the CL lower case character + ;; doesn't match the Unicode lower case character. + (loop for code from 128 below char-code-limit + for ch = (code-char code) + when (/= (char-code (char-downcase ch)) (or (lisp::unicode-lower code) code)) + collect code))) + (dolist (code test-codes) + ;; Verify that we convert to the CL lower case character instead + ;; of the Unicode lower case character for the cases where these + ;; are different. + (assert-false (char-equal (code-char (lisp::unicode-lower code)) + (code-char code)) + code + (lisp::unicode-lower code))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ca36c16321c2028784aaa3… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ca36c16321c2028784aaa3… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #323: CL string casing
by Raymond Toy (＠rtoy) 03 Jun '24

03 Jun '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 535f7e5d by Raymond Toy at 2024-06-03T23:07:07+00:00 Fix #323: CL string casing - - - - - 57d5a21c by Raymond Toy at 2024-06-03T23:07:12+00:00 Merge branch 'issue-323-cl-string-casing' into 'master' Fix #323: CL string casing Closes #323 See merge request cmucl/cmucl!224 - - - - - 5 changed files: - src/code/string.lisp - src/code/unicode.lisp - src/i18n/locale/cmucl.pot - tests/string.lisp - tests/unicode.lisp Changes: ===================================== src/code/string.lisp ===================================== @@ -638,27 +638,14 @@ (new-index (- start offset) (1+ new-index))) ((= index (the fixnum end))) (declare (fixnum index new-index)) - (multiple-value-bind (code wide) (codepoint string index) - (when wide (incf index)) - ;; Use char-upcase if it's not a surrogate pair so that - ;; we're always consist. - (if wide - (setq code (unicode-upper code)) - (setf code (char-code (char-upcase (code-char code))))) - ;;@@ WARNING: this may, in theory, need to extend newstring - ;; but that never actually occurs as of Unicode 5.1.0, - ;; so I'm just going to ignore it for now... - (multiple-value-bind (hi lo) (surrogates code) - (setf (schar newstring new-index) hi) - (when lo - (setf (schar newstring (incf new-index)) lo))))) - ;;@@ WARNING: see above - (do ((index end (1+ index)) + (setf (schar newstring new-index) + (char-upcase (schar string index)))) + (do ((index end (1+ index)) (new-index (- (the fixnum end) offset) (1+ new-index))) ((= index offset-slen)) (declare (fixnum index new-index)) (setf (schar newstring new-index) (schar string index))) - newstring)))) + newstring)))) (defun string-downcase (string &key (start 0) end) _N"Given a string, returns a new string that is a copy of it with all @@ -680,64 +667,8 @@ (new-index (- start offset) (1+ new-index))) ((= index (the fixnum end))) (declare (fixnum index new-index)) - (multiple-value-bind (code wide) (codepoint string index) - (when wide (incf index)) - ;; Use char-downcase if it's not a surrogate pair so that - ;; we're always consist. - (if wide - (setq code (unicode-lower code)) - (setq code (char-code (char-downcase (code-char code))))) - ;;@@ WARNING: this may, in theory, need to extend newstring - ;; but that never actually occurs as of Unicode 5.1.0, - ;; so I'm just going to ignore it for now... - (multiple-value-bind (hi lo) (surrogates code) - (setf (schar newstring new-index) hi) - (when lo - (setf (schar newstring (incf new-index)) lo))))) - ;;@@ WARNING: see above - (do ((index end (1+ index)) - (new-index (- (the fixnum end) offset) (1+ new-index))) - ((= index offset-slen)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - newstring)))) - -#+nil -(defun string-capitalize (string &key (start 0) end) - _N"Given a string, returns a copy of the string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. A ``word'' is defined - to be a string of case-modifiable characters delimited by - non-case-modifiable chars." - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset)) - (newstring (make-string slen))) - (declare (fixnum offset-slen)) - (do ((index offset (1+ index)) - (new-index 0 (1+ new-index))) - ((= index start)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - (do ((index start (1+ index)) - (new-index (- start offset) (1+ new-index)) - (newword t) - (char ())) - ((= index (the fixnum end))) - (declare (fixnum index new-index)) - (setq char (schar string index)) - (cond ((not (alphanumericp char)) - (setq newword t)) - (newword - ;;char is first case-modifiable after non-case-modifiable - (setq char (char-titlecase char)) - (setq newword ())) - ;;char is case-modifiable, but not first - (t (setq char (char-downcase char)))) - (setf (schar newstring new-index) char)) + (setf (schar newstring new-index) + (char-downcase (schar string index)))) (do ((index end (1+ index)) (new-index (- (the fixnum end) offset) (1+ new-index))) ((= index offset-slen)) @@ -796,20 +727,9 @@ (do ((index start (1+ index))) ((= index (the fixnum end))) (declare (fixnum index)) - (multiple-value-bind (code wide) (codepoint string index) - (if wide - (setq code (unicode-upper code)) - (setf code (char-code (char-upcase (code-char code))))) - ;;@@ WARNING: this may, in theory, need to extend string - ;; (which, obviously, we can't do here. Unless - ;; STRING is adjustable, maybe) - ;; but that never actually occurs as of Unicode 5.1.0, - ;; so I'm just going to ignore it for now... - (multiple-value-bind (hi lo) (surrogates code) - (setf (schar string index) hi) - (when lo - (setf (schar string (incf index)) lo)))))) - save-header)) + (setf (schar string index) + (char-upcase (schar string index)))) + save-header))) (defun nstring-downcase (string &key (start 0) end) _N"Given a string, returns that string with all upper case alphabetic @@ -820,45 +740,8 @@ (do ((index start (1+ index))) ((= index (the fixnum end))) (declare (fixnum index)) - (multiple-value-bind (code wide) (codepoint string index) - (if wide - (setq code (unicode-lower code)) - (setf code (char-code (char-downcase (code-char code))))) - ;;@@ WARNING: this may, in theory, need to extend string - ;; (which, obviously, we can't do here. Unless - ;; STRING is adjustable, maybe) - ;; but that never actually occurs as of Unicode 5.1.0, - ;; so I'm just going to ignore it for now... - (multiple-value-bind (hi lo) (surrogates code) - (setf (schar string index) hi) - (when lo - (setf (schar string (incf index)) lo)))))) - save-header)) - -#+nil -(defun nstring-capitalize (string &key (start 0) end) - "Given a string, returns that string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. A ``word'' is defined - to be a string of case-modifiable characters delimited by - non-case-modifiable chars." - (declare (fixnum start)) - (let ((save-header string)) - (with-one-string string start end offset - (do ((index start (1+ index)) - (newword t) - (char ())) - ((= index (the fixnum end))) - (declare (fixnum index)) - (setq char (schar string index)) - (cond ((not (alphanumericp char)) - (setq newword t)) - (newword - ;;char is first case-modifiable after non-case-modifiable - (setf (schar string index) (char-titlecase char)) - (setq newword ())) - (t - (setf (schar string index) (char-downcase char)))))) + (setf (schar string index) + (char-downcase (schar string index))))) save-header)) (defun nstring-capitalize (string &key (start 0) end) ===================================== src/code/unicode.lisp ===================================== @@ -17,14 +17,57 @@ (in-package "UNICODE") (intl:textdomain "cmucl") +(defun string-upcase-simple (string &key (start 0) end) + _N"Given a string, returns a new string that is a copy of it with all + lower case alphabetic characters converted to uppercase." + (declare (fixnum start)) + (let* ((string (string string)) + (slen (length string))) + (declare (fixnum slen)) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset)) + (newstring (make-string slen))) + (declare (fixnum offset-slen)) + (do ((index offset (1+ index)) + (new-index 0 (1+ new-index))) + ((= index start)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + (do ((index start (1+ index)) + (new-index (- start offset) (1+ new-index))) + ((= index (the fixnum end))) + (declare (fixnum index new-index)) + (multiple-value-bind (code wide) (codepoint string index) + (when wide (incf index)) + ;; Use char-upcase if it's not a surrogate pair so that + ;; we're always consist. + (if wide + (setq code (unicode-upper code)) + (setf code (char-code (char-upcase (code-char code))))) + ;;@@ WARNING: this may, in theory, need to extend newstring + ;; but that never actually occurs as of Unicode 5.1.0, + ;; so I'm just going to ignore it for now... + (multiple-value-bind (hi lo) (surrogates code) + (setf (schar newstring new-index) hi) + (when lo + (setf (schar newstring (incf new-index)) lo))))) + ;;@@ WARNING: see above + (do ((index end (1+ index)) + (new-index (- (the fixnum end) offset) (1+ new-index))) + ((= index offset-slen)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + newstring)))) + + ;; An example where this differs from cl:string-upcase differ: ;; #\Latin_Small_Letter_Sharp_S (defun string-upcase-full (string &key (start 0) end) _N"Given a string, returns a new string that is a copy of it with all lower case alphabetic characters converted to uppercase using full case conversion." - (declare (fixnum start)) (let* ((string (if - (stringp string) string (string string))) + (declare (fixnum start)) + (let* ((string (string string)) (slen (length string))) (declare (fixnum slen)) (with-output-to-string (s) @@ -57,11 +100,55 @@ all lower case alphabetic characters converted to uppercase. Casing is :simple or :full for simple or full case conversion, respectively." - (declare (fixnum start)) - (if (eq casing :simple) - (cl:string-upcase string :start start :end end) - (string-upcase-full string :start start :end end))) + (declare (fixnum start) + (type (member :simple :full) casing)) + (ecase casing + (:simple + (string-upcase-simple string :start start :end end)) + (:full + (string-upcase-full string :start start :end end)))) +(defun string-downcase-simple (string &key (start 0) end) + _N"Given a string, returns a new string that is a copy of it with all + upper case alphabetic characters converted to lowercase." + (declare (fixnum start)) + (let* ((string (if (stringp string) string (string string))) + (slen (length string))) + (declare (fixnum slen)) + (lisp::with-one-string string start end offset + (let ((offset-slen (+ slen offset)) + (newstring (make-string slen))) + (declare (fixnum offset-slen)) + (do ((index offset (1+ index)) + (new-index 0 (1+ new-index))) + ((= index start)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + (do ((index start (1+ index)) + (new-index (- start offset) (1+ new-index))) + ((= index (the fixnum end))) + (declare (fixnum index new-index)) + (multiple-value-bind (code wide) (codepoint string index) + (when wide (incf index)) + ;; Use char-downcase if it's not a surrogate pair so that + ;; we're always consist. + (if wide + (setq code (unicode-lower code)) + (setq code (char-code (char-downcase (code-char code))))) + ;;@@ WARNING: this may, in theory, need to extend newstring + ;; but that never actually occurs as of Unicode 5.1.0, + ;; so I'm just going to ignore it for now... + (multiple-value-bind (hi lo) (surrogates code) + (setf (schar newstring new-index) hi) + (when lo + (setf (schar newstring (incf new-index)) lo))))) + ;;@@ WARNING: see above + (do ((index end (1+ index)) + (new-index (- (the fixnum end) offset) (1+ new-index))) + ((= index offset-slen)) + (declare (fixnum index new-index)) + (setf (schar newstring new-index) (schar string index))) + newstring)))) ;; An example this differs from cl:string-downcase: ;; #\Latin_Capital_Letter_I_With_Dot_Above. @@ -104,10 +191,13 @@ uppercase alphabetic characters converted to lowercase. Casing is :simple or :full for simple or full case conversion, respectively." - (declare (fixnum start)) - (if (eq casing :simple) - (cl:string-downcase string :start start :end end) - (string-downcase-full string :start start :end end))) + (declare (fixnum start) + (type (member :simple :full) casing)) + (ecase casing + (:simple + (string-downcase-simple string :start start :end end)) + (:full + (string-downcase-full string :start start :end end)))) ;;; @@ -553,12 +643,14 @@ delimited by non-case-modifiable chars. " (declare (fixnum start) - (type (member :simple :full :title) casing)) + (type (member :simple-title :simple :full :title) casing)) (if unicode-word-break (string-capitalize-unicode string :start start :end end :casing casing) - (if (eq casing :simple) - (string-capitalize-simple string :start start :end end) - (string-capitalize-full string :start start :end end :casing casing)))) + (ecase casing + (:simple-title + (string-capitalize-simple string :start start :end end)) + ((:simple :full :title) + (string-capitalize-full string :start start :end end :casing casing))))) (defun decompose-hangul-syllable (cp stream) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3880,13 +3880,13 @@ msgid "" " a new string Count long filled with the fill character." msgstr "" -#: src/code/string.lisp +#: src/code/unicode.lisp src/code/string.lisp msgid "" "Given a string, returns a new string that is a copy of it with all\n" " lower case alphabetic characters converted to uppercase." msgstr "" -#: src/code/string.lisp +#: src/code/unicode.lisp src/code/string.lisp msgid "" "Given a string, returns a new string that is a copy of it with all\n" " upper case alphabetic characters converted to lowercase." ===================================== tests/string.lisp ===================================== @@ -8,11 +8,10 @@ (defun make-test-string () ;; Create a string consisting of all the code units EXCEPT for the ;; surrogates because string casing handles that differently. - (coerce - (loop for code from 0 to #xffff - unless (lisp::surrogatep code) - collect (code-char code)) - 'string)) + (let ((s (make-string char-code-limit))) + (dotimes (k char-code-limit) + (setf (aref s k) (code-char k))) + s)) (define-test string-upcase (:tag :issues) @@ -62,32 +61,33 @@ (define-test string-capitalize (:tag :issues) - (let* ((s - ;; This string contains a couple of characters where - ;; Unicode has a titlecase version of the character. We - ;; want to make sure we use char-upcase to capitalize the - ;; string instead of lisp::char-titlecse - (coerce - '(#\Latin_Small_Letter_Dz - #\a #\b - #\space - #\Latin_Small_Letter_Lj - #\A #\B) - 'string)) + (let* ((s (string-capitalize + ;; #\Latin_Small_Letter_Dz and #\Latin_Small_Letter_Lj + ;; #have Unicode titlecase characters that differ from + ;; CHAR-UPCASE. This tests that STRING-CAPITALIZE use + ;; CHAR-UPCASE to produce the capitalization. + (coerce + '(#\Latin_Small_Letter_Dz + #\a #\b + #\space + #\Latin_Small_Letter_Lj + #\A #\B) + 'string))) (expected - ;; Manually convert S to a capitalized string using - ;; char-upcase/downcase. - (map 'string - #'(lambda (ch f) - (funcall f ch)) + ;; Manually convert the test string by calling CHAR-UPCASE + ;; or CHAR-DOWNCASE (or IDENTITY) to get the desired + ;; capitalized string. + (map 'list + #'(lambda (c f) + (funcall f c)) s (list #'char-upcase #'char-downcase #'char-downcase - #'char-downcase + #'identity #'char-upcase #'char-downcase #'char-downcase)))) (assert-equal (map 'list #'char-name expected) - (map 'list #'char-name (string-capitalize s))))) + (map 'list #'char-name s)))) ===================================== tests/unicode.lisp ===================================== @@ -192,3 +192,19 @@ computed-breaks))) (assert-equalp b (do-test s))))))))) + +(define-test unicode.case-extend + "Test that Unicode never produces an upper or lower case character + outside the BMP for a character in the BMP" + (:tag :unicode) + ;; For each character code (that isn't a surrogate), find the + ;; corresponding Unicode upper and lowe case character. Verify that + ;; this character is in the BMP. + (loop for code from 0 below char-code-limit + unless (lisp::surrogatep code) + do + (assert-true (< (lisp::unicode-upper code) char-code-limit) + code (lisp::unicode-upper code)) + (assert-true (< (lisp::unicode-lower code) char-code-limit) + code (lisp::unicode-upper code)))) + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b71c090704bec10890c7df… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/b71c090704bec10890c7df… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-323-cl-string-casing] Remove the old versions of string-capitalize and nstring-capitalize
by Raymond Toy (＠rtoy) 03 Jun '24

03 Jun '24

Raymond Toy pushed to branch issue-323-cl-string-casing at cmucl / cmucl Commits: 6d72fb36 by Raymond Toy at 2024-06-03T14:39:51-07:00 Remove the old versions of string-capitalize and nstring-capitalize Forgot to remove these when they were moved to unicode.lisp. - - - - - 1 changed file: - src/code/string.lisp Changes: ===================================== src/code/string.lisp ===================================== @@ -676,49 +676,6 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+nil -(defun string-capitalize (string &key (start 0) end) - _N"Given a string, returns a copy of the string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. A ``word'' is defined - to be a string of case-modifiable characters delimited by - non-case-modifiable chars." - (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) - (slen (length string))) - (declare (fixnum slen)) - (with-one-string string start end offset - (let ((offset-slen (+ slen offset)) - (newstring (make-string slen))) - (declare (fixnum offset-slen)) - (do ((index offset (1+ index)) - (new-index 0 (1+ new-index))) - ((= index start)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - (do ((index start (1+ index)) - (new-index (- start offset) (1+ new-index)) - (newword t) - (char ())) - ((= index (the fixnum end))) - (declare (fixnum index new-index)) - (setq char (schar string index)) - (cond ((not (alphanumericp char)) - (setq newword t)) - (newword - ;;char is first case-modifiable after non-case-modifiable - (setq char (char-upcase char)) - (setq newword ())) - ;;char is case-modifiable, but not first - (t (setq char (char-downcase char)))) - (setf (schar newstring new-index) char)) - (do ((index end (1+ index)) - (new-index (- (the fixnum end) offset) (1+ new-index))) - ((= index offset-slen)) - (declare (fixnum index new-index)) - (setf (schar newstring new-index) (schar string index))) - newstring)))) - (defun string-capitalize (string &key (start 0) end) _N"Given a string, returns a copy of the string with the first character of each ``word'' converted to upper-case, and remaining @@ -787,32 +744,6 @@ (char-downcase (schar string index))))) save-header)) -#+nil -(defun nstring-capitalize (string &key (start 0) end) - "Given a string, returns that string with the first - character of each ``word'' converted to upper-case, and remaining - chars in the word converted to lower case. A ``word'' is defined - to be a string of case-modifiable characters delimited by - non-case-modifiable chars." - (declare (fixnum start)) - (let ((save-header string)) - (with-one-string string start end offset - (do ((index start (1+ index)) - (newword t) - (char ())) - ((= index (the fixnum end))) - (declare (fixnum index)) - (setq char (schar string index)) - (cond ((not (alphanumericp char)) - (setq newword t)) - (newword - ;;char is first case-modifiable after non-case-modifiable - (setf (schar string index) (char-titlecase char)) - (setq newword ())) - (t - (setf (schar string index) (char-downcase char)))))) - save-header)) - (defun nstring-capitalize (string &key (start 0) end) _N"Given a string, returns that string with the first character of each ``word'' converted to upper-case, and remaining View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6d72fb364f0f2f84aaf97d2… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6d72fb364f0f2f84aaf97d2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-326-char-casing-cleanup
by Raymond Toy (＠rtoy) 03 Jun '24

03 Jun '24

Raymond Toy pushed new branch issue-326-char-casing-cleanup at cmucl / cmucl -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-326-char-casing-cle… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-323-cl-string-casing] More cleanups
by Raymond Toy (＠rtoy) 03 Jun '24

03 Jun '24

Raymond Toy pushed to branch issue-323-cl-string-casing at cmucl / cmucl Commits: e3862c75 by Raymond Toy at 2024-06-03T09:58:23-07:00 More cleanups Just use simple `(string string)` instead of doing a test for `stringp`. Fix bad formatting in `string-upcase-full`. Use `ecase` as needed and also add declarations to it clearer to the compiler what the acceptable arguments are. Also, we were confused on what `string-capitalize-simple` does compared to `string-capitalize-full`. We call `string-capitalize-simple` if the `casing` arg is `:simple-title` instead of `:simple`, which should call `string-capitalize-full`. - - - - - 1 changed file: - src/code/unicode.lisp Changes: ===================================== src/code/unicode.lisp ===================================== @@ -21,7 +21,7 @@ _N"Given a string, returns a new string that is a copy of it with all lower case alphabetic characters converted to uppercase." (declare (fixnum start)) - (let* ((string (if (stringp string) string (string string))) + (let* ((string (string string)) (slen (length string))) (declare (fixnum slen)) (lisp::with-one-string string start end offset @@ -66,8 +66,8 @@ _N"Given a string, returns a new string that is a copy of it with all lower case alphabetic characters converted to uppercase using full case conversion." - (declare (fixnum start)) (let* ((string (if - (stringp string) string (string string))) + (declare (fixnum start)) + (let* ((string (string string)) (slen (length string))) (declare (fixnum slen)) (with-output-to-string (s) @@ -100,10 +100,13 @@ all lower case alphabetic characters converted to uppercase. Casing is :simple or :full for simple or full case conversion, respectively." - (declare (fixnum start)) - (if (eq casing :simple) - (string-upcase-simple string :start start :end end) - (string-upcase-full string :start start :end end))) + (declare (fixnum start) + (type (member :simple :full) casing)) + (ecase casing + (:simple + (string-upcase-simple string :start start :end end)) + (:full + (string-upcase-full string :start start :end end)))) (defun string-downcase-simple (string &key (start 0) end) _N"Given a string, returns a new string that is a copy of it with all @@ -188,10 +191,13 @@ uppercase alphabetic characters converted to lowercase. Casing is :simple or :full for simple or full case conversion, respectively." - (declare (fixnum start)) - (if (eq casing :simple) - (string-downcase-simple string :start start :end end) - (string-downcase-full string :start start :end end))) + (declare (fixnum start) + (type (member :simple :full) casing)) + (ecase casing + (:simple + (string-downcase-simple string :start start :end end)) + (:full + (string-downcase-full string :start start :end end)))) ;;; @@ -637,12 +643,14 @@ delimited by non-case-modifiable chars. " (declare (fixnum start) - (type (member :simple :full :title) casing)) + (type (member :simple-title :simple :full :title) casing)) (if unicode-word-break (string-capitalize-unicode string :start start :end end :casing casing) - (if (eq casing :simple) - (string-capitalize-simple string :start start :end end) - (string-capitalize-full string :start start :end end :casing casing)))) + (ecase casing + (:simple-title + (string-capitalize-simple string :start start :end end)) + ((:simple :full :title) + (string-capitalize-full string :start start :end end :casing casing))))) (defun decompose-hangul-syllable (cp stream) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e3862c755851d5df523f922… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/e3862c755851d5df523f922… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0