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

Contents of /src/hemlock/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5