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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.59 - (hide annotations)
Sun Jan 9 11:54:50 2005 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.58: +0 -10 lines
Moved forward-object and backward-object to base.lisp because I
needed them in syntax.lisp.

Improved performance of end-of-line, the slowness of which was
a problem for redisplay.

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

  ViewVC Help
Powered by ViewVC 1.1.5