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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.76 - (show annotations)
Mon Jan 17 08:04:44 2005 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.75: +4 -2 lines
Create a new buffer when a name that corresponds to no existing buffer
is issued by the user when prompted for a buffer name.
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)
32 (;; allows a certain number of commands to have some minimal memory
33 (previous-command :initform nil :accessor previous-command)
34 ;; for next-line and previous-line commands
35 (goal-column :initform nil)
36 ;; for dynamic abbrev expansion
37 (original-prefix :initform nil)
38 (prefix-start-offset :initform nil)
39 (dabbrev-expansion-mark :initform nil)
40 (overwrite-mode :initform nil)))
41
42 (defclass minibuffer-pane (application-pane) ())
43
44 (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
45 (declare (ignore type args))
46 (window-clear pane))
47
48 (define-application-frame climacs ()
49 ((win :reader win)
50 (buffers :initform '() :accessor buffers))
51 (:panes
52 (win (make-pane 'extended-pane
53 :width 900 :height 400
54 :name 'win
55 :incremental-redisplay t
56 :display-function 'display-win))
57
58 (info :application
59 :width 900 :height 20 :max-height 20
60 :name 'info :background +light-gray+
61 :scroll-bars nil
62 :borders nil
63 :incremental-redisplay t
64 :display-function 'display-info)
65 (int (make-pane 'minibuffer-pane
66 :width 900 :height 20 :max-height 20 :min-height 20
67 :scroll-bars nil)))
68 (:layouts
69 (default
70 (vertically (:scroll-bars nil)
71 (scrolling (:width 900 :height 400) win)
72 info
73 int))
74 (without-interactor
75 (vertically (:scroll-bars nil)
76 (scrolling (:width 900 :height 400) win)
77 info)))
78 (:top-level (climacs-top-level)))
79
80 (defmethod redisplay-frame-panes :before ((frame climacs) &rest args)
81 (declare (ignore args))
82 (let ((buffer (buffer (win frame))))
83 (update-syntax buffer (syntax buffer))))
84
85 (defmethod redisplay-frame-panes :after ((frame climacs) &rest args)
86 (declare (ignore args))
87 (clear-modify (buffer (win frame))))
88
89 (defun climacs ()
90 "Starts up a climacs session"
91 (let ((frame (make-application-frame 'climacs)))
92 (run-frame-top-level frame)))
93
94 (defun display-message (format-string &rest format-args)
95 (apply #'format *standard-input* format-string format-args))
96
97 (defun display-info (frame pane)
98 (let* ((win (win frame))
99 (buf (buffer win))
100 (name-info (format nil " ~a ~a Syntax: ~a ~a"
101 (if (needs-saving buf) "**" "--")
102 (name buf)
103 (name (syntax buf))
104 (if (slot-value win 'overwrite-mode)
105 "Ovwrt"
106 ""))))
107 (princ name-info pane)))
108
109 (defun display-win (frame pane)
110 "The display function used by the climacs application frame."
111 (declare (ignore frame))
112 (redisplay-pane pane))
113
114 (defun find-gestures (gestures start-table)
115 (loop with table = (find-command-table start-table)
116 for (gesture . rest) on gestures
117 for item = (find-keystroke-item gesture table :errorp nil)
118 while item
119 do (if (eq (command-menu-item-type item) :command)
120 (return (if (null rest) item nil))
121 (setf table (command-menu-item-value item)))
122 finally (return item)))
123
124 (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))
125 (defparameter *current-gesture* nil)
126
127 (defun meta-digit (gesture)
128 (position gesture
129 '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta)
130 (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta))
131 :test #'event-matches-gesture-name-p))
132
133 (defun climacs-read-gesture ()
134 (loop for gesture = (read-gesture :stream *standard-input*)
135 when (event-matches-gesture-name-p gesture '(#\g :control))
136 do (throw 'outer-loop nil)
137 until (or (characterp gesture)
138 (and (typep gesture 'keyboard-event)
139 (or (keyboard-event-character gesture)
140 (not (member (keyboard-event-key-name
141 gesture)
142 '(:control-left :control-right
143 :shift-left :shift-right
144 :meta-left :meta-right
145 :super-left :super-right
146 :hyper-left :hyper-right
147 :shift-lock :caps-lock
148 :alt-left :alt-right))))))
149 finally (return gesture)))
150
151 (defun read-numeric-argument (&key (stream *standard-input*))
152 (let ((gesture (climacs-read-gesture)))
153 (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
154 (let ((numarg 4))
155 (loop for gesture = (climacs-read-gesture)
156 while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME
157 do (setf numarg (* 4 numarg))
158 finally (unread-gesture gesture :stream stream))
159 (let ((gesture (climacs-read-gesture)))
160 (cond ((and (characterp gesture)
161 (digit-char-p gesture 10))
162 (setf numarg (- (char-code gesture) (char-code #\0)))
163 (loop for gesture = (climacs-read-gesture)
164 while (and (characterp gesture)
165 (digit-char-p gesture 10))
166 do (setf numarg (+ (* 10 numarg)
167 (- (char-code gesture) (char-code #\0))))
168 finally (unread-gesture gesture :stream stream)
169 (return (values numarg t))))
170 (t
171 (unread-gesture gesture :stream stream)
172 (values numarg t))))))
173 ((meta-digit gesture)
174 (let ((numarg (meta-digit gesture)))
175 (loop for gesture = (climacs-read-gesture)
176 while (meta-digit gesture)
177 do (setf numarg (+ (* 10 numarg) (meta-digit gesture)))
178 finally (unread-gesture gesture :stream stream)
179 (return (values numarg t)))))
180 (t (unread-gesture gesture :stream stream)
181 (values 1 nil)))))
182
183 (defun climacs-top-level (frame &key
184 command-parser command-unparser
185 partial-command-parser prompt)
186 (declare (ignore command-parser command-unparser partial-command-parser prompt))
187 (with-slots (win) frame
188 (setf win (find-pane-named frame 'win))
189 (push (buffer win) (buffers frame)))
190 (let ((*standard-output* (find-pane-named frame 'win))
191 (*standard-input* (find-pane-named frame 'int))
192 (*print-pretty* nil)
193 (*abort-gestures* nil))
194 (redisplay-frame-panes frame :force-p t)
195 (loop (catch 'outer-loop
196 (loop for gestures = '()
197 for numarg = (read-numeric-argument :stream *standard-input*)
198 do (loop (setf *current-gesture* (climacs-read-gesture))
199 (setf gestures (nconc gestures (list *current-gesture*)))
200 (let ((item (find-gestures gestures 'global-climacs-table)))
201 (cond ((not item)
202 (beep) (return))
203 ((eq (command-menu-item-type item) :command)
204 (let ((command (command-menu-item-value item)))
205 (unless (consp command)
206 (setf command (list command)))
207 (setf command (substitute-numeric-argument-marker command numarg))
208 (handler-case
209 (execute-frame-command frame command)
210 (error (condition)
211 (beep)
212 (format *error-output* "~a~%" condition)))
213 (setf (previous-command *standard-output*)
214 (if (consp command)
215 (car command)
216 command))
217 (return)))
218 (t nil))))
219 (let ((buffer (buffer (win frame))))
220 (when (modified-p buffer)
221 (setf (needs-saving buffer) t)))
222 (redisplay-frame-panes frame)))
223 (beep)
224 (let ((buffer (buffer (win frame))))
225 (when (modified-p buffer)
226 (setf (needs-saving buffer) t)))
227 (redisplay-frame-panes frame))))
228
229 (defun region-limits (pane)
230 (if (mark< (mark pane) (point pane))
231 (values (mark pane) (point pane))
232 (values (point pane) (mark pane))))
233
234 (defmacro define-named-command (command-name args &body body)
235 `(define-climacs-command ,(if (listp command-name)
236 `(,@command-name :name t)
237 `(,command-name :name t)) ,args ,@body))
238
239 (define-named-command (com-quit) ()
240 (frame-exit *application-frame*))
241
242 (define-named-command com-toggle-overwrite-mode ()
243 (let ((win (win *application-frame*)))
244 (setf (slot-value win 'overwrite-mode)
245 (not (slot-value win 'overwrite-mode)))))
246
247 (define-command com-self-insert ()
248 (let* ((win (win *application-frame*))
249 (point (point win)))
250 (unless (constituentp *current-gesture*)
251 (possibly-expand-abbrev point))
252 (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point)))
253 (progn
254 (delete-range point)
255 (insert-object point *current-gesture*))
256 (insert-object point *current-gesture*))))
257
258 (define-named-command com-beginning-of-line ()
259 (beginning-of-line (point (win *application-frame*))))
260
261 (define-named-command com-end-of-line ()
262 (end-of-line (point (win *application-frame*))))
263
264 (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects"))
265 (delete-range (point (win *application-frame*)) count))
266
267 (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects"))
268 (delete-range (point (win *application-frame*)) (- count)))
269
270 (define-named-command com-transpose-objects ()
271 (let* ((point (point (win *application-frame*))))
272 (unless (beginning-of-buffer-p point)
273 (when (end-of-line-p point)
274 (backward-object point))
275 (let ((object (object-after point)))
276 (delete-range point)
277 (backward-object point)
278 (insert-object point object)
279 (forward-object point)))))
280
281 (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
282 (backward-object (point (win *application-frame*)) count))
283
284 (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects"))
285 (forward-object (point (win *application-frame*)) count))
286
287 (define-named-command com-transpose-words ()
288 (let* ((point (point (win *application-frame*))))
289 (let (bw1 bw2 ew1 ew2)
290 (backward-word point)
291 (setf bw1 (offset point))
292 (forward-word point)
293 (setf ew1 (offset point))
294 (forward-word point)
295 (when (= (offset point) ew1)
296 ;; this is emacs' message in the minibuffer
297 (error "Don't have two things to transpose"))
298 (setf ew2 (offset point))
299 (backward-word point)
300 (setf bw2 (offset point))
301 (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
302 (w1 (buffer-sequence (buffer point) bw1 ew1)))
303 (delete-word point)
304 (insert-sequence point w1)
305 (backward-word point)
306 (backward-word point)
307 (delete-word point)
308 (insert-sequence point w2)
309 (forward-word point)))))
310
311 (define-named-command com-transpose-lines ()
312 (let ((point (point (win *application-frame*))))
313 (beginning-of-line point)
314 (unless (beginning-of-buffer-p point)
315 (previous-line point))
316 (let* ((bol (offset point))
317 (eol (progn (end-of-line point)
318 (offset point)))
319 (line (buffer-sequence (buffer point) bol eol)))
320 (delete-region bol point)
321 ;; Remove newline at end of line as well.
322 (unless (end-of-buffer-p point)
323 (delete-range point))
324 ;; If the current line is at the end of the buffer, we want to
325 ;; be able to insert past it, so we need to get an extra line
326 ;; at the end.
327 (when (progn (end-of-line point)
328 (end-of-buffer-p point))
329 (insert-object point #\Newline))
330 (next-line point)
331 (insert-sequence point line)
332 (insert-object point #\Newline))))
333
334 (define-named-command com-previous-line ()
335 (let* ((win (win *application-frame*))
336 (point (point win)))
337 (unless (or (eq (previous-command win) 'com-previous-line)
338 (eq (previous-command win) 'com-next-line))
339 (setf (slot-value win 'goal-column) (column-number point)))
340 (previous-line point (slot-value win 'goal-column))))
341
342 (define-named-command com-next-line ()
343 (let* ((win (win *application-frame*))
344 (point (point win)))
345 (unless (or (eq (previous-command win) 'com-previous-line)
346 (eq (previous-command win) 'com-next-line))
347 (setf (slot-value win 'goal-column) (column-number point)))
348 (next-line point (slot-value win 'goal-column))))
349
350 (define-named-command com-open-line ()
351 (open-line (point (win *application-frame*))))
352
353 (define-named-command com-kill-line ()
354 (let* ((pane (win *application-frame*))
355 (point (point pane))
356 (mark (offset point)))
357 (cond ((end-of-buffer-p point) nil)
358 ((end-of-line-p point)(forward-object point))
359 (t
360 (end-of-line point)
361 (cond ((beginning-of-buffer-p point) nil)
362 ((beginning-of-line-p point)(forward-object point)))))
363 (if (eq (previous-command pane) 'com-kill-line)
364 (kill-ring-concatenating-push *kill-ring*
365 (region-to-sequence mark point))
366 (kill-ring-standard-push *kill-ring*
367 (region-to-sequence mark point)))
368 (delete-region mark point)))
369
370 (define-named-command com-forward-word ()
371 (forward-word (point (win *application-frame*))))
372
373 (define-named-command com-backward-word ()
374 (backward-word (point (win *application-frame*))))
375
376 (define-named-command com-delete-word ()
377 (delete-word (point (win *application-frame*))))
378
379 (define-named-command com-backward-delete-word ()
380 (backward-delete-word (point (win *application-frame*))))
381
382 (define-named-command com-upcase-region ()
383 (multiple-value-bind (start end) (region-limits (win *application-frame*))
384 (upcase-region start end)))
385
386 (define-named-command com-downcase-region ()
387 (multiple-value-bind (start end) (region-limits (win *application-frame*))
388 (downcase-region start end)))
389
390 (define-named-command com-capitalize-region ()
391 (multiple-value-bind (start end) (region-limits (win *application-frame*))
392 (capitalize-region start end)))
393
394 (define-named-command com-upcase-word ()
395 (upcase-word (point (win *application-frame*))))
396
397 (define-named-command com-downcase-word ()
398 (downcase-word (point (win *application-frame*))))
399
400 (define-named-command com-capitalize-word ()
401 (capitalize-word (point (win *application-frame*))))
402
403 (define-named-command com-tabify-region ()
404 (let ((pane (win *application-frame*)))
405 (multiple-value-bind (start end) (region-limits pane)
406 (tabify-region start end (tab-space-count (stream-default-view pane))))))
407
408 (define-named-command com-untabify-region ()
409 (let ((pane (win *application-frame*)))
410 (multiple-value-bind (start end) (region-limits pane)
411 (untabify-region start end (tab-space-count (stream-default-view pane))))))
412
413 (define-named-command com-delete-indentation ()
414 (delete-indentation (point (win *application-frame*))))
415
416 (define-named-command com-toggle-layout ()
417 (setf (frame-current-layout *application-frame*)
418 (if (eq (frame-current-layout *application-frame*) 'default)
419 'without-interactor
420 'default)))
421
422 (define-command com-extended-command ()
423 (let ((item (accept 'command :prompt "Extended Command")))
424 (execute-frame-command *application-frame* item)))
425
426 (eval-when (:compile-toplevel :load-toplevel)
427 (define-presentation-type completable-pathname ()
428 :inherit-from 'pathname))
429
430 (defun filename-completer (so-far mode)
431 (flet ((remove-trail (s)
432 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
433 (if pos (1+ pos) 0)))))
434 (let* ((directory-prefix
435 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
436 ""
437 (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
438 (full-so-far (concatenate 'string directory-prefix so-far))
439 (pathnames
440 (loop with length = (length full-so-far)
441 for path in (directory (concatenate 'string
442 (remove-trail so-far)
443 "*.*"))
444 when (let ((mismatch (mismatch (namestring path) full-so-far)))
445 (or (null mismatch) (= mismatch length)))
446 collect path))
447 (strings (mapcar #'namestring pathnames))
448 (first-string (car strings))
449 (length-common-prefix nil)
450 (completed-string nil)
451 (full-completed-string nil))
452 (unless (null pathnames)
453 (setf length-common-prefix
454 (loop with length = (length first-string)
455 for string in (cdr strings)
456 do (setf length (min length (or (mismatch string first-string) length)))
457 finally (return length))))
458 (unless (null pathnames)
459 (setf completed-string
460 (subseq first-string (length directory-prefix)
461 (if (null (cdr pathnames)) nil length-common-prefix)))
462 (setf full-completed-string
463 (concatenate 'string directory-prefix completed-string)))
464 (case mode
465 ((:complete-limited :complete-maximal)
466 (cond ((null pathnames)
467 (values so-far nil nil 0 nil))
468 ((null (cdr pathnames))
469 (values completed-string t (car pathnames) 1 nil))
470 (t
471 (values completed-string nil nil (length pathnames) nil))))
472 (:complete
473 (cond ((null pathnames)
474 (values so-far t so-far 1 nil))
475 ((null (cdr pathnames))
476 (values completed-string t (car pathnames) 1 nil))
477 ((find full-completed-string strings :test #'string-equal)
478 (let ((pos (position full-completed-string strings :test #'string-equal)))
479 (values completed-string
480 t (elt pathnames pos) (length pathnames) nil)))
481 (t
482 (values completed-string nil nil (length pathnames) nil))))
483 (:possibilities
484 (values nil nil nil (length pathnames)
485 (loop with length = (length directory-prefix)
486 for name in pathnames
487 collect (list (subseq (namestring name) length nil)
488 name))))))))
489
490 (define-presentation-method accept
491 ((type completable-pathname) stream (view textual-view) &key)
492 (multiple-value-bind (pathname success string)
493 (complete-input stream
494 #'filename-completer
495 :partial-completers '(#\Space)
496 :allow-any-input t)
497 (declare (ignore success))
498 (or pathname string)))
499
500 (defun pathname-filename (pathname)
501 (if (null (pathname-type pathname))
502 (pathname-name pathname)
503 (concatenate 'string (pathname-name pathname)
504 "." (pathname-type pathname))))
505
506 (define-named-command com-find-file ()
507 (let ((filename (accept 'completable-pathname
508 :prompt "Find File"))
509 (buffer (make-instance 'climacs-buffer))
510 (pane (win *application-frame*)))
511 (push buffer (buffers *application-frame*))
512 (setf (buffer (win *application-frame*)) buffer)
513 (setf (syntax buffer) (make-instance 'basic-syntax))
514 (with-open-file (stream filename :direction :input :if-does-not-exist :create)
515 (input-from-stream stream buffer 0))
516 (setf (filename buffer) filename
517 (name buffer) (pathname-filename filename)
518 (needs-saving buffer) nil)
519 (beginning-of-buffer (point pane))
520 ;; this one is needed so that the buffer modification protocol
521 ;; resets the low and high marks after redisplay
522 (redisplay-frame-panes *application-frame*)))
523
524 (define-named-command com-save-buffer ()
525 (let* ((buffer (buffer (win *application-frame*)))
526 (filename (or (filename buffer)
527 (accept 'completable-pathname
528 :prompt "Save Buffer to File"))))
529 (if (or (null (filename buffer))
530 (needs-saving buffer))
531 (progn (with-open-file (stream filename :direction :output :if-exists :supersede)
532 (output-to-stream stream buffer 0 (size buffer)))
533 (setf (filename buffer) filename
534 (name buffer) (pathname-filename filename))
535 (display-message "Wrote: ~a" (filename buffer)))
536 (display-message "No changes need to be saved from ~a" (name buffer)))
537 (setf (needs-saving buffer) nil)))
538
539 (define-named-command com-write-buffer ()
540 (let ((filename (accept 'completable-pathname
541 :prompt "Write Buffer to File"))
542 (buffer (buffer (win *application-frame*))))
543 (with-open-file (stream filename :direction :output :if-exists :supersede)
544 (output-to-stream stream buffer 0 (size buffer)))
545 (setf (filename buffer) filename
546 (name buffer) (pathname-filename filename)
547 (needs-saving buffer) nil)
548 (display-message "Wrote: ~a" (filename buffer))))
549
550 (define-presentation-method accept
551 ((type buffer) stream (view textual-view) &key)
552 (multiple-value-bind (object success string)
553 (complete-input stream
554 (lambda (so-far action)
555 (complete-from-possibilities
556 so-far (buffers *application-frame*) '() :action action
557 :name-key #'name
558 :value-key #'identity))
559 :partial-completers '(#\Space)
560 :allow-any-input t)
561 (declare (ignore success))
562 (or object
563 (car (push (make-instance 'climacs-buffer :name string)
564 (buffers *application-frame*))))))
565
566 (define-named-command com-switch-to-buffer ()
567 (let ((buffer (accept 'buffer
568 :prompt "Switch to buffer")))
569 (setf (buffer (win *application-frame*)) buffer)
570 (setf (syntax buffer) (make-instance 'basic-syntax))
571 (beginning-of-buffer (point (win *application-frame*)))
572 (full-redisplay (win *application-frame*))))
573
574 (define-named-command com-full-redisplay ()
575 (full-redisplay (win *application-frame*)))
576
577 (define-named-command com-load-file ()
578 (let ((filename (accept 'completable-pathname
579 :prompt "Load File")))
580 (load filename)))
581
582 (define-named-command com-beginning-of-buffer ()
583 (beginning-of-buffer (point (win *application-frame*))))
584
585 (define-named-command com-page-down ()
586 (let ((pane (win *application-frame*)))
587 (page-down pane)))
588
589 (define-named-command com-page-up ()
590 (let ((pane (win *application-frame*)))
591 (page-up pane)))
592
593 (define-named-command com-end-of-buffer ()
594 (end-of-buffer (point (win *application-frame*))))
595
596 (define-named-command com-back-to-indentation ()
597 (let ((point (point (win *application-frame*))))
598 (beginning-of-line point)
599 (loop until (end-of-line-p point)
600 while (whitespacep (object-after point))
601 do (incf (offset point)))))
602
603 (define-named-command com-goto-position ()
604 (setf (offset (point (win *application-frame*)))
605 (accept 'integer :prompt "Goto Position")))
606
607 (define-named-command com-goto-line ()
608 (loop with mark = (make-instance 'standard-right-sticky-mark
609 :buffer (buffer (win *application-frame*)))
610 do (end-of-line mark)
611 until (end-of-buffer-p mark)
612 repeat (accept 'integer :prompt "Goto Line")
613 do (incf (offset mark))
614 (end-of-line mark)
615 finally (beginning-of-line mark)
616 (setf (offset (point (win *application-frame*)))
617 (offset mark))))
618
619 (define-named-command com-browse-url ()
620 (accept 'url :prompt "Browse URL"))
621
622 (define-named-command com-set-mark ()
623 (let ((pane (win *application-frame*)))
624 (setf (mark pane) (clone-mark (point pane)))))
625
626 (define-named-command com-exchange-point-and-mark ()
627 (let ((pane (win *application-frame*)))
628 (psetf (offset (mark pane)) (offset (point pane))
629 (offset (point pane)) (offset (mark pane)))))
630
631 (define-named-command com-set-syntax ()
632 (let* ((pane (win *application-frame*))
633 (buffer (buffer pane)))
634 (setf (syntax buffer)
635 (make-instance (accept 'syntax :prompt "Set Syntax")))
636 (setf (offset (low-mark buffer)) 0
637 (offset (high-mark buffer)) (size buffer))))
638
639 ;;;;;;;;;;;;;;;;;;;;
640 ;; Kill ring commands
641
642 ;; Copies an element from a kill-ring to a buffer at the given offset
643 (define-named-command com-yank ()
644 (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*)))
645
646 ;; Destructively cut a given buffer region into the kill-ring
647 (define-named-command com-cut-out ()
648 (multiple-value-bind (start end) (region-limits (win *application-frame*))
649 (kill-ring-standard-push *kill-ring* (region-to-sequence start end))
650 (delete-region (offset start) end)))
651
652 ;; Non destructively copies in buffer region to the kill ring
653 (define-named-command com-copy-out ()
654 (let ((pane (win *application-frame*)))
655 (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
656
657 (define-named-command com-rotate-yank ()
658 (let* ((pane (win *application-frame*))
659 (point (point pane))
660 (last-yank (kill-ring-yank *kill-ring*)))
661 (if (eq (previous-command pane)
662 'com-rotate-yank)
663 (progn
664 (delete-range point (* -1 (length last-yank)))
665 (rotate-yank-position *kill-ring*)))
666 (insert-sequence point (kill-ring-yank *kill-ring*))))
667
668 (define-named-command com-resize-kill-ring ()
669 (let ((size (accept 'integer :prompt "New kill ring size")))
670 (setf (kill-ring-max-size *kill-ring*) size)))
671
672 (define-named-command com-search-forward ()
673 (search-forward (point (win *application-frame*))
674 (accept 'string :prompt "Search Forward")
675 :test (lambda (a b)
676 (and (characterp b) (char-equal a b)))))
677
678 (define-named-command com-search-backward ()
679 (search-backward (point (win *application-frame*))
680 (accept 'string :prompt "Search Backward")
681 :test (lambda (a b)
682 (and (characterp b) (char-equal a b)))))
683
684 (define-named-command com-dabbrev-expand ()
685 (let* ((win (win *application-frame*))
686 (point (point win)))
687 (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win
688 (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
689 (setf (offset dabbrev-expansion-mark)
690 (offset point))
691 (forward-word dabbrev-expansion-mark))
692 ((mark< dabbrev-expansion-mark point)
693 (backward-object dabbrev-expansion-mark))
694 (t (forward-object dabbrev-expansion-mark)))))
695 (unless (or (beginning-of-buffer-p point)
696 (not (constituentp (object-before point))))
697 (unless (and (eq (previous-command win) 'com-dabbrev-expand)
698 (not (null prefix-start-offset)))
699 (setf dabbrev-expansion-mark (clone-mark point))
700 (backward-word dabbrev-expansion-mark)
701 (setf prefix-start-offset (offset dabbrev-expansion-mark))
702 (setf original-prefix (region-to-sequence prefix-start-offset point))
703 (move))
704 (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
705 (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
706 (not (constituentp (object-before dabbrev-expansion-mark))))
707 (looking-at dabbrev-expansion-mark original-prefix)))
708 do (move))
709 (if (end-of-buffer-p dabbrev-expansion-mark)
710 (progn (delete-region prefix-start-offset point)
711 (insert-sequence point original-prefix)
712 (setf prefix-start-offset nil))
713 (progn (delete-region prefix-start-offset point)
714 (insert-sequence point
715 (let ((offset (offset dabbrev-expansion-mark)))
716 (prog2 (forward-word dabbrev-expansion-mark)
717 (region-to-sequence offset dabbrev-expansion-mark)
718 (setf (offset dabbrev-expansion-mark) offset))))
719 (move))))))))
720
721 (define-named-command com-beginning-of-paragraph ()
722 (let* ((pane (win *application-frame*))
723 (point (point pane))
724 (syntax (syntax (buffer pane))))
725 (beginning-of-paragraph point syntax)))
726
727 (define-named-command com-end-of-paragraph ()
728 (let* ((pane (win *application-frame*))
729 (point (point pane))
730 (syntax (syntax (buffer pane))))
731 (end-of-paragraph point syntax)))
732
733 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
734 ;;;
735 ;;; Global command table
736
737 (make-command-table 'global-climacs-table :errorp nil)
738
739 (defun global-set-key (gesture command)
740 (add-command-to-command-table command 'global-climacs-table
741 :keystroke gesture :errorp nil))
742
743 (loop for code from (char-code #\space) to (char-code #\~)
744 do (global-set-key (code-char code) 'com-self-insert))
745
746 (global-set-key #\newline 'com-self-insert)
747 (global-set-key #\tab 'com-self-insert)
748 (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))
749 (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*))
750 (global-set-key '(#\a :control) 'com-beginning-of-line)
751 (global-set-key '(#\e :control) 'com-end-of-line)
752 (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
753 (global-set-key '(#\p :control) 'com-previous-line)
754 (global-set-key '(#\l :control) 'com-full-redisplay)
755 (global-set-key '(#\n :control) 'com-next-line)
756 (global-set-key '(#\o :control) 'com-open-line)
757 (global-set-key '(#\k :control) 'com-kill-line)
758 (global-set-key '(#\t :control) 'com-transpose-objects)
759 (global-set-key '(#\Space :control) 'com-set-mark)
760 (global-set-key '(#\y :control) 'com-yank)
761 (global-set-key '(#\w :control) 'com-cut-out)
762 (global-set-key '(#\f :meta) 'com-forward-word)
763 (global-set-key '(#\b :meta) 'com-backward-word)
764 (global-set-key '(#\t :meta) 'com-transpose-words)
765 (global-set-key '(#\u :meta) 'com-upcase-word)
766 (global-set-key '(#\l :meta) 'com-downcase-word)
767 (global-set-key '(#\c :meta) 'com-capitalize-word)
768 (global-set-key '(#\x :meta) 'com-extended-command)
769 (global-set-key '(#\y :meta) 'com-rotate-yank)
770 (global-set-key '(#\w :meta) 'com-copy-out)
771 (global-set-key '(#\v :control) 'com-page-down)
772 (global-set-key '(#\v :meta) 'com-page-up)
773 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
774 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
775 (global-set-key '(#\m :meta) 'com-back-to-indentation)
776 (global-set-key '(#\^ :shift :meta) 'com-delete-indentation)
777 (global-set-key '(#\d :meta) 'com-delete-word)
778 (global-set-key '(#\Backspace :meta) 'com-backward-delete-word)
779 (global-set-key '(#\/ :meta) 'com-dabbrev-expand)
780 (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph)
781 (global-set-key '(#\e :control :meta) 'com-end-of-paragraph)
782
783 (global-set-key '(:up) 'com-previous-line)
784 (global-set-key '(:down) 'com-next-line)
785 (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
786 (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
787 (global-set-key '(:left :control) 'com-backward-word)
788 (global-set-key '(:right :control) 'com-forward-word)
789 (global-set-key '(:home) 'com-beginning-of-line)
790 (global-set-key '(:end) 'com-end-of-line)
791 (global-set-key '(:prior) 'com-page-up)
792 (global-set-key '(:next) 'com-page-down)
793 (global-set-key '(:home :control) 'com-beginning-of-buffer)
794 (global-set-key '(:end :control) 'com-end-of-buffer)
795 (global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*))
796 (global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*))
797
798 (global-set-key '(:insert) 'com-toggle-overwrite-mode)
799
800 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
801 ;;;
802 ;;; C-x command table
803
804 (make-command-table 'c-x-climacs-table :errorp nil)
805
806 (add-menu-item-to-command-table 'global-climacs-table "C-x"
807 :menu 'c-x-climacs-table
808 :keystroke '(#\x :control))
809
810 (defun c-x-set-key (gesture command)
811 (add-command-to-command-table command 'c-x-climacs-table
812 :keystroke gesture :errorp nil))
813
814 (c-x-set-key '(#\b) 'com-switch-to-buffer)
815 (c-x-set-key '(#\c :control) 'com-quit)
816 (c-x-set-key '(#\f :control) 'com-find-file)
817 (c-x-set-key '(#\l :control) 'com-load-file)
818 (c-x-set-key '(#\s :control) 'com-save-buffer)
819 (c-x-set-key '(#\t :control) 'com-transpose-lines)
820 (c-x-set-key '(#\w :control) 'com-write-buffer)
821 (c-x-set-key '(#\x :control) 'com-exchange-point-and-mark)
822
823 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
824 ;;;
825 ;;; Some Unicode stuff
826
827 (define-named-command com-insert-charcode ((code 'integer :prompt "Code point"))
828 (insert-object (point (win *application-frame*)) (code-char code)))
829
830 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
831 ;;;
832 ;;; Dead-acute command table
833
834 (make-command-table 'dead-acute-climacs-table :errorp nil)
835
836 (add-menu-item-to-command-table 'global-climacs-table "dead-acute"
837 :menu 'dead-acute-climacs-table
838 :keystroke '(:dead--acute))
839
840 (defun dead-acute-set-key (gesture command)
841 (add-command-to-command-table command 'dead-acute-climacs-table
842 :keystroke gesture :errorp nil))
843
844 (dead-acute-set-key '(#\A) '(com-insert-charcode 193))
845 (dead-acute-set-key '(#\E) '(com-insert-charcode 201))
846 (dead-acute-set-key '(#\I) '(com-insert-charcode 205))
847 (dead-acute-set-key '(#\O) '(com-insert-charcode 211))
848 (dead-acute-set-key '(#\U) '(com-insert-charcode 218))
849 (dead-acute-set-key '(#\Y) '(com-insert-charcode 221))
850 (dead-acute-set-key '(#\a) '(com-insert-charcode 225))
851 (dead-acute-set-key '(#\e) '(com-insert-charcode 233))
852 (dead-acute-set-key '(#\i) '(com-insert-charcode 237))
853 (dead-acute-set-key '(#\o) '(com-insert-charcode 243))
854 (dead-acute-set-key '(#\u) '(com-insert-charcode 250))
855 (dead-acute-set-key '(#\y) '(com-insert-charcode 253))
856 (dead-acute-set-key '(#\C) '(com-insert-charcode 199))
857 (dead-acute-set-key '(#\c) '(com-insert-charcode 231))
858 (dead-acute-set-key '(#\x) '(com-insert-charcode 215))
859 (dead-acute-set-key '(#\-) '(com-insert-charcode 247))
860 (dead-acute-set-key '(#\T) '(com-insert-charcode 222))
861 (dead-acute-set-key '(#\t) '(com-insert-charcode 254))
862 (dead-acute-set-key '(#\s) '(com-insert-charcode 223))
863 (dead-acute-set-key '(#\Space) '(com-insert-charcode 39))
864
865 (make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil)
866
867 (add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute"
868 :menu 'dead-acute-dead-accute-climacs-table
869 :keystroke '(:dead--acute))
870
871 (defun dead-acute-dead-accute-set-key (gesture command)
872 (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table
873 :keystroke gesture :errorp nil))
874
875 (dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197))
876 (dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229))
877 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
878 ;;;
879 ;;; Dead-grave command table
880
881 (make-command-table 'dead-grave-climacs-table :errorp nil)
882
883 (add-menu-item-to-command-table 'global-climacs-table "dead-grave"
884 :menu 'dead-grave-climacs-table
885 :keystroke '(:dead--grave))
886
887 (defun dead-grave-set-key (gesture command)
888 (add-command-to-command-table command 'dead-grave-climacs-table
889 :keystroke gesture :errorp nil))
890
891 (dead-grave-set-key '(#\A) '(com-insert-charcode 192))
892 (dead-grave-set-key '(#\E) '(com-insert-charcode 200))
893 (dead-grave-set-key '(#\I) '(com-insert-charcode 204))
894 (dead-grave-set-key '(#\O) '(com-insert-charcode 210))
895 (dead-grave-set-key '(#\U) '(com-insert-charcode 217))
896 (dead-grave-set-key '(#\a) '(com-insert-charcode 224))
897 (dead-grave-set-key '(#\e) '(com-insert-charcode 232))
898 (dead-grave-set-key '(#\i) '(com-insert-charcode 236))
899 (dead-grave-set-key '(#\o) '(com-insert-charcode 242))
900 (dead-grave-set-key '(#\u) '(com-insert-charcode 249))
901 (dead-grave-set-key '(#\Space) '(com-insert-charcode 96))
902
903 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
904 ;;;
905 ;;; Dead-diaeresis command table
906
907 (make-command-table 'dead-diaeresis-climacs-table :errorp nil)
908
909 (add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis"
910 :menu 'dead-diaeresis-climacs-table
911 :keystroke '(:dead--diaeresis :shift))
912
913 (defun dead-diaeresis-set-key (gesture command)
914 (add-command-to-command-table command 'dead-diaeresis-climacs-table
915 :keystroke gesture :errorp nil))
916
917 (dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196))
918 (dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203))
919 (dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207))
920 (dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214))
921 (dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220))
922 (dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228))
923 (dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235))
924 (dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239))
925 (dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246))
926 (dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252))
927 (dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255))
928 (dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34))
929
930 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
931 ;;;
932 ;;; Dead-tilde command table
933
934 (make-command-table 'dead-tilde-climacs-table :errorp nil)
935
936 (add-menu-item-to-command-table 'global-climacs-table "dead-tilde"
937 :menu 'dead-tilde-climacs-table
938 :keystroke '(:dead--tilde :shift))
939
940 (defun dead-tilde-set-key (gesture command)
941 (add-command-to-command-table command 'dead-tilde-climacs-table
942 :keystroke gesture :errorp nil))
943
944 (dead-tilde-set-key '(#\A) '(com-insert-charcode 195))
945 (dead-tilde-set-key '(#\N) '(com-insert-charcode 209))
946 (dead-tilde-set-key '(#\a) '(com-insert-charcode 227))
947 (dead-tilde-set-key '(#\n) '(com-insert-charcode 241))
948 (dead-tilde-set-key '(#\E) '(com-insert-charcode 198))
949 (dead-tilde-set-key '(#\e) '(com-insert-charcode 230))
950 (dead-tilde-set-key '(#\D) '(com-insert-charcode 208))
951 (dead-tilde-set-key '(#\d) '(com-insert-charcode 240))
952 (dead-tilde-set-key '(#\O) '(com-insert-charcode 216))
953 (dead-tilde-set-key '(#\o) '(com-insert-charcode 248))
954 (dead-tilde-set-key '(#\Space) '(com-insert-charcode 126))
955
956 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
957 ;;;
958 ;;; Dead-circumflex command table
959
960 (make-command-table 'dead-circumflex-climacs-table :errorp nil)
961
962 (add-menu-item-to-command-table 'global-climacs-table "dead-circumflex"
963 :menu 'dead-circumflex-climacs-table
964 :keystroke '(:dead--circumflex :shift))
965
966 (defun dead-circumflex-set-key (gesture command)
967 (add-command-to-command-table command 'dead-circumflex-climacs-table
968 :keystroke gesture :errorp nil))
969
970 (dead-circumflex-set-key '(#\A) '(com-insert-charcode 194))
971 (dead-circumflex-set-key '(#\E) '(com-insert-charcode 202))
972 (dead-circumflex-set-key '(#\I) '(com-insert-charcode 206))
973 (dead-circumflex-set-key '(#\O) '(com-insert-charcode 212))
974 (dead-circumflex-set-key '(#\U) '(com-insert-charcode 219))
975 (dead-circumflex-set-key '(#\a) '(com-insert-charcode 226))
976 (dead-circumflex-set-key '(#\e) '(com-insert-charcode 234))
977 (dead-circumflex-set-key '(#\i) '(com-insert-charcode 238))
978 (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244))
979 (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
980 (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))

  ViewVC Help
Powered by ViewVC 1.1.5