Raymond Toy pushed to branch issue-316-support-roundtrip-char-casing at cmucl / cmucl
Commits: 95e6ffdd by Raymond Toy at 2024-05-16T14:04:14-07:00 Let deftransforms do the right thing for char-upcase/downcase
Instead of maintaining duplicate code in the functions char-upcase/downcase and in the deftransforms for these functions, change the implementation of the functions to call themselves. This looks like infinite recursion, but the deftransforms are nicely applied so that we only have one copy of the code now.
- - - - - f3dac007 by Raymond Toy at 2024-05-16T14:05:53-07:00 Slightly simplify implementation of char-upcase/downcase transforms
First, change the arg type from `base-char` to `character` (which are the same in cmucl).
Second, for `char-upcase`, we only upcase a Unicode character if it is a lower-case letter (category "Ll"). Likewise for `char-downcase`, we only downcase if the character is an upper-case letter (category "Lu"). Everything else is ignored.
- - - - -
2 changed files:
- src/code/char.lisp - src/compiler/srctran.lisp
Changes:
===================================== src/code/char.lisp ===================================== @@ -463,18 +463,7 @@ (defun char-upcase (char) "Returns CHAR converted to upper-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 ((< 96 m 123) (code-char (- m 32))) - ((> m +unicode-lower-limit+) - (if (member (unicode-category m) '(92 32 75 109)) - char - (code-char (unicode-upper m)))) - (t char)))) + (char-upcase char))
(defun char-titlecase (char) "Returns CHAR converted to title-case if that is possible." @@ -492,18 +481,7 @@ (defun char-downcase (char) "Returns CHAR converted to lower-case if that is possible." (declare (character char)) - #-(and unicode (not unicode-bootstrap)) - (if (upper-case-p char) - (code-char (+ (char-code char) 32)) - char) - #+(and unicode (not unicode-bootstrap)) - (let ((m (char-code char))) - (cond ((> m +unicode-lower-limit+) - (if (member (unicode-category m) '(92 75 109)) - char - (code-char (unicode-lower m)))) - ((< 64 m 91) (code-char (+ m 32))) - (t char)))) + (char-downcase char))
(defun digit-char (weight &optional (radix 10)) "All arguments must be integers. Returns a character object that
===================================== src/compiler/srctran.lisp ===================================== @@ -3335,9 +3335,8 @@ (= (lisp::equal-char-code a) (lisp::equal-char-code b)))))
-(deftransform char-upcase ((x) (base-char)) +(deftransform char-upcase ((x) (character)) "open code" - ;; NOTE: This MUST match what the function char-upcase does. #-(and unicode (not unicode-bootstrap)) '(if (lower-case-p x) (code-char (- (char-code x) 32)) @@ -3345,25 +3344,22 @@ #+(and unicode (not unicode-bootstrap)) '(let ((m (char-code x))) (cond ((< 96 m 123) (code-char (- m 32))) - ((> m lisp::+unicode-lower-limit+) - (if (member (unicode-category m) '(92 32 75 109)) - x - (code-char (lisp::unicode-upper m)))) + ((and (> m lisp::+unicode-lower-limit+) + (= (unicode-category m) lisp::+unicode-category-lower+)) + (code-char (lisp::unicode-upper m))) (t x))))
-(deftransform char-downcase ((x) (base-char)) +(deftransform char-downcase ((x) (character)) "open code" - ;; NOTE: This MUST match what the function char-downcase does. #-(and unicode (not unicode-bootstrap)) '(if (upper-case-p x) (code-char (+ (char-code x) 32)) x) #+(and unicode (not unicode-bootstrap)) '(let ((m (char-code x))) - (cond ((> m lisp::+unicode-lower-limit+) - (if (member (unicode-category m) '(92 75 109)) - x - (code-char (lisp::unicode-lower m)))) + (cond ((and (> m lisp::+unicode-lower-limit+) + (= (unicode-category m) lisp::+unicode-category-upper+)) + (code-char (lisp::unicode-lower m))) ((< 64 m 91) (code-char (+ m 32))) (t x))))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/37967a5048d11c50a9f6fe2...