/[cmucl]/src/hemlock/macros.lisp
ViewVC logotype

Contents of /src/hemlock/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed May 9 13:05:17 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; This file contains most of the junk that needs to be in the compiler
12 ;;; to compile Hemlock commands.
13 ;;;
14 ;;; Written by Rob MacLachlin and Bill Chiles.
15 ;;;
16
17 (in-package "HEMLOCK-INTERNALS")
18
19 (export '(invoke-hook value setv hlet string-to-variable add-hook remove-hook
20 defcommand with-mark use-buffer editor-error
21 editor-error-format-string editor-error-format-arguments do-strings
22 command-case reprompt with-output-to-mark with-input-from-region
23 handle-lisp-errors with-pop-up-display *random-typeout-buffers*))
24
25
26
27 ;;;; Macros used for manipulating Hemlock variables.
28
29 (defmacro invoke-hook (place &rest args)
30 "Call the functions in place with args. If place is a symbol, then this
31 interprets it as a Hemlock variable rather than a Lisp variable, using its
32 current value as the list of functions."
33 (let ((f (gensym)))
34 `(dolist (,f ,(if (symbolp place) `(%value ',place) place))
35 (funcall ,f ,@args))))
36
37 (defmacro value (name)
38 "Return the current value of the Hemlock variable name."
39 `(%value ',name))
40
41 (defmacro setv (name new-value)
42 "Set the current value of the Hemlock variable name, calling any hook
43 functions with new-value before setting the value."
44 `(%set-value ',name ,new-value))
45
46 ;;; WITH-VARIABLE-OBJECT -- Internal
47 ;;;
48 ;;; Look up the variable object for name and bind it to obj, giving error
49 ;;; if there is no such variable.
50 ;;;
51 (defmacro with-variable-object (name &body forms)
52 `(let ((obj (get ,name 'hemlock-variable-value)))
53 (unless obj (undefined-variable-error ,name))
54 ,@forms))
55
56 (defmacro hlet (binds &rest forms)
57 "Hlet ({Var Value}*) {Form}*
58 Similar to Let, only it creates temporary Hemlock variable bindings. Each
59 of the vars have the corresponding value during the evaluation of the
60 forms."
61 (let ((lets ())
62 (sets ())
63 (unsets ()))
64 (dolist (bind binds)
65 (let ((n-obj (gensym))
66 (n-val (gensym))
67 (n-old (gensym)))
68 (push `(,n-val ,(second bind)) lets)
69 (push `(,n-old (variable-object-value ,n-obj)) lets)
70 (push `(,n-obj (with-variable-object ',(first bind) obj)) lets)
71 (push `(setf (variable-object-value ,n-obj) ,n-val) sets)
72 (push `(setf (variable-object-value ,n-obj) ,n-old) unsets)))
73 `(let* ,lets
74 (unwind-protect
75 (progn ,@sets nil ,@forms)
76 ,@unsets))))
77
78
79
80 ;;;; A couple funs to hack strings to symbols.
81
82 (eval-when (compile load eval)
83
84 (defun bash-string-to-symbol (name suffix)
85 (intern (nsubstitute #\- #\space
86 (nstring-upcase
87 (concatenate 'simple-string
88 name (symbol-name suffix))))))
89
90 ;;; string-to-variable -- Exported
91 ;;;
92 ;;; Return the symbol which corresponds to the string name
93 ;;; "string".
94 (defun string-to-variable (string)
95 (intern (nsubstitute #\- #\space
96 (the simple-string (string-upcase string)))
97 (find-package "HEMLOCK")))
98
99 ); eval-when (compile load eval)
100
101 ;;; string-to-keyword -- Internal
102 ;;;
103 ;;; Mash a string into a Keyword.
104 ;;;
105 (defun string-to-keyword (string)
106 (intern (nsubstitute #\- #\space
107 (the simple-string (string-upcase string)))
108 (find-package "KEYWORD")))
109
110
111
112 ;;;; Macros to add and delete hook functions.
113
114 ;;; add-hook -- Exported
115 ;;;
116 ;;; Add a hook function to a hook, defining a variable if
117 ;;; necessary.
118 ;;;
119 (defmacro add-hook (place hook-fun)
120 "Add-Hook Place Hook-Fun
121 Add Hook-Fun to the list stored in Place. If place is a symbol then it
122 it is interpreted as a Hemlock variable rather than a Lisp variable."
123 (if (symbolp place)
124 `(pushnew ,hook-fun (value ,place))
125 `(pushnew ,hook-fun ,place)))
126
127 ;;; remove-hook -- Public
128 ;;;
129 ;;; Delete a hook-function from somewhere.
130 ;;;
131 (defmacro remove-hook (place hook-fun)
132 "Remove-Hook Place Hook-Fun
133 Remove Hook-Fun from the list in Place. If place is a symbol then it
134 it is interpreted as a Hemlock variable rather than a Lisp variable."
135 (if (symbolp place)
136 `(setf (value ,place) (delete ,hook-fun (value ,place)))
137 `(setf ,place (delete ,hook-fun ,place))))
138
139
140
141 ;;;; DEFCOMMAND.
142
143 ;;; Defcommand -- Public
144 ;;;
145 (defmacro defcommand (name lambda-list command-doc function-doc
146 &body forms)
147 "Defcommand Name Lambda-List Command-Doc Function-Doc {Declaration}* {Form}*
148
149 Define a new Hemlock command named Name. Lambda-List becomes the
150 lambda-list, Function-Doc the documentation, and the Forms the
151 body of the function which implements the command. The first
152 argument, which must be present, is the prefix argument. The name
153 of this function is derived by replacing all spaces in the name with
154 hyphens and appending \"-COMMAND\". Command-Doc becomes the
155 documentation for the command. See the command implementor's manual
156 for further details.
157
158 An example:
159 (defcommand \"Forward Character\" (p)
160 \"Move the point forward one character.
161 With prefix argument move that many characters, with negative argument
162 go backwards.\"
163 \"Move the point of the current buffer forward p characters.\"
164 (unless (character-offset (buffer-point (current-buffer)) (or p 1))
165 (editor-error)))"
166
167 (unless (stringp function-doc)
168 (error "Command function documentation is not a string: ~S."
169 function-doc))
170 (when (atom lambda-list)
171 (error "Command argument list is not a list: ~S." lambda-list))
172 (let (command-name function-name)
173 (cond ((listp name)
174 (setq command-name (car name) function-name (cadr name))
175 (unless (symbolp function-name)
176 (error "Function name is not a symbol: ~S" function-name)))
177 (t
178 (setq command-name name
179 function-name (bash-string-to-symbol name '-COMMAND))))
180 (unless (stringp command-name)
181 (error "Command name is not a string: ~S." name))
182 `(eval-when (load eval)
183 (defun ,function-name ,lambda-list ,function-doc ,@forms)
184 (make-command ',name ,command-doc ',function-name)
185 ',function-name)))
186
187
188
189 ;;;; PARSE-FORMS
190
191 ;;; Parse-Forms -- Internal
192 ;;;
193 ;;; Used for various macros to get the declarations out of a list of
194 ;;; forms.
195 ;;;
196 (eval-when (compile load eval)
197 (defmacro parse-forms ((decls-var forms-var forms) &body gorms)
198 "Parse-Forms (Decls-Var Forms-Var Forms) {Form}*
199 Binds Decls-Var to leading declarations off of Forms and Forms-Var
200 to what is left."
201 `(do ((,forms-var ,forms (cdr ,forms-var))
202 (,decls-var ()))
203 ((or (atom ,forms-var) (atom (car ,forms-var))
204 (not (eq (caar ,forms-var) 'declare)))
205 ,@gorms)
206 (push (car ,forms-var) ,decls-var)))
207 )
208
209
210
211 ;;;; WITH-MARK and USE-BUFFER.
212
213 (defmacro with-mark (mark-bindings &rest forms)
214 "With-Mark ({(Mark Pos [Kind])}*) {declaration}* {form}*
215 With-Mark binds a variable named Mark to a mark specified by Pos. This
216 mark is :temporary, or of kind Kind. The forms are then evaluated."
217 (do ((bindings mark-bindings (cdr bindings))
218 (let-slots ())
219 (cleanup ()))
220 ((null bindings)
221 (if cleanup
222 (parse-forms (decls forms forms)
223 `(let ,(nreverse let-slots)
224 ,@decls
225 (unwind-protect
226 (progn ,@forms)
227 ,@cleanup)))
228 `(let ,(nreverse let-slots) ,@forms)))
229 (let ((name (caar bindings))
230 (pos (cadar bindings))
231 (type (or (caddar bindings) :temporary)))
232 (cond ((not (eq type :temporary))
233 (push `(,name (copy-mark ,pos ,type)) let-slots)
234 (push `(delete-mark ,name) cleanup))
235 (t
236 (push `(,name (copy-mark ,pos :temporary)) let-slots))))))
237
238 #|SAve this shit in case we want WITH-MARKto no longer cons marks.
239 (defconstant with-mark-total 50)
240 (defvar *with-mark-free-marks* (make-array with-mark-total))
241 (defvar *with-mark-next* 0)
242
243 (defmacro with-mark (mark-bindings &rest forms)
244 "WITH-MARK ({(Mark Pos [Kind])}*) {declaration}* {form}*
245 WITH-MARK evaluates each form with each Mark variable bound to a mark
246 specified by the respective Pos, a mark. The created marks are of kind
247 :temporary, or of kind Kind."
248 (do ((bindings mark-bindings (cdr bindings))
249 (let-slots ())
250 (cleanup ()))
251 ((null bindings)
252 (let ((old-next (gensym)))
253 (parse-forms (decls forms forms)
254 `(let ((*with-mark-next* *with-mark-next*)
255 (,old-next *with-mark-next*))
256 (let ,(nreverse let-slots)
257 ,@decls
258 (unwind-protect
259 (progn ,@forms)
260 ,@cleanup))))))
261 (let ((name (caar bindings))
262 (pos (cadar bindings))
263 (type (or (caddar bindings) :temporary)))
264 (push `(,name (mark-for-with-mark ,pos ,type)) let-slots)
265 (if (eq type :temporary)
266 (push `(delete-mark ,name) cleanup)
267 ;; Assume mark is on free list and drop its hold on data.
268 (push `(setf (mark-line ,name) nil) cleanup)))))
269
270 ;;; MARK-FOR-WITH-MARK -- Internal.
271 ;;;
272 ;;; At run time of a WITH-MARK form, this returns an appropriate mark at the
273 ;;; position mark of type kind. First it uses one from the vector of free
274 ;;; marks, possibly storing one in the vector if we need more marks than we
275 ;;; have before, and that need is still less than the total free marks we are
276 ;;; willing to hold onto. If we're over the free limit, just make one for
277 ;;; throwing away.
278 ;;;
279 (defun mark-for-with-mark (mark kind)
280 (let* ((line (mark-line mark))
281 (charpos (mark-charpos mark))
282 (mark (cond ((< *with-mark-next* with-mark-total)
283 (let ((m (svref *with-mark-free-marks* *with-mark-next*)))
284 (cond ((markp m)
285 (setf (mark-line m) line)
286 (setf (mark-charpos m) charpos)
287 (setf (mark-%kind m) kind))
288 (t
289 (setf m (internal-make-mark line charpos kind))
290 (setf (svref *with-mark-free-marks*
291 *with-mark-next*)
292 m)))
293 (incf *with-mark-next*)
294 m))
295 (t (internal-make-mark line charpos kind)))))
296 (unless (eq kind :temporary)
297 (push mark (line-marks (mark-line mark))))
298 mark))
299 |#
300
301 (defmacro use-buffer (buffer &body forms)
302 "Use-Buffer Buffer {Form}*
303 Has The effect of making Buffer the current buffer during the evaluation
304 of the Forms. For restrictions see the manual."
305 (let ((gensym (gensym)))
306 `(let ((,gensym *current-buffer*)
307 (*current-buffer* ,buffer))
308 (unwind-protect
309 (progn
310 (use-buffer-set-up ,gensym)
311 ,@forms)
312 (use-buffer-clean-up ,gensym)))))
313
314
315
316 ;;;; EDITOR-ERROR.
317
318 (defun print-editor-error (condx s)
319 (apply #'format s (editor-error-format-string condx)
320 (editor-error-format-arguments condx)))
321
322 (define-condition editor-error (error)
323 ((format-string "")
324 (format-arguments '()))
325 (:report print-editor-error))
326 ;;;
327 (setf (documentation 'editor-error-format-string 'function)
328 "Returns the FORMAT control string of the given editor-error condition.")
329 (setf (documentation 'editor-error-format-arguments 'function)
330 "Returns the FORMAT arguments for the given editor-error condition.")
331
332 (defun editor-error (&rest args)
333 "This function is called to signal minor errors within Hemlock;
334 these are errors that a normal user could encounter in the course of editing
335 such as a search failing or an attempt to delete past the end of the buffer.
336 This function SIGNAL's an editor-error condition formed from args. Hemlock
337 invokes commands in a dynamic context with an editor-error condition handler
338 bound. This default handler beeps or flashes (or both) the display. If
339 args were supplied, it also invokes MESSAGE on them. The command in
340 progress is always aborted, and this function never returns."
341 (let ((condx (make-condition 'editor-error
342 :format-string (car args)
343 :format-arguments (cdr args))))
344 (signal condx)
345 (error "Unhandled editor-error was signaled -- ~A." condx)))
346
347
348
349 ;;;; Do-Strings
350
351 (defmacro do-strings ((string-var value-var table &optional result) &body forms)
352 "Do-Strings (String-Var Value-Var Table [Result]) {declaration}* {form}*
353 Iterate over the strings in a String Table. String-Var and Value-Var
354 are bound to the string and value respectively of each successive entry
355 in the string-table Table in alphabetical order. If supplied, Result is
356 a form to evaluate to get the return value."
357 (let ((value-nodes (gensym))
358 (num-nodes (gensym))
359 (value-node (gensym))
360 (i (gensym)))
361 `(let ((,value-nodes (string-table-value-nodes ,table))
362 (,num-nodes (string-table-num-nodes ,table)))
363 (dotimes (,i ,num-nodes ,result)
364 (declare (fixnum ,i))
365 (let* ((,value-node (svref ,value-nodes ,i))
366 (,value-var (value-node-value ,value-node))
367 (,string-var (value-node-proper ,value-node)))
368 (declare (simple-string ,string-var))
369 ,@forms)))))
370
371
372
373 ;;;; COMMAND-CASE
374
375 ;;; Command-Case -- Public
376 ;;;
377 ;;; Grovel the awful thing and spit out the corresponding Cond. See Echo
378 ;;; for the definition of command-case-help and logical char stuff.
379 ;;;
380 (eval-when (compile load eval)
381 (defun command-case-tag (tag char)
382 (cond ((and (characterp tag) (standard-char-p tag))
383 `(char= ,char ,(char-upcase tag)))
384 ((and (symbolp tag) (keywordp tag))
385 `(logical-char= ,char ,tag))
386 (t
387 (error "Tag in Command-Case is not a standard character or keyword:~S"
388 tag))))
389 ); eval-when (compile load eval)
390 ;;;
391 (defmacro command-case ((&key (change-window t) character
392 (prompt "Command character: ")
393 (help "Choose one of the following characters:")
394 (bind (gensym)))
395 &body forms)
396 (do* ((forms forms (cdr forms))
397 (form (car forms) (car forms))
398 (cases ())
399 (bname (gensym))
400 (upper (gensym))
401 (again (gensym))
402 (n-prompt (gensym))
403 (n-change (gensym))
404 (docs ())
405 (t-case `(t (beep) (reprompt))))
406 ((atom forms)
407 `(macrolet ((reprompt ()
408 `(progn
409 (setq ,',bind (prompt-for-character*
410 ,',n-prompt ,',n-change))
411 (go ,',AGAIN))))
412 (block ,bname
413 (let* ((,n-prompt ,prompt)
414 (,n-change ,change-window)
415 (,bind ,(or character
416 `(prompt-for-character* ,n-prompt ,n-change))))
417 (tagbody
418 ,AGAIN
419 (let ((,upper (char-upcase ,bind)))
420 (return-from
421 ,bname
422 (cond
423 ,@(nreverse cases)
424 ((logical-char= ,upper :abort) (editor-error))
425 ((logical-char= ,upper :help)
426 (command-case-help ,help ',(nreverse docs))
427 (reprompt))
428 ,t-case))))))))
429
430 (cond ((atom form)
431 (error "Malformed Command-Case clause: ~S" form))
432 ((eq (car form) t)
433 (setq t-case form))
434 ((or (< (length form) 2)
435 (not (stringp (second form))))
436 (error "Malformed Command-Case clause: ~S" form))
437 (t
438 (let ((tag (car form))
439 (rest (cddr form)))
440 (cond ((atom tag)
441 (push (cons (command-case-tag tag upper) rest) cases)
442 (setq tag (list tag)))
443 (t
444 (do ((tag tag (cdr tag))
445 (res () (cons (command-case-tag (car tag) upper) res)))
446 ((null tag)
447 (push `((or ,@res) . ,rest) cases)))))
448 (push (cons tag (second form)) docs))))))
449
450
451
452 ;;;; Some random macros used everywhere.
453
454 (defmacro strlen (str) `(length (the simple-string ,str)))
455 (defmacro neq (a b) `(not (eq ,a ,b))))
456
457
458
459 ;;;; Stuff from here on is implementation dependant.
460
461
462
463 ;;;; WITH-INPUT & WITH-OUTPUT macros.
464
465 (defvar *free-hemlock-output-streams* ()
466 "This variable contains a list of free Hemlock output streams.")
467
468 (defmacro with-output-to-mark ((var mark &optional (buffered ':line))
469 &body gorms)
470 "With-Output-To-Mark (Var Mark [Buffered]) {Declaration}* {Form}*
471 During the evaluation of Forms, Var is bound to a stream which inserts
472 output at the permanent mark Mark. Buffered is the same as for
473 Make-Hemlock-Output-Stream."
474 (parse-forms (decls forms gorms)
475 `(let ((,var (pop *free-hemlock-output-streams*)))
476 ,@decls
477 (if ,var
478 (modify-hemlock-output-stream ,var ,mark ,buffered)
479 (setq ,var (make-hemlock-output-stream ,mark ,buffered)))
480 (unwind-protect
481 (progn ,@forms)
482 (setf (hemlock-output-stream-mark ,var) nil)
483 (push ,var *free-hemlock-output-streams*)))))
484
485 (defvar *free-hemlock-region-streams* ()
486 "This variable contains a list of free Hemlock input streams.")
487
488 (defmacro with-input-from-region ((var region) &body gorms)
489 "With-Input-From-Region (Var Region) {Declaration}* {Form}*
490 During the evaluation of Forms, Var is bound to a stream which
491 returns input from Region."
492 (parse-forms (decls forms gorms)
493 `(let ((,var (pop *free-hemlock-region-streams*)))
494 ,@decls
495 (if ,var
496 (setq ,var (modify-hemlock-region-stream ,var ,region))
497 (setq ,var (make-hemlock-region-stream ,region)))
498 (unwind-protect
499 (progn ,@forms)
500 (delete-mark (hemlock-region-stream-mark ,var))
501 (push ,var *free-hemlock-region-streams*)))))
502
503
504 (defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout"))
505 &body (body decls))
506 "Execute body in a context with var bound to a stream. Output to the stream
507 appears in the buffer named buffer-name. The pop-up display appears after
508 the body completes, but if you supply :height, the output is line buffered,
509 displaying any current output after each line."
510 (when (and (numberp height) (zerop height))
511 (editor-error "I doubt that you really want a window with no height"))
512 (let ((cleanup-p (gensym))
513 (stream (gensym)))
514 `(let ((,cleanup-p nil)
515 (,stream (get-random-typeout-info ,buffer-name ,height)))
516 (unwind-protect
517 (progn
518 (catch 'more-punt
519 ,(when height
520 ;; Test height since it may be supplied, but evaluate
521 ;; to nil.
522 `(when ,height
523 (prepare-for-random-typeout ,stream ,height)
524 (setf ,cleanup-p t)))
525 (let ((,var ,stream))
526 ,@decls
527 (multiple-value-prog1
528 (progn ,@body)
529 (unless ,height
530 (prepare-for-random-typeout ,stream nil)
531 (setf ,cleanup-p t)
532 (funcall (device-random-typeout-full-more
533 (device-hunk-device
534 (window-hunk
535 (random-typeout-stream-window ,stream))))
536 ,stream))
537 (end-random-typeout ,var))))
538 (setf ,cleanup-p nil))
539 (when ,cleanup-p (random-typeout-cleanup ,stream))))))
540
541 (proclaim '(special *random-typeout-ml-fields* *buffer-names*))
542
543 (defvar *random-typeout-buffers* () "A list of random-typeout buffers.")
544
545 (defun get-random-typeout-info (buffer-name line-buffered-p)
546 (let* ((buffer (getstring buffer-name *buffer-names*))
547 (stream
548 (cond
549 ((not buffer)
550 (let* ((buf (make-buffer
551 buffer-name
552 :modes '("Fundamental")
553 :modeline-fields *random-typeout-ml-fields*
554 :delete-hook
555 (list #'(lambda (buffer)
556 (setq *random-typeout-buffers*
557 (delete buffer *random-typeout-buffers*
558 :key #'car))))))
559 (point (buffer-point buf))
560 (stream (make-random-typeout-stream
561 (copy-mark point :left-inserting))))
562 (setf (random-typeout-stream-more-mark stream)
563 (copy-mark point :right-inserting))
564 (push (cons buf stream) *random-typeout-buffers*)
565 stream))
566 ((member buffer *random-typeout-buffers* :key #'car)
567 (delete-region (buffer-region buffer))
568 (let* ((pair (assoc buffer *random-typeout-buffers*))
569 (stream (cdr pair)))
570 (setf *random-typeout-buffers*
571 (cons pair (delete pair *random-typeout-buffers*)))
572 (setf (random-typeout-stream-first-more-p stream) t)
573 (setf (random-typeout-stream-no-prompt stream) nil)
574 stream))
575 (t
576 (error "~A is not a random typeout buffer."
577 (buffer-name buffer))))))
578 (if line-buffered-p
579 (setf (random-typeout-stream-out stream) #'random-typeout-line-out
580 (random-typeout-stream-sout stream) #'random-typeout-line-sout
581 (random-typeout-stream-misc stream) #'random-typeout-line-misc)
582 (setf (random-typeout-stream-out stream) #'random-typeout-full-out
583 (random-typeout-stream-sout stream) #'random-typeout-full-sout
584 (random-typeout-stream-misc stream) #'random-typeout-full-misc))
585 stream))
586
587
588
589 ;;;; Error handling stuff.
590
591 (proclaim '(special *echo-area-stream*))
592
593 ;;; LISP-ERROR-ERROR-HANDLER is in Macros.Lisp instead of Rompsite.Lisp because
594 ;;; it uses WITH-POP-UP-DISPLAY, and Macros is compiled after Rompsite. It
595 ;;; binds an error condition handler to get us out of here on a recursive error
596 ;;; (we are already handling one if we are here). Since COMMAND-CASE uses
597 ;;; EDITOR-ERROR for logical :abort characters, and this is a subtype of ERROR,
598 ;;; we bind an editor-error condition handler just inside of the error handler.
599 ;;; This keeps us from being thrown out into the debugger with supposedly
600 ;;; recursive errors occuring. What we really want in this case is to simply
601 ;;; get back to the command loop and forget about the error we are currently
602 ;;; handling.
603 ;;;
604 (defun lisp-error-error-handler (condition &optional internalp)
605 (handler-bind ((editor-error #'(lambda (condx)
606 (declare (ignore condx))
607 (beep)
608 (throw 'command-loop-catcher nil)))
609 (error #'(lambda (condition)
610 (declare (ignore condition))
611 (let ((device (device-hunk-device
612 (window-hunk (current-window)))))
613 (funcall (device-exit device) device))
614 (invoke-debugger
615 (make-condition
616 'simple-condition
617 :format-string
618 "Error in error handler; Hemlock broken.")))))
619 (clear-echo-area)
620 (clear-input *editor-input*)
621 (beep)
622 (if internalp (write-string "Internal error: " *echo-area-stream*))
623 (princ condition *echo-area-stream*)
624 (let* ((*editor-input* *real-editor-input*)
625 (ch (read-char *editor-input*)))
626 (if (char= ch #\?)
627 (loop
628 (command-case (:prompt "Debug: "
629 :help
630 "Type one of the Hemlock debug command characters:")
631 ((#\D #\d) "Enter a break loop."
632 (let ((device (device-hunk-device
633 (window-hunk (current-window)))))
634 (funcall (device-exit device) device)
635 (unwind-protect
636 (with-simple-restart
637 (continue "Return to Hemlock's debug loop.")
638 (invoke-debugger condition))
639 (funcall (device-init device) device))))
640 (#\B "Do a stack backtrace."
641 (with-pop-up-display (*debug-io* :height 100)
642 (debug:backtrace)))
643 (#\E "Show the error."
644 (with-pop-up-display (*standard-output*)
645 (princ condition)))
646 ((#\Q :exit) "Throw back to Hemlock top-level."
647 (throw 'editor-top-level-catcher nil))
648 ((#\r #\R) "Try to restart from this error."
649 (let ((cases (compute-restarts)))
650 (declare (list cases))
651 (with-pop-up-display (s :height (1+ (length cases)))
652 (debug::show-restarts cases s))
653 (invoke-restart-interactively
654 (nth (prompt-for-integer :prompt "Restart number: ")
655 cases))))))
656 (unread-char ch *editor-input*))
657 (throw 'editor-top-level-catcher nil))))
658
659 (defmacro handle-lisp-errors (&body body)
660 "Handle-Lisp-Errors {Form}*
661 If a Lisp error happens during the evaluation of the body, then it is
662 handled in some fashion. This should be used by commands which may
663 get a Lisp error due to some action of the user."
664 `(handler-bind ((error #'lisp-error-error-handler))
665 ,@body))

  ViewVC Help
Powered by ViewVC 1.1.5