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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5