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

Last change on this file since 480 was 480, checked in by gb, 16 years ago

Tweaks to the :Y command, to handle new shared-resource scheme.
Marco Baringer's :SET breakloop command, from almost a year ago.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.7 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(defun toplevel-loop ()
22  (loop
23    (if (eq (catch :toplevel 
24              (read-loop :break-level 0)) $xstkover)
25      (format t "~&;[Stacks reset due to overflow.]")
26      (when (eq *current-process* *initial-process*)
27        (toplevel)))))
28
29
30(defvar *defined-toplevel-commands* ())
31(defvar *active-toplevel-commands* ())
32
33(defun %define-toplevel-command (group-name key name fn doc args)
34  (let* ((group (or (assoc group-name *defined-toplevel-commands*)
35                    (car (push (list group-name)
36                               *defined-toplevel-commands*))))
37         (pair (assoc key (cdr group) :test #'eq)))
38    (if pair
39      (rplacd pair (list* fn doc args))
40      (push (cons key (list* fn doc args)) (cdr group))))
41  name)
42
43(define-toplevel-command 
44    :global y (&optional p) "Yield control of terminal-input to process
45whose name or ID matches <p>, or to any process if <p> is null"
46    (if p
47      (let* ((proc (find-process p)))
48        (%%yield-terminal-to proc)      ;may be nil
49        (%%yield-terminal-to nil))))
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 p
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 :break pop () "exit current break loop" (abort-break))
88(define-toplevel-command :break go () "continue" (continue))
89(define-toplevel-command :break q () "return to toplevel" (toplevel))
90(define-toplevel-command :break r () "list restarts"
91  (let* ((r (apply #'vector (compute-restarts *break-condition*))))
92    (dotimes (i (length r) (terpri))
93      (format t "~&~d. ~a" i (svref r i)))))
94
95;;; From Marco Baringer 2003/03/18
96(define-toplevel-command :break set (n frame value) "Set <n>th item of frame <frame> to <value>"
97  (let* ((frame-sp (nth-raw-frame frame *break-frame* (%current-tcr))))
98    (if frame-sp
99        (toplevel-print (list (set-nth-value-in-frame frame-sp n (%current-tcr) value)))
100        (format *debug-io* "No frame with number ~D~%" frame))))
101
102(define-toplevel-command :global ? () "help"
103  (dolist (g *active-toplevel-commands*)
104    (dolist (c (cdr g))
105      (let* ((command (car c))
106             (doc (caddr c))
107             (args (cdddr c)))
108        (if args
109          (format t "~& (~S~{ ~A~}) ~8T~A" command args doc)
110          (format t "~& ~S  ~8T~A" command doc))))))
111
112
113(define-toplevel-command :break b (&optional show-frame-contents) "backtrace"
114  (when *break-frame*
115    (print-call-history :detailed-p show-frame-contents
116                        :start-frame *break-frame*)))
117
118(define-toplevel-command :break c (n) "Choose restart <n>"
119   (select-restart n))
120
121(define-toplevel-command :break f (n) "Show backtrace frame <n>"
122   (print-call-history :start-frame *break-frame*
123                       :detailed-p n))
124
125(define-toplevel-command :break v (n frame-number) "Return value <n> in frame <frame-number>"
126  (let* ((frame-sp (nth-raw-frame frame-number *break-frame* (%current-tcr))))
127    (if frame-sp
128      (toplevel-print (list (nth-value-in-frame frame-sp n (%current-tcr)))))))
129
130(defun %use-toplevel-commands (group-name)
131  ;; Push the whole group
132  (pushnew (assoc group-name *defined-toplevel-commands*)
133           *active-toplevel-commands*
134           :key #'(lambda (x) (car x))))  ; #'car not defined yet ...
135
136(%use-toplevel-commands :global)
137
138(defun check-toplevel-command (form)
139  (let* ((cmd (if (consp form) (car form) form))
140         (args (if (consp form) (cdr form))))
141    (if (keywordp cmd)
142      (dolist (g *active-toplevel-commands*)
143        (when
144            (let* ((pair (assoc cmd (cdr g))))
145              (if pair 
146                (progn (apply (cadr pair) args)
147                       t)))
148          (return t))))))
149
150;This is the part common to toplevel loop and inner break loops.
151(defun read-loop (&key (break-level *break-level*)
152                       (prompt-function #'(lambda () (print-listener-prompt t)))
153                       (input-stream *terminal-io*)
154                       (output-stream *terminal-io*))
155  (let* ((*break-level* break-level)
156         (*last-break-level* break-level)
157         *loading-file-source-file*
158         *in-read-loop*
159         (*listener-p* t)
160         *** ** * +++ ++ + /// // / -
161         form)
162    (loop
163      (restart-case
164        (catch :abort ;last resort...
165          (loop
166            (catch-cancel
167              (loop               
168                (setq *loading-file-source-file* nil
169                      *in-read-loop* nil
170                      *break-level* break-level)
171                (setq form (toplevel-read :input-stream input-stream
172                                          :output-stream output-stream
173                                          :prompt-function prompt-function))
174                (if (eq form *eof-value*)
175                  (if (eof-transient-p (stream-device input-stream :input))
176                    (progn
177                      (stream-clear-input *terminal-io*)
178                      (abort-break))
179                    (quit))
180                  (or (check-toplevel-command form)
181                      (toplevel-print
182                       (toplevel-eval form))))))
183            (format *terminal-io* "~&Cancelled")))
184        (abort () :report (lambda (stream)
185                            (if (eq break-level 0)
186                              (format stream "Return to toplevel.")
187                              (format stream "Return to break level ~D." break-level)))
188               #| ; Handled by interactive-abort
189                ; go up one more if abort occurred while awaiting/reading input               
190                (when (and *in-read-loop* (neq break-level 0))
191                  (abort))
192                |#
193               )
194        (abort-break () 
195                     (unless (eq break-level 0)
196                       (abort))))
197      (clear-input *terminal-io*)
198      (format *terminal-io* "~%"))))
199
200;Read a form from *terminal-io*.
201(defun toplevel-read (&key (input-stream *standard-input*)
202                           (output-stream *standard-output*)
203                           (prompt-function #'print-listener-prompt))
204  (let* ((listener input-stream))
205    (force-output output-stream)
206    (funcall prompt-function)
207    (loop
208        (let* ((*in-read-loop* nil)  ;So can abort out of buggy reader macros...
209               (form))
210          (catch '%re-read           
211            (if (eq (setq form (read listener nil *eof-value*)) *eof-value*)
212              (return form)
213              (progn
214                (let ((ch)) ;Trim whitespace
215                  (while (and (listen listener)
216                              (setq ch (read-char listener nil nil))
217                              (whitespacep cH))
218                    (setq ch nil))
219                  (when ch (unread-char ch listener)))
220                (when *listener-indent* 
221                  (write-char #\space listener)
222                  (write-char #\space listener))
223                (return (process-single-selection form)))))))))
224
225(defvar *always-eval-user-defvars* nil)
226
227(defun process-single-selection (form)
228  (if (and *always-eval-user-defvars*
229           (listp form) (eq (car form) 'defvar) (cddr form))
230    `(defparameter ,@(cdr form))
231    form))
232
233(defun toplevel-eval (form &optional env &aux values)
234   (declare (resident))
235  (setq +++ ++ ++ + + - - form)
236  (setq values (multiple-value-list (cheap-eval-in-environment form env)))
237  values)
238
239(defun toplevel-print (values)
240  (declare (resident))
241  (setq /// // // / / values)
242  (setq *** ** ** * * (if (neq (%car values) (%unbound-marker-8)) (%car values)))
243  (when values
244    (fresh-line)
245    (dolist (val values) (write val) (terpri))))
246
247(defun print-listener-prompt (&optional (force t))
248  (when (or force (neq *break-level* *last-break-level*))
249    (let* ((*listener-indent* nil))
250      (fresh-line *terminal-io*)           
251      (if (%izerop *break-level*)
252        (%write-string "?" *terminal-io*)
253        (format *terminal-io* "~s >" *break-level*)))       
254    (write-string " " *terminal-io*)       
255    (setq *last-break-level* *break-level*))
256      (force-output *terminal-io*))
257
258
259;;; Fairly crude default error-handlingbehavior, and a fairly crude mechanism
260;;; for customizing it.
261
262(defvar *app-error-handler-mode* :quit
263  "one of :quit, :quit-quietly, :listener might be useful.")
264
265(defmethod application-error ((a application) condition error-pointer)
266  (case *app-error-handler-mode*
267    (:listener   (break-loop-handle-error condition error-pointer))
268    (:quit-quietly (quit -1))
269    (:quit  (format t "~&Fatal error in ~s : ~a"
270                    (pathname-name (car *command-line-argument-list*))
271                    condition)
272                    (quit -1))))
273
274(defun make-application-error-handler (app mode)
275  (declare (ignore app))
276  (setq *app-error-handler-mode* mode))
277
278
279; You may want to do this anyway even if your application
280; does not otherwise wish to be a "lisp-development-system"
281(defmethod application-error ((a lisp-development-system) condition error-pointer)
282  (break-loop-handle-error condition error-pointer))
283
284(defun break-loop-handle-error (condition error-pointer)
285  (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals)
286    (dolist (x bogus-globals)
287      (set x (funcall (pop newvals))))
288    (when (and *debugger-hook* *break-on-errors*)
289      (let ((hook *debugger-hook*)
290            (*debugger-hook* nil))
291        (funcall hook condition hook)))
292    (%break-message (error-header "Error") condition error-pointer)
293    (with-terminal-input
294      (let* ((s *error-output*))
295        (dolist (bogusness bogus-globals)
296          (let ((oldval (pop oldvals)))
297            (format s "~&;  NOTE: ~S was " bogusness)
298            (if (eq oldval (%unbound-marker-8))
299              (format s "unbound")
300              (format s "~s" oldval))
301            (format s ", was reset to ~s ." (symbol-value bogusness)))))
302      (if *break-on-errors*
303        (break-loop condition error-pointer)
304        (abort)))))
305
306(defun break (&optional string &rest args &aux (fp (%get-frame-ptr)))
307  (flet ((do-break-loop ()
308           (let ((c (make-condition 'simple-condition
309                                    :format-control (or string "")
310                                    :format-arguments args)))
311             (cbreak-loop (error-header "Break") "Return from BREAK." c fp))))
312    (cond ((%i> (interrupt-level) -1)
313           (do-break-loop))
314          (*break-loop-when-uninterruptable*
315           (format *error-output* "Break while interrupt-level less than zero; binding to 0 during break-loop.")
316           (let ((interrupt-level (interrupt-level)))
317             (unwind-protect
318                  (progn
319                    (setf (interrupt-level) 0)
320                    (do-break-loop))
321               (setf (interrupt-level) interrupt-level))))
322          (t (format *error-output* "Break while interrupt-level less than zero; ignored.")))))
323
324(defun invoke-debugger (condition &aux (fp (%get-frame-ptr)))
325  (let ((c (require-type condition 'condition)))
326    (when *debugger-hook*
327      (let ((hook *debugger-hook*)
328            (*debugger-hook* nil))
329        (funcall hook c hook)))
330    (%break-message "Debug" c fp)
331    (with-terminal-input
332        (break-loop c fp))))
333
334(defun %break-message (msg condition error-pointer &optional (prefixchar #\>))
335  (let ((*print-circle* *error-print-circle*)
336        ;(*print-prett*y nil)
337        (*print-array* nil)
338        (*print-escape* t)
339        (*print-gensym* t)
340        (*print-length* nil)  ; ?
341        (*print-level* nil)   ; ?
342        (*print-lines* nil)
343        (*print-miser-width* nil)
344        (*print-readably* nil)
345        (*print-right-margin* nil)
346        (*signal-printing-errors* nil)
347        (s (make-indenting-string-output-stream prefixchar nil)))
348    (format s "~A ~A: " prefixchar msg)
349    (setf (indenting-string-output-stream-indent s) (column s))
350    ;(format s "~A" condition) ; evil if circle
351    (report-condition condition s)
352    (if (not (and (typep condition 'simple-program-error)
353                  (simple-program-error-context condition)))
354      (format *error-output* "~&~A~%~A While executing: ~S~%"
355              (get-output-stream-string s) prefixchar (%real-err-fn-name error-pointer))
356      (format *error-output* "~&~A~%"
357              (get-output-stream-string s)))
358  (force-output *error-output*)))
359                                        ; returns NIL
360
361(defun cbreak-loop (msg cont-string condition error-pointer)
362  (let* ((*print-readably* nil))
363    (%break-message msg condition error-pointer)
364    (with-terminal-input
365      (restart-case (break-loop condition error-pointer *backtrace-on-break*)
366                    (continue () :report (lambda (stream) (write-string cont-string stream))))
367      (fresh-line *error-output*)
368      nil)))
369
370(defun warn (condition-or-format-string &rest args)
371  (when (typep condition-or-format-string 'condition)
372    (unless (typep condition-or-format-string 'warning)
373      (report-bad-arg condition-or-format-string 'warning))
374    (when args
375      (error 'type-error :datum args :expected-type 'null
376             :format-control "Extra arguments in ~s.")))
377  (let ((fp (%get-frame-ptr))
378        (c (require-type (condition-arg condition-or-format-string args 'simple-warning) 'warning)))
379    (when *break-on-warnings*
380      (cbreak-loop "Warning" "Signal the warning." c fp))
381    (restart-case (signal c)
382      (muffle-warning () :report "Skip the warning" (return-from warn nil)))
383    (%break-message (if (typep c 'compiler-warning) "Compiler warning" "Warning") c fp #\;)
384    ))
385
386(declaim (notinline select-backtrace))
387
388(defmacro new-backtrace-info (dialog youngest oldest tcr)
389  `(vector ,dialog ,youngest ,oldest ,tcr nil))
390
391(defun select-backtrace ()
392  (declare (notinline select-backtrace))
393  (require 'new-backtrace)
394  (require :inspector)
395  (select-backtrace))
396
397(defvar *break-condition* nil "condition argument to innermost break-loop.")
398(defvar *break-frame* nil "frame-pointer arg to break-loop")
399(defvar *break-loop-when-uninterruptable* t)
400
401
402
403
404
405(defvar %last-continue% nil)
406(defun break-loop (condition frame-pointer
407                             &optional (backtracep *backtrace-on-break*))
408  "Never returns"
409  (when (and (%i< (interrupt-level) 0) (not *break-loop-when-uninterruptable*))
410    (abort))
411  (let* ((%handlers% (last %handlers%))         ; firewall
412         (*break-frame* frame-pointer)
413         (*break-condition* condition)
414         (*compiling-file* nil)
415         (*backquote-stack* nil)
416         (continue (find-restart 'continue))
417         (*continuablep* (unless (eq %last-continue% continue) continue))
418         (%last-continue% continue)
419         (*standard-input* *debug-io*)
420         (*standard-output* *debug-io*)
421         (level (interrupt-level))
422         (*signal-printing-errors* nil)
423         (*read-suppress* nil)
424         (*print-readably* nil))
425    (unwind-protect
426         (with-toplevel-commands :break
427               (if *continuablep*
428                 (let* ((*print-circle* *error-print-circle*)
429                                        ;(*print-pretty* nil)
430                        (*print-array* nil))
431                   (format t "~&> Type :GO to continue, :POP to abort.")
432                   (format t "~&> If continued: ~A~%" continue))
433                 (format t "~&> Type :POP to abort.~%"))
434               (format t "~&Type :? for other options.")
435               (terpri)
436
437               (force-output)
438               (when backtracep
439                 (select-backtrace))
440               (clear-input *debug-io*)
441               (setq *error-reentry-count* 0) ; succesfully reported error
442               (read-loop :break-level (1+ *break-level*)))
443      (setf (interrupt-level) level))))
444
445
446
447(defun display-restarts (&optional (condition *break-condition*))
448  (let ((i 0))
449    (format t "~&[Pretend that these are buttons.]")
450    (dolist (r (compute-restarts condition) i)
451      (format t "~&~a : ~A" i r)
452      (setq i (%i+ i 1)))
453    (fresh-line nil)))
454
455(defun select-restart (n &optional (condition *break-condition*))
456  (let* ((restarts (compute-restarts condition)))
457    (invoke-restart-interactively
458     (nth (require-type n `(integer 0 (,(length restarts)))) restarts))))
459
460
461
462
463; End of l1-readloop-lds.lisp
Note: See TracBrowser for help on using the repository browser.