source: branches/working-0711/ccl/level-1/l1-readloop-lds.lisp @ 12236

Last change on this file since 12236 was 12236, checked in by gz, 10 years ago

r11901 from trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 29.2 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
247 "If true, tries to interpret otherwise-erroneous toplevel expressions as commands.
248In addition, will suppress standard error handling for expressions that look like
249commands but aren't")
250
251(defvar *default-integer-command* nil
252  "If non-nil, should be (keyword  min max)), causing integers between min and max to be
253  interpreted as (keyword integer)")
254
255(defun check-toplevel-command (form)
256  (when (and *default-integer-command*
257             (integerp form)
258             (<= (cadr *default-integer-command*) form (caddr *default-integer-command*)))
259    (setq form `(,(car *default-integer-command*) ,form)))
260  (let* ((cmd (if (consp form) (car form) form))
261         (args (if (consp form) (cdr form))))
262    (when (or (keywordp cmd)
263              (and *toplevel-commands-dwim*
264                   (non-nil-symbol-p cmd)
265                   (not (if (consp form) (fboundp cmd) (boundp cmd)))
266                   ;; Use find-symbol so don't make unneeded keywords.
267                   (setq cmd (find-symbol (symbol-name cmd) :keyword))))
268      (when (eq cmd :help) (setq cmd :?))
269      (flet ((run (cmd form)
270               (or (dolist (g *active-toplevel-commands*)
271                     (let* ((pair (assoc cmd (cdr g))))
272                       (when pair 
273                         (apply (cadr pair) args)
274                         (return t))))
275                   ;; Try to detect user mistyping a command
276                   (when (and *toplevel-commands-dwim*
277                              (if (consp form)
278                                (and (keywordp (%car form)) (not (fboundp (%car form))))
279                                (keywordp form)))
280                     (error "Unknown command ~s" cmd)))))
281        (declare (dynamic-extent #'run))
282        (if *toplevel-commands-dwim*
283          (block nil
284            (handler-bind ((error (lambda (c)
285                                    (format t "~&~a" c)
286                                    (return t))))
287              (run cmd form)))
288          (run cmd form))))))
289
290(defparameter *quit-on-eof* nil)
291
292(defparameter *consecutive-eof-limit* 2 "max number of consecutive EOFs at a given break level, before we give up and abruptly exit.")
293
294(defmethod stream-eof-transient-p (stream)
295  (let ((fd (stream-device stream :input)))
296    (and fd (eof-transient-p fd))))
297
298;;; This is the part common to toplevel loop and inner break loops.
299(defun read-loop (&key (input-stream *standard-input*)
300                       (output-stream *standard-output*)
301                       (break-level *break-level*)
302                       (prompt-function #'(lambda (stream)
303                                            (when (and *show-available-restarts* *break-condition*)
304                                              (list-restarts)
305                                              (setf *show-available-restarts* nil))
306                                            (print-listener-prompt stream t))))
307  (let* ((*break-level* break-level)
308         (*last-break-level* break-level)
309         (*loading-file-source-file* nil)
310         (*loading-toplevel-location* nil)
311         *in-read-loop*
312         *** ** * +++ ++ + /// // / -
313         (eof-value (cons nil nil))
314         (eof-count 0)
315         (*show-available-restarts* (and *show-restarts-on-break* *break-condition*)))
316    (declare (dynamic-extent eof-value))
317    (loop
318      (restart-case
319       (catch :abort                    ;last resort...
320         (loop
321           (catch-cancel
322            (loop               
323              (setq *in-read-loop* nil
324                    *break-level* break-level)
325              (multiple-value-bind (form env print-result)
326                  (toplevel-read :input-stream input-stream
327                                 :output-stream output-stream
328                                 :prompt-function prompt-function
329                                 :eof-value eof-value)
330                (if (eq form eof-value)
331                  (progn
332                    (when (> (incf eof-count) *consecutive-eof-limit*)
333                      (#_ _exit 0))
334                    (if (and (not *batch-flag*)
335                             (not *quit-on-eof*)
336                             (stream-eof-transient-p input-stream))
337                      (progn
338                        (stream-clear-input input-stream)
339                        (abort-break))
340                      (exit-interactive-process *current-process*)))
341                  (progn
342                    (setq eof-count 0)
343                    (or (check-toplevel-command form)
344                        (let* ((values (toplevel-eval form env)))
345                          (if print-result (toplevel-print values)))))))))
346           (format *terminal-io* "~&Cancelled")))
347       (abort () :report (lambda (stream)
348                           (if (eq break-level 0)
349                             (format stream "Return to toplevel.")
350                             (format stream "Return to break level ~D." break-level)))
351              #|                        ; Handled by interactive-abort
352                                        ; go up one more if abort occurred while awaiting/reading input               
353              (when (and *in-read-loop* (neq break-level 0))
354              (abort))
355              |#
356               )
357        (abort-break () 
358                     (unless (eq break-level 0)
359                       (abort))))
360       (clear-input input-stream)
361      (format output-stream "~%"))))
362
363;;; The first non-whitespace character available on INPUT-STREAM is a colon.
364;;; Try to interpret the line as a colon command (or possibly just a keyword.)
365(defun read-command-or-keyword (input-stream eof-value)
366  (let* ((line (read-line input-stream nil eof-value)))
367    (if (eq line eof-value)
368      eof-value
369      (let* ((in (make-string-input-stream line))
370             (keyword (read in nil eof-value)))
371        (if (eq keyword eof-value)
372          eof-value
373          (if (not (keywordp keyword))
374            keyword
375            (collect ((params))
376              (loop
377                (let* ((param (read in nil eof-value)))
378                  (if (eq param eof-value)
379                    (return
380                      (let* ((params (params)))
381                        (if params
382                          (cons keyword params)
383                          keyword)))
384                    (params (eval param))))))))))))
385
386;;; Read a form from the specified stream.
387(defun toplevel-read (&key (input-stream *standard-input*)
388                           (output-stream *standard-output*)
389                           (prompt-function #'print-listener-prompt)
390                           (eof-value *eof-value*))
391  (force-output output-stream)
392  (funcall prompt-function output-stream)
393  (read-toplevel-form input-stream eof-value))
394
395(defvar *always-eval-user-defvars* nil)
396
397(defun process-single-selection (form)
398  (if (and *always-eval-user-defvars*
399           (listp form) (eq (car form) 'defvar) (cddr form))
400    `(defparameter ,@(cdr form))
401    form))
402
403(defun toplevel-eval (form &optional env)
404  (destructuring-bind (vars . vals) (or env '(nil . nil))
405    (progv vars vals
406      (setq +++ ++ ++ + + - - form)
407      (unwind-protect
408           (let* ((package *package*)
409                  (values (multiple-value-list (cheap-eval-in-environment form nil))))
410             (unless (eq package *package*)
411               ;; If changing a local value (e.g. buffer-local), not useful to notify app
412               ;; without more info.  Perhaps should have a *source-context* that can send along?
413               (unless (member '*package* vars)
414                 (application-ui-operation *application* :note-current-package *package*)))
415             values)
416        (loop for var in vars as pval on vals
417              do (setf (car pval) (symbol-value var)))))))
418
419
420(defun toplevel-print (values &optional (out *standard-output*))
421  (setq /// // // / / values)
422  (unless (eq (car values) (%unbound-marker))
423    (setq *** ** ** * *  (%car values)))
424  (when values
425    (fresh-line out)
426    (dolist (val values) (write val :stream out) (terpri out))))
427
428(defparameter *listener-prompt-format* "~[?~:;~:*~d >~] ")
429
430 
431(defun print-listener-prompt (stream &optional (force t))
432  (unless *quiet-flag*
433    (when (or force (neq *break-level* *last-break-level*))
434      (let* ((*listener-indent* nil))
435        (fresh-line stream)
436        (format stream *listener-prompt-format* *break-level*))
437      (setq *last-break-level* *break-level*)))
438    (force-output stream))
439
440
441;;; Fairly crude default error-handlingbehavior, and a fairly crude mechanism
442;;; for customizing it.
443
444(defvar *app-error-handler-mode* :quit
445  "one of :quit, :quit-quietly, :listener might be useful.")
446
447(defmethod application-error ((a application) condition error-pointer)
448  (case *app-error-handler-mode*
449    (:listener   (break-loop-handle-error condition error-pointer))
450    (:quit-quietly (quit -1))
451    (:quit  (format t "~&Fatal error in ~s : ~a"
452                    (pathname-name (car *command-line-argument-list*))
453                    condition)
454                    (quit -1))))
455
456(defun make-application-error-handler (app mode)
457  (declare (ignore app))
458  (setq *app-error-handler-mode* mode))
459
460
461; You may want to do this anyway even if your application
462; does not otherwise wish to be a "lisp-development-system"
463(defmethod application-error ((a lisp-development-system) condition error-pointer)
464  (break-loop-handle-error condition error-pointer))
465
466(defun abnormal-application-exit ()
467  (ignore-errors
468    (print-call-history)
469    (force-output *debug-io*)
470    (quit -1))
471  (#__exit -1))
472
473(defun break-loop-handle-error (condition error-pointer)
474  (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals)
475    (dolist (x bogus-globals)
476      (set x (funcall (pop newvals))))
477    (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
478      (let ((hook *debugger-hook*)
479            (*debugger-hook* nil))
480        (funcall hook condition hook)))
481    (%break-message "Error" condition error-pointer)
482    (let* ((s *error-output*))
483      (dolist (bogusness bogus-globals)
484        (let ((oldval (pop oldvals)))
485          (format s "~&;  NOTE: ~S was " bogusness)
486          (if (eq oldval (%unbound-marker-8))
487            (format s "unbound")
488            (format s "~s" oldval))
489          (format s ", was reset to ~s ." (symbol-value bogusness)))))
490    (if (and *break-on-errors* (not *batch-flag*))
491      (break-loop condition error-pointer)
492      (if *batch-flag*
493        (abnormal-application-exit)
494        (abort)))))
495
496(defun break (&optional string &rest args)
497  "Print a message and invoke the debugger without allowing any possibility
498   of condition handling occurring."
499  (if *batch-flag*
500    (apply #'error (or string "BREAK invoked in batch mode") args)
501    (apply #'%break-in-frame (%get-frame-ptr) string args)))
502
503(defun %break-in-frame (fp &optional string &rest args)
504  (flet ((do-break-loop ()
505           (let ((c (if (typep string 'condition)
506                      string
507                      (make-condition 'simple-condition
508                                    :format-control (or string "")
509                                    :format-arguments args))))
510             (cbreak-loop "Break" "Return from BREAK." c fp))))
511    (cond ((%i> *interrupt-level* -1)
512           (do-break-loop))
513          (*break-loop-when-uninterruptable*
514           (format *error-output* "Break while interrupt-level less than zero; binding to 0 during break-loop.")
515           (let ((interrupt-level (interrupt-level)))
516             (unwind-protect
517                  (progn
518                    (setf (interrupt-level) 0)
519                    (do-break-loop))
520               (setf (interrupt-level) interrupt-level))))
521          (t (format *error-output* "Break while interrupt-level less than zero; ignored.")))))
522
523
524(defun invoke-debugger (condition &aux (fp (%get-frame-ptr)))
525  "Enter the debugger."
526  (let ((c (require-type condition 'condition)))
527    (when *debugger-hook*
528      (let ((hook *debugger-hook*)
529            (*debugger-hook* nil))
530        (funcall hook c hook)))
531    (%break-message "Debug" c fp)
532    (break-loop c fp)))
533
534(defun %break-message (msg condition error-pointer &optional (prefixchar #\>))
535  (let ((*print-circle* *error-print-circle*)
536        ;(*print-prett*y nil)
537        (*print-array* nil)
538        (*print-escape* t)
539        (*print-gensym* t)
540        (*print-length* *error-print-length*)
541        (*print-level* *error-print-level*)
542        (*print-lines* nil)
543        (*print-miser-width* nil)
544        (*print-readably* nil)
545        (*print-right-margin* nil)
546        (*signal-printing-errors* nil)
547        (s (make-indenting-string-output-stream prefixchar nil)))
548    (format s "~A ~A: " prefixchar msg)
549    (setf (indenting-string-output-stream-indent s) (column s))
550    ;(format s "~A" condition) ; evil if circle
551    (report-condition condition s)
552    (if (not (and (typep condition 'simple-program-error)
553                  (simple-program-error-context condition)))
554      (format *error-output* "~&~A~%~A While executing: ~S"
555              (get-output-stream-string s) prefixchar (%real-err-fn-name error-pointer))
556      (format *error-output* "~&~A"
557              (get-output-stream-string s)))
558    (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*))
559  (force-output *error-output*)))
560                                        ; returns NIL
561
562(defvar *break-hook* nil)
563
564(defun cbreak-loop (msg cont-string condition error-pointer)
565  (let* ((*print-readably* nil)
566         (hook *break-hook*))
567    (restart-case (progn
568                    (when hook
569                      (let ((*break-hook* nil))
570                        (funcall hook condition hook))
571                      (setq hook nil))
572                    (%break-message msg condition error-pointer)
573                    (break-loop condition error-pointer))
574      (continue () :report (lambda (stream) (write-string cont-string stream))))
575    (unless hook
576      (fresh-line *error-output*))
577    nil))
578
579(defun warn (condition-or-format-string &rest args)
580  "Warn about a situation by signalling a condition formed by DATUM and
581   ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
582   exists that causes WARN to immediately return NIL."
583  (when (typep condition-or-format-string 'condition)
584    (unless (typep condition-or-format-string 'warning)
585      (report-bad-arg condition-or-format-string 'warning))
586    (when args
587      (error 'type-error :datum args :expected-type 'null
588             :format-control "Extra arguments in ~s.")))
589  (let ((fp (%get-frame-ptr))
590        (c (require-type (condition-arg condition-or-format-string args 'simple-warning) 'warning)))
591    (when *break-on-warnings*
592      (cbreak-loop "Warning" "Signal the warning." c fp))
593    (restart-case (signal c)
594      (muffle-warning () :report "Skip the warning" (return-from warn nil)))
595    (%break-message (if (typep c 'compiler-warning) "Compiler warning" "Warning") c fp #\;)
596    ))
597
598(declaim (notinline select-backtrace))
599
600(defmacro new-backtrace-info (dialog youngest oldest tcr condition current fake db-link level)
601  (let* ((cond (gensym)))
602  `(let* ((,cond ,condition))
603    (vector ,dialog ,youngest ,oldest ,tcr (cons nil (compute-restarts ,cond)) (%catch-top ,tcr) ,cond ,current ,fake ,db-link ,level))))
604
605(defun select-backtrace ()
606  (declare (notinline select-backtrace))
607  ;(require 'new-backtrace)
608  (require :inspector)
609  (select-backtrace))
610
611(defvar *break-condition* nil "condition argument to innermost break-loop.")
612(defvar *break-frame* nil "frame-pointer arg to break-loop")
613(defvar *break-loop-when-uninterruptable* t)
614(defvar *show-restarts-on-break* #+ccl-0711 t #-ccl-0711 nil)
615(defvar *show-available-restarts* nil)
616
617(defvar *error-reentry-count* 0)
618
619(defun funcall-with-error-reentry-detection (thunk)
620  (let* ((count *error-reentry-count*)
621         (*error-reentry-count* (1+ count)))
622    (cond ((eql count 0) (funcall thunk))
623          ((eql count 1) (error "Error reporting error"))
624          (t (bug "Error reporting error")))))
625
626
627
628
629(defvar %last-continue% nil)
630(defun break-loop (condition frame-pointer)
631  "Never returns"
632  (let* ((%handlers% (last %handlers%)) ; firewall
633         (*break-frame* frame-pointer)
634         (*break-condition* condition)
635         (*compiling-file* nil)
636         (*backquote-stack* nil)
637         (continue (find-restart 'continue))
638         (*continuablep* (unless (eq %last-continue% continue) continue))
639         (%last-continue% continue)
640         (*standard-input* *debug-io*)
641         (*standard-output* *debug-io*)
642         (*signal-printing-errors* nil)
643         (*read-suppress* nil)
644         (*print-readably* nil)
645         (*default-integer-command* `(:c 0 ,(1- (length (compute-restarts condition)))))
646         (context (new-backtrace-info nil
647                                      frame-pointer
648                                      (if *backtrace-contexts*
649                                        (or (child-frame
650                                             (bt.youngest (car *backtrace-contexts*))
651                                             nil)
652                                            (last-frame-ptr))
653                                        (last-frame-ptr))
654                                      (%current-tcr)
655                                      condition
656                                      (%current-frame-ptr)
657                                      #+ppc-target *fake-stack-frames*
658                                      #+x86-target (%current-frame-ptr)
659                                      (db-link)
660                                      (1+ *break-level*)))
661         (*backtrace-contexts* (cons context *backtrace-contexts*)))
662    (with-terminal-input
663      (with-toplevel-commands :break
664        (if *continuablep*
665          (let* ((*print-circle* *error-print-circle*)
666                 (*print-level* *error-print-level*)
667                 (*print-length* *error-print-length*)
668                                        ;(*print-pretty* nil)
669                 (*print-array* nil))
670            (format t (or (application-ui-operation *application* :break-options-string t)
671                          "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts."))
672            (format t "~&> If continued: ~A~%" continue))
673          (format t (or (application-ui-operation *application* :break-options-string nil)
674                        "~&> Type :POP to abort, :R for a list of available restarts.~%")))
675        (format t "~&> Type :? for other options.")
676        (terpri)
677        (force-output)
678
679        (clear-input *debug-io*)
680        (setq *error-reentry-count* 0)  ; succesfully reported error
681        (ignoring-without-interrupts
682          (unwind-protect
683               (progn
684                 (application-ui-operation *application*
685                                           :enter-backtrace-context context)
686                 (read-loop :break-level (1+ *break-level*)
687                            :input-stream *debug-io*
688                            :output-stream *debug-io*))
689            (application-ui-operation *application* :exit-backtrace-context
690                                      context)))))))
691
692
693
694(defun display-restarts (&optional (condition *break-condition*))
695  (loop
696    for restart in (compute-restarts condition)
697    for count upfrom 0
698    do (format *debug-io* "~&~D. ~A" count restart)
699    finally (fresh-line *debug-io*)))
700
701(defun select-restart (n &optional (condition *break-condition*))
702  (let* ((restarts (compute-restarts condition)))
703    (invoke-restart-interactively
704     (nth (require-type n `(integer 0 (,(length restarts)))) restarts))))
705
706
707
708
709; End of l1-readloop-lds.lisp
Note: See TracBrowser for help on using the repository browser.