source: branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp @ 8062

Last change on this file since 8062 was 8062, checked in by gz, 13 years ago

Get rid of the variable "winding" scheme (which used to swap the
current buffer's variable bindings into symbol plists), simplify
variable and mode handing.

Fix a shadow attribute caching bug.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 18.7 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-variable-object ,name :current)))
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;; MODIFYING-BUFFER-STORAGE
74;;
75;; This is kinda Cocoa-specific, but we'll pretend it's not. It gets wrapped around
76;; possible multiple modifications of the buffer's text, so that the OS can defer
77;; layout and redisplay until the end.  It takes care of showing the spin cursor
78;; if the command takes too long, and it ensures that the cocoa selection matches
79;; hemlock's idea of selection.
80;; As a special hack, buffer can be NIL to temporarily turn off the grouping.
81
82(defmacro modifying-buffer-storage ((buffer) &body body)
83  (if (eq buffer '*current-buffer*)
84    `(hemlock-ext:invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body))
85    `(let ((*current-buffer* ,buffer))
86       (hemlock-ext:invoke-modifying-buffer-storage *current-buffer* #'(lambda () ,@body)))))
87
88
89;;;; A couple funs to hack strings to symbols.
90
91(eval-when (:compile-toplevel :execute :load-toplevel)
92
93(defun bash-string-to-symbol (name suffix)
94  (intern (nsubstitute #\- #\space
95                       #-scl
96                       (nstring-upcase
97                        (concatenate 'simple-string
98                                     name (symbol-name suffix)))
99                       #+scl
100                       (let ((base (concatenate 'simple-string
101                                                name (symbol-name suffix))))
102                         (if (eq ext:*case-mode* :upper)
103                             (nstring-upcase base)
104                             (nstring-downcase base))))))
105
106;;; string-to-variable  --  Exported
107;;;
108;;;    Return the symbol which corresponds to the string name
109;;; "string".
110(defun string-to-variable (string)
111  "Returns the symbol name of a Hemlock variable from the corresponding string
112   name."
113  (intern (nsubstitute #\- #\space
114                       #-scl
115                       (the simple-string (string-upcase string))
116                       #+scl
117                       (if (eq ext:*case-mode* :upper)
118                           (string-upcase string)
119                           (string-downcase string)))
120          (find-package :hemlock)))
121
122); eval-when
123
124;;; string-to-keyword  --  Internal
125;;;
126;;;    Mash a string into a Keyword.
127;;;
128(defun string-to-keyword (string)
129  (intern (nsubstitute #\- #\space
130                       #-scl
131                       (the simple-string (string-upcase string))
132                       #+scl
133                       (if (eq ext:*case-mode* :upper)
134                           (string-upcase string)
135                           (string-downcase string)))
136          (find-package :keyword)))
137
138
139;;;; Macros to add and delete hook functions.
140
141;;; add-hook  --  Exported
142;;;
143;;;    Add a hook function to a hook, defining a variable if
144;;; necessary.
145;;;
146(defmacro add-hook (place hook-fun)
147  "Add-Hook Place Hook-Fun
148  Add Hook-Fun to the list stored in Place.  If place is a symbol then it
149  it is interpreted as a Hemlock variable rather than a Lisp variable."
150  (if (symbolp place)
151      `(pushnew ,hook-fun (value ,place))
152      `(pushnew ,hook-fun ,place)))
153
154;;; remove-hook  --  Public
155;;;
156;;;    Delete a hook-function from somewhere.
157;;;
158(defmacro remove-hook (place hook-fun)
159  "Remove-Hook Place Hook-Fun
160  Remove Hook-Fun from the list in Place.  If place is a symbol then it
161  it is interpreted as a Hemlock variable rather than a Lisp variable."
162  (if (symbolp place)
163      `(setf (value ,place) (delete ,hook-fun (value ,place)))
164      `(setf ,place (delete ,hook-fun ,place))))
165
166
167
168;;;; DEFCOMMAND.
169
170;;; Defcommand  --  Public
171;;;
172(defmacro defcommand (name lambda-list command-doc function-doc
173                           &body forms)
174  "Defcommand Name Lambda-List Command-Doc [Function-Doc] {Declaration}* {Form}*
175
176  Define a new Hemlock command named Name.  Lambda-List becomes the
177  lambda-list, Function-Doc the documentation, and the Forms the
178  body of the function which implements the command.  The first
179  argument, which must be present, is the prefix argument.  The name
180  of this function is derived by replacing all spaces in the name with
181  hyphens and appending \"-COMMAND\".  Command-Doc becomes the
182  documentation for the command.  See the command implementor's manual
183  for further details.
184
185  An example:
186    (defcommand \"Forward Character\" (p)
187      \"Move the point forward one character.
188       With prefix argument move that many characters, with negative argument
189       go backwards.\"
190      \"Move the point of the current buffer forward p characters.\"
191      (unless (character-offset (buffer-point (current-buffer)) (or p 1))
192        (editor-error)))"
193
194  (unless (stringp function-doc)
195    (setq forms (cons function-doc forms))
196    (setq function-doc command-doc))
197  (when (atom lambda-list)
198    (error "Command argument list is not a list: ~S." lambda-list))
199  (let (command-name function-name extra-args)
200    (cond ((listp name)
201           (setq command-name (car name) function-name (cadr name))
202           (unless (symbolp function-name)
203             (error "Function name is not a symbol: ~S" function-name))
204           (if (keywordp function-name)
205             (setq function-name nil extra-args (cdr name))
206             (setq extra-args (cddr name))))
207          (t
208           (setq command-name name)))
209    (when (null function-name)
210      (setq function-name (bash-string-to-symbol command-name '-command)))
211    (unless (stringp command-name)
212      (error "Command name is not a string: ~S." name))
213    `(eval-when (:load-toplevel :execute)
214       (defun ,function-name ,lambda-list ,function-doc
215              ,@forms)
216       (make-command ,command-name ,command-doc ',function-name ,@extra-args)
217       ',function-name)))
218
219
220
221;;;; PARSE-FORMS
222
223;;; Parse-Forms  --  Internal
224;;;
225;;;    Used for various macros to get the declarations out of a list of
226;;; forms.
227;;;
228(eval-when (:compile-toplevel :execute :load-toplevel)
229(defmacro parse-forms ((decls-var forms-var forms) &body gorms)
230  "Parse-Forms (Decls-Var Forms-Var Forms) {Form}*
231  Binds Decls-Var to leading declarations off of Forms and Forms-Var
232  to what is left."
233  `(do ((,forms-var ,forms (cdr ,forms-var))
234        (,decls-var ()))
235       ((or (atom ,forms-var) (atom (car ,forms-var))
236            (not (eq (caar ,forms-var) 'declare)))
237        ,@gorms)
238     (push (car ,forms-var) ,decls-var)))
239)
240
241
242
243;;;; WITH-MARK and USE-BUFFER.
244
245(defmacro with-mark (mark-bindings &rest forms)
246  "With-Mark ({(Mark Pos [Kind])}*) {declaration}* {form}*
247  With-Mark binds a variable named Mark to a mark specified by Pos.  This
248  mark is :temporary, or of kind Kind.  The forms are then evaluated."
249  (do ((bindings mark-bindings (cdr bindings))
250       (let-slots ())
251       (cleanup ()))
252      ((null bindings)
253       (if cleanup
254           (parse-forms (decls forms forms)
255             `(let ,(nreverse let-slots)
256                ,@decls
257                (unwind-protect
258                  (progn ,@forms)
259                  ,@cleanup)))
260           `(let ,(nreverse let-slots) ,@forms)))
261    (let ((name (caar bindings))
262          (pos (cadar bindings))
263          (type (or (caddar bindings) :temporary)))
264      (cond ((not (eq type :temporary))
265             (push `(,name (copy-mark ,pos ,type)) let-slots)
266             (push `(delete-mark ,name) cleanup))
267            (t
268             (push `(,name (copy-mark ,pos :temporary)) let-slots))))))
269
270#||SAve this shit in case we want WITH-MARKto no longer cons marks.
271(defconstant with-mark-total 50)
272(defvar *with-mark-free-marks* (make-array with-mark-total))
273(defvar *with-mark-next* 0)
274
275(defmacro with-mark (mark-bindings &rest forms)
276  "WITH-MARK ({(Mark Pos [Kind])}*) {declaration}* {form}*
277   WITH-MARK evaluates each form with each Mark variable bound to a mark
278   specified by the respective Pos, a mark.  The created marks are of kind
279   :temporary, or of kind Kind."
280  (do ((bindings mark-bindings (cdr bindings))
281       (let-slots ())
282       (cleanup ()))
283      ((null bindings)
284       (let ((old-next (gensym)))
285         (parse-forms (decls forms forms)
286           `(let ((*with-mark-next* *with-mark-next*)
287                  (,old-next *with-mark-next*))
288              (let ,(nreverse let-slots)
289                ,@decls
290                (unwind-protect
291                    (progn ,@forms)
292                  ,@cleanup))))))
293       (let ((name (caar bindings))
294             (pos (cadar bindings))
295             (type (or (caddar bindings) :temporary)))
296         (push `(,name (mark-for-with-mark ,pos ,type)) let-slots)
297         (if (eq type :temporary)
298             (push `(delete-mark ,name) cleanup)
299             ;; Assume mark is on free list and drop its hold on data.
300             (push `(setf (mark-line ,name) nil) cleanup)))))
301
302;;; MARK-FOR-WITH-MARK -- Internal.
303;;;
304;;; At run time of a WITH-MARK form, this returns an appropriate mark at the
305;;; position mark of type kind.  First it uses one from the vector of free
306;;; marks, possibly storing one in the vector if we need more marks than we
307;;; have before, and that need is still less than the total free marks we are
308;;; willing to hold onto.  If we're over the free limit, just make one for
309;;; throwing away.
310;;;
311(defun mark-for-with-mark (mark kind)
312  (let* ((line (mark-line mark))
313         (charpos (mark-charpos mark))
314         (mark (cond ((< *with-mark-next* with-mark-total)
315                      (let ((m (svref *with-mark-free-marks* *with-mark-next*)))
316                        (cond ((markp m)
317                               (setf (mark-line m) line)
318                               (setf (mark-charpos m) charpos)
319                               (setf (mark-%kind m) kind))
320                              (t
321                               (setf m (internal-make-mark line charpos kind))
322                               (setf (svref *with-mark-free-marks*
323                                            *with-mark-next*)
324                                     m)))
325                        (incf *with-mark-next*)
326                        m))
327                     (t (internal-make-mark line charpos kind)))))
328    (unless (eq kind :temporary)
329      (push mark (line-marks (mark-line mark))))
330    mark))
331||#
332
333
334;;;; EDITOR-ERROR.
335
336(defun editor-error (&rest args)
337  "This function is called to signal minor errors within Hemlock;
338   these are errors that a normal user could encounter in the course of editing
339   such as a search failing or an attempt to delete past the end of the buffer."
340  (let ((message (and args (apply #'format nil args))))
341    (abort-current-command message)))
342
343;;;; Do-Strings
344
345(defmacro do-strings ((string-var value-var table &optional result) &body forms)
346  "Do-Strings (String-Var Value-Var Table [Result]) {declaration}* {form}*
347  Iterate over the strings in a String Table.  String-Var and Value-Var
348  are bound to the string and value respectively of each successive entry
349  in the string-table Table in alphabetical order.  If supplied, Result is
350  a form to evaluate to get the return value."
351  (let ((value-nodes (gensym))
352        (num-nodes (gensym))
353        (value-node (gensym))
354        (i (gensym)))
355    `(let ((,value-nodes (string-table-value-nodes ,table))
356           (,num-nodes (string-table-num-nodes ,table)))
357       (dotimes (,i ,num-nodes ,result)
358         (declare (fixnum ,i))
359         (let* ((,value-node (svref ,value-nodes ,i))
360                (,value-var (value-node-value ,value-node))
361                (,string-var (value-node-proper ,value-node)))
362           (declare (simple-string ,string-var))
363           ,@forms)))))
364
365
366
367;;;; COMMAND-CASE
368
369;;; COMMAND-CASE  --  Public
370;;;
371;;;    Grovel the awful thing and spit out the corresponding Cond.  See Echo
372;;; for the definition of COMMAND-CASE-HELP and logical char stuff.
373;;;
374(eval-when (:compile-toplevel :execute :load-toplevel)
375(defun command-case-tag (tag key-event char)
376  (cond ((and (characterp tag) (standard-char-p tag))
377         `(and ,char (char= ,char ,tag)))
378        ((and (symbolp tag) (keywordp tag))
379         `(logical-key-event-p ,key-event ,tag))
380        (t
381         (error "Tag in COMMAND-CASE is not a standard character or keyword: ~S"
382                tag))))
383); eval-when
384;;; 
385(defmacro command-case ((&key (prompt "Command character: ")
386                              (help "Choose one of the following characters:")
387                              (bind (gensym)))
388                        &body forms)
389  "This is analogous to the Common Lisp CASE macro.  Commands can use this
390   to get a key-event, translate it to a character, and then to dispatch on
391   the character to the specified case.  The syntax is
392   as follows:
393      (COMMAND-CASE ( {key value}* )
394        {( {( {tag}* )  |  tag}  help  {form}* )}*
395        )
396   Each tag is either a character or a logical key-event.  The user's typed
397   key-event is compared using either LOGICAL-KEY-EVENT-P or CHAR= of
398   KEY-EVENT-CHAR.
399
400   The legal keys of the key/value pairs are :help, :prompt, and :bind."
401  (do* ((forms forms (cdr forms))
402        (form (car forms) (car forms))
403        (cases ())
404        (bname (gensym))
405        (again (gensym))
406        (n-prompt (gensym))
407        (bind-char (gensym))
408        (docs ())
409        (t-case `(t (beep) (reprompt))))
410       ((atom forms)
411        `(macrolet ((reprompt ()
412                      `(progn
413                         (setf ,',bind
414                               (prompt-for-key-event :prompt ,',n-prompt))
415                         (setf ,',bind-char (key-event-char ,',bind))
416                         (go ,',again))))
417           (block ,bname
418             (let* ((,n-prompt ,prompt)
419                    (,bind (prompt-for-key-event :prompt ,n-prompt))
420                    (,bind-char (key-event-char ,bind)))
421               (declare (ignorable,bind ,bind-char))
422               (tagbody
423                ,again
424                (return-from
425                 ,bname
426                 (cond ,@(nreverse cases)
427                       ((logical-key-event-p ,bind :abort)
428                        (editor-error))
429                       ((logical-key-event-p ,bind :help)
430                        (command-case-help ,help ',(nreverse docs))
431                        (reprompt))
432                       ,t-case)))))))
433   
434    (cond ((atom form)
435           (error "Malformed Command-Case clause: ~S" form))
436          ((eq (car form) t)
437           (setq t-case form))
438          ((or (< (length form) 2)
439               (not (stringp (second form))))
440           (error "Malformed Command-Case clause: ~S" form))
441          (t
442           (let ((tag (car form))
443                 (rest (cddr form)))
444             (cond ((atom tag)
445                    (push (cons (command-case-tag tag bind bind-char) rest)
446                          cases)
447                    (setq tag (list tag)))
448                   (t
449                    (do ((tag tag (cdr tag))
450                         (res ()
451                              (cons (command-case-tag (car tag) bind bind-char)
452                                    res)))
453                        ((null tag)
454                         (push `((or ,@res) . ,rest) cases)))))
455             (push (cons tag (second form)) docs))))))
456
457   
458
459;;;; Some random macros used everywhere.
460
461(defmacro strlen (str) `(length (the simple-string ,str)))
462(defmacro neq (a b) `(not (eq ,a ,b)))
463
464
465
466;;;; Stuff from here on is implementation dependant.
467
468(defvar *saved-standard-output* nil)
469
470(defmacro with-output-to-listener (&body body)
471  `(let* ((*saved-standard-output* (or *saved-standard-output*
472                                       (cons *standard-output* *error-output*)))
473          (*standard-output* (hemlock-ext:top-listener-output-stream))
474          (*error-output* *standard-output*))
475     ,@body))
476
477(defmacro with-standard-standard-output (&body body)
478  `(let* ((*standard-output* (or (car *saved-standard-output*) *standard-output*))
479          (*error-output* (or (cdr *saved-standard-output*) *error-output*)))
480     ,@body))
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
526(defmacro with-pop-up-display ((var &key height title)
527                               &body body)
528
529  "Execute body in a context with var bound to a stream.  Output to the stream
530   appears in the buffer named buffer-name.  The pop-up display appears after
531   the body completes, but if you supply :height, the output is line buffered,
532   displaying any current output after each line."
533  (when (and (numberp height) (zerop height))
534    (editor-error "I doubt that you really want a window with no height"))
535  (let ((stream (gensym)))
536    `(let ()
537       (let ((,stream (gui::typeout-stream ,title)))
538         (clear-output ,stream)
539       (unwind-protect
540           (progn
541             (catch 'more-punt
542               (let ((,var ,stream))
543                 ,@body)))
544         (force-output ,stream))))))
545
546
547(declaim (special *random-typeout-ml-fields* *buffer-names*))
548
549(defvar *random-typeout-buffers* () "A list of random-typeout buffers.")
550
551
552
553;;;; Error handling stuff.
554
555(defmacro handle-lisp-errors (&body body)
556  "Handle-Lisp-Errors {Form}*
557  If a Lisp error happens during the evaluation of the body, then it is
558  handled in some fashion.  This should be used by commands which may
559  get a Lisp error due to some action of the user."
560  `(handler-bind ((error #'lisp-error-error-handler))
561     ,@body))
Note: See TracBrowser for help on using the repository browser.