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

Last change on this file was 16803, checked in by svspire, 3 years ago

Missed one file from changeset:16802.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17; l1-readloop-lds.lisp
18
19(in-package "CCL")
20
21
22(defvar *read-loop-function* 'read-loop)
23
24(defun run-read-loop (&rest args)
25  (declare (dynamic-extent args))
26  (apply *read-loop-function* args))
27
28(defun toplevel-loop ()
29  (loop
30    (if (eq (catch :toplevel 
31              (run-read-loop :break-level 0 )) $xstkover)
32      (format t "~&;[Stacks reset due to overflow.]")
33      (when (eq *current-process* *initial-process*)
34        (toplevel)))))
35
36
37(defvar *defined-toplevel-commands* ())
38(defvar *active-toplevel-commands* ())
39
40(defun %define-toplevel-command (group-name key name fn doc args)
41  (let* ((group (or (assoc group-name *defined-toplevel-commands*)
42                    (car (push (list group-name)
43                               *defined-toplevel-commands*))))
44         (pair (assoc key (cdr group) :test #'eq)))
45    (if pair
46      (rplacd pair (list* fn doc args))
47      (push (cons key (list* fn doc args)) (cdr group))))
48  name)
49
50(define-toplevel-command 
51    :global y (&optional p) "Yield control of terminal-input to process
52whose name or ID matches <p>, or to any process if <p> is null"
53    (%%yield-terminal-to (if p (find-process p))))      ;may be nil
54
55
56(define-toplevel-command
57    :global kill (p) "Kill process whose name or ID matches <p>"
58    (let* ((proc (find-process p)))
59      (if proc
60        (process-kill proc))))
61
62(define-toplevel-command 
63    :global proc (&optional p) "Show information about specified process <p>/all processes"
64    (flet ((show-process-info (proc)
65             (format t "~&~d : ~a ~a ~25t[~a] "
66                     (process-serial-number proc)
67                     (if (eq proc *current-process*)
68                       "->"
69                       "  ")
70                     (process-name proc)
71                     (process-whostate proc))
72             (let* ((suspend-count (process-suspend-count proc)))
73               (if (and suspend-count (not (eql 0 suspend-count)))
74                 (format t " (Suspended)")))
75             (let* ((terminal-input-shared-resource
76                     (if (typep *terminal-io* 'two-way-stream)
77                       (input-stream-shared-resource
78                        (two-way-stream-input-stream *terminal-io*)))))
79               (if (and terminal-input-shared-resource
80                        (%shared-resource-requestor-p
81                         terminal-input-shared-resource proc))
82                 (format t " (Requesting terminal input)")))
83             (fresh-line)))
84      (if p
85        (let* ((proc (find-process p)))
86          (if (null proc)
87            (format t "~&;; not found - ~s" p)
88            (show-process-info proc)))
89        (dolist (proc (all-processes) (values))
90          (show-process-info proc)))))
91
92(define-toplevel-command :global cd (dir) "Change to directory DIR (e.g., #p\"ccl:\" or \"/some/dir\")" (setf (current-directory) dir) (toplevel-print (list (current-directory))))
93
94(define-toplevel-command :global pwd () "Print the pathame of the current directory" (toplevel-print (list (current-directory))))
95
96
97
98(defun list-restarts ()
99  (format *debug-io* "~&>   Type (:C <n>) to invoke one of the following restarts:")
100  (display-restarts))
101
102(define-toplevel-command :break pop () "exit current break loop" (abort-break))
103(define-toplevel-command :break a () "exit current break loop" (abort-break))
104(define-toplevel-command :break go () "continue" (continue))
105(define-toplevel-command :break q () "return to toplevel" (toplevel))
106(define-toplevel-command :break r () "list restarts" (list-restarts))
107
108
109(define-toplevel-command :break nframes ()
110  "print the number of stack frames accessible from this break loop"
111  (do* ((p *break-frame* (parent-frame p nil))
112        (i 0 )
113        (last (last-frame-ptr)))
114      ((eql p last) (toplevel-print (list i)))
115    (declare (fixnum i))
116    (when (function-frame-p p nil)
117      (incf i))))
118
119(define-toplevel-command :global ? () "help"
120  (format t "~&The following toplevel commands are available:")
121  (when *default-integer-command*
122    (format t "~& <n>  ~8Tthe same as (~s <n>)" (car *default-integer-command*)))
123  (dolist (g *active-toplevel-commands*)
124    (dolist (c (cdr g))
125      (let* ((command (car c))
126             (doc (caddr c))
127             (args (cdddr c)))
128        (if args
129          (format t "~& (~S~{ ~A~}) ~8T~A" command args doc)
130          (format t "~& ~S  ~8T~A" command doc)))))
131  (format t "~&Any other form is evaluated and its results are printed out."))
132
133
134(define-toplevel-command :break b (&key start count show-frame-contents) "backtrace"
135  (when *break-frame*
136      (print-call-history :detailed-p show-frame-contents
137                          :origin *break-frame*
138                          :count count
139                          :start-frame-number (or start 0))))
140
141(define-toplevel-command :break c (&optional n) "Choose restart <n>. If no <n>, continue"
142  (if n
143   (select-restart n)
144   (continue)))
145
146(define-toplevel-command :break f (n) "Show backtrace frame <n>"
147   (print-call-history :origin *break-frame*
148                       :start-frame-number n
149                       :count 1
150                       :detailed-p t))
151
152(define-toplevel-command :break return-from-frame (i &rest values) "Return VALUES from the I'th stack frame"
153  (let* ((frame-sp (nth-function-frame  i *break-frame* nil)))
154    (if frame-sp
155      (apply #'return-from-frame frame-sp values))))
156
157(define-toplevel-command :break apply-in-frame (i function &rest args) "Applies FUNCTION to ARGS in the execution context of the Ith stack frame"
158  (let* ((frame-sp (nth-function-frame  i *break-frame* nil)))
159    (if frame-sp
160      (apply-in-frame frame-sp function args))))
161                         
162                         
163
164(define-toplevel-command :break raw (n) "Show raw contents of backtrace frame <n>"
165   (print-call-history :origin *break-frame*
166                       :start-frame-number n
167                       :count 1
168                       :detailed-p :raw))
169
170(define-toplevel-command :break v (n frame-number) "Return value <n> in frame <frame-number>"
171  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
172    (if frame-sp
173      (toplevel-print (list (nth-value-in-frame frame-sp n nil))))))
174
175(define-toplevel-command :break arg (name frame-number) "Return value of argument named <name> in frame <frame-number>"
176  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
177    (when frame-sp
178      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
179        (when (and lfun pc)
180          (let* ((unavailable (cons nil nil)))
181            (declare (dynamic-extent unavailable))
182            (let* ((value (arg-value nil frame-sp lfun pc unavailable name)))
183              (if (eq value unavailable)
184                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
185                (toplevel-print (list value))))))))))
186
187(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named <name> in frame <frame-number> to value <new>."
188  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
189    (when frame-sp
190      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
191        (when (and lfun pc)
192          (or (set-arg-value nil frame-sp lfun pc name new)
193              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
194   
195
196(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
197binding of that symbol is used - or an integer index into the frame's set of local bindings."
198  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
199    (when frame-sp
200      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
201        (when (and lfun pc)
202          (let* ((unavailable (cons nil nil)))
203            (declare (dynamic-extent unavailable))
204            (let* ((value (local-value nil frame-sp lfun pc unavailable name)))
205              (if (eq value unavailable)
206                (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number)
207                (toplevel-print (list value))))))))))
208
209(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>."
210  (let* ((frame-sp (nth-function-frame frame-number *break-frame* nil)))
211    (when frame-sp
212      (multiple-value-bind (lfun pc) (cfp-lfun frame-sp)
213        (when (and lfun pc)
214          (or (set-local-value nil frame-sp lfun pc name new)
215              (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number)))))))
216
217
218(define-toplevel-command :break form (frame-number)
219   "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."
220   (let* ((form (dbg-form frame-number)))
221     (when form
222       (let* ((*print-level* (default-print-level *backtrace-print-level*))
223              (*print-length* (default-print-length *backtrace-print-length*)))
224         (toplevel-print (list form))))))
225
226;;; Ordinarily, form follows function.
227(define-toplevel-command :break function (frame-number)
228  "Returns the function invoked in backtrace frame <frame-number>.  This may be useful for, e.g., disassembly"
229  (let* ((cfp (nth-function-frame frame-number *break-frame* nil)))
230    (when (and cfp (not (catch-csp-p cfp nil)))
231      (let* ((function (cfp-lfun cfp)))
232        (when function
233          (toplevel-print (list function)))))))
234 
235
236
237         
238
239 
240
241(defun %use-toplevel-commands (group-name)
242  ;; Push the whole group
243  (pushnew (assoc group-name *defined-toplevel-commands*)
244           *active-toplevel-commands*
245           :key #'(lambda (x) (car x))))  ; #'car not defined yet ...
246
247(%use-toplevel-commands :global)
248
249(defparameter *toplevel-commands-dwim* t
250 "If true, tries to interpret otherwise-erroneous toplevel expressions as commands.
251In addition, will suppress standard error handling for expressions that look like
252commands but aren't")
253
254(defvar *default-integer-command* nil
255  "If non-nil, should be (keyword  min max)), causing integers between min and max to be
256  interpreted as (keyword integer)")
257
258(defun check-toplevel-command (form)
259  (when (and *default-integer-command*
260             (integerp form)
261             (<= (cadr *default-integer-command*) form (caddr *default-integer-command*)))
262    (setq form `(,(car *default-integer-command*) ,form)))
263  (let* ((cmd (if (consp form) (car form) form))
264         (args (if (consp form) (cdr form))))
265    (when (or (keywordp cmd)
266              (and *toplevel-commands-dwim*
267                   (non-nil-symbol-p cmd)
268                   (not (if (consp form)
269                          (fboundp cmd)
270                          (or (boundp cmd)
271                              (nth-value 1 (gethash cmd *symbol-macros*)))))
272                   ;; Use find-symbol so don't make unneeded keywords.
273                   (setq cmd (find-symbol (symbol-name cmd) :keyword))))
274      (when (eq cmd :help) (setq cmd :?))
275      (flet ((run (cmd form)
276               (or (dolist (g *active-toplevel-commands*)
277                     (let* ((pair (assoc cmd (cdr g))))
278                       (when pair 
279                         (apply (cadr pair) args)
280                         (return t))))
281                   ;; Try to detect user mistyping a command
282                   (when (and *toplevel-commands-dwim*
283                              (if (consp form)
284                                (and (keywordp (%car form)) (not (fboundp (%car form))))
285                                (keywordp form)))
286                     (error "Unknown command ~s" cmd)))))
287        (declare (dynamic-extent #'run))
288        (if *toplevel-commands-dwim*
289          (block nil
290            (handler-bind ((error (lambda (c)
291                                    (format t "~&~a" c)
292                                    (return t))))
293              (run cmd form)))
294          (run cmd form))))))
295
296(defparameter *quit-on-eof* nil)
297
298(defparameter *consecutive-eof-limit* 2 "max number of consecutive EOFs at a given break level, before we give up and abruptly exit.")
299
300(defmethod stream-eof-transient-p (stream)
301  (let ((fd (stream-device stream :input)))
302    (and fd (eof-transient-p fd))))
303
304(defvar *save-interactive-source-locations* t)
305
306;;; This is the part common to toplevel loop and inner break loops.
307(defun read-loop (&key (input-stream *standard-input*)
308                       (output-stream *standard-output*)
309                       (break-level *break-level*)
310                       (prompt-function #'(lambda (stream)
311                                            (when (and *show-available-restarts* *break-condition*)
312                                              (list-restarts)
313                                              (setf *show-available-restarts* nil))
314                                            (print-listener-prompt stream t))))
315  (let* ((*break-level* break-level)
316         (*last-break-level* break-level)
317         (*loading-file-source-file* nil)
318         (*loading-toplevel-location* nil)
319         *in-read-loop*
320         *** ** * +++ ++ + /// // / -
321         (eof-value (cons nil nil))
322         (eof-count 0)
323         (*show-available-restarts* (and *show-restarts-on-break* *break-condition*))
324         (map (make-hash-table :test #'eq :shared nil)))
325    (declare (dynamic-extent eof-value))
326    (loop
327      (restart-case
328       (catch :abort                    ;last resort...
329         (loop
330           (catch-cancel
331            (loop               
332              (setq *in-read-loop* nil
333                    *break-level* break-level)
334              (multiple-value-bind (form env print-result)
335                  (toplevel-read :input-stream input-stream
336                                 :output-stream output-stream
337                                 :prompt-function prompt-function
338                                 :eof-value eof-value
339                                 :map (when *save-interactive-source-locations*
340                                        (clrhash map)
341                                        map))
342                (if (eq form eof-value)
343                  (progn
344                    (when (> (incf eof-count) *consecutive-eof-limit*)
345                      (#_ _exit 0))
346                    (if (and (not *batch-flag*)
347                             (not *quit-on-eof*)
348                             (stream-eof-transient-p input-stream))
349                      (progn
350                        (stream-clear-input input-stream)
351                        (abort-break))
352                      (exit-interactive-process *current-process*)))
353                  (let ((*nx-source-note-map* (and *save-interactive-source-locations* map)))
354                    (setq eof-count 0)
355                    (or (check-toplevel-command form)
356                        (let* ((values (toplevel-eval form env)))
357                          (if print-result (toplevel-print values)))))))))
358           (format *terminal-io* "~&Cancelled")))
359       (abort () :report (lambda (stream)
360                           (if (eq break-level 0)
361                             (format stream "Return to toplevel.")
362                             (format stream "Return to break level ~D." break-level)))
363              #|                        ; Handled by interactive-abort
364                                        ; go up one more if abort occurred while awaiting/reading input               
365              (when (and *in-read-loop* (neq break-level 0))
366              (abort))
367              |#
368               )
369        (abort-break () 
370                     (unless (eq break-level 0)
371                       (abort))))
372       (clear-input input-stream)
373      (format output-stream "~%"))))
374
375;;; The first non-whitespace character available on INPUT-STREAM is a colon.
376;;; Try to interpret the line as a colon command (or possibly just a keyword.)
377(defun read-command-or-keyword (input-stream eof-value)
378  (let* ((line (read-line input-stream nil eof-value)))
379    (if (eq line eof-value)
380      eof-value
381      (let* ((in (make-string-input-stream line))
382             (keyword (read in nil eof-value)))
383        (if (eq keyword eof-value)
384          eof-value
385          (if (not (keywordp keyword))
386            keyword
387            (collect ((params))
388              (loop
389                (let* ((param (read in nil eof-value)))
390                  (if (eq param eof-value)
391                    (return
392                      (let* ((params (params)))
393                        (if params
394                          (cons keyword params)
395                          keyword)))
396                    (params (eval param))))))))))))
397
398;;; Read a form from the specified stream.
399(defun toplevel-read (&key (input-stream *standard-input*)
400                           (output-stream *standard-output*)
401                           (prompt-function #'print-listener-prompt)
402                           (eof-value *eof-value*)
403                           (map nil))
404  (force-output output-stream)
405  (funcall prompt-function output-stream)
406  (read-toplevel-form input-stream :eof-value eof-value :map map))
407
408(defvar *always-eval-user-defvars* nil)
409
410(defun process-single-selection (form)
411  (if (and *always-eval-user-defvars*
412           (listp form) (eq (car form) 'defvar) (cddr form))
413    `(defparameter ,@(cdr form))
414    form))
415
416(defun toplevel-eval (form &optional env)
417  (destructuring-bind (vars . vals) (or env '(nil . nil))
418    (progv vars vals
419      (setq +++ ++ ++ + + - - form)
420      (unwind-protect
421           (let* ((package *package*)
422                  (values (multiple-value-list (cheap-eval-in-environment form nil))))
423             (unless (eq package *package*)
424               ;; If changing a local value (e.g. buffer-local), not useful to notify app
425               ;; without more info.  Perhaps should have a *source-context* that can send along?
426               (unless (member '*package* vars)
427                 (application-ui-operation *application* :note-current-package *package*)))
428             values)
429        (loop for var in vars as pval on vals
430              do (setf (car pval) (symbol-value var)))))))
431
432
433(defun toplevel-print (values &optional (out *standard-output*))
434  (setq /// // // / / values)
435  (unless (eq (car values) (%unbound-marker))
436    (setq *** ** ** * *  (%car values)))
437  (when values
438    (fresh-line out)
439    (dolist (val values) (write val :stream out) (terpri out))))
440
441(defparameter *listener-prompt-format* "~[?~:;~:*~d >~] ")
442
443 
444(defun print-listener-prompt (stream &optional (force t))
445  (unless *quiet-flag*
446    (when (or force (neq *break-level* *last-break-level*))
447      (let* ((*listener-indent* nil))
448        (fresh-line stream)
449        (format stream *listener-prompt-format* *break-level*))
450      (setq *last-break-level* *break-level*)))
451    (force-output stream))
452
453
454;;; Fairly crude default error-handlingbehavior, and a fairly crude mechanism
455;;; for customizing it.
456
457(defvar *app-error-handler-mode* :quit
458  "one of :quit, :quit-quietly, :listener might be useful.")
459
460(defmethod application-error ((a application) condition error-pointer)
461  (case *app-error-handler-mode*
462    (:listener   (break-loop-handle-error condition error-pointer))
463    (:quit-quietly (quit -1))
464    (:quit  (format t "~&Fatal error in ~s : ~a"
465                    (pathname-name (car *command-line-argument-list*))
466                    condition)
467                    (quit -1))))
468
469(defun make-application-error-handler (app mode)
470  (declare (ignore app))
471  (setq *app-error-handler-mode* mode))
472
473
474; You may want to do this anyway even if your application
475; does not otherwise wish to be a "lisp-development-system"
476(defmethod application-error ((a lisp-development-system) condition error-pointer)
477  (break-loop-handle-error condition error-pointer))
478
479(defun abnormal-application-exit ()
480  (ignore-errors
481    (print-call-history)
482    (write-line (lisp-implementation-version) *debug-io*)
483    (force-output *debug-io*)
484    (quit -1))
485  (#__exit -1))
486
487;; Make these available to debugger hook
488(defvar *top-error-frame* nil)
489(defvar *break-loop-type* nil) ;; e.g. "Debug", "Signal", "Error".
490
491(defun break-loop-handle-error (condition *top-error-frame*)
492  (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals)
493    (dolist (x bogus-globals)
494      (set x (funcall (pop newvals))))
495    (let ((msg (if *batch-flag* ;; Give a little more info if exiting
496                 (format nil "Error of type ~s" (type-of condition))
497                 "Error")))
498      (when (and *debugger-hook* *break-on-errors* (not *batch-flag*))
499        (let ((hook *debugger-hook*)
500              (*debugger-hook* nil)
501              (*break-loop-type* msg))
502          (funcall hook condition hook)))
503      (%break-message msg condition))
504    (let* ((s *error-output*))
505      (dolist (bogusness bogus-globals)
506        (let ((oldval (pop oldvals)))
507          (format s "~&;  NOTE: ~S was " bogusness)
508          (if (eq oldval (%unbound-marker-8))
509            (format s "unbound")
510            (format s "~s" oldval))
511          (format s ", was reset to ~s ." (symbol-value bogusness)))))
512    (if (and *break-on-errors* (not *batch-flag*))
513      (break-loop condition)
514      (if *batch-flag*
515        (abnormal-application-exit)
516        (abort)))))
517
518(defun break (&optional string &rest args)
519  "Print a message and invoke the debugger without allowing any possibility
520   of condition handling occurring."
521  (if *batch-flag*
522    (apply #'error (or string "BREAK invoked in batch mode") args)
523    (apply #'%break-in-frame (%get-frame-ptr) string args)))
524
525(defun %break-in-frame (fp &optional string &rest args)
526  (flet ((do-break-loop ()
527           (let ((c (if (typep string 'condition)
528                      string
529                      (make-condition 'simple-condition
530                                    :format-control (or string "")
531                                    :format-arguments args))))
532             (cbreak-loop "Break" "Return from BREAK." c fp))))
533    (cond ((%i> *interrupt-level* -1)
534           (do-break-loop))
535          (*break-loop-when-uninterruptable*
536           (format *error-output* "Break while interrupt-level less than zero; binding to 0 during break-loop.")
537           (let ((interrupt-level (interrupt-level)))
538             (unwind-protect
539                  (progn
540                    (setf (interrupt-level) 0)
541                    (do-break-loop))
542               (setf (interrupt-level) interrupt-level))))
543          (t (format *error-output* "Break while interrupt-level less than zero; ignored.")))))
544
545
546(defun invoke-debugger (condition &aux (*top-error-frame* (%get-frame-ptr)))
547  "Enter the debugger."
548  (let ((c (require-type condition 'condition))
549        (msg "Debug"))
550    (when *debugger-hook*
551      (let ((hook *debugger-hook*)
552            (*debugger-hook* nil)
553            (*break-loop-type* msg))
554        (funcall hook c hook)))
555    (%break-message msg c)
556    (break-loop c)))
557
558(defvar *show-condition-context* t
559  "The type of conditions which should include the execution context as part of their error-output message.
560   E.g. value of 'error will prevent warnings from including the calling function and process in the warning message")
561
562(defun %break-message (msg condition &optional (error-pointer *top-error-frame*) (prefixchar #\>))
563  (let ((*print-circle* *error-print-circle*)
564        ;(*print-prett*y nil)
565        (*print-array* nil)
566        (*print-escape* t)
567        (*print-gensym* t)
568        (*print-length* (default-print-length *error-print-length*))
569        (*print-level* (default-print-level *error-print-level*))
570        (*print-string-length* (default-print-string-length *error-print-string-length*))
571        (*print-lines* nil)
572        (*print-miser-width* nil)
573        (*print-readably* nil)
574        (*print-right-margin* nil)
575        (*signal-printing-errors* nil)
576        (s (make-indenting-string-output-stream prefixchar nil))
577        (sub (make-string-output-stream))
578        (show-context (typep condition *show-condition-context*))
579        (indent 0))
580    (format s "~A~@[ ~A:~] " prefixchar msg)
581    (setf (indenting-string-output-stream-indent s) (setq indent (column s)))
582    (decf (stream-line-length sub) indent)
583    ;(format s "~A" condition) ; evil if circle
584    (report-condition condition sub)
585    (format s "~A" (get-output-stream-string sub))
586    (if (and show-context
587             (not (and (typep condition 'simple-program-error)
588                       (simple-program-error-context condition))))
589      (format *error-output* "~&~A~%~A While executing: ~S"
590              (get-output-stream-string s) prefixchar (%real-err-fn-name error-pointer))
591      (format *error-output* "~&~A"
592              (get-output-stream-string s)))
593    (when show-context
594      (if *current-process*
595        (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*))
596        (format *error-output* ", in an uninitialized process~%")))
597  (force-output *error-output*)))
598                                        ; returns NIL
599
600(defvar *break-hook* nil)
601
602(defun cbreak-loop (msg cont-string condition *top-error-frame*)
603  (let* ((*print-readably* nil)
604         (hook *break-hook*))
605    (restart-case (progn
606                    (when (and (eq (type-of condition) 'simple-condition)
607                               (equal (simple-condition-format-control condition) ""))
608                      (setq condition (make-condition 'simple-condition
609                                        :format-control "~a"
610                                        :format-arguments (list msg))))
611                    (when hook
612                      (let ((*break-hook* nil)
613                            (*break-loop-type* msg))
614                        (funcall hook condition hook))
615                      (setq hook nil))
616                    (%break-message msg condition)
617                    (break-loop condition))
618      (continue () :report (lambda (stream) (write-string cont-string stream))))
619    (unless hook
620      (fresh-line *error-output*))
621    nil))
622
623(defun warn (condition-or-format-string &rest args)
624  "Warn about a situation by signalling a condition formed by DATUM and
625   ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
626   exists that causes WARN to immediately return NIL."
627  (when (typep condition-or-format-string 'condition)
628    (unless (typep condition-or-format-string 'warning)
629      (report-bad-arg condition-or-format-string 'warning))
630    (when args
631      (error 'type-error :datum args :expected-type 'null
632             :format-control "Extra arguments in ~s.")))
633  (let ((fp (%get-frame-ptr))
634        (c (require-type (condition-arg condition-or-format-string args 'simple-warning) 'warning)))
635    (when *break-on-warnings*
636      (cbreak-loop "Warning" "Signal the warning." c fp))
637    (restart-case (signal c)
638      (muffle-warning () :report "Skip the warning" (return-from warn nil)))
639    (%break-message (if (typep c 'compiler-warning) "Compiler warning" "Warning") c fp #\;)
640    ))
641
642(defmacro new-backtrace-info (dialog youngest oldest tcr condition current fake db-link level)
643  (let* ((cond (gensym)))
644  `(let* ((,cond ,condition))
645    (vector ,dialog ,youngest ,oldest ,tcr (cons nil (compute-restarts ,cond)) (%catch-top ,tcr) ,cond ,current ,fake ,db-link ,level))))
646
647(defmethod backtrace-context-continuable-p ((context vector))
648  (not (null (find 'continue (cdr (bt.restarts context)) :key #'restart-name))))
649
650(defmethod backtrace-context-break-level ((context vector))
651  (bt.break-level context))
652
653(defmethod backtrace-context-restarts ((context vector))
654  (cdr (bt.restarts context)))
655
656
657;;; Each of these stack ranges defines the entire range of (control/value/temp)
658;;; addresses; they can be used to addresses of stack-allocated objects
659;;; for printing.
660#-arm-target
661(defun make-tsp-stack-range (tcr bt-info)
662  (list (cons (%catch-tsp (bt.top-catch bt-info))
663              (%fixnum-ref (%fixnum-ref tcr target::tcr.ts-area)
664                                target::area.high))))
665
666#+ppc-target
667(defun make-vsp-stack-range (tcr bt-info)
668  (list (cons (%fixnum-ref
669               (%svref (bt.top-catch bt-info) target::catch-frame.csp-cell)
670               target::lisp-frame.savevsp)
671              (%fixnum-ref (%fixnum-ref tcr target::tcr.vs-area) target::area.high))))
672#+x8632-target
673(defun make-vsp-stack-range (tcr bt-info)
674  (list (cons (%svref (bt.top-catch bt-info) target::catch-frame.esp-cell)
675              (%fixnum-ref
676               (%fixnum-ref tcr (- target::tcr.vs-area target::tcr-bias))
677               target::area.high))))
678
679#+x8664-target
680(defun make-vsp-stack-range (tcr bt-info)
681  (list (cons (%svref (bt.top-catch bt-info) target::catch-frame.rsp-cell)
682              (%fixnum-ref (%fixnum-ref tcr target::tcr.vs-area) target::area.high))))
683
684#+arm-target 
685(defun make-vsp-stack-range (tcr bt-info)
686  (list (cons (%fixnum-ref (catch-frame-sp (bt.top-catch bt-info)) target::lisp-frame.savevsp)
687              (%fixnum-ref (%fixnum-ref tcr target::tcr.vs-area) target::area.high))))
688
689#+ppc-target
690(defun make-csp-stack-range (tcr bt-info)
691  (list (cons (%svref (bt.top-catch bt-info) target::catch-frame.csp-cell)
692              (%fixnum-ref (%fixnum-ref tcr target::tcr.cs-area) target::area.high))))
693
694#+x8632-target
695(defun make-csp-stack-range (tcr bt-info)
696  (let ((cs-area nil))
697    #+windows-target
698    (let ((aux (%fixnum-ref tcr (- target::tcr.aux target::tcr-bias))))
699      (setq cs-area (%fixnum-ref aux target::tcr-aux.cs-area)))
700    #-windows-target
701    (setq cs-area (%fixnum-ref tcr target::tcr.cs-area))
702  (list (cons (%svref (bt.top-catch bt-info) target::catch-frame.foreign-sp-cell)
703              (%fixnum-ref cs-area target::area.high)))))
704
705#+x8664-target
706(defun make-csp-stack-range (tcr bt-info)
707  (list (cons (%svref (bt.top-catch bt-info) target::catch-frame.foreign-sp-cell)
708              (%fixnum-ref (%fixnum-ref tcr target::tcr.cs-area) target::area.high))))
709
710#+arm-target
711(defun make-csp-stack-range (tcr bt-info)
712  (list (cons (catch-frame-sp (bt.top-catch bt-info))
713              (%fixnum-ref (%fixnum-ref tcr target::tcr.cs-area) target::area.high))))
714
715
716
717(declaim (notinline select-backtrace))
718
719(defun select-backtrace ()
720  (declare (notinline select-backtrace))
721  ;(require 'new-backtrace)
722  (require :inspector)
723  (select-backtrace))
724
725(defvar *break-condition* nil "condition argument to innermost break-loop.")
726(defvar *break-frame* nil "frame-pointer arg to break-loop")
727(defvar *break-loop-when-uninterruptable* t)
728(defvar *show-restarts-on-break* nil)
729(defvar *show-available-restarts* nil)
730
731(defvar *error-reentry-count* 0)
732
733(defun funcall-with-error-reentry-detection (thunk)
734  (let* ((count *error-reentry-count*)
735         (*error-reentry-count* (1+ count)))
736    (cond ((eql count 0) (funcall thunk))
737          ((eql count 1) (error "Error reporting error"))
738          (t (bug "Error reporting error")))))
739
740
741(defvar %last-continue% nil)
742(defun break-loop (condition &optional (frame-pointer *top-error-frame*))
743  "Never returns"
744  (let* ((%handlers% (last %handlers%)) ; firewall
745         (*break-frame* frame-pointer)
746         (*break-condition* condition)
747         (*compiling-file* nil)
748         (*backquote-stack* nil)
749         (continue (find-restart 'continue))
750         (*continuablep* (unless (eq %last-continue% continue) continue))
751         (%last-continue% continue)
752         (*standard-input* *debug-io*)
753         (*standard-output* *debug-io*)
754         (*signal-printing-errors* nil)
755         (*read-suppress* nil)
756         (*print-readably* nil)
757         (context (new-backtrace-info nil
758                                      frame-pointer
759                                      (if *backtrace-contexts*
760                                        (or (child-frame
761                                             (bt.youngest (car *backtrace-contexts*))
762                                             nil)
763                                            (last-frame-ptr))
764                                        (last-frame-ptr))
765                                      (%current-tcr)
766                                      condition
767                                      (%current-frame-ptr)
768                                      #+ppc-target *fake-stack-frames*
769                                      #+x86-target (%current-frame-ptr)
770                                      #+arm-target (or (current-fake-stack-frame) (%current-frame-ptr))
771                                      (db-link)
772                                      (1+ *break-level*)))
773         (*default-integer-command* `(:c 0 ,(1- (length (cdr (bt.restarts context))))))
774         (*backtrace-contexts* (cons context *backtrace-contexts*)))
775    (with-terminal-input
776      (with-toplevel-commands :break
777        (if *continuablep*
778          (let* ((*print-circle* *error-print-circle*)
779                 (*print-length* (default-print-length *error-print-length*))
780                 (*print-level* (default-print-level *error-print-level*))
781                 (*print-string-length* (default-print-string-length *error-print-string-length*))
782                 ;(*print-pretty* nil)
783                 (*print-array* nil))
784            (format t (or (application-ui-operation *application* :break-options-string t)
785                          "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts."))
786            (format t "~&> If continued: ~A~%" continue))
787          (format t (or (application-ui-operation *application* :break-options-string nil)
788                        "~&> Type :POP to abort, :R for a list of available restarts.~%")))
789        (format t "~&> Type :? for other options.")
790        (terpri)
791        (force-output)
792
793        (clear-input *debug-io*)
794        (setq *error-reentry-count* 0)  ; succesfully reported error
795        (ignoring-without-interrupts
796          (unwind-protect
797               (progn
798                 (application-ui-operation *application*
799                                           :enter-backtrace-context context)
800                 (run-read-loop :break-level (1+ *break-level*)
801                                :input-stream *debug-io*
802                                :output-stream *debug-io*))
803            (application-ui-operation *application* :exit-backtrace-context
804                                      context)))))))
805
806
807
808(defun display-restarts (&optional (condition *break-condition*))
809  (loop
810    for restart in (compute-restarts condition)
811    for count upfrom 0
812    do (format *debug-io* "~&~D. ~A" count restart)
813    finally (fresh-line *debug-io*)))
814
815(defun select-restart (n &optional (condition *break-condition*))
816  (let* ((restarts (compute-restarts condition)))
817    (invoke-restart-interactively
818     (nth (require-type n `(integer 0 (,(length restarts)))) restarts))))
819
820
821
822
823; End of l1-readloop-lds.lisp
Note: See TracBrowser for help on using the repository browser.