;; If we want to move over to list-style names
;; [e.g. (DEFMACRO FOO), maybe to support some XREF-like
;; functionality] here might be a good place to start.
- (debug-name (debug-namify "DEFMACRO ~S" name)))
+ (debug-name (sb!c::debug-namify "DEFMACRO " name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(sb!c::%defmacro ',name #',def ',lambda-list ,doc ,debug-name)))))))
(let ((def `(lambda (,whole ,environment)
,@local-decs
,body))
- (debug-name (debug-namify "DEFINE-COMPILER-MACRO ~S" name)))
+ (debug-name (sb!c::debug-namify "DEFINE-COMPILER-MACRO " name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(sb!c::%define-compiler-macro ',name
#',def
(the simple-string
(if (stringp leaf-debug-name)
leaf-debug-name
- (debug-namify "function ~S" leaf-debug-name)))))
+ (debug-namify "function " leaf-debug-name)))))
;;; Given a list of top level lambdas, return
;;; (VALUES NONTOP-COMPONENTS TOP-COMPONENTS HAIRY-TOP-COMPONENTS).
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)
+;;; 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.
;;;
-;;; 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))))
+;;; (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)))))))))
'(lambda named-lambda instance-lambda lambda-with-lexenv))
(ir1-convert-lambdalike
thing
- :debug-name (debug-namify "#'~S" thing)
+ :debug-name (debug-namify "#'" thing)
:allow-debug-catch-tag t))
((legal-fun-name-p thing)
(find-lexically-apparent-fun
(processing-decls (decls vars nil next result)
(let ((fun (ir1-convert-lambda-body
forms vars
- :debug-name (debug-namify "LET ~S"
- bindings))))
+ :debug-name (debug-namify "LET "
+ bindings))))
(reference-leaf start ctran fun-lvar fun))
(values next result))))
(ir1-convert-combination-args fun-lvar ctran next result values))))))
(ir1-convert-lambda d
:source-name n
:debug-name (debug-namify
- "FLET ~S" n)
+ "FLET " n)
:allow-debug-catch-tag t))
names defs)))
(processing-decls (decls nil fvars next result)
(make-functional
:%source-name name
:%debug-name (debug-namify
- "LABELS placeholder ~S"
+ "LABELS placeholder "
name)))
names))
;; (like PAIRLIS but guaranteed to preserve ordering:)
(ir1-convert-lambda def
:source-name name
:debug-name (debug-namify
- "LABELS ~S" name)
+ "LABELS " name)
:allow-debug-catch-tag t))
names defs))))
(let ((fun (ir1-convert-lambda
`(lambda ()
(return-from ,tag (%unknown-values)))
- :debug-name (debug-namify "escape function for ~S" tag))))
+ :debug-name (debug-namify "escape function for " tag))))
(setf (functional-kind fun) :escape)
(reference-leaf start next result fun)))
(block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
- :debug-name (debug-namify "LAMBDA-inlined ~A"
- (as-debug-name
- source-name
- "<unknown function>"))))
+ :debug-name (debug-namify "LAMBDA-inlined "
+ source-name
+ "<unknown function>")))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
(format nil "~<~@; ~S~:>" (list form))
(prin1-to-string form)))))
-;;; shorthand for a repeated idiom in creating debug names
-;;;
-;;; the problem, part I: We want to create debug names that look like
-;;; "&MORE processor for <something>" where <something> might be
-;;; either a source-name value (typically a symbol) or a non-symbol
-;;; debug-name value (typically a string). It's awkward to handle this
-;;; with FORMAT because we'd like to splice a source-name value using
-;;; "~S" (to get package qualifiers) but a debug-name value using "~A"
-;;; (to avoid irrelevant quotes at string splice boundaries).
-;;;
-;;; the problem, part II: The <something> is represented as a pair
-;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used
-;;; if it's not .ANONYMOUS. (This is parallel to the way that ordinarily
-;;; we don't use a value if it's NIL, instead defaulting it. But we
-;;; can't safely/comfortably use NIL for that in this context, since
-;;; the app programmer can use NIL as a name, so we use the private
-;;; symbol .ANONYMOUS. instead.)
-;;;
-;;; the solution: Use this function to convert whatever it is to a
-;;; string, which FORMAT can then splice using "~A".
-(defun as-debug-name (source-name debug-name)
- (if (eql source-name '.anonymous.)
- debug-name
- (debug-namify "~S" source-name)))
-
;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
;;; error context, or NIL if we can't figure anything out. ARGS is a
;;; list of things that are going to be printed out in the error
:aux-vars (rest aux-vars)
:aux-vals (rest aux-vals)
:debug-name (debug-namify
- "&AUX bindings ~S"
+ "&AUX bindings "
aux-vars))))
(reference-leaf start ctran fun-lvar fun)
(ir1-convert-combination-args fun-lvar ctran next result
,@(default-vals))))
arg-vars
:debug-name
- (debug-namify "&OPTIONAL processor ~D"
- (random 100))
+ (debug-namify "&OPTIONAL processor "
+ (gensym))
:note-lexical-bindings nil))))
(mapc (lambda (var arg-var)
(when (cdr (leaf-refs arg-var))
(%funcall ,(optional-dispatch-main-entry res)
,@(arg-vals))))
(arg-vars)
- :debug-name (debug-namify "~S processing" '&more)
+ :debug-name "&MORE processing"
:note-lexical-bindings nil)))
(setf (optional-dispatch-more-entry res)
(register-entry-point ep res)))))
body (main-vars)
:aux-vars (append (bind-vars) aux-vars)
:aux-vals (append (bind-vals) aux-vals)
- :debug-name (debug-namify "varargs entry for ~A"
- (as-debug-name source-name
- debug-name))))
+ :debug-name (debug-namify
+ "varargs entry for " source-name debug-name)))
(last-entry (convert-optional-entry main-entry default-vars
(main-vals) ())))
(setf (optional-dispatch-main-entry res)
:aux-vars aux-vars
:aux-vals aux-vals
:debug-name (debug-namify
- "hairy arg processor for ~A"
- (as-debug-name source-name
- debug-name)))))
+ "hairy arg processor for "
+ source-name
+ debug-name))))
(setf (optional-dispatch-main-entry res) fun)
(register-entry-point fun res)
(push (if supplied-p-p
&key
(source-name '.anonymous.)
(debug-name (debug-namify
- "OPTIONAL-DISPATCH ~S"
+ "OPTIONAL-DISPATCH "
vars)))
(declare (list body vars aux-vars aux-vals))
(let ((res (make-optional-dispatch :arglist vars
(let* ((forms (if for-value `(,form) `(,form nil)))
(res (ir1-convert-lambda-body
forms ()
- :debug-name (debug-namify "top level form ~S" form))))
+ :debug-name (debug-namify "top level form " form))))
(setf (functional-entry-fun res) res
(functional-arg-documentation res) ()
(functional-kind res) :toplevel)
(ir1-convert-lambda
opname
:debug-name (debug-namify
- "LAMBDA CAR ~S"
+ "LAMBDA CAR "
opname)
:allow-debug-catch-tag t))))))))
(values))
(with-ir1-environment-from-node (lambda-bind (main-entry fun))
(let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
:debug-name (debug-namify
- "XEP for ~A"
+ "XEP for "
(leaf-debug-name fun)))))
(setf (functional-kind res) :external
(leaf-ever-used res) t
(ir1-convert-lambda
(functional-inline-expansion original-functional)
:debug-name (debug-namify
- "local inline ~A"
+ "local inline "
(leaf-debug-name
original-functional)))))))
(cond (losing-local-functional
`(lambda ,vars
(declare (ignorable ,@ignores))
(%funcall ,entry ,@args))
- :debug-name (debug-namify "hairy function entry ~S"
+ :debug-name (debug-namify "hairy function entry "
(lvar-fun-name
(basic-combination-fun call)))))))
(convert-call ref call new-fun)
(setf (component-kind component) :initial)
(let* ((locall-fun (ir1-convert-lambdalike
definition
- :debug-name (debug-namify "top level local call ~S"
- name)
+ :debug-name (debug-namify "top level local call "
+ name)
;; KLUDGE: we do this so that we get to have
;; nice debug returnness in functions defined
;; from the REPL
;;; 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.10.16"
+"0.8.10.17"
projects / sbcl.git / commitdiff