Case sensitive maxima

Here is a patch the implements case-sensitive maxima.  It passes all
of the tests, once the test files are downcased appropriately.  The
code needs some cleanup, and I'm sure there are cases I've missed, but
passing the testsuite is a good sign. :-)

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 17:33:05 -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/macsys.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/macsys.lisp,v
retrieving revision 1.32
diff -u -r1.32 macsys.lisp
--- src/macsys.lisp	19 Oct 2004 12:04:37 -0000	1.32
+++ src/macsys.lisp	27 Oct 2004 17:33:05 -0000
@@ -31,7 +31,7 @@
   ;; Even easier and more general is for MREAD to take
   ;; a FUNARG as the prompt. -gjc
   (format () "~A(~A~D) ~A" *prompt-prefix* 
-	  (stripdollar $inchar) $linenum *prompt-suffix*))
+	  (print-invert-case (stripdollar $inchar)) $linenum *prompt-suffix*))
 
 (defun break-prompt ()
   (declare (special $prompt))
@@ -532,7 +532,7 @@
 				   
 			     (cond ((and (symbolp v) (eql (getcharn v 1)
 							  #\&))
-				    (subseq (symbol-name v) 1))
+				    (subseq (print-invert-case v) 1))
 				   ((stringp v) v)
 				   (t
 				    (coerce (mstring v) 'string))))))
Index: src/matcom.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/matcom.lisp,v
retrieving revision 1.2
diff -u -r1.2 matcom.lisp
--- src/matcom.lisp	4 Oct 2004 02:25:55 -0000	1.2
+++ src/matcom.lisp	27 Oct 2004 17:33:05 -0000
@@ -380,7 +380,7 @@
      (cond ((null rulenum) (setq rulenum 1.)))
      (setq oname (getop name))
      (setq pgname (implode (append (%to$ (explodec oname))
-				   '(r u l e)
+				   '(|r| |u| |l| |e|)
 				   (mexploden rulenum))))
      (meta-mputprop pgname name 'ruleof)
      (meta-add2lnc pgname '$rules)
Index: src/mload.lisp
===================================================================
RCS file: /cvsroot/maxima/maxima/src/mload.lisp,v
retrieving revision 1.16
diff -u -r1.16 mload.lisp
--- src/mload.lisp	19 Oct 2004 12:04:59 -0000	1.16
+++ src/mload.lisp	27 Oct 2004 17:33:05 -0000
@@ -879,7 +879,7 @@
 (defun $file_search (name &optional paths)
   (if (and (symbolp name)
 	   (member (getcharn name 1) '(#\& #\$)))
-      (setq name (subseq (symbol-name name) 1)))
+      (setq name (subseq (print-invert-case name) 1)))
   (if (symbolp name)  (setf name (string name)))
   (if (probe-file name) (return-from $file_search name))
   (or paths (setq paths ($append $file_search_lisp  $file_search_maxima
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 17:33:07 -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))
@@ -403,9 +407,11 @@
 	(or $bothcases  (setq c (fixnum-char-upcase c))))
     (setq flag t)))
 
-(defun scan-lisp-string () (intern (scan-string)))
+(defun scan-lisp-string ()
+  (intern (scan-string)))
 
-(defun scan-macsyma-string () (intern (scan-string #\&)))
+(defun scan-macsyma-string ()
+  (intern-invert-case (scan-string #\&)))
 
 (defun scan-string (&optional init)
   (let ((buf (or *scan-string-buffer*
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 17:33:07 -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."