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