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

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

Don't call QUIT on EOF, call EXIT-INTERACTIVE-PROCESS instead.

Look at *QUIT-ON-EOF* when deciding what to do in response to EOF.

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