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

[Git][cmucl/cmucl][issue-323-cl-string-casing] 2 commits: Add test that a BMP character has an upper/lower case in the BMP.
by Raymond Toy (＠rtoy) 03 Jun '24

03 Jun '24

Raymond Toy pushed to branch issue-323-cl-string-casing at cmucl / cmucl Commits: c9c599f7 by Raymond Toy at 2024-06-03T08:44:43-07:00 Add test that a BMP character has an upper/lower case in the BMP. - - - - - e2e20bc2 by Raymond Toy at 2024-06-03T08:45:16-07:00 Fix typo in name of string-downcase-simpl It should be `string-downcase-simple`. - - - - - 2 changed files: - src/code/unicode.lisp - tests/unicode.lisp Changes: ===================================== src/code/unicode.lisp ===================================== @@ -105,7 +105,7 @@ (string-upcase-simple string :start start :end end) (string-upcase-full string :start start :end end))) -(defun string-downcase-simpl (string &key (start 0) 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)) ===================================== 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/e6ef0eacc569fbad7f87a5… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/e6ef0eacc569fbad7f87a5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-323-cl-string-casing] 3 commits: Update release notes for newly closed issues
by Raymond Toy (＠rtoy) 02 Jun '24

02 Jun '24

Raymond Toy pushed to branch issue-323-cl-string-casing at cmucl / cmucl Commits: 50395287 by Raymond Toy at 2024-05-31T08:28:43-07:00 Update release notes for newly closed issues Forgot to add these in the MRs that closed the issues. - - - - - 5a037b19 by Raymond Toy at 2024-05-31T08:56:12-07:00 String-capitalize should use char-upcase, not lisp:char-titlecase We were using lisp:;char-titlecase to capitalize the string, but we really should use char-upcase. However, to preserve this functionality, we moved the functions to the `unicode` package. Added a test for this. - - - - - e6ef0eac by Raymond Toy at 2024-06-01T18:27:19-07:00 Merge branch 'master' into issue-323-cl-string-casing - - - - - 3 changed files: - src/code/string.lisp - src/code/unicode.lisp - src/general-info/release-21f.md Changes: ===================================== src/code/string.lisp ===================================== @@ -676,6 +676,49 @@ (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 @@ -719,7 +762,7 @@ newstring)))) (defun nstring-upcase (string &key (start 0) end) - "Given a string, returns that string with all lower case alphabetic + _N"Given a string, returns that string with all lower case alphabetic characters converted to uppercase." (declare (fixnum start)) (let ((save-header string)) @@ -732,7 +775,7 @@ save-header))) (defun nstring-downcase (string &key (start 0) end) - "Given a string, returns that string with all upper case alphabetic + _N"Given a string, returns that string with all upper case alphabetic characters converted to lowercase." (declare (fixnum start)) (let ((save-header string)) @@ -744,6 +787,7 @@ (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 @@ -769,6 +813,31 @@ (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 + 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-upcase char)) + (setq newword ())) + (t + (setf (schar string index) (char-downcase char)))))) + save-header)) + #+unicode (progn ===================================== src/code/unicode.lisp ===================================== @@ -641,7 +641,7 @@ (if unicode-word-break (string-capitalize-unicode string :start start :end end :casing casing) (if (eq casing :simple) - (cl:string-capitalize-simple string :start start :end end) + (string-capitalize-simple string :start start :end end) (string-capitalize-full string :start start :end end :casing casing)))) ===================================== src/general-info/release-21f.md ===================================== @@ -77,6 +77,9 @@ public domain. * ~~#298~~ Add `with-float-rounding-mode` macro * ~~#299~~ Enable xoroshiro assembly routine * ~~#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 * 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/163cafa40fb099dc30b798… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/163cafa40fb099dc30b798… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-323-cl-string-casing] 2 commits: CL-compliant string-capitalize
by Raymond Toy (＠rtoy) 31 May '24

31 May '24

Raymond Toy pushed to branch issue-323-cl-string-casing at cmucl / cmucl Commits: 3557fc31 by Raymond Toy at 2024-05-31T16:20:11-07:00 CL-compliant string-capitalize Previously, when we capitalized a word, we used the titlecase. However it should be upper case. Make it so, but move the original implementation to unicode.lisp. Add a test that we do use uppercase instead of titlecase. - - - - - 163cafa4 by Raymond Toy at 2024-05-31T16:23:13-07:00 Rename string-capitalize to string-capitalize-simple. Forgot to rename the old version so it's clear it's not CL string-capitalize. Also call it in unicode:string-capitalize when the casing is simple. - - - - - 4 changed files: - src/code/string.lisp - src/code/unicode.lisp - src/i18n/locale/cmucl.pot - tests/string.lisp Changes: ===================================== src/code/string.lisp ===================================== @@ -706,7 +706,7 @@ (setq newword t)) (newword ;;char is first case-modifiable after non-case-modifiable - (setq char (char-titlecase char)) + (setq char (char-upcase char)) (setq newword ())) ;;char is case-modifiable, but not first (t (setq char (char-downcase char)))) ===================================== src/code/unicode.lisp ===================================== @@ -525,6 +525,48 @@ :end next))) (write-string string result :start end :end offset-slen)))))) +(defun string-capitalize-simple (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)) + (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-full (string &key (start 0) end (casing :full)) "Capitalize String using the Common Lisp word-break algorithm to find the words in String. The beginning is capitalized depending on the @@ -599,7 +641,7 @@ (if unicode-word-break (string-capitalize-unicode string :start start :end end :casing casing) (if (eq casing :simple) - (cl:string-capitalize string :start start :end end) + (cl:string-capitalize-simple string :start start :end end) (string-capitalize-full string :start start :end end :casing casing)))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3892,7 +3892,7 @@ msgid "" " upper case alphabetic characters converted to lowercase." msgstr "" -#: src/code/string.lisp +#: src/code/unicode.lisp src/code/string.lisp msgid "" "Given a string, returns a copy of the string with the first\n" " character of each ``word'' converted to upper-case, and remaining\n" ===================================== tests/string.lisp ===================================== @@ -58,3 +58,36 @@ when (char/= actual (char-downcase expected)) collect (list (char-downcase expected) (char-code actual)))))) + +(define-test string-capitalize + (:tag :issues) + (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 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 + #'identity + #'char-upcase + #'char-downcase + #'char-downcase)))) + (assert-equal + (map 'list #'char-name expected) + (map 'list #'char-name s)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/483dfe3999bd7db0cee36e… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/483dfe3999bd7db0cee36e… 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 old versions of {n}string-{upcase,downcase}
by Raymond Toy (＠rtoy) 31 May '24

31 May '24

Raymond Toy pushed to branch issue-323-cl-string-casing at cmucl / cmucl Commits: 483dfe39 by Raymond Toy at 2024-05-31T11:18:35-07:00 Remove old versions of {n}string-{upcase,downcase} Don't need these anymore. - - - - - 1 changed file: - src/code/string.lisp Changes: ===================================== src/code/string.lisp ===================================== @@ -618,49 +618,6 @@ (setf (schar string i) fill-char)) (make-string count))) -#+nil -(defun string-upcase (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 (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))) - ((= 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)))) - (defun string-upcase (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." @@ -690,49 +647,6 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+nil -(defun string-downcase (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)) - (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)))) - (defun string-downcase (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." @@ -804,31 +718,6 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) -#+nil -(defun nstring-upcase (string &key (start 0) end) - "Given a string, returns that string with all lower case alphabetic - characters converted to uppercase." - (declare (fixnum start)) - (let ((save-header string)) - (with-one-string string start end offset - (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)) - (defun nstring-upcase (string &key (start 0) end) "Given a string, returns that string with all lower case alphabetic characters converted to uppercase." @@ -842,31 +731,6 @@ (char-upcase (schar string index)))) save-header))) -#+nil -(defun nstring-downcase (string &key (start 0) end) - "Given a string, returns that string with all upper case alphabetic - characters converted to lowercase." - (declare (fixnum start)) - (let ((save-header string)) - (with-one-string string start end offset - (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)) - (defun nstring-downcase (string &key (start 0) end) "Given a string, returns that string with all upper case alphabetic characters converted to lowercase." View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/483dfe3999bd7db0cee36ef… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/483dfe3999bd7db0cee36ef… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] String-capitalize should use char-upcase, not lisp:char-titlecase
by Raymond Toy (＠rtoy) 31 May '24

31 May '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 5a037b19 by Raymond Toy at 2024-05-31T08:56:12-07:00 String-capitalize should use char-upcase, not lisp:char-titlecase We were using lisp:;char-titlecase to capitalize the string, but we really should use char-upcase. However, to preserve this functionality, we moved the functions to the `unicode` package. Added a test for this. - - - - - 4 changed files: - src/code/string.lisp - src/code/unicode.lisp - src/i18n/locale/cmucl.pot - tests/string.lisp Changes: ===================================== src/code/string.lisp ===================================== @@ -702,6 +702,7 @@ (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 @@ -744,8 +745,50 @@ (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 + 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 nstring-upcase (string &key (start 0) end) - "Given a string, returns that string with all lower case alphabetic + _N"Given a string, returns that string with all lower case alphabetic characters converted to uppercase." (declare (fixnum start)) (let ((save-header string)) @@ -769,7 +812,7 @@ save-header)) (defun nstring-downcase (string &key (start 0) end) - "Given a string, returns that string with all upper case alphabetic + _N"Given a string, returns that string with all upper case alphabetic characters converted to lowercase." (declare (fixnum start)) (let ((save-header string)) @@ -792,6 +835,7 @@ (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 @@ -817,6 +861,31 @@ (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 + 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-upcase char)) + (setq newword ())) + (t + (setf (schar string index) (char-downcase char)))))) + save-header)) + #+unicode (progn ===================================== src/code/unicode.lisp ===================================== @@ -441,6 +441,48 @@ :end next))) (write-string string result :start end :end offset-slen)))))) +(defun string-capitalize-simple (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)) + (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-full (string &key (start 0) end (casing :full)) "Capitalize String using the Common Lisp word-break algorithm to find the words in String. The beginning is capitalized depending on the @@ -515,7 +557,7 @@ (if unicode-word-break (string-capitalize-unicode string :start start :end end :casing casing) (if (eq casing :simple) - (cl:string-capitalize string :start start :end end) + (string-capitalize-simple string :start start :end end) (string-capitalize-full string :start start :end end :casing casing)))) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -3892,7 +3892,7 @@ msgid "" " upper case alphabetic characters converted to lowercase." msgstr "" -#: src/code/string.lisp +#: src/code/unicode.lisp src/code/string.lisp msgid "" "Given a string, returns a copy of the string with the first\n" " character of each ``word'' converted to upper-case, and remaining\n" ===================================== tests/string.lisp ===================================== @@ -59,3 +59,35 @@ when (char/= actual (char-downcase expected)) collect (list (char-downcase expected) (char-code actual)))))) + +(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)) + (expected + ;; Manually convert S to a capitalized string using + ;; char-upcase/downcase. + (map 'string + #'(lambda (ch f) + (funcall f ch)) + s + (list #'char-upcase + #'char-downcase + #'char-downcase + #'char-downcase + #'char-upcase + #'char-downcase + #'char-downcase)))) + (assert-equal + (map 'list #'char-name expected) + (map 'list #'char-name (string-capitalize s))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5a037b19ff7be80cca1fdd1… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5a037b19ff7be80cca1fdd1… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update release notes for newly closed issues
by Raymond Toy (＠rtoy) 31 May '24

31 May '24

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 50395287 by Raymond Toy at 2024-05-31T08:28:43-07:00 Update release notes for newly closed issues Forgot to add these in the MRs that closed the issues. - - - - - 1 changed file: - src/general-info/release-21f.md Changes: ===================================== src/general-info/release-21f.md ===================================== @@ -77,6 +77,9 @@ public domain. * ~~#298~~ Add `with-float-rounding-mode` macro * ~~#299~~ Enable xoroshiro assembly routine * ~~#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 * 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/50395287ad5abc8842dbf3d… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/50395287ad5abc8842dbf3d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-323-cl-string-casing] 2 commits: Make test string contain all possible characters.
by Raymond Toy (＠rtoy) 31 May '24

31 May '24

Raymond Toy pushed to branch issue-323-cl-string-casing at cmucl / cmucl Commits: db08decf by Raymond Toy at 2024-05-31T07:50:47-07:00 Make test string contain all possible characters. Previously, we skipped over surrogates. - - - - - 0da20df4 by Raymond Toy at 2024-05-31T08:05:47-07:00 Update nstring casing functions. Since we're not dealing with surrogate pairs, we can simplify the functions quite a bit. - - - - - 2 changed files: - src/code/string.lisp - tests/string.lisp Changes: ===================================== src/code/string.lisp ===================================== @@ -804,6 +804,7 @@ (setf (schar newstring new-index) (schar string index))) newstring)))) +#+nil (defun nstring-upcase (string &key (start 0) end) "Given a string, returns that string with all lower case alphabetic characters converted to uppercase." @@ -828,6 +829,20 @@ (setf (schar string (incf index)) lo)))))) save-header)) +(defun nstring-upcase (string &key (start 0) end) + "Given a string, returns that string with all lower case alphabetic + characters converted to uppercase." + (declare (fixnum start)) + (let ((save-header string)) + (with-one-string string start end offset + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (setf (schar string index) + (char-upcase (schar string index)))) + save-header))) + +#+nil (defun nstring-downcase (string &key (start 0) end) "Given a string, returns that string with all upper case alphabetic characters converted to lowercase." @@ -852,6 +867,19 @@ (setf (schar string (incf index)) lo)))))) save-header)) +(defun nstring-downcase (string &key (start 0) end) + "Given a string, returns that string with all upper case alphabetic + characters converted to lowercase." + (declare (fixnum start)) + (let ((save-header string)) + (with-one-string string start end offset + (do ((index start (1+ index))) + ((= index (the fixnum end))) + (declare (fixnum index)) + (setf (schar string index) + (char-downcase (schar string index))))) + save-header)) + (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 ===================================== 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) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ed36bab589e90fc2a222a6… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/ed36bab589e90fc2a222a6… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-323-cl-string-casing
by Raymond Toy (＠rtoy) 31 May '24

31 May '24

Raymond Toy pushed new branch issue-323-cl-string-casing 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-323-cl-string-casing You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-322-optimize-case-mapping-size] Remove unneeded old file
by Raymond Toy (＠rtoy) 31 May '24

31 May '24

Raymond Toy pushed to branch issue-322-optimize-case-mapping-size at cmucl / cmucl Commits: cf069780 by Raymond Toy at 2024-05-30T18:36:12-07:00 Remove unneeded old file Oops. This was the old version that was modified to reduce space usage. Merged these changes to create-case-mapping.lisp. - - - - - 1 changed file: - − src/tools/create-case-table.lisp Changes: ===================================== src/tools/create-case-table.lisp deleted ===================================== @@ -1,174 +0,0 @@ -;; Creates a table of tables that maps a lower case letter to an upper -;; case letter or an upper case letter to a lower case letter. This -;; mapping only works if the roundtrip casing returns the original -;; character, as required by the standard. -;; -;; STAGE2-SIZE is the number of bits to used for the index of the -;; second stage table. -;; -;; Let C be a 16-bit character code. C is decomposed into two parts. -;; The high bits are used as the index into the first table, and the -;; low bits are used as the index into the second table. The number -;; of low bits is STAGE2-SIZE. -;; -;; If the second stage table is all zeroes, the table is replaced by -;; NIL since it contains no valid mapping of lower or upper case -;; letters. -;; -;; Each element of this table is 32-bits long. The low 16 bits -;; contains the mapping of C to the corresponding upper case letter. -;; The high 16 bits maps C to the corresponding lower case letter. -(defun compute-case-table (stage2-size) - (let ((table (make-array (ash 1 (- 16 stage2-size))))) - (dotimes (i (length table)) - (setf (aref table i) (make-array (ash 1 stage2-size) - :initial-element 0 - :element-type '(unsigned-byte 32)))) - (dotimes (i char-code-limit) - (let ((stage1 (ldb (byte (- 16 stage2-size) stage2-size) i)) - (stage2 (ldb (byte stage2-size 0) i))) - (let ((upper (lisp::unicode-upper i)) - (lower (lisp::unicode-lower i)) - (entry 0)) - (declare (type (unsigned-byte 32) entry)) - - (assert (< upper char-code-limit)) - (assert (< lower char-code-limit)) - - ;; Compute mapping from lower case to upper case which is - ;; stored in the low 16 bits of the stage2 table. - ;; - ;; Only consider characters that have an upper case letter and - ;; whose lowercase version returns the original letter. - (when (and (/= i upper) - (= i (lisp::unicode-lower upper))) - (setf entry (ldb (byte 16 0) (- i upper)))) - ;; Compute mapping from upper case to lower case which is - ;; stored in the high 16 bits ofthe stage2 table. - ;; - ;; Only consider characters that have a lower case letter and - ;; whose upper case version returns the original letter. - (when (and (/= i lower) - (= i (lisp::unicode-upper lower))) - (setf entry (ash (ldb (byte 16 0) (- i lower)) - 16))) - - ;; Note: the entry can only contain a lower case code or an - ;; upper case code, not both because we a character is - ;; either lower case or upper case and not both at the same - ;; time. - (setf (aref (aref table stage1) stage2) - entry)))) - - ;; Find each stage2 table that is all zeroes and replace it with - ;; NIL. - (dotimes (k (length table)) - (let ((empty (count-if-not #'zerop (aref table k)))) - (when (zerop empty) - (setf (aref table k) nil)))) - table)) - -;; Given a case-mapping table TABLE, print some information about the -;; size of the tables. This includes the number of empty and -;; non-empty stage2 tables. Also print out how many total non-NIL -;; entries are needed. This is proportional to the total amount of -;; memory needed to store all the tables. -(defun print-table-stats (table stage2-size) - (let ((stage1-size (length table)) - (stage2 (loop for v across table - when v - sum (length v))) - (empty (count-if #'null table))) - (format t "stage2-size ~D~%" stage2-size) - (format t " stage1 entries: ~D: " stage1-size) - (format t " ~D non-empty ~D empty~%" (- stage1-size empty) empty) - (format t " stage2 entries: ~D (length ~D)~%" - stage2 (ash 1 stage2-size)) - (format t " total : ~D~%" (+ (length table) stage2)) - (+ (length table) stage2))) - -(defun find-optimum-size () - (let ((results - (first - (sort (loop for stage2-size from 1 to 15 - collect (list stage2-size - (print-table-stats - (compute-case-table stage2-size) - stage2-size))) - #'< - :key #'second)))) - (format t "Optimum table size: stage2-size ~D, space ~D~%" - (first results) - (second results)))) - -;; Print the case table TABLE to a file named by PATHNAME. -(defun dump-case-table (pathname table stage2-size) - ;; The first entry in the table MUST be NIL because we use that as - ;; the all-zeroes array because of the sparse entries in the table. - (assert (null (aref table 0))) - - (with-open-file (stream pathname :direction :output :if-exists :supersede) - (format stream - "~ -/* - * DO NOT EDIT. - * - * This was generated by (BUILD-CASE-TABLE :STAGE2-SIZE ~D) in - * src/tools/create-case-table.c. - */~2%" - stage2-size) - (format stream "#include <stdint.h>~%") - (format stream "#include <stddef.h>~%") - (format stream "~2%const uint32_t stage2[] = {~%") - (flet ((print-table (header table stream) - ;; Neatly print the table TABLE to STREAM. Each table is - ;; preceded by a C comment in HEADER. The entries are - ;; printed in hex, and neatly wrapped. - (format stream "/* ~A */" header) - (pprint-newline :mandatory stream) - (dotimes (n (length table)) - (unless (zerop n) - (write-char #\, stream) - (write-char #\space stream) - (pprint-newline :fill stream)) - ;;(pprint-pop) - (format stream "0x~8,'0x" (aref table n))) - (princ #\, stream) - (pprint-newline :mandatory stream))) - (let ((index 0) - offsets) - (pprint-logical-block (stream nil :prefix " ") - (print-table "zeroes" - (make-array (ash 1 stage2-size) - :initial-element 0) - stream) - (loop for k from 0 - for s2 across table - when s2 - do (progn - (incf index (ash 1 stage2-size)) - (push index offsets) - (print-table (format nil "stage2_~D (offset ~D)" k index) - s2 - stream)))) - (format stream "};~%") - - ;; Now dump the stage1 table - (format stream "~2%const uint16_t case_mapping[~D] = {~%" - (length table)) - (setf offsets (nreverse offsets)) - (loop for s2 across table - for k from 0 - if s2 - do (format stream " 0x~4,'0x, /* stage2_~D */~%" - (pop offsets) - k) - else - do (format stream " 0x~4,'0x,~%" - 0)) - (format stream "};~%") - (format t "Wrote ~S~%" (namestring stream)))))) - -(defun build-case-table (&key (stage2-size 6) (pathname "./src/lisp/case-mapping.c")) - (let ((table (compute-case-table stage2-size))) - (dump-case-table pathname table stage2-size))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/cf0697808bab7742a0b4f2a… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/cf0697808bab7742a0b4f2a… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-322-optimize-case-mapping-size] 6 commits: Fix #312: Use correct type for message_write_float
by Raymond Toy (＠rtoy) 31 May '24

31 May '24

Raymond Toy pushed to branch issue-322-optimize-case-mapping-size at cmucl / cmucl Commits: a3a3fbd9 by Raymond Toy at 2024-05-30T14:38:30+00:00 Fix #312: Use correct type for message_write_float - - - - - 7e7f3f0f by Raymond Toy at 2024-05-30T14:38:41+00:00 Merge branch 'issue-312-motif-server' into 'master' Fix #312: Use correct type for message_write_float Closes #312 See merge request cmucl/cmucl!218 - - - - - c6c3c9ce by Raymond Toy at 2024-05-30T22:54:14+00:00 Fix #316: Support roundtrip character casing - - - - - 98afa3c8 by Raymond Toy at 2024-05-30T22:54:20+00:00 Merge branch 'issue-316-support-roundtrip-char-casing' into 'master' Fix #316: Support roundtrip character casing Closes #316 See merge request cmucl/cmucl!220 - - - - - caf68d75 by Raymond Toy at 2024-05-30T16:01:11-07:00 Merge branch 'master' into issue-322-optimize-case-mapping-size - - - - - 4bd8ca89 by Raymond Toy at 2024-05-30T18:27:42-07:00 Fix up merge mistakes - - - - - 7 changed files: - src/code/char.lisp - src/i18n/locale/cmucl.pot - src/lisp/case-mapping.c - src/motif/server/datatrans.c - src/motif/server/datatrans.h - src/motif/server/tables.h - + src/tools/create-case-mapping.lisp Changes: ===================================== src/code/char.lisp ===================================== @@ -73,8 +73,8 @@ (alien:def-alien-variable "stage2" (alien:array c-call:unsigned-int nil)) -;; Each entry in the case table consists of the code for either an -;; upper case or lower case character code. +;; Each entry in the case mapping table consists of the code for +;; either an upper case or lower case character code. (defconstant +upper-case-entry+ (byte 16 0)) (defconstant +lower-case-entry+ (byte 16 16)) @@ -84,9 +84,9 @@ (declaim (inline case-mapping-entry)) (defun case-mapping-entry (code) - "For the character code, CODE, return 0 or the 32-bit value from the - case table. A value of 0 means there was no case mapping (neither - upper nor lower case)." + "For the character code, CODE, the 32-bit value from the + case mapping table that indicates the delta between CODE and the + corresponding upper or lower case character for CODE." (declare (type (integer 0 (#.char-code-limit)) code) (optimize (speed 3) (safety 0))) (let* ((index1 (ldb (byte (- 16 +stage2-size+) +stage2-size+) @@ -94,7 +94,7 @@ (index2 (ldb (byte +stage2-size+ 0) code)) (stage2-offset (alien:deref case-mapping index1))) - (alien:deref stage2 (+ (* stage2-offset index2))))) + (alien:deref stage2 (+ stage2-offset index2)))) (declaim (inline case-mapping-lower-case)) (defun case-mapping-lower-case (code) ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -5457,9 +5457,9 @@ msgstr "" #: src/code/char.lisp msgid "" -"For the character code, CODE, return 0 or the 32-bit value from the\n" -" case table. A value of 0 means there was no case mapping (neither\n" -" upper nor lower case)." +"For the character code, CODE, the 32-bit value from the\n" +" case mapping table that indicates the delta between CODE and the\n" +" corresponding upper or lower case character for CODE." msgstr "" #: src/code/char.lisp ===================================== src/lisp/case-mapping.c ===================================== @@ -1,8 +1,8 @@ /* * DO NOT EDIT. * - * This was generated by (BUILD-CASE-TABLE :STAGE2-SIZE 6) in - * src/tools/create-case-table.c. + * This was generated by (BUILD-CASE-MAPPING-TABLE :STAGE2-SIZE 6) in + * src/tools/create-case-mapping.lisp. */ #include <stdint.h> ===================================== src/motif/server/datatrans.c ===================================== @@ -265,10 +265,10 @@ void message_write_color(message_t m,XColor *color,int tag) message_put_word(m,color->blue); } -void message_write_float(message_t m,float f,int tag) +void message_write_float(message_t m,void *f,int tag) { message_put_dblword(m,combine_type_and_data(tag,0)); - message_put_dblword(m,f); + message_put_dblword(m,*(long *) f); } @@ -524,8 +524,8 @@ void message_read_color(message_t m,XColor *color,int tag, int red) void message_read_float(message_t m,float *f,int tag,int data) { - fprintf(stderr,">>>>> Warning:message_read_float: Not implemented.\n"); - fflush(stderr); + long d = message_get_dblword(m); + memcpy(f, &d, sizeof(*f)); } ===================================== src/motif/server/datatrans.h ===================================== @@ -38,7 +38,7 @@ extern void message_write_int_list(); extern void message_write_event(); extern void message_write_color(); /* GCC complains without the full prototype */ -extern void message_write_float(message_t,float,int); +extern void message_write_float(message_t,void *,int); ===================================== src/motif/server/tables.h ===================================== @@ -10,8 +10,8 @@ #ifndef TABLES_H #define TABLES_H -typedef void (*type_writer)(message_t out,caddr_t src,int type_tag); -typedef void (*type_reader)(message_t in,caddr_t dest,int type_tag,int data); +typedef void (*type_writer)(message_t out,void *src,int type_tag); +typedef void (*type_reader)(message_t in,void *dest,int type_tag,int data); typedef struct { String type; ===================================== src/tools/create-case-mapping.lisp ===================================== @@ -0,0 +1,174 @@ +;; Creates a table of tables that maps a lower case letter to an upper +;; case letter or an upper case letter to a lower case letter. This +;; mapping only works if the roundtrip casing returns the original +;; character, as required by the standard. +;; +;; STAGE2-SIZE is the number of bits to used for the index of the +;; second stage table. +;; +;; Let C be a 16-bit character code. C is decomposed into two parts. +;; The high bits are used as the index into the first table, and the +;; low bits are used as the index into the second table. The number +;; of low bits is STAGE2-SIZE. +;; +;; If the second stage table is all zeroes, the table is replaced by +;; NIL since it contains no valid mapping of lower or upper case +;; letters. +;; +;; Each element of this table is 32-bits long. The low 16 bits +;; contains the mapping of C to the corresponding upper case letter. +;; The high 16 bits maps C to the corresponding lower case letter. +(defun compute-case-mapping-table (stage2-size) + (let ((table (make-array (ash 1 (- 16 stage2-size))))) + (dotimes (i (length table)) + (setf (aref table i) (make-array (ash 1 stage2-size) + :initial-element 0 + :element-type '(unsigned-byte 32)))) + (dotimes (i char-code-limit) + (let ((stage1 (ldb (byte (- 16 stage2-size) stage2-size) i)) + (stage2 (ldb (byte stage2-size 0) i))) + (let ((upper (lisp::unicode-upper i)) + (lower (lisp::unicode-lower i)) + (entry 0)) + (declare (type (unsigned-byte 32) entry)) + + (assert (< upper char-code-limit)) + (assert (< lower char-code-limit)) + + ;; Compute mapping from lower case to upper case which is + ;; stored in the low 16 bits of the stage2 table. + ;; + ;; Only consider characters that have an upper case letter and + ;; whose lowercase version returns the original letter. + (when (and (/= i upper) + (= i (lisp::unicode-lower upper))) + (setf entry (ldb (byte 16 0) (- i upper)))) + ;; Compute mapping from upper case to lower case which is + ;; stored in the high 16 bits ofthe stage2 table. + ;; + ;; Only consider characters that have a lower case letter and + ;; whose upper case version returns the original letter. + (when (and (/= i lower) + (= i (lisp::unicode-upper lower))) + (setf entry (ash (ldb (byte 16 0) (- i lower)) + 16))) + + ;; Note: the entry can only contain a lower case code or an + ;; upper case code, not both because we a character is + ;; either lower case or upper case and not both at the same + ;; time. + (setf (aref (aref table stage1) stage2) + entry)))) + + ;; Find each stage2 table that is all zeroes and replace it with + ;; NIL. + (dotimes (k (length table)) + (let ((empty (count-if-not #'zerop (aref table k)))) + (when (zerop empty) + (setf (aref table k) nil)))) + table)) + +;; Given a case-mapping table TABLE, print some information about the +;; size of the tables. This includes the number of empty and +;; non-empty stage2 tables. Also print out how many total non-NIL +;; entries are needed. This is proportional to the total amount of +;; memory needed to store all the tables. +(defun print-table-stats (table stage2-size) + (let ((stage1-size (length table)) + (stage2 (loop for v across table + when v + sum (length v))) + (empty (count-if #'null table))) + (format t "stage2-size ~D~%" stage2-size) + (format t " stage1 entries: ~D: " stage1-size) + (format t " ~D non-empty ~D empty~%" (- stage1-size empty) empty) + (format t " stage2 entries: ~D (length ~D)~%" + stage2 (ash 1 stage2-size)) + (format t " total : ~D~%" (+ (length table) stage2)) + (+ (length table) stage2))) + +(defun find-optimum-size () + (let ((results + (first + (sort (loop for stage2-size from 1 to 15 + collect (list stage2-size + (print-table-stats + (compute-case-mapping-table stage2-size) + stage2-size))) + #'< + :key #'second)))) + (format t "Optimum table size: stage2-size ~D, space ~D~%" + (first results) + (second results)))) + +;; Print the case table TABLE to a file named by PATHNAME. +(defun dump-case-mapping-table (pathname table stage2-size) + ;; The first entry in the table MUST be NIL because we use that as + ;; the all-zeroes array because of the sparse entries in the table. + (assert (null (aref table 0))) + + (with-open-file (stream pathname :direction :output :if-exists :supersede) + (format stream + "~ +/* + * DO NOT EDIT. + * + * This was generated by (BUILD-CASE-MAPPING-TABLE :STAGE2-SIZE ~D) in + * src/tools/create-case-mapping.lisp. + */~2%" + stage2-size) + (format stream "#include <stdint.h>~%") + (format stream "#include <stddef.h>~%") + (format stream "~2%const uint32_t stage2[] = {~%") + (flet ((print-table (header table stream) + ;; Neatly print the table TABLE to STREAM. Each table is + ;; preceded by a C comment in HEADER. The entries are + ;; printed in hex, and neatly wrapped. + (format stream "/* ~A */" header) + (pprint-newline :mandatory stream) + (dotimes (n (length table)) + (unless (zerop n) + (write-char #\, stream) + (write-char #\space stream) + (pprint-newline :fill stream)) + ;;(pprint-pop) + (format stream "0x~8,'0x" (aref table n))) + (princ #\, stream) + (pprint-newline :mandatory stream))) + (let ((index 0) + offsets) + (pprint-logical-block (stream nil :prefix " ") + (print-table "zeroes" + (make-array (ash 1 stage2-size) + :initial-element 0) + stream) + (loop for k from 0 + for s2 across table + when s2 + do (progn + (incf index (ash 1 stage2-size)) + (push index offsets) + (print-table (format nil "stage2_~D (offset ~D)" k index) + s2 + stream)))) + (format stream "};~%") + + ;; Now dump the stage1 table + (format stream "~2%const uint16_t case_mapping[~D] = {~%" + (length table)) + (setf offsets (nreverse offsets)) + (loop for s2 across table + for k from 0 + if s2 + do (format stream " 0x~4,'0x, /* stage2_~D */~%" + (pop offsets) + k) + else + do (format stream " 0x~4,'0x,~%" + 0)) + (format stream "};~%") + (format t "Wrote ~S~%" (namestring stream)))))) + +(defun build-case-mapping-table (&key (stage2-size 6) (pathname "./src/lisp/case-mapping.c")) + (let ((table (compute-case-mapping-table stage2-size))) + (dump-case-mapping-table pathname table stage2-size))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0ff3a9659d487a93fffb7d… -- This project does not include diff previews in email notifications. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0ff3a9659d487a93fffb7d… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0