- climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS update: climacs/pane.lisp
by dholman＠common-lisp.net 05 Dec '05

05 Dec '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28101 Modified Files: pane.lisp Log Message: Added method to fix problems with the viewport after resizing, and added it to the redisplay function. Ideally, it should only be called on resizes leading to the problem, so I'll keep looking for better solutions. Date: Mon Dec 5 10:55:18 2005 Author: dholman Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.33 climacs/pane.lisp:1.34 --- climacs/pane.lisp:1.33 Tue Sep 13 21:23:59 2005 +++ climacs/pane.lisp Mon Dec 5 10:55:18 2005 @@ -527,6 +527,16 @@ (setf cursor-x x cursor-y y))))) +(defgeneric fix-pane-viewport (pane)) + +(defmethod fix-pane-viewport ((pane climacs-pane)) + (let* ((v (window-viewport pane)) + (x (rectangle-width v)) + (y (rectangle-height v))) + (resize-sheet pane x y) + (setf (window-viewport-position pane) (values 0 0)))) + + (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p) (display-cache pane) (when (mark-visible-p pane) (display-mark pane syntax)) @@ -541,8 +551,10 @@ (setf (full-redisplay-p pane) nil)) (adjust-cache pane)) (fill-cache pane) + (fix-pane-viewport pane) (update-syntax-for-display (buffer pane) (syntax (buffer pane)) (top pane) (bot pane)) (redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p)) + (defgeneric full-redisplay (pane))

1 0

[climacs-cvs] CVS update: climacs/prolog2paiprolog.lisp climacs/climacs.asd
by mpearce＠common-lisp.net 23 Nov '05

23 Nov '05

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"))

1 0

[climacs-cvs] CVS update: climacs/esa.lisp climacs/syntax.lisp climacs/gui.lisp
by dlewis＠common-lisp.net 14 Nov '05

14 Nov '05

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 ,@default-initargs) + (:default-initargs :command-table ',command-table ,@default-initargs) ,@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) ()

1 0

[climacs-cvs] CVS update: climacs/window-commands.lisp climacs/gui.lisp
by dmurray＠common-lisp.net 13 Nov '05

13 Nov '05

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)))

1 0

[climacs-cvs] CVS update: climacs/syntax.lisp climacs/packages.lisp climacs/misc-commands.lisp climacs/gui.lisp climacs/esa.lisp
by dmurray＠common-lisp.net 12 Nov '05

12 Nov '05

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 ,@default-initargs) - ,@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))) + ,@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))))))

1 0

[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
by dmurray＠common-lisp.net 12 Nov '05

12 Nov '05

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

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/climacs.asd climacs/cl-syntax.lisp
by dmurray＠common-lisp.net 12 Nov '05

12 Nov '05

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)

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by crhodes＠common-lisp.net 03 Nov '05

03 Nov '05

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))))))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by crhodes＠common-lisp.net 03 Nov '05

03 Nov '05

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)

1 0

[climacs-cvs] CVS update: climacs/prolog-syntax.lisp
by crhodes＠common-lisp.net 01 Nov '05

01 Nov '05

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)

1 0