Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1468/src/code
Modified Files:
debug-info.lisp debug-int.lisp debug.lisp defboot.lisp
defmacro.lisp early-extensions.lisp inspect.lisp macros.lisp
pprint.lisp print.lisp target-misc.lisp toplevel.lisp
typecheckfuns.lisp
Log Message:
0.8.20.1: fun-name fun, debugger debugged
* fix bug 32: print closures as #<CLOSURE name-goes-here>.
* fix bug 33: better inspection of closures
* remove bug 60: LIST-LOCATIONS has been deleted at some
point in history, no point in keeping a bug about it.
* move to using structured function names: (XEP FOO), etc
instead of "XEP for FOO". Ditto for component names.
* unless SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS* is true
display various entry points in backtraces as if they were
"normal functions", and adjust the argument list accordingly.
* fix for debugger I/O style issues: use *DEBUG-IO*, not
*STANDARD-OUTPUT*.
* use INTERACTIVE-EVAL in the debugger instead of reimplementing
it.
* update debugger documentation.
Index: debug-info.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug-info.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- debug-info.lisp 29 Sep 2004 19:34:40 -0000 1.18
+++ debug-info.lisp 1 Mar 2005 10:21:30 -0000 1.19
@@ -263,7 +263,7 @@
(def!struct debug-info
;; Some string describing something about the code in this component.
- (name (missing-arg) :type simple-string)
+ (name (missing-arg) :type t)
;; A list of DEBUG-SOURCE structures describing where the code for this
;; component came from, in the order that they were read.
;;
Index: debug-int.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug-int.lisp,v
retrieving revision 1.88
retrieving revision 1.89
diff -u -d -r1.88 -r1.89
--- debug-int.lisp 6 Jan 2005 12:47:58 -0000 1.88
+++ debug-int.lisp 1 Mar 2005 10:21:30 -0000 1.89
@@ -1408,6 +1408,9 @@
;; optional. Stick the extra var in the result
;; element representing the keyword or optional,
;; which is the previous one.
+ ;;
+ ;; FIXME: NCONC used for side-effect: the effect is defined,
+ ;; but this is bad style no matter what.
(nconc (car res)
(list (compiled-debug-fun-lambda-list-var
args (incf i) vars))))
Index: debug.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug.lisp,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -d -r1.72 -r1.73
--- debug.lisp 28 Oct 2004 14:29:32 -0000 1.72
+++ debug.lisp 1 Mar 2005 10:21:30 -0000 1.73
@@ -93,11 +93,12 @@
Any command -- including the name of a restart -- may be uniquely abbreviated.
The debugger rebinds various special variables for controlling i/o, sometimes
to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to
- its own special values, based on SB-EXT:*DEBUG-PRINT-VARIBALE-ALIST*.
+ its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*.
Debug commands do not affect *, //, and similar variables, but evaluation in
the debug loop does affect these variables.
SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
- drop you deeper into the debugger.
+ drop you deeper into the debugger. The default NIL allows recursive entry
+ to debugger.
Getting in and out of the debugger:
RESTART invokes restart numbered as shown (prompt if not given).
@@ -107,20 +108,19 @@
that restart.
Changing frames:
- U up frame D down frame
- B bottom frame F n frame n (n=0 for top frame)
+ UP up frame DOWN down frame
+ BOTTOM bottom frame FRAME n frame n (n=0 for top frame)
Inspecting frames:
BACKTRACE [n] shows n frames going down the stack.
- LIST-LOCALS, L lists locals in current function.
- PRINT, P displays current function call.
+ LIST-LOCALS, L lists locals in current frame.
+ PRINT, P displays function call for current frame.
SOURCE [n] displays frame's source form with n levels of enclosing forms.
Stepping:
- STEP
- [EXPERIMENTAL] Selects the CONTINUE restart if one exists and starts
- single-stepping. Single stepping affects only code compiled with
- under high DEBUG optimization quality. See User Manul for details.
+ STEP Selects the CONTINUE restart if one exists and starts
+ single-stepping. Single stepping affects only code compiled with
+ under high DEBUG optimization quality. See User Manual for details.
Function and macro commands:
(SB-DEBUG:ARG n)
@@ -130,9 +130,10 @@
Other commands:
RETURN expr
- [EXPERIMENTAL] Return the values resulting from evaluation of expr
- from the current frame, if this frame was compiled with a sufficiently
- high DEBUG optimization quality.
+ Return the values resulting from evaluation of expr from the
+ current frame, if this frame was compiled with a sufficiently high
+ DEBUG optimization quality.
+
SLURP
Discard all pending input on *STANDARD-INPUT*. (This can be
useful when the debugger was invoked to handle an error in
@@ -149,8 +150,7 @@
(return loc))))
(cond ((and (not (sb!di:debug-block-elsewhere-p block))
start)
- ;; FIXME: Why output on T instead of *DEBUG-FOO* or something?
- (format t "~%unknown location: using block start~%")
+ (format *debug-io* "~%unknown location: using block start~%")
start)
(t
loc)))
@@ -158,19 +158,18 @@
;;;; BACKTRACE
-(defun backtrace (&optional (count most-positive-fixnum)
- (*standard-output* *debug-io*))
+(defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*))
#!+sb-doc
- "Show a listing of the call stack going down from the current frame. In the
- debugger, the current frame is indicated by the prompt. COUNT is how many
- frames to show."
- (fresh-line *standard-output*)
+ "Show a listing of the call stack going down from the current frame.
+In the debugger, the current frame is indicated by the prompt. COUNT
+is how many frames to show."
+ (fresh-line stream)
(do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
(sb!di:frame-down frame))
(count count (1- count)))
((or (null frame) (zerop count)))
- (print-frame-call frame :number t))
- (fresh-line *standard-output*)
+ (print-frame-call frame stream :number t))
+ (fresh-line stream)
(values))
(defun backtrace-as-list (&optional (count most-positive-fixnum))
@@ -184,8 +183,8 @@
(push (frame-call-as-list frame) reversed-result)))
(defun frame-call-as-list (frame)
- (cons (sb!di:debug-fun-name (sb!di:frame-debug-fun frame))
- (frame-args-as-list frame)))
+ (multiple-value-bind (name args) (frame-call frame)
+ (cons name args)))
;;;; frame printing
@@ -266,31 +265,45 @@
(sb!di:lambda-list-unavailable
()
(make-unprintable-object "unavailable lambda list")))))
+(legal-fun-name-p '(lambda ()))
+(defvar *show-entry-point-details* nil)
-;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
-;;; print as many of the values as possible, punting the loop over
-;;; lambda-list variables since any other arguments will be in the
-;;; &REST arg's list of values.
-(defun print-frame-call-1 (frame)
- (let ((debug-fun (sb!di:frame-debug-fun frame)))
-
- (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
- (let ((args (ensure-printable-object (frame-args-as-list frame))))
- ;; Since we go to some trouble to make nice informative function
- ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
- ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
- (let ((*print-length* nil)
- (*print-level* nil))
- (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
- ;; For the function arguments, we can just print normally.
- (if (listp args)
- (format t "~{ ~_~S~}" args)
- (format t " ~S" args))))
-
- (when (sb!di:debug-fun-kind debug-fun)
- (write-char #\[)
- (prin1 (sb!di:debug-fun-kind debug-fun))
- (write-char #\]))))
+(defun frame-call (frame)
+ (labels ((clean-name-and-args (name args)
+ (if (and (consp name) (not *show-entry-point-details*))
+ (case (first name)
+ ((sb!c::xep sb!c::tl-xep)
+ (clean-name-and-args
+ (second name)
+ (let ((count (first args))
+ (real-args (rest args)))
+ (subseq real-args 0 (min count (length real-args))))))
+ ((sb!c::&more-processor)
+ (clean-name-and-args
+ (second name)
+ (let* ((more (last args 2))
+ (context (first more))
+ (count (second more)))
+ (append (butlast args 2)
+ (multiple-value-list
+ (sb!c:%more-arg-values context 0 count))))))
+ ;; FIXME: do we need to deal with
+ ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
+ ;; &AUX-BINDINGS appear in backtraces, so they are
+ ;; left alone for now. --NS 2005-02-28
+ ((sb!c::hairy-arg-processor
+ sb!c::varargs-entry sb!c::&optional-processor)
+ (clean-name-and-args (second name) args))
+ (t
+ (values name args)))
+ (values name args))))
+ (let ((debug-fun (sb!di:frame-debug-fun frame)))
+ (multiple-value-bind (name args)
+ (clean-name-and-args (sb!di:debug-fun-name debug-fun)
+ (frame-args-as-list frame))
+ (values name args
+ (when *show-entry-point-details*
+ (sb!di:debug-fun-kind debug-fun)))))))
(defun ensure-printable-object (object)
(handler-case
@@ -312,25 +325,43 @@
;;; zero indicates just printing the DEBUG-FUN's name, and one
;;; indicates displaying call-like, one-liner format with argument
;;; values.
-(defun print-frame-call (frame &key (verbosity 1) (number nil))
- (cond
- ((zerop verbosity)
- (when number
- (format t "~&~S: " (sb!di:frame-number frame)))
- (format t "~S" frame))
- (t
- (when number
- (format t "~&~S: " (sb!di:frame-number frame)))
- (print-frame-call-1 frame)))
+(defun print-frame-call (frame stream &key (verbosity 1) (number nil))
+ (when number
+ (format stream "~&~S: " (sb!di:frame-number frame)))
+ (if (zerop verbosity)
+ (let ((*print-readably* nil))
+ (prin1 frame stream))
+ (multiple-value-bind (name args kind) (frame-call frame)
+ (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+ ;; Since we go to some trouble to make nice informative function
+ ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
+ ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
+ ;; For the function arguments, we can just print normally.
+ (let ((*print-length* nil)
+ (*print-level* nil))
+ (prin1 (ensure-printable-object name) stream))
+ ;; If we hit a &REST arg, then print as many of the values as
+ ;; possible, punting the loop over lambda-list variables since any
+ ;; other arguments will be in the &REST arg's list of values.
+ (let ((args (ensure-printable-object args)))
+ (if (listp args)
+ (format stream "~{ ~_~S~}" args)
+ (format stream " ~S" args))))
+ (when kind
+ (format stream "[~S]" kind))))
(when (>= verbosity 2)
(let ((loc (sb!di:frame-code-location frame)))
(handler-case
(progn
+ ;; FIXME: Is this call really necessary here? If it is,
+ ;; then the reason for it should be unobscured.
(sb!di:code-location-debug-block loc)
- (format t "~%source: ")
- (print-code-location-source-form loc 0))
- (sb!di:debug-condition (ignore) ignore)
- (error (c) (format t "error finding source: ~A" c))))))
+ (format stream "~%source: ")
+ (prin1 (code-location-source-form loc 0) stream))
+ (sb!di:debug-condition (ignore)
+ ignore)
+ (error (c)
+ (format stream "error finding source: ~A" c))))))
;;;; INVOKE-DEBUGGER
@@ -514,16 +545,14 @@
;; been converted to behave this way. -- WHN 2000-11-16)
(unwind-protect
- (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
- ;; violating the principle of least surprise, and making
- ;; it impossible for the user to do reasonable things
- ;; like using PRINT at the debugger prompt to send output
- ;; to the program's ordinary (possibly
- ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
- ;; used to rebind *STANDARD-INPUT* here too, but that's
- ;; been fixed already.)
- (*standard-output* *debug-io*)
- ;; This seems reasonable: e.g. if the user has redirected
+ (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
+ ;; here as well, but that is probably bogus since it
+ ;; removes the users ability to do output to a redirected
+ ;; *S-O*. Now we just rebind it so that users can temporarily
+ ;; frob it. FIXME: This and other "what gets bound when"
+ ;; behaviour should be documented in the manual.
+ (*standard-output* *standard-output*)
+ ;; This seems reasonable: e.g. if the user has redirected
;; *ERROR-OUTPUT* to some log file, it's probably wrong
;; to send errors which occur in interactive debugging to
;; that file, and right to send them to *DEBUG-IO*.
@@ -676,17 +705,15 @@
(princ condition *debug-io*)
(/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
(throw 'debug-loop-catcher nil))))
- (fresh-line)
- (print-frame-call *current-frame* :verbosity 2)
+ (fresh-line *debug-io*)
+ (print-frame-call *current-frame* *debug-io* :verbosity 2)
(loop
(catch 'debug-loop-catcher
(handler-bind ((error (lambda (condition)
(when *flush-debug-errors*
(clear-input *debug-io*)
- (princ condition)
- ;; FIXME: Doing input on *DEBUG-IO*
- ;; and output on T seems broken.
- (format t
+ (princ condition *debug-io*)
+ (format *debug-io*
"~&error flushed (because ~
~S is set)"
'*flush-debug-errors*)
@@ -706,34 +733,23 @@
(cond ((not cmd-fun)
(debug-eval-print exp))
((consp cmd-fun)
- (format t "~&Your command, ~S, is ambiguous:~%"
+ (format *debug-io*
+ "~&Your command, ~S, is ambiguous:~%"
exp)
(dolist (ele cmd-fun)
- (format t " ~A~%" ele)))
+ (format *debug-io* " ~A~%" ele)))
(t
(funcall cmd-fun))))))))))))
;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
(defun debug-eval-print (expr)
(/noshow "entering DEBUG-EVAL-PRINT" expr)
- (/noshow (fboundp 'compile))
- (setq +++ ++ ++ + + - - expr)
- (let* ((values (multiple-value-list (eval -)))
- (*standard-output* *debug-io*))
+ (let ((values (multiple-value-list
+ (interactive-eval (sb!di:preprocess-for-eval expr)))))
(/noshow "done with EVAL in DEBUG-EVAL-PRINT")
- (fresh-line)
- (if values (prin1 (car values)))
- (dolist (x (cdr values))
- (fresh-line)
- (prin1 x))
- (setq /// // // / / values)
- (setq *** ** ** * * (car values))
- ;; Make sure that nobody passes back an unbound marker.
- (unless (boundp '*)
- (setq * nil)
- (fresh-line)
- ;; FIXME: The way INTERACTIVE-EVAL does this seems better.
- (princ "Setting * to NIL (was unbound marker)."))))
+ (dolist (value values)
+ (fresh-line *debug-io*)
+ (prin1 value))))
;;;; debug loop functions
@@ -998,17 +1014,17 @@
(let ((next (sb!di:frame-up *current-frame*)))
(cond (next
(setf *current-frame* next)
- (print-frame-call next))
+ (print-frame-call next *debug-io*))
(t
- (format t "~&Top of stack.")))))
+ (format *debug-io* "~&Top of stack.")))))
(!def-debug-command "DOWN" ()
(let ((next (sb!di:frame-down *current-frame*)))
(cond (next
(setf *current-frame* next)
- (print-frame-call next))
+ (print-frame-call next *debug-io*))
(t
- (format t "~&Bottom of stack.")))))
+ (format *debug-io* "~&Bottom of stack.")))))
(!def-debug-command-alias "D" "DOWN")
@@ -1020,14 +1036,14 @@
;;; (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
;;; ((null lead)
;;; (setf *current-frame* prev)
-;;; (print-frame-call prev))))
+;;; (print-frame-call prev *debug-io*))))
(!def-debug-command "BOTTOM" ()
(do ((prev *current-frame* lead)
(lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
((null lead)
(setf *current-frame* prev)
- (print-frame-call prev))))
+ (print-frame-call prev *debug-io*))))
(!def-debug-command-alias "B" "BOTTOM")
@@ -1045,11 +1061,11 @@
(cond (next-frame
(setf frame next-frame))
(t
- (format t
+ (format *debug-io*
"The ~A of the stack was encountered.~%"
limit-string)
(return frame)))))))
- (print-frame-call *current-frame*))
+ (print-frame-call *current-frame* *debug-io*))
(!def-debug-command-alias "F" "FRAME")
@@ -1088,16 +1104,13 @@
(string= (symbol-name sym1)
(symbol-name sym2)))))
(t
- (format t "~S is invalid as a restart name.~%" num)
+ (format *debug-io* "~S is invalid as a restart name.~%"
+ num)
(return-from restart-debug-command nil)))))
(/show0 "got RESTART")
(if restart
(invoke-restart-interactively restart)
- ;; FIXME: Even if this isn't handled by WARN, it probably
- ;; shouldn't go to *STANDARD-OUTPUT*, but *ERROR-OUTPUT* or
- ;; *QUERY-IO* or something. Look through this file to
- ;; straighten out stream usage.
- (princ "There is no such restart.")))))
+ (princ "There is no such restart." *debug-io*)))))
;;;; information commands
@@ -1122,7 +1135,7 @@
(backtrace (read-if-available most-positive-fixnum)))
(!def-debug-command "PRINT" ()
- (print-frame-call *current-frame*))
+ (print-frame-call *current-frame* *debug-io*))
(!def-debug-command-alias "P" "PRINT")
@@ -1140,7 +1153,7 @@
(setf any-p t)
(when (eq (sb!di:debug-var-validity v location) :valid)
(setf any-valid-p t)
- (format t "~S~:[#~W~;~*~] = ~S~%"
+ (format *debug-io* "~S~:[#~W~;~*~] = ~S~%"
(sb!di:debug-var-symbol v)
(zerop (sb!di:debug-var-id v))
(sb!di:debug-var-id v)
@@ -1148,21 +1161,24 @@
(cond
((not any-p)
- (format t "There are no local variables ~@[starting with ~A ~]~
- in the function."
+ (format *debug-io*
+ "There are no local variables ~@[starting with ~A ~]~
+ in the function."
prefix))
((not any-valid-p)
- (format t "All variables ~@[starting with ~A ~]currently ~
- have invalid values."
+ (format *debug-io*
+ "All variables ~@[starting with ~A ~]currently ~
+ have invalid values."
prefix))))
- (write-line "There is no variable information available."))))
+ (write-line "There is no variable information available."
+ *debug-io*))))
(!def-debug-command-alias "L" "LIST-LOCALS")
(!def-debug-command "SOURCE" ()
- (fresh-line)
- (print-code-location-source-form (sb!di:frame-code-location *current-frame*)
- (read-if-available 0)))
+ (print (code-location-source-form (sb!di:frame-code-location *current-frame*)
+ (read-if-available 0))
+ *debug-io*))
;;;; source location printing
@@ -1241,7 +1257,7 @@
(setq *cached-source-stream* (open name :if-does-not-exist nil))
(unless *cached-source-stream*
(error "The source file no longer exists:~% ~A" (namestring name)))
- (format t "~%; file: ~A~%" (namestring name)))
+ (format *debug-io* "~%; file: ~A~%" (namestring name)))
(setq *cached-debug-source*
(if (= (sb!di:debug-source-created d-source)
@@ -1252,7 +1268,8 @@
((eq *cached-debug-source* d-source)
(file-position *cached-source-stream* char-offset))
(t
- (format t "~%; File has been modified since compilation:~%; ~A~@
+ (format *debug-io*
+ "~%; File has been modified since compilation:~%; ~A~@
; Using form offset instead of character position.~%"
(namestring name))
(file-position *cached-source-stream* 0)
@@ -1271,15 +1288,15 @@
(let ((*readtable* *cached-readtable*))
(read *cached-source-stream*))))
-(defun print-code-location-source-form (location context)
+(defun code-location-source-form (location context)
(let* ((location (maybe-block-start-location location))
(form-num (sb!di:code-location-form-number location)))
(multiple-value-bind (translations form) (get-toplevel-form location)
(unless (< form-num (length translations))
(error "The source path no longer exists."))
- (prin1 (sb!di:source-path-context form
- (svref translations form-num)
- context)))))
+ (sb!di:source-path-context form
+ (svref translations form-num)
+ context))))
;;; step to the next steppable form
(!def-debug-command "STEP" ()
@@ -1299,7 +1316,7 @@
(function (sb!di:debug-fun-fun debug-fun)))
(if function
(describe function)
- (format t "can't figure out the function for this frame"))))
+ (format *debug-io* "can't figure out the function for this frame"))))
(!def-debug-command "SLURP" ()
(loop while (read-char-no-hang *standard-input*)))
@@ -1318,16 +1335,17 @@
return
(sb!di:frame-code-location *current-frame*))
*current-frame*))
- (format t "~@<can't find a tag for this frame ~
- ~2I~_(hint: try increasing the DEBUG optimization quality ~
- and recompiling)~:@>"))))
+ (format *debug-io*
+ "~@<can't find a tag for this frame ~
+ ~2I~_(hint: try increasing the DEBUG optimization quality ~
+ and recompiling)~:@>"))))
;;;; debug loop command utilities
(defun read-prompting-maybe (prompt)
(unless (sb!int:listen-skip-whitespace *debug-io*)
- (princ prompt)
- (force-output))
+ (princ prompt *debug-io*)
+ (force-output *debug-io*))
(read *debug-io*))
(defun read-if-available (default)
Index: defboot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defboot.lisp,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -d -r1.46 -r1.47
--- defboot.lisp 26 Oct 2004 17:51:13 -0000 1.46
+++ defboot.lisp 1 Mar 2005 10:21:31 -0000 1.47
@@ -160,7 +160,7 @@
(block ,(fun-name-block-name name)
,@forms)))
(lambda `(lambda ,@lambda-guts))
- #-sb-xc-host
+ #-sb-xc-host
(named-lambda `(named-lambda ,name ,@lambda-guts))
(inline-lambda
(when (inline-fun-name-p name)
@@ -175,14 +175,14 @@
`(progn
;; In cross-compilation of toplevel DEFUNs, we arrange for
;; the LAMBDA to be statically linked by GENESIS.
- ;;
- ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
- ;; here instead of LAMBDA. The reason is historical:
- ;; COLD-FSET was written before NAMED-LAMBDA, and has special
- ;; logic of its own to notify the compiler about NAME.
- #+sb-xc-host
+ ;;
+ ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
+ ;; here instead of LAMBDA. The reason is historical:
+ ;; COLD-FSET was written before NAMED-LAMBDA, and has special
+ ;; logic of its own to notify the compiler about NAME.
+ #+sb-xc-host
(cold-fset ,name ,lambda)
-
+
(eval-when (:compile-toplevel)
(sb!c:%compiler-defun ',name ',inline-lambda t))
(eval-when (:load-toplevel :execute)
Index: defmacro.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defmacro.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- defmacro.lisp 10 May 2004 15:02:59 -0000 1.19
+++ defmacro.lisp 1 Mar 2005 10:21:31 -0000 1.20
@@ -41,9 +41,10 @@
;; 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 (sb!c::debug-namify "DEFMACRO " name)))
+ (debug-name (sb!c::debug-name 'macro-function name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%defmacro ',name #',def ',lambda-list ,doc ,debug-name)))))))
+ (sb!c::%defmacro ',name #',def ',lambda-list
+ ,doc ',debug-name)))))))
(macrolet
((def (times set-p)
Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -d -r1.70 -r1.71
--- early-extensions.lisp 28 Oct 2004 14:29:33 -0000 1.70
+++ early-extensions.lisp 1 Mar 2005 10:21:31 -0000 1.71
@@ -641,6 +641,7 @@
;;;; various operations on names
;;; Is NAME a legal function name?
+(declaim (inline legal-fun-name-p))
(defun legal-fun-name-p (name)
(values (valid-function-name-p name)))
@@ -796,6 +797,14 @@
(%failed-aver ,(format nil "~A" expr))))
(defun %failed-aver (expr-as-string)
+ ;; hackish way to tell we're in a cold sbcl and output the
+ ;; message before signallign error, as it may be this is too
+ ;; early in the cold init.
+ (when (find-package "SB!C")
+ (fresh-line)
+ (write-line "failed AVER:")
+ (write-line expr-as-string)
+ (terpri))
(bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
(defun bug (format-control &rest format-arguments)
Index: inspect.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/inspect.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- inspect.lisp 20 Feb 2005 12:04:46 -0000 1.22
+++ inspect.lisp 1 Mar 2005 10:21:31 -0000 1.23
@@ -211,18 +211,19 @@
(inspected-standard-object-elements object)))
(defmethod inspected-parts ((object function))
- (let* ((type (sb-kernel:widetag-of object))
- (object (if (= type sb-vm:closure-header-widetag)
- (sb-kernel:%closure-fun object)
- object)))
- (values (format nil "FUNCTION ~S.~@[~%Argument List: ~A~]." object
- (sb-kernel:%simple-fun-arglist object)
- ;; Defined-from stuff used to be here. Someone took
- ;; it out. FIXME: We should make it easy to get
- ;; to DESCRIBE from the inspector.
- )
- t
- nil)))
+ (values (format nil "The object is a ~A named ~S.~%"
+ (if (closurep object) 'closure 'function)
+ (%fun-name object))
+ t
+ ;; Defined-from stuff used to be here. Someone took
+ ;; it out. FIXME: We should make it easy to get
+ ;; to DESCRIBE from the inspector.
+ (list*
+ (cons "Lambda-list" (%fun-lambda-list object))
+ (cons "Ftype" (%fun-type object))
+ (when (closurep object)
+ (list
+ (cons "Closed over values" (%closure-values object)))))))
(defmethod inspected-parts ((object vector))
(values (format nil
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/macros.lisp,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -d -r1.43 -r1.44
--- macros.lisp 7 Feb 2005 12:41:44 -0000 1.43
+++ macros.lisp 1 Mar 2005 10:21:31 -0000 1.44
@@ -128,13 +128,13 @@
(let ((def `(lambda (,whole ,environment)
,@local-decs
,body))
- (debug-name (sb!c::debug-namify "DEFINE-COMPILER-MACRO " name)))
+ (debug-name (sb!c::debug-name 'compiler-macro-function name)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb!c::%define-compiler-macro ',name
- #',def
- ',lambda-list
- ,doc
- ,debug-name))))))
+ (sb!c::%define-compiler-macro ',name
+ #',def
+ ',lambda-list
+ ,doc
+ ',debug-name))))))
;;; FIXME: This will look remarkably similar to those who have already
;;; seen the code for %DEFMACRO in src/code/defmacro.lisp. Various
Index: pprint.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pprint.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- pprint.lisp 30 Oct 2004 14:36:06 -0000 1.30
+++ pprint.lisp 1 Mar 2005 10:21:31 -0000 1.31
@@ -1099,10 +1099,19 @@
(defun pprint-flet (stream list &rest noise)
(declare (ignore noise))
- (funcall (formatter
- "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
- stream
- list))
+ (if (cddr list)
+ (funcall (formatter
+ "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
+ stream
+ list)
+ ;; for printing function names like (flet foo)
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (write (pprint-pop) :stream stream)
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (write (pprint-pop) :stream stream)))))
(defun pprint-let (stream list &rest noise)
(declare (ignore noise))
Index: print.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/print.lisp,v
retrieving revision 1.60
retrieving revision 1.61
diff -u -d -r1.60 -r1.61
--- print.lisp 13 Feb 2005 14:27:08 -0000 1.60
+++ print.lisp 1 Mar 2005 10:21:31 -0000 1.61
@@ -1630,23 +1630,15 @@
nil)
(defun output-fun (object stream)
- (let* ((*print-length* 3) ; in case we have to..
- (*print-level* 3) ; ..print an interpreted function definition
- ;; FIXME: This find-the-function-name idiom ought to be
- ;; encapsulated in a function somewhere.
- (name (case (fun-subtype object)
- (#.sb!vm:closure-header-widetag "CLOSURE")
- (#.sb!vm:simple-fun-header-widetag (%simple-fun-name object))
- (t 'no-name-available)))
- (identified-by-name-p (and (symbolp name)
- (fboundp name)
- (eq (fdefinition name) object))))
- (print-unreadable-object (object
- stream
- :identity (not identified-by-name-p))
- (prin1 'function stream)
- (unless (eq name 'no-name-available)
- (format stream " ~S" name)))))
+ (let* ((*print-length* 3) ; in case we have to..
+ (*print-level* 3) ; ..print an interpreted function definition
+ (name (%fun-name object))
+ (proper-name-p (and (legal-fun-name-p name) (fboundp name)
+ (eq (fdefinition name) object))))
+ (print-unreadable-object (object stream :identity (not proper-name-p))
+ (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]"
+ (closurep object)
+ name))))
;;;; catch-all for unknown things
Index: target-misc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-misc.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- target-misc.lisp 5 Jul 2004 02:30:42 -0000 1.19
+++ target-misc.lisp 1 Mar 2005 10:21:32 -0000 1.20
@@ -35,33 +35,43 @@
(values (svref (sb!c::debug-source-name source) 0)
nil
name))
- ;; FIXME: shouldn't these two clauses be the other way
- ;; round? Using VALID-FUNCTION-NAME-P to see if we
- ;; want to find an inline-expansion?
- ((stringp name)
- (values nil t name))
- (t
+ ((legal-fun-name-p name)
(let ((exp (fun-name-inline-expansion name)))
- (if exp
- (values exp nil name)
- (values nil t name))))))
+ (values exp (not exp) name)))
+ (t
+ (values nil t name))))
(values nil t name))))
+(defun closurep (object)
+ (= sb!vm:closure-header-widetag (widetag-of object)))
+
+(defun %fun-fun (function)
+ (declare (function function))
+ (case (widetag-of function)
+ (#.sb!vm:simple-fun-header-widetag
+ function)
+ (#.sb!vm:closure-header-widetag
+ (%closure-fun function))
+ (#.sb!vm:funcallable-instance-header-widetag
+ (funcallable-instance-fun function))))
+
+(defun %closure-values (object)
+ (declare (function object))
+ (coerce (loop for index from 0 below (1- (get-closure-length object))
+ collect (%closure-index-ref object index))
+ 'simple-vector))
+
+(defun %fun-lambda-list (object)
+ (%simple-fun-arglist (%fun-fun object)))
+
;;; a SETFable function to return the associated debug name for FUN
;;; (i.e., the third value returned from CL:FUNCTION-LAMBDA-EXPRESSION),
;;; or NIL if there's none
-(defun %fun-name (fun)
- (case (widetag-of fun)
- (#.sb!vm:closure-header-widetag
- (%simple-fun-name (%closure-fun fun)))
- (#.sb!vm:simple-fun-header-widetag
- ;; KLUDGE: The pun that %SIMPLE-FUN-NAME is used for closure
- ;; functions is left over from CMU CL (modulo various renaming
- ;; that's gone on since the fork).
- (%simple-fun-name fun))
- (#.sb!vm:funcallable-instance-header-widetag
- (%simple-fun-name
- (funcallable-instance-fun fun)))))
+(defun %fun-name (function)
+ (%simple-fun-name (%fun-fun function)))
+
+(defun %fun-type (function)
+ (%simple-fun-type (%fun-fun function)))
(defun (setf %fun-name) (new-name fun)
(aver nil) ; since this is unsafe 'til bug 137 is fixed
Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -d -r1.63 -r1.64
--- toplevel.lisp 6 Jan 2005 12:47:59 -0000 1.63
+++ toplevel.lisp 1 Mar 2005 10:21:32 -0000 1.64
@@ -272,9 +272,9 @@
+++, ++, +, ///, //, /, and -."
(setf - form)
(let ((results
- (multiple-value-list
- (eval-in-lexenv form
- (make-null-interactive-lexenv)))))
+ (multiple-value-list
+ (eval-in-lexenv form
+ (make-null-interactive-lexenv)))))
(setf /// //
// /
/ results
Index: typecheckfuns.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/typecheckfuns.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- typecheckfuns.lisp 27 Oct 2004 21:36:45 -0000 1.8
+++ typecheckfuns.lisp 1 Mar 2005 10:21:32 -0000 1.9
@@ -130,20 +130,26 @@
#+sb-xc
(defun !typecheckfuns-cold-init ()
+ (/show0 "in typecheckfuns-cold-init")
(setf *typecheckfuns* (make-hash-table :test 'equal))
;; Initialize the table of common typespecs.
(setf *common-typespecs* #.*compile-time-common-typespecs*)
;; Initialize *TYPECHECKFUNS* with typecheckfuns for common typespecs.
+ (/show0 "typecheckfuns-cold-init initial setfs done")
(macrolet ((macro ()
`(progn
,@(map 'list
(lambda (typespec)
- `(setf (gethash ',typespec *typecheckfuns*)
- (lambda (arg)
- (unless (typep arg ',typespec)
- (typecheck-failure arg ',typespec))
- (values))))
- *common-typespecs*))))
+ `(progn
+ (/show0 "setf")
+ (setf (gethash ',typespec *typecheckfuns*)
+ (progn
+ (/show0 "lambda")
+ (lambda (arg)
+ (unless (typep arg ',typespec)
+ (typecheck-failure arg ',typespec))
+ (values))))))
+ *common-typespecs*))))
(macro))
(values))
|