From crhodes at common-lisp.net Tue Nov 1 09:51:04 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Tue, 1 Nov 2005 10:51:04 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/esa.lisp Message-ID: <20051101095104.C0DED8815C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5235 Modified Files: esa.lisp Log Message: Sync esa with gsharp: menu-item input context Date: Tue Nov 1 10:51:03 2005 Author: crhodes Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.21 climacs/esa.lisp:1.22 --- climacs/esa.lisp:1.21 Sat Oct 29 00:16:01 2005 +++ climacs/esa.lisp Tue Nov 1 10:51:03 2005 @@ -212,7 +212,7 @@ (defun process-gestures-or-command (frame command-table) (with-input-context - (`(command :command-table ,(command-table (car (windows frame))))) + (`(or menu-item (command :command-table ,(command-table (car (windows frame)))))) (object) (let ((gestures '())) (multiple-value-bind (numarg numargp) @@ -234,7 +234,18 @@ (execute-frame-command frame command) (return))) (t nil)))))) - (t + (menu-item + (let ((command (command-menu-item-value object))) + (unless (listp command) + (setq command (list command))) + (when (and (typep (frame-standard-input frame) 'interactor-pane) + (member *unsupplied-argument-marker* command :test #'eq)) + (setq command + (command-line-read-remaining-arguments-for-partial-command + (frame-command-table frame) (frame-standard-input frame) + command 0))) + (execute-frame-command frame command))) + (command (execute-frame-command frame object)))) (defmethod redisplay-frame-panes :around ((frame esa-frame-mixin) &key force-p) From crhodes at common-lisp.net Tue Nov 1 10:45:46 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Tue, 1 Nov 2005 11:45:46 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20051101104546.6874F8815C@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8910 Modified Files: prolog-syntax.lisp Log Message: Implement float-number tokenizing and parsing. Only lightly tested. Date: Tue Nov 1 11:45:45 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.23 climacs/prolog-syntax.lisp:1.24 --- climacs/prolog-syntax.lisp:1.23 Thu Oct 13 11:18:47 2005 +++ climacs/prolog-syntax.lisp Tue Nov 1 11:45:45 2005 @@ -163,7 +163,6 @@ (flet ((fo () (vector-push-extend (object-after scan) string) (forward-object scan)) - #+nil ; we might need this later for float-number tokens (bo () (vector-pop string) (backward-object scan))) @@ -302,7 +301,9 @@ (t (return (make-instance 'graphic-lexeme))))) (t (cond - ((and (string= string ".") (whitespacep (object-after scan))) + ((and (string= string ".") + (or (whitespacep (object-after scan)) + (eql (object-after scan) #\%))) (return (make-instance 'end-lexeme))) (t (return (make-instance 'graphic-lexeme)))))) QUOTED-TOKEN @@ -334,7 +335,7 @@ ((eql object #\o) (fo) (go OCTAL-CONSTANT)) ((eql object #\x) (fo) (go HEXADECIMAL-CONSTANT)) ((digit-char-p object) (fo) (go NUMBER)) - ;; FIXME: floats + ((eql object #\.) (fo) (go INTEGER-AND-END-OR-FLOAT)) (t (return (make-instance 'integer-lexeme)))))) CHARACTER-CODE-CONSTANT (if (read-quoted-char #\') @@ -357,6 +358,8 @@ (return (make-instance 'hexadecimal-constant-lexeme)) NUMBER (loop until (end-of-buffer-p scan) + when (eql (object-after scan) #\.) + do (fo) and do (go INTEGER-AND-END-OR-FLOAT) while (digit-char-p (object-after scan)) do (fo)) (return (make-instance 'integer-constant-lexeme)) @@ -364,7 +367,31 @@ (loop named #:mu until (end-of-buffer-p scan) while (read-quoted-char #\")) - (return (make-instance 'char-code-list-lexeme))))))))) + (return (make-instance 'char-code-list-lexeme)) + INTEGER-AND-END-OR-FLOAT + (when (or (end-of-buffer-p scan) + (let ((object (object-after scan))) + (or (eql object #\%) + (whitespacep object)))) + (bo) + (return (make-instance 'integer-lexeme))) + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan)) + do (fo)) + (when (or (end-of-buffer-p scan) + (not (member (object-after scan) '(#\e #\E)))) + (return (make-instance 'float-number-lexeme))) + (fo) + (when (end-of-buffer-p scan) + (return (make-instance 'error-lexeme))) + (when (member (object-after scan) '(#\+ #\-)) + (fo) + (when (end-of-buffer-p scan) + (return (make-instance 'error-lexeme)))) + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan)) + do (fo)) + (return (make-instance 'float-number-lexeme))))))))) ;;; parser @@ -789,6 +816,8 @@ ;;; 6.3.1.1 (define-prolog-rule (term -> (integer)) (make-instance 'constant-term :priority 0 :value integer)) +(define-prolog-rule (term -> (float-number)) + (make-instance 'constant-term :priority 0 :value float-number)) ;;; 6.3.1.2 (define-prolog-rule (term -> ((atom @@ -796,6 +825,11 @@ integer)) ;; FIXME: this doesn't really look right. (make-instance 'constant-term :priority 0 :value (list atom integer))) +(define-prolog-rule (term -> ((atom + (string= (canonical-name atom) "-")) + float-number)) + ;; FIXME: this doesn't really look right. + (make-instance 'constant-term :priority 0 :value (list atom float-number))) ;;; 6.3.1.3 (define-prolog-rule (term -> ((atom (not (operatorp atom))))) From crhodes at common-lisp.net Tue Nov 1 12:31:55 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Tue, 1 Nov 2005 13:31:55 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp Message-ID: <20051101123155.585008857A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17378 Modified Files: prolog-syntax.lisp Log Message: Fix display of -1 and -1.0 Implement FIRST-LEXEME to get -(1,2) and - (1,2) right. Date: Tue Nov 1 13:31:53 2005 Author: crhodes Index: climacs/prolog-syntax.lisp diff -u climacs/prolog-syntax.lisp:1.24 climacs/prolog-syntax.lisp:1.25 --- climacs/prolog-syntax.lisp:1.24 Tue Nov 1 11:45:45 2005 +++ climacs/prolog-syntax.lisp Tue Nov 1 13:31:52 2005 @@ -513,7 +513,12 @@ (defmethod display-parse-tree ((entity constant-term) (syntax prolog-syntax) pane) - (display-parse-tree (value entity) syntax pane)) + ;; FIXME: this is so not the right thing. + (cond + ((consp (value entity)) + (display-parse-tree (first (value entity)) syntax pane) + (display-parse-tree (second (value entity)) syntax pane)) + (t (display-parse-tree (value entity) syntax pane)))) (defmethod display-parse-tree ((entity variable-term) (syntax prolog-syntax) pane) (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.0)) @@ -1072,10 +1077,16 @@ 'string))) (defun first-lexeme (thing) - ;; FIXME: we'll need to implement this. - (declare (ignore thing)) - nil) - + ;; KLUDGE: it might be "cleaner" to walk the various parsing + ;; structures, but this will do. + (let* ((syntax *this-syntax*) + (lexer (slot-value syntax 'lexer))) + (do ((i 0 (+ i 1))) + ((= i (nb-lexemes lexer)) (error "foo")) + (let ((lexeme (lexeme lexer i))) + (when (= (start-offset thing) (start-offset lexeme)) + (return lexeme)))))) + ;;; update syntax (defmethod update-syntax-for-display (buffer (syntax prolog-syntax) top bot) From crhodes at common-lisp.net Thu Nov 3 10:17:45 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Thu, 3 Nov 2005 11:17:45 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20051103101745.C51AE88588@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20581 Modified Files: gui.lisp Log Message: Be gentle to those users (i.e. .gold.ac.uk) using climacs for its buffers and syntaxes without the gui. Pile another hack in the :around method for (setf syntax). Live in hope that one day all this will be cleaned up. Date: Thu Nov 3 11:17:42 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.193 climacs/gui.lisp:1.194 --- climacs/gui.lisp:1.193 Mon Oct 31 14:42:31 2005 +++ climacs/gui.lisp Thu Nov 3 11:17:40 2005 @@ -1427,9 +1427,16 @@ ;;; similar method on (SETF BUFFER). -- CSR, 2005-10-31. (defmethod (setf syntax) :around (syntax (buffer climacs-buffer)) (call-next-method) - (let ((pane (current-window))) - (assert (eq (buffer pane) buffer)) - (note-pane-syntax-changed pane syntax))) + ;; 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) From crhodes at common-lisp.net Thu Nov 3 14:58:53 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Thu, 3 Nov 2005 15:58:53 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/esa.lisp Message-ID: <20051103145853.A26A988588@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8383 Modified Files: esa.lisp Log Message: Play whack-a-mole with bugs exposed by tabedit: change the frame-command-table along with reading gestures or commands from that command table, so that presentation translators can be found. Date: Thu Nov 3 15:58:53 2005 Author: crhodes Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.22 climacs/esa.lisp:1.23 --- climacs/esa.lisp:1.22 Tue Nov 1 10:51:03 2005 +++ climacs/esa.lisp Thu Nov 3 15:58:52 2005 @@ -212,8 +212,11 @@ (defun process-gestures-or-command (frame command-table) (with-input-context - (`(or menu-item (command :command-table ,(command-table (car (windows frame)))))) + ('menu-item) (object) + (with-input-context + (`(command :command-table ,(command-table (car (windows frame))))) + (object) (let ((gestures '())) (multiple-value-bind (numarg numargp) (read-numeric-argument :stream *standard-input*) @@ -234,19 +237,19 @@ (execute-frame-command frame command) (return))) (t nil)))))) - (menu-item - (let ((command (command-menu-item-value object))) - (unless (listp command) - (setq command (list command))) - (when (and (typep (frame-standard-input frame) 'interactor-pane) - (member *unsupplied-argument-marker* command :test #'eq)) - (setq command - (command-line-read-remaining-arguments-for-partial-command - (frame-command-table frame) (frame-standard-input frame) - command 0))) - (execute-frame-command frame command))) (command - (execute-frame-command frame object)))) + (execute-frame-command frame object))) + (menu-item + (let ((command (command-menu-item-value object))) + (unless (listp command) + (setq command (list command))) + (when (and (typep (frame-standard-input frame) 'interactor-pane) + (member *unsupplied-argument-marker* command :test #'eq)) + (setq command + (command-line-read-remaining-arguments-for-partial-command + (frame-command-table frame) (frame-standard-input frame) + command 0))) + (execute-frame-command frame command))))) (defmethod redisplay-frame-panes :around ((frame esa-frame-mixin) &key force-p) (declare (ignore force-p)) @@ -278,7 +281,12 @@ do (restart-case (progn (handler-case - (process-gestures-or-command frame (command-table (car (windows frame)))) + (progn + ;; for presentation-to-command-translators, + ;; which are searched for in + ;; (frame-command-table *application-frame*) + (setf (frame-command-table frame) (command-table (car (windows frame)))) + (process-gestures-or-command frame (command-table (car (windows frame))))) (abort-gesture () (display-message "Quit"))) (redisplay-frame-panes frame)) (return-to-esa () nil)))))) From dmurray at common-lisp.net Sat Nov 12 09:38:34 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sat, 12 Nov 2005 10:38:34 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/window-commands.lisp climacs/unicode-commands.lisp climacs/search-commands.lisp climacs/misc-commands.lisp climacs/file-commands.lisp climacs/developer-commands.lisp Message-ID: <20051112093834.94C098855E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18152 Added Files: window-commands.lisp unicode-commands.lisp search-commands.lisp misc-commands.lisp file-commands.lisp developer-commands.lisp Log Message: The new files. developer-commands.lisp contains commands used in developing climacs. file-commands, search-commands, unicode-commands and window-commands.lisp contain what you would expect. misc-commands contains everything else, except that stuff kept in gui.lisp, which is the gui stuff (no, really), some low-level stuff, and the buffer-handling. Date: Sat Nov 12 10:38:32 2005 Author: dmurray From dmurray at common-lisp.net Sat Nov 12 09:34:38 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sat, 12 Nov 2005 10:34:38 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/climacs.asd climacs/cl-syntax.lisp Message-ID: <20051112093438.BBA948855E@common-lisp.net> 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) From dmurray at common-lisp.net Sat Nov 12 23:09:39 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sun, 13 Nov 2005 00:09:39 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/syntax.lisp climacs/packages.lisp climacs/misc-commands.lisp climacs/gui.lisp climacs/esa.lisp Message-ID: <20051112230939.695858855F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13115 Modified Files: syntax.lisp packages.lisp misc-commands.lisp gui.lisp esa.lisp Log Message: Introduce find-applicable-command-table, specialised on frame class. Remove some :around kludgery from (setf syntax) and (setf buffer). At the moment f-a-c-t for climacs just asks the syntax which command-table to use, but this could be extended to views etc. Date: Sun Nov 13 00:09:36 2005 Author: dmurray Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.59 climacs/syntax.lisp:1.60 --- climacs/syntax.lisp:1.59 Mon Oct 31 14:42:31 2005 +++ climacs/syntax.lisp Sun Nov 13 00:09:34 2005 @@ -205,19 +205,7 @@ *syntaxes*) (defclass ,class-name ,superclasses ,slots (:default-initargs , at default-initargs) - , at defclass-options) - ,@(when command-table - ;; FIXME: double colons? Looks ugly to me. More - ;; importantly, we can't use EXTENDED-PANE as a specializer - ;; here, because that hasn't been defined yet. - `((defmethod climacs-gui::note-pane-syntax-changed - (pane (syntax ,class-name)) - (setf (command-table pane) ',command-table))))))) - -;;; FIXME: see comment in DEFINE-SYNTAX -(defgeneric climacs-gui::note-pane-syntax-changed (pane syntax) - (:method (pane syntax) - (setf (command-table pane) 'climacs-gui::global-climacs-table))) + , at defclass-options)))) #+nil (defmacro define-syntax (class-name (name superclasses) &body body) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.82 climacs/packages.lisp:1.83 --- climacs/packages.lisp:1.82 Tue Sep 13 21:23:59 2005 +++ climacs/packages.lisp Sun Nov 13 00:09:34 2005 @@ -195,7 +195,8 @@ #:esa-top-level #:simple-command-loop #:global-esa-table #:keyboard-macro-table #:help-table - #:set-key)) + #:set-key + #:find-applicable-command-table)) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax Index: climacs/misc-commands.lisp diff -u climacs/misc-commands.lisp:1.1 climacs/misc-commands.lisp:1.2 --- climacs/misc-commands.lisp:1.1 Sat Nov 12 10:38:32 2005 +++ climacs/misc-commands.lisp Sun Nov 13 00:09:34 2005 @@ -734,22 +734,6 @@ (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))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.195 climacs/gui.lisp:1.196 --- climacs/gui.lisp:1.195 Sat Nov 12 10:34:34 2005 +++ climacs/gui.lisp Sun Nov 13 00:09:34 2005 @@ -250,6 +250,14 @@ do (when (modified-p buffer) (setf (needs-saving buffer) t)))) +(defmethod find-applicable-command-table ((frame climacs)) + (or + (let ((syntax (syntax (buffer (current-window))))) + (and (slot-exists-p syntax 'command-table) + (slot-boundp syntax 'command-table) + (slot-value syntax 'command-table))) + (find-command-table 'global-climacs-table))) + (define-command (com-full-redisplay :name t :command-table base-table) () (full-redisplay (current-window))) @@ -359,11 +367,11 @@ (when default (switch-to-buffer default)))) -;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR, -;;; 2005-10-31. -(defmethod (setf buffer) :around (buffer (pane extended-pane)) - (call-next-method) - (note-pane-syntax-changed pane (syntax buffer))) +;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR, +;; ;;; 2005-10-31. +;; (defmethod (setf buffer) :around (buffer (pane extended-pane)) +;; (call-next-method) +;; (note-pane-syntax-changed pane (syntax buffer))) (define-command (com-switch-to-buffer :name t :command-table pane-table) () (let* ((default (second (buffers *application-frame*))) Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.23 climacs/esa.lisp:1.24 --- climacs/esa.lisp:1.23 Thu Nov 3 15:58:52 2005 +++ climacs/esa.lisp Sun Nov 13 00:09:35 2005 @@ -215,7 +215,7 @@ ('menu-item) (object) (with-input-context - (`(command :command-table ,(command-table (car (windows frame))))) + (`(command :command-table ,command-table)) (object) (let ((gestures '())) (multiple-value-bind (numarg numargp) @@ -263,6 +263,11 @@ (car command) command))) +(defgeneric find-applicable-command-table (frame)) + +(defmethod find-applicable-command-table ((frame esa-frame-mixin)) + (command-table (car (windows frame)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Top level @@ -281,12 +286,12 @@ do (restart-case (progn (handler-case - (progn + (let ((command-table (find-applicable-command-table frame))) ;; for presentation-to-command-translators, ;; which are searched for in ;; (frame-command-table *application-frame*) - (setf (frame-command-table frame) (command-table (car (windows frame)))) - (process-gestures-or-command frame (command-table (car (windows frame))))) + (setf (frame-command-table frame) command-table) + (process-gestures-or-command frame command-table)) (abort-gesture () (display-message "Quit"))) (redisplay-frame-panes frame)) (return-to-esa () nil)))))) From dmurray at common-lisp.net Sun Nov 13 09:24:47 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Sun, 13 Nov 2005 10:24:47 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/window-commands.lisp climacs/gui.lisp Message-ID: <20051113092447.3242F880D6@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24708 Modified Files: window-commands.lisp gui.lisp Log Message: Replaced (typep x 'extended-pane) tests with new gf buffer-pane-p. Fixed command-table bug with non-buffer panes. Still need a way to choose command-tables for non-buffer panes e.g. help panes. Date: Sun Nov 13 10:24:46 2005 Author: dmurray Index: climacs/window-commands.lisp diff -u climacs/window-commands.lisp:1.1 climacs/window-commands.lisp:1.2 --- climacs/window-commands.lisp:1.1 Sat Nov 12 10:38:32 2005 +++ climacs/window-commands.lisp Sun Nov 13 10:24:45 2005 @@ -194,7 +194,7 @@ (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) + (when (buffer-pane-p window) (setf (offset (point window)) (click-to-offset window x y)))) @@ -207,7 +207,7 @@ (define-command (com-mouse-save :name nil :command-table window-table) ((window 'pane) (x 'integer) (y 'integer)) - (when (and (typep window 'extended-pane) + (when (and (buffer-pane-p window) (eq window (current-window))) (setf (offset (mark window)) (click-to-offset window x y)) @@ -223,7 +223,7 @@ (define-command (com-yank-here :name nil :command-table window-table) ((window 'pane) (x 'integer) (y 'integer)) - (when (typep window 'extended-pane) + (when (buffer-pane-p window) (other-window window) (setf (offset (point window)) (click-to-offset window x y)) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.196 climacs/gui.lisp:1.197 --- climacs/gui.lisp:1.196 Sun Nov 13 00:09:34 2005 +++ climacs/gui.lisp Sun Nov 13 10:24:45 2005 @@ -37,6 +37,16 @@ (dabbrev-expansion-mark :initform nil) (overwrite-mode :initform nil))) +(defgeneric buffer-pane-p (pane) + (:documentation "Returns T when a pane contains a buffer.")) + +(defmethod buffer-pane-p (pane) + (declare (ignore pane)) + nil) + +(defmethod buffer-pane-p ((pane extended-pane)) + T) + (defclass climacs-info-pane (info-pane) () (:default-initargs @@ -149,7 +159,7 @@ (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) (let ((buffers (remove-duplicates (loop for pane in (windows frame) - when (typep pane 'extended-pane) + when (buffer-pane-p pane) collect (buffer pane))))) (loop for buffer in buffers do (update-syntax buffer (syntax buffer))) @@ -226,7 +236,7 @@ (defmethod execute-frame-command :around ((frame climacs) command) (handler-case - (if (typep (current-window) 'extended-pane) + (if (buffer-pane-p (current-window)) (with-undo ((buffer (current-window))) (call-next-method)) (call-next-method)) @@ -252,8 +262,10 @@ (defmethod find-applicable-command-table ((frame climacs)) (or - (let ((syntax (syntax (buffer (current-window))))) - (and (slot-exists-p syntax 'command-table) + (let ((syntax (and (buffer-pane-p (current-window)) + (syntax (buffer (current-window)))))) + (and syntax + (slot-exists-p syntax 'command-table) (slot-boundp syntax 'command-table) (slot-value syntax 'command-table))) (find-command-table 'global-climacs-table))) From dlewis at common-lisp.net Mon Nov 14 16:30:15 2005 From: dlewis at common-lisp.net (David Lewis) Date: Mon, 14 Nov 2005 17:30:15 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/esa.lisp climacs/syntax.lisp climacs/gui.lisp Message-ID: <20051114163015.4147E880D6@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31363 Modified Files: esa.lisp syntax.lisp gui.lisp Log Message: Added command-table slot to syntax objects. Define-syntax now passes command-table to new syntaxes. com-extended-command uses find-applicable-command-table. Date: Mon Nov 14 17:30:14 2005 Author: dlewis Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.24 climacs/esa.lisp:1.25 --- climacs/esa.lisp:1.24 Sun Nov 13 00:09:35 2005 +++ climacs/esa.lisp Mon Nov 14 17:30:13 2005 @@ -379,8 +379,7 @@ () (let ((item (handler-case (accept - `(command :command-table - ,(command-table (car (windows *application-frame*)))) + `(command :command-table ,(find-applicable-command-table *application-frame*)) :prompt "Extended Command") (error () (progn (beep) (display-message "No such command") Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.60 climacs/syntax.lisp:1.61 --- climacs/syntax.lisp:1.60 Sun Nov 13 00:09:34 2005 +++ climacs/syntax.lisp Mon Nov 14 17:30:13 2005 @@ -23,7 +23,8 @@ (in-package :climacs-syntax) (defclass syntax (name-mixin) - ((buffer :initarg :buffer :reader buffer))) + ((buffer :initarg :buffer :reader buffer) + (command-table :initarg :command-table))) (define-condition no-such-operation (simple-error) () @@ -204,7 +205,7 @@ :pathname-types ',pathname-types) *syntaxes*) (defclass ,class-name ,superclasses ,slots - (:default-initargs , at default-initargs) + (:default-initargs :command-table ',command-table , at default-initargs) , at defclass-options)))) #+nil Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.197 climacs/gui.lisp:1.198 --- climacs/gui.lisp:1.197 Sun Nov 13 10:24:45 2005 +++ climacs/gui.lisp Mon Nov 14 17:30:13 2005 @@ -267,7 +267,8 @@ (and syntax (slot-exists-p syntax 'command-table) (slot-boundp syntax 'command-table) - (slot-value syntax 'command-table))) + (slot-value syntax 'command-table) + (find-command-table (slot-value syntax 'command-table)))) (find-command-table 'global-climacs-table))) (define-command (com-full-redisplay :name t :command-table base-table) () From mpearce at common-lisp.net Wed Nov 23 17:39:30 2005 From: mpearce at common-lisp.net (Marcus Pearce) Date: Wed, 23 Nov 2005 18:39:30 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/prolog2paiprolog.lisp climacs/climacs.asd Message-ID: <20051123173930.3345888554@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29301 Modified Files: climacs.asd Added Files: prolog2paiprolog.lisp Log Message: prolog2paiprolog.lisp: initial checkin. Date: Wed Nov 23 18:39:28 2005 Author: mpearce Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.39 climacs/climacs.asd:1.40 --- climacs/climacs.asd:1.39 Sat Nov 12 10:34:34 2005 +++ climacs/climacs.asd Wed Nov 23 18:39:28 2005 @@ -67,6 +67,7 @@ (:file "cl-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) (:file "html-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) (:file "prolog-syntax" :depends-on ("packages" "base" "syntax" "pane" "buffer")) + (:file "prolog2paiprolog" :depends-on ("prolog-syntax")) (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane")) (:file "esa" :depends-on ("packages"))