(in-package "SB!C")
;;; ANSI limits on compilation
-(def!constant sb!xc:call-arguments-limit most-positive-fixnum
+(def!constant sb!xc:call-arguments-limit sb!xc:most-positive-fixnum
#!+sb-doc
"The exclusive upper bound on the number of arguments which may be passed
to a function, including &REST args.")
-(def!constant sb!xc:lambda-parameters-limit most-positive-fixnum
+(def!constant sb!xc:lambda-parameters-limit sb!xc:most-positive-fixnum
#!+sb-doc
"The exclusive upper bound on the number of parameters which may be specifed
in a given lambda list. This is actually the limit on required and &OPTIONAL
parameters. With &KEY and &AUX you can get more.")
-(def!constant sb!xc:multiple-values-limit most-positive-fixnum
+(def!constant sb!xc:multiple-values-limit sb!xc:most-positive-fixnum
#!+sb-doc
"The exclusive upper bound on the number of multiple VALUES that you can
return.")
(defvar *constants*)
(declaim (type hash-table *constants*))
+;;; *ALLOW-INSTRUMENTING* controls whether we should allow the
+;;; insertion of instrumenting code (like a (CATCH ...)) around code
+;;; to allow the debugger RETURN and STEP commands to function (we
+;;; disallow it for internal stuff).
+(defvar *allow-instrumenting*)
+
;;; miscellaneous forward declarations
(defvar *code-segment*)
#!+sb-dyncount (defvar *collect-dynamic-statistics*)
(defvar *current-path*)
(defvar *current-component*)
(defvar *delayed-ir1-transforms*)
+(defvar *handled-conditions*)
+(defvar *disabled-package-locks*)
(defvar *policy*)
(defvar *dynamic-counts-tn*)
(defvar *elsewhere*)
(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"))
+
+(declaim (type fixnum *compiler-sset-counter*))
+(defvar *compiler-sset-counter* 0)
+
;;; 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
(defvar *object-id-counter* 0)
(defun new-object-id ()
(prog1
- *object-id-counter*
+ *object-id-counter*
(incf *object-id-counter*))))
\f
;;;; miscellaneous utilities
;;; benefit of the compiler, but it's sometimes called from stuff like
;;; type-defining code which isn't logically part of the compiler.
(declaim (ftype (function ((or symbol cons) keyword) (values))
- note-name-defined))
+ note-name-defined))
(defun note-name-defined (name kind)
;; We do this BOUNDP check because this function can be called when
;; not in a compilation unit (as when loading top level forms).
(when (boundp '*undefined-warnings*)
(setq *undefined-warnings*
- (delete-if (lambda (x)
- (and (equal (undefined-warning-name x) name)
- (eq (undefined-warning-kind x) kind)))
- *undefined-warnings*)))
+ (delete-if (lambda (x)
+ (and (equal (undefined-warning-name x) name)
+ (eq (undefined-warning-kind x) kind)))
+ *undefined-warnings*)))
(values))
;;; to be called when a variable is lexically bound
convention (names like *FOO*) for special variables" symbol))
(values))
-;;; shorthand for creating debug names from source names or other
-;;; stems, e.g.
-;;; (DEBUG-NAMIFY "FLET ~S" SOURCE-NAME)
-;;; (DEBUG-NAMIFY "top level form ~S" FORM)
-;;;
-;;; FIXME: This function seems to have a lot in common with
-;;; STRINGIFY-FORM, and perhaps there's some way to merge the two
-;;; functions.
-(declaim (ftype (sfunction (string &rest t) string) debug-namify))
-(defun debug-namify (format-string &rest format-arguments)
- (with-standard-io-syntax
- (let ((*print-readably* nil)
- (*package* *cl-package*)
- (*print-length* 3)
- (*print-level* 2))
- (apply #'format nil format-string format-arguments))))
+(defvar *debug-name-level* 6)
+
+(defun debug-name (type thing)
+ (labels ((walk (x level)
+ (if (> *debug-name-level* (incf level))
+ (typecase x
+ (cons
+ (cons (walk (car x) level) (walk (cdr x) level)))
+ ((or symbol number string)
+ x)
+ (t
+ (list 'of-type (type-of x))))
+ "#<...>")))
+ ;; FIXME: It might be nice to put markers in the tree instead of
+ ;; this #<...> business, so that they would evantually be printed
+ ;; without the quotes.
+ (let ((name (list type (walk thing 0))))
+ (when (legal-fun-name-p name)
+ (bug "~S is a legal function name, and cannot be used as a ~
+ debug name." name))
+ name)))