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

Last change on this file since 6195 was 6195, checked in by gb, 13 years ago

Some changes, then reverted those changes manually and most of the
effects were cosmetic. TOPLEVEL-PRINT takes an output stream arg.

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