source: trunk/source/cocoa-ide/hemlock/src/command.lisp @ 11971

Last change on this file since 11971 was 11971, checked in by gb, 11 years ago

HEMLOCK-EXT:SCROLL-VIEW: accept HOW arguments (:VIEW-PAGE-UP/DOWN) that
don't modify the selection.

New "Page Up", "Page Down" commands.

Bind #k"pageup" to "Page Up", #k"pagedown" to "Page Down" commands.

(ticket:195).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.6 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
32
33
34
35
36
37;;;; Simple character manipulation:
38
39(defcommand "Self Insert" (p)
40  "Insert the last character typed.
41  With prefix argument insert the character that many times."
42  "Implements ``Self Insert'', calling this function is not meaningful."
43  (let ((char (last-char-typed)))
44    (unless char (editor-error "Can't insert that character."))
45    (if (and p (> p 1))
46        (insert-string
47         (current-point-for-insertion)
48         (make-string p :initial-element char))
49        (insert-character (current-point-for-insertion) char))))
50
51(defcommand "Quoted Insert" (p)
52  "Causes the next character typed to be inserted in the current
53   buffer, even if would normally be interpreted as an editor command."
54  (declare (ignore p))
55  (setf (hi::hemlock-view-quote-next-p hi::*current-view*) t))
56
57(defcommand "Forward Character" (p)
58  "Move the point forward one character, collapsing the selection.
59   With prefix argument move that many characters, with negative argument
60   go backwards."
61  "Move the point of the current buffer forward p characters, collapsing the selection."
62  (let* ((p (or p 1))
63         (point (current-point-collapsing-selection)))
64    (cond ((character-offset point p))
65          ((= p 1)
66           (editor-error "No next character."))
67          ((= p -1)
68           (editor-error "No previous character."))
69          (t
70           (if (plusp p)
71               (buffer-end point)
72               (buffer-start point))
73           (editor-error "Not enough characters.")))))
74
75(defcommand "Select Forward Character" (p)
76  "Move the point forward one character, extending the selection.
77   With prefix argument move that many characters, with negative argument
78   go backwards."
79  "Move the point of the current buffer forward p characters, extending the selection."
80  (let* ((p (or p 1))
81         (point (current-point-extending-selection)))
82    (cond ((character-offset point p))
83          ((= p 1)
84           (editor-error "No next character."))
85          ((= p -1)
86           (editor-error "No previous character."))
87          (t
88           (if (plusp p)
89               (buffer-end point)
90               (buffer-start point))
91           (editor-error "Not enough characters.")))))
92
93(defcommand "Backward Character" (p)
94  "Move the point backward one character, collapsing the selection.
95  With prefix argument move that many characters backward."
96  "Move the point p characters backward, collapsing the selection."
97  (forward-character-command (if p (- p) -1)))
98
99(defcommand "Select Backward Character" (p)
100  "Move the point backward one character, extending the selection.
101  With prefix argument move that many characters backward."
102  "Move the point p characters backward, extending the selection."
103  (select-forward-character-command (if p (- p) -1)))
104
105#|
106(defcommand "Delete Next Character" (p)
107  "Deletes the character to the right of the point.
108  With prefix argument, delete that many characters to the right
109  (or left if prefix is negative)."
110  "Deletes p characters to the right of the point."
111  (unless (delete-characters (current-point) (or p 1))
112    (buffer-end (current-point))
113    (editor-error "No next character.")))
114
115(defcommand "Delete Previous Character" (p)
116  "Deletes the character to the left of the point.
117  With prefix argument, delete that many characters to the left
118  (or right if prefix is negative)."
119  "Deletes p characters to the left of the point."
120  (unless (delete-characters (current-point) (if p (- p) -1))
121    (editor-error "No previous character.")))
122|#
123
124(defcommand "Delete Next Character" (p)
125  "Deletes the character to the right of the point.
126   With prefix argument, delete that many characters to the right
127  (or left if prefix is negative)."
128  "Deletes p characters to the right of the point."
129  (let* ((point (current-point-for-deletion)))
130    (when point
131      (cond ((kill-characters point (or p 1)))
132            ((and p (minusp p))
133             (editor-error "Not enough previous characters."))
134            (t
135             (editor-error "Not enough next characters."))))))
136
137(defcommand "Delete Previous Character" (p)
138  "Deletes the character to the left of the point.
139   Will push characters from successive deletes on to the kill ring."
140  "Deletes the character to the left of the point.
141   Will push characters from successive deletes on to the kill ring."
142  (delete-next-character-command (- (or p 1))))
143
144(defcommand "Transpose Characters" (p)
145  "Exchanges the characters on either side of the point and moves forward
146  With prefix argument, does this that many times.  A negative prefix
147  argument causes the point to be moved backwards instead of forwards."
148  "Exchanges the characters on either side of the point and moves forward."
149  (let ((arg (or p 1))
150        (point (current-point-unless-selection)))
151    (when point
152      (dotimes (i (abs arg))
153        (when (minusp arg) (mark-before point))
154        (let ((prev (previous-character point))
155              (next (next-character point)))
156
157          (cond ((not prev) (editor-error "No previous character."))
158                ((not next) (editor-error "No next character."))
159                (t
160                 (setf (previous-character point) next)
161                 (setf (next-character point) prev))))
162        (when (plusp arg) (mark-after point))))))
163
164;;;; Word hacking commands:
165
166;;; WORD-OFFSET
167;;;
168;;;    Move a mark forward/backward some words.
169;;;
170(defun word-offset (mark offset)
171  "Move Mark by Offset words."
172  (if (minusp offset)
173      (do ((cnt offset (1+ cnt)))
174          ((zerop cnt) mark)
175        (cond
176         ((null (reverse-find-attribute mark :word-delimiter #'zerop))
177          (return nil))
178         ((reverse-find-attribute mark :word-delimiter))
179         (t
180          (move-mark
181           mark (buffer-start-mark (mark-buffer mark))))))
182      (do ((cnt offset (1- cnt)))
183          ((zerop cnt) mark)
184        (cond
185         ((null (find-attribute mark :word-delimiter #'zerop))
186          (return nil))
187         ((null (find-attribute mark :word-delimiter))
188          (return nil))))))
189
190(defcommand "Forward Word" (p)
191  "Moves forward one word, collapsing the selection.
192  With prefix argument, moves the point forward over that many words."
193  "Moves the point forward p words, collapsing the selection."
194  (let* ((point (current-point-collapsing-selection)))
195    (cond ((word-offset point (or p 1)))
196          ((and p (minusp p))
197           (buffer-start point)
198           (editor-error "No previous word."))
199          (t
200           (buffer-end point)
201           (editor-error "No next word.")))))
202
203(defcommand "Select Forward Word" (p)
204  "Moves forward one word, extending the selection.
205  With prefix argument, moves the point forward over that many words."
206  "Moves the point forward p words, extending the selection."
207  (let* ((point (current-point-extending-selection)))
208    (cond ((word-offset point (or p 1)))
209          ((and p (minusp p))
210           (buffer-start point)
211           (editor-error "No previous word."))
212          (t
213           (buffer-end point)
214           (editor-error "No next word.")))))
215
216(defcommand "Backward Word" (p)
217  "Moves forward backward word.
218  With prefix argument, moves the point back over that many words."
219  "Moves the point backward p words."
220  (forward-word-command (- (or p 1))))
221
222(defcommand "Select Backward Word" (p)
223  "Moves forward backward word, extending the selection.
224  With prefix argument, moves the point back over that many words."
225  "Moves the point backward p words, extending the selection."
226  (select-forward-word-command (- (or p 1))))
227
228
229
230;;;; Moving around:
231
232(defun set-target-column (mark)
233  (if (eq (last-command-type) :line-motion)
234    (hi::hemlock-target-column hi::*current-view*)
235    (setf (hi::hemlock-target-column hi::*current-view*) (mark-column mark))))
236
237(defhvar "Next Line Inserts Newlines"
238    "If true, causes the \"Next Line\" command to insert newlines when
239     moving past the end of the buffer."
240  :value nil)
241
242
243(defcommand "Next Line" (p)
244  "Moves the point to the next line, collapsing the selection.
245   With prefix argument, moves the point that many lines down (or up if
246   the prefix is negative)."
247  "Moves the down p lines, collapsing the selection."
248  (let* ((point (current-point-collapsing-selection))
249         (target (set-target-column point))
250         (count (or p 1)))
251    (unless (line-offset point count)
252      (cond ((and (not p) (value next-line-inserts-newlines))
253             (when (same-line-p point (buffer-end-mark (current-buffer)))
254               (line-end point))
255             (insert-character point #\newline))
256            ((minusp count)
257             (buffer-start point)
258             (editor-error "No previous line."))
259            (t
260             (buffer-end point)
261             (editor-error "No next line."))))
262    (unless (move-to-position point target) (line-end point))
263    (setf (last-command-type) :line-motion)))
264
265(defcommand "Select Next Line" (p)
266  "Moves the point to the next line, extending the selection.
267   With prefix argument, moves the point that many lines down (or up if
268   the prefix is negative)."
269  "Moves the down p lines, extendin the selection."
270  (let* ((point (current-point-extending-selection))
271         (target (set-target-column point)))
272    (unless (line-offset point (or p 1))
273      (when (value next-line-inserts-newlines)
274        (cond ((not p)
275               (when (same-line-p point (buffer-end-mark (current-buffer)))
276                 (line-end point))
277               (insert-character point #\newline))
278              ((minusp p)
279               (buffer-start point)
280               (editor-error "No previous line."))
281              (t
282               (buffer-end point)
283               (when p (editor-error "No next line."))))))
284    (unless (move-to-position point target) (line-end point))
285    (setf (last-command-type) :line-motion)))
286
287
288(defcommand "Previous Line" (p)
289  "Moves the point to the previous line, collapsing the selection.
290  With prefix argument, moves the point that many lines up (or down if
291  the prefix is negative)."
292  "Moves the point up p lines, collapsing the selection."
293  (next-line-command (- (or p 1))))
294
295(defcommand "Select Previous Line" (p)
296  "Moves the point to the previous line, collapsing the selection.
297  With prefix argument, moves the point that many lines up (or down if
298  the prefix is negative)."
299  "Moves the point up p lines, collapsing the selection."
300  (select-next-line-command (- (or p 1))))
301
302(defcommand "Mark to End of Buffer" (p)
303  "Sets the current region from point to the end of the buffer."
304  "Sets the current region from point to the end of the buffer."
305  (declare (ignore p))
306  (buffer-end (push-new-buffer-mark (current-point) t)))
307
308(defcommand "Mark to Beginning of Buffer" (p)
309  "Sets the current region from the beginning of the buffer to point."
310  "Sets the current region from the beginning of the buffer to point."
311  (declare (ignore p))
312  (buffer-start (push-new-buffer-mark (current-point) t)))
313
314(defcommand "Beginning of Buffer" (p)
315  "Moves the point to the beginning of the current buffer, collapsing the selection."
316  "Moves the point to the beginning of the current buffer, collapsing the selection."
317  (declare (ignore p))
318  (let ((point (current-point-collapsing-selection)))
319    (push-new-buffer-mark point)
320    (buffer-start point)))
321
322(defcommand "End of Buffer" (p)
323  "Moves the point to the end of the current buffer."
324  "Moves the point to the end of the current buffer."
325  (declare (ignore p))
326  (let ((point (current-point-collapsing-selection)))
327    (push-new-buffer-mark point)
328    (buffer-end point)))
329
330(defcommand "Beginning of Line" (p)
331  "Moves the point to the beginning of the current line, collapsing the selection.
332  With prefix argument, moves the point to the beginning of the prefix'th
333  next line."
334  "Moves the point down p lines and then to the beginning of the line, collapsing the selection."
335  (let ((point (current-point-collapsing-selection)))
336    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
337    (line-start point)))
338
339(defcommand "Select to Beginning of Line" (p)
340  "Moves the point to the beginning of the current line, extending the selection.
341  With prefix argument, moves the point to the beginning of the prefix'th
342  next line."
343  "Moves the point down p lines and then to the beginning of the line, extending the selection."
344  (let ((point (current-point-extending-selection)))
345    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
346    (line-start point)))
347
348(defcommand "End of Line" (p)
349  "Moves the point to the end of the current line, collapsing the selection.
350  With prefix argument, moves the point to the end of the prefix'th next line."
351  "Moves the point down p lines and then to the end of the line, collapsing the selection."
352  (let ((point (current-point-collapsing-selection)))
353    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
354    (line-end point)))
355
356(defcommand "Select to End of Line" (p)
357  "Moves the point to the end of the current line, extending the selection.
358  With prefix argument, moves the point to the end of the prefix'th next line."
359  "Moves the point down p lines and then to the end of the line, extending the selection."
360  (let ((point (current-point-extending-selection)))
361    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
362    (line-end point)))
363
364(defhvar "Scroll Overlap"
365  "The \"Scroll Window\" commands leave this much overlap between screens."
366  :value 2)
367
368(defhvar "Scroll Redraw Ratio"
369  "This is a ratio of \"inserted\" lines to the size of a window.  When this
370   ratio is exceeded, insert/delete line terminal optimization is aborted, and
371   every altered line is simply redrawn as efficiently as possible.  For example,
372   setting this to 1/4 will cause scrolling commands to redraw the entire window
373   instead of moving the bottom two lines of the window to the top (typically
374   3/4 of the window is being deleted upward and inserted downward, hence a
375   redraw); however, commands line \"New Line\" and \"Open Line\" will still
376   efficiently, insert a line moving the rest of the window's text downward."
377  :value nil)
378
379(defcommand "Scroll Window Down" (p)
380  "Move down one screenfull.
381  With prefix argument scroll down that many lines."
382  "If P is NIL then scroll Window, which defaults to the current
383  window, down one screenfull.  If P is supplied then scroll that
384  many lines."
385  (if p
386    (set-scroll-position :lines-down p)
387    (set-scroll-position :page-down)))
388
389(defcommand "Page Down" (p)
390  "Move down one screenfull, without changing the selection."
391  "Ignores prefix argument"
392  (declare (ignore p))
393  (set-scroll-position :view-page-down))
394
395(defcommand "Scroll Window Up" (p)
396  "Move up one screenfull.
397  With prefix argument scroll up that many lines."
398  "If P is NIL then scroll Window, which defaults to the current
399  window, up one screenfull.  If P is supplied then scroll that
400  many lines."
401  (if p
402    (set-scroll-position :lines-up p)
403    (set-scroll-position :page-up)))
404
405(defcommand "Page Up" (p)
406  "Move up one screenfull, without changing the selection."
407  "Ignores prefix argument."
408  (declare (ignore p))
409  (set-scroll-position :view-page-up))
410
411;;;; Kind of miscellaneous commands:
412
413(defcommand "Refresh Screen" (p)
414  "Refreshes everything in the window, centering current line.
415With prefix argument, puts moves current line to top of window"
416  (if p
417    (set-scroll-position :line (current-point))
418    (set-scroll-position :center-selection)))
419
420
421(defcommand "Extended Command" (p)
422  "Prompts for and executes an extended command."
423  "Prompts for and executes an extended command.  The prefix argument is
424  passed to the command."
425  (let* ((name (prompt-for-keyword :tables (list *command-names*)
426                                   :prompt "Extended Command: "
427                                   :help "Name of a Hemlock command"))
428         (function (command-function (getstring name *command-names*))))
429    (funcall function p)))
430
431(defhvar "Universal Argument Default"
432  "Default value for \"Universal Argument\" command."
433  :value 4)
434
435(defstruct (prefix-argument-state (:conc-name "PS-"))
436  sign
437  multiplier
438  read-some-digit-p
439  ;; This is NIL if haven't started and don't have a universal argument, else a number
440  result
441  ;; This is cleared by prefix-argument-resetting-state (called at the start of each
442  ;; command) and can be set by a command to avoid the state being reset at
443  ;; the end of the command.
444  set-p)
445
446(defun prefix-argument-resetting-state (&optional (ps (current-prefix-argument-state)))
447  "Fetches the prefix argument and uses it up, i.e. marks it as not being set"
448  (unless (ps-set-p ps)
449    (setf (ps-sign ps) 1
450          (ps-multiplier ps) 1
451          (ps-read-some-digit-p ps) nil
452          (ps-result ps) nil))
453  (setf (ps-set-p ps) nil) ;; mark it for death unless explicitly revived.
454  (when (ps-result ps)
455    (* (ps-sign ps)
456       (if (ps-read-some-digit-p ps)
457         (ps-result ps)
458         (expt (value universal-argument-default) (ps-multiplier ps))))))
459
460(defun note-prefix-argument-set (ps)
461  (assert (ps-result ps))
462  (setf (ps-set-p ps) t)
463  (message (with-output-to-string (s)
464             (dotimes (i (ps-multiplier ps))
465               (write-string "C-U " s))
466             (cond ((ps-read-some-digit-p ps)
467                    (format s "~d" (* (ps-sign ps) (ps-result ps))))
468                   ((< (ps-sign ps) 0)
469                    (write-string "-" s))))))
470
471(defcommand "Universal Argument" (p)
472  "Sets prefix argument for next command.
473   Typing digits, regardless of any modifier keys, specifies the argument.
474   Optionally, you may first type a sign (- or +).  While typing digits, if you
475   type C-U or C-u, the digits following the C-U form a number this command
476   multiplies by the digits preceding the C-U.  The default value for this
477   command and any number following a C-U is the value of \"Universal Argument
478   Default\"."
479  (declare (ignore p)) ;; we operate on underlying state instead
480  (let ((ps (current-prefix-argument-state)))
481    (if (ps-result ps)
482      (incf (ps-multiplier ps))
483      (setf (ps-result ps) 0))
484    (note-prefix-argument-set ps)))
485
486(defcommand "Argument Digit" (p)
487  "This command is equivalent to invoking \"Universal Argument\" and typing
488   the key used to invoke this command.  It waits for more digits and a
489   command to which to give the prefix argument."
490  (declare (ignore p)) ;; we operate on underlying state instead
491  (let* ((ps (current-prefix-argument-state))
492         (key-event (last-key-event-typed))
493         (stripped-key-event (make-key-event key-event))
494         (char (key-event-char stripped-key-event))
495         (digit (if char (digit-char-p char))))
496    (when (null (ps-result ps))
497      (setf (ps-result ps) 0))
498    (case char
499      (#\-
500       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
501         (editor-error "Must type minus sign first."))
502       (setf (ps-sign ps) (- (ps-sign ps))))
503      (#\+
504       (when (ps-read-some-digit-p ps) ;; could just insert it up front...
505         (editor-error "Must type plus sign first.")))
506      (t
507       (unless digit
508         (editor-error "Argument Digit must be bound to a digit!"))
509       (setf (ps-read-some-digit-p ps) t)
510       (setf (ps-result ps) (+ digit (* (ps-result ps) 10)))))
511    (note-prefix-argument-set ps)))
512
513(defcommand "Digit" (p)
514  "With a numeric argument, this command extends the argument.
515   Otherwise it does self insert"
516  (if p
517    (argument-digit-command p)
518    (self-insert-command p)))
Note: See TracBrowser for help on using the repository browser.