/[climacs]/climacs/gui.lisp
ViewVC logotype

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.155 - (hide annotations)
Sun Jul 17 15:31:38 2005 UTC (8 years, 9 months ago) by rstrandh
Branch: MAIN
Changes since 1.154: +9 -3 lines
Reassign *standard-input* when the current pane changes, otherwise the
concept of previous-command (which is per-pane) does not make sense.
1 ejohnson 1.27 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2    
3 mvilleneuve 1.65 ;;; (c) copyright 2004-2005 by
4 ejohnson 1.27 ;;; Robert Strandh (strandh@labri.fr)
5 mvilleneuve 1.65 ;;; (c) copyright 2004-2005 by
6 ejohnson 1.27 ;;; Elliott Johnson (ejohnson@fasl.info)
7 mvilleneuve 1.65 ;;; (c) copyright 2005 by
8     ;;; Matthieu Villeneuve (matthieu.villeneuve@free.fr)
9 abakic 1.68 ;;; (c) copyright 2005 by
10     ;;; Aleksandar Bakic (a_bakic@yahoo.com)
11 ejohnson 1.27
12     ;;; This library is free software; you can redistribute it and/or
13     ;;; modify it under the terms of the GNU Library General Public
14     ;;; License as published by the Free Software Foundation; either
15     ;;; version 2 of the License, or (at your option) any later version.
16     ;;;
17     ;;; This library is distributed in the hope that it will be useful,
18     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20     ;;; Library General Public License for more details.
21     ;;;
22     ;;; You should have received a copy of the GNU Library General Public
23     ;;; License along with this library; if not, write to the
24     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25     ;;; Boston, MA 02111-1307 USA.
26    
27     ;;; GUI for the Climacs editor.
28    
29     (in-package :climacs-gui)
30    
31 rstrandh 1.70 (defclass extended-pane (climacs-pane)
32     (;; allows a certain number of commands to have some minimal memory
33 rstrandh 1.49 (previous-command :initform nil :accessor previous-command)
34     ;; for next-line and previous-line commands
35     (goal-column :initform nil)
36     ;; for dynamic abbrev expansion
37     (original-prefix :initform nil)
38     (prefix-start-offset :initform nil)
39 abakic 1.68 (dabbrev-expansion-mark :initform nil)
40     (overwrite-mode :initform nil)))
41 ejohnson 1.27
42 rstrandh 1.151 ;;; a pane that displays some information about another pane
43 rstrandh 1.81 (defclass info-pane (application-pane)
44 rstrandh 1.151 ((master-pane :initarg :master-pane))
45     (:default-initargs
46     :background +gray85+
47     :scroll-bars nil
48     :borders nil))
49    
50     (defclass minibuffer-pane (application-pane)
51     ((message :initform nil :accessor message))
52     (:default-initargs
53     :scroll-bars nil
54     :display-function 'display-minibuffer))
55 rstrandh 1.81
56 rstrandh 1.151 (defun display-minibuffer (frame pane)
57     (declare (ignore frame))
58     (with-slots (message) pane
59     (unless (null message)
60     (princ message pane)
61     (setf message nil))))
62 rstrandh 1.28
63     (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
64     (declare (ignore type args))
65     (window-clear pane))
66    
67 rstrandh 1.151 (defclass climacs-info-pane (info-pane)
68     ()
69     (:default-initargs
70     :height 20 :max-height 20 :min-height 20
71     :display-function 'display-info
72     :incremental-redisplay t))
73    
74     (defclass climacs-minibuffer-pane (minibuffer-pane)
75     ()
76     (:default-initargs
77     :height 20 :max-height 20 :min-height 20))
78    
79 rstrandh 1.152 (defclass multi-frame-mixin ()
80 rstrandh 1.83 ((windows :accessor windows)
81 rstrandh 1.85 (buffers :initform '() :accessor buffers)
82     (recordingp :initform nil :accessor recordingp)
83     (executingp :initform nil :accessor executingp)
84     (recorded-keys :initform '() :accessor recorded-keys)
85 rstrandh 1.152 (remaining-keys :initform '() :accessor remaining-keys)))
86    
87     (define-application-frame climacs (standard-application-frame
88     multi-frame-mixin)
89     ()
90 ejohnson 1.27 (:panes
91 rstrandh 1.81 (win (let* ((extended-pane
92     (make-pane 'extended-pane
93     :width 900 :height 400
94     :name 'bla
95 rstrandh 1.114 :end-of-line-action :scroll
96 rstrandh 1.81 :incremental-redisplay t
97     :display-function 'display-win))
98     (info-pane
99 rstrandh 1.151 (make-pane 'climacs-info-pane
100     :master-pane extended-pane
101     :width 900)))
102 rstrandh 1.81 (vertically ()
103     (scrolling ()
104     extended-pane)
105     info-pane)))
106 rstrandh 1.151 (int (make-pane 'climacs-minibuffer-pane :width 900)))
107 ejohnson 1.27 (:layouts
108     (default
109     (vertically (:scroll-bars nil)
110 rstrandh 1.77 win
111 rstrandh 1.80 int)))
112 ejohnson 1.27 (:top-level (climacs-top-level)))
113    
114 rstrandh 1.106 (defun display-message (format-string &rest format-args)
115 rstrandh 1.151 (setf (message *standard-input*)
116 rstrandh 1.106 (apply #'format nil format-string format-args)))
117    
118 rstrandh 1.153 (defun current-window ()
119     (car (windows *application-frame*)))
120 rstrandh 1.80
121 rstrandh 1.98 (defmethod execute-frame-command :around ((frame climacs) command)
122     (declare (ignore command))
123     (with-undo ((buffer (current-window)))
124     (call-next-method)))
125    
126 rstrandh 1.80 (defmethod redisplay-frame-panes :around ((frame climacs) &rest args)
127 rstrandh 1.70 (declare (ignore args))
128 rstrandh 1.83 (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame)))))
129     (loop for buffer in buffers
130     do (update-syntax buffer (syntax buffer)))
131 rstrandh 1.80 (call-next-method)
132 rstrandh 1.83 (loop for buffer in buffers
133     do (clear-modify buffer))))
134 rstrandh 1.28
135 rstrandh 1.151 (defun climacs (&key (width 900) (height 400))
136 ejohnson 1.27 "Starts up a climacs session"
137 rstrandh 1.151 (let ((frame (make-application-frame 'climacs :width width :height height)))
138 ejohnson 1.27 (run-frame-top-level frame)))
139    
140     (defun display-info (frame pane)
141 rstrandh 1.81 (declare (ignore frame))
142 rstrandh 1.151 (with-slots (master-pane) pane
143     (let* ((buf (buffer master-pane))
144 mvilleneuve 1.96 (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a"
145 rstrandh 1.81 (if (needs-saving buf) "**" "--")
146     (name buf)
147     (name (syntax buf))
148 rstrandh 1.151 (if (slot-value master-pane 'overwrite-mode)
149 mvilleneuve 1.86 " Ovwrt"
150 rstrandh 1.85 "")
151 rstrandh 1.151 (if (auto-fill-mode master-pane)
152 mvilleneuve 1.86 " Fill"
153     "")
154 rstrandh 1.151 (if (isearch-mode master-pane)
155 mvilleneuve 1.96 " Isearch"
156     "")
157 rstrandh 1.85 (if (recordingp *application-frame*)
158     "Def"
159 rstrandh 1.81 ""))))
160     (princ name-info pane))))
161 ejohnson 1.27
162     (defun display-win (frame pane)
163     "The display function used by the climacs application frame."
164     (declare (ignore frame))
165 rstrandh 1.127 (redisplay-pane pane (eq pane (current-window))))
166 ejohnson 1.27
167 rstrandh 1.113 (defmethod handle-repaint :before ((pane extended-pane) region)
168     (declare (ignore region))
169 crhodes 1.149 (redisplay-frame-pane *application-frame* pane))
170 rstrandh 1.113
171 ejohnson 1.27 (defun find-gestures (gestures start-table)
172     (loop with table = (find-command-table start-table)
173     for (gesture . rest) on gestures
174     for item = (find-keystroke-item gesture table :errorp nil)
175     while item
176     do (if (eq (command-menu-item-type item) :command)
177     (return (if (null rest) item nil))
178     (setf table (command-menu-item-value item)))
179     finally (return item)))
180    
181 ejohnson 1.50 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
182 ejohnson 1.27 (defparameter *current-gesture* nil)
183    
184 rstrandh 1.36 (defun meta-digit (gesture)
185     (position gesture
186     '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
187     (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
188     :test #'event-matches-gesture-name-p))
189    
190 rstrandh 1.47 (defun climacs-read-gesture ()
191 rstrandh 1.85 (unless (null (remaining-keys *application-frame*))
192     (return-from climacs-read-gesture
193     (pop (remaining-keys *application-frame*))))
194 rstrandh 1.47 (loop for gesture = (read-gesture :stream *standard-input*)
195     until (or (characterp gesture)
196     (and (typep gesture 'keyboard-event)
197     (or (keyboard-event-character gesture)
198     (not (member (keyboard-event-key-name
199     gesture)
200     '(:control-left :control-right
201     :shift-left :shift-right
202     :meta-left :meta-right
203     :super-left :super-right
204     :hyper-left :hyper-right
205     :shift-lock :caps-lock
206     :alt-left :alt-right))))))
207 rstrandh 1.85 finally (progn (when (recordingp *application-frame*)
208     (push gesture (recorded-keys *application-frame*)))
209     (return gesture))))
210    
211     (defun climacs-unread-gesture (gesture stream)
212     (cond ((recordingp *application-frame*)
213 rstrandh 1.88 (pop (recorded-keys *application-frame*))
214     (unread-gesture gesture :stream stream))
215 rstrandh 1.85 ((executingp *application-frame*)
216 rstrandh 1.88 (push gesture (remaining-keys *application-frame*)))
217     (t
218     (unread-gesture gesture :stream stream))))
219 rstrandh 1.47
220 rstrandh 1.36 (defun read-numeric-argument (&key (stream *standard-input*))
221 rstrandh 1.47 (let ((gesture (climacs-read-gesture)))
222 rstrandh 1.62 (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
223 rstrandh 1.36 (let ((numarg 4))
224 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
225 rstrandh 1.62 while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
226 rstrandh 1.36 do (setf numarg (* 4 numarg))
227 rstrandh 1.85 finally (climacs-unread-gesture gesture stream))
228 rstrandh 1.47 (let ((gesture (climacs-read-gesture)))
229 rstrandh 1.36 (cond ((and (characterp gesture)
230     (digit-char-p gesture 10))
231     (setf numarg (- (char-code gesture) (char-code #\0)))
232 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
233 rstrandh 1.36 while (and (characterp gesture)
234     (digit-char-p gesture 10))
235 rstrandh 1.62 do (setf numarg (+ (* 10 numarg)
236     (- (char-code gesture) (char-code #\0))))
237 rstrandh 1.85 finally (climacs-unread-gesture gesture stream)
238 rstrandh 1.36 (return (values numarg t))))
239     (t
240 rstrandh 1.85 (climacs-unread-gesture gesture stream)
241 rstrandh 1.36 (values numarg t))))))
242     ((meta-digit gesture)
243     (let ((numarg (meta-digit gesture)))
244 rstrandh 1.47 (loop for gesture = (climacs-read-gesture)
245 rstrandh 1.36 while (meta-digit gesture)
246     do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
247 rstrandh 1.85 finally (climacs-unread-gesture gesture stream)
248 rstrandh 1.36 (return (values numarg t)))))
249 rstrandh 1.85 (t (climacs-unread-gesture gesture stream)
250 rstrandh 1.36 (values 1 nil)))))
251    
252 rstrandh 1.77 ;;; we know the vbox pane has a scroller pane and an info
253     ;;; pane in it. The scroller pane has a viewport in it,
254     ;;; and the viewport contains the climacs-pane as its only child.
255     (defun find-climacs-pane (vbox)
256     (first (sheet-children
257     (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane))
258     (sheet-children
259     (find-if (lambda (pane) (typep pane 'scroller-pane))
260     (sheet-children vbox)))))))
261    
262 rstrandh 1.109 (defvar *numeric-argument-p* (list nil))
263    
264     (defun substitute-numeric-argument-p (command numargp)
265     (substitute numargp *numeric-argument-p* command :test #'eq))
266    
267 rstrandh 1.152 (defmethod execute-frame-command :around ((frame climacs) command)
268     (handler-case
269     (call-next-method)
270     (offset-before-beginning ()
271     (beep) (display-message "Beginning of buffer"))
272     (offset-after-end ()
273     (beep) (display-message "End of buffer"))
274     (motion-before-beginning ()
275     (beep) (display-message "Beginning of buffer"))
276     (motion-after-end ()
277     (beep) (display-message "End of buffer"))
278     (no-expression ()
279     (beep) (display-message "No expression around point"))
280     (no-such-operation ()
281     (beep) (display-message "Operation unavailable for syntax"))))
282    
283 rstrandh 1.153 (defun do-command (frame command)
284     (execute-frame-command frame command)
285     (setf (previous-command *standard-output*)
286     (if (consp command)
287     (car command)
288     command)))
289    
290     (defun update-climacs (frame)
291     (let ((buffer (buffer (current-window))))
292     (when (modified-p buffer)
293     (setf (needs-saving buffer) t)))
294     (when (null (remaining-keys *application-frame*))
295     (setf (executingp *application-frame*) nil)
296     (redisplay-frame-panes frame)))
297    
298 rstrandh 1.154 (defun process-gestures (frame)
299     (loop
300     for gestures = '()
301     do (multiple-value-bind (numarg numargp)
302     (read-numeric-argument :stream *standard-input*)
303     (loop
304     (setf *current-gesture* (climacs-read-gesture))
305     (setf gestures
306     (nconc gestures (list *current-gesture*)))
307     (let ((item (find-gestures gestures 'global-climacs-table)))
308     (cond
309     ((not item)
310     (beep) (return))
311     ((eq (command-menu-item-type item) :command)
312     (let ((command (command-menu-item-value item)))
313     (unless (consp command)
314     (setf command (list command)))
315     (setf command (substitute-numeric-argument-marker command numarg))
316     (setf command (substitute-numeric-argument-p command numargp))
317     (do-command frame command)
318     (return)))
319     (t nil)))))
320     do (update-climacs frame)))
321    
322 ejohnson 1.27 (defun climacs-top-level (frame &key
323 crhodes 1.121 command-parser command-unparser
324     partial-command-parser prompt)
325 ejohnson 1.27 (declare (ignore command-parser command-unparser partial-command-parser prompt))
326 rstrandh 1.83 (with-slots (windows) frame
327 crhodes 1.121 (setf windows (list (find-climacs-pane (find-pane-named frame 'win))))
328     (push (buffer (car windows)) (buffers frame))
329     (let ((*standard-output* (car windows))
330 rstrandh 1.155 (*standard-input* (frame-standard-input frame))
331 crhodes 1.121 (*print-pretty* nil)
332     (*abort-gestures* '((:keyboard #\g 512))))
333     (redisplay-frame-panes frame :force-p t)
334 rstrandh 1.154 (loop
335     for maybe-error = t
336     do (restart-case
337     (progn
338     (handler-case
339     (with-input-context
340     ('(command :command-table global-climacs-table))
341     (object)
342     (process-gestures frame)
343     (t
344     (do-command frame object)
345     (setq maybe-error nil)))
346     (abort-gesture () (display-message "Quit")))
347     (when maybe-error
348     (beep))
349     (update-climacs frame))
350     (return-to-climacs () nil))))))
351 ejohnson 1.27
352 mvilleneuve 1.100 (defmacro simple-command-loop (command-table loop-condition end-clauses)
353     (let ((gesture (gensym))
354     (item (gensym))
355 rstrandh 1.123 (command (gensym)))
356 mvilleneuve 1.100 `(progn
357     (redisplay-frame-panes *application-frame*)
358     (loop while ,loop-condition
359     as ,gesture = (climacs-read-gesture)
360     as ,item = (find-gestures (list ,gesture) ,command-table)
361     do (cond ((and ,item (eq (command-menu-item-type ,item) :command))
362     (setf *current-gesture* ,gesture)
363     (let ((,command (command-menu-item-value ,item)))
364     (unless (consp ,command)
365     (setf ,command (list ,command)))
366     (handler-case
367     (execute-frame-command *application-frame*
368     ,command)
369 rstrandh 1.123 (offset-before-beginning ()
370     (beep) (display-message "Beginning of buffer"))
371     (offset-after-end ()
372     (beep) (display-message "End of buffer"))
373     (motion-before-beginning ()
374     (beep) (display-message "Beginning of buffer"))
375     (motion-after-end ()
376     (beep) (display-message "End of buffer")))))
377 mvilleneuve 1.100 (t
378     (unread-gesture ,gesture)
379     ,@end-clauses))
380     (redisplay-frame-panes *application-frame*)))))
381    
382 abridgewater 1.34 (defmacro define-named-command (command-name args &body body)
383 rstrandh 1.62 `(define-climacs-command ,(if (listp command-name)
384     `(,@command-name :name t)
385     `(,command-name :name t)) ,args ,@body))
386 abridgewater 1.34
387 abakic 1.58 (define-named-command com-toggle-overwrite-mode ()
388 abakic 1.87 (with-slots (overwrite-mode) (current-window)
389     (setf overwrite-mode (not overwrite-mode))))
390 abakic 1.58
391 mvilleneuve 1.89 (defun possibly-fill-line ()
392 mvilleneuve 1.86 (let* ((pane (current-window))
393     (buffer (buffer pane)))
394 mvilleneuve 1.92 (when (auto-fill-mode pane)
395 mvilleneuve 1.95 (let* ((fill-column (auto-fill-column pane))
396 mvilleneuve 1.86 (point (point pane))
397     (offset (offset point))
398     (tab-width (tab-space-count (stream-default-view pane)))
399     (syntax (syntax buffer)))
400     (when (>= (buffer-display-column buffer offset tab-width)
401 mvilleneuve 1.95 (1- fill-column))
402 mvilleneuve 1.86 (fill-line point
403     (lambda (mark)
404     (syntax-line-indentation mark tab-width syntax))
405     fill-column
406 mvilleneuve 1.89 tab-width))))))
407    
408     (defun insert-character (char)
409     (let* ((win (current-window))
410     (point (point win)))
411     (unless (constituentp char)
412     (possibly-expand-abbrev point))
413     (when (whitespacep char)
414     (possibly-fill-line))
415     (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point)))
416     (progn
417     (delete-range point)
418     (insert-object point char))
419     (insert-object point char))))
420    
421     (define-command com-self-insert ()
422 mvilleneuve 1.86 (insert-character *current-gesture*))
423 ejohnson 1.27
424 abridgewater 1.34 (define-named-command com-beginning-of-line ()
425 rstrandh 1.80 (beginning-of-line (point (current-window))))
426 ejohnson 1.27
427 abridgewater 1.34 (define-named-command com-end-of-line ()
428 rstrandh 1.80 (end-of-line (point (current-window))))
429 ejohnson 1.27
430 rstrandh 1.62 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
431 rstrandh 1.80 (delete-range (point (current-window)) count))
432 ejohnson 1.27
433 rstrandh 1.62 (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
434 rstrandh 1.80 (delete-range (point (current-window)) (- count)))
435 ejohnson 1.27
436 rstrandh 1.42 (define-named-command com-transpose-objects ()
437 rstrandh 1.80 (let* ((point (point (current-window))))
438 rstrandh 1.42 (unless (beginning-of-buffer-p point)
439     (when (end-of-line-p point)
440 rstrandh 1.43 (backward-object point))
441     (let ((object (object-after point)))
442     (delete-range point)
443     (backward-object point)
444     (insert-object point object)
445     (forward-object point)))))
446    
447 rstrandh 1.62 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
448 rstrandh 1.80 (backward-object (point (current-window)) count))
449 rstrandh 1.43
450 rstrandh 1.62 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
451 rstrandh 1.80 (forward-object (point (current-window)) count))
452 rstrandh 1.43
453     (define-named-command com-transpose-words ()
454 rstrandh 1.80 (let* ((point (point (current-window))))
455 rstrandh 1.43 (let (bw1 bw2 ew1 ew2)
456     (backward-word point)
457     (setf bw1 (offset point))
458     (forward-word point)
459     (setf ew1 (offset point))
460     (forward-word point)
461     (when (= (offset point) ew1)
462     ;; this is emacs' message in the minibuffer
463     (error "Don't have two things to transpose"))
464     (setf ew2 (offset point))
465     (backward-word point)
466     (setf bw2 (offset point))
467     (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
468     (w1 (buffer-sequence (buffer point) bw1 ew1)))
469     (delete-word point)
470     (insert-sequence point w1)
471     (backward-word point)
472     (backward-word point)
473     (delete-word point)
474     (insert-sequence point w2)
475     (forward-word point)))))
476 rstrandh 1.42
477 rstrandh 1.45 (define-named-command com-transpose-lines ()
478 rstrandh 1.80 (let ((point (point (current-window))))
479 rstrandh 1.45 (beginning-of-line point)
480     (unless (beginning-of-buffer-p point)
481     (previous-line point))
482     (let* ((bol (offset point))
483     (eol (progn (end-of-line point)
484     (offset point)))
485     (line (buffer-sequence (buffer point) bol eol)))
486     (delete-region bol point)
487     ;; Remove newline at end of line as well.
488     (unless (end-of-buffer-p point)
489     (delete-range point))
490     ;; If the current line is at the end of the buffer, we want to
491     ;; be able to insert past it, so we need to get an extra line
492     ;; at the end.
493 abakic 1.82 (end-of-line point)
494     (when (end-of-buffer-p point)
495 rstrandh 1.45 (insert-object point #\Newline))
496 abakic 1.82 (next-line point 0)
497 rstrandh 1.45 (insert-sequence point line)
498     (insert-object point #\Newline))))
499    
500 rstrandh 1.111 (define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?"))
501 rstrandh 1.80 (let* ((win (current-window))
502 rstrandh 1.49 (point (point win)))
503     (unless (or (eq (previous-command win) 'com-previous-line)
504     (eq (previous-command win) 'com-next-line))
505     (setf (slot-value win 'goal-column) (column-number point)))
506 rstrandh 1.111 (previous-line point (slot-value win 'goal-column) numarg)))
507 ejohnson 1.27
508 rstrandh 1.111 (define-named-command com-next-line ((numarg 'integer :prompt "How many lines?"))
509 rstrandh 1.80 (let* ((win (current-window))
510 rstrandh 1.49 (point (point win)))
511     (unless (or (eq (previous-command win) 'com-previous-line)
512     (eq (previous-command win) 'com-next-line))
513     (setf (slot-value win 'goal-column) (column-number point)))
514 rstrandh 1.111 (next-line point (slot-value win 'goal-column) numarg)))
515 ejohnson 1.27
516 rstrandh 1.112 (define-named-command com-open-line ((numarg 'integer :prompt "How many lines?"))
517     (open-line (point (current-window)) numarg))
518 ejohnson 1.27
519 rstrandh 1.110 (define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?")
520     (numargp 'boolean :prompt "Kill entire lines?"))
521 rstrandh 1.80 (let* ((pane (current-window))
522 ejohnson 1.54 (point (point pane))
523     (mark (offset point)))
524 rstrandh 1.110 (cond ((or numargp (> numarg 1))
525     (loop repeat numarg
526     until (end-of-buffer-p point)
527     do (end-of-line point)
528     until (end-of-buffer-p point)
529     do (forward-object point)))
530 ejohnson 1.56 (t
531 rstrandh 1.110 (cond ((end-of-buffer-p point) nil)
532     ((end-of-line-p point)(forward-object point))
533     (t (end-of-line point)))))
534     (unless (mark= point mark)
535     (if (eq (previous-command pane) 'com-kill-line)
536     (kill-ring-concatenating-push *kill-ring*
537     (region-to-sequence mark point))
538     (kill-ring-standard-push *kill-ring*
539     (region-to-sequence mark point)))
540     (delete-region mark point))))
541 ejohnson 1.27
542 rstrandh 1.102 (define-named-command com-forward-word ((count 'integer :prompt "Number of words"))
543     (forward-word (point (current-window)) count))
544 ejohnson 1.27
545 rstrandh 1.102 (define-named-command com-backward-word ((count 'integer :prompt "Number of words"))
546     (backward-word (point (current-window)) count))
547 ejohnson 1.27
548 rstrandh 1.103 (define-named-command com-delete-word ((count 'integer :prompt "Number of words"))
549     (delete-word (point (current-window)) count))
550 rstrandh 1.32
551 rstrandh 1.103 (define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words"))
552     (backward-delete-word (point (current-window)) count))
553 rstrandh 1.32
554 mvilleneuve 1.64 (define-named-command com-upcase-region ()
555 abakic 1.101 (let ((cw (current-window)))
556     (upcase-region (mark cw) (point cw))))
557 mvilleneuve 1.64
558     (define-named-command com-downcase-region ()
559 abakic 1.101 (let ((cw (current-window)))
560     (downcase-region (mark cw) (point cw))))
561 mvilleneuve 1.64
562     (define-named-command com-capitalize-region ()
563 abakic 1.101 (let ((cw (current-window)))
564     (capitalize-region (mark cw) (point cw))))
565 mvilleneuve 1.64
566 rstrandh 1.60 (define-named-command com-upcase-word ()
567 rstrandh 1.80 (upcase-word (point (current-window))))
568 rstrandh 1.60
569     (define-named-command com-downcase-word ()
570 rstrandh 1.80 (downcase-word (point (current-window))))
571 rstrandh 1.60
572     (define-named-command com-capitalize-word ()
573 rstrandh 1.80 (capitalize-word (point (current-window))))
574 rstrandh 1.60
575 mvilleneuve 1.69 (define-named-command com-tabify-region ()
576 rstrandh 1.80 (let ((pane (current-window)))
577 abakic 1.125 (tabify-region
578     (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
579 mvilleneuve 1.69
580     (define-named-command com-untabify-region ()
581 rstrandh 1.80 (let ((pane (current-window)))
582 abakic 1.125 (untabify-region
583     (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
584 mvilleneuve 1.69
585 mvilleneuve 1.79 (defun indent-current-line (pane point)
586     (let* ((buffer (buffer pane))
587     (view (stream-default-view pane))
588     (tab-space-count (tab-space-count view))
589     (indentation (syntax-line-indentation point
590     tab-space-count
591     (syntax buffer))))
592     (indent-line point indentation (and (indent-tabs-mode buffer)
593     tab-space-count))))
594    
595     (define-named-command com-indent-line ()
596 rstrandh 1.80 (let* ((pane (current-window))
597 mvilleneuve 1.79 (point (point pane)))
598     (indent-current-line pane point)))
599    
600     (define-named-command com-newline-and-indent ()
601 rstrandh 1.80 (let* ((pane (current-window))
602 mvilleneuve 1.79 (point (point pane)))
603     (insert-object point #\Newline)
604     (indent-current-line pane point)))
605    
606 mvilleneuve 1.72 (define-named-command com-delete-indentation ()
607 rstrandh 1.80 (delete-indentation (point (current-window))))
608 ejohnson 1.27
609 mvilleneuve 1.86 (define-named-command com-auto-fill-mode ()
610 mvilleneuve 1.92 (let ((pane (current-window)))
611     (setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
612 mvilleneuve 1.86
613 mvilleneuve 1.90 (define-named-command com-fill-paragraph ()
614     (let* ((pane (current-window))
615     (buffer (buffer pane))
616     (syntax (syntax buffer))
617     (point (point pane))
618     (begin-mark (clone-mark point))
619     (end-mark (clone-mark point)))
620     (unless (eql (object-before begin-mark) #\Newline)
621     (beginning-of-paragraph begin-mark syntax))
622     (unless (eql (object-after end-mark) #\Newline)
623     (end-of-paragraph end-mark syntax))
624     (do-buffer-region (object offset buffer
625     (offset begin-mark) (offset end-mark))
626     (when (eql object #\Newline)
627     (setf object #\Space)))
628     (let ((point-backup (clone-mark point)))
629     (setf (offset point) (offset end-mark))
630     (possibly-fill-line)
631     (setf (offset point) (offset point-backup)))))
632    
633 ejohnson 1.27 (define-command com-extended-command ()
634 rstrandh 1.124 (let ((item (handler-case (accept 'command :prompt "Extended Command")
635     (error () (progn (beep)
636     (display-message "No such command")
637     (return-from com-extended-command nil))))))
638 ejohnson 1.27 (execute-frame-command *application-frame* item)))
639    
640 rstrandh 1.41 (eval-when (:compile-toplevel :load-toplevel)
641 ejohnson 1.35 (define-presentation-type completable-pathname ()
642     :inherit-from 'pathname))
643 ejohnson 1.27
644     (defun filename-completer (so-far mode)
645     (flet ((remove-trail (s)
646     (subseq s 0 (let ((pos (position #\/ s :from-end t)))
647     (if pos (1+ pos) 0)))))
648     (let* ((directory-prefix
649     (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
650     ""
651 rstrandh 1.78 (namestring #+sbcl *default-pathname-defaults*
652     #+cmu (ext:default-directory)
653     #-(or sbcl cmu) *default-pathname-defaults*)))
654 ejohnson 1.27 (full-so-far (concatenate 'string directory-prefix so-far))
655     (pathnames
656     (loop with length = (length full-so-far)
657 abakic 1.129 and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
658     for path in
659     #+(or sbcl cmu lispworks) (directory wildcard)
660     #+openmcl (directory wildcard :directories t)
661     #+allegro (directory wildcard :directories-are-files nil)
662     #+cormanlisp (nconc (directory wildcard)
663     (cl::directory-subdirs dirname))
664     #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
665     (directory wildcard)
666     when (let ((mismatch (mismatch (namestring path) full-so-far)))
667     (or (null mismatch) (= mismatch length)))
668     collect path))
669 ejohnson 1.27 (strings (mapcar #'namestring pathnames))
670     (first-string (car strings))
671     (length-common-prefix nil)
672     (completed-string nil)
673     (full-completed-string nil))
674     (unless (null pathnames)
675     (setf length-common-prefix
676     (loop with length = (length first-string)
677     for string in (cdr strings)
678     do (setf length (min length (or (mismatch string first-string) length)))
679     finally (return length))))
680     (unless (null pathnames)
681     (setf completed-string
682     (subseq first-string (length directory-prefix)
683     (if (null (cdr pathnames)) nil length-common-prefix)))
684     (setf full-completed-string
685     (concatenate 'string directory-prefix completed-string)))
686     (case mode
687     ((:complete-limited :complete-maximal)
688     (cond ((null pathnames)
689     (values so-far nil nil 0 nil))
690     ((null (cdr pathnames))
691     (values completed-string t (car pathnames) 1 nil))
692     (t
693     (values completed-string nil nil (length pathnames) nil))))
694     (:complete
695     (cond ((null pathnames)
696     (values so-far t so-far 1 nil))
697     ((null (cdr pathnames))
698     (values completed-string t (car pathnames) 1 nil))
699     ((find full-completed-string strings :test #'string-equal)
700     (let ((pos (position full-completed-string strings :test #'string-equal)))
701     (values completed-string
702     t (elt pathnames pos) (length pathnames) nil)))
703     (t
704     (values completed-string nil nil (length pathnames) nil))))
705     (:possibilities
706     (values nil nil nil (length pathnames)
707     (loop with length = (length directory-prefix)
708     for name in pathnames
709     collect (list (subseq (namestring name) length nil)
710     name))))))))
711    
712     (define-presentation-method accept
713     ((type completable-pathname) stream (view textual-view) &key)
714     (multiple-value-bind (pathname success string)
715     (complete-input stream
716     #'filename-completer
717     :partial-completers '(#\Space)
718     :allow-any-input t)
719     (declare (ignore success))
720     (or pathname string)))
721    
722 abakic 1.134 (defun filepath-filename (pathname)
723 ejohnson 1.27 (if (null (pathname-type pathname))
724     (pathname-name pathname)
725     (concatenate 'string (pathname-name pathname)
726     "." (pathname-type pathname))))
727    
728 crhodes 1.140 (defun syntax-class-name-for-filepath (filepath)
729     (or (climacs-syntax::syntax-description-class-name
730     (find (or (pathname-type filepath)
731     (pathname-name filepath))
732     climacs-syntax::*syntaxes*
733     :test (lambda (x y)
734     (member x y :test #'string=))
735     :key #'climacs-syntax::syntax-description-pathname-types))
736     'basic-syntax))
737    
738 abridgewater 1.34 (define-named-command com-find-file ()
739 abakic 1.134 (let ((filepath (accept 'completable-pathname
740 rstrandh 1.70 :prompt "Find File"))
741     (buffer (make-instance 'climacs-buffer))
742 rstrandh 1.80 (pane (current-window)))
743 rstrandh 1.137 (setf (point (buffer pane)) (clone-mark (point pane)))
744 rstrandh 1.75 (push buffer (buffers *application-frame*))
745 rstrandh 1.80 (setf (buffer (current-window)) buffer)
746 crhodes 1.140 (setf (syntax buffer)
747     (make-instance
748     (syntax-class-name-for-filepath filepath)
749     :buffer (buffer (point pane))))
750 rstrandh 1.84 ;; Don't want to create the file if it doesn't exist.
751 abakic 1.134 (when (probe-file filepath)
752     (with-open-file (stream filepath :direction :input)
753 rstrandh 1.84 (input-from-stream stream buffer 0)))
754 abakic 1.134 (setf (filepath buffer) filepath
755     (name buffer) (filepath-filename filepath)
756 rstrandh 1.70 (needs-saving buffer) nil)
757     (beginning-of-buffer (point pane))
758     ;; this one is needed so that the buffer modification protocol
759     ;; resets the low and high marks after redisplay
760     (redisplay-frame-panes *application-frame*)))
761 ejohnson 1.27
762 crhodes 1.139 (define-named-command com-insert-file ()
763     (let ((filename (accept 'completable-pathname
764     :prompt "Insert File"))
765     (pane (current-window)))
766     (when (probe-file filename)
767     (setf (mark pane) (clone-mark (point pane) :left))
768     (with-open-file (stream filename :direction :input)
769     (input-from-stream stream
770     (buffer pane)
771     (offset (point pane))))
772     (psetf (offset (mark pane)) (offset (point pane))
773     (offset (point pane)) (offset (mark pane))))
774     (redisplay-frame-panes *application-frame*)))
775    
776 rstrandh 1.93 (defun save-buffer (buffer)
777 abakic 1.134 (let ((filepath (or (filepath buffer)
778 rstrandh 1.93 (accept 'completable-pathname
779     :prompt "Save Buffer to File"))))
780 abakic 1.134 (with-open-file (stream filepath :direction :output :if-exists :supersede)
781 rstrandh 1.93 (output-to-stream stream buffer 0 (size buffer)))
782 abakic 1.134 (setf (filepath buffer) filepath
783     (name buffer) (filepath-filename filepath))
784     (display-message "Wrote: ~a" (filepath buffer))
785 rstrandh 1.93 (setf (needs-saving buffer) nil)))
786    
787 abridgewater 1.34 (define-named-command com-save-buffer ()
788 rstrandh 1.93 (let ((buffer (buffer (current-window))))
789 abakic 1.134 (if (or (null (filepath buffer))
790 rstrandh 1.30 (needs-saving buffer))
791 rstrandh 1.93 (save-buffer buffer)
792     (display-message "No changes need to be saved from ~a" (name buffer)))))
793    
794     (define-named-command (com-quit) ()
795     (loop for buffer in (buffers *application-frame*)
796     when (and (needs-saving buffer)
797 crhodes 1.138 (filepath buffer)
798 rstrandh 1.124 (handler-case (accept 'boolean
799     :prompt (format nil "Save buffer: ~a ?" (name buffer)))
800     (error () (progn (beep)
801     (display-message "Invalid answer")
802     (return-from com-quit nil)))))
803 rstrandh 1.93 do (save-buffer buffer))
804 crhodes 1.138 (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
805 rstrandh 1.93 (buffers *application-frame*))
806 rstrandh 1.124 (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
807     (error () (progn (beep)
808     (display-message "Invalid answer")
809     (return-from com-quit nil)))))
810 rstrandh 1.93 (frame-exit *application-frame*)))
811 ejohnson 1.27
812 abridgewater 1.34 (define-named-command com-write-buffer ()
813 abakic 1.134 (let ((filepath (accept 'completable-pathname
814 ejohnson 1.27 :prompt "Write Buffer to File"))
815 rstrandh 1.80 (buffer (buffer (current-window))))
816 abakic 1.134 (with-open-file (stream filepath :direction :output :if-exists :supersede)
817 ejohnson 1.27 (output-to-stream stream buffer 0 (size buffer)))
818 abakic 1.134 (setf (filepath buffer) filepath
819     (name buffer) (filepath-filename filepath)
820 rstrandh 1.30 (needs-saving buffer) nil)
821 abakic 1.134 (display-message "Wrote: ~a" (filepath buffer))))
822 ejohnson 1.27
823 rstrandh 1.75 (define-presentation-method accept
824     ((type buffer) stream (view textual-view) &key)
825     (multiple-value-bind (object success string)
826     (complete-input stream
827     (lambda (so-far action)
828     (complete-from-possibilities
829     so-far (buffers *application-frame*) '() :action action
830     :name-key #'name
831     :value-key #'identity))
832     :partial-completers '(#\Space)
833     :allow-any-input t)
834 rstrandh 1.76 (declare (ignore success))
835     (or object
836     (car (push (make-instance 'climacs-buffer :name string)
837     (buffers *application-frame*))))))
838 rstrandh 1.75
839     (define-named-command com-switch-to-buffer ()
840     (let ((buffer (accept 'buffer
841 abakic 1.125 :prompt "Switch to buffer"))
842     (pane (current-window)))
843 rstrandh 1.137 (setf (point (buffer pane)) (clone-mark (point pane)))
844 abakic 1.125 (setf (buffer pane) buffer)
845     (full-redisplay pane)))
846 rstrandh 1.75
847 rstrandh 1.91 (define-named-command com-kill-buffer ()
848     (with-slots (buffers) *application-frame*
849     (let ((buffer (buffer (current-window))))
850     (when (and (needs-saving buffer)
851 rstrandh 1.124 (handler-case (accept 'boolean :prompt "Save buffer first?")
852     (error () (progn (beep)
853     (display-message "Invalid answer")
854     (return-from com-kill-buffer nil)))))
855 rstrandh 1.91 (com-save-buffer))
856     (setf buffers (remove buffer buffers))
857     ;; Always need one buffer.
858     (when (null buffers)
859     (push (make-instance 'climacs-buffer :name "*scratch*")
860     buffers))
861     (setf (buffer (current-window)) (car buffers)))))
862    
863 rstrandh 1.75 (define-named-command com-full-redisplay ()
864 rstrandh 1.80 (full-redisplay (current-window)))
865 rstrandh 1.75
866 rstrandh 1.63 (define-named-command com-load-file ()
867 abakic 1.134 (let ((filepath (accept 'completable-pathname
868 rstrandh 1.63 :prompt "Load File")))
869 abakic 1.134 (load filepath)))
870 rstrandh 1.63
871 abridgewater 1.34 (define-named-command com-beginning-of-buffer ()
872 rstrandh 1.80 (beginning-of-buffer (point (current-window))))
873 ejohnson 1.27
874 rstrandh 1.39 (define-named-command com-page-down ()
875 rstrandh 1.80 (let ((pane (current-window)))
876 rstrandh 1.70 (page-down pane)))
877 rstrandh 1.39
878 rstrandh 1.40 (define-named-command com-page-up ()
879 rstrandh 1.80 (let ((pane (current-window)))
880 rstrandh 1.70 (page-up pane)))
881 rstrandh 1.40
882 abridgewater 1.34 (define-named-command com-end-of-buffer ()
883 rstrandh 1.80 (end-of-buffer (point (current-window))))
884 ejohnson 1.27
885 abridgewater 1.34 (define-named-command com-back-to-indentation ()
886 rstrandh 1.80 (let ((point (point (current-window))))
887 rstrandh 1.32 (beginning-of-line point)
888     (loop until (end-of-line-p point)
889     while (whitespacep (object-after point))
890     do (incf (offset point)))))
891    
892 abridgewater 1.34 (define-named-command com-goto-position ()
893 rstrandh 1.80 (setf (offset (point (current-window)))
894 rstrandh 1.124 (handler-case (accept 'integer :prompt "Goto Position")
895     (error () (progn (beep)
896     (display-message "Not a valid position")
897     (return-from com-goto-position nil))))))
898 rstrandh 1.32
899 abridgewater 1.34 (define-named-command com-goto-line ()
900 abakic 1.125 (loop with mark = (let ((m (clone-mark
901     (low-mark (buffer (current-window)))
902     :right)))
903     (beginning-of-buffer m)
904     m)
905 rstrandh 1.32 do (end-of-line mark)
906     until (end-of-buffer-p mark)
907 rstrandh 1.124 repeat (handler-case (accept 'integer :prompt "Goto Line")
908     (error () (progn (beep)
909     (display-message "Not a valid line number")
910     (return-from com-goto-line nil))))
911 rstrandh 1.32 do (incf (offset mark))
912     (end-of-line mark)
913     finally (beginning-of-line mark)
914 rstrandh 1.80 (setf (offset (point (current-window)))
915 rstrandh 1.32 (offset mark))))
916    
917 abridgewater 1.34 (define-named-command com-browse-url ()
918 ejohnson 1.27 (accept 'url :prompt "Browse URL"))
919    
920 abridgewater 1.34 (define-named-command com-set-mark ()
921 rstrandh 1.80 (let ((pane (current-window)))
922 rstrandh 1.70 (setf (mark pane) (clone-mark (point pane)))))
923 rstrandh 1.45
924     (define-named-command com-exchange-point-and-mark ()
925 rstrandh 1.80 (let ((pane (current-window)))
926 rstrandh 1.70 (psetf (offset (mark pane)) (offset (point pane))
927     (offset (point pane)) (offset (mark pane)))))
928 rstrandh 1.38
929     (define-named-command com-set-syntax ()
930 rstrandh 1.80 (let* ((pane (current-window))
931 rstrandh 1.67 (buffer (buffer pane)))
932 rstrandh 1.70 (setf (syntax buffer)
933 rstrandh 1.124 (make-instance (or (accept 'syntax :prompt "Set Syntax")
934     (progn (beep)
935     (display-message "No such syntax")
936     (return-from com-set-syntax nil)))
937 bmastenbrook 1.147 :buffer (buffer (point pane))))))
938 ejohnson 1.27
939 rstrandh 1.77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
940     ;;;
941 rstrandh 1.85 ;;; Keyboard macros
942    
943     (define-named-command com-start-kbd-macro ()
944     (setf (recordingp *application-frame*) t)
945     (setf (recorded-keys *application-frame*) '()))
946    
947     (define-named-command com-end-kbd-macro ()
948     (setf (recordingp *application-frame*) nil)
949     (setf (recorded-keys *application-frame*)
950     ;; this won't work if the command was invoked in any old way
951     (reverse (cddr (recorded-keys *application-frame*)))))
952    
953     (define-named-command com-call-last-kbd-macro ()
954     (setf (remaining-keys *application-frame*)
955     (recorded-keys *application-frame*))
956     (setf (executingp *application-frame*) t))
957    
958     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
959     ;;;
960 rstrandh 1.77 ;;; Commands for splitting windows
961    
962 rstrandh 1.83 (defun replace-constellation (constellation additional-constellation vertical-p)
963     (let* ((parent (sheet-parent constellation))
964     (children (sheet-children parent))
965     (first (first children))
966 rstrandh 1.117 (second (second children))
967     (third (third children))
968     (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
969 rstrandh 1.83 (assert (member constellation children))
970 rstrandh 1.117 (sheet-disown-child parent constellation)
971     (let ((new (if vertical-p
972     (vertically ()
973     constellation adjust additional-constellation)
974     (horizontally ()
975     constellation adjust additional-constellation))))
976     (sheet-adopt-child parent new)
977     (reorder-sheets parent
978     (if (eq constellation first)
979     (if third
980     (list new second third)
981     (list new second))
982     (if third
983     (list first second new)
984     (list first new)))))))
985 rstrandh 1.83
986     (defun parent3 (sheet)
987     (sheet-parent (sheet-parent (sheet-parent sheet))))
988    
989     (defun make-pane-constellation ()
990     "make a vbox containing a scroller pane as its first child and an
991     info pane as its second child. The scroller pane contains a viewport
992     which contains an extended pane. Return the vbox and the extended pane
993     as two values"
994     (let* ((extended-pane
995     (make-pane 'extended-pane
996     :width 900 :height 400
997     :name 'win
998 rstrandh 1.114 :end-of-line-action :scroll
999 rstrandh 1.83 :incremental-redisplay t
1000     :display-function 'display-win))
1001     (vbox
1002     (vertically ()
1003     (scrolling () extended-pane)
1004 rstrandh 1.151 (make-pane 'climacs-info-pane
1005     :master-pane extended-pane
1006     :width 900))))
1007 rstrandh 1.83 (values vbox extended-pane)))
1008    
1009 rstrandh 1.77 (define-named-command com-split-window-vertically ()
1010     (with-look-and-feel-realization
1011     ((frame-manager *application-frame*) *application-frame*)
1012 rstrandh 1.83 (multiple-value-bind (vbox new-pane) (make-pane-constellation)
1013     (let* ((current-window (current-window))
1014     (constellation-root (parent3 current-window)))
1015 rstrandh 1.137 (setf (point (buffer current-window)) (clone-mark (point current-window))
1016     (buffer new-pane) (buffer current-window)
1017 mvilleneuve 1.95 (auto-fill-mode new-pane) (auto-fill-mode current-window)
1018     (auto-fill-column new-pane) (auto-fill-column current-window))
1019 rstrandh 1.83 (push new-pane (windows *application-frame*))
1020 rstrandh 1.155 (setf *standard-output* new-pane)
1021 rstrandh 1.83 (replace-constellation constellation-root vbox t)
1022     (full-redisplay current-window)
1023     (full-redisplay new-pane)))))
1024    
1025     (define-named-command com-split-window-horizontally ()
1026     (with-look-and-feel-realization
1027     ((frame-manager *application-frame*) *application-frame*)
1028     (multiple-value-bind (vbox new-pane) (make-pane-constellation)
1029     (let* ((current-window (current-window))
1030     (constellation-root (parent3 current-window)))
1031 rstrandh 1.137 (setf (point (buffer current-window)) (clone-mark (point current-window))
1032     (buffer new-pane) (buffer current-window)
1033 mvilleneuve 1.95 (auto-fill-mode new-pane) (auto-fill-mode current-window)
1034     (auto-fill-column new-pane) (auto-fill-column current-window))
1035 rstrandh 1.83 (push new-pane (windows *application-frame*))
1036 rstrandh 1.155 (setf *standard-output* new-pane)
1037 rstrandh 1.83 (replace-constellation constellation-root vbox nil)
1038     (full-redisplay current-window)
1039     (full-redisplay new-pane)))))
1040    
1041     (define-named-command com-other-window ()
1042     (setf (windows *application-frame*)
1043     (append (cdr (windows *application-frame*))
1044 rstrandh 1.155 (list (car (windows *application-frame*)))))
1045     (setf *standard-output* (car (windows *application-frame*))))
1046 rstrandh 1.83
1047 rstrandh 1.117 (define-named-command com-single-window ()
1048     (loop until (null (cdr (windows *application-frame*)))
1049     do (rotatef (car (windows *application-frame*))
1050     (cadr (windows *application-frame*)))
1051 rstrandh 1.155 (com-delete-window))
1052     (setf *standard-output* (car (windows *application-frame*))))
1053    
1054 rstrandh 1.117
1055 rstrandh 1.83 (define-named-command com-delete-window ()
1056     (unless (null (cdr (windows *application-frame*)))
1057     (let* ((constellation (parent3 (current-window)))
1058     (box (sheet-parent constellation))
1059     (box-children (sheet-children box))
1060     (other (if (eq constellation (first box-children))
1061 rstrandh 1.117 (third box-children)
1062 rstrandh 1.83 (first box-children)))
1063     (parent (sheet-parent box))
1064     (children (sheet-children parent))
1065     (first (first children))
1066 rstrandh 1.117 (second (second children))
1067     (third (third children)))
1068 rstrandh 1.83 (pop (windows *application-frame*))
1069 rstrandh 1.155 (setf *standard-output* (car (windows *application-frame*)))
1070 rstrandh 1.83 (sheet-disown-child box other)
1071 rstrandh 1.116 (sheet-disown-child parent box)
1072 rstrandh 1.117 (sheet-adopt-child parent other)
1073 rstrandh 1.116 (reorder-sheets parent (if (eq box first)
1074 rstrandh 1.117 (if third
1075     (list other second third)
1076     (list other second))
1077     (if third
1078     (list first second other)
1079     (list first other)))))))
1080 rstrandh 1.94
1081 ejohnson 1.27 ;;;;;;;;;;;;;;;;;;;;
1082     ;; Kill ring commands
1083    
1084 ejohnson 1.31 ;; Copies an element from a kill-ring to a buffer at the given offset
1085 ejohnson 1.50 (define-named-command com-yank ()
1086 rstrandh 1.80 (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
1087 ejohnson 1.27
1088 ejohnson 1.31 ;; Destructively cut a given buffer region into the kill-ring
1089 abridgewater 1.34 (define-named-command com-cut-out ()
1090 abakic 1.125 (let ((pane (current-window)))
1091     (kill-ring-standard-push
1092     *kill-ring* (region-to-sequence (mark pane) (point pane)))
1093     (delete-region (mark pane) (point pane))))
1094 ejohnson 1.27
1095 ejohnson 1.31 ;; Non destructively copies in buffer region to the kill ring
1096 abridgewater 1.34 (define-named-command com-copy-out ()
1097 rstrandh 1.80 (let ((pane (current-window)))
1098 rstrandh 1.70 (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
1099 ejohnson 1.27
1100 ejohnson 1.50 (define-named-command com-rotate-yank ()
1101 rstrandh 1.80 (let* ((pane (current-window))
1102 ejohnson 1.54 (point (point pane))
1103 ejohnson 1.50 (last-yank (kill-ring-yank *kill-ring*)))
1104 ejohnson 1.54 (if (eq (previous-command pane)
1105 ejohnson 1.50 'com-rotate-yank)
1106 ejohnson 1.54 (progn
1107     (delete-range point (* -1 (length last-yank)))
1108     (rotate-yank-position *kill-ring*)))
1109     (insert-sequence point (kill-ring-yank *kill-ring*))))
1110 ejohnson 1.27
1111 ejohnson 1.50 (define-named-command com-resize-kill-ring ()
1112 rstrandh 1.124 (let ((size (handler-case (accept 'integer :prompt "New kill ring size")
1113     (error () (progn (beep)
1114     (display-message "Not a valid kill ring size")
1115     (return-from com-resize-kill-ring nil))))))
1116 ejohnson 1.50 (setf (kill-ring-max-size *kill-ring*) size)))
1117 rstrandh 1.47
1118 mvilleneuve 1.96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1119     ;;;
1120     ;;; Incremental search
1121    
1122 mvilleneuve 1.97 (defun isearch-command-loop (pane forwardp)
1123     (let ((point (point pane)))
1124 mvilleneuve 1.96 (unless (endp (isearch-states pane))
1125     (setf (isearch-previous-string pane)
1126     (search-string (first (isearch-states pane)))))
1127     (setf (isearch-mode pane) t)
1128     (setf (isearch-states pane)
1129     (list (make-instance 'isearch-state
1130     :search-string ""
1131 mvilleneuve 1.97 :search-mark (clone-mark point)
1132 mvilleneuve 1.105 :search-forward-p forwardp
1133     :search-success-p t)))
1134 mvilleneuve 1.100 (simple-command-loop 'isearch-climacs-table
1135     (isearch-mode pane)
1136     ((setf (isearch-mode pane) nil)))))
1137 mvilleneuve 1.96
1138 mvilleneuve 1.97 (defun isearch-from-mark (pane mark string forwardp)
1139     (flet ((object-equal (x y)
1140     (if (characterp x)
1141     (and (characterp y) (char-equal x y))
1142     (eql x y))))
1143     (let* ((point (point pane))
1144     (mark2 (clone-mark mark))
1145     (success (funcall (if forwardp #'search-forward #'search-backward)
1146     mark2
1147     string
1148     :test #'object-equal)))
1149 mvilleneuve 1.105 (when success
1150     (setf (offset point) (offset mark2)
1151     (offset mark) (if forwardp
1152     (- (offset mark2) (length string))
1153     (+ (offset mark2) (length string)))))
1154 abakic 1.130 (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A"
1155     success forwardp string)
1156 mvilleneuve 1.105 (push (make-instance 'isearch-state
1157     :search-string string
1158     :search-mark mark
1159     :search-forward-p forwardp
1160     :search-success-p success)
1161     (isearch-states pane))
1162     (unless success
1163     (beep)))))
1164 mvilleneuve 1.97
1165     (define-named-command com-isearch-mode-forward ()
1166 abakic 1.130 (display-message "Isearch: ")
1167 mvilleneuve 1.97 (isearch-command-loop (current-window) t))
1168    
1169     (define-named-command com-isearch-mode-backward ()
1170 abakic 1.130 (display-message "Isearch backward: ")
1171 mvilleneuve 1.97 (isearch-command-loop (current-window) nil))
1172 mvilleneuve 1.96
1173     (define-named-command com-isearch-append-char ()
1174     (let* ((pane (current-window))
1175     (states (isearch-states pane))
1176     (string (concatenate 'string
1177     (search-string (first states))
1178     (string *current-gesture*)))
1179     (mark (clone-mark (search-mark (first states))))
1180 mvilleneuve 1.97 (forwardp (search-forward-p (first states))))
1181     (unless forwardp
1182     (incf (offset mark)))
1183     (isearch-from-mark pane mark string forwardp)))
1184 mvilleneuve 1.96
1185     (define-named-command com-isearch-delete-char ()
1186     (let* ((pane (current-window)))
1187     (cond ((null (second (isearch-states pane)))
1188 abakic 1.130 (display-message "Isearch: ")
1189 mvilleneuve 1.96 (beep))
1190     (t
1191     (pop (isearch-states pane))
1192 mvilleneuve 1.105 (loop until (endp (rest (isearch-states pane)))
1193     until (search-success-p (first (isearch-states pane)))
1194     do (pop (isearch-states pane)))
1195 mvilleneuve 1.96 (let ((state (first (isearch-states pane))))
1196     (setf (offset (point pane))
1197 mvilleneuve 1.97 (if (search-forward-p state)
1198     (+ (offset (search-mark state))
1199     (length (search-string state)))
1200     (- (offset (search-mark state))
1201 abakic 1.130 (length (search-string state)))))
1202     (display-message "Isearch~:[ backward~;~]: ~A"
1203     (search-forward-p state)
1204     (search-string state)))))))
1205 mvilleneuve 1.96
1206     (define-named-command com-isearch-forward ()
1207     (let* ((pane (current-window))
1208     (point (point pane))
1209     (states (isearch-states pane))
1210     (string (if (null (second states))
1211     (isearch-previous-string pane)
1212     (search-string (first states))))
1213 mvilleneuve 1.97 (mark (clone-mark point)))
1214     (isearch-from-mark pane mark string t)))
1215    
1216     (define-named-command com-isearch-backward ()
1217     (let* ((pane (current-window))
1218     (point (point pane))
1219     (states (isearch-states pane))
1220     (string (if (null (second states))
1221     (isearch-previous-string pane)
1222     (search-string (first states))))
1223     (mark (clone-mark point)))
1224     (isearch-from-mark pane mark string nil)))
1225 mvilleneuve 1.96
1226     (define-named-command com-isearch-exit ()
1227     (setf (isearch-mode (current-window)) nil))
1228    
1229 mvilleneuve 1.100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1230     ;;;
1231     ;;; Query replace
1232    
1233     (defun query-replace-find-next-match (mark string)
1234 mvilleneuve 1.104 (flet ((object-equal (x y)
1235     (and (characterp x)
1236     (characterp y)
1237     (char-equal x y))))
1238     (let ((offset-before (offset mark)))
1239     (search-forward mark string :test #'object-equal)
1240     (/= (offset mark) offset-before))))
1241 mvilleneuve 1.100
1242     (define-named-command com-query-replace ()
1243 abakic 1.135 (let* ((pane (current-window))
1244     (old-state (query-replace-state pane))
1245     (old-string1 (when old-state (string1 old-state)))
1246     (old-string2 (when old-state (string2 old-state)))
1247     (string1 (handler-case
1248     (if old-string1
1249     (accept 'string
1250     :prompt "Query Replace"
1251     :default old-string1
1252     :default-type 'string)
1253     (accept 'string :prompt "Query Replace"))
1254 rstrandh 1.124 (error () (progn (beep)
1255     (display-message "Empty string")
1256     (return-from com-query-replace nil)))))
1257 abakic 1.135 (string2 (handler-case
1258     (if old-string2
1259     (accept 'string
1260     :prompt (format nil "Query Replace ~A with"
1261     string1)
1262     :default old-string2
1263     :default-type 'string)
1264     (accept 'string
1265     :prompt (format nil "Query Replace ~A with" string1)))
1266 rstrandh 1.124 (error () (progn (beep)
1267     (display-message "Empty string")
1268     (return-from com-query-replace nil)))))
1269 abakic 1.135 (point (point pane))
1270     (occurrences 0))
1271     (declare (special string1 string2 occurrences))
1272 mvilleneuve 1.100 (when (query-replace-find-next-match point string1)
1273     (setf (query-replace-state pane) (make-instance 'query-replace-state
1274     :string1 string1
1275     :string2 string2)
1276     (query-replace-mode pane) t)
1277 abakic 1.135 (display-message "Query Replace ~A with ~A:"
1278     string1 string2)
1279 mvilleneuve 1.100 (simple-command-loop 'query-replace-climacs-table
1280 abakic 1.135 (query-replace-mode pane)
1281     ((setf (query-replace-mode pane) nil))))
1282     (display-message "Replaced ~A occurrence~:P" occurrences)))
1283 mvilleneuve 1.100
1284     (define-named-command com-query-replace-replace ()
1285 abakic 1.135 (declare (special string1 string2 occurrences))
1286 mvilleneuve 1.100 (let* ((pane (current-window))
1287     (point (point pane))
1288 mvilleneuve 1.104 (buffer (buffer pane))
1289 abakic 1.135 (string1-length (length string1)))
1290 mvilleneuve 1.100 (backward-object point string1-length)
1291 mvilleneuve 1.104 (let* ((offset1 (offset point))
1292     (offset2 (+ offset1 string1-length))
1293     (region-case (buffer-region-case buffer offset1 offset2)))
1294     (delete-range point string1-length)
1295 abakic 1.135 (insert-sequence point string2)
1296     (setf offset2 (+ offset1 (length string2)))
1297 mvilleneuve 1.104 (finish-output *error-output*)
1298     (case region-case
1299     (:upper-case (upcase-buffer-region buffer offset1 offset2))
1300     (:lower-case (downcase-buffer-region buffer offset1 offset2))
1301     (:capitalized (capitalize-buffer-region buffer offset1 offset2))))
1302 abakic 1.135 (incf occurrences)
1303     (if (query-replace-find-next-match point string1)
1304     (display-message "Query Replace ~A with ~A:"
1305     string1 string2)
1306     (setf (query-replace-mode pane) nil))))
1307 mvilleneuve 1.100
1308     (define-named-command com-query-replace-skip ()
1309 abakic 1.135 (declare (special string1 string2))
1310 mvilleneuve 1.100 (let* ((pane (current-window))
1311 abakic 1.135 (point (point pane)))
1312     (if (query-replace-find-next-match point string1)
1313     (display-message "Query Replace ~A with ~A:"
1314     string1 string2)
1315     (setf (query-replace-mode pane) nil))))
1316 mvilleneuve 1.100
1317     (define-named-command com-query-replace-exit ()
1318     (setf (query-replace-mode (current-window)) nil))
1319    
1320     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1321     ;;;
1322     ;;; Undo/redo
1323    
1324 rstrandh 1.98 (define-named-command com-undo ()
1325 rstrandh 1.148 (handler-case (undo (undo-tree (buffer (current-window))))
1326     (no-more-undo () (beep) (display-message "No more undo")))
1327 abakic 1.128 (full-redisplay (current-window)))
1328 rstrandh 1.98
1329     (define-named-command com-redo ()
1330 rstrandh 1.148 (handler-case (redo (undo-tree (buffer (current-window))))
1331     (no-more-undo () (beep) (display-message "No more redo")))
1332 abakic 1.128 (full-redisplay (current-window)))
1333 rstrandh 1.98
1334 mvilleneuve 1.96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1335     ;;;
1336     ;;; Dynamic abbrevs
1337 ejohnson 1.27
1338 rstrandh 1.49 (define-named-command com-dabbrev-expand ()
1339 rstrandh 1.80 (let* ((win (current-window))
1340 rstrandh 1.49 (point (point win)))
1341     (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
1342     (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
1343     (setf (offset dabbrev-expansion-mark)
1344     (offset point))
1345     (forward-word dabbrev-expansion-mark))
1346     ((mark< dabbrev-expansion-mark point)
1347     (backward-object dabbrev-expansion-mark))
1348     (t (forward-object dabbrev-expansion-mark)))))
1349     (unless (or (beginning-of-buffer-p point)
1350     (not (constituentp (object-before point))))
1351     (unless (and (eq (previous-command win) 'com-dabbrev-expand)
1352     (not (null prefix-start-offset)))
1353     (setf dabbrev-expansion-mark (clone-mark point))
1354     (backward-word dabbrev-expansion-mark)
1355     (setf prefix-start-offset (offset dabbrev-expansion-mark))
1356     (setf original-prefix (region-to-sequence prefix-start-offset point))
1357     (move))
1358     (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
1359     (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
1360     (not (constituentp (object-before dabbrev-expansion-mark))))
1361     (looking-at dabbrev-expansion-mark original-prefix)))
1362     do (move))
1363     (if (end-of-buffer-p dabbrev-expansion-mark)
1364     (progn (delete-region prefix-start-offset point)
1365     (insert-sequence point original-prefix)
1366     (setf prefix-start-offset nil))
1367     (progn (delete-region prefix-start-offset point)
1368     (insert-sequence point
1369     (let ((offset (offset dabbrev-expansion-mark)))
1370     (prog2 (forward-word dabbrev-expansion-mark)
1371     (region-to-sequence offset dabbrev-expansion-mark)
1372     (setf (offset dabbrev-expansion-mark) offset))))
1373     (move))))))))
1374    
1375 rstrandh 1.71 (define-named-command com-beginning-of-paragraph ()
1376 rstrandh 1.80 (let* ((pane (current-window))
1377 rstrandh 1.71 (point (point pane))
1378     (syntax (syntax (buffer pane))))
1379     (beginning-of-paragraph point syntax)))
1380    
1381     (define-named-command com-end-of-paragraph ()
1382 rstrandh 1.80 (let* ((pane (current-window))
1383 rstrandh 1.71 (point (point pane))
1384     (syntax (syntax (buffer pane))))
1385     (end-of-paragraph point syntax)))
1386 rstrandh 1.106
1387 rstrandh 1.109 (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
1388     (let* ((*package* (find-package :climacs-gui))
1389 rstrandh 1.124 (string (handler-case (accept 'string :prompt "Eval")
1390     (error () (progn (beep)
1391     (display-message "Empty string")
1392     (return-from com-eval-expression nil)))))
1393     (result (format nil "~a"
1394     (handler-case (eval (read-from-string string))
1395     (error (condition) (progn (beep)
1396     (display-message "~a" condition)
1397     (return-from com-eval-expression nil)))))))
1398 rstrandh 1.109 (if insertp
1399     (insert-sequence (point (current-window)) result)
1400     (display-message result))))
1401    
1402 ejohnson 1.27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1403     ;;;
1404 rstrandh 1.141 ;;; For testing purposes
1405    
1406     (define-named-command com-reset-profile ()
1407 rstrandh 1.142 #+sbcl (sb-profile:reset)
1408     #-sbcl nil)
1409 rstrandh 1.141
1410     (define-named-command com-report-profile ()
1411 rstrandh 1.142 #+sbcl (sb-profile:report)
1412     #-sbcl nil)
1413 rstrandh 1.141
1414     (define-named-command com-recompile ()
1415     (asdf:operate 'asdf:load-op :climacs))
1416    
1417     (define-named-command com-backward-expression ((count 'integer :prompt "Number of expressions"))
1418     (declare (ignore count))
1419     (let* ((pane (current-window))
1420     (point (point pane))
1421     (syntax (syntax (buffer pane))))
1422     (backward-expression point syntax)))
1423    
1424     (define-named-command com-forward-expression ((count 'integer :prompt "Number of expresssions"))
1425     (declare (ignore count))
1426     (let* ((pane (current-window))
1427     (point (point pane))
1428     (syntax (syntax (buffer pane))))
1429     (forward-expression point syntax)))
1430    
1431 rstrandh 1.143 (define-named-command com-eval-defun ()
1432     (let* ((pane (current-window))
1433     (point (point pane))
1434     (syntax (syntax (buffer pane))))
1435     (eval-defun point syntax)))
1436    
1437 rstrandh 1.144 (define-named-command com-package ()
1438     (let* ((pane (current-window))
1439     (syntax (syntax (buffer pane)))
1440     (package (climacs-lisp-syntax::package-of syntax)))
1441     (display-message (format nil "~s" package))))
1442    
1443     (define-named-command com-accept-string ()
1444     (display-message (format nil "~s" (accept 'string))))
1445    
1446     (define-named-command com-accept-symbol ()
1447     (display-message (format nil "~s" (accept 'symbol))))
1448    
1449 rstrandh 1.141 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1450     ;;;
1451 rstrandh 1.80 ;;; Global and dead-escape command tables
1452 ejohnson 1.27
1453     (make-command-table 'global-climacs-table :errorp nil)
1454    
1455 rstrandh 1.80 (make-command-table 'dead-escape-climacs-table :errorp nil)
1456    
1457     (add-menu-item-to-command-table 'global-climacs-table "dead-escape"
1458     :menu 'dead-escape-climacs-table
1459     :keystroke '(:escape))
1460    
1461     (defun dead-escape-set-key (gesture command)
1462     (add-command-to-command-table command 'dead-escape-climacs-table
1463     :keystroke gesture :errorp nil))
1464    
1465 ejohnson 1.27 (defun global-set-key (gesture command)
1466     (add-command-to-command-table command 'global-climacs-table
1467 rstrandh 1.80 :keystroke gesture :errorp nil)
1468     (when (and
1469     (listp gesture)
1470     (find :meta gesture))
1471     (dead-escape-set-key (remove :meta gesture) command)))
1472 ejohnson 1.27
1473 mvilleneuve 1.89 (loop for code from (char-code #\Space) to (char-code #\~)
1474 ejohnson 1.27 do (global-set-key (code-char code) 'com-self-insert))
1475    
1476 mvilleneuve 1.89 (global-set-key #\Newline 'com-self-insert)
1477 mvilleneuve 1.86 (global-set-key #\Tab 'com-indent-line)
1478 rstrandh 1.150 (global-set-key '(#\i :control) 'com-indent-line)
1479 rstrandh 1.109 (global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*))
1480 mvilleneuve 1.79 (global-set-key '(#\j :control) 'com-newline-and-indent)
1481 rstrandh 1.62 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
1482     (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
1483 ejohnson 1.27 (global-set-key '(#\a :control) 'com-beginning-of-line)
1484     (global-set-key '(#\e :control) 'com-end-of-line)
1485 rstrandh 1.62 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
1486 rstrandh 1.111 (global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*))
1487 rstrandh 1.75 (global-set-key '(#\l :control) 'com-full-redisplay)
1488 rstrandh 1.111 (global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*))
1489 rstrandh 1.112 (global-set-key '(#\o :control) `(com-open-line ,*numeric-argument-marker*))
1490 rstrandh 1.110 (global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*))
1491 rstrandh 1.42 (global-set-key '(#\t :control) 'com-transpose-objects)
1492 ejohnson 1.27 (global-set-key '(#\Space :control) 'com-set-mark)
1493 ejohnson 1.50 (global-set-key '(#\y :control) 'com-yank)
1494 ejohnson 1.27 (global-set-key '(#\w :control) 'com-cut-out)
1495 rstrandh 1.102 (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*))
1496     (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*))
1497 rstrandh 1.43 (global-set-key '(#\t :meta) 'com-transpose-words)
1498 rstrandh 1.60 (global-set-key '(#\u :meta) 'com-upcase-word)
1499     (global-set-key '(#\l :meta) 'com-downcase-word)
1500     (global-set-key '(#\c :meta) 'com-capitalize-word)
1501 ejohnson 1.27 (global-set-key '(#\x :meta) 'com-extended-command)
1502 ejohnson 1.50 (global-set-key '(#\y :meta) 'com-rotate-yank)
1503 ejohnson 1.27 (global-set-key '(#\w :meta) 'com-copy-out)
1504 rstrandh 1.39 (global-set-key '(#\v :control) 'com-page-down)
1505 rstrandh 1.40 (global-set-key '(#\v :meta) 'com-page-up)
1506 ejohnson 1.27 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
1507     (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
1508 rstrandh 1.32 (global-set-key '(#\m :meta) 'com-back-to-indentation)
1509 mvilleneuve 1.74 (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
1510 mvilleneuve 1.90 (global-set-key '(#\q :meta) 'com-fill-paragraph)
1511 rstrandh 1.103 (global-set-key '(#\d :meta) `(com-delete-word ,*numeric-argument-marker*))
1512     (global-set-key '(#\Backspace :meta) `(com-backward-delete-word ,*numeric-argument-marker*))
1513 rstrandh 1.49 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
1514 rstrandh 1.71 (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)
1515     (global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
1516 mvilleneuve 1.97 (global-set-key '(#\s :control) 'com-isearch-mode-forward)
1517     (global-set-key '(#\r :control) 'com-isearch-mode-backward)
1518 mvilleneuve 1.100 (global-set-key '(#\% :shift :meta) 'com-query-replace)
1519 ejohnson 1.27
1520 rstrandh 1.111 (global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*))
1521     (global-set-key '(:down) `(com-next-line ,*numeric-argument-marker*))
1522 rstrandh 1.62 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
1523 ejohnson 1.66 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
1524 rstrandh 1.102 (global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*))
1525     (global-set-key '(:right :control) `(com-forward-word ,*numeric-argument-marker*))
1526 ejohnson 1.27 (global-set-key '(:home) 'com-beginning-of-line)
1527     (global-set-key '(:end) 'com-end-of-line)
1528 abridgewater 1.57 (global-set-key '(:prior) 'com-page-up)
1529     (global-set-key '(:next) 'com-page-down)
1530 ejohnson 1.27 (global-set-key '(:home :control) 'com-beginning-of-buffer)
1531     (global-set-key '(:end :control) 'com-end-of-buffer)
1532 rstrandh 1.62 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
1533     (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
1534 abakic 1.58
1535     (global-set-key '(:insert) 'com-toggle-overwrite-mode)
1536 rstrandh 1.141
1537     (global-set-key '(#\b :control :meta) `(com-backward-expression ,*numeric-argument-marker*))
1538     (global-set-key '(#\f :control :meta) `(com-forward-expression ,*numeric-argument-marker*))
1539 rstrandh 1.143 (global-set-key '(#\x :control :meta) '(com-eval-defun))
1540 ejohnson 1.27
1541     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1542     ;;;
1543     ;;; C-x command table
1544    
1545     (make-command-table 'c-x-climacs-table :errorp nil)
1546    
1547     (add-menu-item-to-command-table 'global-climacs-table "C-x"
1548     :menu 'c-x-climacs-table
1549     :keystroke '(#\x :control))
1550    
1551     (defun c-x-set-key (gesture command)
1552     (add-command-to-command-table command 'c-x-climacs-table
1553     :keystroke gesture :errorp nil))
1554    
1555 rstrandh 1.83 (c-x-set-key '(#\0) 'com-delete-window)
1556 ejohnson 1.107 (c-x-set-key '(#\1) 'com-single-window)
1557 rstrandh 1.77 (c-x-set-key '(#\2) 'com-split-window-vertically)
1558 rstrandh 1.83 (c-x-set-key '(#\3) 'com-split-window-horizontally)
1559 rstrandh 1.85 (c-x-set-key '(#\() 'com-start-kbd-macro)
1560     (c-x-set-key '(#\)) 'com-end-kbd-macro)
1561 rstrandh 1.75 (c-x-set-key '(#\b) 'com-switch-to-buffer)
1562 rstrandh 1.85 (c-x-set-key '(#\e) 'com-call-last-kbd-macro)
1563 ejohnson 1.27 (c-x-set-key '(#\c :control) 'com-quit)
1564     (c-x-set-key '(#\f :control) 'com-find-file)
1565 crhodes 1.139 (c-x-set-key '(#\i) 'com-insert-file)
1566 rstrandh 1.91 (c-x-set-key '(#\k) 'com-kill-buffer)
1567 rstrandh 1.63 (c-x-set-key '(#\l :control) 'com-load-file)
1568 rstrandh 1.83 (c-x-set-key '(#\o) 'com-other-window)
1569 rstrandh 1.98 (c-x-set-key '(#\r) 'com-redo)
1570     (c-x-set-key '(#\u) 'com-undo)
1571 ejohnson 1.27 (c-x-set-key '(#\s :control) 'com-save-buffer)
1572 rstrandh 1.45 (c-x-set-key '(#\t :control) 'com-transpose-lines)
1573 ejohnson 1.27 (c-x-set-key '(#\w :control) 'com-write-buffer)
1574 rstrandh 1.45 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
1575 rstrandh 1.44
1576     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1577     ;;;
1578     ;;; Some Unicode stuff
1579    
1580     (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
1581 rstrandh 1.80 (insert-object (point (current-window)) (code-char code)))
1582 rstrandh 1.44
1583     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1584     ;;;
1585     ;;; Dead-acute command table
1586    
1587     (make-command-table 'dead-acute-climacs-table :errorp nil)
1588    
1589     (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
1590     :menu 'dead-acute-climacs-table
1591     :keystroke '(:dead--acute))
1592    
1593     (defun dead-acute-set-key (gesture command)
1594     (add-command-to-command-table command 'dead-acute-climacs-table
1595     :keystroke gesture :errorp nil))
1596    
1597     (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
1598     (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
1599     (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
1600     (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
1601     (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
1602     (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
1603     (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
1604     (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
1605     (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
1606     (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
1607     (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
1608     (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
1609     (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
1610     (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
1611     (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
1612     (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
1613     (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
1614     (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
1615     (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
1616     (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
1617    
1618 rstrandh 1.45 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
1619    
1620     (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
1621     :menu 'dead-acute-dead-accute-climacs-table
1622     :keystroke '(:dead--acute))
1623    
1624     (defun dead-acute-dead-accute-set-key (gesture command)
1625     (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
1626     :keystroke gesture :errorp nil))
1627    
1628     (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
1629     (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
1630 rstrandh 1.44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1631     ;;;
1632     ;;; Dead-grave command table
1633    
1634     (make-command-table 'dead-grave-climacs-table :errorp nil)
1635    
1636     (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
1637     :menu 'dead-grave-climacs-table
1638     :keystroke '(:dead--grave))
1639    
1640     (defun dead-grave-set-key (gesture command)
1641     (add-command-to-command-table command 'dead-grave-climacs-table
1642     :keystroke gesture :errorp nil))
1643    
1644     (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
1645     (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
1646     (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
1647     (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
1648     (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
1649     (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
1650     (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
1651     (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
1652     (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
1653     (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
1654     (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
1655    
1656     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1657     ;;;
1658     ;;; Dead-diaeresis command table
1659    
1660     (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
1661    
1662     (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
1663     :menu 'dead-diaeresis-climacs-table
1664     :keystroke '(:dead--diaeresis :shift))
1665    
1666     (defun dead-diaeresis-set-key (gesture command)
1667     (add-command-to-command-table command 'dead-diaeresis-climacs-table
1668     :keystroke gesture :errorp nil))
1669    
1670     (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
1671     (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
1672     (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
1673     (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
1674     (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
1675     (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
1676     (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
1677     (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
1678     (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
1679     (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
1680     (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
1681     (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
1682    
1683     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1684     ;;;
1685     ;;; Dead-tilde command table
1686    
1687     (make-command-table 'dead-tilde-climacs-table :errorp nil)
1688    
1689     (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
1690     :menu 'dead-tilde-climacs-table
1691     :keystroke '(:dead--tilde :shift))
1692    
1693     (defun dead-tilde-set-key (gesture command)
1694     (add-command-to-command-table command 'dead-tilde-climacs-table
1695     :keystroke gesture :errorp nil))
1696    
1697     (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
1698     (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
1699     (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
1700     (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
1701     (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
1702     (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
1703     (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
1704     (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
1705     (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
1706     (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
1707     (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
1708    
1709     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1710     ;;;
1711     ;;; Dead-circumflex command table
1712    
1713     (make-command-table 'dead-circumflex-climacs-table :errorp nil)
1714    
1715     (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
1716     :menu 'dead-circumflex-climacs-table
1717     :keystroke '(:dead--circumflex :shift))
1718    
1719     (defun dead-circumflex-set-key (gesture command)
1720     (add-command-to-command-table command 'dead-circumflex-climacs-table
1721     :keystroke gesture :errorp nil))
1722    
1723     (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
1724     (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
1725     (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
1726     (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
1727     (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
1728     (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
1729     (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
1730     (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
1731     (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
1732     (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
1733     (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))
1734 mvilleneuve 1.96
1735     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1736     ;;;
1737     ;;; Isearch command table
1738    
1739     (make-command-table 'isearch-climacs-table :errorp nil)
1740    
1741     (defun isearch-set-key (gesture command)
1742     (add-command-to-command-table command 'isearch-climacs-table
1743     :keystroke gesture :errorp nil))
1744    
1745     (loop for code from (char-code #\Space) to (char-code #\~)
1746     do (isearch-set-key (code-char code) 'com-isearch-append-char))
1747    
1748     (isearch-set-key '(#\Newline) 'com-isearch-exit)
1749     (isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
1750     (isearch-set-key '(#\s :control) 'com-isearch-forward)
1751 mvilleneuve 1.97 (isearch-set-key '(#\r :control) 'com-isearch-backward)
1752 mvilleneuve 1.100
1753     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1754     ;;;
1755     ;;; Query replace command table
1756    
1757     (make-command-table 'query-replace-climacs-table :errorp nil)
1758    
1759     (defun query-replace-set-key (gesture command)
1760     (add-command-to-command-table command 'query-replace-climacs-table
1761     :keystroke gesture :errorp nil))
1762    
1763     (query-replace-set-key '(#\Newline) 'com-query-replace-exit)
1764     (query-replace-set-key '(#\Space) 'com-query-replace-replace)
1765     (query-replace-set-key '(#\Backspace) 'com-query-replace-skip)
1766     (query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
1767     (query-replace-set-key '(#\q) 'com-query-replace-exit)
1768     (query-replace-set-key '(#\y) 'com-query-replace-replace)
1769     (query-replace-set-key '(#\n) 'com-query-replace-skip)

  ViewVC Help
Powered by ViewVC 1.1.5