source: trunk/ccl/hemlock/src/macros.lisp @ 880

Last change on this file since 880 was 880, checked in by gb, 15 years ago

WITH-POPUP-DISPLAY: use typeout-stream (from Alex Crain.)

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