GitLab

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.

@@ -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

@@ -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))))

Raymond Toy pushed to branch issue-316-support-roundtrip-char-casing at cmucl / cmucl

Commits:

2 changed files:

Changes: