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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.150 - (hide annotations)
Mon Jul 11 08:47:50 2005 UTC (8 years, 9 months ago) by rstrandh
Branch: MAIN
Changes since 1.149: +1 -0 lines
Indentation for defclass.

Code factoring through a macro called define-list-indentor.

Ignore errors when reading package name after `in-package'.

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

  ViewVC Help
Powered by ViewVC 1.1.5