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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5