X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fearly-c.lisp;h=515701aab766b346534eaff8c8b925658da29cd7;hb=942e45e3bb73fd55786e4a0ab4590324063c0c89;hp=d308bdd1d6970b55904034c141fde41cc44faa04;hpb=0794cd3908a441222f430ba0cf3bb7c3e1a96c63;p=sbcl.git diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index d308bdd..515701a 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -16,16 +16,16 @@ (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.") @@ -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*) @@ -102,6 +108,7 @@ (defvar *current-component*) (defvar *delayed-ir1-transforms*) (defvar *handled-conditions*) +(defvar *disabled-package-locks*) (defvar *policy*) (defvar *dynamic-counts-tn*) (defvar *elsewhere*) @@ -131,7 +138,7 @@ (defvar *object-id-counter* 0) (defun new-object-id () (prog1 - *object-id-counter* + *object-id-counter* (incf *object-id-counter*)))) ;;;; miscellaneous utilities @@ -140,16 +147,16 @@ ;;; 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 @@ -172,58 +179,24 @@ dynamic binding, even though the symbol name follows the usual naming~@ convention (names like *FOO*) for special variables" symbol)) (values)) -;;; Hacky (duplicating machinery found elsewhere because this function -;;; turns out to be on a critical path in the compiler) shorthand for -;;; creating debug names from source names or other stems, e.g. -;;; -;;; (DEBUG-NAMIFY "FLET " SOURCE-NAME) -> "FLET FOO:BAR" -;;; (DEBUG-NAMIFY "top level form " FORM) -> "top level form (QUUX :FOO)" -;;; -;;; If ALT is given it must be a string -- it is then used in place of -;;; either HEAD or TAIL if either of them is EQ to SB-C::.ANONYMOUS. -;;; -(declaim (inline debug-namify)) -(defun debug-namify (head tail &optional alt) - (declare (type (or null string) alt)) - (flet ((symbol-debug-name (symbol) - ;; KLUDGE: (OAOOM warning) very much akin to OUTPUT-SYMBOL. - (if (and alt (eq '.anonymous. symbol)) - alt - (let ((package (symbol-package symbol)) - (name (symbol-name symbol))) - (cond - ((eq package *keyword-package*) - (concatenate 'string ":" name)) - ((eq package *cl-package*) - name) - ((null package) - (concatenate 'string "#:" name)) - (t - (multiple-value-bind (symbol status) - (find-symbol name package) - (declare (ignore symbol)) - (concatenate 'string - (package-name package) - (if (eq status :external) ":" "::") - name)))))))) - (cond ((and (stringp head) (stringp tail)) - (concatenate 'string head tail)) - ((and (stringp head) (symbolp tail)) - (concatenate 'string head (symbol-debug-name tail))) - ((and (symbolp head) (stringp tail)) - (concatenate 'string (symbol-debug-name head) tail)) - (t - (macrolet ((out (obj s) - `(typecase ,obj - (string (write-string ,obj ,s)) - (symbol (write-string (symbol-debug-name ,obj) ,s)) - (t (prin1 ,obj ,s))))) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*print-pretty* nil) - (*package* *cl-package*) - (*print-length* 3) - (*print-level* 2)) - (with-output-to-string (s) - (out head s) - (out tail s))))))))) +(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)))