From: William Harold Newman Date: Fri, 6 Apr 2001 13:02:09 +0000 (+0000) Subject: 0.6.11.32: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a8fa26a6e9804d3548f5bca9361a91345a689099;p=sbcl.git 0.6.11.32: MNA patches from sbcl-devel.. ..package cleanup (2001-03-29) ..bug 94 compiler type mismatch nondetection fix (2001-03-30) (started trying to fix bug 87, following MNA 2001-04-04 patch, but fix doesn't work yet) renamed TYPES-INTERSECT and VALUES-TYPES-INTERSECT to TYPES-EQUAL-OR-INTERSECT and VALUES-TYPES-EQUAL-OR-INTERSECT removed redundant quotes from self-evaluating constants build-under-CMU-CL fixes from Christophe sbcl-devel 2001-04-05 added CMU CL 18c workaround in cross-float.lisp --- diff --git a/BUGS b/BUGS index 37e8fed..00f38e7 100644 --- a/BUGS +++ b/BUGS @@ -811,13 +811,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: (I haven't tried to investigate this bug enough to guess whether there might be any user-level symptoms.) -87: - Despite what the manual says, (DECLAIM (SPEED 0)) doesn't cause - things to be byte compiled. This seems to be true in cmucl-2.4.19, - too: (COMPILE-FILE .. :BYTE-COMPILE T) causes byte-compilation, - but ordinary COMPILE-FILE of a file containing (DECLAIM (SPEED 0)) - does not. - 90: a latent cross-compilation/bootstrapping bug: The cross-compilation host's CL:CHAR-CODE-LIMIT is used in target code in readtable.lisp @@ -857,15 +850,33 @@ Error in function C::GET-LAMBDA-TO-COMPILE: (:LINUX :X86 :IEEE-FLOATING-POINT :SB-CONSTRAIN-FLOAT-TYPE :SB-TEST :SB-INTERPRETER :SB-DOC :UNIX ...) is not of type SYMBOL. -94: - As reported by Christophe Rhodes on sbcl-devel 2001-03-28, the - old declaration - (declaim (ftype (function (list list symbol t) list) parse-deftransform)) - above DEFUN PARSE-DEFTRANSFORM was incorrect. The bad declaration was - removed in sbcl-0.6.11.28, but the compiler problem remains: the compiler - should've complained about the mismatch between the declaration and the - definition, and didn't. (The compiler in cmucl-2.5.1 does detect the - problem and complain.) +94a: + Inconsistencies between derived and declared VALUES return types for + DEFUN aren't checked very well. E.g. the logic which successfully + catches problems like + (declaim (ftype (function (fixnum) float) foo)) + (defun foo (x) + (declare (type integer x)) + (values x)) ; wrong return type, detected, gives warning, good! + fails to catch + (declaim (ftype (function (t) (values t t)) bar)) + (defun bar (x) + (values x)) ; wrong number of return values, no warning, bad! + The cause of this is seems to be that (1) the internal function + VALUES-TYPES-EQUAL-OR-INTERSECT used to make the check handles its + arguments symmetrically, and (2) when the type checking code was + written back when when SBCL's code was still CMU CL, the intent + was that this case + (declaim (ftype (function (t) t) bar)) + (defun bar (x) + (values x x)) ; wrong number of return values; should give warning? + not be warned for, because a two-valued return value is considered + to be compatible with callers who expects a single value to be + returned. That intent is probably not appropriate for modern ANSI + Common Lisp, but fixing this might be complicated because of other + divergences between auld-style and new-style handling of + multiple-VALUES types. (Some issues related to this were discussed + on cmucl-imp at some length sometime in 2000.) KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 5195c23..40f5025 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -327,13 +327,6 @@ :use ("CL" "SB!ALIEN" "SB!BIGNUM" "SB!C-CALL" "SB!DEBUG" "SB!EXT" "SB!GRAY" "SB!INT" "SB!KERNEL" "SB!SYS")) - ;; FIXME: It seems to me that this could go away, with its contents moved - ;; into SB!KERNEL, like the implementation of the rest of the class system. -;; #s(sb-cold:package-data -;; :name "SB!CONDITIONS" -;; :doc "private: the implementation of the condition system" -;; :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")) - #s(sb-cold:package-data :name "SB!DEBUG" :doc @@ -475,12 +468,7 @@ like *STACK-TOP-HINT*" :doc "public: miscellaneous supported extensions to the ANSI Lisp spec" ;; FIXME: Why don't we just USE-PACKAGE %KERNEL here instead of importing? :use ("CL" "SB!ALIEN" "SB!C-CALL" "SB!INT" "SB!SYS" "SB!GRAY") - ;; FIXME: If we advertise these as extensions, they should be in the - ;; SB!EXT package (and perhaps re-exported from the %KERNEL - ;; package) rather than in some other package and reexported from - ;; SB!EXT. - :import-from (("SB!KERNEL" "WEAK-POINTER-P")) - :reexport ("LOAD-FOREIGN" "LOAD-1-FOREIGN" "WEAK-POINTER-P") + :reexport ("LOAD-FOREIGN" "LOAD-1-FOREIGN") :export (;; Information about how the program was invoked is ;; nonstandard but very useful. "*POSIX-ARGV*" "POSIX-GETENV" "POSIX-ENVIRON" @@ -488,7 +476,6 @@ like *STACK-TOP-HINT*" ;; People have various good reasons to mess with the GC. "*AFTER-GC-HOOKS*" "*BEFORE-GC-HOOKS*" "*GC-NOTIFY-AFTER*" "*GC-NOTIFY-BEFORE*" "*GC-NOTIFY-STREAM*" - "*GC-VERBOSE*" "BYTES-CONSED-BETWEEN-GCS" "GC" "GC-OFF" "GC-ON" "GET-BYTES-CONSED" "*GC-RUN-TIME*" @@ -545,10 +532,10 @@ like *STACK-TOP-HINT*" "INTERACTIVE-EVAL" ;; weak pointers and finalization - "FINALIZE" "CANCEL-FINALIZATION" - ;; FIXME: "WEAK-POINTER-P" here once it moves from SB!KERNEL + "CANCEL-FINALIZATION" + "FINALIZE" "HASH-TABLE-WEAK-P" "MAKE-WEAK-POINTER" - "WEAK-POINTER" "WEAK-POINTER-VALUE" + "WEAK-POINTER" "WEAK-POINTER-P" "WEAK-POINTER-VALUE" ;; If the user knows we're doing IEEE, he might reasonably ;; want to do this stuff. @@ -844,7 +831,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." :use ("CL" "SB!ALIEN" "SB!ALIEN-INTERNALS" "SB!BIGNUM" "SB!EXT" "SB!INT" "SB!SYS" "SB!GRAY") :import-from (("SB!C-CALL" "VOID")) - :reexport ("DEF!STRUCT" "DEF!MACRO" "VOID") + :reexport ("DEF!STRUCT" "DEF!MACRO" "VOID" "WEAK-POINTER-P") :export ("%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" @@ -1124,9 +1111,9 @@ is a good idea, but see SB-SYS for blurring of boundaries." "TYPE-DIFFERENCE" "TYPE-EXPAND" "TYPE-INTERSECTION" "TYPE-INTERSECTION2" "TYPE-APPROX-INTERSECTION2" - "TYPE-SPECIFIER" - "TYPE-UNION" "TYPE/=" "TYPE=" - "TYPES-INTERSECT" "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY" + "TYPE-SPECIFIER" "TYPE-UNION" "TYPE/=" "TYPE=" + "TYPES-EQUAL-OR-INTERSECT" + "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY" "UNDEFINED-SYMBOL-ERROR" "UNION-TYPE" "UNION-TYPE-P" "UNION-TYPE-TYPES" "UNKNOWN-ERROR" "UNKNOWN-KEY-ARGUMENT-ERROR" @@ -1139,7 +1126,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "VALUES-TYPE-KEYWORDS" "VALUES-TYPE-OPTIONAL" "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED" "VALUES-TYPE-REST" "VALUES-TYPE-UNION" - "VALUES-TYPES" "VALUES-TYPES-INTERSECT" "VECTOR-T-P" + "VALUES-TYPES" "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P" "VECTOR-TO-VECTOR*" "VECTOR-TO-SIMPLE-STRING*" "VECTOR-TO-BIT-VECTOR*" "VECTOR-TO-SIMPLE-BIT-VECTOR*" "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" @@ -1165,7 +1152,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "DEFSTRUCT-DESCRIPTION" "UNDEFINE-STRUCTURE" "DD-COPIER" "UNDEFINE-FUNCTION-NAME" "DD-TYPE" "CLASS-STATE" "INSTANCE" - "*TYPE-SYSTEM-INITIALIZED*" "WEAK-POINTER-P" "FIND-LAYOUT" + "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT" "DSD-NAME" "%TYPEP" "DD-RAW-INDEX" "DD-NAME" "CLASS-SUBCLASSES" "CLASS-LAYOUT" "CLASS-%NAME" diff --git a/src/code/backq.lisp b/src/code/backq.lisp index c601ee4..710e402 100644 --- a/src/code/backq.lisp +++ b/src/code/backq.lisp @@ -133,7 +133,7 @@ (cond ((atom code) (cond ((null code) (values nil nil)) - ((or (numberp code) (eq code 't)) + ((or (numberp code) (eq code t)) (values t code)) (t (values *bq-comma-flag* code)))) ((eq (car code) 'quote) diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index aaafdfa..a890b0a 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -27,19 +27,19 @@ (etypecase x (simple-byte-function `(function ,(make-list (simple-byte-function-num-args x) - :initial-element 't) + :initial-element t) *)) (hairy-byte-function (collect ((res)) (let ((min (hairy-byte-function-min-args x)) (max (hairy-byte-function-max-args x))) - (dotimes (i min) (res 't)) + (dotimes (i min) (res t)) (when (> max min) (res '&optional) (dotimes (i (- max min)) - (res 't)))) + (res t)))) (when (hairy-byte-function-rest-arg-p x) - (res '&rest 't)) + (res '&rest t)) (ecase (hairy-byte-function-keywords-p x) ((t :allow-others) (res '&key) diff --git a/src/code/class.lisp b/src/code/class.lisp index c25ae3b..fda5bed 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -1092,15 +1092,15 @@ '(t)))) x (declare (ignore codes state translation)) - (let ((inherits-list (if (eq name 't) - () - (cons 't (reverse inherits)))) + (let ((inherits-list (if (eq name t) + () + (cons t (reverse inherits)))) (class (make-built-in-class :enumerable enumerable :name name :translation (if trans-p :initializing nil) :direct-superclasses - (if (eq name 't) + (if (eq name t) nil (mapcar #'sb!xc:find-class direct-superclasses))))) (setf (info :type :kind name) :primitive diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp index 397e127..2a9389a 100644 --- a/src/code/cross-float.lisp +++ b/src/code/cross-float.lisp @@ -32,9 +32,9 @@ (mask (1- (ash high-bit 1))) (uresult (logand mask x))) (if (zerop (logand uresult high-bit)) - uresult - (logior uresult - (logand -1 (lognot mask)))))) + uresult + (logior uresult + (logand -1 (lognot mask)))))) ;;; portable implementations of SINGLE-FLOAT-BITS, ;;; DOUBLE-FLOAT-LOW-BITS, and DOUBLE-FLOAT-HIGH-BITS @@ -55,116 +55,140 @@ (declare (type single-float x)) (assert (= (float-radix x) 2)) (if (zerop x) - 0 ; known property of IEEE floating point: 0.0 is represented as 0. - (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) - (integer-decode-float x) - (assert (plusp lisp-significand)) - ;; Calculate IEEE-style fields from Common-Lisp-style fields. - ;; - ;; KLUDGE: This code was written from my foggy memory of what IEEE - ;; format looks like, augmented by some experiments with - ;; the existing implementation of SINGLE-FLOAT-BITS, and what - ;; I found floating around on the net at - ;; , - ;; , - ;; and - ;; . - ;; And beyond the probable sheer flakiness of the code, all the bare - ;; numbers floating around here are sort of ugly, too. -- WHN 19990711 - (let* ((significand lisp-significand) - (exponent (+ lisp-exponent 23 127)) - (unsigned-result - (if (plusp exponent) ; if not obviously denormalized - (do () - (nil) - (cond (;; ordinary termination case - (>= significand (expt 2 23)) - (assert (< 0 significand (expt 2 24))) - ;; Exponent 0 is reserved for denormalized numbers, - ;; and 255 is reserved for specials like NaN. - (assert (< 0 exponent 255)) - (return (logior (ash exponent 23) - (logand significand - (1- (ash 1 23)))))) - (;; special termination case, denormalized float number - (zerop exponent) - ;; Denormalized numbers have exponent one greater than - ;; the exponent field. - (return (ash significand -1))) - (t - ;; Shift as necessary to set bit 24 of significand. - (setf significand (ash significand 1) - exponent (1- exponent))))) - (do () - ((zerop exponent) - ;; Denormalized numbers have exponent one greater than the - ;; exponent field. - (ash significand -1)) - (unless (zerop (logand significand 1)) - (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" x)) - (setf significand (ash significand -1) - exponent (1+ exponent)))))) - (ecase lisp-sign - (1 unsigned-result) - (-1 (logior unsigned-result (- (expt 2 31))))))))) + 0 ; known property of IEEE floating point: 0.0 is represented as 0. + (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) + (integer-decode-float x) + (assert (plusp lisp-significand)) + ;; Calculate IEEE-style fields from Common-Lisp-style fields. + ;; + ;; KLUDGE: This code was written from my foggy memory of what IEEE + ;; format looks like, augmented by some experiments with + ;; the existing implementation of SINGLE-FLOAT-BITS, and what + ;; I found floating around on the net at + ;; , + ;; , + ;; and + ;; . + ;; And beyond the probable sheer flakiness of the code, all the bare + ;; numbers floating around here are sort of ugly, too. -- WHN 19990711 + (let* ((significand lisp-significand) + (exponent (+ lisp-exponent 23 127)) + (unsigned-result + (if (plusp exponent) ; if not obviously denormalized + (do () + (nil) + (cond (;; ordinary termination case + (>= significand (expt 2 23)) + (assert (< 0 significand (expt 2 24))) + ;; Exponent 0 is reserved for + ;; denormalized numbers, and 255 is + ;; reserved for specials like NaN. + (assert (< 0 exponent 255)) + (return (logior (ash exponent 23) + (logand significand + (1- (ash 1 23)))))) + (;; special termination case, denormalized + ;; float number + (zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (return (ash significand -1))) + (t + ;; Shift as necessary to set bit 24 of + ;; significand. + (setf significand (ash significand 1) + exponent (1- exponent))))) + (do () + ((zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (ash significand -1)) + (unless (zerop (logand significand 1)) + (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" + x)) + (setf significand (ash significand -1) + exponent (1+ exponent)))))) + (ecase lisp-sign + (1 unsigned-result) + (-1 (logior unsigned-result (- (expt 2 31))))))))) (defun double-float-bits (x) (declare (type double-float x)) (assert (= (float-radix x) 2)) (if (zerop x) - 0 ; known property of IEEE floating point: 0.0d0 is represented as 0. - ;; KLUDGE: As per comments in SINGLE-FLOAT-BITS, above. - (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) - (integer-decode-float x) - (assert (plusp lisp-significand)) - (let* ((significand lisp-significand) - (exponent (+ lisp-exponent 52 1023)) - (unsigned-result - (if (plusp exponent) ; if not obviously denormalized - (do () - (nil) - (cond (;; ordinary termination case - (>= significand (expt 2 52)) - (assert (< 0 significand (expt 2 53))) - ;; Exponent 0 is reserved for denormalized numbers, - ;; and 2047 is reserved for specials like NaN. - (assert (< 0 exponent 2047)) - (return (logior (ash exponent 52) - (logand significand - (1- (ash 1 52)))))) - (;; special termination case, denormalized float number - (zerop exponent) - ;; Denormalized numbers have exponent one greater than - ;; the exponent field. - (return (ash significand -1))) - (t - ;; Shift as necessary to set bit 53 of significand. - (setf significand (ash significand 1) - exponent (1- exponent))))) - (do () - ((zerop exponent) - ;; Denormalized numbers have exponent one greater than the - ;; exponent field. - (ash significand -1)) - (unless (zerop (logand significand 1)) - (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" x)) - (setf significand (ash significand -1) - exponent (1+ exponent)))))) - (ecase lisp-sign - (1 unsigned-result) - (-1 (logior unsigned-result (- (expt 2 63))))))))) + 0 ; known property of IEEE floating point: 0.0d0 is represented as 0. + ;; KLUDGE: As per comments in SINGLE-FLOAT-BITS, above. + (multiple-value-bind (lisp-significand lisp-exponent lisp-sign) + (integer-decode-float x) + (assert (plusp lisp-significand)) + (let* ((significand lisp-significand) + (exponent (+ lisp-exponent 52 1023)) + (unsigned-result + (if (plusp exponent) ; if not obviously denormalized + (do () + (nil) + (cond (;; ordinary termination case + (>= significand (expt 2 52)) + (assert (< 0 significand (expt 2 53))) + ;; Exponent 0 is reserved for + ;; denormalized numbers, and 2047 is + ;; reserved for specials like NaN. + (assert (< 0 exponent 2047)) + (return (logior (ash exponent 52) + (logand significand + (1- (ash 1 52)))))) + (;; special termination case, denormalized + ;; float number + (zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (return (ash significand -1))) + (t + ;; Shift as necessary to set bit 53 of + ;; significand. + (setf significand (ash significand 1) + exponent (1- exponent))))) + (do () + ((zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (ash significand -1)) + (unless (zerop (logand significand 1)) + (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" + x)) + (setf significand (ash significand -1) + exponent (1+ exponent)))))) + (ecase lisp-sign + (1 unsigned-result) + (-1 (logior unsigned-result (- (expt 2 63))))))))) (defun double-float-low-bits (x) (declare (type double-float x)) (if (zerop x) - 0 - ;; Unlike DOUBLE-FLOAT-HIGH-BITS or SINGLE-FLOAT-BITS, the CMU CL - ;; DOUBLE-FLOAT-LOW-BITS seems to return a unsigned value, not a signed - ;; value. - (logand #xffffffff (double-float-bits x)))) + 0 + ;; FIXME: Unlike DOUBLE-FLOAT-HIGH-BITS or SINGLE-FLOAT-BITS, + ;; the CMU CL DOUBLE-FLOAT-LOW-BITS seemed to return a unsigned + ;; value, not a signed value, so we've done the same. But it + ;; would be nice to make the family of functions have a more + ;; consistent return convention. + (logand #xffffffff (double-float-bits x)))) (defun double-float-high-bits (x) (declare (type double-float x)) (if (zerop x) - 0 - (mask-and-sign-extend (ash (double-float-bits x) -32) 32))) + 0 + (mask-and-sign-extend (ash (double-float-bits x) -32) 32))) + +;;; KLUDGE: This is a hack to work around a bug in CMU CL 18c which +;;; causes the 18c compiler to die with a floating point exception +;;; when trying to optimize the EXPT forms in the MAKE-FOO-FLOAT +;;; functions below. See the message +;;; Subject: Re: Compiler bug? +;;; From: Raymond Toy +;;; Date: 28 Mar 2001 08:19:59 -0500 +;;; Message-ID: <4nvgou3u9s.fsf@rtp.ericsson.se> +;;; on the cmucl-imp@cons.org mailing list. Once the CMU CL folks +;;; make a bug-fix release, we can get rid of this and go back to +;;; calling EXPT directly. -- WHN 2001-04-05 +(defun kludge-opaque-expt (x y) + (expt x y)) ;;; KLUDGE: These functions will blow up on any cross-compilation ;;; host Lisp which has less floating point precision than the target @@ -184,24 +208,24 @@ ;;; with this quick kludge instead.) -- WHN 19990711 (defun make-single-float (bits) (if (zerop bits) ; IEEE float special case - 0.0 - (let ((sign (ecase (ldb (byte 1 31) bits) - (0 1.0) - (1 -1.0))) - (expt (- (ldb (byte 8 23) bits) 127)) - (mant (* (logior (ldb (byte 23 0) bits) - (ash 1 23)) - (expt 0.5 23)))) - (* sign (expt 2.0 expt) mant)))) + 0.0 + (let ((sign (ecase (ldb (byte 1 31) bits) + (0 1.0) + (1 -1.0))) + (expt (- (ldb (byte 8 23) bits) 127)) + (mant (* (logior (ldb (byte 23 0) bits) + (ash 1 23)) + (expt 0.5 23)))) + (* sign (kludge-opaque-expt 2.0 expt) mant)))) (defun make-double-float (hi lo) (if (and (zerop hi) (zerop lo)) ; IEEE float special case - 0.0d0 - (let* ((bits (logior (ash hi 32) lo)) - (sign (ecase (ldb (byte 1 63) bits) - (0 1.0d0) - (1 -1.0d0))) - (expt (- (ldb (byte 11 52) bits) 1023)) - (mant (* (logior (ldb (byte 52 0) bits) - (ash 1 52)) - (expt 0.5d0 52)))) - (* sign (expt 2.0d0 expt) mant)))) + 0.0d0 + (let* ((bits (logior (ash hi 32) lo)) + (sign (ecase (ldb (byte 1 63) bits) + (0 1.0d0) + (1 -1.0d0))) + (expt (- (ldb (byte 11 52) bits) 1023)) + (mant (* (logior (ldb (byte 52 0) bits) + (ash 1 52)) + (expt 0.5d0 52)))) + (* sign (kludge-opaque-expt 2.0d0 expt) mant)))) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 29e47a9..ad90045 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -1591,7 +1591,7 @@ argument") (if function (describe function) (format t "can't figure out the function for this frame")))) - < + ;;;; debug loop command utilities (defun read-prompting-maybe (prompt &optional (in *standard-input*) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 8ea7dae..40f7ba9 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -85,7 +85,7 @@ ;; classes, CLASS-STRUCTURE-P = NIL) ;; ;; vector element type - (element-type 't) + (element-type t) ;; T if :NAMED was explicitly specified, NIL otherwise (named nil :type boolean) ;; any INITIAL-OFFSET option on this direct type @@ -199,7 +199,7 @@ (funcall #',(farg po) ,x ,s)))) (t nil)))) ,@(let ((pure (dd-pure defstruct))) - (cond ((eq pure 't) + (cond ((eq pure t) `((setf (layout-pure (class-layout (sb!xc:find-class ',name))) t))) @@ -491,7 +491,7 @@ (cond ((eq type 'funcallable-structure) (setf (dd-type defstruct) type)) ((member type '(list vector)) - (setf (dd-element-type defstruct) 't) + (setf (dd-element-type defstruct) t) (setf (dd-type defstruct) type)) ((and (consp type) (eq (first type) 'vector)) (destructuring-bind (vector vtype) type @@ -619,7 +619,7 @@ (setf (dsd-default islot) default)) (when type-p (setf (dsd-type islot) - (if (eq (dsd-type islot) 't) + (if (eq (dsd-type islot) t) type `(and ,(dsd-type islot) ,type)))) (when ro-p @@ -1166,7 +1166,7 @@ (t (dsd-index slot))) (cond - ((eq rtype 't) object) + ((eq rtype t) object) (data) (t `(truly-the (simple-array (unsigned-byte 32) (*)) diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp index 920c090..50bee46 100644 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@ -110,7 +110,7 @@ ;;; something legal in an evaluated context ;;; FIXME: could probably go away -(sb!xc:deftype form () 't) +(sb!xc:deftype form () t) ;;; Maclisp compatibility... ;;; FIXME: should be STRING-DESIGNATOR (the term used in the ANSI spec) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 3154ef4..e93074c 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -445,10 +445,8 @@ (declaim (ftype (function (symbol t stream) (values)) defprinter-prin1 defprinter-princ)) (defun defprinter-prin1 (name value stream) - (declare (ignore indent)) (defprinter-prinx #'prin1 name value stream)) (defun defprinter-princ (name value stream) - (declare (ignore indent)) (defprinter-prinx #'princ name value stream)) (defun defprinter-prinx (prinx name value stream) (declare (type function prinx)) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index d7a1199..0881f04 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -787,7 +787,7 @@ "could not restore ~S to its original contents: ~A" (fd-stream-file stream) (sb!unix:get-unix-error-msg err)))) - ;; We can't restore the orignal, so nuke that puppy. + ;; We can't restore the original, so nuke that puppy. (multiple-value-bind (okay err) (sb!unix:unix-unlink (fd-stream-file stream)) (unless okay diff --git a/src/code/format-time.lisp b/src/code/format-time.lisp index d572d02..9736122 100644 --- a/src/code/format-time.lisp +++ b/src/code/format-time.lisp @@ -35,7 +35,7 @@ ;;; FORMAT function. (defun valid-destination-p (destination) (or (not destination) - (eq destination 't) + (eq destination t) (streamp destination) (and (stringp destination) (array-has-fill-pointer-p destination)))) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index bc8fc16..5d05e7b 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -466,7 +466,7 @@ ;;; than the precise result. ;;; ;;; The return convention seems to be analogous to -;;; TYPES-INTERSECT. -- WHN 19990910. +;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910. (defun-cached (values-type-union :hash-function type-cache-hash :hash-bits 8 :default nil @@ -493,22 +493,19 @@ #'max (specifier-type 'null))))) -;;; This is like TYPES-INTERSECT, except that it sort of works on -;;; VALUES types. Note that due to the semantics of +;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of +;;; works on VALUES types. Note that due to the semantics of ;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when -;;; there isn't really any intersection (?). -;;; -;;; The return convention seems to be analogous to -;;; TYPES-INTERSECT. -- WHN 19990910. -(defun values-types-intersect (type1 type2) +;;; there isn't really any intersection. +(defun values-types-equal-or-intersect (type1 type2) (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) - (values 't t)) + (values t t)) ((or (values-type-p type1) (values-type-p type2)) (multiple-value-bind (res win) (values-type-intersection type1 type2) (values (not (eq res *empty-type*)) win))) (t - (types-intersect type1 type2)))) + (types-equal-or-intersect type1 type2)))) ;;; a SUBTYPEP-like operation that can be used on any types, including ;;; VALUES types @@ -522,7 +519,7 @@ (cond ((eq type2 *wild-type*) (values t t)) ((eq type1 *wild-type*) (values (eq type2 *universal-type*) t)) - ((not (values-types-intersect type1 type2)) + ((not (values-types-equal-or-intersect type1 type2)) (values nil t)) (t (if (or (values-type-p type1) (values-type-p type2)) @@ -711,15 +708,15 @@ ((hairy-type-p type1) type2) (t type1))) -;;; The first value is true unless the types don't intersect. The -;;; second value is true if the first value is definitely correct. NIL -;;; is considered to intersect with any type. If T is a subtype of -;;; either type, then we also return T, T. This way we recognize -;;; that hairy types might intersect with T. +;;; a test useful for checking whether a derived type matches a +;;; declared type ;;; -;;; FIXME: It would be more accurate to call this TYPES-MIGHT-INTERSECT, -;;; and rename VALUES-TYPES-INTERSECT the same way. -(defun types-intersect (type1 type2) +;;; The first value is true unless the types don't intersect and +;;; aren't equal. The second value is true if the first value is +;;; definitely correct. NIL is considered to intersect with any type. +;;; If T is a subtype of either type, then we also return T, T. This +;;; way we recognize that hairy types might intersect with T. +(defun types-equal-or-intersect (type1 type2) (declare (type ctype type1 type2)) (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) (values t t) @@ -915,9 +912,9 @@ (aver (not (hairy-type-p type2))) ;; Besides the old CMU CL assertion above, we also need to avoid ;; compound types, else we could get into trouble with - ;; (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR))) + ;; (SUBTYPEP T '(OR (SATISFIES FOO) (SATISFIES BAR))) ;; or - ;; (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))). + ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))). (aver (not (compound-type-p type2))) ;; Then, since TYPE2 is reasonably tractable, we're good to go. (values (eq type1 *empty-type*) t)) @@ -1492,7 +1489,7 @@ nil)) ;;; Handle the case of type intersection on two numeric types. We use -;;; TYPES-INTERSECT to throw out the case of types with no +;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no ;;; intersection. If an attribute in TYPE1 is unspecified, then we use ;;; TYPE2's attribute, which must be at least as restrictive. If the ;;; types intersect, then the only attributes that can be specified @@ -1804,7 +1801,7 @@ ;;; subtype of the MEMBER type. (!define-type-method (member :complex-subtypep-arg2) (type1 type2) (cond ((not (type-enumerable type1)) (values nil t)) - ((types-intersect type1 type2) (values nil nil)) + ((types-equal-or-intersect type1 type2) (values nil nil)) (t (values nil t)))) (!define-type-method (member :simple-intersection2) (type1 type2) @@ -2107,7 +2104,7 @@ (multiple-value-bind (val win) (csubtypep x-type y-type) (unless win (return-from type-difference nil)) (when val (return)) - (when (types-intersect x-type y-type) + (when (types-equal-or-intersect x-type y-type) (return-from type-difference nil)))))) (let ((y-mem (find-if #'member-type-p y-types))) (when y-mem diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 43c66d7..0a59951 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -961,7 +961,7 @@ (stringp array) (bit-vector-p array)) (output-ugly-object array stream)) - ((and *print-readably* (not (eq (array-element-type array) 't))) + ((and *print-readably* (not (eq (array-element-type array) t))) (let ((*print-readably* nil)) (error 'print-not-readable :object array))) ((vectorp array) diff --git a/src/code/print.lisp b/src/code/print.lisp index 53507ee..593c490 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -969,7 +969,7 @@ (output-object (aref vector i) stream))) (t (when (and *print-readably* - (not (eq (array-element-type vector) 't))) + (not (eq (array-element-type vector) t))) (error 'print-not-readable :object vector)) (descend-into (stream) (write-string "#(" stream) diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 32661aa..6d921b1 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -1273,7 +1273,8 @@ (error "The dispatch character ~S already exists." char)) (t (setf (dispatch-tables rt) - (push (cons char (make-char-dispatch-table)) dalist)))))) + (push (cons char (make-char-dispatch-table)) dalist))))) + t) (defun set-dispatch-macro-character (disp-char sub-char function &optional (rt *readtable*)) diff --git a/src/code/string.lisp b/src/code/string.lisp index 10e5dcd..28cb331 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -94,8 +94,8 @@ (eval-when (:compile-toplevel :execute) -;;; Lessp is true if the desired expansion is for string<* or string<=*. -;;; Equalp is true if the desired expansion is for string<=* or string>=*. +;;; LESSP is true if the desired expansion is for STRING<* or STRING<=*. +;;; EQUALP is true if the desired expansion is for STRING<=* or STRING>=*. (sb!xc:defmacro string<>=*-body (lessp equalp) (let ((offset1 (gensym))) `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2 @@ -116,7 +116,7 @@ (schar string2 (+ (the fixnum index) (- start2 start1)))) (- (the fixnum index) ,offset1)) (t nil)) - ,(if equalp `(- (the fixnum end1) ,offset1) 'nil)))))) + ,(if equalp `(- (the fixnum end1) ,offset1) nil)))))) ) ; EVAL-WHEN (defun string<* (string1 string2 start1 end1 start2 end2) diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index 648432a..f112680 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -188,7 +188,7 @@ (defmacro fast-read-byte (&optional (eof-error-p t) (eof-value ()) any-type) ;; KLUDGE: should use ONCE-ONLY on EOF-ERROR-P and EOF-VALUE -- WHN 19990825 `(truly-the - ,(if (and (eq eof-error-p 't) (not any-type)) '(unsigned-byte 8) 't) + ,(if (and (eq eof-error-p t) (not any-type)) '(unsigned-byte 8) t) (cond ((not %frc-buffer%) (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value)) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index 5501cdd..eb86005 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -384,7 +384,7 @@ (specifier-type (compute-alien-rep-type (local-alien-info-type info)))))))) - 'nil) + nil) (deftransform local-alien ((info var) * * :important t) (unless (constant-continuation-p info) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 945e154..05e57ab 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -108,7 +108,7 @@ (unsupplied-or-nil fill-pointer)))) (specifier-type `(,(if simple 'simple-array 'array) - ,(cond ((not element-type) 't) + ,(cond ((not element-type) t) ((constant-continuation-p element-type) (continuation-value element-type)) (t diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index 912ea91..d23f8d7 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -488,7 +488,7 @@ (let ((leaf (ref-leaf (continuation-use fun)))) (and (slot-accessor-p leaf) (or (policy call (zerop safety)) - (not (find 't args + (not (find t args :key #'continuation-type-check))) (if (consp name) (not (continuation-dest (node-cont call))) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 3c0303d..3441ad6 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -484,8 +484,8 @@ (unless (member type-check '(nil :error :deleted)) (let ((atype (continuation-asserted-type cont))) (do-uses (use cont) - (unless (values-types-intersect (node-derived-type use) - atype) + (unless (values-types-equal-or-intersect + (node-derived-type use) atype) (mark-error-continuation cont) (unless (policy node (= inhibit-warnings 3)) (do-type-warning use)))))) diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 52b6ee9..584f656 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -375,7 +375,7 @@ (csubtypep (specifier-type 'null) not-res) (eq (continuation-asserted-type cont) *wild-type*)) (setf (node-derived-type ref) *wild-type*) - (change-ref-leaf ref (find-constant 't))) + (change-ref-leaf ref (find-constant t))) (t (derive-node-type ref (or (type-difference res not-res) res))))))) diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index e94c732..948c0df 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -423,7 +423,8 @@ (values boolean boolean)) valid-approximate-type)) (defun valid-approximate-type (call-type type &optional - (*test-function* #'types-intersect) + (*test-function* + #'types-equal-or-intersect) (*error-function* #'compiler-style-warning) (*warning-function* #'compiler-note)) @@ -730,7 +731,8 @@ (atype (when return (continuation-asserted-type (return-result return))))) (cond - ((and atype (not (values-types-intersect atype type-returns))) + ((and atype (not (values-types-equal-or-intersect atype + type-returns))) (note-lossage "The result type from ~A:~% ~S~@ conflicts with the definition's result type assertion:~% ~S" diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 1cf4f85..434fefe 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -252,7 +252,7 @@ :compiled (source-info-start-time info) :source-root (file-info-source-root x) :start-positions - (unless (eq *byte-compile* 't) + (unless (eq *byte-compile* t) (coerce-to-smallest-eltype (file-info-positions x))))) (name (file-info-name x))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 67288ae..2baedb4 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -97,7 +97,7 @@ ;;;; classes -(sb!xc:deftype name-for-class () 't) +(sb!xc:deftype name-for-class () t) (defknown class-name (sb!xc:class) name-for-class (flushable)) (defknown find-class (name-for-class &optional t lexenv) (or sb!xc:class null) ()) @@ -893,7 +893,7 @@ (movable foldable flushable)) (defknown (output-stream-p input-stream-p) (stream) boolean (movable foldable flushable)) -(defknown close (stream &key (:abort t)) stream ()) +(defknown close (stream &key (:abort t)) (eql t) ()) ;;;; from the "Input/Output" chapter: @@ -919,7 +919,7 @@ (defknown make-dispatch-macro-character (character &optional t readtable) (eql t) ()) (defknown set-dispatch-macro-character - (character character callable &optional readtable) (eql t) + (character character callable &optional readtable) function (unsafe)) (defknown get-dispatch-macro-character (character character &optional (or readtable null)) callable diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 3e33039..b566b11 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -18,7 +18,7 @@ (!def-primitive-type t (descriptor-reg)) (/show0 "primtype.lisp 20") -(setf *backend-t-primitive-type* (primitive-type-or-lose 't)) +(setf *backend-t-primitive-type* (primitive-type-or-lose t)) ;;; primitive integer types that fit in registers (/show0 "primtype.lisp 24") diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 9dcf76d..4a1b4fa 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -133,8 +133,7 @@ (if (eq eltype *wild-type*) *wild-type* (dolist (stype-name *specialized-array-element-types* - ;; FIXME: Use *UNIVERSAL-TYPE* here? - (specifier-type 't)) + *universal-type*) ;; FIXME: Mightn't it be better to have ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated ;; SPECIFIER-TYPE results, instead of having to calculate diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index 92548d9..8f8cb16 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -30,8 +30,8 @@ (compiler-note "~@" note (first what) (rest what))) ((valid-function-use node what - :argument-test #'types-intersect - :result-test #'values-types-intersect) + :argument-test #'types-equal-or-intersect + :result-test #'values-types-equal-or-intersect) (collect ((messages)) (flet ((frob (string &rest stuff) (messages string) @@ -77,7 +77,21 @@ (setf (info :function :type name) dtype) (setf (info :function :assumed-type name) nil)) (setf (info :function :where-from name) :defined)) - (:declared); Just keep declared type. + (:declared + ;; Check that derived type matches declared type. + (let ((type (info :function :type name))) + (when (and type (function-type-p dtype)) + (let ((type-returns (function-type-returns type)) + (dtype-returns (function-type-returns dtype)) + (*error-function* #'compiler-warning)) + (unless (values-types-equal-or-intersect type-returns + dtype-returns) + (note-lossage "The result type from previous declaration:~% ~S~@ + conflicts with the result type:~% ~S" + (type-specifier type-returns) + (type-specifier dtype-returns)))))) + ;; (Regardless of what happens, we keep the declared type.) + ) (:defined (when global-p (setf (info :function :type name) dtype))))))) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 78ffa84..79a89ed 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -539,7 +539,7 @@ (if (continuation-value test) (if-alternative node) (if-consequent node))) - ((not (types-intersect type (specifier-type 'null))) + ((not (types-equal-or-intersect type (specifier-type 'null))) (if-alternative node)) ((type= type (specifier-type 'null)) (if-consequent node))))) @@ -985,8 +985,9 @@ ((and flame (valid-function-use node type - :argument-test #'types-intersect - :result-test #'values-types-intersect)) + :argument-test #'types-equal-or-intersect + :result-test + #'values-types-equal-or-intersect)) (record-optimization-failure node transform type) t) (t @@ -1522,4 +1523,4 @@ `(lambda (val ,@dummies) (declare (ignore ,@dummies)) val)) - 'nil)) + nil)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 5752d6e..ae66986 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1596,7 +1596,7 @@ (values)) -;;; This is called by IR1-Convert-Hairy-Args when we run into a &REST +;;; This is called by IR1-CONVERT-HAIRY-ARGS when we run into a &REST ;;; or &KEY arg. The arguments are similar to that function, but we ;;; split off any &REST arg and pass it in separately. REST is the ;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of @@ -1691,29 +1691,30 @@ ;;; arguments, analyzing the arglist on the way down and generating entry ;;; points on the way up. ;;; -;;; Default-Vars is a reversed list of all the argument vars processed so -;;; far, including supplied-p vars. Default-Vals is a list of the names of the -;;; Default-Vars. +;;; Default-Vars is a reversed list of all the argument vars processed +;;; so far, including supplied-p vars. Default-Vals is a list of the +;;; names of the Default-Vars. ;;; -;;; Entry-Vars is a reversed list of processed argument vars, excluding -;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get -;;; the values for all the vars from the Entry-Vars. It has the var name for -;;; each required or optional arg, and has T for each supplied-p arg. +;;; Entry-Vars is a reversed list of processed argument vars, +;;; excluding supplied-p vars. Entry-Vals is a list things that can be +;;; evaluated to get the values for all the vars from the Entry-Vars. +;;; It has the var name for each required or optional arg, and has T +;;; for each supplied-p arg. ;;; -;;; Vars is a list of the Lambda-Var structures for arguments that haven't -;;; been processed yet. Supplied-p-p is true if a supplied-p argument has -;;; already been processed; only in this case are the Default-XXX and Entry-XXX -;;; different. +;;; Vars is a list of the Lambda-Var structures for arguments that +;;; haven't been processed yet. Supplied-p-p is true if a supplied-p +;;; argument has already been processed; only in this case are the +;;; Default-XXX and Entry-XXX different. ;;; -;;; The result at each point is a lambda which should be called by the above -;;; level to default the remaining arguments and evaluate the body. We cause -;;; the body to be evaluated by converting it and returning it as the result -;;; when the recursion bottoms out. +;;; The result at each point is a lambda which should be called by the +;;; above level to default the remaining arguments and evaluate the +;;; body. We cause the body to be evaluated by converting it and +;;; returning it as the result when the recursion bottoms out. ;;; -;;; Each level in the recursion also adds its entry point function to the -;;; result Optional-Dispatch. For most arguments, the defaulting function and -;;; the entry point function will be the same, but when supplied-p args are -;;; present they may be different. +;;; Each level in the recursion also adds its entry point function to +;;; the result Optional-Dispatch. For most arguments, the defaulting +;;; function and the entry point function will be the same, but when +;;; supplied-p args are present they may be different. ;;; ;;; When we run into a &REST or &KEY arg, we punt out to ;;; IR1-CONVERT-MORE, which finishes for us in this case. @@ -1779,9 +1780,9 @@ aux-vals cont))))))) ;;; This function deals with the case where we have to make an -;;; Optional-Dispatch to represent a lambda. We cons up the result and call -;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the -;;; min-args and max-args. +;;; Optional-Dispatch to represent a lambda. We cons up the result and +;;; call IR1-Convert-Hairy-Args to do the work. When it is done, we +;;; figure out the min-args and max-args. (defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont) (declare (list body vars aux-vars aux-vals) (type continuation cont)) (let ((res (make-optional-dispatch :arglist vars @@ -2586,7 +2587,7 @@ (let* ((ctype (values-specifier-type type)) (old-type (or (lexenv-find cont type-restrictions) *wild-type*)) - (intersects (values-types-intersect old-type ctype)) + (intersects (values-types-equal-or-intersect old-type ctype)) (int (values-type-intersection old-type ctype)) (new (if intersects int old-type))) (when (null (find-uses cont)) @@ -3115,9 +3116,6 @@ ;; 3.2.2.3 of the spec) but at least as of sbcl-0.6.11, we don't ;; keep track of whether the mismatched data came from the same ;; compilation unit, so we can't do that. -- WHN 2001-02-11 - ;; - ;; FIXME: Actually, I think we could issue a full WARNING if the - ;; new definition contradicts a DECLAIM FTYPE. :error-function #'compiler-style-warning :warning-function (cond (info #'compiler-style-warning) (for-real #'compiler-note) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index ab01bce..6d3a1a0 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -273,21 +273,21 @@ #!-sb-fluid (declare (inline node-home-lambda)) (lambda-environment (node-home-lambda (block-last block)))) -;;; Return the Top Level Form number of path, i.e. the ordinal number of -;;; its orignal source's top-level form in its compilation unit. +;;; Return the Top Level Form number of path, i.e. the ordinal number +;;; of its original source's top-level form in its compilation unit. (defun source-path-tlf-number (path) (declare (list path)) (car (last path))) -;;; Return the (reversed) list for the path in the orignal source (with the -;;; TLF number last.) +;;; Return the (reversed) list for the path in the original source +;;; (with the Top Level Form number last). (defun source-path-original-source (path) (declare (list path) (inline member)) (cddr (member 'original-source-start path :test #'eq))) -;;; Return the Form Number of Path's orignal source inside the Top Level -;;; Form that contains it. This is determined by the order that we walk the -;;; subforms of the top level source form. +;;; Return the Form Number of Path's original source inside the Top +;;; Level Form that contains it. This is determined by the order that +;;; we walk the subforms of the top level source form. (defun source-path-form-number (path) (declare (list path) (inline member)) (cadr (member 'original-source-start path :test #'eq))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index dadfbdd..d848bf6 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -154,7 +154,7 @@ (cond ,@(if more (butlast (entries)) (entries)) ,@(when more - `((,(if (zerop min) 't `(>= ,n-supplied ,max)) + `((,(if (zerop min) t `(>= ,n-supplied ,max)) ,(let ((n-context (gensym)) (n-count (gensym))) `(multiple-value-bind (,n-context ,n-count) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index ba40a14..1ce7180 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -793,8 +793,9 @@ (and (template-note try) (valid-function-use call (template-type try) - :argument-test #'types-intersect - :result-test #'values-types-intersect)))) + :argument-test #'types-equal-or-intersect + :result-test + #'values-types-equal-or-intersect)))) (losers try))))) (when (losers) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 89de3a1..0f0f7de 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -56,7 +56,8 @@ forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE (the default.) When true, we decide to byte-compile.") -;;; default value of the :BYTE-COMPILE argument to the compiler +;;; the value of the :BYTE-COMPILE argument which was passed to the +;;; compiler (defvar *byte-compile* :maybe) ;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when @@ -474,38 +475,52 @@ (defun byte-compiling () (if (eq *byte-compiling* :maybe) (or (eq *byte-compile* t) + ;; FIXME: It's bad to share this expression between this + ;; function and LAMBDA-IS-BYTE-COMPILABLE-P (and who knows + ;; where else?), it should be factored out into some + ;; common function. (policy nil (and (zerop speed) (<= debug 1)))) (and *byte-compile* *byte-compiling*))) ;;; Delete components with no external entry points before we try to ;;; generate code. Unreachable closures can cause IR2 conversion to ;;; puke on itself, since it is the reference to the closure which -;;; normally causes the components to be combined. This doesn't really -;;; cover all cases... +;;; normally causes the components to be combined. +;;; +;;; FIXME: The original CMU CL comment said "This doesn't really cover +;;; all cases..." That's a little scary. (defun delete-if-no-entries (component) (dolist (fun (component-lambdas component) (delete-component component)) (case (functional-kind fun) (:top-level (return)) (:external - (unless (every #'(lambda (ref) - (eq (block-component (node-block ref)) - component)) + (unless (every (lambda (ref) + (eq (block-component (node-block ref)) + component)) (leaf-refs fun)) (return)))))) +(defun lambda-is-byte-compilable-p (lambda) + #| + (format t "~S SPEED=~S DEBUG=~S~%" ; REMOVEME + lambda + (policy (lambda-bind lambda) speed) + (policy (lambda-bind lambda) debug)) + |# + (policy (lambda-bind lambda) + (and (zerop speed) (<= debug 1)))) + +(defun byte-compile-this-component-p (component) + (ecase *byte-compile* + ((t) t) + ((nil) nil) + ((:maybe) + (every #'lambda-is-byte-compilable-p (component-lambdas component))))) + (defun compile-component (component) (let* ((*component-being-compiled* component) - (*byte-compiling* - (ecase *byte-compile* - ((t) t) - ((nil) nil) - (:maybe - (dolist (fun (component-lambdas component) t) - (unless (policy (lambda-bind fun) - (and (zerop speed) (<= debug 1))) - (return nil))))))) - + (*byte-compiling* (byte-compile-this-component-p component))) (when sb!xc:*compile-print* (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: " *byte-compiling* diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 12c594e..714cdf9 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -1172,7 +1172,7 @@ (make-array sc-number-limit :initial-element 0)) (defparameter *no-loads* - (make-array sc-number-limit :initial-element 't)) + (make-array sc-number-limit :initial-element t)) ;;; Pick off the case of operands with no restrictions. (defun compute-loading-costs-if-any (op load-p) @@ -1274,7 +1274,7 @@ ;;; satisfy the first test, and omit the second. (defun check-operand-type-scs (parse op type load-p) (declare (type vop-parse parse) (type operand-parse op)) - (let ((ptypes (if (eq type '*) (list 't) (rest type))) + (let ((ptypes (if (eq type '*) (list t) (rest type))) (scs (operand-parse-scs op))) (when scs (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 8bccb59..502d4b5 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -173,7 +173,7 @@ ;; Following the introduced forms is a representation of the ;; location of the enclosing original source form. This transition ;; is indicated by the magic ORIGINAL-SOURCE-START marker. The first - ;; element of the orignal source is the "form number", which is the + ;; element of the original source is the "form number", which is the ;; ordinal number of this form in a depth-first, left-to-right walk ;; of the truly top-level form in which this appears. ;; @@ -183,7 +183,7 @@ ;; ;; The last element in the list is the top-level form number, which ;; is the ordinal number (in this call to the compiler) of the truly - ;; top-level form containing the orignal source. + ;; top-level form containing the original source. (source-path *current-path* :type list) ;; If this node is in a tail-recursive position, then this is set to ;; T. At the end of IR1 (in environment analysis) this is computed diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 5fe42b1..39e494c 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -196,11 +196,12 @@ (when (eq (info :function :where-from name) :declared) (let ((old-type (info :function :type name))) (when (type/= type old-type) - (style-warn "new FTYPE proclamation~@ - ~S~@ - for ~S does not match old FTYPE proclamation~@ - ~S" - (list type name old-type))))) + (style-warn + "new FTYPE proclamation~@ + ~S~@ + for ~S does not match old FTYPE proclamation~@ + ~S" + (list type name old-type))))) (proclaim-as-function-name name) (note-name-defined name :function) @@ -209,7 +210,7 @@ (freeze-type (dolist (type args) (let ((class (specifier-type type))) - (when (typep class 'class) + (when (typep class 'sb!xc:class) (setf (class-state class) :sealed) (let ((subclasses (class-subclasses class))) (when subclasses diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 2a405a4..d72020d 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -249,7 +249,7 @@ `(if (funcall test e ',(car els)) ',els ,(frob (cdr els))) - 'nil))) + nil))) (frob val))))) ;;; FIXME: Rewrite this so that these definitions of DELETE, ASSOC, and MEMBER @@ -279,8 +279,8 @@ (cond (test (unless (continuation-function-is test '(eq)) (give-up-ir1-transform))) - ((types-intersect (continuation-type item) - (specifier-type 'number)) + ((types-equal-or-intersect (continuation-type item) + (specifier-type 'number)) (give-up-ir1-transform "Item might be a number."))) `(,eq-fun item list)))) @@ -620,7 +620,7 @@ (- start2 start1)))))) index) (t nil)) - ,(if equalp 'end1 'nil)))))) + ,(if equalp 'end1 nil)))))) (dolist (stuff '((string=* not) (string/=* identity))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 339db89..f70c854 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3067,9 +3067,10 @@ :defun-only t :when :both) (cond ((same-leaf-ref-p x y) - 't) - ((not (types-intersect (continuation-type x) (continuation-type y))) - 'nil) + t) + ((not (types-equal-or-intersect (continuation-type x) + (continuation-type y))) + nil) (t (give-up-ir1-transform)))) @@ -3096,14 +3097,14 @@ (char-type (specifier-type 'character)) (number-type (specifier-type 'number))) (cond ((same-leaf-ref-p x y) - 't) - ((not (types-intersect x-type y-type)) - 'nil) + t) + ((not (types-equal-or-intersect x-type y-type)) + nil) ((and (csubtypep x-type char-type) (csubtypep y-type char-type)) '(char= x y)) - ((or (not (types-intersect x-type number-type)) - (not (types-intersect y-type number-type))) + ((or (not (types-equal-or-intersect x-type number-type)) + (not (types-equal-or-intersect y-type number-type))) '(eq x y)) ((and (not (constant-continuation-p y)) (or (constant-continuation-p x) @@ -3161,7 +3162,7 @@ #!-sb-propagate-float-type (defun ir1-transform-< (x y first second inverse) (if (same-leaf-ref-p x y) - 'nil + nil (let* ((x-type (numeric-type-or-lose x)) (x-lo (numeric-type-low x-type)) (x-hi (numeric-type-high x-type)) @@ -3180,7 +3181,7 @@ #!+sb-propagate-float-type (defun ir1-transform-< (x y first second inverse) (if (same-leaf-ref-p x y) - 'nil + nil (let ((xi (numeric-type->interval (numeric-type-or-lose x))) (yi (numeric-type->interval (numeric-type-or-lose y)))) (cond ((interval-< xi yi) @@ -3236,11 +3237,11 @@ (last nil current) (current (gensym) (gensym)) (vars (list current) (cons current vars)) - (result 't (if not-p - `(if (,predicate ,current ,last) - nil ,result) - `(if (,predicate ,current ,last) - ,result nil)))) + (result t (if not-p + `(if (,predicate ,current ,last) + nil ,result) + `(if (,predicate ,current ,last) + ,result nil)))) ((zerop i) `((lambda ,vars ,result) . ,args))))))) @@ -3285,7 +3286,7 @@ (let ((vars (make-gensym-list nargs))) (do ((var vars next) (next (cdr vars) (cdr next)) - (result 't)) + (result t)) ((null next) `((lambda ,vars ,result) . ,args)) (let ((v1 (first var))) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index ed0cb35..b23410c 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -71,7 +71,7 @@ (defun ir1-transform-type-predicate (object type) (declare (type continuation object) (type ctype type)) (let ((otype (continuation-type object))) - (cond ((not (types-intersect otype type)) + (cond ((not (types-equal-or-intersect otype type)) nil) ((csubtypep otype type) t) @@ -407,14 +407,11 @@ (if (and res (not (layout-invalid res))) res nil)))) - (/noshow "entering DEFTRANSFORM %INSTANCE-TYPEP" otype spec class name layout) (cond ;; Flush tests whose result is known at compile time. - ((not (types-intersect otype class)) - (/noshow "flushing constant NIL") + ((not (types-equal-or-intersect otype class)) nil) ((csubtypep otype class) - (/noshow "flushing constant T") t) ;; If not properly named, error. ((not (and name (eq (sb!xc:find-class name) class))) @@ -431,12 +428,10 @@ (values '%instancep '%instance-layout)) (t (values '(lambda (x) (declare (ignore x)) t) 'layout-of))) - (/noshow pred get-layout) (cond ((and (eq (class-state class) :sealed) layout (not (class-subclasses class))) ;; Sealed and has no subclasses. - (/noshow "sealed and has no subclasses") (let ((n-layout (gensym))) `(and (,pred object) (let ((,n-layout (,get-layout object))) @@ -445,7 +440,6 @@ (%layout-invalid-error object ',layout)))) (eq ,n-layout ',layout))))) ((and (typep class 'basic-structure-class) layout) - (/noshow "structure type tests; hierarchical layout depths") ;; structure type tests; hierarchical layout depths (let ((depthoid (layout-depthoid layout)) (n-layout (gensym))) diff --git a/src/compiler/vmdef.lisp b/src/compiler/vmdef.lisp index cf523ad..0d03768 100644 --- a/src/compiler/vmdef.lisp +++ b/src/compiler/vmdef.lisp @@ -201,7 +201,7 @@ (flet ((convert (types more-types) (flet ((frob (x) (if (eq x '*) - 't + t (ecase (first x) (:or `(or ,@(mapcar #'(lambda (type) (type-specifier diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index 2cfa67d..1553085 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -43,7 +43,7 @@ (cond ;; Flush tests whose result is known at compile time. ((csubtypep otype std-obj) t) - ((not (types-intersect otype std-obj)) nil) + ((not (types-equal-or-intersect otype std-obj)) nil) (t `(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper))))) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 4e2b10d..76179ea 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -520,7 +520,7 @@ ,parameter) ,new-value)) (:boundp - 'T))) + t))) (let* ((parameter-entry (assq parameter slots)) (slot-entry (assq slot-name (cdr parameter-entry))) (position (posq parameter-entry slots)) diff --git a/version.lisp-expr b/version.lisp-expr index 2bce8a5..da5ccc5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.31" +"0.6.11.32"