X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fearly-c.lisp;h=11f7176506034bca93edd8db73cd9d212e000fd9;hb=6e89948ce34d63b35eea687ca7cde0f2876c3062;hp=f3c7319fb2daee7efa3a3d023aded49e350589b6;hpb=5e9825374b74df450d8cfb2c005e6bef30197734;p=sbcl.git

diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp
index f3c7319..11f7176 100644
--- a/src/compiler/early-c.lisp
+++ b/src/compiler/early-c.lisp
@@ -86,6 +86,12 @@
 (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*)
@@ -101,6 +107,8 @@
 (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*)
@@ -116,6 +124,11 @@
 (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
@@ -166,19 +179,24 @@ dynamic binding, even though the symbol name follows the usual naming~@
 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
+                    (format nil "#<~S>" (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)))