source: trunk/ccl/hemlock/src/command.lisp @ 2115

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

The "Next Line" command doesn't insert newlines at the end of the buffer
by default; there's a global Hemlock variable that controls this behavior.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.5 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;;; This file contains the definitions for the basic Hemlock commands.
13;;;
14
15(in-package :hemlock)
16
17
18;;; Make a mark for buffers as they're consed:
19
20(defun hcmd-new-buffer-hook-fun (buff)
21  (let ((ring (make-ring 10 #'delete-mark)))
22    (defhvar "Buffer Mark Ring" 
23      "This variable holds this buffer's mark ring."
24      :buffer buff
25      :value ring)
26    (setf (hi::buffer-%mark buff) (copy-mark (buffer-point buff) :right-inserting))))
27
28(add-hook make-buffer-hook #'hcmd-new-buffer-hook-fun)
29(dolist (buff *buffer-list*) (hcmd-new-buffer-hook-fun buff))
30
31(defcommand "Exit Hemlock" (p)
32  "Exit hemlock returning to the Lisp top-level read-eval-print loop."
33  "Exit hemlock returning to the Lisp top-level read-eval-print loop."
34  (declare (ignore p))
35  (exit-hemlock))
36
37(defcommand "Pause Hemlock" (p)
38  "Pause the Hemlock/Lisp process returning to the process that invoked the
39   Lisp."
40  "Pause the Hemlock/Lisp process returning to the process that invoked the
41   Lisp."
42  (declare (ignore p))
43  (pause-hemlock))
44
45
46
47;;;; Simple character manipulation:
48
49(defcommand "Self Insert" (p)
50  "Insert the last character typed.
51  With prefix argument insert the character that many times."
52  "Implements ``Self Insert'', calling this function is not meaningful."
53  (let ((char (hemlock-ext:key-event-char *last-key-event-typed*)))
54    (unless char (editor-error "Can't insert that character."))
55    (if (and p (> p 1))
56        (insert-string
57         (current-point)
58         (make-string p :initial-element char))
59        (insert-character (current-point) char))))
60
61(defcommand "Quoted Insert" (p)
62  "Read a character from the terminal and insert it.
63  With prefix argument, insert the character that many times."
64  "Reads a key-event from *editor-input* and inserts it at the point."
65  (let ((char (hemlock-ext:key-event-char (get-key-event *editor-input* t)))
66        (point (current-point)))
67    (unless char (editor-error "Can't insert that character."))
68    (if (and p (> p 1))
69        (insert-string point (make-string p :initial-element char))
70        (insert-character point char))))
71
72(defcommand "Forward Character" (p)
73  "Move the point forward one character.
74   With prefix argument move that many characters, with negative argument
75   go backwards."
76  "Move the point of the current buffer forward p characters."
77  (let ((p (or p 1)))
78    (cond ((character-offset (current-point) p))
79          ((= p 1)
80           (editor-error "No next character."))
81          ((= p -1)
82           (editor-error "No previous character."))
83          (t
84           (if (plusp p)
85               (buffer-end (current-point))
86               (buffer-start (current-point)))
87           (editor-error "Not enough characters.")))))
88
89(defcommand "Backward Character" (p)
90  "Move the point backward one character.
91  With prefix argument move that many characters backward."
92  "Move the point p characters backward."
93  (forward-character-command (if p (- p) -1)))
94
95#|
96(defcommand "Delete Next Character" (p)
97  "Deletes the character to the right of the point.
98  With prefix argument, delete that many characters to the right
99  (or left if prefix is negative)."
100  "Deletes p characters to the right of the point."
101  (unless (delete-characters (current-point) (or p 1))
102    (buffer-end (current-point))
103    (editor-error "No next character.")))
104
105(defcommand "Delete Previous Character" (p)
106  "Deletes the character to the left of the point.
107  With prefix argument, delete that many characters to the left
108  (or right if prefix is negative)."
109  "Deletes p characters to the left of the point."
110  (unless (delete-characters (current-point) (if p (- p) -1))
111    (editor-error "No previous character.")))
112|#
113
114(defcommand "Delete Next Character" (p)
115  "Deletes the character to the right of the point.
116   With prefix argument, delete that many characters to the right
117  (or left if prefix is negative)."
118  "Deletes p characters to the right of the point."
119  (cond ((kill-characters (current-point) (or p 1)))
120        ((and p (minusp p))
121         (editor-error "Not enough previous characters."))
122        (t
123         (editor-error "Not enough next characters."))))
124
125(defcommand "Delete Previous Character" (p)
126  "Deletes the character to the left of the point.
127   Will push characters from successive deletes on to the kill ring."
128  "Deletes the character to the left of the point.
129   Will push characters from successive deletes on to the kill ring."
130  (delete-next-character-command (- (or p 1))))
131
132(defcommand "Transpose Characters" (p)
133  "Exchanges the characters on either side of the point and moves forward
134  With prefix argument, does this that many times.  A negative prefix
135  argument causes the point to be moved backwards instead of forwards."
136  "Exchanges the characters on either side of the point and moves forward."
137  (let ((arg (or p 1))
138        (point (current-point)))
139    (dotimes (i (abs arg))
140      (when (minusp arg) (mark-before point))
141      (let ((prev (previous-character point))
142            (next (next-character point)))
143
144        (cond ((not prev) (editor-error "No previous character."))
145              ((not next) (editor-error "No next character."))
146              (t
147               (setf (previous-character point) next)
148               (setf (next-character point) prev))))
149      (when (plusp arg) (mark-after point)))))
150
151;;;; Word hacking commands:
152
153;;; WORD-OFFSET
154;;;
155;;;    Move a mark forward/backward some words.
156;;;
157(defun word-offset (mark offset)
158  "Move Mark by Offset words."
159  (if (minusp offset)
160      (do ((cnt offset (1+ cnt)))
161          ((zerop cnt) mark)
162        (cond
163         ((null (reverse-find-attribute mark :word-delimiter #'zerop))
164          (return nil))
165         ((reverse-find-attribute mark :word-delimiter))
166         (t
167          (move-mark
168           mark (buffer-start-mark (line-buffer (mark-line mark)))))))
169      (do ((cnt offset (1- cnt)))
170          ((zerop cnt) mark)
171        (cond
172         ((null (find-attribute mark :word-delimiter #'zerop))
173          (return nil))
174         ((null (find-attribute mark :word-delimiter))
175          (return nil))))))
176
177(defcommand "Forward Word" (p)
178  "Moves forward one word.
179  With prefix argument, moves the point forward over that many words."
180  "Moves the point forward p words."
181  (cond ((word-offset (current-point) (or p 1)))
182        ((and p (minusp p))
183         (buffer-start (current-point))
184         (editor-error "No previous word."))
185        (t
186         (buffer-end (current-point))
187         (editor-error "No next word."))))
188
189(defcommand "Backward Word" (p)
190  "Moves forward backward word.
191  With prefix argument, moves the point back over that many words."
192  "Moves the point backward p words."
193  (forward-word-command (- (or p 1))))
194
195
196
197;;;; Moving around:
198
199(defvar *target-column* 0)
200
201(defun set-target-column (mark)
202  (if (eq (last-command-type) :line-motion)
203      *target-column*
204      (setq *target-column* (mark-column mark))))
205
206(defhvar "Next Line Inserts Newlines"
207    "If true, causes the \"Next Line\" command to insert newlines when
208     moving past the end of the buffer."
209  :value nil)
210
211
212(defcommand "Next Line" (p)
213  "Moves the point to the next line.
214   With prefix argument, moves the point that many lines down (or up if
215   the prefix is negative)."
216  "Moves the down p lines."
217  (let* ((point (current-point))
218         (target (set-target-column point)))
219    (unless (line-offset point (or p 1))
220      (when (value next-line-inserts-newlines)
221        (cond ((not p)
222               (when (same-line-p point (buffer-end-mark (current-buffer)))
223                 (line-end point))
224               (insert-character point #\newline))
225              ((minusp p)
226               (buffer-start point)
227               (editor-error "No previous line."))
228              (t
229               (buffer-end point)
230               (when p (editor-error "No next line."))))))
231    (unless (move-to-column point target) (line-end point))
232    (setf (last-command-type) :line-motion)))
233
234
235(defcommand "Previous Line" (p)
236  "Moves the point to the previous line.
237  With prefix argument, moves the point that many lines up (or down if
238  the prefix is negative)."
239  "Moves the point up p lines."
240  (next-line-command (- (or p 1))))
241
242(defcommand "Mark to End of Buffer" (p)
243  "Sets the current region from point to the end of the buffer."
244  "Sets the current region from point to the end of the buffer."
245  (declare (ignore p))
246  (push-buffer-mark (buffer-end (copy-mark (current-point))) t))
247
248(defcommand "Mark to Beginning of Buffer" (p)
249  "Sets the current region from the beginning of the buffer to point."
250  "Sets the current region from the beginning of the buffer to point."
251  (declare (ignore p))
252  (push-buffer-mark (buffer-start (copy-mark (current-point))) t))
253
254(defcommand "Beginning of Buffer" (p)
255  "Moves the point to the beginning of the current buffer."
256  "Moves the point to the beginning of the current buffer."
257  (declare (ignore p))
258  (let ((point (current-point)))
259    (push-buffer-mark (copy-mark point))
260    (buffer-start point)))
261
262(defcommand "End of Buffer" (p)
263  "Moves the point to the end of the current buffer."
264  "Moves the point to the end of the current buffer."
265  (declare (ignore p))
266  (let ((point (current-point)))
267    (push-buffer-mark (copy-mark point))
268    (buffer-end point)))
269
270(defcommand "Beginning of Line" (p)
271  "Moves the point to the beginning of the current line.
272  With prefix argument, moves the point to the beginning of the prefix'th
273  next line."
274  "Moves the point down p lines and then to the beginning of the line."
275  (let ((point (current-point)))
276    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
277    (line-start point)))
278
279(defcommand "End of Line" (p)
280  "Moves the point to the end of the current line.
281  With prefix argument, moves the point to the end of the prefix'th next line."
282  "Moves the point down p lines and then to the end of the line."
283  (let ((point (current-point)))
284    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
285    (line-end point)))
286
287(defhvar "Scroll Overlap"
288  "The \"Scroll Window\" commands leave this much overlap between screens."
289  :value 2)
290
291(defhvar "Scroll Redraw Ratio"
292  "This is a ratio of \"inserted\" lines to the size of a window.  When this
293   ratio is exceeded, insert/delete line terminal optimization is aborted, and
294   every altered line is simply redrawn as efficiently as possible.  For example,
295   setting this to 1/4 will cause scrolling commands to redraw the entire window
296   instead of moving the bottom two lines of the window to the top (typically
297   3/4 of the window is being deleted upward and inserted downward, hence a
298   redraw); however, commands line \"New Line\" and \"Open Line\" will still
299   efficiently, insert a line moving the rest of the window's text downward."
300  :value nil)
301
302(defcommand "Scroll Window Down" (p &optional (window (current-window)))
303  "Move down one screenfull.
304  With prefix argument scroll down that many lines."
305  "If P is NIL then scroll Window, which defaults to the current
306  window, down one screenfull.  If P is supplied then scroll that
307  many lines."
308  (scroll-window window (or p 1)))
309
310(defcommand "Scroll Window Up" (p &optional (window (current-window)))
311  "Move up one screenfull.
312  With prefix argument scroll up that many lines."
313  "If P is NIL then scroll Window, which defaults to the current
314  window, up one screenfull.  If P is supplied then scroll that
315  many lines."
316  (scroll-window window (or p -1)))
317
318(defcommand "Scroll Next Window Down" (p)
319  "Do a \"Scroll Window Down\" on the next window."
320  "Do a \"Scroll Window Down\" on the next window."
321  (let ((win (next-window (current-window))))
322    (when (eq win (current-window)) (editor-error "Only one window."))
323    (scroll-window-down-command p win)))
324
325(defcommand "Scroll Next Window Up" (p)
326  "Do a \"Scroll Window Up\" on the next window."
327  "Do a \"Scroll Window Up\" on the next window."
328  (let ((win (next-window (current-window))))
329    (when (eq win (current-window)) (editor-error "Only one window."))
330    (scroll-window-up-command p win)))
331
332(defcommand "Top of Window" (p)
333  "Move the point to the top of the current window.
334  The point is left before the first character displayed in the window."
335  "Move the point to the top of the current window."
336  (declare (ignore p))
337  (move-mark (current-point) (window-display-start (current-window))))
338
339(defcommand "Bottom of Window" (p)
340  "Move the point to the bottom of the current window.
341  The point is left at the start of the bottom line."
342  "Move the point to the bottom of the current window."
343  (declare (ignore p))
344  (line-start (current-point)
345              (mark-line (window-display-end (current-window)))))
346
347;;;; Kind of miscellaneous commands:
348
349;;; "Refresh Screen" may not be right with respect to wrapping lines in
350;;; the case where an argument is supplied due the use of
351;;; WINDOW-DISPLAY-START instead of SCROLL-WINDOW, but using the latter
352;;; messed with point and did other hard to predict stuff.
353;;;
354(defcommand "Refresh Screen" (p)
355  "Refreshes everything in the window, centering current line."
356  "Refreshes everything in the window, centering current line."
357  (declare (ignore p))
358  (center-text-pane (current-window)))
359
360
361(defcommand "Track Buffer Point" (p)
362  "Make the current window track the buffer's point.
363   This means that each time Hemlock redisplays, it will make sure the buffer's
364   point is visible in the window.  This is useful for windows into buffer's
365   that receive output from streams coming from other processes."
366  "Make the current window track the buffer's point."
367  (declare (ignore p))
368  (setf (window-display-recentering (current-window)) t))
369;;;
370(defun reset-window-display-recentering (window &optional buffer)
371  (declare (ignore buffer))
372  (setf (window-display-recentering window) nil))
373;;;
374(add-hook window-buffer-hook #'reset-window-display-recentering)
375
376
377(defcommand "Extended Command" (p)
378  "Prompts for and executes an extended command."
379  "Prompts for and executes an extended command.  The prefix argument is
380  passed to the command."
381  (let* ((name (prompt-for-keyword (list *command-names*)
382                                   :prompt "Extended Command: "
383                                   :help "Name of a Hemlock command"))
384         (function (command-function (getstring name *command-names*))))
385    (funcall function p)))
386
387(defhvar "Universal Argument Default"
388  "Default value for \"Universal Argument\" command."
389  :value 4)
390
391(defcommand "Universal Argument" (p)
392  "Sets prefix argument for next command.
393  Typing digits, regardless of any modifier keys, specifies the argument.
394  Optionally, you may first type a sign (- or +).  While typing digits, if you
395  type C-U or C-u, the digits following the C-U form a number this command
396  multiplies by the digits preceding the C-U.  The default value for this
397  command and any number following a C-U is the value of \"Universal Argument
398  Default\"."
399  "You probably don't want to use this as a function."
400  (declare (ignore p))
401  (clear-echo-area)
402  (write-string "C-U " *echo-area-stream*)
403  (let* ((key-event (get-key-event *editor-input*))
404         (char (hemlock-ext:key-event-char key-event)))
405    (if char
406        (case char
407          (#\-
408           (write-char #\- *echo-area-stream*)
409           (universal-argument-loop (get-key-event *editor-input*) -1))
410          (#\+
411           (write-char #\+ *echo-area-stream*)
412           (universal-argument-loop (get-key-event *editor-input*) -1))
413          (t
414           (universal-argument-loop key-event 1)))
415        (universal-argument-loop key-event 1))))
416
417(defcommand "Negative Argument" (p)
418  "This command is equivalent to invoking \"Universal Argument\" and typing
419   a minus sign (-).  It waits for more digits and a command to which to give
420   the prefix argument."
421  "Don't call this as a function."
422  (when p (editor-error "Must type minus sign first."))
423  (clear-echo-area)
424  (write-string "C-U -" *echo-area-stream*)
425  (universal-argument-loop (get-key-event *editor-input*) -1))
426
427(defcommand "Argument Digit" (p)
428  "This command is equivalent to invoking \"Universal Argument\" and typing
429   the digit used to invoke this command.  It waits for more digits and a
430   command to which to give the prefix argument."
431  "Don't call this as a function."
432  (declare (ignore p))
433  (clear-echo-area)
434  (write-string "C-U " *echo-area-stream*)
435  (universal-argument-loop *last-key-event-typed* 1))
436
437(defun universal-argument-loop (key-event sign &optional (multiplier 1))
438  (flet ((prefix (sign multiplier read-some-digit-p result)
439           ;; read-some-digit-p and (zerop result) are not
440           ;; equivalent if the user invokes this and types 0.
441           (* sign multiplier
442              (if read-some-digit-p
443                  result
444                  (value universal-argument-default)))))
445    (let* ((stripped-key-event (if key-event (hemlock-ext:make-key-event key-event)))
446           (char (hemlock-ext:key-event-char stripped-key-event))
447           (digit (if char (digit-char-p char)))
448           (result 0)
449           (read-some-digit-p nil))
450      (loop
451        (cond (digit
452               (setf read-some-digit-p t)
453               (write-char char *echo-area-stream*)
454               (setf result (+ digit (* 10 result)))
455               (setf key-event (get-key-event *editor-input*))
456               (setf stripped-key-event (if key-event
457                                            (hemlock-ext:make-key-event key-event)))
458               (setf char (hemlock-ext:key-event-char stripped-key-event))
459               (setf digit (if char (digit-char-p char))))
460              ((or (eq key-event #k"C-u") (eq key-event #k"C-U"))
461               (write-string " C-U " *echo-area-stream*)
462               (universal-argument-loop
463                (get-key-event *editor-input*) 1
464                (prefix sign multiplier read-some-digit-p result))
465               (return))
466              (t
467               (unget-key-event key-event *editor-input*)
468               (setf (prefix-argument)
469                     (prefix sign multiplier read-some-digit-p result))
470               (return))))))
471  (setf (last-command-type) (last-command-type)))
Note: See TracBrowser for help on using the repository browser.