Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10092/src/code

Modified Files:
	bignum.lisp early-extensions.lisp fd-stream.lisp 
	float-trap.lisp list.lisp numbers.lisp print.lisp sharpm.lisp 
	sysmacs.lisp target-package.lisp typedefs.lisp unix.lisp 
Log Message:
0.9.0.6:
	MORE CASE CONSISTENCY

	Make the system (with the x86-64 backend) buildable under
	(readtable-case *readtable*) => :invert.

	This may seem like a bit of an eccentric thing to do.  The plan,
	however, is to in future define this as the build mode for SBCL,
	enforcing it in the build scripts, so that userinits are 
	prevented from interfering in this respect, and also so that
	case-consistency throughout the system is enforced (to reduce
	potential reader confusion further down the line).  However,
	since there are 100000 MIPS-related patches waiting to be 
	merged, it would be a bad time to enforce this (and break
	all non-x86-64 backends).


Index: bignum.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/bignum.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- bignum.lisp	6 Jan 2005 12:47:58 -0000	1.18
+++ bignum.lisp	29 Apr 2005 14:37:36 -0000	1.19
@@ -535,7 +535,7 @@
     (if nil
 	`(assert ,@args)))
   ;; We'll be doing a lot of modular arithmetic.
-  (sb!xc:defmacro M (form)
+  (sb!xc:defmacro modularly (form)
     `(logand all-ones-digit ,form)))
 
 ;;; I'm not sure why I need this FTYPE declaration.  Compiled by the
@@ -606,10 +606,10 @@
     (dotimes (i digit-size)
       (setf umask (logior umask imask))
       (unless (zerop (logand ud umask))
-	(setf ud (M (- ud vd)))
-	(setf m (M (logior m imask))))
-      (setf imask (M (ash imask 1)))
-      (setf vd (M (ash vd 1))))
+	(setf ud (modularly (- ud vd)))
+	(setf m (modularly (logior m imask))))
+      (setf imask (modularly (ash imask 1)))
+      (setf vd (modularly (ash vd 1))))
     m))
 
 (defun dmod (u u-len v v-len tmp1)
@@ -654,16 +654,16 @@
   (let* ((c (bmod x y))
 	 (n1 c)
 	 (d1 1)
-	 (n2 (M (1+ (M (lognot n1)))))
-	 (d2 (M -1)))
+	 (n2 (modularly (1+ (modularly (lognot n1)))))
+	 (d2 (modularly -1)))
     (declare (type (unsigned-byte #.sb!vm:n-word-bits) n1 d1 n2 d2))
     (loop while (> n2 (expt 2 (truncate digit-size 2))) do
 	  (loop for i of-type (mod #.sb!vm:n-word-bits)
 		downfrom (- (integer-length n1) (integer-length n2))
 		while (>= n1 n2) do
-		(when (>= n1 (M (ash n2 i)))
-		  (psetf n1 (M (- n1 (M (ash n2 i))))
-			 d1 (M (- d1 (M (ash d2 i)))))))
+		(when (>= n1 (modularly (ash n2 i)))
+		  (psetf n1 (modularly (- n1 (modularly (ash n2 i))))
+			 d1 (modularly (- d1 (modularly (ash d2 i)))))))
 	  (psetf n1 n2
 		 d1 d2
 		 n2 n1
@@ -781,7 +781,7 @@
 				 (- (copy-bignum tmp1 tmp1-len)
 				    (copy-bignum tmp2 tmp2-len)))))
 	      (bignum-abs-buffer u u-len)
-	      (gcd-assert (zerop (M u)))))
+	      (gcd-assert (zerop (modularly u)))))
 	(setf u-len (make-gcd-bignum-odd u u-len))
 	(rotatef u v)	
 	(rotatef u-len v-len))

Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -d -r1.71 -r1.72
--- early-extensions.lisp	1 Mar 2005 10:21:31 -0000	1.71
+++ early-extensions.lisp	29 Apr 2005 14:37:36 -0000	1.72
@@ -581,7 +581,7 @@
 
 (defmacro define-cached-synonym
     (name &optional (original (symbolicate "%" name)))
-  (let ((cached-name (symbolicate "%%" name "-cached")))
+  (let ((cached-name (symbolicate "%%" name "-CACHED")))
     `(progn
        (defun-cached (,cached-name :hash-bits 8
                                    :hash-function (lambda (x)

Index: fd-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fd-stream.lisp,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -d -r1.64 -r1.65
--- fd-stream.lisp	4 Apr 2005 09:49:47 -0000	1.64
+++ fd-stream.lisp	29 Apr 2005 14:37:36 -0000	1.65
@@ -299,8 +299,7 @@
 	(mapcar
 	    (lambda (buffering)
 	      (let ((function
-		     (intern (let ((*print-case* :upcase))
-			       (format nil name-fmt (car buffering))))))
+		     (intern (format nil name-fmt (string (car buffering))))))
 		`(progn
 		   (defun ,function (stream byte)
 		     (output-wrapper/variable-width (stream ,size ,buffering ,restart)
@@ -326,8 +325,7 @@
 	(mapcar
 	    (lambda (buffering)
 	      (let ((function
-		     (intern (let ((*print-case* :upcase))
-			       (format nil name-fmt (car buffering))))))
+		     (intern (format nil name-fmt (string (car buffering))))))
 		`(progn
 		   (defun ,function (stream byte)
 		     (output-wrapper (stream ,size ,buffering ,restart)
@@ -979,14 +977,10 @@
 (defmacro define-external-format (external-format size output-restart
                                   out-expr in-expr)
   (let* ((name (first external-format))
-         (out-function (intern (let ((*print-case* :upcase))
-                                 (format nil "OUTPUT-BYTES/~A" name))))
-         (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name))
-         (in-function (intern (let ((*print-case* :upcase))
-                                (format nil "FD-STREAM-READ-N-CHARACTERS/~A"
-                                        name))))
-         (in-char-function (intern (let ((*print-case* :upcase))
-                                     (format nil "INPUT-CHAR/~A" name)))))
+         (out-function (symbolicate "OUTPUT-BYTES/" name))
+         (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
+         (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
+         (in-char-function (symbolicate "INPUT-CHAR/" name)))
     `(progn
       (defun ,out-function (stream string flush-p start end)
 	(let ((start (or start 0))
@@ -1076,8 +1070,7 @@
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
 	       ,@(mapcar #'(lambda (buffering)
-			     (intern (let ((*print-case* :upcase))
-				       (format nil format buffering))))
+			     (intern (format nil format (string buffering))))
 			 '(:none :line :full)))
 	*external-formats*)))))
 
@@ -1085,16 +1078,11 @@
     (external-format output-restart out-size-expr
      out-expr in-size-expr in-expr)
   (let* ((name (first external-format))
-	 (out-function (intern (let ((*print-case* :upcase))
-				 (format nil "OUTPUT-BYTES/~A" name))))
-	 (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name))
-	 (in-function (intern (let ((*print-case* :upcase))
-				(format nil "FD-STREAM-READ-N-CHARACTERS/~A"
-					name))))
-	 (in-char-function (intern (let ((*print-case* :upcase))
-				     (format nil "INPUT-CHAR/~A" name))))
-	 (resync-function (intern (let ((*print-case* :upcase))
-				    (format nil "RESYNC/~A" name)))))
+	 (out-function (symbolicate "OUTPUT-BYTES/" name))
+	 (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
+	 (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
+	 (in-char-function (symbolicate "INPUT-CHAR/" name))
+	 (resync-function (symbolicate "RESYNC/" name)))
     `(progn
       (defun ,out-function (fd-stream string flush-p start end)
 	(let ((start (or start 0))
@@ -1221,8 +1209,7 @@
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
 	       ,@(mapcar #'(lambda (buffering)
-			     (intern (let ((*print-case* :upcase))
-				       (format nil format buffering))))
+			     (intern (format nil format (string buffering))))
 			 '(:none :line :full))
 	       ,resync-function)
 	*external-formats*)))))

Index: float-trap.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/float-trap.lisp,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- float-trap.lisp	8 Jun 2004 14:49:26 -0000	1.15
+++ float-trap.lisp	29 Apr 2005 14:37:36 -0000	1.16
@@ -171,7 +171,7 @@
 	   (error 'floating-point-underflow))
 	  ((not (zerop (logand float-inexact-trap-bit traps)))
 	   (error 'floating-point-inexact))
-	  #!+FreeBSD
+	  #!+freebsd
 	  ((zerop (ldb float-exceptions-byte modes))
 	   ;; I can't tell what caused the exception!!
 	   (error 'floating-point-exception

Index: list.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/list.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- list.lisp	1 Jul 2003 05:23:06 -0000	1.23
+++ list.lisp	29 Apr 2005 14:37:36 -0000	1.24
@@ -592,7 +592,7 @@
                (cond ((satisfies-the-test old subtree) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)
-                              (subtree subtree (Cdr subtree)))
+                              (subtree subtree (cdr subtree)))
                              ((atom subtree)
                               (if (satisfies-the-test old subtree)
                                   (setf (cdr last) new)))
@@ -611,7 +611,7 @@
                (cond ((funcall test (apply-key key subtree)) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)
-                              (subtree subtree (Cdr subtree)))
+                              (subtree subtree (cdr subtree)))
                              ((atom subtree)
                               (if (funcall test (apply-key key subtree))
                                   (setf (cdr last) new)))
@@ -630,7 +630,7 @@
                (cond ((not (funcall test (apply-key key subtree))) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)
-                              (subtree subtree (Cdr subtree)))
+                              (subtree subtree (cdr subtree)))
                              ((atom subtree)
                               (if (not (funcall test (apply-key key subtree)))
                                   (setf (cdr last) new)))
@@ -685,16 +685,16 @@
     (declare (inline assoc))
     (let (temp)
       (labels ((s (subtree)
-                 (cond ((Setq temp (nsublis-macro))
+                 (cond ((setq temp (nsublis-macro))
                         (cdr temp))
                        ((atom subtree) subtree)
                        (t (do* ((last nil subtree)
-                                (subtree subtree (Cdr subtree)))
+                                (subtree subtree (cdr subtree)))
                                ((atom subtree)
                                 (if (setq temp (nsublis-macro))
                                     (setf (cdr last) (cdr temp))))
                             (if (setq temp (nsublis-macro))
-                                (return (setf (Cdr last) (Cdr temp)))
+                                (return (setf (cdr last) (cdr temp)))
                                 (setf (car subtree) (s (car subtree)))))
                           subtree))))
         (s tree)))))
@@ -830,7 +830,7 @@
       (do () ((endp list1))
         (if (with-set-keys (member (apply-key key (car list1)) list2))
             (steve-splice list1 res)
-            (setq list1 (Cdr list1))))
+            (setq list1 (cdr list1))))
       res)))
 
 (defun set-difference (list1 list2

Index: numbers.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/numbers.lisp,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -d -r1.44 -r1.45
--- numbers.lisp	11 Feb 2005 07:32:52 -0000	1.44
+++ numbers.lisp	29 Apr 2005 14:37:37 -0000	1.45
@@ -388,7 +388,7 @@
 		(cond ((eql t1 0) 0)
 		      ((eql g2 1)
 		       (%make-ratio t1 (* t2 dy)))
-		      (T (let* ((nn (truncate t1 g2))
+		      (t (let* ((nn (truncate t1 g2))
 				(t3 (truncate dy g2))
 				(nd (if (eql t2 1) t3 (* t2 t3))))
 			   (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
@@ -744,7 +744,7 @@
   "Return T if all of its arguments are numerically equal, NIL otherwise."
   (the number number)
   (do ((nlist more-numbers (cdr nlist)))
-      ((atom nlist) T)
+      ((atom nlist) t)
      (declare (list nlist))
      (if (not (= (car nlist) number)) (return nil))))
 
@@ -756,7 +756,7 @@
        ((atom nlist) t)
      (declare (list nlist))
      (unless (do* ((nl nlist (cdr nl)))
-		  ((atom nl) T)
+		  ((atom nl) t)
 	       (declare (list nl))
 	       (if (= head (car nl)) (return nil)))
        (return nil))))

Index: print.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/print.lisp,v
retrieving revision 1.61
retrieving revision 1.62
diff -u -d -r1.61 -r1.62
--- print.lisp	1 Mar 2005 10:21:31 -0000	1.61
+++ print.lisp	29 Apr 2005 14:37:37 -0000	1.62
@@ -21,7 +21,7 @@
   "If true, all objects will printed readably. If readable printing is
   impossible, an error will be signalled. This overrides the value of
   *PRINT-ESCAPE*.")
-(defvar *print-escape* T
+(defvar *print-escape* t
   #!+sb-doc
   "Should we print in a reasonably machine-readable way? (possibly
   overridden by *PRINT-READABLY*)")

Index: sharpm.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sharpm.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- sharpm.lisp	18 Feb 2005 08:22:29 -0000	1.14
+++ sharpm.lisp	29 Apr 2005 14:37:37 -0000	1.15
@@ -172,20 +172,20 @@
 
 (defun sharp-B (stream sub-char numarg)
   (ignore-numarg sub-char numarg)
-  (sharp-r stream sub-char 2))
+  (sharp-R stream sub-char 2))
 
 (defun sharp-C (stream sub-char numarg)
   (ignore-numarg sub-char numarg)
   ;; The next thing had better be a list of two numbers.
   (let ((cnum (read stream t nil t)))
-    (when *read-suppress* (return-from sharp-c nil))
+    (when *read-suppress* (return-from sharp-C nil))
     (if (and (listp cnum) (= (length cnum) 2))
 	(complex (car cnum) (cadr cnum))
 	(%reader-error stream "illegal complex number format: #C~S" cnum))))
 
 (defun sharp-O (stream sub-char numarg)
   (ignore-numarg sub-char numarg)
-  (sharp-r stream sub-char 8))
+  (sharp-R stream sub-char 8))
 
 (defun sharp-R (stream sub-char radix)
   (cond (*read-suppress*
@@ -208,7 +208,7 @@
 
 (defun sharp-X (stream sub-char numarg)
   (ignore-numarg sub-char numarg)
-  (sharp-r stream sub-char 16))
+  (sharp-R stream sub-char 16))
 
 ;;;; reading circular data: the #= and ## readmacros
 
@@ -450,8 +450,8 @@
   (set-dispatch-macro-character #\# #\C #'sharp-C)
   (set-dispatch-macro-character #\# #\c #'sharp-C)
   (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
-  (set-dispatch-macro-character #\# #\p #'sharp-p)
-  (set-dispatch-macro-character #\# #\P #'sharp-p)
+  (set-dispatch-macro-character #\# #\p #'sharp-P)
+  (set-dispatch-macro-character #\# #\P #'sharp-P)
   (set-dispatch-macro-character #\# #\) #'sharp-illegal)
   (set-dispatch-macro-character #\# #\< #'sharp-illegal)
   (set-dispatch-macro-character #\# #\Space #'sharp-illegal)

Index: sysmacs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sysmacs.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- sysmacs.lisp	29 Oct 2004 00:43:26 -0000	1.18
+++ sysmacs.lisp	29 Apr 2005 14:37:37 -0000	1.19
@@ -50,7 +50,7 @@
     `(let ((,svar ,stream))
        (cond ((null ,svar) *standard-input*)
 	     ((eq ,svar t) *terminal-io*)
-	     (T ,@(when check-type `((enforce-type ,svar ,check-type)))
+	     (t ,@(when check-type `((enforce-type ,svar ,check-type)))	;
 		#!+high-security
 		(unless (input-stream-p ,svar)
 		  (error 'simple-type-error
@@ -64,7 +64,7 @@
     `(let ((,svar ,stream))
        (cond ((null ,svar) *standard-output*)
 	     ((eq ,svar t) *terminal-io*)
-	     (T ,@(when check-type `((check-type ,svar ,check-type)))
+	     (t ,@(when check-type `((check-type ,svar ,check-type)))
 		#!+high-security
 		(unless (output-stream-p ,svar)
 		  (error 'simple-type-error

Index: target-package.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-package.lisp,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -d -r1.32 -r1.33
--- target-package.lisp	16 Mar 2005 10:21:52 -0000	1.32
+++ target-package.lisp	29 Apr 2005 14:37:37 -0000	1.33
@@ -649,8 +649,8 @@
   ;; We just simple-stringify the name and call INTERN*, where the real
   ;; logic is.
   (let ((name (if (simple-string-p name)
-		name
-		(coerce name 'simple-string)))
+		  name
+		  (coerce name 'simple-string)))
 	(package (find-undeleted-package-or-lose package)))
     (declare (simple-string name))
       (intern* name

Index: typedefs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/typedefs.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- typedefs.lisp	26 Aug 2003 13:21:18 -0000	1.18
+++ typedefs.lisp	29 Apr 2005 14:37:37 -0000	1.19
@@ -77,7 +77,7 @@
   (enumerable nil :read-only t)
   ;; an arbitrary hash code used in EQ-style hashing of identity
   ;; (since EQ hashing can't be done portably)
-  (hash-value (random #.(ash 1 20))
+  (hash-value (random #.(ash 1 15))
 	      :type (and fixnum unsigned-byte)
 	      :read-only t)
   ;; Can this object contain other types? A global property of our

Index: unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -d -r1.52 -r1.53
--- unix.lisp	6 Apr 2005 17:17:03 -0000	1.52
+++ unix.lisp	29 Apr 2005 14:37:37 -0000	1.53
@@ -513,7 +513,7 @@
 ;;; they are ready for reading and writing. See the UNIX Programmer's
 ;;; Manual for more information.
 (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
-  (declare (type (integer 0 #.FD-SETSIZE) nfds)
+  (declare (type (integer 0 #.fd-setsize) nfds)
 	   (type unsigned-byte rdfds wrfds xpfds)
 	   (type (or (unsigned-byte 31) null) to-secs)
 	   (type (unsigned-byte 31) to-usecs)
@@ -663,7 +663,7 @@
                (rem (struct timespec)))
     (setf (slot req 'tv-sec) secs)
     (setf (slot req 'tv-nsec) nsecs)
-    (loop while (eql sb!unix:EINTR
+    (loop while (eql sb!unix:eintr
                      (nth-value 1
                                 (int-syscall ("nanosleep" (* (struct timespec))
                                                           (* (struct timespec)))
@@ -694,7 +694,7 @@
 	       (tz (struct timezone)))
     (syscall* ("gettimeofday" (* (struct timeval))
 			      (* (struct timezone)))
-	      (values T
+	      (values t
 		      (slot tv 'tv-sec)
 		      (slot tv 'tv-usec)
 		      (slot tz 'tz-minuteswest)
@@ -710,11 +710,11 @@
     (it-interval (struct timeval))	; timer interval
     (it-value (struct timeval))))	; current value
 
-(defconstant ITIMER-REAL 0)
-(defconstant ITIMER-VIRTUAL 1)
-(defconstant ITIMER-PROF 2)
+(defconstant itimer-real 0)
+(defconstant itimer-virtual 1)
+(defconstant itimer-prof 2)
 
-(defun unix-getitimer(which)
+(defun unix-getitimer (which)
   "Unix-getitimer returns the INTERVAL and VALUE slots of one of
    three system timers (:real :virtual or :profile). On success,
    unix-getitimer returns 5 values,
@@ -724,12 +724,12 @@
 		   (unsigned-byte 29) (mod 1000000)
 		   (unsigned-byte 29) (mod 1000000)))
   (let ((which (ecase which
-		 (:real ITIMER-REAL)
-		 (:virtual ITIMER-VIRTUAL)
-		 (:profile ITIMER-PROF))))
+		 (:real itimer-real)
+		 (:virtual itimer-virtual)
+		 (:profile itimer-prof))))
     (with-alien ((itv (struct itimerval)))
       (syscall* ("getitimer" int (* (struct itimerval)))
-		(values T
+		(values t
 			(slot (slot itv 'it-interval) 'tv-sec)
 			(slot (slot itv 'it-interval) 'tv-usec)
 			(slot (slot itv 'it-value) 'tv-sec)
@@ -752,9 +752,9 @@
 		   (unsigned-byte 29) (mod 1000000)
 		   (unsigned-byte 29) (mod 1000000)))
   (let ((which (ecase which
-		 (:real ITIMER-REAL)
-		 (:virtual ITIMER-VIRTUAL)
-		 (:profile ITIMER-PROF))))
+		 (:real itimer-real)
+		 (:virtual itimer-virtual)
+		 (:profile itimer-prof))))
     (with-alien ((itvn (struct itimerval))
 		 (itvo (struct itimerval)))
       (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs
@@ -762,7 +762,7 @@
 	    (slot (slot itvn 'it-value   ) 'tv-sec ) val-secs
 	    (slot (slot itvn 'it-value   ) 'tv-usec) val-usec)
       (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval)))
-		(values T
+		(values t
 			(slot (slot itvo 'it-interval) 'tv-sec)
 			(slot (slot itvo 'it-interval) 'tv-usec)
 			(slot (slot itvo 'it-value) 'tv-sec)