From: Christophe R. <cr...@us...> - 2005-04-29 14:38:27
|
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) |