source: trunk/source/level-1/l1-readloop-lds.lisp @ 11373

Last change on this file since 11373 was 11373, checked in by gz, 11 years ago

Finish source location and pc -> source mapping support, from working-0711 but with some modifications.

Details:

Source location are recorded in CCL:SOURCE-NOTE's, which are objects with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end positions are file positions (not character positions). The text will be NIL unless text recording was on at read-time. If the original file is still available, you can force missing source text to be read from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.

Source-note's are associated with definitions (via record-source-file) and also stored in function objects (including anonymous and nested functions). The former can be retrieved via CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.

The recording behavior is controlled by the new variable CCL:*SAVE-SOURCE-LOCATIONS*:

If NIL, don't store source-notes in function objects, and store only the filename for definitions (the latter only if *record-source-file* is true).
If T, store source-notes, including a copy of the original source text, for function objects and definitions (the latter only if *record-source-file* is true).
If :NO-TEXT, store source-notes, but without saved text, for function objects and defintions (the latter only if *record-source-file* is true). This is the default.

PC to source mapping is controlled by the new variable CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a compressed table mapping pc offsets to corresponding source locations. This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) which returns a source-note for the source at offset pc in the function.

Currently the only thing that makes use of any of this is the disassembler. ILISP and current version of Slime still use backward-compatible functions that deal with filenames only. The plan is to make Slime, and our IDE, use this eventually.

Known bug: most of this only works through the file compiler. Still need to make it work with loading from source (not hard, just haven't gotten to it yet).

This checkin incidentally includes bits and pieces of support for code coverage, which is still
incomplete and untested. Ignore it.

The PPC version is untested. I need to check it in so I can move to a PPC for testing.

Sizes:

18387152 Nov 16 10:00 lx86cl64.image-no-loc-no-pc
19296464 Nov 16 10:11 lx86cl64.image-loc-no-text-no-pc
20517072 Nov 16 09:58 lx86cl64.image-loc-no-text-with-pc [default]
25514192 Nov 16 09:55 lx86cl64.image-loc-with-text-with-pc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 27.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17; l1-readloop-lds.lisp
18
19(in-package "CCL")
20
21
22
23(defun toplevel-loop ()
24  (loop
25    (if (eq (catch :toplevel 
26              (read-loop :break-level 0 )) $xstkover)
27      (format t "~&;[Stacks reset due to overflow.]")
28      (when (eq *current-process* *initial-process*)
29        (toplevel)))))
30
31
32(defvar *defined-toplevel-commands* ())
33(defvar *active-toplevel-commands* ())
34
35(defun %define-toplevel-command (group-name key name fn doc args)
36  (let* ((group (or (assoc group-name *defined-toplevel-commands*)
37                    (car (push (list group-name)
38                               *defined-toplevel-commands*))))
39         (pair (assoc key (cdr group) :test #'eq)))
40    (if pair
41      (rplacd pair (list* fn doc args))
42      (push (cons key (list* fn doc args)) (cdr group))))
43  name)
44
45(define-toplevel-command 
46    :global y (&optional p) "Yield control of terminal-input to process
47whose name or ID matches <p>, or to any process if <p> is null"
48    (%%yield-terminal-to (if p (find-process p))))      ;may be nil
49
50
51(define-toplevel-command
52    :global kill (p) "Kill process whose name or ID matches <p>"
53    (let* ((proc (find-process p)))
54      (if proc
55        (process-kill proc))))
56
57(define-toplevel-command 
58    :global proc (&optional p) "Show information about specified process <p>/all processes"
59    (flet ((show-process-info (proc)
60             (format t "~&~d : ~a ~a ~20t[~a] "
61                     (process-serial-number proc)
62                     (if (eq proc *current-process*)
63                       "->"
64                       "  ")
65                     (process-name proc)
66                     (process-whostate proc))
67             (let* ((suspend-count (process-suspend-count proc)))
68               (if (and suspend-count (not (eql 0 suspend-count)))
69                 (format t " (Suspended)")))
70             (let* ((terminal-input-shared-resource
71                     (if (typep *terminal-io* 'two-way-stream)
72                       (input-stream-shared-resource
73                        (two-way-stream-input-stream *terminal-io*)))))
74               (if (and terminal-input-shared-resource
75                        (%shared-resource-requestor-p
76                         terminal-input-shared-resource proc))
77                 (format t " (Requesting terminal input)")))
78             (fresh-line)))
79      (if p
80        (let* ((proc (find-process p)))
81          (if (null proc)
82            (format t "~&;; not found - ~s" p)
83            (show-process-info proc)))
84        (dolist (proc (all-processes) (values))
85          (show-process-info proc)))))
86
87(define-toplevel-command :global cd (dir) "Change to directory DIR" (setf (current-directory) dir) (toplevel-print (list (current-directory))))
88
89(define-toplevel-command :global pwd () "Print the pathame of the current directory" (toplevel-print (list (current-directory))))
90
91
92
93(defun list-restarts ()
94  (format *debug-io* "~&>   Type (:C <n>) to invoke one of the following restarts:")
95  (display-restarts))
96
97(define-toplevel-command :break pop () "exit current break loop" (abort-break))
98(define-toplevel-command :break a () "exit current break loop" (abort-break))
99(define-toplevel-command :break go () "continue" (continue))
100(define-toplevel-command :break q () "return to toplevel" (toplevel))
101(define-toplevel-command :break r () "list restarts" (list-restarts))
102
103(define-toplevel-command :break set (n frame value) "Set <n>th item of frame <frame> to <value>"
104  (let* ((frame-sp (nth-raw-frame frame *break-frame* nil)))
105    (if frame-sp
106        (toplevel-print (list (set-nth-value-in-frame frame-sp n nil value)))
107        (format *debug-io* "No frame with number ~D~%" frame))))
108
109(define-toplevel-command :break nframes ()
110  "print the number of stack frames accessible from this break loop"
111  (do* ((p *break-frame* (parent-frame p nil))
112        (i 0 (1+ i))
113        (last (last-frame-ptr)))
114      ((eql p last) (toplevel-print (list i)))))
115
116(define-toplevel-command :global ? () "help"
117  (format t "~&The following toplevel commands are available:")
118  (when *default-integer-command*
119    (format t "~& <n>  ~8Tthe same as (~s <n>)" (car *default-integer-command*)))
120  (dolist (g *active-toplevel-commands*)
121    (dolist (c (cdr g))
122      (let* ((command (car c))
123             (doc (caddr c))
124             (args (cdddr c)))
125        (if args
126          (format t "~& (~S~{ ~A~}) ~8T~A" command args doc)
127          (format t "~& ~S  ~8T~A" command doc)))))
128  (format t "~&Any other form is evaluated and its results are printed out."))
129
130
131(define-toplevel-command :break b (&key start count show-frame-contents) "backtrace"
132  (when *break-frame*
133      (print-call-history :detailed-p show-frame-contents
134                          :origin *break-frame*
135                          :count count
136                          :start-frame-number (or start 0))))
137
138(define-toplevel-command :break c (&optional n) "Choose restart <n>. If no <n>, continue"
139  (if n
140   (select-restart n)
141   (continue)))
142
143(define-toplevel-command :break f (n) "Show backtrace frame <n>"
144   (print-call-history :origin *break-frame*
145                       :start-frame-number n
146                       :count 1
147                       :detailed-p t))
148
149(define-toplevel-command :break return-from-frame (i &rest values) "Return VALUES from the I'th stack frame"
150  (let* ((frame-sp (nth-raw-frame  i *break-frame* nil)))
151    (if frame-sp
152      (apply #'return-from-frame frame-sp values))))
153
154(define-toplevel-command :break apply-in-frame (i function &rest args) "Applies FUNCTION to ARGS in the execution context of the Ith stack frame"
155  (let* ((frame-sp (nth-raw-frame  i *break-frame* nil)))
156    (if frame-sp
157      (apply-in-frame frame-sp function args))))
158                         
159                         
160
161(define-toplevel-command :break raw (n) "Show raw contents of backtrace frame <n>"
162   (print-call-history :origin *break-frame*
163                       :start-frame-number n
164                       :count 1
165                       :detailed-p :raw))
166
167(define-toplevel-command :break v (n frame-number) "Return value <n> in frame <frame-number>"
168  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
169    (if frame-sp
170      (toplevel-print (list (nth-value-in-frame frame-sp n nil))))))
171
172(define-toplevel-command :break arg (name frame-number) "Return value of argument named <name> in frame <frame-number>"
173  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
174    (when frame-sp
175      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
176        (when (and lfun pc)
177          (let* ((unavailable (cons nil nil)))
178            (declare (dynamic-extent unavailable))
179            (let* ((value (arg-value nil frame-sp lfun pc unavailable name)))
180              (if (eq value unavailable)
181                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
182                (toplevel-print (list value))))))))))
183
184(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named <name> in frame <frame-number> to value <new>."
185  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
186    (when frame-sp
187      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
188        (when (and lfun pc)
189          (or (set-arg-value nil frame-sp lfun pc name new)
190              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
191   
192
193(define-toplevel-command :break local (name frame-number) "Return value of local denoted by <name> in frame <frame-number> <name> can either be a symbol - in which case the most recent
194binding of that symbol is used - or an integer index into the frame's set of local bindings."
195  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
196    (when frame-sp
197      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
198        (when (and lfun pc)
199          (let* ((unavailable (cons nil nil)))
200            (declare (dynamic-extent unavailable))
201            (let* ((value (local-value nil frame-sp lfun pc unavailable name)))
202              (if (eq value unavailable)
203                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
204                (toplevel-print (list value))))))))))
205
206(define-toplevel-command :break set-local (name frame-number new) "Set value of argument denoted <name> (see :LOCAL) in frame <frame-number> to value <new>."
207  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
208    (when frame-sp
209      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
210        (when (and lfun pc)
211          (or (set-local-value nil frame-sp lfun pc name new)
212              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
213
214
215(define-toplevel-command :break form (frame-number)
216   "Return a form which looks like the call which established the stack frame identified by <frame-number>.  This is only well-defined in certain cases: when the function is globally named and not a lexical closure and when it was compiled with *SAVE-LOCAL-SYMBOLS* in effect."
217   (let* ((form (dbg-form frame-number)))
218     (when form
219       (let* ((*print-level* *backtrace-print-level*)
220              (*print-length* *backtrace-print-length*))
221         (toplevel-print (list form))))))
222
223;;; Ordinarily, form follows function.
224(define-toplevel-command :break function (frame-number)
225  "Returns the function invoked in backtrace frame <frame-number>.  This may be useful for, e.g., disassembly"
226  (let* ((cfp (nth-raw-frame frame-number *break-frame* nil)))
227    (when (and cfp (not (catch-csp-p cfp nil)))
228      (let* ((function (cfp-lfun cfp)))
229        (when function
230          (toplevel-print (list function)))))))
231 
232
233
234         
235
236 
237
238(defun %use-toplevel-commands (group-name)
239  ;; Push the whole group
240  (pushnew (assoc group-name *defined-toplevel-commands*)
241           *active-toplevel-commands*
242           :key #'(lambda (x) (car x))))  ; #'car not defined yet ...
243
244(%use-toplevel-commands :global)
245
246(defparameter *toplevel-commands-dwim* t "If true, tries to interpret otherwise-erroneous toplevel
247expressions as commands")
248
249(defvar *default-integer-command* nil
250  "If non-nil, should be (keyword  min max)), causing integers between min and max to be
251  interpreted as (keyword integer)")
252
253(defun check-toplevel-command (form)
254  (when (and *default-integer-command*
255             (integerp form)
256             (<= (cadr *default-integer-command*) form (caddr *default-integer-command*)))
257    (setq form `(,(car *default-integer-command*) ,form)))
258  (let* ((cmd (if (consp form) (car form) form))
259         (args (if (consp form) (cdr form))))
260    (when (or (keywordp cmd)
261              (and *toplevel-commands-dwim*
262                   (non-nil-symbol-p cmd)
263                   (not (if (consp form) (fboundp cmd) (boundp cmd)))
264                   ;; Use find-symbol so don't make unneeded keywords.
265                   (setq cmd (find-symbol (symbol-name cmd) :keyword))))
266      (when (eq cmd :help) (setq cmd :?))
267      (dolist (g *active-toplevel-commands*)
268        (let* ((pair (assoc cmd (cdr g))))
269          (when pair 
270            (apply (cadr pair) args)
271            (return t)))))))
272
273(defparameter *quit-on-eof* nil)
274
275(defmethod stream-eof-transient-p (stream)
276  (let ((fd (stream-device stream :input)))
277    (and fd (eof-transient-p fd))))
278
279;;; This is the part common to toplevel loop and inner break loops.
280(defun read-loop (&key (input-stream *standard-input*)
281                       (output-stream *standard-output*)
282                       (break-level *break-level*)
283                       (prompt-function #'(lambda (stream)
284                                            (when (and *show-available-restarts* *break-condition*)
285                                              (list-restarts)
286                                              (setf *show-available-restarts* nil))
287                                            (print-listener-prompt stream t))))
288  (let* ((*break-level* break-level)
289         (*last-break-level* break-level)
290         (*loading-file-source-file* nil)
291         (*loading-toplevel-location* nil)
292         *in-read-loop*
293         *** ** * +++ ++ + /// // / -
294         (eof-value (cons nil nil))
295         (*show-available-restarts* (and *show-restarts-on-break* *break-condition*)))
296    (declare (dynamic-extent eof-value))
297    (loop
298      (restart-case
299       (catch :abort                    ;last resort...
300         (loop
301           (catch-cancel
302            (loop               
303              (setq *in-read-loop* nil
304                    *break-level* break-level)
305              (multiple-value-bind (form env print-result)
306                  (toplevel-read :input-stream input-stream
307                                 :output-stream output-stream
308                                 :prompt-function prompt-function
309                                 :eof-value eof-value)
310                (if (eq form eof-value)
311                  (if (and (not *batch-flag*)
312                           (not *quit-on-eof*)
313                           (stream-eof-transient-p input-stream))
314                    (progn
315                      (stream-clear-input input-stream)
316                      (abort-break))
317                    (exit-interactive-process *current-process*))
318                    (or (check-toplevel-command form)
319                        (let* ((values (toplevel-eval form env)))
320                          (if print-result (toplevel-print values))))))))
321           (format *terminal-io* "~&Cancelled")))
322       (abort () :report (lambda (stream)
323                           (if (eq break-level 0)
324                             (format stream "Return to toplevel.")
325                             (format stream "Return to break level ~D." break-level)))
326              #|                        ; Handled by interactive-abort
327                                        ; go up one more if abort occurred while awaiting/reading input               
328              (when (and *in-read-loop* (neq break-level 0))
329              (abort))
330              |#
331               )
332        (abort-break () 
333                     (unless (eq break-level 0)
334                       (abort))))
335       (clear-input input-stream)
336      (format output-stream "~%"))))
337
338;;; The first non-whitespace character available on INPUT-STREAM is a colon.
339;;; Try to interpret the line as a colon command (or possibly just a keyword.)
340(defun read-command-or-keyword (input-stream eof-value)
341  (let* ((line (read-line input-stream nil eof-value)))
342    (if (eq line eof-value)
343      eof-value
344      (let* ((in (make-string-input-stream line))
345             (keyword (read in nil eof-value)))
346        (if (eq keyword eof-value)
347          eof-value
348          (if (not (keywordp keyword))
349            keyword
350            (collect ((params))
351              (loop
352                (let* ((param (read in nil eof-value)))
353                  (if (eq param eof-value)
354                    (return
355                      (let* ((params (params)))
356                        (if params
357                          (cons keyword params)
358                          keyword)))
359                    (params (eval param))))))))))))
360
361;;; Read a form from the specified stream.
362(defun toplevel-read (&key (input-stream *standard-input*)
363                           (output-stream *standard-output*)
364                           (prompt-function #'print-listener-prompt)
365                           (eof-value *eof-value*))
366  (force-output output-stream)
367  (funcall prompt-function output-stream)
368  (read-toplevel-form input-stream eof-value))
369
370(defvar *always-eval-user-defvars* nil)
371
372(defun process-single-selection (form)
373  (if (and *always-eval-user-defvars*
374           (listp form) (eq (car form) 'defvar) (cddr form))
375    `(defparameter ,@(cdr form))
376    form))
377
378(defun toplevel-eval (form &optional env)
379  (destructuring-bind (vars . vals) (or env '(nil . nil))
380    (progv vars vals
381      (setq +++ ++ ++ + + - - form)
382      (unwind-protect
383           (let* ((package *package*)
384                  (values (multiple-value-list (cheap-eval-in-environment form nil))))
385             (unless (eq package *package*)
386               ;; If changing a local value (e.g. buffer-local), not useful to notify app
387               ;; without more info.  Perhaps should have a *source-context* that can send along?
388               (unless (member '*package* vars)
389                 (application-ui-operation *application* :note-current-package *package*)))
390             values)
391        (loop for var in vars as pval on vals
392              do (setf (car pval) (symbol-value var)))))))
393
394
395(defun toplevel-print (values &optional (out *standard-output*))
396  (setq /// // // / / values)
397  (unless (eq (car values) (%unbound-marker))
398    (setq *** ** ** * *  (%car values)))
399  (when values
400    (fresh-line out)
401    (dolist (val values) (write val :stream out) (terpri out))))
402
403(defparameter *listener-prompt-format* "~[?~:;~:*~d >~] ")
404
405 
406(defun print-listener-prompt (stream &optional (force t))
407  (unless *quiet-flag*
408    (when (or force (neq *break-level* *last-break-level*))
409      (let* ((*listener-indent* nil))
410        (fresh-line stream)
411        (format stream *listener-prompt-format* *break-level*))
412      (setq *last-break-level* *break-level*)))
413    (force-output stream))
414
415
416;;; Fairly crude default error-handlingbehavior, and a fairly crude mechanism
417;;; for customizing it.
418
419(defvar *app-error-handler-mode* :quit
420  "one of :quit, :quit-quietly, :listener might be useful.")
421
422(defmethod application-error ((a application) condition error-pointer)
423  (case *app-error-handler-mode*
424    (:listener   (break-loop-handle-error condition error-pointer))
425    (:quit-quietly (quit -1))
426    (:quit  (format t "~&Fatal error in ~s : ~a"
427                    (pathname-name (car *command-line-argument-list*))
428                    condition)
429                    (quit -1))))
430
431(defun make-application-error-handler (app mode)
432  (declare (ignore app))
433  (setq *app-error-handler-mode* mode))
434
435
436; You may want to do this anyway even if your application
437; does not otherwise wish to be a "lisp-development-system"
438(defmethod application-error ((a lisp-development-system) condition error-pointer)
439  (break-loop-handle-error condition error-pointer))
440
441(defun abnormal-application-exit ()
442  (ignore-errors
443    (print-call-history)
444    (force-output *debug-io*)
445    (quit -1))
446  (#__exit -1))
447
448(defun break-loop-handle-error (condition error-pointer)
449  (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals)
450    (dolist (x bogus-globals)
451      (set x (funcall (pop newvals))))
452    (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
453      (let ((hook *debugger-hook*)
454            (*debugger-hook* nil))
455        (funcall hook condition hook)))
456    (%break-message "Error" condition error-pointer)
457    (let* ((s *error-output*))
458      (dolist (bogusness bogus-globals)
459        (let ((oldval (pop oldvals)))
460          (format s "~&;  NOTE: ~S was " bogusness)
461          (if (eq oldval (%unbound-marker-8))
462            (format s "unbound")
463            (format s "~s" oldval))
464          (format s ", was reset to ~s ." (symbol-value bogusness)))))
465    (if (and *break-on-errors* (not *batch-flag*))
466      (with-terminal-input
467          (break-loop condition error-pointer))
468      (if *batch-flag*
469        (abnormal-application-exit)
470        (abort)))))
471
472(defun break (&optional string &rest args)
473  "Print a message and invoke the debugger without allowing any possibility
474   of condition handling occurring."
475  (if *batch-flag*
476    (apply #'error string args)
477    (apply #'%break-in-frame (%get-frame-ptr) string args)))
478
479(defun %break-in-frame (fp &optional string &rest args)
480  (flet ((do-break-loop ()
481           (let ((c (if (typep string 'condition)
482                      string
483                      (make-condition 'simple-condition
484                                    :format-control (or string "")
485                                    :format-arguments args))))
486             (cbreak-loop "Break" "Return from BREAK." c fp))))
487    (cond ((%i> *interrupt-level* -1)
488           (do-break-loop))
489          (*break-loop-when-uninterruptable*
490           (format *error-output* "Break while interrupt-level less than zero; binding to 0 during break-loop.")
491           (let ((interrupt-level (interrupt-level)))
492             (unwind-protect
493                  (progn
494                    (setf (interrupt-level) 0)
495                    (do-break-loop))
496               (setf (interrupt-level) interrupt-level))))
497          (t (format *error-output* "Break while interrupt-level less than zero; ignored.")))))
498
499
500(defun invoke-debugger (condition &aux (fp (%get-frame-ptr)))
501  "Enter the debugger."
502  (let ((c (require-type condition 'condition)))
503    (when *debugger-hook*
504      (let ((hook *debugger-hook*)
505            (*debugger-hook* nil))
506        (funcall hook c hook)))
507    (%break-message "Debug" c fp)
508    (with-terminal-input
509        (break-loop c fp))))
510
511(defun %break-message (msg condition error-pointer &optional (prefixchar #\>))
512  (let ((*print-circle* *error-print-circle*)
513        ;(*print-prett*y nil)
514        (*print-array* nil)
515        (*print-escape* t)
516        (*print-gensym* t)
517        (*print-length* *error-print-length*)
518        (*print-level* *error-print-level*)
519        (*print-lines* nil)
520        (*print-miser-width* nil)
521        (*print-readably* nil)
522        (*print-right-margin* nil)
523        (*signal-printing-errors* nil)
524        (s (make-indenting-string-output-stream prefixchar nil)))
525    (format s "~A ~A: " prefixchar msg)
526    (setf (indenting-string-output-stream-indent s) (column s))
527    ;(format s "~A" condition) ; evil if circle
528    (report-condition condition s)
529    (if (not (and (typep condition 'simple-program-error)
530                  (simple-program-error-context condition)))
531      (format *error-output* "~&~A~%~A While executing: ~S"
532              (get-output-stream-string s) prefixchar (%real-err-fn-name error-pointer))
533      (format *error-output* "~&~A"
534              (get-output-stream-string s)))
535    (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*))
536  (force-output *error-output*)))
537                                        ; returns NIL
538
539(defun cbreak-loop (msg cont-string condition error-pointer)
540  (let* ((*print-readably* nil))
541    (%break-message msg condition error-pointer)
542    (with-terminal-input
543      (restart-case (break-loop condition error-pointer)
544                    (continue () :report (lambda (stream) (write-string cont-string stream))))
545      (fresh-line *error-output*)
546      nil)))
547
548(defun warn (condition-or-format-string &rest args)
549  "Warn about a situation by signalling a condition formed by DATUM and
550   ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
551   exists that causes WARN to immediately return NIL."
552  (when (typep condition-or-format-string 'condition)
553    (unless (typep condition-or-format-string 'warning)
554      (report-bad-arg condition-or-format-string 'warning))
555    (when args
556      (error 'type-error :datum args :expected-type 'null
557             :format-control "Extra arguments in ~s.")))
558  (let ((fp (%get-frame-ptr))
559        (c (require-type (condition-arg condition-or-format-string args 'simple-warning) 'warning)))
560    (when *break-on-warnings*
561      (cbreak-loop "Warning" "Signal the warning." c fp))
562    (restart-case (signal c)
563      (muffle-warning () :report "Skip the warning" (return-from warn nil)))
564    (%break-message (if (typep c 'compiler-warning) "Compiler warning" "Warning") c fp #\;)
565    ))
566
567(declaim (notinline select-backtrace))
568
569(defmacro new-backtrace-info (dialog youngest oldest tcr condition current fake db-link level)
570  (let* ((cond (gensym)))
571  `(let* ((,cond ,condition))
572    (vector ,dialog ,youngest ,oldest ,tcr (cons nil (compute-restarts ,cond)) (%catch-top ,tcr) ,cond ,current ,fake ,db-link ,level))))
573
574(defun select-backtrace ()
575  (declare (notinline select-backtrace))
576  ;(require 'new-backtrace)
577  (require :inspector)
578  (select-backtrace))
579
580(defvar *break-condition* nil "condition argument to innermost break-loop.")
581(defvar *break-frame* nil "frame-pointer arg to break-loop")
582(defvar *break-loop-when-uninterruptable* t)
583(defvar *show-restarts-on-break* #+ccl-0711 t #-ccl-0711 nil)
584(defvar *show-available-restarts* nil)
585
586(defvar *error-reentry-count* 0)
587
588(defun funcall-with-error-reentry-detection (thunk)
589  (let* ((count *error-reentry-count*)
590         (*error-reentry-count* (1+ count)))
591    (cond ((eql count 0) (funcall thunk))
592          ((eql count 1) (error "Error reporting error"))
593          (t (bug "Error reporting error")))))
594
595
596
597
598(defvar %last-continue% nil)
599(defun break-loop (condition frame-pointer)
600  "Never returns"
601  (let* ((%handlers% (last %handlers%)) ; firewall
602         (*break-frame* frame-pointer)
603         (*break-condition* condition)
604         (*compiling-file* nil)
605         (*backquote-stack* nil)
606         (continue (find-restart 'continue))
607         (*continuablep* (unless (eq %last-continue% continue) continue))
608         (%last-continue% continue)
609         (*standard-input* *debug-io*)
610         (*standard-output* *debug-io*)
611         (*signal-printing-errors* nil)
612         (*read-suppress* nil)
613         (*print-readably* nil))
614    (let* ((context (new-backtrace-info nil
615                                        frame-pointer
616                                        (if *backtrace-contexts*
617                                          (or (child-frame
618                                               (bt.youngest (car *backtrace-contexts*))
619                                               nil)
620                                              (last-frame-ptr))
621                                          (last-frame-ptr))
622                                        (%current-tcr)
623                                        condition
624                                        (%current-frame-ptr)
625                                        #+ppc-target *fake-stack-frames*
626                                        #+x86-target (%current-frame-ptr)
627                                        (db-link)
628                                        (1+ *break-level*)))
629           (*backtrace-contexts* (cons context *backtrace-contexts*)))
630      (with-toplevel-commands :break
631        (if *continuablep*
632          (let* ((*print-circle* *error-print-circle*)
633                 (*print-level* *error-print-level*)
634                 (*print-length* *error-print-length*)
635                                        ;(*print-pretty* nil)
636                 (*print-array* nil))
637            (format t "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.")
638            (format t "~&> If continued: ~A~%" continue))
639          (format t "~&> Type :POP to abort, :R for a list of available restarts.~%"))
640        (format t "~&> Type :? for other options.")
641        (terpri)
642        (force-output)
643
644        (clear-input *debug-io*)
645        (setq *error-reentry-count* 0)  ; succesfully reported error
646        (ignoring-without-interrupts
647         (unwind-protect
648              (progn
649                (application-ui-operation *application*
650                                          :enter-backtrace-context context)
651                (read-loop :break-level (1+ *break-level*)
652                           :input-stream *debug-io*
653                           :output-stream *debug-io*))
654           (application-ui-operation *application* :exit-backtrace-context
655                                     context)))))))
656
657
658
659(defun display-restarts (&optional (condition *break-condition*))
660  (loop
661    for restart in (compute-restarts condition)
662    for count upfrom 0
663    do (format *debug-io* "~&~D. ~A" count restart)
664    finally (fresh-line *debug-io*)))
665
666(defun select-restart (n &optional (condition *break-condition*))
667  (let* ((restarts (compute-restarts condition)))
668    (invoke-restart-interactively
669     (nth (require-type n `(integer 0 (,(length restarts)))) restarts))))
670
671
672
673
674; End of l1-readloop-lds.lisp
Note: See TracBrowser for help on using the repository browser.