Re: Case-sensitivity goals, policy and implementation

>>>>> "ole" == ole rohne <ole.rohne@cern.ch> writes:

    ole> Still thinking about READTABLE-CASE/READ-FROM-STRING versus explicit
    ole> case translation and INTERN:

    ole> I think it is good advise to let the Lisp Reader do just that (Read
    ole> Lisp) - use a parser for anything else. If the macsyma/maxima
    ole> developers for 30 years have resisted the temptation to call READ, I
    ole> don't think this is the time to give in.

    ole> Secondly, by the time you've set up the readtable (with casing, macro
    ole> characters and character syntax), and bound *PACKAGE*, *READ-EVAL* and
    ole> friends, the effort by far exceeds writing simply:

It wasn't quite as simple as that, but pretty close.

So here is a patch that uses this idea to implement case-sensitivity.
After downcasing the testsuite and a few minor changes, I get:

    Running tests in rtest1.mac: 28/28 tests passed.
    Running tests in rtest1a.mac: 23/23 tests passed.
    Running tests in rtest2.mac: 47/47 tests passed.
    Running tests in rtest4.mac: 82/82 tests passed.
    Running tests in rtest5.mac: 51/51 tests passed.
    Running tests in rtest6.mac: 4/4 tests passed.
    Running tests in rtest6a.mac: 56/56 tests passed.
    Running tests in rtest6b.mac: 16/16 tests passed.
    Running tests in rtest7.mac: 41/41 tests passed.
    Running tests in rtest9.mac: 77/77 tests passed.
    Running tests in rtest9a.mac: 18/18 tests passed.
    Running tests in rtest10.mac: 38/38 tests passed.
    Running tests in rtest11.mac: 86/86 tests passed.
    Running tests in rtest13.mac: 24/24 tests passed.
    Running tests in rtest14.mac: 65/65 tests passed.
    Running tests in rtest15.mac: 141/141 tests passed.
    Running tests in rtest16.mac: 5/5 tests passed.
    Running tests in rtestode.mac: 64/64 tests passed.
    Running tests in rtestode_zp.mac: 30/30 tests passed.
    Running tests in rtestflatten.mac: 32/32 tests passed.
    Running tests in rtest3.mac: 94/94 tests passed.
    Running tests in rtest8.mac: 50/50 tests passed.
    Running tests in rtest12.mac: 
    ********************** Problem 20 ***************
    Input:
    tellsimp(sin(%i x), %i sinh(x))


    Result:
    [sinRULE1, simp-%sin]

    This differed from the expected result:
    [sinrule1, simp-%sin]

    73/74 tests passed.
    The following 1 problem failed: (20)
    Running tests in rexamples.mac: 


There is a slight problem that the input prompt %I is printed in
uppercase, but the output prompt is ok.  Also note that some tests in
rtest13s cause maxima to hang waiting for input or something.  The
tests in rexamples do the same.

This looks quite promising, and is probably simpler to deal with than
using the reader because I, for one, am not very good at hacking the
reader into submission.

Ray

Index: src/commac.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/commac.lisp,v
retrieving revision 1.17
diff -u -r1.17 commac.lisp
--- src/commac.lisp	19 Oct 2004 12:04:36 -0000	1.17
+++ src/commac.lisp	27 Oct 2004 13:50:04 -0000
@@ -468,7 +468,8 @@
   (let* (#+(and gcl (not gmp)) (big-chunk-size 120)
 	   #+(and gcl (not gmp)) (tentochunksize (expt 10 big-chunk-size))
 	   string)
-    (cond ((symbolp symb)(setq string (symbol-name symb)))
+    (cond ((symbolp symb)
+	   (setq string (print-invert-case symb)))
 	  ((floatp symb)
 	   (let ((a (abs symb)))
 	     (cond ((or (eql a 0.0)
@@ -500,7 +501,7 @@
     (coerce string 'list)))
 
 (defun explodec (symb &aux tem sstring)
-  (setq sstring (format nil "~a" symb))
+  (setq sstring (print-invert-case symb))
 					;(setq sstring (coerce symb 'string))
   (sloop for v on (setq tem (coerce sstring 'list))
 	 do (setf (car v)(intern (string (car v)))))
@@ -512,6 +513,29 @@
 
 (defun implode (lis) (implode1 lis nil))
 
+
+(defun intern-invert-case (string)
+  ;; Like read-from-string with readtable-case :invert
+  (flet ((alpha-upper-case-p (s)
+	   (not (some #'lower-case-p s)))
+	 (alpha-lower-case-p (s)
+	   (not (some #'upper-case-p s))))
+    ;; Don't explicitly add a package here.  It seems maxima sets
+    ;; *package* as needed.
+    (intern (cond ((alpha-upper-case-p string)
+		   (string-downcase string))
+		  ((alpha-lower-case-p string)
+		   (string-upcase string))
+		  (t
+		   string)))))
+
+(let ((local-table (copy-readtable nil)))
+  (setf (readtable-case local-table) :invert)
+  (defun print-invert-case (sym)
+    (let ((*readtable* local-table)
+	  (*print-case* :upcase))
+      (princ-to-string sym))))
+				      
 (defun implode1 (lis upcase &aux (ar *string-for-implode*) (leng 0))
   (declare (type string ar) (fixnum leng))
   (or (> (array-total-size ar) (setq leng (length lis)))
@@ -523,34 +547,11 @@
 	 (cond ((typep v 'character))
 	       ((symbolp v) (setq v (aref (symbol-name v) 0)))
 	       ((numberp v) (setq v (code-char v))))
-	 (setf (aref ar i) (if upcase (char-upcase v) v)))
-  (intern ar))
+	 (setf (aref ar i) v))
+  (intern-invert-case ar))
 
 (defun bothcase-implode (lis  &aux tem )
-  (cond ((not (eql (car lis) #\$))
-	 (return-from bothcase-implode (implode1 lis nil))))
-  (multiple-value-bind
-	(sym there)
-      (implode1 lis nil)
-    (cond (there (if (setq tem (get sym 'upcase)) tem sym))
-	  (t
-	   ;; if all upper case lets not bother interning...
-	   (sloop for v in lis with haslower
-		  when (not (eql (char-upcase v) v))
-		  do (setq haslower t) (loop-finish)
-		  finally (or haslower (return-from bothcase-implode sym)))
-	   (multiple-value-bind
-		 (symup there)
-	       (implode1 lis t)
-	     (cond ((and there (or
-				;; not single symbols
-				(cddr lis)
-				(fboundp symup) (symbol-plist symup)))
-		       
-		    (setf (get sym 'upcase) symup)
-		    symup)
-		   (t (or there (unintern symup))
-		      sym)))))))
+  (implode1 lis nil))
 
 
 (defun explode (symb &aux tem)
Index: src/nparse.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/nparse.lisp,v
retrieving revision 1.18
diff -u -r1.18 nparse.lisp
--- src/nparse.lisp	19 Oct 2004 12:04:59 -0000	1.18
+++ src/nparse.lisp	27 Oct 2004 13:50:08 -0000
@@ -374,6 +374,7 @@
 ;; except that || is a literal |.
 
 ;; Note that this function modifies LIST destructively.
+#+nil
 (defun lisp-token-fixup-case (list)
   (let* ((list (cons nil list))
 	 (todo list)
@@ -392,6 +393,9 @@
 	      (pop todo)
 	      (setq preserve (not preserve))))))))
 
+(defun lisp-token-fixup-case (list)
+  list)
+
 (defvar $bothcases t)
 (defun scan-token (flag)
   (do ((c (parse-tyipeek) (parse-tyipeek))
Index: src/suprv1.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/suprv1.lisp,v
retrieving revision 1.18
diff -u -r1.18 suprv1.lisp
--- src/suprv1.lisp	19 Oct 2004 12:05:00 -0000	1.18
+++ src/suprv1.lisp	27 Oct 2004 13:50:08 -0000
@@ -159,19 +159,20 @@
 (defmvar $% '$% "The last out-line computed, corresponds to lisp *"
 	 no-reset)
 
-(defmvar $inchar '|$%i|
+(defmvar $inchar '$%I
   "The alphabetic prefix of the names of expressions typed by the user.")
 ;;; jfa: begin case-sensitivity hack
 ;;;      delete this when case-sensitivity is fixed!!!! 05/11/2004
 
+#+nil
 (defmvar |$%i| '|$%I|
   "%i = %I until maxima's case behavior is fixed.")
 ;;; jfa: end case-sensitivity hack
 
-(defmvar $outchar '|$%o|
+(defmvar $outchar '$%O
   "The alphabetic prefix of the names of expressions returned by the system.")
 
-(defmvar $linechar '|$%t|
+(defmvar $linechar '$%T
   "The alphabetic prefix of the names of intermediate displayed expressions.")
 
 (defmvar $linenum 1 "the line number of the last expression."
@@ -725,6 +726,7 @@
     (setq l1 (cons (car l) l1)))
   (do nil ((eq loclist (cdr mpdls))) (munlocal)))
 
+
 (defmfun getalias (x) (cond ((get x 'alias)) ((eq x '$false) nil) (t x)))
 
 (defmfun makealias (x) (implode (cons #\$ (exploden x))))
@@ -1279,18 +1281,20 @@
 
 #+cl (setq error-call 'errbreak)
 
-(progn (do ((l '($sqrt $erf $sin $cos $tan $log $plog $sec $csc $cot $sinh $cosh
-		 $tanh $sech $csch $coth $asin $acos $atan $acot $acsc $asec $asinh
-		 $acosh $atanh $acsch $asech $acoth $binomial $gamma $genfact $del)
-	       (cdr l)))( (null l))
-	 ((lambda (x)
-	    (putprop (car l) x 'alias)
-	    (putprop x (stripdollar (car l)) 'reversealias))
-	  ($nounify (car l))))
-       ($nounify '$sum) ($nounify '$product)
-       ($nounify '$integrate) ($nounify '$limit)
-       (defprop $diff %derivative verb) (defprop %derivative $diff noun)
-       '(noun properties))
+(progn
+  (do ((l '($sqrt $erf $sin $cos $tan $log $plog $sec $csc $cot $sinh $cosh
+	    $tanh $sech $csch $coth $asin $acos $atan $acot $acsc $asec $asinh
+	    $acosh $atanh $acsch $asech $acoth $binomial $gamma $genfact $del)
+	  (cdr l)))
+      ((null l))
+    ((lambda (x)
+       (putprop (car l) x 'alias)
+       (putprop x (stripdollar (car l)) 'reversealias))
+     ($nounify (car l))))
+  ($nounify '$sum) ($nounify '$product)
+  ($nounify '$integrate) ($nounify '$limit)
+  (defprop $diff %derivative verb) (defprop %derivative $diff noun)
+  '(noun properties))
 
 (progn (mapc #'(lambda (x) (putprop (car x) (cadr x) 'assign))
 	     '(($debugmode debugmode1) ($bothcases bothcases1)