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

Last change on this file since 7788 was 7788, checked in by gb, 14 years ago

Port batch-quit stuff from working-0710 branch.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.0 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(define-toplevel-command :break pop () "exit current break loop" (abort-break))
94(define-toplevel-command :break go () "continue" (continue))
95(define-toplevel-command :break q () "return to toplevel" (toplevel))
96(define-toplevel-command :break r () "list restarts"
97  (format t "~&   (:C <n>) can be used to invoke one of the following restarts in this break loop:")
98  (let* ((r (apply #'vector (compute-restarts *break-condition*))))
99    (dotimes (i (length r) (terpri))
100      (format *debug-io* "~&~d. ~a" i (svref r i)))))
101
102;;; From Marco Baringer 2003/03/18
103
104(define-toplevel-command :break set (n frame value) "Set <n>th item of frame <frame> to <value>"
105  (let* ((frame-sp (nth-raw-frame frame *break-frame* nil)))
106    (if frame-sp
107        (toplevel-print (list (set-nth-value-in-frame frame-sp n nil value)))
108        (format *debug-io* "No frame with number ~D~%" frame))))
109
110(define-toplevel-command :break nframes ()
111                         "print the number of stack frames accessible from this break loop"
112                         (do* ((p *break-frame* (parent-frame p nil))
113                               (i 0 (1+ i))
114                               (last (last-frame-ptr)))
115                              ((eql p last) (toplevel-print (list i)))))
116
117(define-toplevel-command :global ? () "help"
118  (dolist (g *active-toplevel-commands*)
119    (dolist (c (cdr g))
120      (let* ((command (car c))
121             (doc (caddr c))
122             (args (cdddr c)))
123        (if args
124          (format t "~& (~S~{ ~A~}) ~8T~A" command args doc)
125          (format t "~& ~S  ~8T~A" command doc))))))
126
127
128(define-toplevel-command :break b (&key start count show-frame-contents) "backtrace"
129  (when *break-frame*
130      (print-call-history :detailed-p show-frame-contents
131                          :origin *break-frame*
132                          :count count
133                          :start-frame-number (or start 0))))
134
135(define-toplevel-command :break c (n) "Choose restart <n>"
136   (select-restart n))
137
138(define-toplevel-command :break f (n) "Show backtrace frame <n>"
139   (print-call-history :origin *break-frame*
140                       :start-frame-number n
141                       :count 1
142                       :detailed-p t))
143
144(define-toplevel-command :break raw (n) "Show raw contents of backtrace frame <n>"
145   (print-call-history :origin *break-frame*
146                       :start-frame-number n
147                       :count 1
148                       :detailed-p :raw))
149
150(define-toplevel-command :break v (n frame-number) "Return value <n> in frame <frame-number>"
151  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
152    (if frame-sp
153      (toplevel-print (list (nth-value-in-frame frame-sp n nil))))))
154
155(define-toplevel-command :break arg (name frame-number) "Return value of argument named <name> in frame <frame-number>"
156  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
157    (when frame-sp
158      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
159        (when (and lfun pc)
160          (let* ((unavailable (cons nil nil)))
161            (declare (dynamic-extent unavailable))
162            (let* ((value (arg-value nil frame-sp lfun pc unavailable name)))
163              (if (eq value unavailable)
164                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
165                (toplevel-print (list value))))))))))
166
167(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named <name> in frame <frame-number> to value <new>."
168  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
169    (when frame-sp
170      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
171        (when (and lfun pc)
172          (or (set-arg-value nil frame-sp lfun pc name new)
173              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
174   
175
176(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
177binding of that symbol is used - or an integer index into the frame's set of local bindings."
178  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
179    (when frame-sp
180      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
181        (when (and lfun pc)
182          (let* ((unavailable (cons nil nil)))
183            (declare (dynamic-extent unavailable))
184            (let* ((value (local-value nil frame-sp lfun pc unavailable name)))
185              (if (eq value unavailable)
186                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
187                (toplevel-print (list value))))))))))
188
189(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>."
190  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil)))
191    (when frame-sp
192      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
193        (when (and lfun pc)
194          (or (set-local-value nil frame-sp lfun pc name new)
195              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
196
197
198(define-toplevel-command :break form (frame-number)
199   "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."
200   (let* ((form (dbg-form frame-number)))
201     (when form
202       (let* ((*print-level* *backtrace-print-level*)
203              (*print-length* *backtrace-print-length*))
204         (toplevel-print (list form))))))
205
206;;; Ordinarily, form follows function.
207(define-toplevel-command :break function (frame-number)
208  "Returns the function invoked in backtrace frame <frame-number>.  This may be useful for, e.g., disassembly"
209  (let* ((cfp (nth-raw-frame frame-number *break-frame* nil)))
210    (when (and cfp (not (catch-csp-p cfp nil)))
211      (let* ((function (cfp-lfun cfp)))
212        (when function
213          (toplevel-print (list function)))))))
214 
215
216
217         
218
219 
220
221(defun %use-toplevel-commands (group-name)
222  ;; Push the whole group
223  (pushnew (assoc group-name *defined-toplevel-commands*)
224           *active-toplevel-commands*
225           :key #'(lambda (x) (car x))))  ; #'car not defined yet ...
226
227(%use-toplevel-commands :global)
228
229(defun check-toplevel-command (form)
230  (let* ((cmd (if (consp form) (car form) form))
231         (args (if (consp form) (cdr form))))
232    (if (keywordp cmd)
233      (dolist (g *active-toplevel-commands*)
234        (when
235            (let* ((pair (assoc cmd (cdr g))))
236              (if pair 
237                (progn (apply (cadr pair) args)
238                       t)))
239          (return t))))))
240
241(defparameter *quit-on-eof* nil)
242
243;;; This is the part common to toplevel loop and inner break loops.
244(defun read-loop (&key (input-stream *standard-input*)
245                       (output-stream *standard-output*)
246                       (break-level *break-level*)
247                       (prompt-function #'(lambda (stream) (print-listener-prompt stream t))))
248  (let* ((*break-level* break-level)
249         (*last-break-level* break-level)
250         *loading-file-source-file*
251         *in-read-loop*
252         *** ** * +++ ++ + /// // / -
253         (eof-value (cons nil nil)))
254    (declare (dynamic-extent eof-value))
255    (loop
256      (restart-case
257       (catch :abort                    ;last resort...
258         (loop
259           (catch-cancel
260            (loop               
261              (setq *in-read-loop* nil
262                    *break-level* break-level)
263              (multiple-value-bind (form path print-result)
264                  (toplevel-read :input-stream input-stream
265                                 :output-stream output-stream
266                                 :prompt-function prompt-function
267                                 :eof-value eof-value)
268                (if (eq form eof-value)
269                  (if (and (not *batch-flag*)
270                           (not *quit-on-eof*)
271                           (eof-transient-p (stream-device input-stream :input)))
272                    (progn
273                      (stream-clear-input input-stream)
274                      (abort-break))
275                    (exit-interactive-process *current-process*))
276                    (or (check-toplevel-command form)
277                        (let* ((values (toplevel-eval form path)))
278                          (if print-result (toplevel-print values))))))))
279           (format *terminal-io* "~&Cancelled")))
280       (abort () :report (lambda (stream)
281                           (if (eq break-level 0)
282                             (format stream "Return to toplevel.")
283                             (format stream "Return to break level ~D." break-level)))
284              #|                        ; Handled by interactive-abort
285                                        ; go up one more if abort occurred while awaiting/reading input               
286              (when (and *in-read-loop* (neq break-level 0))
287              (abort))
288              |#
289               )
290        (abort-break () 
291                     (unless (eq break-level 0)
292                       (abort))))
293       (clear-input input-stream)
294      (format output-stream "~%"))))
295
296;;; The first non-whitespace character available on INPUT-STREAM is a colon.
297;;; Try to interpret the line as a colon command (or possibly just a keyword.)
298(defun read-command-or-keyword (input-stream eof-value)
299  (let* ((line (read-line input-stream nil eof-value)))
300    (if (eq line eof-value)
301      eof-value
302      (let* ((in (make-string-input-stream line))
303             (keyword (read in nil eof-value)))
304        (if (eq keyword eof-value)
305          eof-value
306          (if (not (keywordp keyword))
307            keyword
308            (collect ((params))
309              (loop
310                (let* ((param (read in nil eof-value)))
311                  (if (eq param eof-value)
312                    (return
313                      (let* ((params (params)))
314                        (if params
315                          (cons keyword params)
316                          keyword)))
317                    (params (eval param))))))))))))
318
319;;; Read a form from the specified stream.
320(defun toplevel-read (&key (input-stream *standard-input*)
321                           (output-stream *standard-output*)
322                           (prompt-function #'print-listener-prompt)
323                           (eof-value *eof-value*))
324  (force-output output-stream)
325  (funcall prompt-function output-stream)
326  (read-toplevel-form input-stream eof-value))
327
328(defvar *always-eval-user-defvars* nil)
329
330(defun process-single-selection (form)
331  (if (and *always-eval-user-defvars*
332           (listp form) (eq (car form) 'defvar) (cddr form))
333    `(defparameter ,@(cdr form))
334    form))
335
336(defun toplevel-eval (form &optional *loading-file-source-file*)
337  (setq +++ ++ ++ + + - - form)
338  (let* ((package *package*)
339         (values (multiple-value-list (cheap-eval-in-environment form nil))))
340    (unless (eq package *package*)
341      (application-ui-operation *application* :note-current-package *package*))
342    values))
343
344(defun toplevel-print (values &optional (out *standard-output*))
345  (setq /// // // / / values)
346  (unless (eq (car values) (%unbound-marker))
347    (setq *** ** ** * *  (%car values)))
348  (when values
349    (fresh-line out)
350    (dolist (val values) (write val :stream out) (terpri out))))
351
352(defun print-listener-prompt (stream &optional (force t))
353  (unless *quiet-flag*
354    (when (or force (neq *break-level* *last-break-level*))
355      (let* ((*listener-indent* nil))
356        (fresh-line stream)           
357        (if (%izerop *break-level*)
358          (%write-string "?" stream)
359          (format stream "~s >" *break-level*)))       
360      (write-string " " stream)       
361      (setq *last-break-level* *break-level*)))
362    (force-output stream))
363
364
365;;; Fairly crude default error-handlingbehavior, and a fairly crude mechanism
366;;; for customizing it.
367
368(defvar *app-error-handler-mode* :quit
369  "one of :quit, :quit-quietly, :listener might be useful.")
370
371(defmethod application-error ((a application) condition error-pointer)
372  (case *app-error-handler-mode*
373    (:listener   (break-loop-handle-error condition error-pointer))
374    (:quit-quietly (quit -1))
375    (:quit  (format t "~&Fatal error in ~s : ~a"
376                    (pathname-name (car *command-line-argument-list*))
377                    condition)
378                    (quit -1))))
379
380(defun make-application-error-handler (app mode)
381  (declare (ignore app))
382  (setq *app-error-handler-mode* mode))
383
384
385; You may want to do this anyway even if your application
386; does not otherwise wish to be a "lisp-development-system"
387(defmethod application-error ((a lisp-development-system) condition error-pointer)
388  (break-loop-handle-error condition error-pointer))
389
390(defun abnormal-application-exit ()
391  (print-call-history)
392  (quit -1))
393
394(defun break-loop-handle-error (condition error-pointer)
395  (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals)
396    (dolist (x bogus-globals)
397      (set x (funcall (pop newvals))))
398    (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
399      (let ((hook *debugger-hook*)
400            (*debugger-hook* nil))
401        (funcall hook condition hook)))
402    (%break-message "Error" condition error-pointer)
403    (let* ((s *error-output*))
404      (dolist (bogusness bogus-globals)
405        (let ((oldval (pop oldvals)))
406          (format s "~&;  NOTE: ~S was " bogusness)
407          (if (eq oldval (%unbound-marker-8))
408            (format s "unbound")
409            (format s "~s" oldval))
410          (format s ", was reset to ~s ." (symbol-value bogusness)))))
411    (if (and *break-on-errors* (not *batch-flag*))
412      (with-terminal-input
413          (break-loop condition error-pointer))
414      (if *batch-flag*
415        (abnormal-application-exit)
416        (abort)))))
417
418(defun break (&optional string &rest args)
419  "Print a message and invoke the debugger without allowing any possibility
420   of condition handling occurring."
421  (if *batch-flag*
422    (apply #'error string args)
423    (apply #'%break-in-frame (%get-frame-ptr) string args)))
424
425(defun %break-in-frame (fp &optional string &rest args)
426  (flet ((do-break-loop ()
427           (let ((c (if (typep string 'condition)
428                      string
429                      (make-condition 'simple-condition
430                                    :format-control (or string "")
431                                    :format-arguments args))))
432             (cbreak-loop "Break" "Return from BREAK." c fp))))
433    (cond ((%i> *interrupt-level* -1)
434           (do-break-loop))
435          (*break-loop-when-uninterruptable*
436           (format *error-output* "Break while interrupt-level less than zero; binding to 0 during break-loop.")
437           (let ((interrupt-level (interrupt-level)))
438             (unwind-protect
439                  (progn
440                    (setf (interrupt-level) 0)
441                    (do-break-loop))
442               (setf (interrupt-level) interrupt-level))))
443          (t (format *error-output* "Break while interrupt-level less than zero; ignored.")))))
444
445
446(defun invoke-debugger (condition &aux (fp (%get-frame-ptr)))
447  "Enter the debugger."
448  (let ((c (require-type condition 'condition)))
449    (when *debugger-hook*
450      (let ((hook *debugger-hook*)
451            (*debugger-hook* nil))
452        (funcall hook c hook)))
453    (%break-message "Debug" c fp)
454    (with-terminal-input
455        (break-loop c fp))))
456
457(defun %break-message (msg condition error-pointer &optional (prefixchar #\>))
458  (let ((*print-circle* *error-print-circle*)
459        ;(*print-prett*y nil)
460        (*print-array* nil)
461        (*print-escape* t)
462        (*print-gensym* t)
463        (*print-length* *backtrace-print-length*)  ; ?
464        (*print-level* *backtrace-print-level*)   ; ?
465        (*print-lines* nil)
466        (*print-miser-width* nil)
467        (*print-readably* nil)
468        (*print-right-margin* nil)
469        (*signal-printing-errors* nil)
470        (s (make-indenting-string-output-stream prefixchar nil)))
471    (format s "~A ~A: " prefixchar msg)
472    (setf (indenting-string-output-stream-indent s) (column s))
473    ;(format s "~A" condition) ; evil if circle
474    (report-condition condition s)
475    (if (not (and (typep condition 'simple-program-error)
476                  (simple-program-error-context condition)))
477      (format *error-output* "~&~A~%~A While executing: ~S"
478              (get-output-stream-string s) prefixchar (%real-err-fn-name error-pointer))
479      (format *error-output* "~&~A"
480              (get-output-stream-string s)))
481    (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*))
482  (force-output *error-output*)))
483                                        ; returns NIL
484
485(defun cbreak-loop (msg cont-string condition error-pointer)
486  (let* ((*print-readably* nil))
487    (%break-message msg condition error-pointer)
488    (with-terminal-input
489      (restart-case (break-loop condition error-pointer)
490                    (continue () :report (lambda (stream) (write-string cont-string stream))))
491      (fresh-line *error-output*)
492      nil)))
493
494(defun warn (condition-or-format-string &rest args)
495  "Warn about a situation by signalling a condition formed by DATUM and
496   ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
497   exists that causes WARN to immediately return NIL."
498  (when (typep condition-or-format-string 'condition)
499    (unless (typep condition-or-format-string 'warning)
500      (report-bad-arg condition-or-format-string 'warning))
501    (when args
502      (error 'type-error :datum args :expected-type 'null
503             :format-control "Extra arguments in ~s.")))
504  (let ((fp (%get-frame-ptr))
505        (c (require-type (condition-arg condition-or-format-string args 'simple-warning) 'warning)))
506    (when *break-on-warnings*
507      (cbreak-loop "Warning" "Signal the warning." c fp))
508    (restart-case (signal c)
509      (muffle-warning () :report "Skip the warning" (return-from warn nil)))
510    (%break-message (if (typep c 'compiler-warning) "Compiler warning" "Warning") c fp #\;)
511    ))
512
513(declaim (notinline select-backtrace))
514
515(defmacro new-backtrace-info (dialog youngest oldest tcr condition current fake db-link level)
516  (let* ((cond (gensym)))
517  `(let* ((,cond ,condition))
518    (vector ,dialog ,youngest ,oldest ,tcr (cons nil (compute-restarts ,cond)) (%catch-top ,tcr) ,cond ,current ,fake ,db-link ,level))))
519
520(defun select-backtrace ()
521  (declare (notinline select-backtrace))
522  ;(require 'new-backtrace)
523  (require :inspector)
524  (select-backtrace))
525
526(defvar *break-condition* nil "condition argument to innermost break-loop.")
527(defvar *break-frame* nil "frame-pointer arg to break-loop")
528(defvar *break-loop-when-uninterruptable* t)
529
530(defvar *error-reentry-count* 0)
531
532(defun funcall-with-error-reentry-detection (thunk)
533  (let* ((count *error-reentry-count*)
534         (*error-reentry-count* (1+ count)))
535    (cond ((eql count 0) (funcall thunk))
536          ((eql count 1) (error "Error reporting error"))
537          (t (bug "Error reporting error")))))
538
539
540
541
542(defvar %last-continue% nil)
543(defun break-loop (condition frame-pointer)
544  "Never returns"
545  (let* ((%handlers% (last %handlers%)) ; firewall
546         (*break-frame* frame-pointer)
547         (*break-condition* condition)
548         (*compiling-file* nil)
549         (*backquote-stack* nil)
550         (continue (find-restart 'continue))
551         (*continuablep* (unless (eq %last-continue% continue) continue))
552         (%last-continue% continue)
553         (*standard-input* *debug-io*)
554         (*standard-output* *debug-io*)
555         (*signal-printing-errors* nil)
556         (*read-suppress* nil)
557         (*print-readably* nil))
558    (let* ((context (new-backtrace-info nil
559                                        frame-pointer
560                                        (if *backtrace-contexts*
561                                          (or (child-frame
562                                               (bt.youngest (car *backtrace-contexts*))
563                                               nil)
564                                              (last-frame-ptr))
565                                          (last-frame-ptr))
566                                        (%current-tcr)
567                                        condition
568                                        (%current-frame-ptr)
569                                        #+ppc-target *fake-stack-frames*
570                                        #+x86-target (%current-frame-ptr)
571                                        (db-link)
572                                        (1+ *break-level*)))
573           (*backtrace-contexts* (cons context *backtrace-contexts*)))
574      (with-toplevel-commands :break
575        (if *continuablep*
576          (let* ((*print-circle* *error-print-circle*)
577                 (*print-level* *backtrace-print-level*)
578                 (*print-length* *backtrace-print-length*)
579                                        ;(*print-pretty* nil)
580                 (*print-array* nil))
581            (format t "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.")
582            (format t "~&> If continued: ~A~%" continue))
583          (format t "~&> Type :POP to abort, :R for a list of available restarts.~%"))
584        (format t "~&> Type :? for other options.")
585        (terpri)
586        (force-output)
587
588        (clear-input *debug-io*)
589        (setq *error-reentry-count* 0)  ; succesfully reported error
590        (ignoring-without-interrupts
591         (unwind-protect
592              (progn
593                (application-ui-operation *application*
594                                          :enter-backtrace-context context)
595                  (read-loop :break-level (1+ *break-level*)
596                             :input-stream *debug-io*
597                             :output-stream *debug-io*))
598           (application-ui-operation *application* :exit-backtrace-context
599                                     context)))))))
600
601
602
603(defun display-restarts (&optional (condition *break-condition*))
604  (let ((i 0))
605    (format t "~&[Pretend that these are buttons.]")
606    (dolist (r (compute-restarts condition) i)
607      (format t "~&~a : ~A" i r)
608      (setq i (%i+ i 1)))
609    (fresh-line nil)))
610
611(defun select-restart (n &optional (condition *break-condition*))
612  (let* ((restarts (compute-restarts condition)))
613    (invoke-restart-interactively
614     (nth (require-type n `(integer 0 (,(length restarts)))) restarts))))
615
616
617
618
619; End of l1-readloop-lds.lisp
Note: See TracBrowser for help on using the repository browser.