source: trunk/ccl/hemlock/src/morecoms.lisp @ 2094

Last change on this file since 2094 was 2094, checked in by gb, 14 years ago

Dont do CHECK-REGION-QUERY-SIZE (I think that that's actually the real name ...).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 31.1 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock -*-
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;;; Written by Bill Chiles and Rob MacLachlan.
13;;;
14;;; Even more commands...
15
16(in-package :hemlock)
17
18(defhvar "Region Query Size"
19  "A number-of-lines threshold that destructive, undoable region commands
20   should ask the user about when the indicated region is too big."
21  :value 30)
22
23(defun check-region-query-size (region)
24  "Checks the number of lines in region against \"Region Query Size\" and
25   asks the user if the region crosses this threshold.  If the user responds
26   negatively, then an editor error is signaled."
27  (let ((threshold (or (value region-query-size) 0)))
28    (if (and (plusp threshold)
29             (>= (count-lines region) threshold)
30             (not (prompt-for-y-or-n
31                   :prompt "Region size exceeds \"Region Query Size\".  Confirm: "
32                   :must-exist t)))
33        (editor-error))))
34
35
36
37;;;; Casing commands...
38
39(defcommand "Uppercase Word" (p)
40  "Uppercase a word at point.
41   With prefix argument uppercase that many words."
42  "Uppercase p words at the point."
43  (filter-words p (current-point) #'string-upcase))
44
45(defcommand "Lowercase Word" (p)
46  "Uppercase a word at point.
47   With prefix argument uppercase that many words."
48  "Uppercase p words at the point."
49  (filter-words p (current-point) #'string-downcase))
50
51;;; FILTER-WORDS implements "Uppercase Word" and "Lowercase Word".
52;;;
53(defun filter-words (p point function)
54  (let ((arg (or p 1)))
55    (with-mark ((mark point))
56      (if (word-offset (if (minusp arg) mark point) arg)
57          (filter-region function (region mark point))
58          (editor-error "Not enough words.")))))
59
60;;; "Capitalize Word" is different than uppercasing and lowercasing because
61;;; the differences between Hemlock's notion of what a word is and Common
62;;; Lisp's notion are too annoying.
63;;;
64(defcommand "Capitalize Word" (p)
65  "Lowercase a word capitalizing the first character.  With a prefix
66  argument, capitalize that many words.  A negative argument capitalizes
67  words before the point, but leaves the point where it was."
68  "Capitalize p words at the point."
69  (let ((point (current-point))
70        (arg (or p 1)))
71    (with-mark ((start point :left-inserting)
72                (end point))
73      (when (minusp arg)
74        (unless (word-offset start arg) (editor-error "No previous word.")))
75      (do ((region (region start end))
76           (cnt (abs arg) (1- cnt)))
77          ((zerop cnt) (move-mark point end))
78        (unless (find-attribute start :word-delimiter #'zerop)
79          (editor-error "No next word."))
80        (move-mark end start)
81        (find-attribute end :word-delimiter)
82        (loop
83          (when (mark= start end)
84            (move-mark point end)
85            (editor-error "No alphabetic characters in word."))
86          (when (alpha-char-p (next-character start)) (return))
87          (character-offset start 1))
88        (setf (next-character start) (char-upcase (next-character start)))
89        (mark-after start)
90        (filter-region #'string-downcase region)))))
91
92(defcommand "Uppercase Region" (p)
93  "Uppercase words from point to mark."
94  "Uppercase words from point to mark."
95  (declare (ignore p))
96  (twiddle-region (current-region) #'string-upcase "Uppercase Region"))
97
98(defcommand "Lowercase Region" (p)
99  "Lowercase words from point to mark."
100  "Lowercase words from point to mark."
101  (declare (ignore p))
102  (twiddle-region (current-region) #'string-downcase "Lowercase Region"))
103
104;;; TWIDDLE-REGION implements "Uppercase Region" and "Lowercase Region".
105;;;
106(defun twiddle-region (region function name)
107  (let* (;; don't delete marks start and end since undo stuff will.
108         (start (copy-mark (region-start region) :left-inserting))
109         (end (copy-mark (region-end region) :left-inserting)))
110    (let* ((region (region start end))
111           (undo-region (copy-region region)))
112      (filter-region function region)
113      (make-region-undo :twiddle name region undo-region))))
114
115
116
117;;;; More stuff.
118
119(defcommand "Delete Previous Character Expanding Tabs" (p)
120  "Delete the previous character.
121  When deleting a tab pretend it is the equivalent number of spaces.
122  With prefix argument, do it that many times."
123  "Delete the P previous characters, expanding tabs into spaces."
124  (let ((point (current-point))
125        (n (or p 1)))
126    (when (minusp n)
127      (editor-error "Delete Previous Character Expanding Tabs only accepts ~
128                     positive arguments."))
129    ;; Pre-calculate the number of characters that need to be deleted
130    ;; and any remaining white space filling, allowing modification to
131    ;; be avoided if there are not enough characters to delete.
132    (let ((errorp nil)
133          (del 0)
134          (fill 0))
135      (with-mark ((mark point))
136        (dotimes (i n)
137          (if (> fill 0)
138              (decf fill)
139              (let ((prev (previous-character mark)))
140                (cond ((and prev (char= prev #\tab))
141                       (let ((pos (mark-column mark)))
142                         (mark-before mark)
143                         (incf fill (- pos (mark-column mark) 1)))
144                       (incf del))
145                      ((mark-before mark)
146                       (incf del))
147                      (t
148                       (setq errorp t)
149                       (return)))))))
150      (cond ((and (not errorp) (kill-characters point (- del)))
151             (with-mark ((mark point :left-inserting))
152               (dotimes (i fill)
153                 (insert-character mark #\space))))
154            (t
155             (editor-error "There were not ~D characters before point." n))))))
156
157
158(defvar *scope-table*
159  (list (make-string-table :initial-contents
160                           '(("Global" . :global)
161                             ("Buffer" . :buffer)
162                             ("Mode" . :mode)))))
163
164(defun prompt-for-place (prompt help)
165  (multiple-value-bind (word val)
166                       (prompt-for-keyword *scope-table* :prompt prompt
167                                           :help help :default "Global")
168    (declare (ignore word))
169    (case val
170      (:buffer
171       (values :buffer (prompt-for-buffer :help "Buffer to be local to."
172                                          :default (current-buffer))))
173      (:mode
174       (values :mode (prompt-for-keyword 
175                      (list *mode-names*)
176                      :prompt "Mode: "
177                      :help "Mode to be local to."
178                      :default (buffer-major-mode (current-buffer)))))
179      (:global :global))))
180
181(defcommand "Bind Key" (p)
182  "Bind a command to a key.
183  The command, key and place to make the binding are prompted for."
184  "Prompt for stuff to do a bind-key."
185  (declare (ignore p))
186  (multiple-value-call #'bind-key 
187    (values (prompt-for-keyword
188             (list *command-names*)
189             :prompt "Command to bind: "
190             :help "Name of command to bind to a key."))
191    (values (prompt-for-key 
192             :prompt "Bind to: "  :must-exist nil
193             :help "Key to bind command to, confirm to complete."))
194    (prompt-for-place "Kind of binding: "
195                      "The kind of binding to make.")))             
196
197(defcommand "Delete Key Binding" (p)
198  "Delete a key binding.
199  The key and place to remove the binding are prompted for."
200  "Prompt for stuff to do a delete-key-binding."
201  (declare (ignore p))
202  (let ((key (prompt-for-key 
203              :prompt "Delete binding: " :must-exist nil 
204              :help "Key to delete binding from.")))
205    (multiple-value-bind (kind where)
206                         (prompt-for-place "Kind of binding: "
207                                           "The kind of binding to make.")
208      (unless (get-command key kind where) 
209        (editor-error "No such binding: ~S" key))
210      (delete-key-binding key kind where))))
211
212
213(defcommand "Set Variable" (p)
214  "Prompt for a Hemlock variable and a new value."
215  "Prompt for a Hemlock variable and a new value."
216  (declare (ignore p))
217  (multiple-value-bind (name var)
218                       (prompt-for-variable
219                        :prompt "Variable: "
220                        :help "The name of a variable to set.")
221    (declare (ignore name))
222    (setf (variable-value var)
223          (handle-lisp-errors
224           (eval (prompt-for-expression
225                  :prompt "Value: "
226                  :help "Expression to evaluate for new value."))))))
227
228(defcommand "Defhvar" (p)
229  "Define a hemlock variable in some location.  If the named variable exists
230   currently, its documentation is propagated to the new instance, but this
231   never prompts for documentation."
232  "Define a hemlock variable in some location."
233  (declare (ignore p))
234  (let* ((name (nstring-capitalize (prompt-for-variable :must-exist nil)))
235         (var (string-to-variable name))
236         (doc (if (hemlock-bound-p var)
237                  (variable-documentation var)
238                  ""))
239         (hooks (if (hemlock-bound-p var) (variable-hooks var)))
240         (val (prompt-for-expression :prompt "Variable value: "
241                                     :help "Value for the variable.")))
242    (multiple-value-bind
243        (kind where)
244        (prompt-for-place
245         "Kind of binding: "
246         "Whether the variable is global, mode, or buffer specific.")
247      (if (eq kind :global)
248          (defhvar name doc :value val :hooks hooks)
249          (defhvar name doc kind where :value val :hooks hooks)))))
250
251
252(defcommand "List Buffers" (p)
253  "Show a list of all buffers.
254   If the buffer is modified then a * is displayed before the name.  If there
255   is an associated file then it's name is displayed last.  With prefix
256   argument, only list modified buffers."
257  "Display the names of all buffers in a with-random-typeout window."
258  (with-pop-up-display (s)
259    (do-strings (n b *buffer-names*)
260      (declare (simple-string n))
261      (unless (or (eq b *echo-area-buffer*)
262                  (assoc b *random-typeout-buffers* :test #'eq))
263        (let ((modified (buffer-modified b))
264              (buffer-pathname (buffer-pathname b)))
265          (when (or (not p) modified)
266            (write-char (if modified #\* #\space) s)
267            (if buffer-pathname
268                (format s "~A  ~25T~A~:[~68T~A~;~]~%"
269                        (file-namestring buffer-pathname)
270                        (directory-namestring buffer-pathname)
271                        (string= (pathname-to-buffer-name buffer-pathname) n)
272                        n)
273                (format s "~A~68T~D Line~:P~%"
274                        n (count-lines (buffer-region b))))))))))
275
276(defcommand "Select Random Typeout Buffer" (p)
277  "Select last random typeout buffer."
278  "Select last random typeout buffer."
279  (declare (ignore p))
280  (if *random-typeout-buffers*
281      (change-to-buffer (caar *random-typeout-buffers*))
282      (editor-error "There are no random typeout buffers.")))
283
284
285(defcommand "Room" (p)
286  "Display stats on allocated storage."
287  "Run Room into a With-Random-Typeout window."
288  (declare (ignore p))
289  (with-pop-up-display (*standard-output*)
290    (room)))
291
292
293;;; This is used by the :edit-level modeline field which is defined in Main.Lisp.
294;;;
295(defvar *recursive-edit-count* 0)
296
297(defun do-recursive-edit ()
298  "Does a recursive edit, wrapping []'s around the modeline of the current
299  window during its execution.  The current window and buffer are saved
300  beforehand and restored afterward.  If they have been deleted by the
301  time the edit is done then an editor-error is signalled."
302  (let* ((win (current-window))
303         (buf (current-buffer)))
304    (unwind-protect
305        (let ((*recursive-edit-count* (1+ *recursive-edit-count*)))
306          (update-modeline-field *echo-area-buffer* *echo-area-window*
307                                 (modeline-field :edit-level))
308          (recursive-edit))
309      (update-modeline-field *echo-area-buffer* *echo-area-window*
310                             (modeline-field :edit-level))
311      (unless (and (member win *window-list*) (memq buf *buffer-list*))
312        (editor-error "Old window or buffer has been deleted."))
313      (setf (current-window) win)
314      (unless (eq (window-buffer win) buf)
315        (setf (window-buffer win) buf))
316      (setf (current-buffer) buf))))
317
318(defcommand "Exit Recursive Edit" (p)
319  "Exit a level of recursive edit.  Signals an error when not in a
320   recursive edit."
321  "Exit a level of recursive edit.  Signals an error when not in a
322   recursive edit."
323  (declare (ignore p))
324  (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
325  (exit-recursive-edit ()))
326
327(defcommand "Abort Recursive Edit" (p)
328  "Abort the current recursive edit.  Signals an error when not in a
329   recursive edit."
330  "Abort the current recursive edit.  Signals an error when not in a
331   recursive edit."
332  (declare (ignore p))
333  (unless (in-recursive-edit) (editor-error "Not in a recursive edit!"))
334  (abort-recursive-edit "Recursive edit aborted."))
335
336
337;;; TRANSPOSE REGIONS uses CURRENT-REGION to signal an error if the current
338;;; region is not active and to get start2 and end2 in proper order.  Delete1,
339;;; delete2, and delete3 are necessary since we are possibly ROTATEF'ing the
340;;; locals end1/start1, start1/start2, and end1/end2, and we need to know which
341;;; marks to dispose of at the end of all this stuff.  When we actually get to
342;;; swapping the regions, we must delete both up front if they both are to be
343;;; deleted since we don't know what kind of marks are in start1, start2, end1,
344;;; and end2, and the marks will be moving around unpredictably as we insert
345;;; text at them.  We copy point into ipoint for insertion purposes since one
346;;; of our four marks is the point.
347;;;
348(defcommand "Transpose Regions" (p)
349  "Transpose two regions with endpoints defined by the mark stack and point.
350   To use:  mark start of region1, mark end of region1, mark start of region2,
351   and place point at end of region2.  Invoking this immediately following
352   one use will put the regions back, but you will have to activate the
353   current region."
354  "Transpose two regions with endpoints defined by the mark stack and point."
355  (declare (ignore p))
356  (unless (>= (ring-length (value buffer-mark-ring)) 3)
357    (editor-error "Need two marked regions to do Transpose Regions."))
358  (let* ((region (current-region))
359         (end2 (region-end region))
360         (start2 (region-start region))
361         (delete1 (pop-buffer-mark))
362         (end1 (pop-buffer-mark))
363         (delete2 end1)
364         (start1 (pop-buffer-mark))
365         (delete3 start1))
366    ;;get marks in the right order, to simplify the code that follows
367    (unless (mark<= start1 end1) (rotatef start1 end1))
368    (unless (mark<= start1 start2)
369      (rotatef start1 start2)
370      (rotatef end1 end2))
371    ;;order now guaranteed:  <Buffer Start> start1 end1 start2 end2 <Buffer End>
372    (unless (mark<= end1 start2)
373      (editor-error "Can't transpose overlapping regions."))
374    (let* ((adjacent-p (mark= end1 start2))
375           (region1 (delete-and-save-region (region start1 end1)))
376           (region2 (unless adjacent-p
377                      (delete-and-save-region (region start2 end2))))
378           (point (current-point)))
379      (with-mark ((ipoint point :left-inserting))
380        (let ((save-end2-loc (push-buffer-mark (copy-mark end2))))
381          (ninsert-region (move-mark ipoint end2) region1)
382          (push-buffer-mark (copy-mark ipoint))
383          (cond (adjacent-p
384                 (push-buffer-mark (copy-mark start2))
385                 (move-mark point save-end2-loc))
386                (t (push-buffer-mark (copy-mark end1))
387                   (ninsert-region (move-mark ipoint end1) region2)
388                   (move-mark point ipoint))))))
389    (delete-mark delete1)
390    (delete-mark delete2)
391    (delete-mark delete3)))
392
393
394(defcommand "Goto Absolute Line" (p)
395  "Goes to the indicated line, if you counted them starting at the beginning
396   of the buffer with the number one.  If a prefix argument is supplied, that
397   is the line numbe; otherwise, the user is prompted."
398  "Go to a user perceived line number."
399  (let ((p (or p (prompt-for-expression
400                  :prompt "Line number: "
401                  :help "Enter an absolute line number to goto."))))
402    (unless (and (integerp p) (plusp p))
403      (editor-error "Must supply a positive integer."))
404    (let ((point (current-point)))
405      (with-mark ((m point))
406        (unless (line-offset (buffer-start m) (1- p) 0)
407          (editor-error "Not enough lines in buffer."))
408        (move-mark point m)))))
409
410
411
412;;;; Mouse Commands.
413
414(defcommand "Do Nothing" (p)
415  "Do nothing.
416  With prefix argument, do it that many times."
417  "Do nothing p times."
418  (dotimes (i (or p 1)))
419  (setf (last-command-type) (last-command-type)))
420
421(defun do-nothing (&rest args)
422  (declare (ignore args))
423  nil)
424
425(defun maybe-change-window (window)
426  (unless (eq window (current-window))
427    (when (or (eq window *echo-area-window*)
428              (eq (current-window) *echo-area-window*)
429              (member window *random-typeout-buffers*
430                      :key #'(lambda (cons)
431                               (hi::random-typeout-stream-window (cdr cons)))))
432      (supply-generic-pointer-up-function #'do-nothing)
433      (editor-error "I'm afraid I can't let you do that Dave."))
434    (setf (current-window) window)
435    (let ((buffer (window-buffer window)))
436      (unless (eq (current-buffer) buffer)
437        (setf (current-buffer) buffer)))))
438
439(defcommand "Top Line to Here" (p)
440  "Move the top line to the line the mouse is on.
441  If in the first two columns then scroll continuously until the button is
442  released."
443  "Move the top line to the line the mouse is on."
444  (declare (ignore p))
445  (multiple-value-bind (x y window)
446                       (last-key-event-cursorpos)
447    (unless y (editor-error))
448    (cond ((< x 2)
449           (loop
450             (when (listen-editor-input *editor-input*) (return))
451             (scroll-window window -1)
452             (redisplay)
453             (editor-finish-output window)))
454          (t
455           (scroll-window window (- y))))))
456
457(defcommand "Here to Top of Window" (p)
458  "Move the line the mouse is on to the top of the window.
459  If in the first two columns then scroll continuously until the button is
460  released."
461  "Move the line the mouse is on to the top of the window."
462  (declare (ignore p))
463  (multiple-value-bind (x y window)
464                       (last-key-event-cursorpos)
465    (unless y (editor-error))
466    (cond ((< x 2)
467           (loop
468             (when (listen-editor-input *editor-input*) (return))
469             (scroll-window window 1)
470             (redisplay)
471             (editor-finish-output window)))
472          (t
473           (scroll-window window y)))))
474
475
476(defvar *generic-pointer-up-fun* nil
477  "This is the function for the \"Generic Pointer Up\" command that defines
478   its action.  Other commands set this in preparation for this command's
479   invocation.")
480;;;
481(defun supply-generic-pointer-up-function (fun)
482  "This provides the action \"Generic Pointer Up\" command performs."
483  (check-type fun function)
484  (setf *generic-pointer-up-fun* fun))
485
486(defcommand "Generic Pointer Up" (p)
487  "Other commands determine this command's action by supplying functions that
488   this command invokes.  The following built-in commands supply the following
489   generic up actions:
490      \"Point to Here\"
491         When the position of the pointer is different than the current
492         point, the action pushes a buffer mark at point and moves point
493         to the pointer's position.
494      \"Bufed Goto and Quit\"
495         The action is a no-op."
496  "Invoke whatever is on *generic-pointer-up-fun*."
497  (declare (ignore p))
498  (unless *generic-pointer-up-fun*
499    (editor-error "No commands have supplied a \"Generic Pointer Up\" action."))
500  (funcall *generic-pointer-up-fun*))
501
502
503(defcommand "Point to Here" (p)
504  "Move the point to the position of the mouse.
505   If in the modeline, move to the absolute position in the file indicated by
506   the position within the modeline, pushing the old position on the mark
507   stack.  This supplies a function \"Generic Pointer Up\" invokes if it runs
508   without any intervening generic pointer up predecessors running.  If the
509   position of the pointer is different than the current point when the user
510   invokes \"Generic Pointer Up\", then this function pushes a buffer mark at
511   point and moves point to the pointer's position.  This allows the user to
512   mark off a region with the mouse."
513  "Move the point to the position of the mouse."
514  (declare (ignore p))
515  (multiple-value-bind (x y window)
516                       (last-key-event-cursorpos)
517    (unless x (editor-error))
518    (maybe-change-window window)
519    (if y
520        (let ((m (cursorpos-to-mark x y window)))
521          (unless m (editor-error))
522          (move-mark (current-point) m))
523        (let* ((buffer (window-buffer window))
524               (region (buffer-region buffer))
525               (point (buffer-point buffer)))
526          (push-buffer-mark (copy-mark point))
527          (move-mark point (region-start region))
528          (line-offset point (round (* (1- (count-lines region)) x)
529                                    (1- (window-width window)))))))
530  (supply-generic-pointer-up-function #'point-to-here-up-action))
531
532(defun point-to-here-up-action ()
533  (multiple-value-bind (x y window)
534                       (last-key-event-cursorpos)
535    (unless x (editor-error))
536    (when y
537      (maybe-change-window window)
538      (let ((m (cursorpos-to-mark x y window)))
539        (unless m (editor-error))
540        (when (eq (line-buffer (mark-line (current-point)))
541                  (line-buffer (mark-line m)))
542          (unless (mark= m (current-point))
543            (push-buffer-mark (copy-mark (current-point)) t)))
544        (move-mark (current-point) m)))))
545
546
547(defcommand "Insert Kill Buffer" (p)
548  "Move current point to the mouse location and insert the kill buffer."
549  "Move current point to the mouse location and insert the kill buffer."
550  (declare (ignore p))
551  (multiple-value-bind (x y window)
552                       (last-key-event-cursorpos)
553    (unless x (editor-error))
554    (maybe-change-window window)
555    (if y
556        (let ((m (cursorpos-to-mark x y window)))
557          (unless m (editor-error))
558          (move-mark (current-point) m)
559          (un-kill-command nil))
560        (editor-error "Can't insert kill buffer in modeline."))))
561
562
563
564;;;; Page commands & stuff.
565
566(defvar *goto-page-last-num* 0)
567(defvar *goto-page-last-string* "")
568
569(defcommand "Goto Page" (p)
570  "Go to an absolute page number (argument).  If no argument, then go to
571  next page.  A negative argument moves back that many pages if possible.
572  If argument is zero, prompt for string and goto page with substring
573  in title."
574  "Go to an absolute page number (argument).  If no argument, then go to
575  next page.  A negative argument moves back that many pages if possible.
576  If argument is zero, prompt for string and goto page with substring
577  in title."
578  (let ((point (current-point)))
579    (cond ((not p)
580           (page-offset point 1))
581          ((zerop p)
582           (let* ((againp (eq (last-command-type) :goto-page-zero))
583                  (name (prompt-for-string :prompt "Substring of page title: "
584                                           :default (if againp
585                                                        *goto-page-last-string*
586                                                        *parse-default*)))
587                  (dir (page-directory (current-buffer)))
588                  (i 1))
589             (declare (simple-string name))
590             (cond ((not againp)
591                    (push-buffer-mark (copy-mark point)))
592                   ((string-equal name *goto-page-last-string*)
593                    (setf dir (nthcdr *goto-page-last-num* dir))
594                    (setf i (1+ *goto-page-last-num*))))
595             (loop 
596               (when (null dir)
597                 (editor-error "No page title contains ~S." name))
598               (when (search name (the simple-string (car dir))
599                             :test #'char-equal)
600                 (goto-page point i)
601                 (setf (last-command-type) :goto-page-zero)
602                 (setf *goto-page-last-num* i)
603                 (setf *goto-page-last-string* name)
604                 (return t))
605               (incf i)
606               (setf dir (cdr dir)))))
607            ((minusp p)
608             (page-offset point p))
609            (t (goto-page point p)))
610    (line-start (move-mark (window-display-start (current-window)) point))))
611
612(defun goto-page (mark i)
613  (with-mark ((m mark))
614    (buffer-start m)
615    (unless (page-offset m (1- i))
616      (editor-error "No page numbered ~D." i))
617    (move-mark mark m)))
618
619                           
620(defcommand "View Page Directory" (p)
621  "Print a listing of the first non-blank line after each page mark
622   in a pop-up window."
623  "Print a listing of the first non-blank line after each page mark
624   in a pop-up window."
625  (declare (ignore p))
626  (let ((dir (page-directory (current-buffer))))
627    (declare (list dir))
628    (with-pop-up-display (s :height (1+ (the fixnum (length dir))))
629      (display-page-directory s dir))))
630
631(defcommand "Insert Page Directory" (p)
632  "Insert a listing of the first non-blank line after each page mark at
633   the beginning of the buffer.  A mark is dropped before going to the
634   beginning of the buffer.  If an argument is supplied, insert the page
635   directory at point."
636  "Insert a listing of the first non-blank line after each page mark at
637   the beginning of the buffer."
638  (let ((point (current-point)))
639    (unless p
640      (push-buffer-mark (copy-mark point))
641      (buffer-start point))
642    (push-buffer-mark (copy-mark point))
643    (display-page-directory (make-hemlock-output-stream point :full)
644                            (page-directory (current-buffer))))
645  (setf (last-command-type) :ephemerally-active))
646
647(defun display-page-directory (stream directory)
648  "This writes the list of strings, directory, to stream, enumerating them
649   in a field of three characters.  The number and string are separated by
650   two spaces, and the first line contains headings for the numbers and
651   strings columns."
652  (write-line "Page    First Non-blank Line" stream)
653  (do ((dir directory (cdr dir))
654       (count 1 (1+ count)))
655      ((null dir))
656    (declare (fixnum count))
657    (format stream "~3D  " count)
658    (write-line (car dir) stream)))
659
660(defun page-directory (buffer)
661  "Return a list of strings where each is the first non-blank line
662   following a :page-delimiter in buffer."
663  (with-mark ((m (buffer-point buffer)))
664    (buffer-start m)
665    (let ((end-of-buffer (buffer-end-mark buffer)) result)
666      (loop ;over pages.
667        (loop ;for first non-blank line.
668          (cond ((not (blank-after-p m))
669                 (let* ((str (line-string (mark-line m)))
670                        (len (length str)))
671                   (declare (simple-string str))
672                   (push (if (and (> len 1)
673                                  (= (character-attribute :page-delimiter
674                                                          (schar str 0))
675                                     1))
676                             (subseq str 1)
677                             str)
678                         result))
679                 (unless (page-offset m 1)
680                   (return-from page-directory (nreverse result)))
681                 (when (mark= m end-of-buffer)
682                   (return-from page-directory (nreverse result)))
683                 (return))
684                ((not (line-offset m 1 0))
685                 (return-from page-directory (nreverse result)))
686                ((= (character-attribute :page-delimiter (next-character m))
687                    1)
688                 (push "" result)
689                 (mark-after m)
690                 (return))))))))
691
692
693(defcommand "Previous Page" (p)
694  "Move to the beginning of the current page.
695  With prefix argument move that many pages."
696  "Move backward P pages."
697  (let ((point (current-point)))
698    (unless (page-offset point (- (or p 1)))
699      (editor-error "No such page."))
700    (line-start (move-mark (window-display-start (current-window)) point))))
701
702(defcommand "Next Page" (p)
703  "Move to the beginning of the next page.
704  With prefix argument move that many pages."
705  "Move forward P pages."
706  (let ((point (current-point)))
707    (unless (page-offset point (or p 1))
708      (editor-error "No such page."))
709    (line-start (move-mark (window-display-start (current-window)) point))))
710
711(defcommand "Mark Page" (p)
712  "Put point at beginning, mark at end of current page.
713   With prefix argument, mark the page that many pages after the current one."
714  "Mark the P'th page after the current one."
715  (let ((point (current-point)))
716    (if p
717        (unless (page-offset point (1+ p)) (editor-error "No such page."))
718        (page-offset point 1)) ;If this loses, we're at buffer-end.
719    (with-mark ((m point))
720      (unless (page-offset point -1)
721        (editor-error "No such page."))
722      (push-buffer-mark (copy-mark m) t)
723      (line-start (move-mark (window-display-start (current-window)) point)))))
724
725(defun page-offset (mark n)
726  "Move mark past n :page-delimiters that are in the zero'th line position.
727   If a :page-delimiter is the immediately next character after mark in the
728   appropriate direction, then skip it before starting."
729  (cond ((plusp n)
730         (find-attribute mark :page-delimiter #'zerop)
731         (dotimes (i n mark)
732           (unless (next-character mark) (return nil))
733           (loop
734             (unless (find-attribute mark :page-delimiter)
735               (return-from page-offset nil))
736             (unless (mark-after mark)
737               (return (if (= i (1- n)) mark)))
738             (when (= (mark-charpos mark) 1) (return)))))
739        (t
740         (reverse-find-attribute mark :page-delimiter #'zerop)
741         (prog1
742          (dotimes (i (- n) mark)
743            (unless (previous-character mark) (return nil))
744            (loop
745              (unless (reverse-find-attribute mark :page-delimiter)
746                (return-from page-offset nil))
747              (mark-before mark)
748              (when (= (mark-charpos mark) 0) (return))))
749          (let ((buffer (line-buffer (mark-line mark))))
750            (unless (or (not buffer) (mark= mark (buffer-start-mark buffer)))
751              (mark-after mark)))))))
752
753
754
755;;;; Counting some stuff
756
757(defcommand "Count Lines Page" (p)
758  "Display number of lines in current page and position within page.
759   With prefix argument do on entire buffer."
760  "Count some lines, Man."
761  (let ((point (current-point)))
762    (if p
763        (let ((r (buffer-region (current-buffer))))
764          (count-lines-function "Buffer" (region-start r) point (region-end r)))
765        (with-mark ((m1 point)
766                    (m2 point))
767          (unless (and (= (character-attribute :page-delimiter
768                                               (previous-character m1))
769                          1)
770                       (= (mark-charpos m1) 1))
771            (page-offset m1 -1))
772          (unless (and (= (character-attribute :page-delimiter
773                                               (next-character m2))
774                          1)
775                       (= (mark-charpos m2) 0))
776            (page-offset m2 1))
777          (count-lines-function "Page" m1 point m2)))))
778
779(defun count-lines-function (msg start mark end)
780  (let ((before (1- (count-lines (region start mark))))
781        (after (count-lines (region mark end))))
782    (message "~A: ~D lines, ~D/~D" msg (+ before after) before after)))
783
784(defcommand "Count Lines" (p)
785  "Display number of lines in the region."
786  "Display number of lines in the region."
787  (declare (ignore p))
788  (multiple-value-bind (region activep) (get-count-region)
789    (message "~:[After point~;Active region~]: ~A lines"
790             activep (count-lines region))))
791
792(defcommand "Count Words" (p)
793  "Prints in the Echo Area the number of words in the region
794   between the point and the mark by using word-offset. The
795   argument is ignored."
796  "Prints Number of Words in the Region"
797  (declare (ignore p))
798  (multiple-value-bind (region activep) (get-count-region)
799    (let ((end-mark (region-end region)))
800      (with-mark ((beg-mark (region-start region)))
801        (let ((word-count 0))
802          (loop
803            (when (mark>= beg-mark end-mark)
804              (return))
805            (unless (word-offset beg-mark 1)
806              (return))
807            (incf word-count))
808          (message "~:[After point~;Active region~]: ~D Word~:P"
809                   activep word-count))))))
810
811;;; GET-COUNT-REGION -- Internal Interface.
812;;;
813;;; Returns the active region or the region between point and end-of-buffer.
814;;; As a second value, it returns whether the region was active.
815;;;
816;;; Some searching commands use this routine.
817;;;
818(defun get-count-region ()
819  (if (region-active-p)
820      (values (current-region) t)
821      (values (region (current-point) (buffer-end-mark (current-buffer)))
822              nil)))
823
824
825
826;;;; Some modes:
827
828(defcommand "Fundamental Mode" (p)
829  "Put the current buffer into \"Fundamental\" mode."
830  "Put the current buffer into \"Fundamental\" mode."
831  (declare (ignore p))
832  (setf (buffer-major-mode (current-buffer)) "Fundamental"))
833
834;;;
835;;; Text mode.
836;;;
837
838(defmode "Text" :major-p t)
839
840(defcommand "Text Mode" (p)
841  "Put the current buffer into \"Text\" mode."
842  "Put the current buffer into \"Text\" mode."
843  (declare (ignore p))
844  (setf (buffer-major-mode (current-buffer)) "Text"))
845
846;;;
847;;; Caps-lock mode.
848;;;
849
850(defmode "CAPS-LOCK")
851
852(defcommand "Caps Lock Mode" (p)
853  "Simulate having a CAPS LOCK key.  Toggle CAPS-LOCK mode.  Zero or a
854   negative argument turns it off, while a positive argument turns it
855   on."
856  "Simulate having a CAPS LOCK key.  Toggle CAPS-LOCK mode.  Zero or a
857   negative argument turns it off, while a positive argument turns it
858   on."
859  (setf (buffer-minor-mode (current-buffer) "CAPS-LOCK")
860        (if p
861            (plusp p)
862            (not (buffer-minor-mode (current-buffer) "CAPS-LOCK")))))
863
864(defcommand "Self Insert Caps Lock" (p)
865  "Insert the last character typed, or the argument number of them.
866   If the last character was an alphabetic character, then insert its
867   capital form."
868  "Insert the last character typed, or the argument number of them.
869   If the last character was an alphabetic character, then insert its
870   capital form."
871  (let ((char (char-upcase (hemlock-ext:key-event-char *last-key-event-typed*))))
872    (if (and p (> p 1))
873        (insert-string (current-point) (make-string p :initial-element char))
874        (insert-character (current-point) char))))
Note: See TracBrowser for help on using the repository browser.