Bug: Readtable-Case :INVERT does not work properly.

SUMMARY:
The problem is that readtable-case of :INVERT does not properly 
preserve the case of mixed case identifiers.

PRODUCTS AFFECTED:

    MCL 5.0;  MCL 5.0b;  OpenMCL 0.13
    MCL 4.3.5

    Possibly other older versions as well.

EXAMPLE:

(setf (readtable-case *readtable*) :invert)
(symbol-name (read-from-string "foo"))   =>  "FOO"      ; Correct
(symbol-name (read-from-string "FOO"))   =>  "foo"      ; Correct
(symbol-name (read-from-string "Foo"))   =>  "foo"      ; BUG

ANALYSIS:

The problem lies in the function %casify-token in the file 
ccl:l1;ppc;l1-reader.lisp which just gets the decision about whether to 
upcase or downcase wrong.  Below I give a corrected function that will 
fix the problem.  It changes the logic used to determine whether a 
mixed case identifier is seen or not so that it now works properly.

I note that packaging this as a patch is a little bit tricky because of 
the use of accessors and macros that were only defined in the 
compile-time environment when %casify-token was compiled.

CORRECTION:

A corrected version of %casify-token is shown below.  I am also 
attaching a patch file which sets up the proper compilation environment 
so that it can be compiled and then loaded.  The part of the function 
that I changed is the body of the
     (WHEN (EQ CASE :INVERT) ...)


(defun %casify-token (token escapes)
   (let* ((case (readtable-case *readtable*))
          (opos (token.opos token))
          (string (token.string token)))
     (declare (fixnum opos))
     (if (and (null escapes) (eq case :upcase))          ; Most common 
case, pardon the pun
       ; %strup is faster - boot probs tho
       (dotimes (i opos)
         (setf (%schar string i) (char-upcase (%schar string i))))
       (unless (eq case :preserve)
         (when (eq case :invert)
           (let* ((lower-seen nil)
                  (upper-seen nil))
             (do* ((i (1- opos) (1- i))
                   (esclist escapes)
                   (nextesc (if esclist (pop esclist) -1)))
                  ((< i 0) (if upper-seen (unless lower-seen (setq case 
:downcase))
                                          (when lower-seen (setq case 
:upcase))))
               (declare (fixnum i nextesc))
               (if (= nextesc i)
                 (setq nextesc (if esclist (pop esclist) -1))
                 (let* ((ch (%schar string i)))
                   (if (upper-case-p ch)
                     (setq upper-seen t)
                     (if (lower-case-p ch)
                       (setq lower-seen t))))))))
         (if (eq case :upcase)
           (do* ((i (1- opos) (1- i))
                   (nextesc (if escapes (pop escapes) -1)))
                ((< i 0))
             (declare (fixnum i nextesc))
             (if (= nextesc i)
                 (setq nextesc (if escapes (pop escapes) -1))
                 (setf (%schar string i) (char-upcase (%schar string 
i)))))
           (if (eq case :downcase)
             (do* ((i (1- opos) (1- i))
                   (nextesc (if escapes (pop escapes) -1)))
                ((< i 0))
             (declare (fixnum i nextesc))
             (if (= nextesc i)
                 (setq nextesc (if escapes (pop escapes) -1))
                 (setf (%schar string i) (char-downcase (%schar string 
i)))))))))))

It is also possible to code an earlier exit from the DO loop if a mixed 
case identifier was encountered.  It isn't clear that this is 
necessarily worthwhile, though, since it involves less work for mixed 
case identifiers, but more for single case identifiers.  It would allow 
a simplification of the termination clause of the DO* loop.  In any 
case, the code below could replace the LET* above if you want to have 
this particular enhancement.

(let* ((ch (%schar string i)))
   (cond ((upper-case-p ch)
          (if lower-seen
            (return)
            (setq upper-seen t)))
         ((lower-case-p ch)
          (if upper-seen
            (return)
            (setq lower-seen t)))))


--
Thomas A. Russ, Ph.D.  Senior Research Scientist             [email protected]
USC/Information Sciences Institute              WWW:  http://www.isi.edu
4676 Admiralty Way, Marina del Rey, CA 90292              (310) 448-8775

_______________________________________________
bug-openmcl mailing list
[email protected]
http://clozure.com/cgi-bin/mailman/listinfo/bug-openmcl

(in-package "CCL")

;; Patch to fix readtable-case :INVERT

(let ((*WARN-IF-REDEFINE* NIL)
      (*WARN-IF-REDEFINE-KERNEL* NIL))

(eval-when (:compile-toplevel :execute)
(def-accessors %svref
  token.string
  token.ipos
  token.opos
  token.len
  token.extendp                       ; Is token.string extended ?
)
)

(defun %casify-token (token escapes)
  (let* ((case (readtable-case *readtable*))
         (opos (token.opos token))
         (string (token.string token)))
    (declare (fixnum opos))
    (if (and (null escapes) (eq case :upcase))          ; Most common case, pardon the pun
      ; %strup is faster - boot probs tho
      (dotimes (i opos)
        (setf (%schar string i) (char-upcase (%schar string i))))
      (unless (eq case :preserve)
        (when (eq case :invert)
          (let* ((lower-seen nil)
                 (upper-seen nil))
            (do* ((i (1- opos) (1- i))
                  (esclist escapes)
                  (nextesc (if esclist (pop esclist) -1)))
                 ((< i 0) (if upper-seen (unless lower-seen (setq case :downcase))
                                         (when lower-seen (setq case :upcase))))
              (declare (fixnum i nextesc))
              (if (= nextesc i)
                (setq nextesc (if esclist (pop esclist) -1))
                (let* ((ch (%schar string i)))
                  (if (upper-case-p ch)
                    (setq upper-seen t)
                    (if (lower-case-p ch)
                      (setq lower-seen t))))))))
        (if (eq case :upcase)
          (do* ((i (1- opos) (1- i))
                  (nextesc (if escapes (pop escapes) -1)))
               ((< i 0))
            (declare (fixnum i nextesc))
            (if (= nextesc i)
                (setq nextesc (if escapes (pop escapes) -1))
                (setf (%schar string i) (char-upcase (%schar string i)))))
          (if (eq case :downcase)
            (do* ((i (1- opos) (1- i))
                  (nextesc (if escapes (pop escapes) -1)))
               ((< i 0))
            (declare (fixnum i nextesc))
            (if (= nextesc i)
                (setq nextesc (if escapes (pop escapes) -1))
                (setf (%schar string i) (char-downcase (%schar string i)))))))))))

)  ; End LET