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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5