Make unknown variables signal a compile-time warning.
... slightly hacky (if (eq kind :variable) ...) in the
warning logic itself;
... rearrange bits of the build to eliminate technically
undefined forward references;
... fix for multiple *CURRENT-CATCH-BLOCK* and
*CURRENT-UNWIND-PROTECT-BLOCK*: we now have one and
only one of each variable, rather than three
* The runtime build system has been tweaked to support building
(on SPARC/SunOS) using a C compiler which invokes Sun's own
assembler and linker. (thanks to Nikodemus Siivola)
+ * Unbound, undefined, undeclared variables now trigger full
+ WARNINGs, not just STYLE-WARNINGs, on the assumption that this is
+ more often programmer error than deliberate exploitation of undefined
+ behaviour.
* optimization: implemented multiplication as a modular
(UNSIGNED-BYTE 32) operation on the PPC backend.
* fixed some bugs revealed by Paul Dietz' test suite:
("src/code/cross-float" :not-target)
("src/code/cross-io" :not-target)
("src/code/cross-sap" :not-target)
+ ("src/code/cross-thread" :not-target)
("src/code/cross-make-load-form" :not-target)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; stuff needed early both in cross-compilation host and in target Lisp
("src/code/uncross")
+ ("src/code/primordial-type")
("src/code/early-defbangmethod")
("src/code/defbangtype")
("src/code/target-error" :not-host)
+ ("src/compiler/early-backend")
;; a comment from classic CMU CL:
;; "These guys can supposedly come in any order, but not really.
;; Some are put at the end so that macros don't run interpreted
("src/code/misc-aliens" :not-host)
("src/code/array" :not-host)
- ("src/code/target-sxhash" :not-host)
+ ("src/code/early-float" :not-host)
+ ("src/code/target-sxhash" :not-host) ; needs most-fooative-foo-float constants
("src/code/list" :not-host)
("src/code/seq" :not-host) ; "code/seq" should come after "code/list".
;; (and so that they don't cause lots of annoying compiler warnings
;; about undefined types).
("src/compiler/generic/core")
- ("src/code/cross-thread" :not-target)
("src/code/thread")
("src/code/load")
name
layout))))))
-;;; a vector that maps type codes to layouts, used for quickly finding
-;;; the layouts of built-in classes
-(defvar *built-in-class-codes*) ; initialized in cold load
-(declaim (type simple-vector *built-in-class-codes*))
-
(!cold-init-forms
#-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
(setq *built-in-class-codes*
--- /dev/null
+;;;; This file contains the definitions of float-specific number
+;;;; support (other than irrational stuff, which is in irrat.) There is
+;;;; code in here that assumes there are only two float formats: IEEE
+;;;; single and double. (LONG-FLOAT support has been added, but bugs
+;;;; may still remain due to old code which assumes this dichotomy.)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+\f
+;;;; utilities
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; These functions let us create floats from bits with the
+;;; significand uniformly represented as an integer. This is less
+;;; efficient for double floats, but is more convenient when making
+;;; special values, etc.
+(defun single-from-bits (sign exp sig)
+ (declare (type bit sign) (type (unsigned-byte 24) sig)
+ (type (unsigned-byte 8) exp))
+ (make-single-float
+ (dpb exp sb!vm:single-float-exponent-byte
+ (dpb sig sb!vm:single-float-significand-byte
+ (if (zerop sign) 0 -1)))))
+(defun double-from-bits (sign exp sig)
+ (declare (type bit sign) (type (unsigned-byte 53) sig)
+ (type (unsigned-byte 11) exp))
+ (make-double-float (dpb exp sb!vm:double-float-exponent-byte
+ (dpb (ash sig -32)
+ sb!vm:double-float-significand-byte
+ (if (zerop sign) 0 -1)))
+ (ldb (byte 32 0) sig)))
+#!+(and long-float x86)
+(defun long-from-bits (sign exp sig)
+ (declare (type bit sign) (type (unsigned-byte 64) sig)
+ (type (unsigned-byte 15) exp))
+ (make-long-float (logior (ash sign 15) exp)
+ (ldb (byte 32 32) sig)
+ (ldb (byte 32 0) sig)))
+
+) ; EVAL-WHEN
+\f
+;;;; float parameters
+
+(defconstant least-positive-single-float (single-from-bits 0 0 1))
+(defconstant least-positive-short-float (single-from-bits 0 0 1))
+(defconstant least-negative-single-float (single-from-bits 1 0 1))
+(defconstant least-negative-short-float (single-from-bits 1 0 1))
+(defconstant least-positive-double-float (double-from-bits 0 0 1))
+#!-long-float
+(defconstant least-positive-long-float (double-from-bits 0 0 1))
+#!+(and long-float x86)
+(defconstant least-positive-long-float (long-from-bits 0 0 1))
+(defconstant least-negative-double-float (double-from-bits 1 0 1))
+#!-long-float
+(defconstant least-negative-long-float (double-from-bits 1 0 1))
+#!+(and long-float x86)
+(defconstant least-negative-long-float (long-from-bits 1 0 1))
+
+(defconstant least-positive-normalized-single-float
+ (single-from-bits 0 sb!vm:single-float-normal-exponent-min 0))
+(defconstant least-positive-normalized-short-float
+ least-positive-normalized-single-float)
+(defconstant least-negative-normalized-single-float
+ (single-from-bits 1 sb!vm:single-float-normal-exponent-min 0))
+(defconstant least-negative-normalized-short-float
+ least-negative-normalized-single-float)
+(defconstant least-positive-normalized-double-float
+ (double-from-bits 0 sb!vm:double-float-normal-exponent-min 0))
+#!-long-float
+(defconstant least-positive-normalized-long-float
+ least-positive-normalized-double-float)
+#!+(and long-float x86)
+(defconstant least-positive-normalized-long-float
+ (long-from-bits 0 sb!vm:long-float-normal-exponent-min
+ (ash sb!vm:long-float-hidden-bit 32)))
+(defconstant least-negative-normalized-double-float
+ (double-from-bits 1 sb!vm:double-float-normal-exponent-min 0))
+#!-long-float
+(defconstant least-negative-normalized-long-float
+ least-negative-normalized-double-float)
+#!+(and long-float x86)
+(defconstant least-negative-normalized-long-float
+ (long-from-bits 1 sb!vm:long-float-normal-exponent-min
+ (ash sb!vm:long-float-hidden-bit 32)))
+
+(defconstant most-positive-single-float
+ (single-from-bits 0 sb!vm:single-float-normal-exponent-max
+ (ldb sb!vm:single-float-significand-byte -1)))
+(defconstant most-positive-short-float most-positive-single-float)
+(defconstant most-negative-single-float
+ (single-from-bits 1 sb!vm:single-float-normal-exponent-max
+ (ldb sb!vm:single-float-significand-byte -1)))
+(defconstant most-negative-short-float most-negative-single-float)
+(defconstant most-positive-double-float
+ (double-from-bits 0 sb!vm:double-float-normal-exponent-max
+ (ldb (byte sb!vm:double-float-digits 0) -1)))
+#!-long-float
+(defconstant most-positive-long-float most-positive-double-float)
+#!+(and long-float x86)
+(defconstant most-positive-long-float
+ (long-from-bits 0 sb!vm:long-float-normal-exponent-max
+ (ldb (byte sb!vm:long-float-digits 0) -1)))
+(defconstant most-negative-double-float
+ (double-from-bits 1 sb!vm:double-float-normal-exponent-max
+ (ldb (byte sb!vm:double-float-digits 0) -1)))
+#!-long-float
+(defconstant most-negative-long-float most-negative-double-float)
+#!+(and long-float x86)
+(defconstant most-negative-long-float
+ (long-from-bits 1 sb!vm:long-float-normal-exponent-max
+ (ldb (byte sb!vm:long-float-digits 0) -1)))
+
+;;; We don't want to do these DEFCONSTANTs at cross-compilation time,
+;;; because the cross-compilation host might not support floating
+;;; point infinities. Putting them inside a LET removes
+;;; toplevel-formness, so that any EVAL-WHEN trickiness in the
+;;; DEFCONSTANT forms is suppressed.
+;;;
+;;; Note that it might be worth performing a similar MAKE-LOAD-FORM
+;;; trick as with -0.0 (see the UNPORTABLE-FLOAT structure). CSR,
+;;; 2004-03-09
+(let ()
+(defconstant single-float-positive-infinity
+ (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
+(defconstant short-float-positive-infinity
+ (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
+(defconstant single-float-negative-infinity
+ (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0))
+(defconstant short-float-negative-infinity
+ (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0))
+(defconstant double-float-positive-infinity
+ (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
+#!+(not long-float)
+(defconstant long-float-positive-infinity
+ (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
+#!+(and long-float x86)
+(defconstant long-float-positive-infinity
+ (long-from-bits 0 (1+ sb!vm:long-float-normal-exponent-max)
+ (ash sb!vm:long-float-hidden-bit 32)))
+(defconstant double-float-negative-infinity
+ (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0))
+#!+(not long-float)
+(defconstant long-float-negative-infinity
+ (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0))
+#!+(and long-float x86)
+(defconstant long-float-negative-infinity
+ (long-from-bits 1 (1+ sb!vm:long-float-normal-exponent-max)
+ (ash sb!vm:long-float-hidden-bit 32)))
+) ; LET-to-suppress-possible-EVAL-WHENs
+
+(defconstant single-float-epsilon
+ (single-from-bits 0 (- sb!vm:single-float-bias
+ (1- sb!vm:single-float-digits)) 1))
+(defconstant short-float-epsilon single-float-epsilon)
+(defconstant single-float-negative-epsilon
+ (single-from-bits 0 (- sb!vm:single-float-bias sb!vm:single-float-digits) 1))
+(defconstant short-float-negative-epsilon single-float-negative-epsilon)
+(defconstant double-float-epsilon
+ (double-from-bits 0 (- sb!vm:double-float-bias
+ (1- sb!vm:double-float-digits)) 1))
+#!-long-float
+(defconstant long-float-epsilon double-float-epsilon)
+#!+(and long-float x86)
+(defconstant long-float-epsilon
+ (long-from-bits 0 (- sb!vm:long-float-bias (1- sb!vm:long-float-digits))
+ (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
+(defconstant double-float-negative-epsilon
+ (double-from-bits 0 (- sb!vm:double-float-bias sb!vm:double-float-digits) 1))
+#!-long-float
+(defconstant long-float-negative-epsilon double-float-negative-epsilon)
+#!+(and long-float x86)
+(defconstant long-float-negative-epsilon
+ (long-from-bits 0 (- sb!vm:long-float-bias sb!vm:long-float-digits)
+ (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
*read-only-space-free-pointer*
sb!vm:*static-space-free-pointer*
sb!vm:*initial-dynamic-space-free-pointer*
- *current-catch-block*
- *current-unwind-protect-block*
+ sb!vm::*current-catch-block*
+ sb!vm::*current-unwind-protect-block*
sb!vm::*alien-stack*
#!+sb-thread sb!thread::*foreground-thread-stack*
sb!vm::*control-stack-start*
(!begin-collecting-cold-init-forms)
-;;; Has the type system been properly initialized? (I.e. is it OK to
-;;; use it?)
-(defvar *type-system-initialized* #+sb-xc-host nil) ; (set in cold load)
-\f
;;;; representations of types
;;; A HAIRY-TYPE represents anything too weird to be described
(in-package "SB!KERNEL")
\f
-;;;; utilities
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-;;; These functions let us create floats from bits with the
-;;; significand uniformly represented as an integer. This is less
-;;; efficient for double floats, but is more convenient when making
-;;; special values, etc.
-(defun single-from-bits (sign exp sig)
- (declare (type bit sign) (type (unsigned-byte 24) sig)
- (type (unsigned-byte 8) exp))
- (make-single-float
- (dpb exp sb!vm:single-float-exponent-byte
- (dpb sig sb!vm:single-float-significand-byte
- (if (zerop sign) 0 -1)))))
-(defun double-from-bits (sign exp sig)
- (declare (type bit sign) (type (unsigned-byte 53) sig)
- (type (unsigned-byte 11) exp))
- (make-double-float (dpb exp sb!vm:double-float-exponent-byte
- (dpb (ash sig -32)
- sb!vm:double-float-significand-byte
- (if (zerop sign) 0 -1)))
- (ldb (byte 32 0) sig)))
-#!+(and long-float x86)
-(defun long-from-bits (sign exp sig)
- (declare (type bit sign) (type (unsigned-byte 64) sig)
- (type (unsigned-byte 15) exp))
- (make-long-float (logior (ash sign 15) exp)
- (ldb (byte 32 32) sig)
- (ldb (byte 32 0) sig)))
-
-) ; EVAL-WHEN
-\f
-;;;; float parameters
-
-(defconstant least-positive-single-float (single-from-bits 0 0 1))
-(defconstant least-positive-short-float (single-from-bits 0 0 1))
-(defconstant least-negative-single-float (single-from-bits 1 0 1))
-(defconstant least-negative-short-float (single-from-bits 1 0 1))
-(defconstant least-positive-double-float (double-from-bits 0 0 1))
-#!-long-float
-(defconstant least-positive-long-float (double-from-bits 0 0 1))
-#!+(and long-float x86)
-(defconstant least-positive-long-float (long-from-bits 0 0 1))
-(defconstant least-negative-double-float (double-from-bits 1 0 1))
-#!-long-float
-(defconstant least-negative-long-float (double-from-bits 1 0 1))
-#!+(and long-float x86)
-(defconstant least-negative-long-float (long-from-bits 1 0 1))
-
-(defconstant least-positive-normalized-single-float
- (single-from-bits 0 sb!vm:single-float-normal-exponent-min 0))
-(defconstant least-positive-normalized-short-float
- least-positive-normalized-single-float)
-(defconstant least-negative-normalized-single-float
- (single-from-bits 1 sb!vm:single-float-normal-exponent-min 0))
-(defconstant least-negative-normalized-short-float
- least-negative-normalized-single-float)
-(defconstant least-positive-normalized-double-float
- (double-from-bits 0 sb!vm:double-float-normal-exponent-min 0))
-#!-long-float
-(defconstant least-positive-normalized-long-float
- least-positive-normalized-double-float)
-#!+(and long-float x86)
-(defconstant least-positive-normalized-long-float
- (long-from-bits 0 sb!vm:long-float-normal-exponent-min
- (ash sb!vm:long-float-hidden-bit 32)))
-(defconstant least-negative-normalized-double-float
- (double-from-bits 1 sb!vm:double-float-normal-exponent-min 0))
-#!-long-float
-(defconstant least-negative-normalized-long-float
- least-negative-normalized-double-float)
-#!+(and long-float x86)
-(defconstant least-negative-normalized-long-float
- (long-from-bits 1 sb!vm:long-float-normal-exponent-min
- (ash sb!vm:long-float-hidden-bit 32)))
-
-(defconstant most-positive-single-float
- (single-from-bits 0 sb!vm:single-float-normal-exponent-max
- (ldb sb!vm:single-float-significand-byte -1)))
-(defconstant most-positive-short-float most-positive-single-float)
-(defconstant most-negative-single-float
- (single-from-bits 1 sb!vm:single-float-normal-exponent-max
- (ldb sb!vm:single-float-significand-byte -1)))
-(defconstant most-negative-short-float most-negative-single-float)
-(defconstant most-positive-double-float
- (double-from-bits 0 sb!vm:double-float-normal-exponent-max
- (ldb (byte sb!vm:double-float-digits 0) -1)))
-#!-long-float
-(defconstant most-positive-long-float most-positive-double-float)
-#!+(and long-float x86)
-(defconstant most-positive-long-float
- (long-from-bits 0 sb!vm:long-float-normal-exponent-max
- (ldb (byte sb!vm:long-float-digits 0) -1)))
-(defconstant most-negative-double-float
- (double-from-bits 1 sb!vm:double-float-normal-exponent-max
- (ldb (byte sb!vm:double-float-digits 0) -1)))
-#!-long-float
-(defconstant most-negative-long-float most-negative-double-float)
-#!+(and long-float x86)
-(defconstant most-negative-long-float
- (long-from-bits 1 sb!vm:long-float-normal-exponent-max
- (ldb (byte sb!vm:long-float-digits 0) -1)))
-
-;;; We don't want to do these DEFCONSTANTs at cross-compilation time,
-;;; because the cross-compilation host might not support floating
-;;; point infinities. Putting them inside a LET removes
-;;; toplevel-formness, so that any EVAL-WHEN trickiness in the
-;;; DEFCONSTANT forms is suppressed.
-(let ()
-(defconstant single-float-positive-infinity
- (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
-(defconstant short-float-positive-infinity single-float-positive-infinity)
-(defconstant single-float-negative-infinity
- (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0))
-(defconstant short-float-negative-infinity single-float-negative-infinity)
-(defconstant double-float-positive-infinity
- (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
-#!+(not long-float)
-(defconstant long-float-positive-infinity double-float-positive-infinity)
-#!+(and long-float x86)
-(defconstant long-float-positive-infinity
- (long-from-bits 0 (1+ sb!vm:long-float-normal-exponent-max)
- (ash sb!vm:long-float-hidden-bit 32)))
-(defconstant double-float-negative-infinity
- (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0))
-#!+(not long-float)
-(defconstant long-float-negative-infinity double-float-negative-infinity)
-#!+(and long-float x86)
-(defconstant long-float-negative-infinity
- (long-from-bits 1 (1+ sb!vm:long-float-normal-exponent-max)
- (ash sb!vm:long-float-hidden-bit 32)))
-) ; LET-to-suppress-possible-EVAL-WHENs
-
-(defconstant single-float-epsilon
- (single-from-bits 0 (- sb!vm:single-float-bias
- (1- sb!vm:single-float-digits)) 1))
-(defconstant short-float-epsilon single-float-epsilon)
-(defconstant single-float-negative-epsilon
- (single-from-bits 0 (- sb!vm:single-float-bias sb!vm:single-float-digits) 1))
-(defconstant short-float-negative-epsilon single-float-negative-epsilon)
-(defconstant double-float-epsilon
- (double-from-bits 0 (- sb!vm:double-float-bias
- (1- sb!vm:double-float-digits)) 1))
-#!-long-float
-(defconstant long-float-epsilon double-float-epsilon)
-#!+(and long-float x86)
-(defconstant long-float-epsilon
- (long-from-bits 0 (- sb!vm:long-float-bias (1- sb!vm:long-float-digits))
- (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
-(defconstant double-float-negative-epsilon
- (double-from-bits 0 (- sb!vm:double-float-bias sb!vm:double-float-digits) 1))
-#!-long-float
-(defconstant long-float-negative-epsilon double-float-negative-epsilon)
-#!+(and long-float x86)
-(defconstant long-float-negative-epsilon
- (long-from-bits 0 (- sb!vm:long-float-bias sb!vm:long-float-digits)
- (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
-\f
;;;; float predicates and environment query
#!-sb-fluid
:operands (list x exp)))
(* (float-sign x)
(etypecase x
- (single-float single-float-positive-infinity)
- (double-float double-float-positive-infinity))))))
+ (single-float
+ ;; SINGLE-FLOAT-POSITIVE-INFINITY
+ (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
+ (double-float
+ ;; DOUBLE-FLOAT-POSITIVE-INFINITY
+ (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)))))))
;;; Scale a single or double float, calling the correct over/underflow
;;; functions.
The functions are run with interrupts disabled and all other threads
paused. They should take no arguments.")
-(defvar *gc-run-time* 0
- #!+sb-doc
- "the total CPU time spent doing garbage collection (as reported by
- GET-INTERNAL-RUN-TIME)")
-(declaim (type index *gc-run-time*))
-
;;;; The following specials are used to control when garbage
;;;; collection occurs.
;;; they're effectively implemented as special variable references,
;;; and the code below which uses them might be unnecessarily
;;; inefficient. Perhaps some sort of MAKE-LOAD-TIME-VALUE hackery
-;;; should be used instead?
+;;; should be used instead? (KLUDGED 2004-03-08 CSR, by replacing the
+;;; special variable references with (probably equally slow)
+;;; constructors)
(declaim (inline square))
(defun square (x)
(cond ((float-nan-p x)
x)
((float-infinity-p x)
- sb!ext:double-float-positive-infinity)
+ ;; DOUBLE-FLOAT-POSITIVE-INFINITY
+ (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
((zerop x)
;; The answer is negative infinity, but we are supposed to
;; signal divide-by-zero, so do the actual division
(float-infinity-p rho))
(or (float-infinity-p (abs x))
(float-infinity-p (abs y))))
- (values sb!ext:double-float-positive-infinity 0))
+ ;; DOUBLE-FLOAT-POSITIVE-INFINITY
+ (values
+ (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)
+ 0))
((let ((threshold #.(/ least-positive-double-float
double-float-epsilon))
(traps (ldb sb!vm::float-sticky-bits
(!define-type-class named)
-(defvar *wild-type*)
-(defvar *empty-type*)
-(defvar *universal-type*)
-(defvar *universal-fun-type*)
-
(!cold-init-forms
(macrolet ((frob (name var)
`(progn
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+;;; Has the type system been properly initialized? (I.e. is it OK to
+;;; use it?)
+(defvar *type-system-initialized* #+sb-xc-host nil) ; (set in cold load)
+
+(defvar *wild-type*)
+(defvar *empty-type*)
+(defvar *universal-type*)
+(defvar *universal-fun-type*)
+
+;;; a vector that maps type codes to layouts, used for quickly finding
+;;; the layouts of built-in classes
+(defvar *built-in-class-codes*) ; initialized in cold load
+(declaim (type simple-vector *built-in-class-codes*))
\f
;;;; TIME
+(defvar *gc-run-time* 0
+ #!+sb-doc
+ "the total CPU time spent doing garbage collection (as reported by
+ GET-INTERNAL-RUN-TIME)")
+(declaim (type index *gc-run-time*))
+
(defmacro time (form)
#!+sb-doc
"Execute FORM and print timing information on *TRACE-OUTPUT*."
;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
;;; of all static symbols in early-impl.lisp.
(progn
- (defvar *current-catch-block*)
- (defvar *current-unwind-protect-block*)
+ (defvar sb!vm::*current-catch-block*)
+ (defvar sb!vm::*current-unwind-protect-block*)
(defvar *free-interrupt-context-index*))
\f
;;; specials initialized by !COLD-INIT
;; USERINITish files
(probe-init-files (explicitly-specified-init-file-name
&rest default-init-file-names)
- (declare (type list possible-init-file-names))
+ (declare (type list default-init-file-names))
(if explicitly-specified-init-file-name
(or (probe-file explicitly-specified-init-file-name)
(startup-error "The file ~S was not found."
;;; they haven't been installed yet
(defvar *backend-internal-errors* nil)
(declaim (type (or simple-vector null) *backend-internal-errors*))
-
-;;; the maximum number of bytes per page on this system (used by GENESIS)
-(defvar *backend-page-size* 0)
-(declaim (type index *backend-page-size*))
\f
;;;; VM support routines
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+\f
+;;; the maximum number of bytes per page on this system (used by GENESIS)
+(defvar *backend-page-size* 0)
+(declaim (type index *backend-page-size*))
(defvar *undefined-warnings*)
(defvar *warnings-p*)
+;;; This lock is seized in the compiler, and related areas: the
+;;; compiler is not presently thread-safe
+(defvar *big-compiler-lock*
+ (sb!thread:make-mutex :name "big compiler lock"))
+
;;; unique ID for the next object created (to let us track object
;;; identity even across GC, useful for understanding weird compiler
;;; bugs where something is supposed to be unique but is instead
(frob sb!di::handle-fun-end-breakpoint)
(frob sb!thread::handle-thread-exit))
- (cold-set '*current-catch-block* (make-fixnum-descriptor 0))
- (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0))
+ (cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0))
+ (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))
(cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))
;;; normally causes nested uses to be no-ops).
(defvar *in-compilation-unit* nil)
-;;; This lock is siezed in the same situation: the compiler is not
-;;; presently thread-safe
-(defvar *big-compiler-lock*
- (sb!thread:make-mutex :name "big compiler lock"))
-
;;; Count of the number of compilation units dynamically enclosed by
;;; the current active WITH-COMPILATION-UNIT that were unwound out of.
(defvar *aborted-compilation-unit-count*)
defined later, the code doing so would not be ~
portable.~:@>"
kind name)))
- (compiler-style-warn "undefined ~(~A~): ~S" kind name)))
+ (if (eq kind :variable)
+ (compiler-warn "undefined ~(~A~): ~S" kind name)
+ (compiler-style-warn "undefined ~(~A~): ~S" kind name))))
(let ((warn-count (length warnings)))
(when (and warnings (> undefined-warning-count warn-count))
(let ((more (- undefined-warning-count warn-count)))
- (compiler-style-warn
- "~W more use~:P of undefined ~(~A~) ~S"
- more kind name))))))
+ (if (eq kind :variable)
+ (compiler-warn
+ "~W more use~:P of undefined ~(~A~) ~S"
+ more kind name)
+ (compiler-style-warn
+ "~W more use~:P of undefined ~(~A~) ~S"
+ more kind name)))))))
(dolist (kind '(:variable :function :type))
(let ((summary (mapcar #'undefined-warning-name
(remove kind undefs :test-not #'eq
:key #'undefined-warning-kind))))
(when summary
- (compiler-style-warn
- "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
- ~% ~{~<~% ~1:;~S~>~^ ~}"
- (cdr summary) kind summary)))))))
+ (if (eq kind :variable)
+ (compiler-warn
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
+ (cdr summary) kind summary)
+ (compiler-style-warn
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
+ (cdr summary) kind summary))))))))
(unless (and (not abort-p)
(zerop *aborted-compilation-unit-count*)
(defun gf-requires-emf-keyword-checks (generic-function)
(member '&key (gf-lambda-list generic-function)))
+(defvar *in-precompute-effective-methods-p* nil)
+
(defun standard-compute-effective-method
(generic-function combin applicable-methods)
(collect ((before) (primary) (after) (around))
(parse-gspec spec
(name (fdefine-carefully name new-value))))
\f
-(declaim (special *the-class-t*
- *the-class-vector* *the-class-symbol*
- *the-class-string* *the-class-sequence*
- *the-class-rational* *the-class-ratio*
- *the-class-number* *the-class-null* *the-class-list*
- *the-class-integer* *the-class-float* *the-class-cons*
- *the-class-complex* *the-class-character*
- *the-class-bit-vector* *the-class-array*
- *the-class-stream*
-
- *the-class-slot-object*
- *the-class-structure-object*
- *the-class-std-object*
- *the-class-standard-object*
- *the-class-funcallable-standard-object*
- *the-class-class*
- *the-class-generic-function*
- *the-class-built-in-class*
- *the-class-slot-class*
- *the-class-condition-class*
- *the-class-structure-class*
- *the-class-std-class*
- *the-class-standard-class*
- *the-class-funcallable-standard-class*
- *the-class-method*
- *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*
- *the-class-standard-generic-function*
- *the-class-standard-effective-slot-definition*
-
- *the-eslotd-standard-class-slots*
- *the-eslotd-funcallable-standard-class-slots*))
-
-(declaim (special *the-wrapper-of-t*
- *the-wrapper-of-vector* *the-wrapper-of-symbol*
- *the-wrapper-of-string* *the-wrapper-of-sequence*
- *the-wrapper-of-rational* *the-wrapper-of-ratio*
- *the-wrapper-of-number* *the-wrapper-of-null*
- *the-wrapper-of-list* *the-wrapper-of-integer*
- *the-wrapper-of-float* *the-wrapper-of-cons*
- *the-wrapper-of-complex* *the-wrapper-of-character*
- *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
-\f
;;;; type specifier hackery
;;; internal to this file
(return (setf (third c) t))))
(return nil))))))
-(defvar *in-precompute-effective-methods-p* nil)
-
-;used only in map-all-orders
+;;; CMUCL comment: used only in map-all-orders
(defun class-might-precede-p (class1 class2)
(if (not *in-precompute-effective-methods-p*)
(not (member class1 (cdr (class-precedence-list class2))))
(and (symbolp type)
(condition-classoid-p (find-classoid type nil))))
\f
+(declaim (special *the-class-t*
+ *the-class-vector* *the-class-symbol*
+ *the-class-string* *the-class-sequence*
+ *the-class-rational* *the-class-ratio*
+ *the-class-number* *the-class-null* *the-class-list*
+ *the-class-integer* *the-class-float* *the-class-cons*
+ *the-class-complex* *the-class-character*
+ *the-class-bit-vector* *the-class-array*
+ *the-class-stream*
+
+ *the-class-slot-object*
+ *the-class-structure-object*
+ *the-class-std-object*
+ *the-class-standard-object*
+ *the-class-funcallable-standard-object*
+ *the-class-class*
+ *the-class-generic-function*
+ *the-class-built-in-class*
+ *the-class-slot-class*
+ *the-class-condition-class*
+ *the-class-structure-class*
+ *the-class-std-class*
+ *the-class-standard-class*
+ *the-class-funcallable-standard-class*
+ *the-class-method*
+ *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*
+ *the-class-standard-generic-function*
+ *the-class-standard-effective-slot-definition*
+
+ *the-eslotd-standard-class-slots*
+ *the-eslotd-funcallable-standard-class-slots*))
+
+(declaim (special *the-wrapper-of-t*
+ *the-wrapper-of-vector* *the-wrapper-of-symbol*
+ *the-wrapper-of-string* *the-wrapper-of-sequence*
+ *the-wrapper-of-rational* *the-wrapper-of-ratio*
+ *the-wrapper-of-number* *the-wrapper-of-null*
+ *the-wrapper-of-list* *the-wrapper-of-integer*
+ *the-wrapper-of-float* *the-wrapper-of-cons*
+ *the-wrapper-of-complex* *the-wrapper-of-character*
+ *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
+\f
(/show "finished with early-low.lisp")
EOF
expect_clean_compile $tmpfilename
+# undeclared unbound variables should cause a full warning, as they
+# invoke undefined behaviour
+cat > $tmpfilename <<EOF
+ (defun foo () x)
+EOF
+expect_failed_compile $tmpfilename
+
+cat > $tmpfilename <<EOF
+ (declaim (special *x*))
+ (defun foo () *x*)
+EOF
+expect_clean_compile $tmpfilename
+
+cat > $tmpfilename <<EOF
+ (defun foo () (declare (special x)) x)
+EOF
+expect_clean_compile $tmpfilename
+
rm $tmpfilename
rm $compiled_tmpfilename
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.8.20"
+"0.8.8.21"
projects / sbcl.git / commitdiff