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
(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
(: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
: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
: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"
;; 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*"
"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.
: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"
"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"
"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"
"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"
(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)
(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)
'(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
(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
(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
- ;; <http://www.scri.fsu.edu/~jac/MAD3401/Backgrnd/ieee.html>,
- ;; <http://rodin.cs.uh.edu/~johnson2/ieee.html>,
- ;; and
- ;; <http://www.ttu.ee/sidu/cas/IEEE_Floating.htm>.
- ;; 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
+ ;; <http://www.scri.fsu.edu/~jac/MAD3401/Backgrnd/ieee.html>,
+ ;; <http://rodin.cs.uh.edu/~johnson2/ieee.html>,
+ ;; and
+ ;; <http://www.ttu.ee/sidu/cas/IEEE_Floating.htm>.
+ ;; 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 <toy@rtp.ericsson.se>
+;;; 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
;;; 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))))
(if function
(describe function)
(format t "can't figure out the function for this frame"))))
-\f<
+\f
;;;; debug loop command utilities
(defun read-prompting-maybe (prompt &optional (in *standard-input*)
;; 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
(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)))
(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
(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
(t
(dsd-index slot)))
(cond
- ((eq rtype 't) object)
+ ((eq rtype t) object)
(data)
(t
`(truly-the (simple-array (unsigned-byte 32) (*))
;;; 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)
(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))
"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
;;; 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))))
;;; 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
#'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
(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))
((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)
(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))
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
;;; 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)
(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
(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)
(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)
(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*))
(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
(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)
(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))
(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)
(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
(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)))
(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))))))
(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)))))))
(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))
(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"
: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)))
\f
;;;; 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) ())
(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) ())
\f
;;;; from the "Input/Output" chapter:
(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
(!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")
(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
(compiler-note "~@<unable to ~2I~_~A ~I~_because: ~2I~_~?~:>"
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)
(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)))))))
(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)))))
((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
`(lambda (val ,@dummies)
(declare (ignore ,@dummies))
val))
- 'nil))
+ nil))
(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
;;; 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.
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
(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))
;; 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)
#!-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)))
(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)
(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)
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
(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*
(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)
;;; 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)
;; 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.
;;
;;
;; 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
(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)
(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
`(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
(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))))
(- start2 start1))))))
index)
(t nil))
- ,(if equalp 'end1 'nil))))))
+ ,(if equalp 'end1 nil))))))
(dolist (stuff '((string=* not)
(string/=* identity)))
: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))))
(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)
#!-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))
#!+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)
(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)))))))
(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)))
(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)
(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)))
(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)))
(%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)))
(flet ((convert (types more-types)
(flet ((frob (x)
(if (eq x '*)
- 't
+ t
(ecase (first x)
(:or `(or ,@(mapcar #'(lambda (type)
(type-specifier
(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)))))
,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))
;;; 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"
projects / sbcl.git / commitdiff