[climacs-cvs] CVS update: climacs/gui.lisp climacs/climacs.asd climacs/cl-syntax.lisp
Dave Murray
dmurray at common-lisp.net
Sat Nov 12 09:34:38 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv18067
Modified Files:
gui.lisp climacs.asd cl-syntax.lisp
Log Message:
Moved various things from gui.lisp into developer-commands.lisp,
file-commands.lisp, misc-commands.lisp (rather large...),
search-commands.lisp, unicode-commands.lisp and
window-commands.lisp. Also tried to get the .asd right.
Additionally, removed "lisp" as a file-type for the Common Lisp
syntax.
Date: Sat Nov 12 10:34:35 2005
Author: dmurray
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.194 climacs/gui.lisp:1.195
--- climacs/gui.lisp:1.194 Thu Nov 3 11:17:40 2005
+++ climacs/gui.lisp Sat Nov 12 10:34:34 2005
@@ -250,652 +250,43 @@
do (when (modified-p buffer)
(setf (needs-saving buffer) t))))
-(define-command (com-overwrite-mode :name t :command-table editing-table) ()
- (with-slots (overwrite-mode) (current-window)
- (setf overwrite-mode (not overwrite-mode))))
-
-(set-key 'com-overwrite-mode
- 'editing-table
- '((:insert)))
-
-(define-command (com-not-modified :name t :command-table buffer-table) ()
- (setf (needs-saving (buffer (current-window))) nil))
-
-(set-key 'com-not-modified
- 'buffer-table
- '((#\~ :meta :shift)))
-
-(define-command (com-set-fill-column :name t :command-table fill-table)
- ((column 'integer :prompt "Column Number:"))
- (set-fill-column column))
-
-(set-key `(com-set-fill-column ,*numeric-argument-marker*)
- 'fill-table
- '((#\x :control) (#\f)))
-
-(defun set-fill-column (column)
- (if (> column 1)
- (setf (auto-fill-column (current-window)) column)
- (progn (beep) (display-message "Set Fill Column requires an explicit argument."))))
-
-(defun possibly-fill-line ()
- (let* ((pane (current-window))
- (buffer (buffer pane)))
- (when (auto-fill-mode pane)
- (let* ((fill-column (auto-fill-column pane))
- (point (point pane))
- (offset (offset point))
- (tab-width (tab-space-count (stream-default-view pane)))
- (syntax (syntax buffer)))
- (when (>= (buffer-display-column buffer offset tab-width)
- (1- fill-column))
- (fill-line point
- (lambda (mark)
- (syntax-line-indentation mark tab-width syntax))
- fill-column
- tab-width))))))
-
-(defun insert-character (char)
- (let* ((window (current-window))
- (point (point window)))
- (unless (constituentp char)
- (possibly-expand-abbrev point))
- (when (whitespacep char)
- (possibly-fill-line))
- (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point)))
- (progn
- (delete-range point)
- (insert-object point char))
- (insert-object point char))))
-
-(define-command com-self-insert ((count 'integer))
- (loop repeat count do (insert-character *current-gesture*)))
-
-(define-command (com-beginning-of-line :name t :command-table movement-table) ()
- (beginning-of-line (point (current-window))))
-
-(set-key 'com-beginning-of-line
- 'movement-table
- '((:home)))
-
-(set-key 'com-beginning-of-line
- 'movement-table
- '((#\a :control)))
-
-(define-command (com-end-of-line :name t :command-table movement-table) ()
- (end-of-line (point (current-window))))
-
-(set-key 'com-end-of-line
- 'movement-table
- '((#\e :control)))
-
-(set-key 'com-end-of-line
- 'movement-table
- '((:end)))
-
-(define-command (com-delete-object :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of Objects")
- (killp 'boolean :prompt "Kill?"))
- (let* ((point (point (current-window)))
- (mark (clone-mark point)))
- (forward-object mark count)
- (when killp
- (kill-ring-standard-push *kill-ring*
- (region-to-sequence point mark)))
- (delete-region point mark)))
-
-(set-key `(com-delete-object ,*numeric-argument-marker*
- ,*numeric-argument-p*)
- 'deletion-table
- '(#\Rubout))
-
-(set-key `(com-delete-object ,*numeric-argument-marker*
- ,*numeric-argument-p*)
- 'deletion-table
- '((#\d :control)))
-
-(define-command (com-backward-delete-object :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of Objects")
- (killp 'boolean :prompt "Kill?"))
- (let* ((point (point (current-window)))
- (mark (clone-mark point)))
- (backward-object mark count)
- (when killp
- (kill-ring-standard-push *kill-ring*
- (region-to-sequence mark point)))
- (delete-region mark point)))
-
-(set-key `(com-backward-delete-object ,*numeric-argument-marker*
- ,*numeric-argument-p*)
- 'deletion-table
- '(#\Backspace))
-
-(define-command (com-zap-to-object :name t :command-table deletion-table) ()
- (let* ((item (handler-case (accept 't :prompt "Zap to Object")
- (error () (progn (beep)
- (display-message "Not a valid object")
- (return-from com-zap-to-object nil)))))
- (current-point (point (current-window)))
- (item-mark (clone-mark current-point))
- (current-offset (offset current-point)))
- (search-forward item-mark (vector item))
- (delete-range current-point (- (offset item-mark) current-offset))))
-
-(define-command (com-zap-to-character :name t :command-table deletion-table) ()
- (let* ((item-string (handler-case (accept 'string :prompt "Zap to Character") ; Figure out how to get #\d and d. (or 'string 'character)?
- (error () (progn (beep)
- (display-message "Not a valid string. ")
- (return-from com-zap-to-character nil)))))
- (item (subseq item-string 0 1))
- (current-point (point (current-window)))
- (item-mark (clone-mark current-point))
-
- (current-offset (offset current-point)))
- (if (> (length item-string) 1)
- (display-message "Using just the first character"))
- (search-forward item-mark item)
- (delete-range current-point (- (offset item-mark) current-offset))))
-
-(set-key 'com-zap-to-character
- 'deletion-table
- '((#\z :meta)))
-
-(defun transpose-objects (mark)
- (unless (beginning-of-buffer-p mark)
- (when (end-of-line-p mark)
- (backward-object mark))
- (let ((object (object-after mark)))
- (delete-range mark)
- (backward-object mark)
- (insert-object mark object)
- (forward-object mark))))
-
-(define-command (com-transpose-objects :name t :command-table editing-table) ()
- (transpose-objects (point (current-window))))
-
-(set-key 'com-transpose-objects
- 'editing-table
- '((#\t :control)))
-
-(define-command (com-backward-object :name t :command-table movement-table)
- ((count 'integer :prompt "Number of Objects"))
- (backward-object (point (current-window)) count))
-
-(set-key `(com-backward-object ,*numeric-argument-marker*)
- 'movement-table
- '((#\b :control)))
-
-(set-key `(com-backward-object ,*numeric-argument-marker*)
- 'movement-table
- '((:left)))
-
-(define-command (com-forward-object :name t :command-table movement-table)
- ((count 'integer :prompt "Number of Objects"))
- (forward-object (point (current-window)) count))
-
-(set-key `(com-forward-object ,*numeric-argument-marker*)
- 'movement-table
- '((#\f :control)))
-
-(set-key `(com-forward-object ,*numeric-argument-marker*)
- 'movement-table
- '((:right)))
-
-(defun transpose-words (mark)
- (let (bw1 bw2 ew1 ew2)
- (backward-word mark)
- (setf bw1 (offset mark))
- (forward-word mark)
- (setf ew1 (offset mark))
- (forward-word mark)
- (when (= (offset mark) ew1)
- ;; this is emacs' message in the minibuffer
- (error "Don't have two things to transpose"))
- (setf ew2 (offset mark))
- (backward-word mark)
- (setf bw2 (offset mark))
- (let ((w2 (buffer-sequence (buffer mark) bw2 ew2))
- (w1 (buffer-sequence (buffer mark) bw1 ew1)))
- (delete-word mark)
- (insert-sequence mark w1)
- (backward-word mark)
- (backward-word mark)
- (delete-word mark)
- (insert-sequence mark w2)
- (forward-word mark))))
-
-(define-command (com-transpose-words :name t :command-table editing-table) ()
- (transpose-words (point (current-window))))
-
-(set-key 'com-transpose-words
- 'editing-table
- '((#\t :meta)))
-
-(defun transpose-lines (mark)
- (beginning-of-line mark)
- (unless (beginning-of-buffer-p mark)
- (previous-line mark))
- (let* ((bol (offset mark))
- (eol (progn (end-of-line mark)
- (offset mark)))
- (line (buffer-sequence (buffer mark) bol eol)))
- (delete-region bol mark)
- ;; Remove newline at end of line as well.
- (unless (end-of-buffer-p mark)
- (delete-range mark))
- ;; If the current line is at the end of the buffer, we want to
- ;; be able to insert past it, so we need to get an extra line
- ;; at the end.
- (end-of-line mark)
- (when (end-of-buffer-p mark)
- (insert-object mark #\Newline))
- (next-line mark 0)
- (insert-sequence mark line)
- (insert-object mark #\Newline)))
-
-(define-command (com-transpose-lines :name t :command-table editing-table) ()
- (transpose-lines (point (current-window))))
-
-(set-key 'com-transpose-lines
- 'editing-table
- '((#\x :control) (#\t :control)))
-
-(define-command (com-previous-line :name t :command-table movement-table)
- ((numarg 'integer :prompt "How many lines?"))
- (let* ((window (current-window))
- (point (point window)))
- (unless (or (eq (previous-command window) 'com-previous-line)
- (eq (previous-command window) 'com-next-line))
- (setf (slot-value window 'goal-column) (column-number point)))
- (if (plusp numarg)
- (previous-line point (slot-value window 'goal-column) numarg)
- (next-line point (slot-value window 'goal-column) (- numarg)))))
-
-(set-key `(com-previous-line ,*numeric-argument-marker*)
- 'movement-table
- '((#\p :control)))
-
-(set-key `(com-previous-line ,*numeric-argument-marker*)
- 'movement-table
- '((:up)))
-
-(define-command (com-next-line :name t :command-table movement-table)
- ((numarg 'integer :prompt "How many lines?"))
- (let* ((window (current-window))
- (point (point window)))
- (unless (or (eq (previous-command window) 'com-previous-line)
- (eq (previous-command window) 'com-next-line))
- (setf (slot-value window 'goal-column) (column-number point)))
- (if (plusp numarg)
- (next-line point (slot-value window 'goal-column) numarg)
- (previous-line point (slot-value window 'goal-column) (- numarg)))))
-
-(set-key `(com-next-line ,*numeric-argument-marker*)
- 'movement-table
- '((#\n :control)))
-
-(set-key `(com-next-line ,*numeric-argument-marker*)
- 'movement-table
- '((:down)))
-
-(define-command (com-open-line :name t :command-table editing-table)
- ((numarg 'integer :prompt "How many lines?"))
- (open-line (point (current-window)) numarg))
-
-(set-key `(com-open-line ,*numeric-argument-marker*)
- 'editing-table
- '((#\o :control)))
-
-(defun kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil))
- (let ((start (offset mark)))
- (cond ((= 0 count)
- (beginning-of-line mark))
- ((< count 0)
- (loop repeat (- count)
- until (beginning-of-buffer-p mark)
- do (beginning-of-line mark)
- until (beginning-of-buffer-p mark)
- do (backward-object mark)))
- ((or whole-lines-p (> count 1))
- (loop repeat count
- until (end-of-buffer-p mark)
- do (end-of-line mark)
- until (end-of-buffer-p mark)
- do (forward-object mark)))
- (t
- (cond ((end-of-buffer-p mark) nil)
- ((end-of-line-p mark)(forward-object mark))
- (t (end-of-line mark)))))
- (unless (mark= mark start)
- (if concatenate-p
- (kill-ring-concatenating-push *kill-ring*
- (region-to-sequence start mark))
- (kill-ring-standard-push *kill-ring*
- (region-to-sequence start mark)))
- (delete-region start mark))))
-
-(define-command (com-kill-line :name t :command-table deletion-table)
- ((numarg 'integer :prompt "Kill how many lines?")
- (numargp 'boolean :prompt "Kill entire lines?"))
- (let* ((pane (current-window))
- (point (point pane))
- (concatenate-p (eq (previous-command pane) 'com-kill-line)))
- (kill-line point numarg numargp concatenate-p)))
-
-(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*)
- 'deletion-table
- '((#\k :control)))
-
-(define-command (com-forward-word :name t :command-table movement-table)
- ((count 'integer :prompt "Number of words"))
- (if (plusp count)
- (forward-word (point (current-window)) count)
- (backward-word (point (current-window)) (- count))))
-
-(set-key `(com-forward-word ,*numeric-argument-marker*)
- 'movement-table
- '((#\f :meta)))
-
-(set-key `(com-forward-word ,*numeric-argument-marker*)
- 'movement-table
- '((:right :control)))
-
-(define-command (com-backward-word :name t :command-table movement-table)
- ((count 'integer :prompt "Number of words"))
- (backward-word (point (current-window)) count))
-
-(set-key `(com-backward-word ,*numeric-argument-marker*)
- 'movement-table
- '((#\b :meta)))
-
-(set-key `(com-backward-word ,*numeric-argument-marker*)
- 'movement-table
- '((:left :control)))
-
-(define-command (com-delete-word :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of words"))
- (delete-word (point (current-window)) count))
-
-(defun kill-word (mark &optional (count 1) (concatenate-p nil))
- (let ((start (offset mark)))
- (if (plusp count)
- (loop repeat count
- until (end-of-buffer-p mark)
- do (forward-word mark))
- (loop repeat (- count)
- until (beginning-of-buffer-p mark)
- do (backward-word mark)))
- (unless (mark= mark start)
- (if concatenate-p
- (if (plusp count)
- (kill-ring-concatenating-push *kill-ring*
- (region-to-sequence start mark))
- (kill-ring-reverse-concatenating-push *kill-ring*
- (region-to-sequence start mark)))
- (kill-ring-standard-push *kill-ring*
- (region-to-sequence start mark)))
- (delete-region start mark))))
-
-(define-command (com-kill-word :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of words"))
- (let* ((pane (current-window))
- (point (point pane))
- (concatenate-p (eq (previous-command pane) 'com-kill-word)))
- (kill-word point count concatenate-p)))
-
-(set-key `(com-kill-word ,*numeric-argument-marker*)
- 'deletion-table
- '((#\d :meta)))
-
-(define-command (com-backward-kill-word :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of words"))
- (let* ((pane (current-window))
- (point (point pane))
- (concatenate-p (eq (previous-command pane) 'com-backward-kill-word)))
- (kill-word point (- count) concatenate-p)))
-
-(set-key `(com-backward-kill-word ,*numeric-argument-marker*)
- 'deletion-table
- '((#\Backspace :meta)))
-
-(define-command (com-mark-word :name t :command-table marking-table)
- ((count 'integer :prompt "Number of words"))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane)))
- (unless (eq (previous-command pane) 'com-mark-word)
- (setf (offset mark) (offset point)))
- (if (plusp count)
- (forward-word mark count)
- (backward-word mark (- count)))))
-
-(set-key `(com-mark-word ,*numeric-argument-marker*)
- 'marking-table
- '((#\@ :meta :shift)))
-
-(define-command (com-backward-delete-word :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of words"))
- (backward-delete-word (point (current-window)) count))
-
-(define-command (com-upcase-region :name t :command-table case-table) ()
- (let ((cw (current-window)))
- (upcase-region (mark cw) (point cw))))
-
-(define-command (com-downcase-region :name t :command-table case-table) ()
- (let ((cw (current-window)))
- (downcase-region (mark cw) (point cw))))
-
-(define-command (com-capitalize-region :name t :command-table case-table) ()
- (let ((cw (current-window)))
- (capitalize-region (mark cw) (point cw))))
-
-(define-command (com-upcase-word :name t :command-table case-table) ()
- (upcase-word (point (current-window))))
-
-(set-key 'com-upcase-word
- 'case-table
- '((#\u :meta)))
-
-(define-command (com-downcase-word :name t :command-table case-table) ()
- (downcase-word (point (current-window))))
-
-(set-key 'com-downcase-word
- 'case-table
- '((#\l :meta)))
-
-(define-command (com-capitalize-word :name t :command-table case-table) ()
- (capitalize-word (point (current-window))))
-
-(set-key 'com-capitalize-word
- 'case-table
- '((#\c :meta)))
-
-(define-command (com-tabify-region :name t :command-table editing-table) ()
- (let ((pane (current-window)))
- (tabify-region
- (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
-
-(define-command (com-untabify-region :name t :command-table editing-table) ()
- (let ((pane (current-window)))
- (untabify-region
- (mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
-
-(defun indent-current-line (pane point)
- (let* ((buffer (buffer pane))
- (view (stream-default-view pane))
- (tab-space-count (tab-space-count view))
- (indentation (syntax-line-indentation point
- tab-space-count
- (syntax buffer))))
- (indent-line point indentation (and (indent-tabs-mode buffer)
- tab-space-count))))
-
-(define-command (com-indent-line :name t :command-table indent-table) ()
- (let* ((pane (current-window))
- (point (point pane)))
- (indent-current-line pane point)))
-
-(set-key 'com-indent-line
- 'indent-table
- '((#\Tab)))
-
-(set-key 'com-indent-line
- 'indent-table
- '((#\i :control)))
-
-(define-command (com-newline-and-indent :name t :command-table indent-table) ()
- (let* ((pane (current-window))
- (point (point pane)))
- (insert-object point #\Newline)
- (indent-current-line pane point)))
-
-(set-key 'com-newline-and-indent
- 'indent-table
- '((#\j :control)))
-
-(define-command (com-delete-indentation :name t :command-table indent-table) ()
- (delete-indentation (point (current-window))))
-
-(set-key 'com-delete-indentation
- 'indent-table
- '((#\^ :shift :meta)))
-
-(define-command (com-auto-fill-mode :name t :command-table fill-table) ()
- (let ((pane (current-window)))
- (setf (auto-fill-mode pane) (not (auto-fill-mode pane)))))
-
-(define-command (com-fill-paragraph :name t :command-table fill-table) ()
- (let* ((pane (current-window))
- (buffer (buffer pane))
- (syntax (syntax buffer))
- (point (point pane))
- (begin-mark (clone-mark point))
- (end-mark (clone-mark point)))
- (unless (eql (object-before begin-mark) #\Newline)
- (backward-paragraph begin-mark syntax))
- (unless (eql (object-after end-mark) #\Newline)
- (forward-paragraph end-mark syntax))
- (do-buffer-region (object offset buffer
- (offset begin-mark) (offset end-mark))
- (when (eql object #\Newline)
- (setf object #\Space)))
- (let ((point-backup (clone-mark point)))
- (setf (offset point) (offset end-mark))
- (possibly-fill-line)
- (setf (offset point) (offset point-backup)))))
-
-(set-key 'com-fill-paragraph
- 'fill-table
- '((#\q :meta)))
-
-(defun filename-completer (so-far mode)
- (flet ((remove-trail (s)
- (subseq s 0 (let ((pos (position #\/ s :from-end t)))
- (if pos (1+ pos) 0)))))
- (let* ((directory-prefix
- (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
- ""
- (namestring #+sbcl *default-pathname-defaults*
- #+cmu (ext:default-directory)
- #-(or sbcl cmu) *default-pathname-defaults*)))
- (full-so-far (concatenate 'string directory-prefix so-far))
- (pathnames
- (loop with length = (length full-so-far)
- and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
- for path in
- #+(or sbcl cmu lispworks) (directory wildcard)
- #+openmcl (directory wildcard :directories t)
- #+allegro (directory wildcard :directories-are-files nil)
- #+cormanlisp (nconc (directory wildcard)
- (cl::directory-subdirs dirname))
- #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
- (directory wildcard)
- when (let ((mismatch (mismatch (namestring path) full-so-far)))
- (or (null mismatch) (= mismatch length)))
- collect path))
- (strings (mapcar #'namestring pathnames))
- (first-string (car strings))
- (length-common-prefix nil)
- (completed-string nil)
- (full-completed-string nil))
- (unless (null pathnames)
- (setf length-common-prefix
- (loop with length = (length first-string)
- for string in (cdr strings)
- do (setf length (min length (or (mismatch string first-string) length)))
- finally (return length))))
- (unless (null pathnames)
- (setf completed-string
- (subseq first-string (length directory-prefix)
- (if (null (cdr pathnames)) nil length-common-prefix)))
- (setf full-completed-string
- (concatenate 'string directory-prefix completed-string)))
- (case mode
- ((:complete-limited :complete-maximal)
- (cond ((null pathnames)
- (values so-far nil nil 0 nil))
- ((null (cdr pathnames))
- (values completed-string t (car pathnames) 1 nil))
- (t
- (values completed-string nil nil (length pathnames) nil))))
- (:complete
- (cond ((null pathnames)
- (values so-far t so-far 1 nil))
- ((null (cdr pathnames))
- (values completed-string t (car pathnames) 1 nil))
- ((find full-completed-string strings :test #'string-equal)
- (let ((pos (position full-completed-string strings :test #'string-equal)))
- (values completed-string
- t (elt pathnames pos) (length pathnames) nil)))
+(define-command (com-full-redisplay :name t :command-table base-table) ()
+ (full-redisplay (current-window)))
+
+(set-key 'com-full-redisplay
+ 'base-table
+ '((#\l :control)))
+
+(defun load-file (file-name)
+ (cond ((directory-pathname-p file-name)
+ (display-message "~A is a directory name." file-name)
+ (beep))
+ (t
+ (cond ((probe-file file-name)
+ (load file-name))
(t
- (values completed-string nil nil (length pathnames) nil))))
- (:possibilities
- (values nil nil nil (length pathnames)
- (loop with length = (length directory-prefix)
- for name in pathnames
- collect (list (subseq (namestring name) length nil)
- name))))))))
-
-(define-presentation-method present (object (type pathname)
- stream (view climacs-textual-view) &key)
- (princ (namestring object) stream))
-
-(define-presentation-method accept ((type pathname) stream (view climacs-textual-view)
- &key (default nil defaultp) (default-type type))
- (multiple-value-bind (pathname success string)
- (complete-input stream
- #'filename-completer
- :allow-any-input t)
- (cond (success
- (values pathname type))
- ((and (zerop (length string))
- defaultp)
- (values default default-type))
- (t (values string 'string)))))
-
-(defun filepath-filename (pathname)
- (if (null (pathname-type pathname))
- (pathname-name pathname)
- (concatenate 'string (pathname-name pathname)
- "." (pathname-type pathname))))
-
-(defun syntax-class-name-for-filepath (filepath)
- (or (climacs-syntax::syntax-description-class-name
- (find (or (pathname-type filepath)
- (pathname-name filepath))
- climacs-syntax::*syntaxes*
- :test (lambda (x y)
- (member x y :test #'string-equal))
- :key #'climacs-syntax::syntax-description-pathname-types))
- 'basic-syntax))
-
-;; Adapted from cl-fad/PCL
-(defun directory-pathname-p (pathspec)
- "Returns NIL if PATHSPEC does not designate a directory."
- (let ((name (pathname-name pathspec))
- (type (pathname-type pathspec)))
- (and (or (null name) (eql name :unspecific))
- (or (null type) (eql type :unspecific)))))
+ (display-message "No such file: ~A" file-name)
+ (beep))))))
+
+(define-command (com-load-file :name t :command-table base-table) ()
+ (let ((filepath (accept 'pathname :prompt "Load File")))
+ (load-file filepath)))
+
+(set-key 'com-load-file
+ 'base-table
+ '((#\c :control) (#\l :control)))
+
+(loop for code from (char-code #\Space) to (char-code #\~)
+ do (set-key `(com-self-insert ,*numeric-argument-marker*)
+ 'self-insert-table
+ (list (list (code-char code)))))
+
+(set-key `(com-self-insert ,*numeric-argument-marker*)
+ 'self-insert-table
+ '((#\Newline)))
+
+;;;;;;;;;;;;;;;;;;;
+;;; Pane commands
(defun make-buffer (&optional name)
(let ((buffer (make-instance 'climacs-buffer)))
@@ -903,124 +294,6 @@
(push buffer (buffers *application-frame*))
buffer))
-(defun find-file (filepath)
- (cond ((null filepath)
- (display-message "No file name given.")
- (beep))
- ((directory-pathname-p filepath)
- (display-message "~A is a directory name." filepath)
- (beep))
- (t
- (let ((existing-buffer (find filepath (buffers *application-frame*)
- :key #'filepath :test #'equal)))
- (if existing-buffer
- (switch-to-buffer existing-buffer)
- (let ((buffer (make-buffer))
- (pane (current-window)))
- (setf (offset (point (buffer pane))) (offset (point pane)))
- (setf (buffer (current-window)) buffer)
- (setf (syntax buffer)
- (make-instance (syntax-class-name-for-filepath filepath)
- :buffer (buffer (point pane))))
- ;; Don't want to create the file if it doesn't exist.
- (when (probe-file filepath)
- (with-open-file (stream filepath :direction :input)
- (input-from-stream stream buffer 0)))
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath)
- (needs-saving buffer) nil)
- (beginning-of-buffer (point pane))
- ;; this one is needed so that the buffer modification protocol
- ;; resets the low and high marks after redisplay
- (redisplay-frame-panes *application-frame*)
- buffer))))))
-
-(define-command (com-find-file :name t :command-table buffer-table) ()
- (let* ((filepath (accept 'pathname :prompt "Find File")))
- (find-file filepath)))
-
-(set-key 'com-find-file
- 'buffer-table
- '((#\x :control) (#\f :control)))
-
-(defun find-file-read-only (filepath)
- (cond ((null filepath)
- (display-message "No file name given.")
- (beep))
- ((directory-pathname-p filepath)
- (display-message "~A is a directory name." filepath)
- (beep))
- (t
- (let ((existing-buffer (find filepath (buffers *application-frame*)
- :key #'filepath :test #'equal)))
- (if (and existing-buffer (read-only-p existing-buffer))
- (switch-to-buffer existing-buffer)
- (if (probe-file filepath)
- (let ((buffer (make-buffer))
- (pane (current-window)))
- (setf (offset (point (buffer pane))) (offset (point pane)))
- (setf (buffer (current-window)) buffer)
- (setf (syntax buffer)
- (make-instance (syntax-class-name-for-filepath filepath)
- :buffer (buffer (point pane))))
- (with-open-file (stream filepath :direction :input)
- (input-from-stream stream buffer 0))
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath)
- (needs-saving buffer) nil
- (read-only-p buffer) t)
- (beginning-of-buffer (point pane))
- ;; this one is needed so that the buffer modification protocol
- ;; resets the low and high marks after redisplay
- (redisplay-frame-panes *application-frame*)
- buffer)
- (progn
- (display-message "No such file: ~A" filepath)
- (beep)
- nil)))))))
-
-(define-command (com-find-file-read-only :name t :command-table buffer-table) ()
- (let ((filepath (accept 'pathname :Prompt "Find file read only")))
- (find-file-read-only filepath)))
-
-(set-key 'com-find-file-read-only
- 'buffer-table
- '((#\x :control) (#\r :control)))
-
-(define-command (com-read-only :name t :command-table buffer-table) ()
- (let ((buffer (buffer (current-window))))
- (setf (read-only-p buffer) (not (read-only-p buffer)))))
-
-(set-key 'com-read-only
- 'buffer-table
- '((#\x :control) (#\q :control)))
-
-(defun set-visited-file-name (filename buffer)
- (setf (filepath buffer) filename
- (name buffer) (filepath-filename filename)
- (needs-saving buffer) t))
-
-(define-command (com-set-visited-file-name :name t :command-table buffer-table) ()
- (let ((filename (accept 'pathname :prompt "New file name")))
- (set-visited-file-name filename (buffer (current-window)))))
-
-(define-command (com-insert-file :name t :command-table buffer-table) ()
- (let ((filename (accept 'pathname :prompt "Insert File"))
- (pane (current-window)))
- (when (probe-file filename)
- (setf (mark pane) (clone-mark (point pane) :left))
- (with-open-file (stream filename :direction :input)
- (input-from-stream stream
- (buffer pane)
- (offset (point pane))))
- (psetf (offset (mark pane)) (offset (point pane))
- (offset (point pane)) (offset (mark pane))))
- (redisplay-frame-panes *application-frame*)))
-
-(set-key 'com-insert-file
- 'buffer-table
- '((#\x :control) (#\i :control)))
-
(defgeneric erase-buffer (buffer))
(defmethod erase-buffer ((buffer string))
@@ -1035,93 +308,6 @@
(end-of-buffer point)
(delete-region mark point)))
-(define-command (com-revert-buffer :name t :command-table buffer-table) ()
- (let* ((pane (current-window))
- (buffer (buffer pane))
- (filepath (filepath buffer))
- (save (offset (point pane))))
- (when (accept 'boolean :prompt (format nil "Revert buffer from file ~A?"
- (filepath buffer)))
- (cond ((directory-pathname-p filepath)
- (display-message "~A is a directory name." filepath)
- (beep))
- ((probe-file filepath)
- (erase-buffer buffer)
- (with-open-file (stream filepath :direction :input)
- (input-from-stream stream buffer 0))
- (setf (offset (point pane))
- (min (size buffer) save)))
- (t
- (display-message "No file ~A" filepath)
- (beep))))))
-
-(defun save-buffer (buffer)
- (let ((filepath (or (filepath buffer)
- (accept 'pathname :prompt "Save Buffer to File"))))
- (cond
- ((directory-pathname-p filepath)
- (display-message "~A is a directory." filepath)
- (beep))
- (t
- (when (probe-file filepath)
- (let ((backup-name (pathname-name filepath))
- (backup-type (concatenate 'string (pathname-type filepath) "~")))
- (rename-file filepath (make-pathname :name backup-name
- :type backup-type))))
- (with-open-file (stream filepath :direction :output :if-exists :supersede)
- (output-to-stream stream buffer 0 (size buffer)))
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath))
- (display-message "Wrote: ~a" (filepath buffer))
- (setf (needs-saving buffer) nil)))))
-
-(define-command (com-save-buffer :name t :command-table buffer-table) ()
- (let ((buffer (buffer (current-window))))
- (if (or (null (filepath buffer))
- (needs-saving buffer))
- (save-buffer buffer)
- (display-message "No changes need to be saved from ~a" (name buffer)))))
-
-(set-key 'com-save-buffer
- 'buffer-table
- '((#\x :control) (#\s :control)))
-
-(defmethod frame-exit :around ((frame climacs))
- (loop for buffer in (buffers frame)
- when (and (needs-saving buffer)
- (filepath buffer)
- (handler-case (accept 'boolean
- :prompt (format nil "Save buffer: ~a ?" (name buffer)))
- (error () (progn (beep)
- (display-message "Invalid answer")
- (return-from frame-exit nil)))))
- do (save-buffer buffer))
- (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
- (buffers frame))
- (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
- (error () (progn (beep)
- (display-message "Invalid answer")
- (return-from frame-exit nil)))))
- (call-next-method)))
-
-(define-command (com-write-buffer :name t :command-table buffer-table) ()
- (let ((filepath (accept 'pathname :prompt "Write Buffer to File"))
- (buffer (buffer (current-window))))
- (cond
- ((directory-pathname-p filepath)
- (display-message "~A is a directory name." filepath))
- (t
- (with-open-file (stream filepath :direction :output :if-exists :supersede)
- (output-to-stream stream buffer 0 (size buffer)))
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath)
- (needs-saving buffer) nil)
- (display-message "Wrote: ~a" (filepath buffer))))))
-
-(set-key 'com-write-buffer
- 'buffer-table
- '((#\x :control) (#\w :control)))
-
(define-presentation-method present (object (type buffer)
stream
(view textual-view)
@@ -1227,1497 +413,3 @@
(set-key 'com-kill-buffer
'pane-table
'((#\x :control) (#\k)))
-
-(define-command (com-full-redisplay :name t :command-table base-table) ()
- (full-redisplay (current-window)))
-
-(set-key 'com-full-redisplay
- 'base-table
- '((#\l :control)))
-
-(defun load-file (file-name)
- (cond ((directory-pathname-p file-name)
- (display-message "~A is a directory name." file-name)
- (beep))
- (t
- (cond ((probe-file file-name)
- (load file-name))
- (t
- (display-message "No such file: ~A" file-name)
- (beep))))))
-
-(define-command (com-load-file :name t :command-table base-table) ()
- (let ((filepath (accept 'pathname :prompt "Load File")))
- (load-file filepath)))
-
-(set-key 'com-load-file
- 'base-table
- '((#\c :control) (#\l :control)))
-
-(define-command (com-beginning-of-buffer :name t :command-table movement-table) ()
- (beginning-of-buffer (point (current-window))))
-
-(set-key 'com-beginning-of-buffer
- 'movement-table
- '((#\< :shift :meta)))
-
-(set-key 'com-beginning-of-buffer
- 'movement-table
- '((:home :control)))
-
-(define-command (com-page-down :name t :command-table movement-table) ()
- (let ((pane (current-window)))
- (page-down pane)))
-
-(set-key 'com-page-down
- 'movement-table
- '((#\v :control)))
-
-(set-key 'com-page-down
- 'movement-table
- '((:next)))
-
-(define-command (com-page-up :name t :command-table movement-table) ()
- (let ((pane (current-window)))
- (page-up pane)))
-
-(set-key 'com-page-up
- 'movement-table
- '((#\v :meta)))
-
-(set-key 'com-page-up
- 'movement-table
- '((:prior)))
-
-(define-command (com-end-of-buffer :name t :command-table movement-table) ()
- (end-of-buffer (point (current-window))))
-
-(set-key 'com-end-of-buffer
- 'movement-table
- '((#\> :shift :meta)))
-
-(set-key 'com-end-of-buffer
- 'movement-table
- '((:end :control)))
-
-(define-command (com-mark-whole-buffer :name t :command-table marking-table) ()
- (beginning-of-buffer (point (current-window)))
- (end-of-buffer (mark (current-window))))
-
-(set-key 'com-mark-whole-buffer
- 'marking-table
- '((#\x :control) (#\h)))
-
-(defun back-to-indentation (mark)
- (beginning-of-line mark)
- (loop until (end-of-line-p mark)
- while (whitespacep (object-after mark))
- do (forward-object mark)))
-
-(define-command (com-back-to-indentation :name t :command-table movement-table) ()
- (back-to-indentation (point (current-window))))
-
-(set-key 'com-back-to-indentation
- 'movement-table
- '((#\m :meta)))
-
-(defun delete-horizontal-space (mark &optional (backward-only-p nil))
- (let ((mark2 (clone-mark mark)))
- (loop until (beginning-of-line-p mark)
- while (whitespacep (object-before mark))
- do (backward-object mark))
- (unless backward-only-p
- (loop until (end-of-line-p mark2)
- while (whitespacep (object-after mark2))
- do (forward-object mark2)))
- (delete-region mark mark2)))
-
-(define-command (com-delete-horizontal-space :name t :command-table deletion-table)
- ((backward-only-p
- 'boolean :prompt "Delete backwards only?"))
- (delete-horizontal-space (point (current-window)) backward-only-p))
-
-(set-key `(com-delete-horizontal-space ,*numeric-argument-p*)
- 'deletion-table
- '((#\\ :meta)))
-
-(defun just-one-space (mark count)
- (let (offset)
- (loop until (beginning-of-line-p mark)
- while (whitespacep (object-before mark))
- do (backward-object mark))
- (loop until (end-of-line-p mark)
- while (whitespacep (object-after mark))
- repeat count do (forward-object mark)
- finally (setf offset (offset mark)))
- (loop until (end-of-line-p mark)
- while (whitespacep (object-after mark))
- do (forward-object mark))
- (delete-region offset mark)))
-
-(define-command (com-just-one-space :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of spaces"))
- (just-one-space (point (current-window)) count))
-
-(set-key `(com-just-one-space ,*numeric-argument-marker*)
- 'deletion-table
- '((#\Space :meta)))
-
-(defun goto-position (mark pos)
- (setf (offset mark) pos))
-
-(define-command (com-goto-position :name t :command-table movement-table) ()
- (goto-position
- (point (current-window))
- (handler-case (accept 'integer :prompt "Goto Position")
- (error () (progn (beep)
- (display-message "Not a valid position")
- (return-from com-goto-position nil))))))
-
-(defun goto-line (mark line-number)
- (loop with m = (clone-mark (low-mark (buffer mark))
- :right)
- initially (beginning-of-buffer m)
- do (end-of-line m)
- until (end-of-buffer-p m)
- repeat (1- line-number)
- do (incf (offset m))
- (end-of-line m)
- finally (beginning-of-line m)
- (setf (offset mark) (offset m))))
-
-(define-command (com-goto-line :name t :command-table movement-table) ()
- (goto-line (point (current-window))
- (handler-case (accept 'integer :prompt "Goto Line")
- (error () (progn (beep)
- (display-message "Not a valid line number")
- (return-from com-goto-line nil))))))
-
-(define-command (com-browse-url :name t :command-table base-table) ()
- (let ((url (accept 'url :prompt "Browse URL")))
- #+ (and sbcl darwin)
- (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)
- #+ (and openmcl darwin)
- (ccl:run-program "/usr/bin/open" `(,url) :wait nil)))
-
-(define-command (com-set-mark :name t :command-table marking-table) ()
- (let ((pane (current-window)))
- (setf (mark pane) (clone-mark (point pane)))))
-
-(set-key 'com-set-mark
- 'marking-table
- '((#\Space :control)))
-
-(define-command (com-exchange-point-and-mark :name t :command-table marking-table) ()
- (let ((pane (current-window)))
- (psetf (offset (mark pane)) (offset (point pane))
- (offset (point pane)) (offset (mark pane)))))
-
-(set-key 'com-exchange-point-and-mark
- 'marking-table
- '((#\x :control) (#\x :control)))
-
-(defgeneric set-syntax (buffer syntax))
-
-(defmethod set-syntax ((buffer climacs-buffer) (syntax syntax))
- (setf (syntax buffer) syntax))
-
-;;; FIXME: This :around method is probably not going to remain here
-;;; for ever; it is a symptom of level mixing, I think. See also the
-;;; similar method on (SETF BUFFER). -- CSR, 2005-10-31.
-(defmethod (setf syntax) :around (syntax (buffer climacs-buffer))
- (call-next-method)
- ;; FIXME: we need this because some clients (e.g. the tablature
- ;; editor) use climacs buffers without a gui, for off-line (e.g. Web
- ;; backend) processing. The problem here is that (setf syntax)
- ;; /should/ have no GUI effects whatsoever. So maybe the right
- ;; answer would instead be to find the active pane's buffer in the
- ;; top-level loop? That might need to be pushed into ESA.
- (when clim:*application-frame*
- (let ((pane (current-window)))
- (assert (eq (buffer pane) buffer))
- (note-pane-syntax-changed pane syntax))))
-
-;;; FIXME - what should this specialise on?
-(defmethod set-syntax ((buffer climacs-buffer) syntax)
- (set-syntax buffer (make-instance syntax :buffer buffer)))
-
-(defmethod set-syntax ((buffer climacs-buffer) (syntax string))
- (let ((syntax-class (syntax-from-name syntax)))
- (cond (syntax-class
- (set-syntax buffer (make-instance syntax-class
- :buffer buffer)))
- (t
- (beep)
- (display-message "No such syntax: ~A." syntax)))))
-
-(define-command (com-set-syntax :name t :command-table buffer-table) ()
- (let* ((pane (current-window))
- (buffer (buffer pane)))
- (set-syntax buffer (accept 'syntax :prompt "Set Syntax"))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Commands for splitting windows
-
-(defun replace-constellation (constellation additional-constellation vertical-p)
- (let* ((parent (sheet-parent constellation))
- (children (sheet-children parent))
- (first (first children))
- (second (second children))
- (third (third children))
- (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
- (assert (member constellation children))
- (sheet-disown-child parent constellation)
- (let ((new (if vertical-p
- (vertically ()
- constellation adjust additional-constellation)
- (horizontally ()
- constellation adjust additional-constellation))))
- (sheet-adopt-child parent new)
- (reorder-sheets parent
- (if (eq constellation first)
- (if third
- (list new second third)
- (list new second))
- (if third
- (list first second new)
- (list first new)))))))
-
-(defun find-parent (sheet)
- (loop for parent = (sheet-parent sheet)
- then (sheet-parent parent)
- until (typep parent 'vrack-pane)
- finally (return parent)))
-
-(defclass typeout-pane (application-pane esa-pane-mixin) ())
-
-(defun make-typeout-constellation (&optional label)
- (let* ((typeout-pane
- (make-pane 'typeout-pane :width 900 :height 400 :display-time nil))
- (label
- (make-pane 'label-pane :label label))
- (vbox
- (vertically ()
- (scrolling (:scroll-bar :vertical) typeout-pane) label)))
- (values vbox typeout-pane)))
-
-(defun typeout-window (&optional (label "Typeout") (pane (current-window)))
- (with-look-and-feel-realization
- ((frame-manager *application-frame*) *application-frame*)
- (multiple-value-bind (vbox new-pane) (make-typeout-constellation label)
- (let* ((current-window pane)
- (constellation-root (find-parent current-window)))
- (push new-pane (windows *application-frame*))
- (other-window)
- (replace-constellation constellation-root vbox t)
- (full-redisplay current-window)
- new-pane))))
-
-(define-command (com-describe-bindings :name t :command-table help-table)
- ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?"))
- (let* ((window (current-window))
- (buffer (buffer (current-window)))
- (stream (typeout-window
- (format nil "~10THelp: Describe Bindings for ~A" (name buffer))))
- (command-table (command-table window)))
- (esa::describe-bindings stream command-table
- (if sort-by-keystrokes
- #'esa::sort-by-keystrokes
- #'esa::sort-by-name))))
-
-(set-key `(com-describe-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b)))
-
-(defun make-pane-constellation (&optional (with-scrollbars *with-scrollbars*))
- "make a vbox containing a scroller pane as its first child and an
-info pane as its second child. The scroller pane contains a viewport
-which contains an extended pane. Return the vbox and the extended pane
-as two values.
-If with-scrollbars nil, omit the scroller."
- (let* ((extended-pane
- (make-pane 'extended-pane
- :width 900 :height 400
- :name 'window
- :end-of-line-action :scroll
- :incremental-redisplay t
- :display-function 'display-window
- :command-table 'global-climacs-table))
- (vbox
- (vertically ()
- (if with-scrollbars
- (scrolling ()
- extended-pane)
- extended-pane)
- (make-pane 'climacs-info-pane
- :master-pane extended-pane
- :width 900))))
- (values vbox extended-pane)))
-
-(defun split-window (&optional (vertically-p nil) (pane (current-window)))
- (with-look-and-feel-realization
- ((frame-manager *application-frame*) *application-frame*)
- (multiple-value-bind (vbox new-pane) (make-pane-constellation)
- (let* ((current-window pane)
- (constellation-root (find-parent current-window)))
- (setf (offset (point (buffer current-window))) (offset (point current-window))
- (buffer new-pane) (buffer current-window)
- (auto-fill-mode new-pane) (auto-fill-mode current-window)
- (auto-fill-column new-pane) (auto-fill-column current-window))
- (push new-pane (windows *application-frame*))
- (setf *standard-output* new-pane)
- (replace-constellation constellation-root vbox vertically-p)
- (full-redisplay current-window)
- (full-redisplay new-pane)
- new-pane))))
-
-(define-command (com-split-window-vertically :name t :command-table window-table) ()
- (split-window t))
-
-(set-key 'com-split-window-vertically
- 'window-table
- '((#\x :control) (#\2)))
-
-(define-command (com-split-window-horizontally :name t :command-table window-table) ()
- (split-window))
-
-(set-key 'com-split-window-horizontally
- 'window-table
- '((#\x :control) (#\3)))
-
-(defun other-window (&optional pane)
- (if (and pane (find pane (windows *application-frame*)))
- (setf (windows *application-frame*)
- (append (list pane)
- (remove pane (windows *application-frame*))))
- (setf (windows *application-frame*)
- (append (cdr (windows *application-frame*))
- (list (car (windows *application-frame*))))))
- (setf *standard-output* (car (windows *application-frame*))))
-
-(define-command (com-other-window :name t :command-table window-table) ()
- (other-window))
-
-(set-key 'com-other-window
- 'window-table
- '((#\x :control) (#\o)))
-
-(defun click-to-offset (window x y)
- (with-slots (top bot) window
- (let ((new-x (floor x (stream-character-width window #\m)))
- (new-y (floor y (stream-line-height window)))
- (buffer (buffer window)))
- (loop for scan from (offset top)
- with lines = 0
- until (= scan (offset bot))
- until (= lines new-y)
- when (eql (buffer-object buffer scan) #\Newline)
- do (incf lines)
- finally (loop for columns from 0
- until (= scan (offset bot))
- until (eql (buffer-object buffer scan) #\Newline)
- until (= columns new-x)
- do (incf scan))
- (return scan)))))
-
-(define-command (com-switch-to-this-window :name nil :command-table window-table)
- ((window 'pane) (x 'integer) (y 'integer))
- (other-window window)
- (when (typep window 'extended-pane)
- (setf (offset (point window))
- (click-to-offset window x y))))
-
-(define-presentation-to-command-translator blank-area-to-switch-to-this-window
- (blank-area com-switch-to-this-window window-table :echo nil)
- (window x y)
- (list window x y))
-
-(define-gesture-name :select-other :pointer-button (:right) :unique nil)
-
-(define-command (com-mouse-save :name nil :command-table window-table)
- ((window 'pane) (x 'integer) (y 'integer))
- (when (and (typep window 'extended-pane)
- (eq window (current-window)))
- (setf (offset (mark window))
- (click-to-offset window x y))
- (com-exchange-point-and-mark)
- (com-copy-region)))
-
-(define-presentation-to-command-translator blank-area-to-mouse-save
- (blank-area com-mouse-save window-table :echo nil :gesture :select-other)
- (window x y)
- (list window x y))
-
-(define-gesture-name :middle-button :pointer-button (:middle) :unique nil)
-
-(define-command (com-yank-here :name nil :command-table window-table)
- ((window 'pane) (x 'integer) (y 'integer))
- (when (typep window 'extended-pane)
- (other-window window)
- (setf (offset (point window))
- (click-to-offset window x y))
- (com-yank)))
-
-(define-presentation-to-command-translator blank-area-to-yank-here
- (blank-area com-yank-here window-table :echo nil :gesture :middle-button)
- (window x y)
- (list window x y))
-
-(defun single-window ()
- (loop until (null (cdr (windows *application-frame*)))
- do (rotatef (car (windows *application-frame*))
- (cadr (windows *application-frame*)))
- (com-delete-window))
- (setf *standard-output* (car (windows *application-frame*))))
-
-(define-command (com-single-window :name t :command-table window-table) ()
- (single-window))
-
-(set-key 'com-single-window
- 'window-table
- '((#\x :control) (#\1)))
-
-(define-command (com-scroll-other-window :name t :command-table window-table) ()
- (let ((other-window (second (windows *application-frame*))))
- (when other-window
- (page-down other-window))))
-
-(set-key 'com-scroll-other-window
- 'window-table
- '((#\v :control :meta)))
-
-(define-command (com-scroll-other-window-up :name t :command-table window-table) ()
- (let ((other-window (second (windows *application-frame*))))
- (when other-window
- (page-up other-window))))
-
-(set-key 'com-scroll-other-window-up
- 'window-table
- '((#\V :control :meta :shift)))
-
-(defun delete-window (&optional (window (current-window)))
- (unless (null (cdr (windows *application-frame*)))
- (let* ((constellation (find-parent window))
- (box (sheet-parent constellation))
- (box-children (sheet-children box))
- (other (if (eq constellation (first box-children))
- (third box-children)
- (first box-children)))
- (parent (sheet-parent box))
- (children (sheet-children parent))
- (first (first children))
- (second (second children))
- (third (third children)))
- (setf (windows *application-frame*)
- (remove window (windows *application-frame*)))
- (setf *standard-output* (car (windows *application-frame*)))
- (sheet-disown-child box other)
- (sheet-disown-child parent box)
- (sheet-adopt-child parent other)
- (reorder-sheets parent (if (eq box first)
- (if third
- (list other second third)
- (list other second))
- (if third
- (list first second other)
- (list first other)))))))
-
-(define-command (com-delete-window :name t :command-table window-table) ()
- (delete-window))
-
-(set-key 'com-delete-window
- 'window-table
- '((#\x :control) (#\0)))
-
-;;;;;;;;;;;;;;;;;;;;
-;; Kill ring commands
-
-;; Copies an element from a kill-ring to a buffer at the given offset
-(define-command (com-yank :name t :command-table editing-table) ()
- (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)))
-
-(set-key 'com-yank
- 'editing-table
- '((#\y :control)))
-
-;; Destructively cut a given buffer region into the kill-ring
-(define-command (com-kill-region :name t :command-table editing-table) ()
- (let ((pane (current-window)))
- (kill-ring-standard-push
- *kill-ring* (region-to-sequence (mark pane) (point pane)))
- (delete-region (mark pane) (point pane))))
-
-(set-key 'com-kill-region
- 'editing-table
- '((#\w :control)))
-
-;; Non destructively copies buffer region to the kill ring
-(define-command (com-copy-region :name t :command-table marking-table) ()
- (let ((pane (current-window)))
- (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
-
-(set-key 'com-copy-region
- 'marking-table
- '((#\w :meta)))
-
-(define-command (com-rotate-yank :name t :command-table editing-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (last-yank (kill-ring-yank *kill-ring*)))
- (if (eq (previous-command pane)
- 'com-rotate-yank)
- (progn
- (delete-range point (* -1 (length last-yank)))
- (rotate-yank-position *kill-ring*)))
- (insert-sequence point (kill-ring-yank *kill-ring*))))
-
-(set-key 'com-rotate-yank
- 'editing-table
- '((#\y :meta)))
-
-(define-command (com-resize-kill-ring :name t :command-table editing-table) ()
- (let ((size (handler-case (accept 'integer :prompt "New kill ring size")
- (error () (progn (beep)
- (display-message "Not a valid kill ring size")
- (return-from com-resize-kill-ring nil))))))
- (setf (kill-ring-max-size *kill-ring*) size)))
-
-(define-command (com-append-next-kill :name t :command-table editing-table) ()
- (setf (append-next-p *kill-ring*) t))
-
-(set-key 'com-append-next-kill
- 'editing-table
- '((#\w :control :meta)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Incremental search
-
-(make-command-table 'isearch-climacs-table :errorp nil)
-
-(defun isearch-command-loop (pane forwardp)
- (let ((point (point pane)))
- (unless (endp (isearch-states pane))
- (setf (isearch-previous-string pane)
- (search-string (first (isearch-states pane)))))
- (setf (isearch-mode pane) t)
- (setf (isearch-states pane)
- (list (make-instance 'isearch-state
- :search-string ""
- :search-mark (clone-mark point)
- :search-forward-p forwardp
- :search-success-p t)))
- (simple-command-loop 'isearch-climacs-table
- (isearch-mode pane)
- ((setf (isearch-mode pane) nil)))))
-
-(defun isearch-from-mark (pane mark string forwardp)
- (flet ((object-equal (x y)
- (if (characterp x)
- (and (characterp y) (char-equal x y))
- (eql x y))))
- (let* ((point (point pane))
- (mark2 (clone-mark mark))
- (success (funcall (if forwardp #'search-forward #'search-backward)
- mark2
- string
- :test #'object-equal)))
- (when success
- (setf (offset point) (offset mark2)
- (offset mark) (if forwardp
- (- (offset mark2) (length string))
- (+ (offset mark2) (length string)))))
- (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A"
- success forwardp string)
- (push (make-instance 'isearch-state
- :search-string string
- :search-mark mark
- :search-forward-p forwardp
- :search-success-p success)
- (isearch-states pane))
- (unless success
- (beep)))))
-
-(define-command (com-isearch-forward :name t :command-table search-table) ()
- (display-message "Isearch: ")
- (isearch-command-loop (current-window) t))
-
-(set-key 'com-isearch-forward
- 'search-table
- '((#\s :control)))
-
-(define-command (com-isearch-backward :name t :command-table search-table) ()
- (display-message "Isearch backward: ")
- (isearch-command-loop (current-window) nil))
-
-(set-key 'com-isearch-backward
- 'search-table
- '((#\r :control)))
-
-(define-command (com-isearch-append-char :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window))
- (states (isearch-states pane))
- (string (concatenate 'string
- (search-string (first states))
- (string *current-gesture*)))
- (mark (clone-mark (search-mark (first states))))
- (forwardp (search-forward-p (first states))))
- (unless forwardp
- (incf (offset mark)))
- (isearch-from-mark pane mark string forwardp)))
-
-(define-command (com-isearch-delete-char :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window)))
- (cond ((null (second (isearch-states pane)))
- (display-message "Isearch: ")
- (beep))
- (t
- (pop (isearch-states pane))
- (loop until (endp (rest (isearch-states pane)))
- until (search-success-p (first (isearch-states pane)))
- do (pop (isearch-states pane)))
- (let ((state (first (isearch-states pane))))
- (setf (offset (point pane))
- (if (search-forward-p state)
- (+ (offset (search-mark state))
- (length (search-string state)))
- (- (offset (search-mark state))
- (length (search-string state)))))
- (display-message "Isearch~:[ backward~;~]: ~A"
- (search-forward-p state)
- (search-string state)))))))
-
-(define-command (com-isearch-search-forward :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (states (isearch-states pane))
- (string (if (null (second states))
- (isearch-previous-string pane)
- (search-string (first states))))
- (mark (clone-mark point)))
- (isearch-from-mark pane mark string t)))
-
-(define-command (com-isearch-search-backward :name t :command-table isearch-climacs-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (states (isearch-states pane))
- (string (if (null (second states))
- (isearch-previous-string pane)
- (search-string (first states))))
- (mark (clone-mark point)))
- (isearch-from-mark pane mark string nil)))
-
-(define-command (com-isearch-exit :name t :command-table isearch-climacs-table) ()
- (setf (isearch-mode (current-window)) nil))
-
-(defun isearch-set-key (gesture command)
- (add-command-to-command-table command 'isearch-climacs-table
- :keystroke gesture :errorp nil))
-
-(loop for code from (char-code #\Space) to (char-code #\~)
- do (isearch-set-key (code-char code) 'com-isearch-append-char))
-
-(isearch-set-key '(#\Newline) 'com-isearch-exit)
-(isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
-(isearch-set-key '(#\s :control) 'com-isearch-search-forward)
-(isearch-set-key '(#\r :control) 'com-isearch-search-backward)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Query replace
-
-(make-command-table 'query-replace-climacs-table :errorp nil)
-
-(defun query-replace-find-next-match (mark string)
- (flet ((object-equal (x y)
- (and (characterp x)
- (characterp y)
- (char-equal x y))))
- (let ((offset-before (offset mark)))
- (search-forward mark string :test #'object-equal)
- (/= (offset mark) offset-before))))
-
-(define-command (com-query-replace :name t :command-table search-table) ()
- (let* ((pane (current-window))
- (old-state (query-replace-state pane))
- (old-string1 (when old-state (string1 old-state)))
- (old-string2 (when old-state (string2 old-state)))
- (string1 (handler-case
- (if old-string1
- (accept 'string
- :prompt "Query Replace"
- :default old-string1
- :default-type 'string)
- (accept 'string :prompt "Query Replace"))
- (error () (progn (beep)
- (display-message "Empty string")
- (return-from com-query-replace nil)))))
- (string2 (handler-case
- (if old-string2
- (accept 'string
- :prompt (format nil "Query Replace ~A with"
- string1)
- :default old-string2
- :default-type 'string)
- (accept 'string
- :prompt (format nil "Query Replace ~A with" string1)))
- (error () (progn (beep)
- (display-message "Empty string")
- (return-from com-query-replace nil)))))
- (point (point pane))
- (occurrences 0))
- (declare (special string1 string2 occurrences))
- (when (query-replace-find-next-match point string1)
- (setf (query-replace-state pane) (make-instance 'query-replace-state
- :string1 string1
- :string2 string2)
- (query-replace-mode pane) t)
- (display-message "Query Replace ~A with ~A:"
- string1 string2)
- (simple-command-loop 'query-replace-climacs-table
- (query-replace-mode pane)
- ((setf (query-replace-mode pane) nil))))
- (display-message "Replaced ~A occurrence~:P" occurrences)))
-
-(set-key 'com-query-replace
- 'search-table
- '((#\% :shift :meta)))
-
-(define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) ()
- (declare (special string1 string2 occurrences))
- (let* ((pane (current-window))
- (point (point pane))
- (buffer (buffer pane))
- (string1-length (length string1)))
- (backward-object point string1-length)
- (let* ((offset1 (offset point))
- (offset2 (+ offset1 string1-length))
- (region-case (buffer-region-case buffer offset1 offset2)))
- (delete-range point string1-length)
- (insert-sequence point string2)
- (setf offset2 (+ offset1 (length string2)))
- (finish-output *error-output*)
- (unless (find-if #'upper-case-p string1)
- (case region-case
- (:upper-case (upcase-buffer-region buffer offset1 offset2))
- (:lower-case (downcase-buffer-region buffer offset1 offset2))
- (:capitalized (capitalize-buffer-region buffer offset1 offset2)))))
- (incf occurrences)
- (if (query-replace-find-next-match point string1)
- (display-message "Query Replace ~A with ~A:"
- string1 string2)
- (setf (query-replace-mode pane) nil))))
-
-(define-command (com-query-replace-skip :name t :command-table query-replace-climacs-table) ()
- (declare (special string1 string2))
- (let* ((pane (current-window))
- (point (point pane)))
- (if (query-replace-find-next-match point string1)
- (display-message "Query Replace ~A with ~A:"
- string1 string2)
- (setf (query-replace-mode pane) nil))))
-
-(define-command (com-query-replace-exit :name t :command-table query-replace-climacs-table) ()
- (setf (query-replace-mode (current-window)) nil))
-
-(defun query-replace-set-key (gesture command)
- (add-command-to-command-table command 'query-replace-climacs-table
- :keystroke gesture :errorp nil))
-
-(query-replace-set-key '(#\Newline) 'com-query-replace-exit)
-(query-replace-set-key '(#\Space) 'com-query-replace-replace)
-(query-replace-set-key '(#\Backspace) 'com-query-replace-skip)
-(query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
-(query-replace-set-key '(#\q) 'com-query-replace-exit)
-(query-replace-set-key '(#\y) 'com-query-replace-replace)
-(query-replace-set-key '(#\n) 'com-query-replace-skip)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Undo/redo
-
-(define-command (com-undo :name t :command-table editing-table) ()
- (handler-case (undo (undo-tree (buffer (current-window))))
- (no-more-undo () (beep) (display-message "No more undo")))
- (full-redisplay (current-window)))
-
-(set-key 'com-undo
- 'editing-table
- '((#\_ :shift :control)))
-
-(set-key 'com-undo
- 'editing-table
- '((#\x :control) (#\u)))
-
-(define-command (com-redo :name t :command-table editing-table) ()
- (handler-case (redo (undo-tree (buffer (current-window))))
- (no-more-undo () (beep) (display-message "No more redo")))
- (full-redisplay (current-window)))
-
-(set-key 'com-redo
- 'editing-table
- '((#\_ :shift :meta)))
-
-(set-key 'com-redo
- 'editing-table
- '((#\x :control) (#\r :control)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Dynamic abbrevs
-
-(define-command (com-dabbrev-expand :name t :command-table editing-table) ()
- (let* ((window (current-window))
- (point (point window)))
- (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) window
- (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark)
- (setf (offset dabbrev-expansion-mark)
- (offset point))
- (forward-word dabbrev-expansion-mark))
- ((mark< dabbrev-expansion-mark point)
- (backward-object dabbrev-expansion-mark))
- (t (forward-object dabbrev-expansion-mark)))))
- (unless (or (beginning-of-buffer-p point)
- (not (constituentp (object-before point))))
- (unless (and (eq (previous-command window) 'com-dabbrev-expand)
- (not (null prefix-start-offset)))
- (setf dabbrev-expansion-mark (clone-mark point))
- (backward-word dabbrev-expansion-mark)
- (setf prefix-start-offset (offset dabbrev-expansion-mark))
- (setf original-prefix (region-to-sequence prefix-start-offset point))
- (move))
- (loop until (or (end-of-buffer-p dabbrev-expansion-mark)
- (and (or (beginning-of-buffer-p dabbrev-expansion-mark)
- (not (constituentp (object-before dabbrev-expansion-mark))))
- (looking-at dabbrev-expansion-mark original-prefix)))
- do (move))
- (if (end-of-buffer-p dabbrev-expansion-mark)
- (progn (delete-region prefix-start-offset point)
- (insert-sequence point original-prefix)
- (setf prefix-start-offset nil))
- (progn (delete-region prefix-start-offset point)
- (insert-sequence point
- (let ((offset (offset dabbrev-expansion-mark)))
- (prog2 (forward-word dabbrev-expansion-mark)
- (region-to-sequence offset dabbrev-expansion-mark)
- (setf (offset dabbrev-expansion-mark) offset))))
- (move))))))))
-
-(set-key 'com-dabbrev-expand
- 'editing-table
- '((#\/ :meta)))
-
-(define-command (com-backward-paragraph :name t :command-table movement-table)
- ((count 'integer :prompt "Number of paragraphs"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (backward-paragraph point syntax))
- (loop repeat (- count) do (forward-paragraph point syntax)))))
-
-(set-key `(com-backward-paragraph ,*numeric-argument-marker*)
- 'movement-table
- '((#\{ :shift :meta)))
-
-(define-command (com-forward-paragraph :name t :command-table movement-table)
- ((count 'integer :prompt "Number of paragraphs"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (forward-paragraph point syntax))
- (loop repeat (- count) do (backward-paragraph point syntax)))))
-
-(set-key `(com-forward-paragraph ,*numeric-argument-marker*)
- 'movement-table
- '((#\} :shift :meta)))
-
-(define-command (com-mark-paragraph :name t :command-table marking-table)
- ((count 'integer :prompt "Number of paragraphs"))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane))
- (syntax (syntax (buffer pane))))
- (unless (eq (previous-command pane) 'com-mark-paragraph)
- (setf (offset mark) (offset point))
- (if (plusp count)
- (backward-paragraph point syntax)
- (forward-paragraph point syntax)))
- (if (plusp count)
- (loop repeat count do (forward-paragraph mark syntax))
- (loop repeat (- count) do (backward-paragraph mark syntax)))))
-
-(set-key `(com-mark-paragraph ,*numeric-argument-marker*)
- 'marking-table
- '((#\h :meta)))
-
-(define-command (com-backward-sentence :name t :command-table movement-table)
- ((count 'integer :prompt "Number of sentences"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (backward-sentence point syntax))
- (loop repeat (- count) do (forward-sentence point syntax)))))
-
-(set-key `(com-backward-sentence ,*numeric-argument-marker*)
- 'movement-table
- '((#\a :meta)))
-
-(define-command (com-forward-sentence :name t :command-table movement-table)
- ((count 'integer :prompt "Number of sentences"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (forward-sentence point syntax))
- (loop repeat (- count) do (backward-sentence point syntax)))))
-
-(set-key `(com-forward-sentence ,*numeric-argument-marker*)
- 'movement-table
- '((#\e :meta)))
-
-(define-command (com-kill-sentence :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of sentences"))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (clone-mark point))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (forward-sentence point syntax))
- (loop repeat (- count) do (backward-sentence point syntax)))
- (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
- (delete-region point mark)))
-
-(set-key `(com-kill-sentence ,*numeric-argument-marker*)
- 'deletion-table
- '((#\k :meta)))
-
-(define-command (com-backward-kill-sentence :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of sentences"))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (clone-mark point))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (backward-sentence point syntax))
- (loop repeat (- count) do (forward-sentence point syntax)))
- (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
- (delete-region point mark)))
-
-(set-key `(com-backward-kill-sentence ,*numeric-argument-marker*)
- 'deletion-table
- '((#\x :control) (#\Backspace)))
-
-(defun forward-page (mark &optional (count 1))
- (loop repeat count
- unless (search-forward mark (coerce (list #\Newline #\Page) 'vector))
- do (end-of-buffer mark)
- (loop-finish)))
-
-(define-command (com-forward-page :name t :command-table movement-table)
- ((count 'integer :prompt "Number of pages"))
- (let* ((pane (current-window))
- (point (point pane)))
- (if (plusp count)
- (forward-page point count)
- (backward-page point count))))
-
-(set-key `(com-forward-page ,*numeric-argument-marker*)
- 'movement-table
- '((#\x :control) (#\])))
-
-(defun backward-page (mark &optional (count 1))
- (loop repeat count
- when (search-backward mark (coerce (list #\Newline #\Page) 'vector))
- do (forward-object mark)
- else do (beginning-of-buffer mark)
- (loop-finish)))
-
-(define-command (com-backward-page :name t :command-table movement-table)
- ((count 'integer :prompt "Number of pages"))
- (let* ((pane (current-window))
- (point (point pane)))
- (if (plusp count)
- (backward-page point count)
- (forward-page point count))))
-
-(set-key `(com-backward-page ,*numeric-argument-marker*)
- 'movement-table
- '((#\x :control) (#\[)))
-
-(define-command (com-mark-page :name t :command-table marking-table)
- ((count 'integer :prompt "Move how many pages")
- (numargp 'boolean :prompt "Move to another page?"))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane)))
- (cond ((and numargp (/= 0 count))
- (if (plusp count)
- (forward-page point count)
- (backward-page point (1+ count))))
- (t (backward-page point count)))
- (setf (offset mark) (offset point))
- (forward-page mark 1)))
-
-(set-key `(com-mark-page ,*numeric-argument-marker* ,*numeric-argument-p*)
- 'marking-table
- '((#\x :control) (#\p :control)))
-
-(define-command (com-count-lines-page :name t :command-table info-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (start (clone-mark point))
- (end (clone-mark point)))
- (backward-page start)
- (forward-page end)
- (let ((total (number-of-lines-in-region start end))
- (before (number-of-lines-in-region start point))
- (after (number-of-lines-in-region point end)))
- (display-message "Page has ~A lines (~A + ~A)" total before after))))
-
-(set-key 'com-count-lines-page
- 'info-table
- '((#\x :control) (#\l)))
-
-(define-command (com-count-lines-region :name t :command-table info-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane))
- (lines (number-of-lines-in-region point mark))
- (chars (abs (- (offset point) (offset mark)))))
- (display-message "Region has ~D line~:P, ~D character~:P." lines chars)))
-
-(set-key 'com-count-lines-region
- 'info-table
- '((#\= :meta)))
-
-(define-command (com-what-cursor-position :name t :command-table info-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (buffer (buffer pane))
- (offset (offset point))
- (size (size buffer))
- (char (object-after point))
- (column (column-number point)))
- (display-message "Char: ~:C (#o~O ~:*~D ~:*#x~X) point=~D of ~D (~D%) column ~D"
- char (char-code char) offset size
- (round (* 100 (/ offset size))) column)))
-
-(set-key 'com-what-cursor-position
- 'info-table
- '((#\x :control) (#\=)))
-
-(define-command (com-eval-expression :name t :command-table base-table)
- ((insertp 'boolean :prompt "Insert?"))
- (let* ((*package* (find-package :climacs-gui))
- (string (handler-case (accept 'string :prompt "Eval")
- (error () (progn (beep)
- (display-message "Empty string")
- (return-from com-eval-expression nil)))))
- (values (multiple-value-list
- (handler-case (eval (read-from-string string))
- (error (condition) (progn (beep)
- (display-message "~a" condition)
- (return-from com-eval-expression nil))))))
- (result (format nil "~:[; No values~;~:*~{~S~^,~}~]" values)))
- (if insertp
- (insert-sequence (point (current-window)) result)
- (display-message result))))
-
-(set-key `(com-eval-expression ,*numeric-argument-p*)
- 'base-table
- '((#\: :shift :meta)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Commenting
-
-;;; figure out how to make commands without key bindings accept numeric arguments.
-(define-command (com-comment-region :name t :command-table comment-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane))
- (syntax (syntax (buffer pane))))
- (comment-region syntax point mark)))
-
-(define-command (com-backward-expression :name t :command-table movement-table)
- ((count 'integer :prompt "Number of expressions"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (backward-expression point syntax))
- (loop repeat (- count) do (forward-expression point syntax)))))
-
-(set-key `(com-backward-expression ,*numeric-argument-marker*)
- 'movement-table
- '((#\b :control :meta)))
-
-(define-command (com-forward-expression :name t :command-table movement-table)
- ((count 'integer :prompt "Number of expresssions"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (forward-expression point syntax))
- (loop repeat (- count) do (backward-expression point syntax)))))
-
-(set-key `(com-forward-expression ,*numeric-argument-marker*)
- 'movement-table
- '((#\f :control :meta)))
-
-(define-command (com-mark-expression :name t :command-table marking-table)
- ((count 'integer :prompt "Number of expressions"))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane))
- (syntax (syntax (buffer pane))))
- (unless (eq (previous-command pane) 'com-mark-expression)
- (setf (offset mark) (offset point)))
- (if (plusp count)
- (loop repeat count do (forward-expression mark syntax))
- (loop repeat (- count) do (backward-expression mark syntax)))))
-
-(set-key `(com-mark-expression ,*numeric-argument-marker*)
- 'marking-table
- '((#\@ :shift :control :meta)))
-
-(define-command (com-kill-expression :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of expressions"))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (clone-mark point))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (forward-expression mark syntax))
- (loop repeat (- count) do (backward-expression mark syntax)))
- (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))
- (delete-region mark point)))
-
-(set-key `(com-kill-expression ,*numeric-argument-marker*)
- 'deletion-table
- '((#\k :control :meta)))
-
-(define-command (com-backward-kill-expression :name t :command-table deletion-table)
- ((count 'integer :prompt "Number of expressions"))
- (let* ((pane (current-window))
- (point (point pane))
- (mark (clone-mark point))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (backward-expression mark syntax))
- (loop repeat (- count) do (forward-expression mark syntax)))
- (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))
- (delete-region mark point)))
-
-(set-key `(com-backward-kill-expression ,*numeric-argument-marker*)
- 'deletion-table
- '((#\Backspace :control :meta)))
-
-;; (defparameter *insert-pair-alist*
-;; '((#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) (#\" #\") (#\' #\') (#\` #\')))
-
-(defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\)))
- (cond ((> count 0)
- (loop while (and (not (end-of-buffer-p mark))
- (whitespacep (object-after mark)))
- do (forward-object mark)))
- ((< count 0)
- (setf count (- count))
- (loop repeat count do (backward-expression mark syntax))))
- (unless (or (beginning-of-buffer-p mark)
- (whitespacep (object-before mark)))
- (insert-object mark #\Space))
- (insert-object mark open)
- (let ((here (clone-mark mark)))
- (loop repeat count
- do (forward-expression here syntax))
- (insert-object here close)
- (unless (or (end-of-buffer-p here)
- (whitespacep (object-after here)))
- (insert-object here #\Space))))
-
-(defun insert-parentheses (mark syntax count)
- (insert-pair mark syntax count #\( #\)))
-
-(define-command (com-insert-parentheses :name t :command-table editing-table)
- ((count 'integer :prompt "Number of expressions")
- (wrap-p 'boolean :prompt "Wrap expressions?"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (unless wrap-p (setf count 0))
- (insert-parentheses point syntax count)))
-
-(set-key `(com-insert-parentheses ,*numeric-argument-marker* ,*numeric-argument-p*)
- 'editing-table
- '((#\( :meta)))
-
-(define-command (com-forward-list :name t :command-table movement-table)
- ((count 'integer :prompt "Number of lists"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (forward-list point syntax))
- (loop repeat (- count) do (backward-list point syntax)))))
-
-(set-key `(com-forward-list ,*numeric-argument-marker*)
- 'movement-table
- '((#\n :control :meta)))
-
-(define-command (com-backward-list :name t :command-table movement-table)
- ((count 'integer :prompt "Number of lists"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (backward-list point syntax))
- (loop repeat (- count) do (forward-list point syntax)))))
-
-(set-key `(com-backward-list ,*numeric-argument-marker*)
- 'movement-table
- '((#\p :control :meta)))
-
-(define-command (com-down-list :name t :command-table movement-table)
- ((count 'integer :prompt "Number of lists"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (down-list point syntax))
- (loop repeat (- count) do (backward-down-list point syntax)))))
-
-(set-key `(com-down-list ,*numeric-argument-marker*)
- 'movement-table
- '((#\d :control :meta)))
-
-(define-command (com-backward-down-list :name t :command-table movement-table)
- ((count 'integer :prompt "Number of lists"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (backward-down-list point syntax))
- (loop repeat (- count) do (down-list point syntax)))))
-
-(define-command (com-backward-up-list :name t :command-table movement-table)
- ((count 'integer :prompt "Number of lists"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (backward-up-list point syntax))
- (loop repeat (- count) do (up-list point syntax)))))
-
-(set-key `(com-backward-up-list ,*numeric-argument-marker*)
- 'movement-table
- '((#\u :control :meta)))
-
-(define-command (com-up-list :name t :command-table movement-table) ((count 'integer :prompt "Number of lists"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (up-list point syntax))
- (loop repeat (- count) do (backward-up-list point syntax)))))
-
-(define-command (com-eval-defun :name t :command-table lisp-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (eval-defun point syntax)))
-
-(set-key 'com-eval-defun
- 'lisp-table
- '((#\x :control :meta)))
-
-(define-command (com-beginning-of-definition :name t :command-table movement-table)
- ((count 'integer :prompt "Number of definitions"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (beginning-of-definition point syntax))
- (loop repeat (- count) do (end-of-definition point syntax)))))
-
-(set-key `(com-beginning-of-definition ,*numeric-argument-marker*)
- 'movement-table
- '((#\a :control :meta)))
-
-(define-command (com-end-of-definition :name t :command-table movement-table)
- ((count 'integer :prompt "Number of definitions"))
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (if (plusp count)
- (loop repeat count do (end-of-definition point syntax))
- (loop repeat (- count) do (beginning-of-definition point syntax)))))
-
-(set-key `(com-end-of-definition ,*numeric-argument-marker*)
- 'movement-table
- '((#\e :control :meta)))
-
-(define-command (com-mark-definition :name t :command-table marking-table) ()
- (let* ((pane (current-window))
- (point (point pane))
- (mark (mark pane))
- (syntax (syntax (buffer pane))))
- (unless (eq (previous-command pane) 'com-mark-definition)
- (beginning-of-definition point syntax)
- (setf (offset mark) (offset point)))
- (end-of-definition mark syntax)))
-
-(set-key 'com-mark-definition
- 'marking-table
- '((#\h :control :meta)))
-
-(define-command (com-package :name t :command-table lisp-table) ()
- (let* ((pane (current-window))
- (syntax (syntax (buffer pane)))
- (package (climacs-lisp-syntax::package-of syntax)))
- (display-message (format nil "~s" package))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; For testing purposes
-
-(define-command (com-reset-profile :name t :command-table development-table) ()
- #+sbcl (sb-profile:reset)
- #-sbcl nil)
-
-(define-command (com-report-profile :name t :command-table development-table) ()
- #+sbcl (sb-profile:report)
- #-sbcl nil)
-
-(define-command (com-recompile :name t :command-table development-table) ()
- (asdf:operate 'asdf:load-op :climacs))
-
-
-(define-gesture-name :select-other :pointer-button-press (:left :meta) :unique nil)
-
-(define-presentation-translator lisp-string-to-string
- (climacs-lisp-syntax::lisp-string string development-table
- :gesture :select-other
- :tester-definitive t
- :menu nil
- :priority 10)
- (object)
- object)
-
-(define-command (com-accept-string :name t :command-table development-table) ()
- (display-message (format nil "~s" (accept 'string))))
-
-(define-command (com-accept-symbol :name t :command-table development-table) ()
- (display-message (format nil "~s" (accept 'symbol))))
-
-(define-command (com-accept-lisp-string :name t :command-table development-table) ()
- (display-message (format nil "~s" (accept 'lisp-string))))
-
-(define-command (com-visible-mark :name t :command-table marking-table) ()
- (setf (mark-visible-p (current-window)) (not (mark-visible-p (current-window)))))
-
-(loop for code from (char-code #\Space) to (char-code #\~)
- do (set-key `(com-self-insert ,*numeric-argument-marker*)
- 'self-insert-table
- (list (list (code-char code)))))
-
-(set-key `(com-self-insert ,*numeric-argument-marker*)
- 'self-insert-table
- '((#\Newline)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Some Unicode stuff
-
-(define-command (com-insert-charcode :name t :command-table self-insert-table)
- ((code 'integer :prompt "Code point"))
- (insert-object (point (current-window)) (code-char code)))
-
-(set-key '(com-insert-charcode 193) 'self-insert-table '((:dead--acute)(#\A)))
-(set-key '(com-insert-charcode 201) 'self-insert-table '((:dead--acute)(#\E)))
-(set-key '(com-insert-charcode 205) 'self-insert-table '((:dead--acute)(#\I)))
-(set-key '(com-insert-charcode 211) 'self-insert-table '((:dead--acute)(#\O)))
-(set-key '(com-insert-charcode 218) 'self-insert-table '((:dead--acute)(#\U)))
-(set-key '(com-insert-charcode 221) 'self-insert-table '((:dead--acute)(#\Y)))
-(set-key '(com-insert-charcode 225) 'self-insert-table '((:dead--acute)(#\a)))
-(set-key '(com-insert-charcode 233) 'self-insert-table '((:dead--acute)(#\e)))
-(set-key '(com-insert-charcode 237) 'self-insert-table '((:dead--acute)(#\i)))
-(set-key '(com-insert-charcode 243) 'self-insert-table '((:dead--acute)(#\o)))
-(set-key '(com-insert-charcode 250) 'self-insert-table '((:dead--acute)(#\u)))
-(set-key '(com-insert-charcode 253) 'self-insert-table '((:dead--acute)(#\y)))
-(set-key '(com-insert-charcode 199) 'self-insert-table '((:dead--acute)(#\C)))
-(set-key '(com-insert-charcode 231) 'self-insert-table '((:dead--acute)(#\c)))
-(set-key '(com-insert-charcode 215) 'self-insert-table '((:dead--acute)(#\x)))
-(set-key '(com-insert-charcode 247) 'self-insert-table '((:dead--acute)(#\-)))
-(set-key '(com-insert-charcode 222) 'self-insert-table '((:dead--acute)(#\T)))
-(set-key '(com-insert-charcode 254) 'self-insert-table '((:dead--acute)(#\t)))
-(set-key '(com-insert-charcode 223) 'self-insert-table '((:dead--acute)(#\s)))
-(set-key '(com-insert-charcode 39) 'self-insert-table '((:dead--acute)(#\Space)))
-
-(set-key '(com-insert-charcode 197) 'self-insert-table '((:dead--acute)(:dead--acute)(#\A)))
-(set-key '(com-insert-charcode 229) 'self-insert-table '((:dead--acute)(:dead--acute)(#\a)))
-
-(set-key '(com-insert-charcode 192) 'self-insert-table '((:dead--grave)(#\A)))
-(set-key '(com-insert-charcode 200) 'self-insert-table '((:dead--grave)(#\E)))
-(set-key '(com-insert-charcode 204) 'self-insert-table '((:dead--grave)(#\I)))
-(set-key '(com-insert-charcode 210) 'self-insert-table '((:dead--grave)(#\O)))
-(set-key '(com-insert-charcode 217) 'self-insert-table '((:dead--grave)(#\U)))
-(set-key '(com-insert-charcode 224) 'self-insert-table '((:dead--grave)(#\a)))
-(set-key '(com-insert-charcode 232) 'self-insert-table '((:dead--grave)(#\e)))
-(set-key '(com-insert-charcode 236) 'self-insert-table '((:dead--grave)(#\i)))
-(set-key '(com-insert-charcode 242) 'self-insert-table '((:dead--grave)(#\o)))
-(set-key '(com-insert-charcode 249) 'self-insert-table '((:dead--grave)(#\u)))
-(set-key '(com-insert-charcode 96) 'self-insert-table '((:dead--grave)(#\Space)))
-
-(set-key '(com-insert-charcode 196) 'self-insert-table '((:dead--diaeresis :shift)(#\A)))
-(set-key '(com-insert-charcode 203) 'self-insert-table '((:dead--diaeresis :shift)(#\E)))
-(set-key '(com-insert-charcode 207) 'self-insert-table '((:dead--diaeresis :shift)(#\I)))
-(set-key '(com-insert-charcode 214) 'self-insert-table '((:dead--diaeresis :shift)(#\O)))
-(set-key '(com-insert-charcode 220) 'self-insert-table '((:dead--diaeresis :shift)(#\U)))
-(set-key '(com-insert-charcode 228) 'self-insert-table '((:dead--diaeresis :shift)(#\a)))
-(set-key '(com-insert-charcode 235) 'self-insert-table '((:dead--diaeresis :shift)(#\e)))
-(set-key '(com-insert-charcode 239) 'self-insert-table '((:dead--diaeresis :shift)(#\i)))
-(set-key '(com-insert-charcode 246) 'self-insert-table '((:dead--diaeresis :shift)(#\o)))
-(set-key '(com-insert-charcode 252) 'self-insert-table '((:dead--diaeresis :shift)(#\u)))
-(set-key '(com-insert-charcode 255) 'self-insert-table '((:dead--diaeresis :shift)(#\y)))
-(set-key '(com-insert-charcode 34) 'self-insert-table '((:dead--diaeresis :shift)(#\Space)))
-
-(set-key '(com-insert-charcode 195) 'self-insert-table '((:dead--tilde :shift)(#\A)))
-(set-key '(com-insert-charcode 209) 'self-insert-table '((:dead--tilde :shift)(#\N)))
-(set-key '(com-insert-charcode 227) 'self-insert-table '((:dead--tilde :shift)(#\a)))
-(set-key '(com-insert-charcode 241) 'self-insert-table '((:dead--tilde :shift)(#\n)))
-(set-key '(com-insert-charcode 198) 'self-insert-table '((:dead--tilde :shift)(#\E)))
-(set-key '(com-insert-charcode 230) 'self-insert-table '((:dead--tilde :shift)(#\e)))
-(set-key '(com-insert-charcode 208) 'self-insert-table '((:dead--tilde :shift)(#\D)))
-(set-key '(com-insert-charcode 240) 'self-insert-table '((:dead--tilde :shift)(#\d)))
-(set-key '(com-insert-charcode 216) 'self-insert-table '((:dead--tilde :shift)(#\O)))
-(set-key '(com-insert-charcode 248) 'self-insert-table '((:dead--tilde :shift)(#\o)))
-(set-key '(com-insert-charcode 126) 'self-insert-table '((:dead--tilde :shift)(#\Space)))
-
-(set-key '(com-insert-charcode 194) 'self-insert-table '((:dead--circumflex :shift)(#\A)))
-(set-key '(com-insert-charcode 202) 'self-insert-table '((:dead--circumflex :shift)(#\E)))
-(set-key '(com-insert-charcode 206) 'self-insert-table '((:dead--circumflex :shift)(#\I)))
-(set-key '(com-insert-charcode 212) 'self-insert-table '((:dead--circumflex :shift)(#\O)))
-(set-key '(com-insert-charcode 219) 'self-insert-table '((:dead--circumflex :shift)(#\U)))
-(set-key '(com-insert-charcode 226) 'self-insert-table '((:dead--circumflex :shift)(#\a)))
-(set-key '(com-insert-charcode 234) 'self-insert-table '((:dead--circumflex :shift)(#\e)))
-(set-key '(com-insert-charcode 238) 'self-insert-table '((:dead--circumflex :shift)(#\i)))
-(set-key '(com-insert-charcode 244) 'self-insert-table '((:dead--circumflex :shift)(#\o)))
-(set-key '(com-insert-charcode 251) 'self-insert-table '((:dead--circumflex :shift)(#\u)))
-(set-key '(com-insert-charcode 94) 'self-insert-table '((:dead--circumflex :shift)(#\Space)))
-
-(define-command (com-regex-search-forward :name t :command-table search-table) ()
- (let ((string (accept 'string :prompt "RE search"
- :delimiter-gestures nil
- :activation-gestures
- '(:newline :return))))
- (re-search-forward (point (current-window)) string)))
-
-(define-command (com-regex-search-backward :name t :command-table search-table) ()
- (let ((string (accept 'string :prompt "RE search backward"
- :delimiter-gestures nil
- :activation-gestures
- '(:newline :return))))
- (re-search-backward (point (current-window)) string)))
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.38 climacs/climacs.asd:1.39
--- climacs/climacs.asd:1.38 Sun Sep 25 22:06:25 2005
+++ climacs/climacs.asd Sat Nov 12 10:34:34 2005
@@ -72,6 +72,13 @@
(:file "esa" :depends-on ("packages"))
(:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane"
"esa" "kill-ring" "io" "text-syntax" "abbrev"))
+;; (:file "buffer-commands" :depends-on ("gui"))
+ (:file "developer-commands" :depends-on ("gui" "lisp-syntax"))
+ (:file "file-commands" :depends-on ("gui"))
+ (:file "misc-commands" :depends-on ("gui"))
+ (:file "search-commands" :depends-on ("gui"))
+ (:file "window-commands" :depends-on ("gui"))
+ (:file "unicode-commands" :depends-on ("gui"))
(:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane"))
(:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax" "gui"))))
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.15 climacs/cl-syntax.lisp:1.16
--- climacs/cl-syntax.lisp:1.15 Tue Aug 16 01:31:22 2005
+++ climacs/cl-syntax.lisp Sat Nov 12 10:34:34 2005
@@ -116,7 +116,7 @@
(valid-parse :initform 1)
(parser))
(:name "Common Lisp")
- (:pathname-types "lisp" "lsp" "cl"))
+ (:pathname-types "lsp" "cl"))
(defun neutralcharp (var)
(and (characterp var)
More information about the Climacs-cvs
mailing list