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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5