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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5