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

Contents of /src/hemlock/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5