From rstrandh at common-lisp.net Sat Jan 1 09:34:28 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 1 Jan 2005 10:34:28 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp Message-ID: <20050101093428.7320C884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17852 Modified Files: base.lisp gui.lisp packages.lisp syntax.lisp Log Message: Factored aspects of named objects (currently buffers and syntaxes) into a syntax-mixin class in base.lisp. Updated packages.lisp accordingly. Implemented syntax completion (i.e., the possibility to use CLIM completion to determine the name of a syntax). I Implemented an extended command "Set Syntax" using the completion. Currently, it does not invalidate the CLIM output history, because I need to think a bit more about how to do that properly. Date: Sat Jan 1 10:34:26 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.8 climacs/base.lisp:1.9 --- climacs/base.lisp:1.8 Thu Dec 30 06:28:21 2004 +++ climacs/base.lisp Sat Jan 1 10:34:25 2005 @@ -135,3 +135,12 @@ while (constituentp (object-before mark)) do (delete-range mark -1))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Named objects + +(defgeneric name (obj)) + +(defclass name-mixin () + ((name :initarg :name :accessor name))) + Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.37 climacs/gui.lisp:1.38 --- climacs/gui.lisp:1.37 Fri Dec 31 14:33:06 2004 +++ climacs/gui.lisp Sat Jan 1 10:34:25 2005 @@ -27,9 +27,10 @@ (defclass filename-mixin () ((filename :initform nil :accessor filename))) -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin) - ((name :initform "*scratch*" :accessor name) - (needs-saving :initform nil :accessor needs-saving))) +(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin) + ((needs-saving :initform nil :accessor needs-saving)) + (:default-initargs :name "*scratch*")) + (defclass climacs-pane (application-pane) ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) @@ -94,9 +95,10 @@ (defun display-info (frame pane) (let* ((win (win frame)) (buf (buffer win)) - (name-info (format nil " ~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a" (if (needs-saving buf) "**" "--") - (name buf)))) + (name buf) + (name (syntax win))))) (princ name-info pane))) (defun display-win (frame pane) @@ -420,6 +422,11 @@ (define-named-command com-set-mark () (with-slots (point mark) (win *application-frame*) (setf mark (clone-mark point)))) + +(define-named-command com-set-syntax () + (setf (syntax (win *application-frame*)) + (make-instance (accept 'syntax :prompt "Set Syntax") + :pane (win *application-frame*)))) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.16 climacs/packages.lisp:1.17 --- climacs/packages.lisp:1.16 Fri Dec 31 14:33:06 2004 +++ climacs/packages.lisp Sat Jan 1 10:34:25 2005 @@ -48,7 +48,8 @@ #:constituentp #:whitespacep #:forward-word #:backward-word #:delete-word #:backward-delete-word - #:input-from-stream #:output-to-stream)) + #:input-from-stream #:output-to-stream + #:name-mixin #:name)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.13 climacs/syntax.lisp:1.14 --- climacs/syntax.lisp:1.13 Fri Dec 31 14:33:06 2004 +++ climacs/syntax.lisp Sat Jan 1 10:34:25 2005 @@ -24,7 +24,7 @@ (in-package :climacs-syntax) -(defclass syntax () ()) +(defclass syntax (name-mixin) ()) (defgeneric redisplay-with-syntax (pane syntax)) @@ -34,7 +34,37 @@ (defgeneric full-redisplay (pane syntax)) -(defclass basic-syntax (syntax) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Syntax completion + +(defparameter *syntaxes* '()) + +(defmacro define-syntax (class-name (name superclasses) &body body) + `(progn (push '(,name . ,class-name) *syntaxes*) + (defclass ,class-name ,superclasses + , at body + (:default-initargs :name ,name)))) + +(define-presentation-method accept + ((type syntax) stream (view textual-view) &key) + (multiple-value-bind (pathname success string) + (complete-input stream + (lambda (so-far action) + (complete-from-possibilities + so-far *syntaxes* '() :action action + :name-key #'car + :value-key #'cdr)) + :partial-completers '(#\Space) + :allow-any-input t) + (declare (ignore success)) + (or pathname string))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Basic syntax + +(define-syntax basic-syntax ("Basic" (syntax)) ((top :reader top) (bot :reader bot) (scan :reader scan) @@ -58,6 +88,8 @@ (define-presentation-type url () :inherit-from 'string) +(defgeneric present-contents (contenst pane syntax)) + (defmethod present-contents (contents pane (syntax basic-syntax)) (unless (null contents) (present contents @@ -66,6 +98,8 @@ 'string) :stream pane))) +(defgeneric display-line (pane syntax line)) + (defmethod display-line (pane (syntax basic-syntax) line) (let ((saved-index nil) (id 0)) @@ -117,6 +151,8 @@ (terpri pane) (incf scan)))))) +(defgeneric compute-cache (pane syntax)) + (defmethod compute-cache (pane (syntax basic-syntax)) (with-slots (top bot cache) syntax (let* ((buffer (buffer pane)) @@ -225,7 +261,7 @@ ;;; ;;; Texinfo syntax -(defclass texinfo-syntax (basic-syntax) ()) +(define-syntax texinfo-syntax ("Texinfo" (basic-syntax)) ()) (define-presentation-type texinfo-command () :inherit-from 'string) @@ -236,4 +272,5 @@ (with-drawing-options (pane :ink +red+) (present contents 'texinfo-command :stream pane)) (present contents 'string :stream pane)))) + From rstrandh at common-lisp.net Sat Jan 1 10:06:24 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 1 Jan 2005 11:06:24 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp Message-ID: <20050101100624.40A83884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19337 Modified Files: gui.lisp packages.lisp syntax.lisp Log Message: Implemented page-down (C-v). Date: Sat Jan 1 11:06:22 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.38 climacs/gui.lisp:1.39 --- climacs/gui.lisp:1.38 Sat Jan 1 10:34:25 2005 +++ climacs/gui.lisp Sat Jan 1 11:06:21 2005 @@ -390,6 +390,10 @@ (define-named-command com-beginning-of-buffer () (beginning-of-buffer (point (win *application-frame*)))) +(define-named-command com-page-down () + (let ((pane (win *application-frame*))) + (page-down pane (syntax pane)))) + (define-named-command com-end-of-buffer () (end-of-buffer (point (win *application-frame*)))) @@ -503,6 +507,7 @@ (global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only (global-set-key '(#\w :meta) 'com-copy-out) +(global-set-key '(#\v :control) 'com-page-down) (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\u :meta) 'com-browse-url) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.17 climacs/packages.lisp:1.18 --- climacs/packages.lisp:1.17 Sat Jan 1 10:34:25 2005 +++ climacs/packages.lisp Sat Jan 1 11:06:21 2005 @@ -60,6 +60,7 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:basic-syntax #:texinfo-syntax #:redisplay-pane #:redisplay-with-syntax #:full-redisplay + #:page-down #:url)) (defpackage :climacs-kill-ring Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.14 climacs/syntax.lisp:1.15 --- climacs/syntax.lisp:1.14 Sat Jan 1 10:34:25 2005 +++ climacs/syntax.lisp Sat Jan 1 11:06:21 2005 @@ -199,6 +199,7 @@ (declare (ignore x y w)) (let ((nb-lines-in-pane (max 1 (floor h (+ height (stream-vertical-spacing pane))))) (nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) + (format *query-io* "~a ~a~%" (offset top) (offset bot)) ;; adjust the region on display to fit the pane (loop repeat (- nb-lines-on-display nb-lines-in-pane) do (beginning-of-line bot) @@ -226,6 +227,14 @@ do (incf (offset bot)) (end-of-line bot)))))))) +(defun page-down (pane syntax) + (position-window pane syntax) + (with-slots (top bot cache) syntax + (when (mark> (size (buffer bot)) bot) + (setf (offset top) (offset bot)) + (beginning-of-line top) + (setf (offset (point pane)) (offset top)) + (setf cache nil)))) ;;; this one should not be necessary. (defun round-up (x) From rstrandh at common-lisp.net Sat Jan 1 10:43:42 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 1 Jan 2005 11:43:42 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp Message-ID: <20050101104342.19867884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20869 Modified Files: gui.lisp packages.lisp syntax.lisp Log Message: Implemented page-down (M-v). Date: Sat Jan 1 11:43:39 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.39 climacs/gui.lisp:1.40 --- climacs/gui.lisp:1.39 Sat Jan 1 11:06:21 2005 +++ climacs/gui.lisp Sat Jan 1 11:43:39 2005 @@ -394,6 +394,10 @@ (let ((pane (win *application-frame*))) (page-down pane (syntax pane)))) +(define-named-command com-page-up () + (let ((pane (win *application-frame*))) + (page-up pane (syntax pane)))) + (define-named-command com-end-of-buffer () (end-of-buffer (point (win *application-frame*)))) @@ -508,6 +512,7 @@ (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only (global-set-key '(#\w :meta) 'com-copy-out) (global-set-key '(#\v :control) 'com-page-down) +(global-set-key '(#\v :meta) 'com-page-up) (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\u :meta) 'com-browse-url) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.18 climacs/packages.lisp:1.19 --- climacs/packages.lisp:1.18 Sat Jan 1 11:06:21 2005 +++ climacs/packages.lisp Sat Jan 1 11:43:39 2005 @@ -60,7 +60,7 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:basic-syntax #:texinfo-syntax #:redisplay-pane #:redisplay-with-syntax #:full-redisplay - #:page-down + #:page-down #:page-up #:url)) (defpackage :climacs-kill-ring Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.15 climacs/syntax.lisp:1.16 --- climacs/syntax.lisp:1.15 Sat Jan 1 11:06:21 2005 +++ climacs/syntax.lisp Sat Jan 1 11:43:39 2005 @@ -199,7 +199,6 @@ (declare (ignore x y w)) (let ((nb-lines-in-pane (max 1 (floor h (+ height (stream-vertical-spacing pane))))) (nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) - (format *query-io* "~a ~a~%" (offset top) (offset bot)) ;; adjust the region on display to fit the pane (loop repeat (- nb-lines-on-display nb-lines-in-pane) do (beginning-of-line bot) @@ -235,6 +234,23 @@ (beginning-of-line top) (setf (offset (point pane)) (offset top)) (setf cache nil)))) + +(defun page-up (pane syntax) + (position-window pane syntax) + (with-slots (top bot cache) syntax + (let ((nb-lines-in-region (number-of-lines-in-region top bot))) + (when (> (offset top) 0) + (setf (offset bot) (offset top)) + (end-of-line bot) + (loop repeat nb-lines-in-region + while (> (offset top) 0) + do (decf (offset top)) + (beginning-of-line top)) + (setf (offset (point pane)) (offset top)) + (position-window pane syntax) + (setf (offset (point pane)) (offset bot)) + (beginning-of-line (point pane)) + (setf cache nil))))) ;;; this one should not be necessary. (defun round-up (x) From rstrandh at common-lisp.net Sat Jan 1 10:49:28 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 1 Jan 2005 11:49:28 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/syntax.lisp Message-ID: <20050101104928.94125884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21597 Modified Files: syntax.lisp Log Message: minor stuff. Date: Sat Jan 1 11:49:27 2005 Author: rstrandh Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.16 climacs/syntax.lisp:1.17 --- climacs/syntax.lisp:1.16 Sat Jan 1 11:43:39 2005 +++ climacs/syntax.lisp Sat Jan 1 11:49:26 2005 @@ -238,8 +238,8 @@ (defun page-up (pane syntax) (position-window pane syntax) (with-slots (top bot cache) syntax - (let ((nb-lines-in-region (number-of-lines-in-region top bot))) - (when (> (offset top) 0) + (when (> (offset top) 0) + (let ((nb-lines-in-region (number-of-lines-in-region top bot))) (setf (offset bot) (offset top)) (end-of-line bot) (loop repeat nb-lines-in-region From rstrandh at common-lisp.net Sat Jan 1 12:55:03 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 1 Jan 2005 13:55:03 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050101125503.2DBF1884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28467 Modified Files: gui.lisp Log Message: Committed fix for bug found by Christophe Rhodes. Thanks. Date: Sat Jan 1 13:55:02 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.40 climacs/gui.lisp:1.41 --- climacs/gui.lisp:1.40 Sat Jan 1 11:43:39 2005 +++ climacs/gui.lisp Sat Jan 1 13:55:01 2005 @@ -264,7 +264,7 @@ (let ((item (accept 'command :prompt "Extended Command"))) (execute-frame-command *application-frame* item))) -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :load-toplevel) (define-presentation-type completable-pathname () :inherit-from 'pathname)) From rstrandh at common-lisp.net Sat Jan 1 13:25:21 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 1 Jan 2005 14:25:21 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050101132521.99C49884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30026 Modified Files: gui.lisp Log Message: implemented transpose-objects (C-t) according to a suggestion by Christophe Rhodes. Applied some code factoring to his initial suggestion. Date: Sat Jan 1 14:25:19 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.41 climacs/gui.lisp:1.42 --- climacs/gui.lisp:1.41 Sat Jan 1 13:55:01 2005 +++ climacs/gui.lisp Sat Jan 1 14:25:19 2005 @@ -230,6 +230,17 @@ (define-named-command com-backward-delete-object () (delete-range (point (win *application-frame*)) -1)) +(define-named-command com-transpose-objects () + (let* ((point (point (win *application-frame*)))) + (unless (beginning-of-buffer-p point) + (when (end-of-line-p point) + (decf (offset point))) + (let ((object (object-after point))) + (delete-range point) + (decf (offset point)) + (insert-object point object) + (incf (offset point)))))) + (define-named-command com-previous-line () (previous-line (point (win *application-frame*)))) @@ -503,6 +514,7 @@ (global-set-key '(#\n :control) 'com-next-line) (global-set-key '(#\o :control) 'com-open-line) (global-set-key '(#\k :control) 'com-kill-line) +(global-set-key '(#\t :control) 'com-transpose-objects) (global-set-key '(#\Space :control) 'com-set-mark) (global-set-key '(#\y :control) 'com-copy-in) (global-set-key '(#\w :control) 'com-cut-out) From rstrandh at common-lisp.net Sat Jan 1 14:40:02 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 1 Jan 2005 15:40:02 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/climacs.asd Message-ID: <20050101144002.CBED8884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1923 Modified Files: climacs.asd Log Message: Added improvement to asdf compilation procedure. Thanks to Andreas Fuchs. Date: Sat Jan 1 15:39:56 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.6 climacs/climacs.asd:1.7 --- climacs/climacs.asd:1.6 Wed Dec 29 06:45:37 2004 +++ climacs/climacs.asd Sat Jan 1 15:39:55 2005 @@ -57,3 +57,15 @@ "syntax" "kill-ring" "gui") + +#+asdf +(defmethod asdf:perform :around ((o asdf:compile-op) + (c (eql (asdf:find-component (asdf:find-system :climacs) "skiplist-package")))) + (cond + ((null (probe-file (first (asdf:input-files o c)))) + (cerror "Retry loading climacs." + "~@" nil) + (asdf:perform o c)) + (t (call-next-method o c)))) From rstrandh at common-lisp.net Sat Jan 1 19:58:42 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 1 Jan 2005 20:58:42 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050101195842.2D3A0884FE@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17974 Modified Files: gui.lisp Log Message: Patch from Christophe Rhodes implementing transpose-objects and transpose-words. Thank you. Date: Sat Jan 1 20:58:40 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.42 climacs/gui.lisp:1.43 --- climacs/gui.lisp:1.42 Sat Jan 1 14:25:19 2005 +++ climacs/gui.lisp Sat Jan 1 20:58:40 2005 @@ -212,12 +212,6 @@ (possibly-expand-abbrev (point (win *application-frame*)))) (insert-object (point (win *application-frame*)) *current-gesture*)) -(define-named-command com-backward-object () - (decf (offset (point (win *application-frame*))))) - -(define-named-command com-forward-object () - (incf (offset (point (win *application-frame*))))) - (define-named-command com-beginning-of-line () (beginning-of-line (point (win *application-frame*)))) @@ -234,12 +228,52 @@ (let* ((point (point (win *application-frame*)))) (unless (beginning-of-buffer-p point) (when (end-of-line-p point) - (decf (offset point))) - (let ((object (object-after point))) - (delete-range point) - (decf (offset point)) - (insert-object point object) - (incf (offset point)))))) + (backward-object point)) + (let ((object (object-after point))) + (delete-range point) + (backward-object point) + (insert-object point object) + (forward-object point))))) + +(defgeneric backward-object (mark &optional count)) +(defmethod backward-object ((mark climacs-buffer::mark-mixin) + &optional (count 1)) + (decf (offset mark) count)) + +(defgeneric forward-object (mark &optional count)) +(defmethod forward-object ((mark climacs-buffer::mark-mixin) + &optional (count 1)) + (incf (offset mark) count)) + +(define-named-command com-backward-object () + (backward-object (point (win *application-frame*)))) + +(define-named-command com-forward-object () + (forward-object (point (win *application-frame*)))) + +(define-named-command com-transpose-words () + (let* ((point (point (win *application-frame*)))) + (let (bw1 bw2 ew1 ew2) + (backward-word point) + (setf bw1 (offset point)) + (forward-word point) + (setf ew1 (offset point)) + (forward-word point) + (when (= (offset point) ew1) + ;; this is emacs' message in the minibuffer + (error "Don't have two things to transpose")) + (setf ew2 (offset point)) + (backward-word point) + (setf bw2 (offset point)) + (let ((w2 (buffer-sequence (buffer point) bw2 ew2)) + (w1 (buffer-sequence (buffer point) bw1 ew1))) + (delete-word point) + (insert-sequence point w1) + (backward-word point) + (backward-word point) + (delete-word point) + (insert-sequence point w2) + (forward-word point))))) (define-named-command com-previous-line () (previous-line (point (win *application-frame*)))) @@ -520,6 +554,7 @@ (global-set-key '(#\w :control) 'com-cut-out) (global-set-key '(#\f :meta) 'com-forward-word) (global-set-key '(#\b :meta) 'com-backward-word) +(global-set-key '(#\t :meta) 'com-transpose-words) (global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only (global-set-key '(#\w :meta) 'com-copy-out) From rstrandh at common-lisp.net Mon Jan 3 10:25:57 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 3 Jan 2005 11:25:57 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp Message-ID: <20050103102557.B4F02884F7@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4300 Modified Files: climacs.asd gui.lisp Log Message: Added support for input of latin-1 characters for those who have a keyboard configured as us-international, where the following keys are dead: ' ` " ~ ^ Date: Mon Jan 3 11:25:54 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.7 climacs/climacs.asd:1.8 --- climacs/climacs.asd:1.7 Sat Jan 1 15:39:55 2005 +++ climacs/climacs.asd Mon Jan 3 11:25:42 2005 @@ -49,6 +49,7 @@ "Flexichain/utilities" "Flexichain/flexichain" "Flexichain/flexicursor" + "translate" "packages" "buffer" "base" Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.43 climacs/gui.lisp:1.44 --- climacs/gui.lisp:1.43 Sat Jan 1 20:58:40 2005 +++ climacs/gui.lisp Mon Jan 3 11:25:43 2005 @@ -598,3 +598,152 @@ (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\w :control) 'com-write-buffer) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Some Unicode stuff + +(define-named-command com-insert-charcode ((code 'integer :prompt "Code point")) + (insert-object (point (win *application-frame*)) (code-char code))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-acute command table + +(make-command-table 'dead-acute-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-acute" + :menu 'dead-acute-climacs-table + :keystroke '(:dead--acute)) + +(defun dead-acute-set-key (gesture command) + (add-command-to-command-table command 'dead-acute-climacs-table + :keystroke gesture :errorp nil)) + +(dead-acute-set-key '(#\A) '(com-insert-charcode 193)) +(dead-acute-set-key '(#\E) '(com-insert-charcode 201)) +(dead-acute-set-key '(#\I) '(com-insert-charcode 205)) +(dead-acute-set-key '(#\O) '(com-insert-charcode 211)) +(dead-acute-set-key '(#\U) '(com-insert-charcode 218)) +(dead-acute-set-key '(#\Y) '(com-insert-charcode 221)) +(dead-acute-set-key '(#\a) '(com-insert-charcode 225)) +(dead-acute-set-key '(#\e) '(com-insert-charcode 233)) +(dead-acute-set-key '(#\i) '(com-insert-charcode 237)) +(dead-acute-set-key '(#\o) '(com-insert-charcode 243)) +(dead-acute-set-key '(#\u) '(com-insert-charcode 250)) +(dead-acute-set-key '(#\y) '(com-insert-charcode 253)) +(dead-acute-set-key '(#\C) '(com-insert-charcode 199)) +(dead-acute-set-key '(#\c) '(com-insert-charcode 231)) +(dead-acute-set-key '(#\B) '(com-insert-charcode 197)) ; not great +(dead-acute-set-key '(#\b) '(com-insert-charcode 229)) ; not great +(dead-acute-set-key '(#\x) '(com-insert-charcode 215)) +(dead-acute-set-key '(#\-) '(com-insert-charcode 247)) +(dead-acute-set-key '(#\T) '(com-insert-charcode 222)) +(dead-acute-set-key '(#\t) '(com-insert-charcode 254)) +(dead-acute-set-key '(#\s) '(com-insert-charcode 223)) +(dead-acute-set-key '(#\Space) '(com-insert-charcode 39)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-grave command table + +(make-command-table 'dead-grave-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-grave" + :menu 'dead-grave-climacs-table + :keystroke '(:dead--grave)) + +(defun dead-grave-set-key (gesture command) + (add-command-to-command-table command 'dead-grave-climacs-table + :keystroke gesture :errorp nil)) + +(dead-grave-set-key '(#\A) '(com-insert-charcode 192)) +(dead-grave-set-key '(#\E) '(com-insert-charcode 200)) +(dead-grave-set-key '(#\I) '(com-insert-charcode 204)) +(dead-grave-set-key '(#\O) '(com-insert-charcode 210)) +(dead-grave-set-key '(#\U) '(com-insert-charcode 217)) +(dead-grave-set-key '(#\a) '(com-insert-charcode 224)) +(dead-grave-set-key '(#\e) '(com-insert-charcode 232)) +(dead-grave-set-key '(#\i) '(com-insert-charcode 236)) +(dead-grave-set-key '(#\o) '(com-insert-charcode 242)) +(dead-grave-set-key '(#\u) '(com-insert-charcode 249)) +(dead-grave-set-key '(#\Space) '(com-insert-charcode 96)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-diaeresis command table + +(make-command-table 'dead-diaeresis-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis" + :menu 'dead-diaeresis-climacs-table + :keystroke '(:dead--diaeresis :shift)) + +(defun dead-diaeresis-set-key (gesture command) + (add-command-to-command-table command 'dead-diaeresis-climacs-table + :keystroke gesture :errorp nil)) + +(dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196)) +(dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203)) +(dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207)) +(dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214)) +(dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220)) +(dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228)) +(dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235)) +(dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239)) +(dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246)) +(dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252)) +(dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255)) +(dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-tilde command table + +(make-command-table 'dead-tilde-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-tilde" + :menu 'dead-tilde-climacs-table + :keystroke '(:dead--tilde :shift)) + +(defun dead-tilde-set-key (gesture command) + (add-command-to-command-table command 'dead-tilde-climacs-table + :keystroke gesture :errorp nil)) + +(dead-tilde-set-key '(#\A) '(com-insert-charcode 195)) +(dead-tilde-set-key '(#\N) '(com-insert-charcode 209)) +(dead-tilde-set-key '(#\a) '(com-insert-charcode 227)) +(dead-tilde-set-key '(#\n) '(com-insert-charcode 241)) +(dead-tilde-set-key '(#\E) '(com-insert-charcode 198)) +(dead-tilde-set-key '(#\e) '(com-insert-charcode 230)) +(dead-tilde-set-key '(#\D) '(com-insert-charcode 208)) +(dead-tilde-set-key '(#\d) '(com-insert-charcode 240)) +(dead-tilde-set-key '(#\O) '(com-insert-charcode 216)) +(dead-tilde-set-key '(#\o) '(com-insert-charcode 248)) +(dead-tilde-set-key '(#\Space) '(com-insert-charcode 126)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-circumflex command table + +(make-command-table 'dead-circumflex-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-circumflex" + :menu 'dead-circumflex-climacs-table + :keystroke '(:dead--circumflex :shift)) + +(defun dead-circumflex-set-key (gesture command) + (add-command-to-command-table command 'dead-circumflex-climacs-table + :keystroke gesture :errorp nil)) + +(dead-circumflex-set-key '(#\A) '(com-insert-charcode 194)) +(dead-circumflex-set-key '(#\E) '(com-insert-charcode 202)) +(dead-circumflex-set-key '(#\I) '(com-insert-charcode 206)) +(dead-circumflex-set-key '(#\O) '(com-insert-charcode 212)) +(dead-circumflex-set-key '(#\U) '(com-insert-charcode 219)) +(dead-circumflex-set-key '(#\a) '(com-insert-charcode 226)) +(dead-circumflex-set-key '(#\e) '(com-insert-charcode 234)) +(dead-circumflex-set-key '(#\i) '(com-insert-charcode 238)) +(dead-circumflex-set-key '(#\o) '(com-insert-charcode 244)) +(dead-circumflex-set-key '(#\u) '(com-insert-charcode 251)) +(dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94)) From rstrandh at common-lisp.net Mon Jan 3 10:45:49 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 3 Jan 2005 11:45:49 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/translate.lisp Message-ID: <20050103104549.9C904884F7@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5301 Added Files: translate.lisp Log Message: replacement for CLX' and McCLIM's translate functions. Date: Mon Jan 3 11:45:47 2005 Author: rstrandh From rstrandh at common-lisp.net Mon Jan 3 12:21:22 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 3 Jan 2005 13:21:22 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/syntax.lisp Message-ID: <20050103122122.664F3884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10659 Modified Files: gui.lisp syntax.lisp Log Message: 2005-01-02 Lawrence Mitchell * gui.lisp ((define-application-frame climacs)): Add a without-interactor clause to the frame :layout. This is a layout without a minibuffer pane. (com-toggle-layout): Toggle layout between 'default and 'without-interactor. Note the without-interactor layout no longer allows you to enter extended commands (there's nowhere for *standard-input* to go) so I'm not sure how useful it is. (com-set-mark): Fix indentation. (com-exchange-point-and-mark): New command, exchange the positions of point and mark, bound to C-x C-x. (com-transpose-lines): New command, bound to C-x C-t. * syntax.lisp (present-contents): Fix typo in argument list. Date: Mon Jan 3 13:21:20 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.44 climacs/gui.lisp:1.45 --- climacs/gui.lisp:1.44 Mon Jan 3 11:25:43 2005 +++ climacs/gui.lisp Mon Jan 3 13:21:19 2005 @@ -77,7 +77,11 @@ (vertically (:scroll-bars nil) (scrolling (:width 900 :height 400) win) info - int))) + int)) + (without-interactor + (vertically (:scroll-bars nil) + (scrolling (:width 900 :height 400) win) + info))) (:top-level (climacs-top-level))) (defmethod redisplay-frame-panes :after ((frame climacs) &rest args) @@ -275,6 +279,29 @@ (insert-sequence point w2) (forward-word point))))) +(define-named-command com-transpose-lines () + (let ((point (point (win *application-frame*)))) + (beginning-of-line point) + (unless (beginning-of-buffer-p point) + (previous-line point)) + (let* ((bol (offset point)) + (eol (progn (end-of-line point) + (offset point))) + (line (buffer-sequence (buffer point) bol eol))) + (delete-region bol point) + ;; Remove newline at end of line as well. + (unless (end-of-buffer-p point) + (delete-range point)) + ;; 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. + (when (progn (end-of-line point) + (end-of-buffer-p point)) + (insert-object point #\Newline)) + (next-line point) + (insert-sequence point line) + (insert-object point #\Newline)))) + (define-named-command com-previous-line () (previous-line (point (win *application-frame*)))) @@ -302,7 +329,7 @@ (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) - 'with-interactor + 'without-interactor 'default))) (define-command com-extended-command () @@ -474,7 +501,12 @@ (define-named-command com-set-mark () (with-slots (point mark) (win *application-frame*) - (setf mark (clone-mark point)))) + (setf mark (clone-mark point)))) + +(define-named-command com-exchange-point-and-mark () + (with-slots (point mark) (win *application-frame*) + (psetf (offset mark) (offset point) + (offset point) (offset mark)))) (define-named-command com-set-syntax () (setf (syntax (win *application-frame*)) @@ -597,7 +629,9 @@ (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\s :control) 'com-save-buffer) +(c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) +(c-x-set-key '(#\x :control) 'com-exchange-point-and-mark) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -634,8 +668,6 @@ (dead-acute-set-key '(#\y) '(com-insert-charcode 253)) (dead-acute-set-key '(#\C) '(com-insert-charcode 199)) (dead-acute-set-key '(#\c) '(com-insert-charcode 231)) -(dead-acute-set-key '(#\B) '(com-insert-charcode 197)) ; not great -(dead-acute-set-key '(#\b) '(com-insert-charcode 229)) ; not great (dead-acute-set-key '(#\x) '(com-insert-charcode 215)) (dead-acute-set-key '(#\-) '(com-insert-charcode 247)) (dead-acute-set-key '(#\T) '(com-insert-charcode 222)) @@ -643,6 +675,18 @@ (dead-acute-set-key '(#\s) '(com-insert-charcode 223)) (dead-acute-set-key '(#\Space) '(com-insert-charcode 39)) +(make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute" + :menu 'dead-acute-dead-accute-climacs-table + :keystroke '(:dead--acute)) + +(defun dead-acute-dead-accute-set-key (gesture command) + (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table + :keystroke gesture :errorp nil)) + +(dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197)) +(dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Dead-grave command table Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.17 climacs/syntax.lisp:1.18 --- climacs/syntax.lisp:1.17 Sat Jan 1 11:49:26 2005 +++ climacs/syntax.lisp Mon Jan 3 13:21:20 2005 @@ -88,7 +88,7 @@ (define-presentation-type url () :inherit-from 'string) -(defgeneric present-contents (contenst pane syntax)) +(defgeneric present-contents (contents pane syntax)) (defmethod present-contents (contents pane (syntax basic-syntax)) (unless (null contents) From ejohnson at common-lisp.net Mon Jan 3 13:36:35 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Mon, 3 Jan 2005 14:36:35 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050103133635.9DCA1884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14784 Modified Files: gui.lisp Log Message: a very small fix. Fixnum was a bad choice here. Integer works much nicer Date: Mon Jan 3 14:36:34 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.45 climacs/gui.lisp:1.46 --- climacs/gui.lisp:1.45 Mon Jan 3 13:21:19 2005 +++ climacs/gui.lisp Mon Jan 3 14:36:34 2005 @@ -553,7 +553,7 @@ ;; Not bound to a key yet (define-named-command com-kr-resize () - (let ((size (accept 'fixnum :prompt "New kill ring size: "))) + (let ((size (accept 'integer :prompt "New kill ring size"))) (kr-resize *kill-ring* size))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From rstrandh at common-lisp.net Mon Jan 3 15:07:10 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 3 Jan 2005 16:07:10 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/syntax.lisp Message-ID: <20050103150710.5D43B884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19246 Modified Files: syntax.lisp Log Message: Redisplay is much faster. Date: Mon Jan 3 16:07:09 2005 Author: rstrandh Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.18 climacs/syntax.lisp:1.19 --- climacs/syntax.lisp:1.18 Mon Jan 3 13:21:20 2005 +++ climacs/syntax.lisp Mon Jan 3 16:07:09 2005 @@ -265,10 +265,19 @@ (with-slots (top bot scan cache cursor-x cursor-y) syntax (position-window pane syntax) (compute-cache pane syntax) - (setf scan (offset top)) - (loop for id from 0 below (nb-elements cache) - do (updating-output (pane :unique-id id) - (display-line pane syntax (element* cache id)))) + (loop with start-offset = (offset top) + for id from 0 below (nb-elements cache) + do (setf scan start-offset) + (updating-output + (pane :unique-id id + :cache-value (if (<= start-offset + (offset (point pane)) + (+ start-offset (length (element* cache id)))) + (cons nil nil) + (element* cache id)) + :cache-test #'eq) + (display-line pane syntax (element* cache id))) + (incf start-offset (1+ (length (element* cache id))))) (when (mark= scan (point pane)) (multiple-value-bind (x y) (stream-cursor-position pane) (setf cursor-x x From abakic at common-lisp.net Mon Jan 3 18:15:46 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Mon, 3 Jan 2005 19:15:46 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer.lisp Message-ID: <20050103181546.2462A884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29335 Modified Files: buffer.lisp Log Message: Very minor, cosmetic changes. Date: Mon Jan 3 19:15:41 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.13 climacs/buffer.lisp:1.14 --- climacs/buffer.lisp:1.13 Wed Dec 29 07:58:53 2004 +++ climacs/buffer.lisp Mon Jan 3 19:15:41 2005 @@ -339,7 +339,7 @@ (defmethod insert-object ((mark mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) -(defgeneric insert-sequence (mark string) +(defgeneric insert-sequence (mark sequence) (:documentation "Insert the objects in the sequence at the mark. This function simply calls insert-buffer-sequence with the buffer and the position of the mark.")) @@ -482,7 +482,7 @@ (min (offset (low-mark buffer)) offset)) (setf (offset (high-mark buffer)) (max (offset (high-mark buffer)) (+ offset n))) -(setf (slot-value buffer 'modified) t)) + (setf (slot-value buffer 'modified) t)) (defgeneric clear-modify (buffer)) From abakic at common-lisp.net Mon Jan 3 23:55:18 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Tue, 4 Jan 2005 00:55:18 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/climacs.asd Message-ID: <20050103235518.6A5FA884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14958 Modified Files: climacs.asd Log Message: asdf::input-files is not external (in my version). Date: Tue Jan 4 00:55:17 2005 Author: abakic Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.8 climacs/climacs.asd:1.9 --- climacs/climacs.asd:1.8 Mon Jan 3 11:25:42 2005 +++ climacs/climacs.asd Tue Jan 4 00:55:16 2005 @@ -63,7 +63,7 @@ (defmethod asdf:perform :around ((o asdf:compile-op) (c (eql (asdf:find-component (asdf:find-system :climacs) "skiplist-package")))) (cond - ((null (probe-file (first (asdf:input-files o c)))) + ((null (probe-file (first (asdf::input-files o c)))) (cerror "Retry loading climacs." "~@ Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21195 Modified Files: buffer.lisp Log Message: Removed a duplicate defclass. Date: Wed Jan 5 00:07:34 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.14 climacs/buffer.lisp:1.15 --- climacs/buffer.lisp:1.14 Mon Jan 3 19:15:41 2005 +++ climacs/buffer.lisp Wed Jan 5 00:07:34 2005 @@ -90,8 +90,6 @@ (defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) () (:documentation "A right-sticky-mark subclass suitable for use in a standard-buffer")) -(defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) ()) - (defmethod initialize-instance :after ((mark left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) From rstrandh at common-lisp.net Wed Jan 5 05:09:08 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 5 Jan 2005 06:09:08 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050105050908.6F760880E6@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7326 Modified Files: base.lisp gui.lisp packages.lisp Log Message: Added (non-incremental for now) search functions. Date: Wed Jan 5 06:09:04 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.9 climacs/base.lisp:1.10 --- climacs/base.lisp:1.9 Sat Jan 1 10:34:25 2005 +++ climacs/base.lisp Wed Jan 5 06:09:04 2005 @@ -144,3 +144,53 @@ (defclass name-mixin () ((name :initarg :name :accessor name))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Search + +(defun buffer-looking-at (buffer offset vector &key (test #'eql)) + "return true if and only if BUFFER contains VECTOR at OFFSET" + (and (<= (+ offset (length vector)) (size buffer)) + (loop for i from offset + for obj across vector + unless (funcall test (buffer-object buffer i) obj) + return nil + finally (return t)))) + +(defun looking-at (mark vector &key (test #'eql)) + "return true if and only if BUFFER contains VECTOR after MARK" + (buffer-looking-at (buffer mark) (offset mark) vector :test test)) + + +(defun buffer-search-forward (buffer offset vector &key (test #'eql)) + "return the smallest offset of BUFFER >= OFFSET containing VECTOR +or NIL if no such offset exists" + (loop for i from offset to (size buffer) + when (buffer-looking-at buffer i vector :test test) + return i + finally (return nil))) + + +(defun buffer-search-backward (buffer offset vector &key (test #'eql)) + "return the largest offset of BUFFER <= (- OFFSET (length VECTOR)) +containing VECTOR or NIL if no such offset exists" + (loop for i downfrom (- offset (length vector)) to 0 + when (buffer-looking-at buffer i vector :test test) + return i + finally (return nil))) + +(defun search-forward (mark vector &key (test #'eql)) + "move MARK forward after the first occurence of VECTOR after MARK" + (let ((offset (buffer-search-forward + (buffer mark) (offset mark) vector :test test))) + (when offset + (setf (offset mark) (+ offset (length vector)))))) + +(defun search-backward (mark vector &key (test #'eql)) + "move MARK backward before the first occurence of VECTOR before MARK" + (let ((offset (buffer-search-backward + (buffer mark) (offset mark) vector :test test))) + (when offset + (setf (offset mark) offset)))) + + Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.46 climacs/gui.lisp:1.47 --- climacs/gui.lisp:1.46 Mon Jan 3 14:36:34 2005 +++ climacs/gui.lisp Wed Jan 5 06:09:04 2005 @@ -129,19 +129,37 @@ (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) :test #'event-matches-gesture-name-p)) +(defun climacs-read-gesture () + (loop for gesture = (read-gesture :stream *standard-input*) + when (event-matches-gesture-name-p gesture '(#\g :control)) + do (throw 'outer-loop nil) + until (or (characterp gesture) + (and (typep gesture 'keyboard-event) + (or (keyboard-event-character gesture) + (not (member (keyboard-event-key-name + gesture) + '(:control-left :control-right + :shift-left :shift-right + :meta-left :meta-right + :super-left :super-right + :hyper-left :hyper-right + :shift-lock :caps-lock + :alt-left :alt-right)))))) + finally (return gesture))) + (defun read-numeric-argument (&key (stream *standard-input*)) - (let ((gesture (read-gesture :stream stream))) + (let ((gesture (climacs-read-gesture))) (cond ((event-matches-gesture-name-p gesture '(#\u :control)) (let ((numarg 4)) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (event-matches-gesture-name-p gesture '(#\u :control)) do (setf numarg (* 4 numarg)) finally (unread-gesture gesture :stream stream)) - (let ((gesture (read-gesture :stream stream))) + (let ((gesture (climacs-read-gesture))) (cond ((and (characterp gesture) (digit-char-p gesture 10)) (setf numarg (- (char-code gesture) (char-code #\0))) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf gesture (+ (* 10 numarg) @@ -152,7 +170,7 @@ (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) finally (unread-gesture gesture :stream stream) @@ -170,40 +188,35 @@ (*print-pretty* nil) (*abort-gestures* nil)) (redisplay-frame-panes frame :force-p t) - (loop with gestures = '() - with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) - do (setf *current-gesture* (read-gesture :stream *standard-input*)) - (when (or (characterp *current-gesture*) - (and (typep *current-gesture* 'keyboard-event) - (or (keyboard-event-character *current-gesture*) - (not (member (keyboard-event-key-name - *current-gesture*) - '(:control-left :control-right - :shift-left :shift-right - :meta-left :meta-right - :super-left :super-right - :hyper-left :hyper-right - :shift-lock :caps-lock)))))) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (setf gestures '())) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (handler-case - (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf gestures '()))) - (t nil)))) - (let ((buffer (buffer (win frame)))) - (when (modified-p buffer) - (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame)))) + (loop (catch 'outer-loop + (loop with gestures = '() + with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) + do (setf *current-gesture* (climacs-read-gesture)) + (setf gestures (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-table))) + (cond ((not item) + (beep) (setf gestures '())) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf gestures '()))) + (t nil))) + (let ((buffer (buffer (win frame)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (redisplay-frame-panes frame))) + (beep) + (let ((buffer (buffer (win frame)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (redisplay-frame-panes frame)))) (defmacro define-named-command (command-name args &body body) `(define-climacs-command ,(if (listp command-name) `(, at command-name :name t) `(,command-name :name t)) ,args , at body)) @@ -555,6 +568,18 @@ (define-named-command com-kr-resize () (let ((size (accept 'integer :prompt "New kill ring size"))) (kr-resize *kill-ring* size))) + +(define-named-command com-search-forward () + (search-forward (point (win *application-frame*)) + (accept 'string :prompt "Search Forward") + :test (lambda (a b) + (and (characterp b) (char-equal a b))))) + +(define-named-command com-search-backward () + (search-backward (point (win *application-frame*)) + (accept 'string :prompt "Search Backward") + :test (lambda (a b) + (and (characterp b) (char-equal a b))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.19 climacs/packages.lisp:1.20 --- climacs/packages.lisp:1.19 Sat Jan 1 11:43:39 2005 +++ climacs/packages.lisp Wed Jan 5 06:09:04 2005 @@ -49,7 +49,10 @@ #:forward-word #:backward-word #:delete-word #:backward-delete-word #:input-from-stream #:output-to-stream - #:name-mixin #:name)) + #:name-mixin #:name + #:buffer-lookin-at #:looking-at + #:buffer-search-forward #:buffer-search-backward + #:search-forward #:search-backward)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) From rstrandh at common-lisp.net Wed Jan 5 21:39:26 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 5 Jan 2005 22:39:26 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer.lisp Message-ID: <20050105213926.B6053884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24863 Modified Files: buffer.lisp Log Message: Fixed some code that was not great, and modified the name of a reader function of the no-such-offset condition that made a bug in CMUCL manifest itself and made it impossible to run Climacs. Date: Wed Jan 5 22:39:24 2005 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.15 climacs/buffer.lisp:1.16 --- climacs/buffer.lisp:1.15 Wed Jan 5 00:07:34 2005 +++ climacs/buffer.lisp Wed Jan 5 22:39:23 2005 @@ -76,10 +76,10 @@ (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark.")) -(defmethod offset (mark) +(defmethod offset ((mark mark-mixin)) (cursor-pos (cursor mark))) -(defmethod (setf offset) (new-offset mark) +(defmethod (setf offset) (new-offset (mark mark-mixin)) (assert (<= 0 new-offset (size (buffer mark))) () (make-condition 'no-such-offset :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) @@ -129,9 +129,9 @@ (make-instance type :buffer (buffer mark) :offset (offset mark))) (define-condition no-such-offset (simple-error) - ((offset :reader offset :initarg :offset)) + ((offset :reader condition-offset :initarg :offset)) (:report (lambda (condition stream) - (format stream "No such offset: ~a" (offset condition)))) + (format stream "No such offset: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made at an operation that is before the beginning or after the end of the buffer.")) From rstrandh at common-lisp.net Thu Jan 6 16:38:56 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 6 Jan 2005 17:38:56 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp Message-ID: <20050106163856.4D383884BC@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18516 Modified Files: base.lisp Log Message: modified previous-line and next-line to take an optional column argument. Date: Thu Jan 6 17:38:55 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.10 climacs/base.lisp:1.11 --- climacs/base.lisp:1.10 Wed Jan 5 06:09:04 2005 +++ climacs/base.lisp Thu Jan 6 17:38:54 2005 @@ -28,29 +28,31 @@ (in-package :climacs-base) -(defun previous-line (mark) +(defun previous-line (mark &optional column) "Move a mark up one line conserving horizontal position." - (let ((column (column-number mark))) - (beginning-of-line mark) - (if (beginning-of-buffer-p mark) - (incf (offset mark) column) - (progn (decf (offset mark)) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column)))))) + (unless column + (setf column (column-number mark))) + (beginning-of-line mark) + (if (beginning-of-buffer-p mark) + (incf (offset mark) column) + (progn (decf (offset mark)) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))))) -(defun next-line (mark) +(defun next-line (mark &optional column) "Move a mark down one line conserving horizontal position." - (let ((column (column-number mark))) - (end-of-line mark) - (if (end-of-buffer-p mark) - (progn (beginning-of-line mark) - (incf (offset mark) column)) - (progn (incf (offset mark)) - (end-of-line mark) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column)))))) + (unless column + (setf column (column-number mark))) + (end-of-line mark) + (if (end-of-buffer-p mark) + (progn (beginning-of-line mark) + (incf (offset mark) column)) + (progn (incf (offset mark)) + (end-of-line mark) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))))) (defun open-line (mark) "Create a new line in a buffer." From rstrandh at common-lisp.net Thu Jan 6 16:41:13 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 6 Jan 2005 17:41:13 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050106164113.8322E884BC@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18560 Modified Files: gui.lisp Log Message: Improved next- and previous-line commands so that a sequence of such commands tries to preserve the original column. Date: Thu Jan 6 17:41:11 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.47 climacs/gui.lisp:1.48 --- climacs/gui.lisp:1.47 Wed Jan 5 06:09:04 2005 +++ climacs/gui.lisp Thu Jan 6 17:41:11 2005 @@ -178,6 +178,8 @@ (t (unread-gesture gesture :stream stream) (values 1 nil))))) +(defvar *previous-command*) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -206,7 +208,10 @@ (error (condition) (beep) (format *error-output* "~a~%" condition))) - (setf gestures '()))) + (setf gestures '()) + (setf *previous-command* (if (consp command) + (car command) + command)))) (t nil))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer) @@ -315,11 +320,21 @@ (insert-sequence point line) (insert-object point #\Newline)))) +(defvar *goal-column*) + (define-named-command com-previous-line () - (previous-line (point (win *application-frame*)))) + (let ((point (point (win *application-frame*)))) + (unless (or (eq *previous-command* 'com-previous-line) + (eq *previous-command* 'com-next-line)) + (setf *goal-column* (column-number point))) + (previous-line point *goal-column*))) (define-named-command com-next-line () - (next-line (point (win *application-frame*)))) + (let ((point (point (win *application-frame*)))) + (unless (or (eq *previous-command* 'com-previous-line) + (eq *previous-command* 'com-next-line)) + (setf *goal-column* (column-number point))) + (next-line point *goal-column*))) (define-named-command com-open-line () (open-line (point (win *application-frame*)))) From ejohnson at common-lisp.net Thu Jan 6 17:56:44 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Thu, 6 Jan 2005 18:56:44 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi Message-ID: <20050106175644.7400B884B9@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv22737/Doc Modified Files: climacs-internals.texi Log Message: protocol update for kill ring Date: Thu Jan 6 18:56:43 2005 Author: ejohnson Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.5 climacs/Doc/climacs-internals.texi:1.6 --- climacs/Doc/climacs-internals.texi:1.5 Wed Dec 29 07:58:55 2004 +++ climacs/Doc/climacs-internals.texi Thu Jan 6 18:56:42 2005 @@ -1649,6 +1649,85 @@ @deftp {initarg} :records @end deftp + at chapter Kill Ring Protocol + + at section Overview + +During the process of text editing it may become necessary for regions of text +to be manipulated non-sequentially. The kill ring and its surrounding protocol +offers both a temporary location for data to be stored, as well as methods for +stored data to be accessed. + +Conceptually, the kill ring is a stack of bounded depth, so that when elements +are pushed beyond that depth, the oldest element is removed. All newly added +data is attached to a single point at the ``start of ring position'' or SORP. + +This protocol provides two methods which govern how data is to be attached to the +SORP. The first method moves the current SORP to a new position, on to which a new +object is attached. The second conserves the current position and replaces its +contents with a sequence constructed of new and pre-existing SORP objects. This +latter method is refered to as a ``concatenating push''. + +For data retrievial the kill ring class provides a ``yank point'' which +allows focus to be shifted from the SORP to other positions within the kill ring. +The yank point is limited to two types of motition, one being a rotation away from the SORP +and the other being an immediate return or ``reset'' to the start position. + + at section General + + at deftp {class} kill-ring +A class for all kill rings. + at end deftp + + at deftp {init-arg} :max-size +A limitation placed upon the number of elements held by a kill ring. Once the maximum size +has been reached, older entries must first be removed before new ones can be added. + at end deftp + + at deffn {generic function} kill-ring-max-size kill-ring +Returns the value of a kill ring's maximum size. + at end deffn + + at deffn {generic function} {(setf kill-ring-max-size)} kill-ring size +Alters the maximum size of a kill ring even if it means dropping +elements to do so. + at end deffn + + at deffn {generic function} kill-ring-length kill-ring +Returns the current length of a kill-ring. Note this is different than +kill-ring-max-size. + at end deffn + + at deffn {generic function} kill-ring-standard-push kill-ring vector +Pushes a vector of objects onto a given kill ring creating a new start of ring +position. This function is much like an everyday lisp push with size considerations. +If the length of the kill ring is greater than its maximum size, ``older'' elements +will be removed from the ring until the maximum size is reached. + at end deffn + + at deffn {generic function} kill-ring-concatenating-push kill-ring vector +Concatenates the contents of vector onto the end of the contents of +the current top of the kill-ring. If the kill-ring is empty, a new +entry is pushed.. + at end deffn + + at deffn {generic function} rotate-yank-position kill-ring &optional times +Moves the yank point associated with a kill-ring one or times many positions +away from the start of ring position. If times is greater than the current length +then the cursor will wrap to the start of ring position and continue rotating. + at end deffn + + at deffn {generic function} reset-yank-position kill-ring +Moves the current position of the yank point associated with a kill ring back to +the start of ring position. + at end deffn + + at deffn {generic function} kill-ring-yank kill-ring &optional reset +Returns the vector of objects currently pointed to by the cursor. If reset is T, then a +call to reset-yank-position is called before the object is yanked. The default for reset +is NIL. + at end deffn + @node Index @unnumbered Index From rstrandh at common-lisp.net Fri Jan 7 07:26:27 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 7 Jan 2005 08:26:27 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050107072627.3AB07884B9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31712 Modified Files: base.lisp gui.lisp packages.lisp Log Message: replaced *previous-command* and *goal-column* by slots in the pane according to a suggestion by Rudi Schlatte. implemented dynamic abbrev expansion according to a suggestion by Luigi Panzeri. Date: Fri Jan 7 08:26:25 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.11 climacs/base.lisp:1.12 --- climacs/base.lisp:1.11 Thu Jan 6 17:38:54 2005 +++ climacs/base.lisp Fri Jan 7 08:26:23 2005 @@ -137,6 +137,15 @@ while (constituentp (object-before mark)) do (delete-range mark -1))) +(defun previous-word (mark) + "Return a freshly allocated sequence, that is word before the mark" + (region-to-sequence + (loop for i downfrom (offset mark) + while (and (plusp i) + (constituentp (buffer-object (buffer mark) (1- i)))) + finally (return i)) + mark)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Named objects @@ -195,4 +204,20 @@ (when offset (setf (offset mark) offset)))) +(defun buffer-search-word-backward (buffer offset word &key (test #'eql)) + "return the largest offset of BUFFER <= (- OFFSET (length WORD)) +containing WORD as a word or NIL if no such offset exists" + (loop for i downfrom (- offset (length word)) to 0 + when (and (or (zerop i) (whitespacep (buffer-object buffer (1- i)))) + (buffer-looking-at buffer i word :test test)) + return i + finally (return nil))) +(defun buffer-search-word-forward (buffer offset word &key (test #'eql)) + "Return the smallest offset of BUFFER >= (+ OFFSET (length WORD)) +containing WORD as a word or NIL if no such offset exists" + (loop for i upfrom (+ offset (length word)) to (- (size buffer) (max (length word) 1)) + when (and (whitespacep (buffer-object buffer (1- i))) + (buffer-looking-at buffer i word :test test)) + return i + finally (return nil))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.48 climacs/gui.lisp:1.49 --- climacs/gui.lisp:1.48 Thu Jan 6 17:41:11 2005 +++ climacs/gui.lisp Fri Jan 7 08:26:24 2005 @@ -36,7 +36,15 @@ ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) (point :initform nil :initarg :point :reader point) (syntax :initarg :syntax :accessor syntax) - (mark :initform nil :initarg :mark :reader mark))) + (mark :initform nil :initarg :mark :reader mark) + ;; allows a certain number of commands to have some minimal memory + (previous-command :initform nil :accessor previous-command) + ;; for next-line and previous-line commands + (goal-column :initform nil) + ;; for dynamic abbrev expansion + (original-prefix :initform nil) + (prefix-start-offset :initform nil) + (dabbrev-expansion-mark :initform nil))) (defmethod initialize-instance :after ((pane climacs-pane) &rest args) (declare (ignore args)) @@ -178,8 +186,6 @@ (t (unread-gesture gesture :stream stream) (values 1 nil))))) -(defvar *previous-command*) - (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -209,9 +215,10 @@ (beep) (format *error-output* "~a~%" condition))) (setf gestures '()) - (setf *previous-command* (if (consp command) - (car command) - command)))) + (setf (previous-command *standard-output*) + (if (consp command) + (car command) + command)))) (t nil))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer) @@ -320,21 +327,21 @@ (insert-sequence point line) (insert-object point #\Newline)))) -(defvar *goal-column*) - (define-named-command com-previous-line () - (let ((point (point (win *application-frame*)))) - (unless (or (eq *previous-command* 'com-previous-line) - (eq *previous-command* 'com-next-line)) - (setf *goal-column* (column-number point))) - (previous-line point *goal-column*))) + (let* ((win (win *application-frame*)) + (point (point win))) + (unless (or (eq (previous-command win) 'com-previous-line) + (eq (previous-command win) 'com-next-line)) + (setf (slot-value win 'goal-column) (column-number point))) + (previous-line point (slot-value win 'goal-column)))) (define-named-command com-next-line () - (let ((point (point (win *application-frame*)))) - (unless (or (eq *previous-command* 'com-previous-line) - (eq *previous-command* 'com-next-line)) - (setf *goal-column* (column-number point))) - (next-line point *goal-column*))) + (let* ((win (win *application-frame*)) + (point (point win))) + (unless (or (eq (previous-command win) 'com-previous-line) + (eq (previous-command win) 'com-next-line)) + (setf (slot-value win 'goal-column) (column-number point))) + (next-line point (slot-value win 'goal-column)))) (define-named-command com-open-line () (open-line (point (win *application-frame*)))) @@ -596,6 +603,43 @@ :test (lambda (a b) (and (characterp b) (char-equal a b))))) +(define-named-command com-dabbrev-expand () + (let* ((win (win *application-frame*)) + (point (point win))) + (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win + (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 win) '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)))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Global command table @@ -638,6 +682,7 @@ (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) +(global-set-key '(#\/ :meta) 'com-dabbrev-expand) (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.20 climacs/packages.lisp:1.21 --- climacs/packages.lisp:1.20 Wed Jan 5 06:09:04 2005 +++ climacs/packages.lisp Fri Jan 7 08:26:24 2005 @@ -52,7 +52,8 @@ #:name-mixin #:name #:buffer-lookin-at #:looking-at #:buffer-search-forward #:buffer-search-backward - #:search-forward #:search-backward)) + #:search-forward #:search-backward + #:buffer-search-word-backward #:buffer-search-word-forward)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) From ejohnson at common-lisp.net Fri Jan 7 13:07:50 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Fri, 7 Jan 2005 14:07:50 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/kill-ring.lisp climacs/packages.lisp Message-ID: <20050107130750.5A84F884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16638 Modified Files: gui.lisp kill-ring.lisp packages.lisp Log Message: kill ring updated and functioning protocol. Enjoy C-k and M-y like you never have in climacs before:) Date: Fri Jan 7 14:07:46 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.49 climacs/gui.lisp:1.50 --- climacs/gui.lisp:1.49 Fri Jan 7 08:26:24 2005 +++ climacs/gui.lisp Fri Jan 7 14:07:45 2005 @@ -128,7 +128,7 @@ (setf table (command-menu-item-value item))) finally (return item))) -(defvar *kill-ring* (initialize-kill-ring 7)) +(defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) (defparameter *current-gesture* nil) (defun meta-digit (gesture) @@ -347,7 +347,22 @@ (open-line (point (win *application-frame*)))) (define-named-command com-kill-line () - (kill-line (point (win *application-frame*)))) + (let* ((payne (win *application-frame*)) + (pnt (point payne))) + (if (and (beginning-of-buffer-p pnt) + (end-of-line-p pnt)) + NIL + (let ((mrk (offset pnt))) + (end-of-line pnt) + (if (end-of-buffer-p pnt) + nil + (forward-object pnt)) + (if (eq (previous-command payne) 'com-kill-line) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence mrk pnt)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence mrk pnt))) + (delete-region mrk pnt))))) (define-named-command com-forward-word () (forward-word (point (win *application-frame*)))) @@ -552,25 +567,23 @@ ;; Kill ring commands ;; Copies an element from a kill-ring to a buffer at the given offset -(define-named-command com-copy-in () - (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*))) - -;; Cuts an element from a kill-ring out to a buffer at a given offset -(define-named-command com-cut-in () - (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*))) +(define-named-command com-yank () + (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*))) ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () (with-slots (buffer point mark)(win *application-frame*) - (if (< (offset point) (offset mark)) - ((lambda (b o1 o2) - (kr-push *kill-ring* (buffer-sequence b o1 o2)) - (delete-buffer-range b o1 (- o2 o1))) - buffer (offset point) (offset mark)) - ((lambda (b o1 o2) - (kr-push *kill-ring* (buffer-sequence b o2 o1)) - (delete-buffer-range b o1 (- o2 o1))) - buffer (offset mark) (offset point))))) + (let ((offp (offset point)) + (offm (offset mark))) + (if (< offp offm) + ((lambda (b o1 o2) + (kill-ring-standard-push *kill-ring* (buffer-sequence b o1 o2)) + (delete-buffer-range b o1 (- o2 o1))) + buffer offp offm) + ((lambda (b o1 o2) + (kill-ring-standard-push *kill-ring* (buffer-sequence b o2 o1)) + (delete-buffer-range b o1 (- o2 o1))) + buffer offm offp))))) ;; Non destructively copies in buffer region to the kill ring @@ -579,17 +592,25 @@ (let ((off1 (offset point)) (off2 (offset mark))) (if (< off1 off2) - (kr-push *kill-ring* (buffer-sequence buffer off1 off2)) - (kr-push *kill-ring* (buffer-sequence buffer off2 off1)))))) + (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off1 off2)) + (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off2 off1)))))) + -;; Needs adjustment to be like emacs M-y -(define-named-command com-kr-rotate () - (kr-rotate *kill-ring* -1)) +(define-named-command com-rotate-yank () + (let* ((payne (win *application-frame*)) + (pnt (point payne)) + (last-yank (kill-ring-yank *kill-ring*))) + (if (eq (previous-command payne) + 'com-rotate-yank) + ((lambda (p ly) + (delete-range p (* -1 (length ly))) + (rotate-yank-position *kill-ring*)) + pnt last-yank)) + (insert-sequence pnt (kill-ring-yank *kill-ring*)))) -;; Not bound to a key yet -(define-named-command com-kr-resize () +(define-named-command com-resize-kill-ring () (let ((size (accept 'integer :prompt "New kill ring size"))) - (kr-resize *kill-ring* size))) + (setf (kill-ring-max-size *kill-ring*) size))) (define-named-command com-search-forward () (search-forward (point (win *application-frame*)) @@ -666,13 +687,13 @@ (global-set-key '(#\k :control) 'com-kill-line) (global-set-key '(#\t :control) 'com-transpose-objects) (global-set-key '(#\Space :control) 'com-set-mark) -(global-set-key '(#\y :control) 'com-copy-in) +(global-set-key '(#\y :control) 'com-yank) (global-set-key '(#\w :control) 'com-cut-out) (global-set-key '(#\f :meta) 'com-forward-word) (global-set-key '(#\b :meta) 'com-backward-word) (global-set-key '(#\t :meta) 'com-transpose-words) (global-set-key '(#\x :meta) 'com-extended-command) -(global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only +(global-set-key '(#\y :meta) 'com-rotate-yank) (global-set-key '(#\w :meta) 'com-copy-out) (global-set-key '(#\v :control) 'com-page-down) (global-set-key '(#\v :meta) 'com-page-up) Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.3 climacs/kill-ring.lisp:1.4 --- climacs/kill-ring.lisp:1.3 Thu Dec 30 04:55:14 2004 +++ climacs/kill-ring.lisp Fri Jan 7 14:07:45 2005 @@ -25,70 +25,112 @@ (in-package :climacs-kill-ring) (defclass kill-ring () - ((max-size :type unsigned-byte - :initarg :max-size - :accessor kr-max-size) - (flexichain :type standard-flexichain - :initarg :flexichain - :accessor kr-flexi)) - (:documentation "Basic flexichain without resizing")) - -(defun initialize-kill-ring (size) - "Construct a kill ring of a given size" - (make-instance 'kill-ring - :max-size size - :flexichain (make-instance 'standard-flexichain))) - - -(defgeneric kr-length (kr) - (:documentation "Returns the length of a kill-ring's flexichain")) - -(defmethod kr-length ((kr kill-ring)) - (nb-elements (kr-flexi kr))) - -(defgeneric kr-resize (kr size) - (:documentation "Resize a kill ring to the value of SIZE")) - -(defmethod kr-resize ((kr kill-ring) size) - (setf (slot-value kr 'max-size) size) - (let ((len (kr-length kr))) + ((max-size :type (integer 5 *) ;5 element minimum from flexichain protocol + :initarg :max-size) + (cursorchain :type standard-cursorchain + :accessor kill-ring-chain + :initform (make-instance 'standard-cursorchain)) + (yankpoint :type left-sticky-flexicursor + :accessor kill-ring-cursor)) + (:documentation "A class for all kill rings")) + +(defmethod initialize-instance :after((kr kill-ring) &rest args) + "Adds in the yankpoint" + (declare (ignore args)) + (with-slots (cursorchain yankpoint) kr + (setf yankpoint (make-instance 'left-sticky-flexicursor :chain cursorchain)))) + +(defgeneric kill-ring-length (kr) + (:documentation "Returns the current length of the kill ring")) + +(defgeneric kill-ring-max-size (kr) + (:documentation "Returns the value of a kill ring's maximum size")) + +(defgeneric (setf kill-ring-max-size) (kr size) + (:documentation "Alters the maximum size of a kill ring, even +if it means dropping elements to do so.")) + +(defgeneric reset-yank-position (kr) + (:documentation "Moves the current yank point back to the start of + of kill ring position")) + +(defgeneric rotate-yank-position (kr &optional times) + (:documentation "Moves the yank point associated with a kill-ring + one or times many positions away from the start + of ring position. If times is greater than the + current length then the cursor will wrap to the + start of ring position and continue rotating.")) + +(defgeneric kill-ring-standard-push (kr vector) + (:documentation "Pushes a vector of objects onto the kill ring creating a new +start of ring position. This function is much like an every- +day lisp push with size considerations. If the length of the +kill ring is greater than the maximum size, then \"older\" +elements will be removed from the ring until the maximum size +is reached.")) + +(defgeneric kill-ring-concatenating-push (kr vector) + (:documentation "Concatenates the contents of vector onto the end + of the current contents of the top of the kill ring. + If the kill ring is empty the a new entry is pushed.")) + +(defgeneric kill-ring-yank (kr &optional reset) + (:documentation "Returns the vector of objects currently pointed to + by the cursor. If reset is T, a call to + reset-yank-position is called befor the object is + yanked. The default for reset is NIL")) + +(defmethod kill-ring-length ((kr kill-ring)) + (nb-elements (kill-ring-chain kr))) + +(defmethod kill-ring-max-size ((kr kill-ring)) + (with-slots (max-size) kr + max-size)) + +(defmethod (setf kill-ring-max-size) ((kr kill-ring) size) + (unless (typep size 'integer) + (error "Error, ~S, is not an integer value" size)) + (if (< size 5) + (set (slot-value kr 'max-size) 5) + (setf (slot-value kr 'max-size) size)) + (let ((len (kill-ring-length kr))) (if (> len size) (loop for n from 1 to (- len size) - do (pop-end (kr-flexi kr)))))) + do (pop-end (kill-ring-chain kr)))))) -(defgeneric kr-push (kr object) - (:documentation "Push an object onto a kill ring with size considerations")) - -(defmethod kr-push ((kr kill-ring) object) - (let ((flexi (kr-flexi kr))) - (if (>= (kr-length kr)(kr-max-size kr)) +(defmethod reset-yank-position ((kr kill-ring)) + (setf (cursor-pos (kill-ring-cursor kr)) 0) + t) + +(defmethod rotate-yank-position ((kr kill-ring) &optional (times 1)) + (if (> (kill-ring-length kr) 0) + (let* ((curs (kill-ring-cursor kr)) + (pos (mod (+ times (cursor-pos curs)) + (kill-ring-length kr)))) + (setf (cursor-pos curs) pos)))) + +(defmethod kill-ring-standard-push ((kr kill-ring) vector) + (let ((chain (kill-ring-chain kr))) + (if (>= (kill-ring-length kr) + (kill-ring-max-size kr)) ((lambda (flex obj) (pop-end flex) (push-start flex obj)) - flexi object) - (push-start flexi object)))) - -(defgeneric kr-pop (kr) - (:documentation "Pops an object off of a kill ring")) - -(defmethod kr-pop ((kr kill-ring)) - (if (> (nb-elements (kr-flexi kr)) 0) - (pop-start (kr-flexi kr)) - nil)) - -(defgeneric kr-rotate (kr &optional n) - (:documentation "Rotates the kill ring either once forward or an optional amound +/-")) - -(defmethod kr-rotate ((kr kill-ring) &optional (n -1)) - (assert (typep n 'fixnum)(n) "Can not rotate the kill ring ~S positions" n) - (let ((flexi (kr-flexi kr))) - (rotate flexi n))) - -(defgeneric kr-copy (kr) - (:documentation "Copies out a member of a kill ring without deleting it")) - -(defmethod kr-copy ((kr kill-ring)) - (let ((object (kr-pop kr))) - (kr-push kr object) - object)) + chain vector) + (push-start chain vector))) + (reset-yank-position kr)) + +(defmethod kill-ring-concatenating-push ((kr kill-ring) vector) + (let ((chain (kill-ring-chain kr))) + (if (zerop (kill-ring-length kr)) + (push-start chain vector) + (push-start chain + (concatenate 'vector + (pop-start chain) + vector)))) + (reset-yank-position kr)) + +(defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL)) + (if reset (reset-yank-position kr)) + (element> (kill-ring-cursor kr))) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.21 climacs/packages.lisp:1.22 --- climacs/packages.lisp:1.21 Fri Jan 7 08:26:24 2005 +++ climacs/packages.lisp Fri Jan 7 14:07:45 2005 @@ -52,8 +52,7 @@ #:name-mixin #:name #:buffer-lookin-at #:looking-at #:buffer-search-forward #:buffer-search-backward - #:search-forward #:search-backward - #:buffer-search-word-backward #:buffer-search-word-forward)) + #:search-forward #:search-backward)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) @@ -68,10 +67,10 @@ #:url)) (defpackage :climacs-kill-ring - (:use :clim-lisp :climacs-buffer :flexichain) - (:export #:initialize-kill-ring #:kr-length - #:kr-resize #:kr-rotate #:kill-ring - #:kr-copy #:kr-push #:kr-pop)) + (:use :clim-lisp :flexichain) + (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size + #:reset-yank-position #:rotate-yank-position #:kill-ring-yank + #:kill-ring-standard-push #:kill-ring-concatenating-push)) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-kill-ring)) From ejohnson at common-lisp.net Fri Jan 7 14:29:14 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Fri, 7 Jan 2005 15:29:14 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050107142914.CD164884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20385 Modified Files: gui.lisp Log Message: fixed up a flaw in C-k, thanks antifuchsls Date: Fri Jan 7 15:29:10 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.50 climacs/gui.lisp:1.51 --- climacs/gui.lisp:1.50 Fri Jan 7 14:07:45 2005 +++ climacs/gui.lisp Fri Jan 7 15:29:05 2005 @@ -348,21 +348,18 @@ (define-named-command com-kill-line () (let* ((payne (win *application-frame*)) - (pnt (point payne))) - (if (and (beginning-of-buffer-p pnt) - (end-of-line-p pnt)) - NIL - (let ((mrk (offset pnt))) - (end-of-line pnt) - (if (end-of-buffer-p pnt) - nil - (forward-object pnt)) - (if (eq (previous-command payne) 'com-kill-line) - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence mrk pnt)) - (kill-ring-standard-push *kill-ring* - (region-to-sequence mrk pnt))) - (delete-region mrk pnt))))) + (pnt (point payne)) + (mrk (offset pnt))) + (end-of-line pnt) + (cond ((or (beginning-of-buffer-p pnt) + (end-of-buffer-p pnt)) nil) + ((beginning-of-line-p pnt)(forward-object pnt))) + (if (eq (previous-command payne) 'com-kill-line) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence mrk pnt)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence mrk pnt))) + (delete-region mrk pnt))) (define-named-command com-forward-word () (forward-word (point (win *application-frame*)))) From ejohnson at common-lisp.net Fri Jan 7 14:59:16 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Fri, 7 Jan 2005 15:59:16 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050107145916.7FA9A884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21935 Modified Files: gui.lisp Log Message: Now C-k dosn't kill newlines be default and does kill newlines if kills are performed at the end of line. Good stuff :) Date: Fri Jan 7 15:59:15 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.51 climacs/gui.lisp:1.52 --- climacs/gui.lisp:1.51 Fri Jan 7 15:29:05 2005 +++ climacs/gui.lisp Fri Jan 7 15:59:15 2005 @@ -353,7 +353,8 @@ (end-of-line pnt) (cond ((or (beginning-of-buffer-p pnt) (end-of-buffer-p pnt)) nil) - ((beginning-of-line-p pnt)(forward-object pnt))) + ((and (beginning-of-line-p pnt) + (end-of-line-p pnt))(forward-object pnt))) (if (eq (previous-command payne) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* (region-to-sequence mrk pnt)) From ejohnson at common-lisp.net Fri Jan 7 15:01:29 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Fri, 7 Jan 2005 16:01:29 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050107150129.CFBFE884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv22222 Modified Files: gui.lisp Log Message: Lets try this again Date: Fri Jan 7 16:01:23 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.52 climacs/gui.lisp:1.53 --- climacs/gui.lisp:1.52 Fri Jan 7 15:59:15 2005 +++ climacs/gui.lisp Fri Jan 7 16:01:20 2005 @@ -350,11 +350,13 @@ (let* ((payne (win *application-frame*)) (pnt (point payne)) (mrk (offset pnt))) - (end-of-line pnt) - (cond ((or (beginning-of-buffer-p pnt) - (end-of-buffer-p pnt)) nil) - ((and (beginning-of-line-p pnt) - (end-of-line-p pnt))(forward-object pnt))) + (if (end-of-line-p pnt) + (forward-object pnt) + (progn + (end-of-line pnt) + (cond ((or (beginning-of-buffer-p pnt) + (end-of-buffer-p pnt)) nil) + ((beginning-of-line-p pnt)(forward-object pnt))))) (if (eq (previous-command payne) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* (region-to-sequence mrk pnt)) From ejohnson at common-lisp.net Fri Jan 7 18:58:10 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Fri, 7 Jan 2005 19:58:10 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/kill-ring.lisp Message-ID: <20050107185810.005EE884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1713 Modified Files: gui.lisp kill-ring.lisp Log Message: Kill Ring clean up. Fixed com-cut-out bug and substituted my habitual use of lambdas for progn's Date: Fri Jan 7 19:58:08 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.53 climacs/gui.lisp:1.54 --- climacs/gui.lisp:1.53 Fri Jan 7 16:01:20 2005 +++ climacs/gui.lisp Fri Jan 7 19:58:08 2005 @@ -347,22 +347,22 @@ (open-line (point (win *application-frame*)))) (define-named-command com-kill-line () - (let* ((payne (win *application-frame*)) - (pnt (point payne)) - (mrk (offset pnt))) - (if (end-of-line-p pnt) - (forward-object pnt) + (let* ((pane (win *application-frame*)) + (point (point pane)) + (mark (offset point))) + (if (end-of-line-p point) + (forward-object point) (progn - (end-of-line pnt) - (cond ((or (beginning-of-buffer-p pnt) - (end-of-buffer-p pnt)) nil) - ((beginning-of-line-p pnt)(forward-object pnt))))) - (if (eq (previous-command payne) 'com-kill-line) + (end-of-line point) + (cond ((or (beginning-of-buffer-p point) + (end-of-buffer-p point)) nil) + ((beginning-of-line-p point)(forward-object point))))) + (if (eq (previous-command pane) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* - (region-to-sequence mrk pnt)) + (region-to-sequence mark point)) (kill-ring-standard-push *kill-ring* - (region-to-sequence mrk pnt))) - (delete-region mrk pnt))) + (region-to-sequence mark point))) + (delete-region mark point))) (define-named-command com-forward-word () (forward-word (point (win *application-frame*)))) @@ -573,40 +573,35 @@ ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () (with-slots (buffer point mark)(win *application-frame*) - (let ((offp (offset point)) - (offm (offset mark))) - (if (< offp offm) - ((lambda (b o1 o2) - (kill-ring-standard-push *kill-ring* (buffer-sequence b o1 o2)) - (delete-buffer-range b o1 (- o2 o1))) - buffer offp offm) - ((lambda (b o1 o2) - (kill-ring-standard-push *kill-ring* (buffer-sequence b o2 o1)) - (delete-buffer-range b o1 (- o2 o1))) - buffer offm offp))))) + (let ((offset-point (offset point)) + (offset-mark (offset mark))) + (if (< offset-point offset-mark) + (progn + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (delete-buffer-range buffer offset-point (- offset-mark offset-point ))) + (progn + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) + (delete-buffer-range buffer offset-mark (- offset-point offset-mark))))))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () - (with-slots (buffer point mark)(win *application-frame*) - (let ((off1 (offset point)) - (off2 (offset mark))) - (if (< off1 off2) - (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off1 off2)) - (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off2 off1)))))) + (with-slots (point mark)(win *application-frame*) + (if (< (offset point) (offset mark)) + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))))) (define-named-command com-rotate-yank () - (let* ((payne (win *application-frame*)) - (pnt (point payne)) + (let* ((pane (win *application-frame*)) + (point (point pane)) (last-yank (kill-ring-yank *kill-ring*))) - (if (eq (previous-command payne) + (if (eq (previous-command pane) 'com-rotate-yank) - ((lambda (p ly) - (delete-range p (* -1 (length ly))) - (rotate-yank-position *kill-ring*)) - pnt last-yank)) - (insert-sequence pnt (kill-ring-yank *kill-ring*)))) + (progn + (delete-range point (* -1 (length last-yank))) + (rotate-yank-position *kill-ring*))) + (insert-sequence point (kill-ring-yank *kill-ring*)))) (define-named-command com-resize-kill-ring () (let ((size (accept 'integer :prompt "New kill ring size"))) Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.4 climacs/kill-ring.lisp:1.5 --- climacs/kill-ring.lisp:1.4 Fri Jan 7 14:07:45 2005 +++ climacs/kill-ring.lisp Fri Jan 7 19:58:08 2005 @@ -113,10 +113,9 @@ (let ((chain (kill-ring-chain kr))) (if (>= (kill-ring-length kr) (kill-ring-max-size kr)) - ((lambda (flex obj) - (pop-end flex) - (push-start flex obj)) - chain vector) + (progn + (pop-end chain) + (push-start chain vector)) (push-start chain vector))) (reset-yank-position kr)) @@ -132,5 +131,4 @@ (defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL)) (if reset (reset-yank-position kr)) - (element> (kill-ring-cursor kr))) - + (element> (kill-ring-cursor kr))) \ No newline at end of file From ejohnson at common-lisp.net Sat Jan 8 06:04:23 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Sat, 8 Jan 2005 07:04:23 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi Message-ID: <20050108060423.9F9E1884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv3803 Modified Files: climacs-internals.texi Log Message: added implementation details of the kill ring protocol Date: Sat Jan 8 07:04:22 2005 Author: ejohnson Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.6 climacs/Doc/climacs-internals.texi:1.7 --- climacs/Doc/climacs-internals.texi:1.6 Thu Jan 6 18:56:42 2005 +++ climacs/Doc/climacs-internals.texi Sat Jan 8 07:04:21 2005 @@ -665,7 +665,7 @@ @end multitable @multitable @columnfractions .3 .3 .3 - at headitem Expression @tab Syntax @tab handle/read + at item Expression @tab Syntax @tab handle/read @item quoted-expression @tab 'expr @tab handle @item comment @tab ; chars @tab handle @item string @tab " chars " @tab read @@ -1502,11 +1502,9 @@ Undo might be presented in a CLIM gadget in the form of a tree where branches are added to the right over time, in @xref{figundo}. - at float + @image{undo} @anchor{figundo} - at caption{Suggested CLIM pane for `undo'} - at end float where the bigger black circle indicates the current state. The tree will be fairly tall and skinny, so the gadget should probably be a @@ -1726,6 +1724,29 @@ Returns the vector of objects currently pointed to by the cursor. If reset is T, then a call to reset-yank-position is called before the object is yanked. The default for reset is NIL. + at end deffn + + at section Implementation + +The kill ring structure is built mainly of two parts: the stack like ring portion, which is +a cursorchain, and the yank point, which is a left-sticky-flexicursor. +To initialize a kill ring, the :max-size slot initarg is simply used to set the max +size. The remaining slots constisting of the cursorchain and the left-sticky-flexicursor +are instantized upon creation of the kill ring. + +Stored onto the cursorchain are simple-vectors of objects, mainly characters from a +climacs buffer. In order to facilitate this, the kill ring implementation borrows heavily from +the flexichain library of functions. The following functions lie outside the kill ring and +flexichain protocols, but are pertinent to the kill ring implementation. + + at deffn {accessor} kill-ring-chain kill-ring +A slot accessor provided by the Climacs implemention of the kill ring class, which returns the +cursorchain associated with kill-ring. + at end deffn + + at deffn {accessor} kill-ring-cursor kill-ring +A slot accessor provided by the Climacs implemention of the kill ring class, which returns the +flexicursor assocated with kill-ring. @end deffn @node Index From ejohnson at common-lisp.net Sat Jan 8 06:30:29 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Sat, 8 Jan 2005 07:30:29 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050108063029.C198D884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4907 Modified Files: gui.lisp Log Message: Minor clean ups on com-cut-out and com-copy-out. Basically leftover bits of code that could be factored out. Date: Sat Jan 8 07:30:28 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.54 climacs/gui.lisp:1.55 --- climacs/gui.lisp:1.54 Fri Jan 7 19:58:08 2005 +++ climacs/gui.lisp Sat Jan 8 07:30:25 2005 @@ -572,24 +572,18 @@ ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () - (with-slots (buffer point mark)(win *application-frame*) - (let ((offset-point (offset point)) - (offset-mark (offset mark))) - (if (< offset-point offset-mark) - (progn - (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) - (delete-buffer-range buffer offset-point (- offset-mark offset-point ))) - (progn - (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) - (delete-buffer-range buffer offset-mark (- offset-point offset-mark))))))) - + (with-slots (point mark)(win *application-frame*) + (cond ((< (offset mark)(offset point)) + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) + (delete-region (offset mark) point)) + (t + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (delete-region (offset point) mark))))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () (with-slots (point mark)(win *application-frame*) - (if (< (offset point) (offset mark)) - (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) - (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))))) + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)))) (define-named-command com-rotate-yank () From ejohnson at common-lisp.net Sat Jan 8 07:46:34 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Sat, 8 Jan 2005 08:46:34 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050108074634.A0B37884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8946 Modified Files: gui.lisp Log Message: Fixed the beeping from C-k at end-of-buffer, thanks Robert Date: Sat Jan 8 08:46:33 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.55 climacs/gui.lisp:1.56 --- climacs/gui.lisp:1.55 Sat Jan 8 07:30:25 2005 +++ climacs/gui.lisp Sat Jan 8 08:46:33 2005 @@ -350,13 +350,12 @@ (let* ((pane (win *application-frame*)) (point (point pane)) (mark (offset point))) - (if (end-of-line-p point) - (forward-object point) - (progn - (end-of-line point) - (cond ((or (beginning-of-buffer-p point) - (end-of-buffer-p point)) nil) - ((beginning-of-line-p point)(forward-object point))))) + (cond ((end-of-buffer-p point) nil) + ((end-of-line-p point)(forward-object point)) + (t + (end-of-line point) + (cond ((beginning-of-buffer-p point) nil) + ((beginning-of-line-p point)(forward-object point))))) (if (eq (previous-command pane) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* (region-to-sequence mark point)) From abridgewater at common-lisp.net Sat Jan 8 17:16:28 2005 From: abridgewater at common-lisp.net (Alastair Bridgewater) Date: Sat, 8 Jan 2005 18:16:28 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050108171628.AE657884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5135 Modified Files: gui.lisp Log Message: Made PgUp and PgDn (:PRIOR and :NEXT) keys work. Date: Sat Jan 8 18:16:22 2005 Author: abridgewater Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.56 climacs/gui.lisp:1.57 --- climacs/gui.lisp:1.56 Sat Jan 8 08:46:33 2005 +++ climacs/gui.lisp Sat Jan 8 18:16:19 2005 @@ -701,6 +701,8 @@ (global-set-key '(:right :control) 'com-forward-word) (global-set-key '(:home) 'com-beginning-of-line) (global-set-key '(:end) 'com-end-of-line) +(global-set-key '(:prior) 'com-page-up) +(global-set-key '(:next) 'com-page-down) (global-set-key '(:home :control) 'com-beginning-of-buffer) (global-set-key '(:end :control) 'com-end-of-buffer) (global-set-key #\Rubout 'com-delete-object) From ejohnson at common-lisp.net Sat Jan 8 18:07:42 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Sat, 8 Jan 2005 19:07:42 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/INSTALL Message-ID: <20050108180742.E9A06884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7947 Modified Files: INSTALL Log Message: testing cvs commit Date: Sat Jan 8 19:07:40 2005 Author: ejohnson Index: climacs/INSTALL diff -u climacs/INSTALL:1.2 climacs/INSTALL:1.3 --- climacs/INSTALL:1.2 Wed Dec 22 15:43:18 2004 +++ climacs/INSTALL Sat Jan 8 19:07:30 2005 @@ -33,3 +33,5 @@ Start the Climacs editor. + + From abakic at common-lisp.net Sun Jan 9 02:42:19 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 9 Jan 2005 03:42:19 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp Message-ID: <20050109024219.0F7F4884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1272 Modified Files: gui.lisp packages.lisp Log Message: Overwrite mode: first iteration (no protocol changes). Date: Sun Jan 9 03:42:15 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.57 climacs/gui.lisp:1.58 --- climacs/gui.lisp:1.57 Sat Jan 8 18:16:19 2005 +++ climacs/gui.lisp Sun Jan 9 03:42:14 2005 @@ -104,13 +104,18 @@ (defun display-message (format-string &rest format-args) (apply #'format *standard-input* format-string format-args)) +(defvar *overwrite-mode* nil) + (defun display-info (frame pane) (let* ((win (win frame)) (buf (buffer win)) - (name-info (format nil " ~a ~a Syntax: ~a" + (name-info (format nil " ~a ~a Syntax: ~a ~a" (if (needs-saving buf) "**" "--") (name buf) - (name (syntax win))))) + (name (syntax win)) + (if *overwrite-mode* + "Ovwrt" + (format nil "L~d" (line-number (point win))))))) (princ name-info pane))) (defun display-win (frame pane) @@ -236,10 +241,18 @@ (define-named-command (com-quit) () (frame-exit *application-frame*)) +(define-named-command com-toggle-overwrite-mode () + (setf *overwrite-mode* (not *overwrite-mode*))) + (define-command com-self-insert () - (unless (constituentp *current-gesture*) - (possibly-expand-abbrev (point (win *application-frame*)))) - (insert-object (point (win *application-frame*)) *current-gesture*)) + (let ((point (point (win *application-frame*)))) + (unless (constituentp *current-gesture*) + (possibly-expand-abbrev point)) + (if (and *overwrite-mode* (not (end-of-line-p point))) + (progn + (delete-range point) + (insert-object point *current-gesture*)) + (insert-object point *current-gesture*)))) (define-named-command com-beginning-of-line () (beginning-of-line (point (win *application-frame*)))) @@ -707,6 +720,8 @@ (global-set-key '(:end :control) 'com-end-of-buffer) (global-set-key #\Rubout 'com-delete-object) (global-set-key #\Backspace 'com-backward-delete-object) + +(global-set-key '(:insert) 'com-toggle-overwrite-mode) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.22 climacs/packages.lisp:1.23 --- climacs/packages.lisp:1.22 Fri Jan 7 14:07:45 2005 +++ climacs/packages.lisp Sun Jan 9 03:42:14 2005 @@ -33,7 +33,7 @@ #:beginning-of-line-p #:end-of-line-p #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence - #:insert-object #:insert-sequence + #:update-object #:insert-object #:insert-sequence #:delete-buffer-range #:delete-range #:delete-region #:buffer-object #:buffer-sequence From abakic at common-lisp.net Sun Jan 9 02:46:53 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 9 Jan 2005 03:46:53 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/packages.lisp Message-ID: <20050109024653.63865884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1638 Modified Files: packages.lisp Log Message: Rollback (repeat: no protocol changes). Date: Sun Jan 9 03:46:43 2005 Author: abakic Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.23 climacs/packages.lisp:1.24 --- climacs/packages.lisp:1.23 Sun Jan 9 03:42:14 2005 +++ climacs/packages.lisp Sun Jan 9 03:46:35 2005 @@ -33,7 +33,7 @@ #:beginning-of-line-p #:end-of-line-p #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence - #:update-object #:insert-object #:insert-sequence + #:insert-object #:insert-sequence #:delete-buffer-range #:delete-range #:delete-region #:buffer-object #:buffer-sequence From rstrandh at common-lisp.net Sun Jan 9 11:54:54 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 9 Jan 2005 12:54:54 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp Message-ID: <20050109115454.533BB884B9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29333 Modified Files: base.lisp buffer.lisp gui.lisp packages.lisp syntax.lisp Log Message: Moved forward-object and backward-object to base.lisp because I needed them in syntax.lisp. Improved performance of end-of-line, the slowness of which was a problem for redisplay. Fixed (I hope) bug in redisplay code. I don't seem to be able to convince McCLIM to avoid redrawing all the lines after a new line has been inserted, though. Date: Sun Jan 9 12:54:50 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.12 climacs/base.lisp:1.13 --- climacs/base.lisp:1.12 Fri Jan 7 08:26:23 2005 +++ climacs/base.lisp Sun Jan 9 12:54:50 2005 @@ -28,6 +28,16 @@ (in-package :climacs-base) +(defgeneric backward-object (mark &optional count)) +(defmethod backward-object ((mark climacs-buffer::mark-mixin) + &optional (count 1)) + (decf (offset mark) count)) + +(defgeneric forward-object (mark &optional count)) +(defmethod forward-object ((mark climacs-buffer::mark-mixin) + &optional (count 1)) + (incf (offset mark) count)) + (defun previous-line (mark &optional column) "Move a mark up one line conserving horizontal position." (unless column Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.16 climacs/buffer.lisp:1.17 --- climacs/buffer.lisp:1.16 Wed Jan 5 22:39:23 2005 +++ climacs/buffer.lisp Sun Jan 9 12:54:50 2005 @@ -288,8 +288,14 @@ at the end of the buffer if no following newline character exists.")) (defmethod end-of-line ((mark mark-mixin)) - (loop until (end-of-line-p mark) - do (incf (offset mark)))) + (let* ((offset (offset mark)) + (buffer (buffer mark)) + (chain (slot-value buffer 'contents)) + (size (nb-elements chain))) + (loop until (or (= offset size) + (eql (element* chain offset) #\Newline)) + do (incf offset)) + (setf (offset mark) offset))) (defgeneric line-number (mark) (:documentation "Return the line number of the mark. Lines are numbered from zero.")) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.58 climacs/gui.lisp:1.59 --- climacs/gui.lisp:1.58 Sun Jan 9 03:42:14 2005 +++ climacs/gui.lisp Sun Jan 9 12:54:50 2005 @@ -277,16 +277,6 @@ (insert-object point object) (forward-object point))))) -(defgeneric backward-object (mark &optional count)) -(defmethod backward-object ((mark climacs-buffer::mark-mixin) - &optional (count 1)) - (decf (offset mark) count)) - -(defgeneric forward-object (mark &optional count)) -(defmethod forward-object ((mark climacs-buffer::mark-mixin) - &optional (count 1)) - (incf (offset mark) count)) - (define-named-command com-backward-object () (backward-object (point (win *application-frame*)))) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.24 climacs/packages.lisp:1.25 --- climacs/packages.lisp:1.24 Sun Jan 9 03:46:35 2005 +++ climacs/packages.lisp Sun Jan 9 12:54:50 2005 @@ -42,7 +42,8 @@ (defpackage :climacs-base (:use :clim-lisp :climacs-buffer) - (:export #:previous-line #:next-line + (:export #:forward-object #:backward-object + #:previous-line #:next-line #:open-line #:kill-line #:number-of-lines-in-region #:constituentp #:whitespacep Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.19 climacs/syntax.lisp:1.20 --- climacs/syntax.lisp:1.19 Mon Jan 3 16:07:09 2005 +++ climacs/syntax.lisp Sun Jan 9 12:54:50 2005 @@ -64,6 +64,11 @@ ;;; ;;; Basic syntax +(defun make-cache () + (let ((cache (make-instance 'standard-flexichain))) + (insert* cache 0 nil) + cache)) + (define-syntax basic-syntax ("Basic" (syntax)) ((top :reader top) (bot :reader bot) @@ -72,7 +77,7 @@ (cursor-y :initform 2) (space-width :initform nil) (tab-width :initform nil) - (cache :initform nil))) + (cache :initform (make-cache)))) (defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key pane) (declare (ignore args)) @@ -151,92 +156,113 @@ (terpri pane) (incf scan)))))) -(defgeneric compute-cache (pane syntax)) +(defgeneric fill-cache (pane syntax) + (:documentation "fill nil cache entries from the buffer")) -(defmethod compute-cache (pane (syntax basic-syntax)) +(defmethod fill-cache (pane (syntax basic-syntax)) (with-slots (top bot cache) syntax - (let* ((buffer (buffer pane)) - (high-mark (high-mark buffer)) - (low-mark (low-mark buffer))) - (when (or (mark< low-mark top) (mark> high-mark bot)) - (setf cache nil)) - (if (null cache) - (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot))) - (mark1 (clone-mark top)) - (mark2 (clone-mark top))) - (setf cache (make-instance 'standard-flexichain)) - (loop for line from 0 below nb-lines-on-display - do (beginning-of-line mark1) - (end-of-line mark2) - (insert* cache line (region-to-sequence mark1 mark2)) - unless (end-of-buffer-p mark2) - do (setf (offset mark1) (1+ (offset mark2)) - (offset mark2) (offset mark1)))) - (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot))) - (mark1 (clone-mark low-mark)) - (mark2 (clone-mark low-mark)) - (size1 (number-of-lines-in-region top low-mark)) - (size2 (number-of-lines-in-region high-mark bot))) - (loop repeat (- (nb-elements cache) size1 size2) - do (delete* cache size1)) - (loop for line from size1 - repeat (- nb-lines-on-display (nb-elements cache)) - do (beginning-of-line mark1) - (end-of-line mark2) - (insert* cache line (region-to-sequence mark1 mark2)) - unless (end-of-buffer-p mark2) - do (setf (offset mark1) (1+ (offset mark2)) - (offset mark2) (offset mark1)))))))) + (let ((mark1 (clone-mark top)) + (mark2 (clone-mark top))) + (loop for line from 0 below (nb-elements cache) + do (beginning-of-line mark1) + (end-of-line mark2) + when (null (element* cache line)) + do (setf (element* cache line) (region-to-sequence mark1 mark2)) + unless (end-of-buffer-p mark2) + do (setf (offset mark1) (1+ (offset mark2)) + (offset mark2) (offset mark1)))))) -(defun position-window (pane syntax) +(defun nb-lines-in-pane (pane) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) (height (text-style-height style medium))) + (multiple-value-bind (x y w h) (bounding-rectangle* pane) + (declare (ignore x y w)) + (max 1 (floor h (+ height (stream-vertical-spacing pane))))))) + +;;; make the region on display fit the size of the pane as closely as +;;; possible by adjusting bot leaving top intact. Also make the cache +;;; size fit the size of the region on display. +(defun adjust-cache-size-and-bot (pane syntax) + (let ((nb-lines-in-pane (nb-lines-in-pane pane))) + (with-slots (top bot cache) syntax + (setf (offset bot) (offset top)) + (loop until (end-of-buffer-p bot) + repeat (1- nb-lines-in-pane) + do (forward-object bot) + (end-of-line bot)) + (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) + (loop repeat (- (nb-elements cache) nb-lines-on-display) + do (pop-end cache)) + (loop repeat (- nb-lines-on-display (nb-elements cache)) + do (push-end cache nil)))))) + +;;; put all-nil entries in the cache +(defun empty-cache (cache) + (loop for i from 0 below (nb-elements cache) + do (setf (element* cache i) nil))) + +;;; empty the cache and try to put point close to the middle +;;; of the pane by moving top half a pane-size up. +(defun reposition-window (pane syntax) + (let ((nb-lines-in-pane (nb-lines-in-pane pane))) + (with-slots (top bot cache) syntax + (empty-cache cache) + (setf (offset top) (offset (point pane))) + (loop do (beginning-of-line top) + repeat (floor nb-lines-in-pane 2) + until (beginning-of-buffer-p top) + do (decf (offset top)) + (beginning-of-line top))))) + +;;; Make the cache reflect the contents of the buffer starting at top, +;;; trying to preserve contents as much as possible, and inserting a +;;; nil entry where buffer contents is unknonwn. The size of the +;;; cache size at the end may be smaller than, equal to, or greater +;;; than the number of lines in the pane. +(defun adjust-cache (pane syntax) + (let* ((buffer (buffer pane)) + (high-mark (high-mark buffer)) + (low-mark (low-mark buffer)) + (nb-lines-in-pane (nb-lines-in-pane pane))) (with-slots (top bot cache) syntax (beginning-of-line top) (end-of-line bot) - (multiple-value-bind (x y w h) (bounding-rectangle* pane) - (declare (ignore x y w)) - (let ((nb-lines-in-pane (max 1 (floor h (+ height (stream-vertical-spacing pane))))) - (nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) - ;; adjust the region on display to fit the pane - (loop repeat (- nb-lines-on-display nb-lines-in-pane) - do (beginning-of-line bot) - (decf (offset bot)) - (unless (null cache) - (pop-end cache))) - (loop until (end-of-buffer-p bot) - repeat (- nb-lines-in-pane nb-lines-on-display) - do (incf (offset bot)) + (if (or (mark< (point pane) top) + (>= (number-of-lines-in-region top (point pane)) nb-lines-in-pane) + (and (mark< low-mark top) + (>= (number-of-lines-in-region top high-mark) (nb-elements cache)))) + (reposition-window pane syntax) + (let* ((n1 (number-of-lines-in-region top low-mark)) + (n2 (1+ (number-of-lines-in-region low-mark high-mark))) + (n3 (number-of-lines-in-region high-mark bot)) + (diff (- (+ n1 n2 n3) (nb-elements cache)))) + (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20)) + (setf (offset bot) (offset top)) (end-of-line bot) - (setf cache nil)) - ;; move region on display if point is outside the current region - (when (or (mark< (point pane) top) (mark> (point pane) bot)) - (setf cache nil) - (setf (offset top) (offset (point pane))) - (loop do (beginning-of-line top) - repeat (floor nb-lines-in-pane 2) - until (beginning-of-buffer-p top) - do (decf (offset top)) - (beginning-of-line top)) - (setf (offset bot) (offset top)) - (loop do (end-of-line bot) - repeat (1- nb-lines-in-pane) - until (end-of-buffer-p bot) - do (incf (offset bot)) - (end-of-line bot)))))))) + (loop for i from n1 below (nb-elements cache) + do (setf (element* cache i) nil))) + ((>= diff 0) + (loop repeat diff do (insert* cache n1 nil)) + (loop for i from (+ n1 diff) below (+ n1 n2) + do (setf (element* cache i) nil))) + (t + (loop repeat (- diff) do (delete* cache n1)) + (loop for i from n1 below (+ n1 n2) + do (setf (element* cache i) nil)))))))) + (adjust-cache-size-and-bot pane syntax)) (defun page-down (pane syntax) - (position-window pane syntax) + (adjust-cache pane syntax) (with-slots (top bot cache) syntax (when (mark> (size (buffer bot)) bot) + (empty-cache cache) (setf (offset top) (offset bot)) (beginning-of-line top) - (setf (offset (point pane)) (offset top)) - (setf cache nil)))) + (setf (offset (point pane)) (offset top))))) (defun page-up (pane syntax) - (position-window pane syntax) + (adjust-cache pane syntax) (with-slots (top bot cache) syntax (when (> (offset top) 0) (let ((nb-lines-in-region (number-of-lines-in-region top bot))) @@ -247,10 +273,10 @@ do (decf (offset top)) (beginning-of-line top)) (setf (offset (point pane)) (offset top)) - (position-window pane syntax) + (adjust-cache pane syntax) (setf (offset (point pane)) (offset bot)) (beginning-of-line (point pane)) - (setf cache nil))))) + (empty-cache cache))))) ;;; this one should not be necessary. (defun round-up (x) @@ -263,8 +289,8 @@ (style (medium-text-style medium)) (height (text-style-height style medium))) (with-slots (top bot scan cache cursor-x cursor-y) syntax - (position-window pane syntax) - (compute-cache pane syntax) + (adjust-cache pane syntax) + (fill-cache pane syntax) (loop with start-offset = (offset top) for id from 0 below (nb-elements cache) do (setf scan start-offset) From rstrandh at common-lisp.net Sun Jan 9 14:08:28 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 9 Jan 2005 15:08:28 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050109140828.BF540884B9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3491 Modified Files: base.lisp gui.lisp packages.lisp Log Message: upcase, downcase, capitalize words from Rudi Schlatte. Thanks! Date: Sun Jan 9 15:08:27 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.13 climacs/base.lisp:1.14 --- climacs/base.lisp:1.13 Sun Jan 9 12:54:50 2005 +++ climacs/base.lisp Sun Jan 9 15:08:26 2005 @@ -111,20 +111,28 @@ #+sbcl (sb-impl::whitespacep obj) #-sbcl (member obj '(#\Space #\Tab)))) -(defun forward-word (mark) - "Forward the mark to the next word." +(defun forward-to-word-boundary (mark) + "Forward the mark forward to the beginning of the next word." (loop until (end-of-buffer-p mark) until (constituentp (object-after mark)) - do (incf (offset mark))) + do (incf (offset mark)))) + +(defun backward-to-word-boundary (mark) + "Move the mark backward to the end of the previous word." + (loop until (beginning-of-buffer-p mark) + until (constituentp (object-before mark)) + do (decf (offset mark)))) + +(defun forward-word (mark) + "Forward the mark to the next word." + (forward-to-word-boundary mark) (loop until (end-of-buffer-p mark) while (constituentp (object-after mark)) do (incf (offset mark)))) (defun backward-word (mark) "Shuttle the mark to the start of the previous word." - (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) - do (decf (offset mark))) + (backward-to-word-boundary mark) (loop until (beginning-of-buffer-p mark) while (constituentp (object-before mark)) do (decf (offset mark)))) @@ -155,6 +163,45 @@ (constituentp (buffer-object (buffer mark) (1- i)))) finally (return i)) mark)) + +(defun downcase-word (mark &optional (n 1)) + "Convert the next N words to lowercase, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (loop until (end-of-buffer-p mark) + while (constituentp (object-after mark)) + for character = (object-after mark) + if (upper-case-p character) + do (progn (delete-range mark 1) + (insert-object mark (char-downcase character))) + else + do (incf (offset mark))))) + +(defun upcase-word (mark &optional (n 1)) + "Convert the next N words to uppercase, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (loop until (end-of-buffer-p mark) + while (constituentp (object-after mark)) + for character = (object-after mark) + when (lower-case-p character) + do (progn + (delete-range mark 1) + (insert-object mark (char-upcase character))) + else + do (incf (offset mark))))) + +(defun capitalize-word (mark &optional (n 1)) + "Capitalize the next N words, leaving mark after the last word." + (dotimes (i n) + (forward-to-word-boundary mark) + (unless (end-of-buffer-p mark) + (let ((character (object-after mark))) + (when (lower-case-p character) + (delete-range mark 1) + (insert-object mark (char-upcase character)))) + (when (constituentp (object-after mark)) + (downcase-word mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.59 climacs/gui.lisp:1.60 --- climacs/gui.lisp:1.59 Sun Jan 9 12:54:50 2005 +++ climacs/gui.lisp Sun Jan 9 15:08:27 2005 @@ -378,6 +378,15 @@ (define-named-command com-backward-delete-word () (backward-delete-word (point (win *application-frame*)))) +(define-named-command com-upcase-word () + (upcase-word (point (win *application-frame*)))) + +(define-named-command com-downcase-word () + (downcase-word (point (win *application-frame*)))) + +(define-named-command com-capitalize-word () + (capitalize-word (point (win *application-frame*)))) + (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) @@ -683,6 +692,9 @@ (global-set-key '(#\f :meta) 'com-forward-word) (global-set-key '(#\b :meta) 'com-backward-word) (global-set-key '(#\t :meta) 'com-transpose-words) +(global-set-key '(#\u :meta) 'com-upcase-word) +(global-set-key '(#\l :meta) 'com-downcase-word) +(global-set-key '(#\c :meta) 'com-capitalize-word) (global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\y :meta) 'com-rotate-yank) (global-set-key '(#\w :meta) 'com-copy-out) @@ -690,7 +702,6 @@ (global-set-key '(#\v :meta) 'com-page-up) (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) -(global-set-key '(#\u :meta) 'com-browse-url) (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.25 climacs/packages.lisp:1.26 --- climacs/packages.lisp:1.25 Sun Jan 9 12:54:50 2005 +++ climacs/packages.lisp Sun Jan 9 15:08:27 2005 @@ -49,6 +49,7 @@ #:constituentp #:whitespacep #:forward-word #:backward-word #:delete-word #:backward-delete-word + #:upcase-word #:downcase-word #:capitalize-word #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-lookin-at #:looking-at From rstrandh at common-lisp.net Mon Jan 10 05:31:24 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 10 Jan 2005 06:31:24 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/syntax.lisp Message-ID: <20050110053124.8AD81884B9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17277 Modified Files: gui.lisp syntax.lisp Log Message: Removed the line number from the status line until we have the better buffer implementation. Right now, this function requires scanning the entire buffer and counting newlines. Fixed adjust-cache so that it doesn't do anything when there has been no modification of the buffer since previous redisplay. Date: Mon Jan 10 06:31:20 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.60 climacs/gui.lisp:1.61 --- climacs/gui.lisp:1.60 Sun Jan 9 15:08:27 2005 +++ climacs/gui.lisp Mon Jan 10 06:31:16 2005 @@ -115,7 +115,7 @@ (name (syntax win)) (if *overwrite-mode* "Ovwrt" - (format nil "L~d" (line-number (point win))))))) + "")))) (princ name-info pane))) (defun display-win (frame pane) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.20 climacs/syntax.lisp:1.21 --- climacs/syntax.lisp:1.20 Sun Jan 9 12:54:50 2005 +++ climacs/syntax.lisp Mon Jan 10 06:31:17 2005 @@ -233,23 +233,24 @@ (and (mark< low-mark top) (>= (number-of-lines-in-region top high-mark) (nb-elements cache)))) (reposition-window pane syntax) - (let* ((n1 (number-of-lines-in-region top low-mark)) - (n2 (1+ (number-of-lines-in-region low-mark high-mark))) - (n3 (number-of-lines-in-region high-mark bot)) - (diff (- (+ n1 n2 n3) (nb-elements cache)))) - (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20)) - (setf (offset bot) (offset top)) - (end-of-line bot) - (loop for i from n1 below (nb-elements cache) - do (setf (element* cache i) nil))) - ((>= diff 0) - (loop repeat diff do (insert* cache n1 nil)) - (loop for i from (+ n1 diff) below (+ n1 n2) - do (setf (element* cache i) nil))) - (t - (loop repeat (- diff) do (delete* cache n1)) - (loop for i from n1 below (+ n1 n2) - do (setf (element* cache i) nil)))))))) + (when (mark>= high-mark low-mark) + (let* ((n1 (number-of-lines-in-region top low-mark)) + (n2 (1+ (number-of-lines-in-region low-mark high-mark))) + (n3 (number-of-lines-in-region high-mark bot)) + (diff (- (+ n1 n2 n3) (nb-elements cache)))) + (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20)) + (setf (offset bot) (offset top)) + (end-of-line bot) + (loop for i from n1 below (nb-elements cache) + do (setf (element* cache i) nil))) + ((>= diff 0) + (loop repeat diff do (insert* cache n1 nil)) + (loop for i from (+ n1 diff) below (+ n1 n2) + do (setf (element* cache i) nil))) + (t + (loop repeat (- diff) do (delete* cache n1)) + (loop for i from n1 below (+ n1 n2) + do (setf (element* cache i) nil))))))))) (adjust-cache-size-and-bot pane syntax)) (defun page-down (pane syntax) From rstrandh at common-lisp.net Wed Jan 12 16:41:19 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 12 Jan 2005 17:41:19 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/syntax.lisp Message-ID: <20050112164119.4B35C884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1612 Modified Files: gui.lisp syntax.lisp Log Message: * added numeric arguments. This feature requires a CVS version of McCLIM as of 2005-01-11. Only a few commands take numeric arguments at the moment such as forward-object, backward-object, delete-object, and backward-delete-object. There are more to come. * the cursor display problem has been "fixed" by drawing a rectangle rather than a line. This makes obsolete the hacky code for explicit rounding of cursor coordinates. Date: Wed Jan 12 17:41:17 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.61 climacs/gui.lisp:1.62 --- climacs/gui.lisp:1.61 Mon Jan 10 06:31:16 2005 +++ climacs/gui.lisp Wed Jan 12 17:41:16 2005 @@ -71,15 +71,17 @@ :name 'win :incremental-redisplay t :display-function 'display-win)) - (info :application - :width 900 :height 20 :max-height 20 - :name 'info :background +light-gray+ - :scroll-bars nil - :incremental-redisplay t - :display-function 'display-info) - (int (make-pane 'minibuffer-pane - :width 900 :height 20 :max-height 20 :min-height 20 - :scroll-bars nil))) + + (info :application + :width 900 :height 20 :max-height 20 + :name 'info :background +light-gray+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info) + (int (make-pane 'minibuffer-pane + :width 900 :height 20 :max-height 20 :min-height 20 + :scroll-bars nil))) (:layouts (default (vertically (:scroll-bars nil) @@ -162,10 +164,10 @@ (defun read-numeric-argument (&key (stream *standard-input*)) (let ((gesture (climacs-read-gesture))) - (cond ((event-matches-gesture-name-p gesture '(#\u :control)) + (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME (let ((numarg 4)) (loop for gesture = (climacs-read-gesture) - while (event-matches-gesture-name-p gesture '(#\u :control)) + while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME do (setf numarg (* 4 numarg)) finally (unread-gesture gesture :stream stream)) (let ((gesture (climacs-read-gesture))) @@ -175,11 +177,12 @@ (loop for gesture = (climacs-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) - do (setf gesture (+ (* 10 numarg) - (- (char-code gesture) (char-code #\0)))) + do (setf numarg (+ (* 10 numarg) + (- (char-code gesture) (char-code #\0)))) finally (unread-gesture gesture :stream stream) (return (values numarg t)))) (t + (unread-gesture gesture :stream stream) (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) @@ -202,29 +205,29 @@ (*abort-gestures* nil)) (redisplay-frame-panes frame :force-p t) (loop (catch 'outer-loop - (loop with gestures = '() - with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) - do (setf *current-gesture* (climacs-read-gesture)) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (setf gestures '())) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (handler-case - (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf gestures '()) - (setf (previous-command *standard-output*) - (if (consp command) - (car command) - command)))) - (t nil))) + (loop for gestures = '() + for numarg = (read-numeric-argument :stream *standard-input*) + do (loop (setf *current-gesture* (climacs-read-gesture)) + (setf gestures (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-table))) + (cond ((not item) + (beep) (return)) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf (previous-command *standard-output*) + (if (consp command) + (car command) + command)) + (return))) + (t nil)))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) @@ -236,7 +239,9 @@ (redisplay-frame-panes frame)))) (defmacro define-named-command (command-name args &body body) - `(define-climacs-command ,(if (listp command-name) `(, at command-name :name t) `(,command-name :name t)) ,args , at body)) + `(define-climacs-command ,(if (listp command-name) + `(, at command-name :name t) + `(,command-name :name t)) ,args , at body)) (define-named-command (com-quit) () (frame-exit *application-frame*)) @@ -260,11 +265,11 @@ (define-named-command com-end-of-line () (end-of-line (point (win *application-frame*)))) -(define-named-command com-delete-object () - (delete-range (point (win *application-frame*)))) +(define-named-command com-delete-object ((count 'integer :prompt "Number of Objects")) + (delete-range (point (win *application-frame*)) count)) -(define-named-command com-backward-delete-object () - (delete-range (point (win *application-frame*)) -1)) +(define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects")) + (delete-range (point (win *application-frame*)) (- count))) (define-named-command com-transpose-objects () (let* ((point (point (win *application-frame*)))) @@ -277,11 +282,11 @@ (insert-object point object) (forward-object point))))) -(define-named-command com-backward-object () - (backward-object (point (win *application-frame*)))) +(define-named-command com-backward-object ((count 'integer :prompt "Number of Objects")) + (backward-object (point (win *application-frame*)) count)) -(define-named-command com-forward-object () - (forward-object (point (win *application-frame*)))) +(define-named-command com-forward-object ((count 'integer :prompt "Number of Objects")) + (forward-object (point (win *application-frame*)) count)) (define-named-command com-transpose-words () (let* ((point (point (win *application-frame*)))) @@ -676,11 +681,11 @@ (global-set-key #\newline 'com-self-insert) (global-set-key #\tab 'com-self-insert) -(global-set-key '(#\f :control) 'com-forward-object) -(global-set-key '(#\b :control) 'com-backward-object) +(global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) +(global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*)) (global-set-key '(#\a :control) 'com-beginning-of-line) (global-set-key '(#\e :control) 'com-end-of-line) -(global-set-key '(#\d :control) 'com-delete-object) +(global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*)) (global-set-key '(#\p :control) 'com-previous-line) (global-set-key '(#\n :control) 'com-next-line) (global-set-key '(#\o :control) 'com-open-line) @@ -709,8 +714,8 @@ (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) -(global-set-key '(:left) 'com-backward-object) -(global-set-key '(:right) 'com-forward-object) +(global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*)) +(global-set-key '(:right) `(com-forward-object *numeric-argument-marker*)) (global-set-key '(:left :control) 'com-backward-word) (global-set-key '(:right :control) 'com-forward-word) (global-set-key '(:home) 'com-beginning-of-line) @@ -719,8 +724,8 @@ (global-set-key '(:next) 'com-page-down) (global-set-key '(:home :control) 'com-beginning-of-buffer) (global-set-key '(:end :control) 'com-end-of-buffer) -(global-set-key #\Rubout 'com-delete-object) -(global-set-key #\Backspace 'com-backward-delete-object) +(global-set-key #\Rubout `(com-delete-object ,*numeric-argument-marker*)) +(global-set-key #\Backspace `(com-backward-delete-object ,*numeric-argument-marker*)) (global-set-key '(:insert) 'com-toggle-overwrite-mode) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.21 climacs/syntax.lisp:1.22 --- climacs/syntax.lisp:1.21 Mon Jan 10 06:31:17 2005 +++ climacs/syntax.lisp Wed Jan 12 17:41:17 2005 @@ -279,12 +279,6 @@ (beginning-of-line (point pane)) (empty-cache cache))))) -;;; this one should not be necessary. -(defun round-up (x) - (cond ((zerop x) 2) - ((evenp x) x) - (t (1+ x)))) - (defmethod redisplay-with-syntax (pane (syntax basic-syntax)) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) @@ -310,13 +304,10 @@ (setf cursor-x x cursor-y y))) (updating-output (pane :unique-id -1) - (draw-line* pane - ;; cursors with odd or zero x-positions were invisible - ;; so we round them up to even. - ;; We don't know why, though. - (round-up cursor-x) (- cursor-y (* 0.2 height)) - (round-up cursor-x) (+ cursor-y (* 0.8 height)) - :ink +red+))))) + (draw-rectangle* pane + cursor-x (- cursor-y (* 0.2 height)) + (1+ cursor-x) (+ cursor-y (* 0.8 height)) + :ink +red+))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From rstrandh at common-lisp.net Thu Jan 13 05:38:43 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 13 Jan 2005 06:38:43 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/abbrev.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp Message-ID: <20050113053843.D02A1884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9121 Modified Files: abbrev.lisp gui.lisp packages.lisp syntax.lisp Log Message: Fixed up abbrevs somewhat. Made the cursor wider, so easier to find. Added new command `Load File'. Date: Thu Jan 13 06:38:41 2005 Author: rstrandh Index: climacs/abbrev.lisp diff -u climacs/abbrev.lisp:1.5 climacs/abbrev.lisp:1.6 --- climacs/abbrev.lisp:1.5 Fri Dec 31 07:39:21 2004 +++ climacs/abbrev.lisp Thu Jan 13 06:38:40 2005 @@ -50,6 +50,9 @@ (defgeneric add-abbrev (word expansion dictionary-abbrev-expander) (:documentation "Add an abbrev expansion to a dictionary abbrev expander")) +(defmethod add-abbrev (word expansion (expander dictionary-abbrev-expander)) + (push (cons word expansion) (dictionary expander))) + (defun string-upper-case-p (string) "A predicate testing if each character of a string is uppercase." (every #'upper-case-p string)) @@ -74,7 +77,8 @@ (loop until (zerop offset1) while (constituentp (buffer-object buffer (1- offset1))) do (decf offset1)) - (let ((expansion (expand-abbrev (buffer-sequence buffer offset1 offset2) + (let ((expansion (expand-abbrev (coerce (buffer-sequence buffer offset1 offset2) + 'string) (abbrev-expander buffer)))) (when expansion (delete-buffer-range buffer offset1 (- offset2 offset1)) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.62 climacs/gui.lisp:1.63 --- climacs/gui.lisp:1.62 Wed Jan 12 17:41:16 2005 +++ climacs/gui.lisp Thu Jan 13 06:38:41 2005 @@ -525,6 +525,11 @@ (needs-saving buffer) nil) (display-message "Wrote: ~a" (filename buffer)))) +(define-named-command com-load-file () + (let ((filename (accept 'completable-pathname + :prompt "Load File"))) + (load filename))) + (define-named-command com-beginning-of-buffer () (beginning-of-buffer (point (win *application-frame*)))) @@ -745,6 +750,7 @@ (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) +(c-x-set-key '(#\l :control) 'com-load-file) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.26 climacs/packages.lisp:1.27 --- climacs/packages.lisp:1.26 Sun Jan 9 15:08:27 2005 +++ climacs/packages.lisp Thu Jan 13 06:38:41 2005 @@ -59,7 +59,8 @@ (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) (:export #:abbrev-expander #:dictionary-abbrev-expander #:dictionary - #:expand-abbrev #:abbrev-mixin #:possibly-expand-abbrev)) + #:expand-abbrev #:abbrev-mixin #:possibly-expand-abbrev + #:add-abbrev)) (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.22 climacs/syntax.lisp:1.23 --- climacs/syntax.lisp:1.22 Wed Jan 12 17:41:17 2005 +++ climacs/syntax.lisp Thu Jan 13 06:38:41 2005 @@ -305,8 +305,8 @@ cursor-y y))) (updating-output (pane :unique-id -1) (draw-rectangle* pane - cursor-x (- cursor-y (* 0.2 height)) - (1+ cursor-x) (+ cursor-y (* 0.8 height)) + (1- cursor-x) (- cursor-y (* 0.2 height)) + (+ cursor-x 2) (+ cursor-y (* 0.8 height)) :ink +red+))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From mvilleneuve at common-lisp.net Thu Jan 13 15:31:16 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Thu, 13 Jan 2005 16:31:16 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer.lisp Message-ID: <20050113153116.01EAE884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6911 Modified Files: buffer.lisp Log Message: Added a (setf buffer-object) method Date: Thu Jan 13 16:31:12 2005 Author: mvilleneuve Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.17 climacs/buffer.lisp:1.18 --- climacs/buffer.lisp:1.17 Sun Jan 9 12:54:50 2005 +++ climacs/buffer.lisp Thu Jan 13 16:31:11 2005 @@ -410,6 +410,16 @@ (make-condition 'no-such-offset :offset offset)) (element* (slot-value buffer 'contents) offset)) +(defgeneric (setf buffer-object) (object buffer offset) + (:documentation "Set the object at the offset in the buffer. The first object +has offset 0. If offset is less than zero or greater than or equal to +the size of the buffer, a no-such-offset condition is signaled.")) + +(defmethod (setf buffer-object) (object (buffer standard-buffer) offset) + (assert (<= 0 offset (1- (size buffer))) () + (make-condition 'no-such-offset :offset offset)) + (setf (element* (slot-value buffer 'contents) offset) object)) + (defgeneric buffer-sequence (buffer offset1 offset2) (:documentation "Return the contents of the buffer starting at offset1 and ending at offset2-1 as a sequence. If either of the offsets is less than zero @@ -464,6 +474,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Buffer modification protocol + +(defmethod (setf buffer-object) :before (object (buffer standard-buffer) offset) + (declare (ignore object)) + (setf (offset (low-mark buffer)) + (min (offset (low-mark buffer)) offset)) + (setf (offset (high-mark buffer)) + (max (offset (high-mark buffer)) offset)) + (setf (slot-value buffer 'modified) t)) (defmethod insert-buffer-object :before ((buffer standard-buffer) offset object) (declare (ignore object)) From mvilleneuve at common-lisp.net Thu Jan 13 15:34:09 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Thu, 13 Jan 2005 16:34:09 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050113153409.F083E884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7173 Modified Files: base.lisp gui.lisp packages.lisp Log Message: Added upcase/downcase/capitalize-region, and a do-buffer-region macro Date: Thu Jan 13 16:34:05 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.14 climacs/base.lisp:1.15 --- climacs/base.lisp:1.14 Sun Jan 9 15:08:26 2005 +++ climacs/base.lisp Thu Jan 13 16:34:05 2005 @@ -28,12 +28,23 @@ (in-package :climacs-base) +(defmacro do-buffer-region ((object offset buffer offset1 offset2) + &body body) + "Iterate over the elements of the region delimited by offset1 and offset2. +The body is executed for each element, with object being the current object +(setf-able), and offset being its offset." + `(symbol-macrolet ((,object (buffer-object ,buffer ,offset))) + (loop for ,offset from ,offset1 to ,offset2 + do , at body))) + (defgeneric backward-object (mark &optional count)) + (defmethod backward-object ((mark climacs-buffer::mark-mixin) &optional (count 1)) (decf (offset mark) count)) (defgeneric forward-object (mark &optional count)) + (defmethod forward-object ((mark climacs-buffer::mark-mixin) &optional (count 1)) (incf (offset mark) count)) @@ -164,44 +175,106 @@ finally (return i)) mark)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Character case + +(defun downcase-buffer-region (buffer offset1 offset2) + (do-buffer-region (object offset buffer offset1 offset2) + (when (and (constituentp object) (upper-case-p object)) + (setf object (char-downcase object))))) + +(defgeneric downcase-region (mark1 mark2) + (:documentation "Convert all characters after mark1 and before mark2 to +lowercase. An error is signaled if the two marks are positioned in different +buffers. It is acceptable to pass an offset in place of one of the marks.")) + +(defmethod downcase-region ((mark1 climacs-buffer::mark-mixin) + (mark2 climacs-buffer::mark-mixin)) + (assert (eq (buffer mark1) (buffer mark2))) + (downcase-buffer-region (buffer mark1) (offset mark1) (offset mark2))) + +(defmethod downcase-region ((offset integer) (mark climacs-buffer::mark-mixin)) + (downcase-buffer-region (buffer mark) offset (offset mark))) + +(defmethod downcase-region ((mark climacs-buffer::mark-mixin) (offset integer)) + (downcase-buffer-region (buffer mark) (offset mark) offset)) + (defun downcase-word (mark &optional (n 1)) "Convert the next N words to lowercase, leaving mark after the last word." - (dotimes (i n) - (forward-to-word-boundary mark) - (loop until (end-of-buffer-p mark) - while (constituentp (object-after mark)) - for character = (object-after mark) - if (upper-case-p character) - do (progn (delete-range mark 1) - (insert-object mark (char-downcase character))) - else - do (incf (offset mark))))) + (loop repeat n + do (forward-to-word-boundary mark) + (let ((offset (offset mark))) + (forward-word mark) + (downcase-region offset mark)))) + +(defun upcase-buffer-region (buffer offset1 offset2) + (do-buffer-region (object offset buffer offset1 offset2) + (when (and (constituentp object) (lower-case-p object)) + (setf object (char-upcase object))))) + +(defgeneric upcase-region (mark1 mark2) + (:documentation "Convert all characters after mark1 and before mark2 to +uppercase. An error is signaled if the two marks are positioned in different +buffers. It is acceptable to pass an offset in place of one of the marks.")) + +(defmethod upcase-region ((mark1 climacs-buffer::mark-mixin) + (mark2 climacs-buffer::mark-mixin)) + (assert (eq (buffer mark1) (buffer mark2))) + (upcase-buffer-region (buffer mark1) (offset mark1) (offset mark2))) + +(defmethod upcase-region ((offset integer) (mark climacs-buffer::mark-mixin)) + (upcase-buffer-region (buffer mark) offset (offset mark))) + +(defmethod upcase-region ((mark climacs-buffer::mark-mixin) (offset integer)) + (upcase-buffer-region (buffer mark) (offset mark) offset)) (defun upcase-word (mark &optional (n 1)) "Convert the next N words to uppercase, leaving mark after the last word." - (dotimes (i n) - (forward-to-word-boundary mark) - (loop until (end-of-buffer-p mark) - while (constituentp (object-after mark)) - for character = (object-after mark) - when (lower-case-p character) - do (progn - (delete-range mark 1) - (insert-object mark (char-upcase character))) - else - do (incf (offset mark))))) + (loop repeat n + do (forward-to-word-boundary mark) + (let ((offset (offset mark))) + (forward-word mark) + (upcase-region offset mark)))) + +(defun capitalize-buffer-region (buffer offset1 offset2) + (let ((previous-char-constituent-p + (and (plusp offset1) + (constituentp (buffer-object buffer (1- offset1)))))) + (do-buffer-region (object offset buffer offset1 offset2) + (when (constituentp object) + (if previous-char-constituent-p + (when (upper-case-p object) + (setf object (char-downcase object))) + (when (lower-case-p object) + (setf object (char-upcase object))))) + (setf previous-char-constituent-p (constituentp object))))) + +(defgeneric capitalize-region (mark1 mark2) + (:documentation "Capitalize all words after mark1 and before mark2. +An error is signaled if the two marks are positioned in different buffers. +It is acceptable to pass an offset in place of one of the marks.")) + +(defmethod capitalize-region ((mark1 climacs-buffer::mark-mixin) + (mark2 climacs-buffer::mark-mixin)) + (assert (eq (buffer mark1) (buffer mark2))) + (capitalize-buffer-region (buffer mark1) (offset mark1) (offset mark2))) + +(defmethod capitalize-region ((offset integer) + (mark climacs-buffer::mark-mixin)) + (capitalize-buffer-region (buffer mark) offset (offset mark))) + +(defmethod capitalize-region ((mark climacs-buffer::mark-mixin) + (offset integer)) + (capitalize-buffer-region (buffer mark) (offset mark) offset)) (defun capitalize-word (mark &optional (n 1)) "Capitalize the next N words, leaving mark after the last word." - (dotimes (i n) - (forward-to-word-boundary mark) - (unless (end-of-buffer-p mark) - (let ((character (object-after mark))) - (when (lower-case-p character) - (delete-range mark 1) - (insert-object mark (char-upcase character)))) - (when (constituentp (object-after mark)) - (downcase-word mark))))) + (loop repeat n + do (forward-to-word-boundary mark) + (let ((offset (offset mark))) + (forward-word mark) + (capitalize-region offset mark)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.63 climacs/gui.lisp:1.64 --- climacs/gui.lisp:1.63 Thu Jan 13 06:38:41 2005 +++ climacs/gui.lisp Thu Jan 13 16:34:05 2005 @@ -238,6 +238,12 @@ (setf (needs-saving buffer) t))) (redisplay-frame-panes frame)))) +(defun region-limits (pane) + (with-slots (point mark) pane + (if (< (offset mark) (offset point)) + (values mark point) + (values point mark)))) + (defmacro define-named-command (command-name args &body body) `(define-climacs-command ,(if (listp command-name) `(, at command-name :name t) @@ -383,6 +389,18 @@ (define-named-command com-backward-delete-word () (backward-delete-word (point (win *application-frame*)))) +(define-named-command com-upcase-region () + (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (upcase-region start end))) + +(define-named-command com-downcase-region () + (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (downcase-region start end))) + +(define-named-command com-capitalize-region () + (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (capitalize-region start end))) + (define-named-command com-upcase-word () (upcase-word (point (win *application-frame*)))) @@ -593,13 +611,9 @@ ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () - (with-slots (point mark)(win *application-frame*) - (cond ((< (offset mark)(offset point)) - (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) - (delete-region (offset mark) point)) - (t - (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) - (delete-region (offset point) mark))))) + (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (kill-ring-standard-push *kill-ring* (region-to-sequence start end)) + (delete-region (offset start) end))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.27 climacs/packages.lisp:1.28 --- climacs/packages.lisp:1.27 Thu Jan 13 06:38:41 2005 +++ climacs/packages.lisp Thu Jan 13 16:34:05 2005 @@ -42,13 +42,15 @@ (defpackage :climacs-base (:use :clim-lisp :climacs-buffer) - (:export #:forward-object #:backward-object + (:export #:do-buffer-region + #:forward-object #:backward-object #:previous-line #:next-line #:open-line #:kill-line #:number-of-lines-in-region #:constituentp #:whitespacep #:forward-word #:backward-word #:delete-word #:backward-delete-word + #:upcase-region #:downcase-region #:capitalize-region #:upcase-word #:downcase-word #:capitalize-word #:input-from-stream #:output-to-stream #:name-mixin #:name From mvilleneuve at common-lisp.net Thu Jan 13 16:52:19 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Thu, 13 Jan 2005 17:52:19 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050113165219.828BC884BC@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11276 Modified Files: base.lisp buffer.lisp gui.lisp packages.lisp Log Message: Fixed wrong usage of mark-mixin, updated copyrights Date: Thu Jan 13 17:52:14 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.15 climacs/base.lisp:1.16 --- climacs/base.lisp:1.15 Thu Jan 13 16:34:05 2005 +++ climacs/base.lisp Thu Jan 13 17:52:14 2005 @@ -1,9 +1,11 @@ ;;; -*- Mode: Lisp; Package: CLIMACS-BASE -*- -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson at fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -39,14 +41,12 @@ (defgeneric backward-object (mark &optional count)) -(defmethod backward-object ((mark climacs-buffer::mark-mixin) - &optional (count 1)) +(defmethod backward-object ((mark mark) &optional (count 1)) (decf (offset mark) count)) (defgeneric forward-object (mark &optional count)) -(defmethod forward-object ((mark climacs-buffer::mark-mixin) - &optional (count 1)) +(defmethod forward-object ((mark mark) &optional (count 1)) (incf (offset mark) count)) (defun previous-line (mark &optional column) @@ -189,15 +189,14 @@ lowercase. An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks.")) -(defmethod downcase-region ((mark1 climacs-buffer::mark-mixin) - (mark2 climacs-buffer::mark-mixin)) +(defmethod downcase-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) (downcase-buffer-region (buffer mark1) (offset mark1) (offset mark2))) -(defmethod downcase-region ((offset integer) (mark climacs-buffer::mark-mixin)) +(defmethod downcase-region ((offset integer) (mark mark)) (downcase-buffer-region (buffer mark) offset (offset mark))) -(defmethod downcase-region ((mark climacs-buffer::mark-mixin) (offset integer)) +(defmethod downcase-region ((mark mark) (offset integer)) (downcase-buffer-region (buffer mark) (offset mark) offset)) (defun downcase-word (mark &optional (n 1)) @@ -218,15 +217,14 @@ uppercase. An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks.")) -(defmethod upcase-region ((mark1 climacs-buffer::mark-mixin) - (mark2 climacs-buffer::mark-mixin)) +(defmethod upcase-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) (upcase-buffer-region (buffer mark1) (offset mark1) (offset mark2))) -(defmethod upcase-region ((offset integer) (mark climacs-buffer::mark-mixin)) +(defmethod upcase-region ((offset integer) (mark mark)) (upcase-buffer-region (buffer mark) offset (offset mark))) -(defmethod upcase-region ((mark climacs-buffer::mark-mixin) (offset integer)) +(defmethod upcase-region ((mark mark) (offset integer)) (upcase-buffer-region (buffer mark) (offset mark) offset)) (defun upcase-word (mark &optional (n 1)) @@ -255,17 +253,14 @@ An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks.")) -(defmethod capitalize-region ((mark1 climacs-buffer::mark-mixin) - (mark2 climacs-buffer::mark-mixin)) +(defmethod capitalize-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) (capitalize-buffer-region (buffer mark1) (offset mark1) (offset mark2))) -(defmethod capitalize-region ((offset integer) - (mark climacs-buffer::mark-mixin)) +(defmethod capitalize-region ((offset integer) (mark mark)) (capitalize-buffer-region (buffer mark) offset (offset mark))) -(defmethod capitalize-region ((mark climacs-buffer::mark-mixin) - (offset integer)) +(defmethod capitalize-region ((mark mark) (offset integer)) (capitalize-buffer-region (buffer mark) (offset mark) offset)) (defun capitalize-word (mark &optional (n 1)) Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.18 climacs/buffer.lisp:1.19 --- climacs/buffer.lisp:1.18 Thu Jan 13 16:31:11 2005 +++ climacs/buffer.lisp Thu Jan 13 17:52:14 2005 @@ -1,9 +1,11 @@ ;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*- -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson at fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.64 climacs/gui.lisp:1.65 --- climacs/gui.lisp:1.64 Thu Jan 13 16:34:05 2005 +++ climacs/gui.lisp Thu Jan 13 17:52:14 2005 @@ -1,9 +1,11 @@ ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*- -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson at fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.28 climacs/packages.lisp:1.29 --- climacs/packages.lisp:1.28 Thu Jan 13 16:34:05 2005 +++ climacs/packages.lisp Thu Jan 13 17:52:14 2005 @@ -1,7 +1,9 @@ ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public From ejohnson at common-lisp.net Thu Jan 13 19:36:40 2005 From: ejohnson at common-lisp.net (Elliott Johnson) Date: Thu, 13 Jan 2005 20:36:40 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050113193640.53CDD884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19736 Modified Files: gui.lisp Log Message: missing comma befor forward-object's *numeric-argument-marker* argument Date: Thu Jan 13 20:36:29 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.65 climacs/gui.lisp:1.66 --- climacs/gui.lisp:1.65 Thu Jan 13 17:52:14 2005 +++ climacs/gui.lisp Thu Jan 13 20:36:28 2005 @@ -736,7 +736,7 @@ (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*)) -(global-set-key '(:right) `(com-forward-object *numeric-argument-marker*)) +(global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*)) (global-set-key '(:left :control) 'com-backward-word) (global-set-key '(:right :control) 'com-forward-word) (global-set-key '(:home) 'com-beginning-of-line) From rstrandh at common-lisp.net Fri Jan 14 13:07:42 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 14 Jan 2005 14:07:42 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/text-syntax.lisp climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp Message-ID: <20050114130742.6E472884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9425 Modified Files: climacs.asd gui.lisp packages.lisp Added Files: text-syntax.lisp Log Message: First attempt at a syntax for ordinary text. Date: Fri Jan 14 14:07:40 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.9 climacs/climacs.asd:1.10 --- climacs/climacs.asd:1.9 Tue Jan 4 00:55:16 2005 +++ climacs/climacs.asd Fri Jan 14 14:07:39 2005 @@ -56,6 +56,7 @@ "io" "abbrev" "syntax" + "text-syntax" "kill-ring" "gui") Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.66 climacs/gui.lisp:1.67 --- climacs/gui.lisp:1.66 Thu Jan 13 20:36:28 2005 +++ climacs/gui.lisp Fri Jan 14 14:07:39 2005 @@ -600,9 +600,13 @@ (offset point) (offset mark)))) (define-named-command com-set-syntax () - (setf (syntax (win *application-frame*)) - (make-instance (accept 'syntax :prompt "Set Syntax") - :pane (win *application-frame*)))) + (let* ((pane (win *application-frame*)) + (buffer (buffer pane))) + (setf (syntax (win *application-frame*)) + (make-instance (accept 'syntax :prompt "Set Syntax") + :pane pane)) + (setf (offset (low-mark buffer)) 0 + (offset (high-mark buffer)) (size buffer)))) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.29 climacs/packages.lisp:1.30 --- climacs/packages.lisp:1.29 Thu Jan 13 17:52:14 2005 +++ climacs/packages.lisp Fri Jan 14 14:07:39 2005 @@ -68,7 +68,8 @@ (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) - (:export #:syntax #:basic-syntax #:texinfo-syntax + (:export #:syntax #:define-syntax + #:basic-syntax #:texinfo-syntax #:redisplay-pane #:redisplay-with-syntax #:full-redisplay #:page-down #:page-up #:url)) From abakic at common-lisp.net Fri Jan 14 20:44:48 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Fri, 14 Jan 2005 21:44:48 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050114204448.7B31E884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32458 Modified Files: gui.lisp Log Message: Turned *overwrite-mode* variable into a slot of climacs-pane. (Perhaps there should be pane-mixin and buffer-mixin for non-essential slots.) Date: Fri Jan 14 21:44:47 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.67 climacs/gui.lisp:1.68 --- climacs/gui.lisp:1.67 Fri Jan 14 14:07:39 2005 +++ climacs/gui.lisp Fri Jan 14 21:44:47 2005 @@ -6,6 +6,8 @@ ;;; Elliott Johnson (ejohnson at fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) +;;; (c) copyright 2005 by +;;; Aleksandar Bakic (a_bakic at yahoo.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -46,7 +48,8 @@ ;; for dynamic abbrev expansion (original-prefix :initform nil) (prefix-start-offset :initform nil) - (dabbrev-expansion-mark :initform nil))) + (dabbrev-expansion-mark :initform nil) + (overwrite-mode :initform nil))) (defmethod initialize-instance :after ((pane climacs-pane) &rest args) (declare (ignore args)) @@ -108,8 +111,6 @@ (defun display-message (format-string &rest format-args) (apply #'format *standard-input* format-string format-args)) -(defvar *overwrite-mode* nil) - (defun display-info (frame pane) (let* ((win (win frame)) (buf (buffer win)) @@ -117,7 +118,7 @@ (if (needs-saving buf) "**" "--") (name buf) (name (syntax win)) - (if *overwrite-mode* + (if (slot-value win 'overwrite-mode) "Ovwrt" "")))) (princ name-info pane))) @@ -255,13 +256,16 @@ (frame-exit *application-frame*)) (define-named-command com-toggle-overwrite-mode () - (setf *overwrite-mode* (not *overwrite-mode*))) + (let ((win (win *application-frame*))) + (setf (slot-value win 'overwrite-mode) + (not (slot-value win 'overwrite-mode))))) (define-command com-self-insert () - (let ((point (point (win *application-frame*)))) + (let* ((win (win *application-frame*)) + (point (point win))) (unless (constituentp *current-gesture*) (possibly-expand-abbrev point)) - (if (and *overwrite-mode* (not (end-of-line-p point))) + (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point))) (progn (delete-range point) (insert-object point *current-gesture*)) From mvilleneuve at common-lisp.net Sat Jan 15 17:39:30 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sat, 15 Jan 2005 18:39:30 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp Message-ID: <20050115173930.B06B8884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1311 Modified Files: base.lisp buffer.lisp gui.lisp packages.lisp syntax.lisp Log Message: Added tabify/untabify-region Date: Sat Jan 15 18:39:24 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.16 climacs/base.lisp:1.17 --- climacs/base.lisp:1.16 Thu Jan 13 17:52:14 2005 +++ climacs/base.lisp Sat Jan 15 18:39:23 2005 @@ -96,6 +96,15 @@ count (eql (buffer-object buffer offset1) #\Newline) do (incf offset1))) +(defun buffer-display-column-number (buffer offset tab-width) + (let ((line-start-offset (- offset (buffer-column-number buffer offset)))) + (loop with column = 0 + for i from line-start-offset below offset + do (incf column (if (eql (buffer-object buffer i) #\Tab) + (- tab-width (mod column tab-width)) + 1)) + finally (return column)))) + (defgeneric number-of-lines-in-region (mark1 mark2) (:documentation "Return the number of lines (or rather the number of Newline characters) in the region between MARK and MARK2. It is @@ -270,6 +279,72 @@ (let ((offset (offset mark))) (forward-word mark) (capitalize-region offset mark)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Tabify + +(defun tabify-buffer-region (buffer offset1 offset2 tab-width) + (flet ((looking-at-spaces (buffer offset count) + (loop for i from offset + repeat count + unless (char= (buffer-object buffer i) #\Space) + return nil + finally (return t)))) + (loop for offset = offset1 then (1+ offset) + until (>= offset offset2) + do (let* ((column (buffer-display-column-number + buffer offset tab-width)) + (count (- tab-width (mod column tab-width)))) + (when (looking-at-spaces buffer offset count) + (finish-output) + (delete-buffer-range buffer offset count) + (insert-buffer-object buffer offset #\Tab) + (decf offset2 (1- count))))))) + +(defgeneric tabify-region (mark1 mark2 tab-width) + (:documentation "Replace sequences of tab-width spaces with tabs +in the region delimited by mark1 and mark2.")) + +(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width) + (assert (eq (buffer mark1) (buffer mark2))) + (tabify-buffer-region (buffer mark1) (offset mark1) (offset mark2) + tab-width)) + +(defmethod tabify-region ((offset integer) (mark mark) tab-width) + (tabify-buffer-region (buffer mark) offset (offset mark) tab-width)) + +(defmethod tabify-region ((mark mark) (offset integer) tab-width) + (tabify-buffer-region (buffer mark) (offset mark) offset tab-width)) + +(defun untabify-buffer-region (buffer offset1 offset2 tab-width) + (loop for offset = offset1 then (1+ offset) + until (>= offset offset2) + when (char= (buffer-object buffer offset) #\Tab) + do (let* ((column (buffer-display-column-number + buffer offset tab-width)) + (count (- tab-width (mod column tab-width)))) + (delete-buffer-range buffer offset 1) + (loop repeat count + do (insert-buffer-object buffer offset #\Space)) + (incf offset (1- count)) + (finish-output *error-output*) + (incf offset2 (1- count))))) + +(defgeneric untabify-region (mark1 mark2 tab-width) + (:documentation "Replace tabs with tab-width spaces in the region +delimited by mark1 and mark2.")) + +(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width) + (assert (eq (buffer mark1) (buffer mark2))) + (untabify-buffer-region (buffer mark1) (offset mark1) (offset mark2) + tab-width)) + +(defmethod untabify-region ((offset integer) (mark mark) tab-width) + (untabify-buffer-region (buffer mark) offset (offset mark) tab-width)) + +(defmethod untabify-region ((mark mark) (offset integer) tab-width) + (untabify-buffer-region (buffer mark) (offset mark) offset tab-width)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.19 climacs/buffer.lisp:1.20 --- climacs/buffer.lisp:1.19 Thu Jan 13 17:52:14 2005 +++ climacs/buffer.lisp Sat Jan 15 18:39:24 2005 @@ -299,14 +299,30 @@ do (incf offset)) (setf (offset mark) offset))) +(defgeneric buffer-line-number (buffer offset) + (:documentation "Return the line number of the offset. Lines are numbered from zero.")) + +(defmethod buffer-line-number ((buffer standard-buffer) (offset integer)) + (loop for i from 0 below offset + count (eql (buffer-object buffer i) #\Newline))) + +(defgeneric buffer-column-number (buffer offset) + (:documentation "Return the column number of the offset. The column number of an offset is + the number of objects between it and the preceding newline, or + between it and the beginning of the buffer if the offset is on the + first line of the buffer.")) + +(defmethod buffer-column-number ((buffer standard-buffer) (offset integer)) + (loop for i downfrom offset + while (> i 0) + until (eql (buffer-object buffer (1- i)) #\Newline) + count t)) + (defgeneric line-number (mark) (:documentation "Return the line number of the mark. Lines are numbered from zero.")) (defmethod line-number ((mark mark-mixin)) - (loop with buffer = (buffer mark) - with end = (offset mark) - for offset from 0 below end - count (eql (buffer-object buffer offset) #\Newline))) + (buffer-line-number (buffer mark) (offset mark))) (defgeneric column-number (mark) (:documentation "Return the column number of the mark. The column number of a mark is @@ -315,10 +331,7 @@ first line of the buffer.")) (defmethod column-number ((mark mark-mixin)) - (loop for offset downfrom (offset mark) - while (> offset 0) - until (eql (buffer-object (buffer mark) (1- offset)) #\Newline) - count t)) + (buffer-column-number (buffer mark) (offset mark))) (defgeneric insert-buffer-object (buffer offset object) (:documentation "Insert the object at the offset in the buffer. Any left-sticky marks Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.68 climacs/gui.lisp:1.69 --- climacs/gui.lisp:1.68 Fri Jan 14 21:44:47 2005 +++ climacs/gui.lisp Sat Jan 15 18:39:24 2005 @@ -416,6 +416,16 @@ (define-named-command com-capitalize-word () (capitalize-word (point (win *application-frame*)))) +(define-named-command com-tabify-region () + (let ((pane (win *application-frame*))) + (multiple-value-bind (start end) (region-limits pane) + (tabify-region start end (tab-space-count (syntax pane)))))) + +(define-named-command com-untabify-region () + (let ((pane (win *application-frame*))) + (multiple-value-bind (start end) (region-limits pane) + (untabify-region start end (tab-space-count (syntax pane)))))) + (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.30 climacs/packages.lisp:1.31 --- climacs/packages.lisp:1.30 Fri Jan 14 14:07:39 2005 +++ climacs/packages.lisp Sat Jan 15 18:39:24 2005 @@ -33,6 +33,7 @@ #:beginning-of-buffer-p #:end-of-buffer-p #:beginning-of-line #:end-of-line #:beginning-of-line-p #:end-of-line-p + #:buffer-line-number #:buffer-column-number #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence #:insert-object #:insert-sequence @@ -54,6 +55,7 @@ #:delete-word #:backward-delete-word #:upcase-region #:downcase-region #:capitalize-region #:upcase-word #:downcase-word #:capitalize-word + #:tabify-region #:untabify-region #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-lookin-at #:looking-at @@ -69,6 +71,7 @@ (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:define-syntax + #:tabify-mixin #:tab-space-count #:basic-syntax #:texinfo-syntax #:redisplay-pane #:redisplay-with-syntax #:full-redisplay #:page-down #:page-up Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.23 climacs/syntax.lisp:1.24 --- climacs/syntax.lisp:1.23 Thu Jan 13 06:38:41 2005 +++ climacs/syntax.lisp Sat Jan 15 18:39:24 2005 @@ -1,7 +1,9 @@ ;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*- -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -36,6 +38,22 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Tabify + +(defclass tabify-mixin () + ((space-width :initarg nil :reader space-width) + (tab-width :initarg nil :reader tab-width))) + +(defgeneric tab-space-count (tabify)) + +(defmethod tab-space-count (tabify) + 1) + +(defmethod tab-space-count ((tabify tabify-mixin)) + (round (tab-width tabify) (space-width tabify))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Syntax completion (defparameter *syntaxes* '()) @@ -69,14 +87,12 @@ (insert* cache 0 nil) cache)) -(define-syntax basic-syntax ("Basic" (syntax)) +(define-syntax basic-syntax ("Basic" (syntax tabify-mixin)) ((top :reader top) (bot :reader bot) (scan :reader scan) (cursor-x :initform 2) (cursor-y :initform 2) - (space-width :initform nil) - (tab-width :initform nil) (cache :initform (make-cache)))) (defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key pane) From rstrandh at common-lisp.net Sat Jan 15 19:50:48 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 15 Jan 2005 20:50:48 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/pane.lisp climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp climacs/text-syntax.lisp Message-ID: <20050115195048.3FA6A884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8063 Modified Files: climacs.asd gui.lisp packages.lisp syntax.lisp text-syntax.lisp Added Files: pane.lisp Log Message: Did a major overhaul of the syntax facility. The previous functionality is now divided into three parts: the first one is the real syntax, associated with the buffer instead of with the pane. The second part is the cache management, now associated with the pane instead of with the syntax. The third part is a CLIM view, associated with the pane, which determines presentation parameters such as highlighting. modified the tabify/untabify code so that the space-width and tab-width are no longer in the syntax, but in the view. Factored out the climacs pane and displaying of text in the pane into a new file, pane.lisp. Date: Sat Jan 15 20:50:44 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.10 climacs/climacs.asd:1.11 --- climacs/climacs.asd:1.10 Fri Jan 14 14:07:39 2005 +++ climacs/climacs.asd Sat Jan 15 20:50:43 2005 @@ -58,6 +58,7 @@ "syntax" "text-syntax" "kill-ring" + "pane" "gui") #+asdf Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.69 climacs/gui.lisp:1.70 --- climacs/gui.lisp:1.69 Sat Jan 15 18:39:24 2005 +++ climacs/gui.lisp Sat Jan 15 20:50:43 2005 @@ -28,20 +28,8 @@ (in-package :climacs-gui) -(defclass filename-mixin () - ((filename :initform nil :accessor filename))) - -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin) - ((needs-saving :initform nil :accessor needs-saving)) - (:default-initargs :name "*scratch*")) - - -(defclass climacs-pane (application-pane) - ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) - (point :initform nil :initarg :point :reader point) - (syntax :initarg :syntax :accessor syntax) - (mark :initform nil :initarg :mark :reader mark) - ;; allows a certain number of commands to have some minimal memory +(defclass extended-pane (climacs-pane) + (;; allows a certain number of commands to have some minimal memory (previous-command :initform nil :accessor previous-command) ;; for next-line and previous-line commands (goal-column :initform nil) @@ -51,17 +39,6 @@ (dabbrev-expansion-mark :initform nil) (overwrite-mode :initform nil))) -(defmethod initialize-instance :after ((pane climacs-pane) &rest args) - (declare (ignore args)) - (with-slots (buffer point syntax mark) pane - (when (null point) - (setf point (make-instance 'standard-right-sticky-mark - :buffer buffer))) - (when (null mark) - (setf mark (make-instance 'standard-right-sticky-mark - :buffer buffer))) - (setf syntax (make-instance 'texinfo-syntax :pane pane)))) - (defclass minibuffer-pane (application-pane) ()) (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args) @@ -71,7 +48,7 @@ (define-application-frame climacs () ((win :reader win)) (:panes - (win (make-pane 'climacs-pane + (win (make-pane 'extended-pane :width 900 :height 400 :name 'win :incremental-redisplay t @@ -99,6 +76,11 @@ info))) (:top-level (climacs-top-level))) +(defmethod redisplay-frame-panes :before ((frame climacs) &rest args) + (declare (ignore args)) + (let ((buffer (buffer (win frame)))) + (update-syntax buffer (syntax buffer)))) + (defmethod redisplay-frame-panes :after ((frame climacs) &rest args) (declare (ignore args)) (clear-modify (buffer (win frame)))) @@ -117,7 +99,7 @@ (name-info (format nil " ~a ~a Syntax: ~a ~a" (if (needs-saving buf) "**" "--") (name buf) - (name (syntax win)) + (name (syntax buf)) (if (slot-value win 'overwrite-mode) "Ovwrt" "")))) @@ -242,10 +224,9 @@ (redisplay-frame-panes frame)))) (defun region-limits (pane) - (with-slots (point mark) pane - (if (< (offset mark) (offset point)) - (values mark point) - (values point mark)))) + (if (mark< (mark pane) (point pane)) + (values (mark pane) (point pane)) + (values (point pane) (mark pane)))) (defmacro define-named-command (command-name args &body body) `(define-climacs-command ,(if (listp command-name) @@ -419,12 +400,12 @@ (define-named-command com-tabify-region () (let ((pane (win *application-frame*))) (multiple-value-bind (start end) (region-limits pane) - (tabify-region start end (tab-space-count (syntax pane)))))) + (tabify-region start end (tab-space-count (stream-default-view pane)))))) (define-named-command com-untabify-region () (let ((pane (win *application-frame*))) (multiple-value-bind (start end) (region-limits pane) - (untabify-region start end (tab-space-count (syntax pane)))))) + (untabify-region start end (tab-space-count (stream-default-view pane)))))) (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) @@ -518,20 +499,20 @@ (define-named-command com-find-file () (let ((filename (accept 'completable-pathname - :prompt "Find File"))) - (with-slots (buffer point syntax) (win *application-frame*) - (setf buffer (make-instance 'climacs-buffer) - point (make-instance 'standard-right-sticky-mark :buffer buffer) - syntax (make-instance 'texinfo-syntax :pane (win *application-frame*))) - (with-open-file (stream filename :direction :input :if-does-not-exist :create) - (input-from-stream stream buffer 0)) - (setf (filename buffer) filename - (name buffer) (pathname-filename filename) - (needs-saving buffer) nil) - (beginning-of-buffer point) - ;; this one is needed so that the buffer modification protocol - ;; resets the low and high marks after redisplay - (redisplay-frame-panes *application-frame*)))) + :prompt "Find File")) + (buffer (make-instance 'climacs-buffer)) + (pane (win *application-frame*))) + (setf (buffer (win *application-frame*)) buffer) + (setf (syntax buffer) (make-instance 'basic-syntax)) + (with-open-file (stream filename :direction :input :if-does-not-exist :create) + (input-from-stream stream buffer 0)) + (setf (filename buffer) filename + (name buffer) (pathname-filename filename) + (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*))) (define-named-command com-save-buffer () (let* ((buffer (buffer (win *application-frame*))) @@ -569,11 +550,11 @@ (define-named-command com-page-down () (let ((pane (win *application-frame*))) - (page-down pane (syntax pane)))) + (page-down pane))) (define-named-command com-page-up () (let ((pane (win *application-frame*))) - (page-up pane (syntax pane)))) + (page-up pane))) (define-named-command com-end-of-buffer () (end-of-buffer (point (win *application-frame*)))) @@ -605,20 +586,19 @@ (accept 'url :prompt "Browse URL")) (define-named-command com-set-mark () - (with-slots (point mark) (win *application-frame*) - (setf mark (clone-mark point)))) + (let ((pane (win *application-frame*))) + (setf (mark pane) (clone-mark (point pane))))) (define-named-command com-exchange-point-and-mark () - (with-slots (point mark) (win *application-frame*) - (psetf (offset mark) (offset point) - (offset point) (offset mark)))) + (let ((pane (win *application-frame*))) + (psetf (offset (mark pane)) (offset (point pane)) + (offset (point pane)) (offset (mark pane))))) (define-named-command com-set-syntax () (let* ((pane (win *application-frame*)) (buffer (buffer pane))) - (setf (syntax (win *application-frame*)) - (make-instance (accept 'syntax :prompt "Set Syntax") - :pane pane)) + (setf (syntax buffer) + (make-instance (accept 'syntax :prompt "Set Syntax"))) (setf (offset (low-mark buffer)) 0 (offset (high-mark buffer)) (size buffer)))) @@ -637,9 +617,8 @@ ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () - (with-slots (point mark)(win *application-frame*) - (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)))) - + (let ((pane (win *application-frame*))) + (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane))))) (define-named-command com-rotate-yank () (let* ((pane (win *application-frame*)) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.31 climacs/packages.lisp:1.32 --- climacs/packages.lisp:1.31 Sat Jan 15 18:39:24 2005 +++ climacs/packages.lisp Sat Jan 15 20:50:43 2005 @@ -71,11 +71,8 @@ (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:define-syntax - #:tabify-mixin #:tab-space-count - #:basic-syntax #:texinfo-syntax - #:redisplay-pane #:redisplay-with-syntax #:full-redisplay - #:page-down #:page-up - #:url)) + #:basic-syntax + #:update-syntax)) (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) @@ -83,6 +80,17 @@ #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push)) +(defpackage :climacs-pane + (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev + :climacs-syntax :flexichain) + (:export #:climacs-buffer #:needs-saving #:filename + #:climacs-pane #:point #:mark + #:redisplay-pane #:full-redisplay + #:page-down #:page-up + #:tab-space-count + #:url)) + (defpackage :climacs-gui - (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-kill-ring)) + (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax + :climacs-kill-ring :climacs-pane)) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.24 climacs/syntax.lisp:1.25 --- climacs/syntax.lisp:1.24 Sat Jan 15 18:39:24 2005 +++ climacs/syntax.lisp Sat Jan 15 20:50:43 2005 @@ -20,37 +20,11 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; A `syntax' is a CLOS object that determines how a buffer is to be -;;; rendered. The `redisplay-with-syntax' functions are specialized -;;; on the syntax. - (in-package :climacs-syntax) (defclass syntax (name-mixin) ()) -(defgeneric redisplay-with-syntax (pane syntax)) - -(defun redisplay-pane (pane) - "redisplay the pane according to its syntax" - (redisplay-with-syntax pane (syntax pane))) - -(defgeneric full-redisplay (pane syntax)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Tabify - -(defclass tabify-mixin () - ((space-width :initarg nil :reader space-width) - (tab-width :initarg nil :reader tab-width))) - -(defgeneric tab-space-count (tabify)) - -(defmethod tab-space-count (tabify) - 1) - -(defmethod tab-space-count ((tabify tabify-mixin)) - (round (tab-width tabify) (space-width tabify))) +(defgeneric update-syntax (buffer syntax)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -82,263 +56,8 @@ ;;; ;;; Basic syntax -(defun make-cache () - (let ((cache (make-instance 'standard-flexichain))) - (insert* cache 0 nil) - cache)) - -(define-syntax basic-syntax ("Basic" (syntax tabify-mixin)) - ((top :reader top) - (bot :reader bot) - (scan :reader scan) - (cursor-x :initform 2) - (cursor-y :initform 2) - (cache :initform (make-cache)))) - -(defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key pane) - (declare (ignore args)) - (let ((buffer (buffer pane))) - (with-slots (top bot scan space-width tab-width) syntax - (setf top (make-instance 'standard-left-sticky-mark :buffer buffer) - bot (make-instance 'standard-right-sticky-mark :buffer buffer)) - (let* ((medium (sheet-medium pane)) - (style (medium-text-style medium))) - (setf space-width (text-style-width style medium) - tab-width (* 8 space-width)))))) - -(define-presentation-type url () - :inherit-from 'string) - -(defgeneric present-contents (contents pane syntax)) - -(defmethod present-contents (contents pane (syntax basic-syntax)) - (unless (null contents) - (present contents - (if (and (>= (length contents) 7) (string= (subseq contents 0 7) "http://")) - 'url - 'string) - :stream pane))) - -(defgeneric display-line (pane syntax line)) - -(defmethod display-line (pane (syntax basic-syntax) line) - (let ((saved-index nil) - (id 0)) - (flet ((output-word (index) - (unless (null saved-index) - (let ((contents (coerce (subseq line saved-index index) 'string))) - (updating-output (pane :unique-id (incf id) - :cache-value contents - :cache-test #'string=) - (present-contents contents pane syntax))) - (setf saved-index nil)))) - (with-slots (bot scan cursor-x cursor-y space-width tab-width) syntax - (loop for index from 0 - for obj across line - when (mark= scan (point pane)) - do (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x (+ x (if (null saved-index) - 0 - (* space-width (- index saved-index)))) - cursor-y y)) - do (cond ((eql obj #\Space) - (output-word index) - (stream-increment-cursor-position pane space-width 0)) - ((eql obj #\Tab) - (output-word index) - (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0))) - ((constituentp obj) - (when (null saved-index) - (setf saved-index index))) - ((characterp obj) - (output-word index) - (updating-output (pane :unique-id (incf id) - :cache-value obj) - (present obj))) - (t - (output-word index) - (updating-output (pane :unique-id (incf id) - :cache-value obj - :cache-test #'eq) - (present obj)))) - (incf scan) - finally (output-word index) - (when (mark= scan (point pane)) - (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x x - cursor-y y))) - (terpri pane) - (incf scan)))))) - -(defgeneric fill-cache (pane syntax) - (:documentation "fill nil cache entries from the buffer")) - -(defmethod fill-cache (pane (syntax basic-syntax)) - (with-slots (top bot cache) syntax - (let ((mark1 (clone-mark top)) - (mark2 (clone-mark top))) - (loop for line from 0 below (nb-elements cache) - do (beginning-of-line mark1) - (end-of-line mark2) - when (null (element* cache line)) - do (setf (element* cache line) (region-to-sequence mark1 mark2)) - unless (end-of-buffer-p mark2) - do (setf (offset mark1) (1+ (offset mark2)) - (offset mark2) (offset mark1)))))) - -(defun nb-lines-in-pane (pane) - (let* ((medium (sheet-medium pane)) - (style (medium-text-style medium)) - (height (text-style-height style medium))) - (multiple-value-bind (x y w h) (bounding-rectangle* pane) - (declare (ignore x y w)) - (max 1 (floor h (+ height (stream-vertical-spacing pane))))))) - -;;; make the region on display fit the size of the pane as closely as -;;; possible by adjusting bot leaving top intact. Also make the cache -;;; size fit the size of the region on display. -(defun adjust-cache-size-and-bot (pane syntax) - (let ((nb-lines-in-pane (nb-lines-in-pane pane))) - (with-slots (top bot cache) syntax - (setf (offset bot) (offset top)) - (loop until (end-of-buffer-p bot) - repeat (1- nb-lines-in-pane) - do (forward-object bot) - (end-of-line bot)) - (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) - (loop repeat (- (nb-elements cache) nb-lines-on-display) - do (pop-end cache)) - (loop repeat (- nb-lines-on-display (nb-elements cache)) - do (push-end cache nil)))))) - -;;; put all-nil entries in the cache -(defun empty-cache (cache) - (loop for i from 0 below (nb-elements cache) - do (setf (element* cache i) nil))) - -;;; empty the cache and try to put point close to the middle -;;; of the pane by moving top half a pane-size up. -(defun reposition-window (pane syntax) - (let ((nb-lines-in-pane (nb-lines-in-pane pane))) - (with-slots (top bot cache) syntax - (empty-cache cache) - (setf (offset top) (offset (point pane))) - (loop do (beginning-of-line top) - repeat (floor nb-lines-in-pane 2) - until (beginning-of-buffer-p top) - do (decf (offset top)) - (beginning-of-line top))))) - -;;; Make the cache reflect the contents of the buffer starting at top, -;;; trying to preserve contents as much as possible, and inserting a -;;; nil entry where buffer contents is unknonwn. The size of the -;;; cache size at the end may be smaller than, equal to, or greater -;;; than the number of lines in the pane. -(defun adjust-cache (pane syntax) - (let* ((buffer (buffer pane)) - (high-mark (high-mark buffer)) - (low-mark (low-mark buffer)) - (nb-lines-in-pane (nb-lines-in-pane pane))) - (with-slots (top bot cache) syntax - (beginning-of-line top) - (end-of-line bot) - (if (or (mark< (point pane) top) - (>= (number-of-lines-in-region top (point pane)) nb-lines-in-pane) - (and (mark< low-mark top) - (>= (number-of-lines-in-region top high-mark) (nb-elements cache)))) - (reposition-window pane syntax) - (when (mark>= high-mark low-mark) - (let* ((n1 (number-of-lines-in-region top low-mark)) - (n2 (1+ (number-of-lines-in-region low-mark high-mark))) - (n3 (number-of-lines-in-region high-mark bot)) - (diff (- (+ n1 n2 n3) (nb-elements cache)))) - (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20)) - (setf (offset bot) (offset top)) - (end-of-line bot) - (loop for i from n1 below (nb-elements cache) - do (setf (element* cache i) nil))) - ((>= diff 0) - (loop repeat diff do (insert* cache n1 nil)) - (loop for i from (+ n1 diff) below (+ n1 n2) - do (setf (element* cache i) nil))) - (t - (loop repeat (- diff) do (delete* cache n1)) - (loop for i from n1 below (+ n1 n2) - do (setf (element* cache i) nil))))))))) - (adjust-cache-size-and-bot pane syntax)) - -(defun page-down (pane syntax) - (adjust-cache pane syntax) - (with-slots (top bot cache) syntax - (when (mark> (size (buffer bot)) bot) - (empty-cache cache) - (setf (offset top) (offset bot)) - (beginning-of-line top) - (setf (offset (point pane)) (offset top))))) - -(defun page-up (pane syntax) - (adjust-cache pane syntax) - (with-slots (top bot cache) syntax - (when (> (offset top) 0) - (let ((nb-lines-in-region (number-of-lines-in-region top bot))) - (setf (offset bot) (offset top)) - (end-of-line bot) - (loop repeat nb-lines-in-region - while (> (offset top) 0) - do (decf (offset top)) - (beginning-of-line top)) - (setf (offset (point pane)) (offset top)) - (adjust-cache pane syntax) - (setf (offset (point pane)) (offset bot)) - (beginning-of-line (point pane)) - (empty-cache cache))))) - -(defmethod redisplay-with-syntax (pane (syntax basic-syntax)) - (let* ((medium (sheet-medium pane)) - (style (medium-text-style medium)) - (height (text-style-height style medium))) - (with-slots (top bot scan cache cursor-x cursor-y) syntax - (adjust-cache pane syntax) - (fill-cache pane syntax) - (loop with start-offset = (offset top) - for id from 0 below (nb-elements cache) - do (setf scan start-offset) - (updating-output - (pane :unique-id id - :cache-value (if (<= start-offset - (offset (point pane)) - (+ start-offset (length (element* cache id)))) - (cons nil nil) - (element* cache id)) - :cache-test #'eq) - (display-line pane syntax (element* cache id))) - (incf start-offset (1+ (length (element* cache id))))) - (when (mark= scan (point pane)) - (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x x - cursor-y y))) - (updating-output (pane :unique-id -1) - (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink +red+))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Texinfo syntax - -(define-syntax texinfo-syntax ("Texinfo" (basic-syntax)) ()) - -(define-presentation-type texinfo-command () - :inherit-from 'string) - -(defmethod present-contents (contents pane (syntax texinfo-syntax)) - (unless (null contents) - (if (char= (aref contents 0) #\@) - (with-drawing-options (pane :ink +red+) - (present contents 'texinfo-command :stream pane)) - (present contents 'string :stream pane)))) - +(define-syntax basic-syntax ("Basic" (syntax)) + ()) +(defmethod update-syntax (buffer (syntax basic-syntax)) + nil) Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.1 climacs/text-syntax.lisp:1.2 --- climacs/text-syntax.lisp:1.1 Fri Jan 14 14:07:39 2005 +++ climacs/text-syntax.lisp Sat Jan 15 20:50:43 2005 @@ -47,9 +47,8 @@ (define-syntax text-syntax ("Text" (basic-syntax)) ((paragraphs :initform (make-instance 'standard-flexichain)))) -(defmethod redisplay-with-syntax :before (pane (syntax text-syntax)) - (let* ((buffer (buffer pane)) - (high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer))) +(defmethod update-syntax (buffer (syntax text-syntax)) + (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer))) (low-offset (max (- (offset (low-mark buffer)) 3) 0))) (with-slots (paragraphs) syntax (let* ((nb-paragraphs (nb-elements paragraphs)) From rstrandh at common-lisp.net Sat Jan 15 21:35:57 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 15 Jan 2005 22:35:57 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/text-syntax.lisp Message-ID: <20050115213557.2CEAF884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv13600 Modified Files: gui.lisp packages.lisp text-syntax.lisp Log Message: Implemented beginning-of-paragraph and end-of-paragraph, the first commands to exploit a syntax, in this case text-syntax. Date: Sat Jan 15 22:35:54 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.70 climacs/gui.lisp:1.71 --- climacs/gui.lisp:1.70 Sat Jan 15 20:50:43 2005 +++ climacs/gui.lisp Sat Jan 15 22:35:53 2005 @@ -684,6 +684,18 @@ (setf (offset dabbrev-expansion-mark) offset)))) (move)))))))) +(define-named-command com-beginning-of-paragraph () + (let* ((pane (win *application-frame*)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (beginning-of-paragraph point syntax))) + +(define-named-command com-end-of-paragraph () + (let* ((pane (win *application-frame*)) + (point (point pane)) + (syntax (syntax (buffer pane)))) + (end-of-paragraph point syntax))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Global command table @@ -729,6 +741,8 @@ (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) (global-set-key '(#\/ :meta) 'com-dabbrev-expand) +(global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph) +(global-set-key '(#\e :control :meta) 'com-end-of-paragraph) (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.32 climacs/packages.lisp:1.33 --- climacs/packages.lisp:1.32 Sat Jan 15 20:50:43 2005 +++ climacs/packages.lisp Sat Jan 15 22:35:53 2005 @@ -72,7 +72,8 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:define-syntax #:basic-syntax - #:update-syntax)) + #:update-syntax + #:beginning-of-paragraph #:end-of-paragraph)) (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.2 climacs/text-syntax.lisp:1.3 --- climacs/text-syntax.lisp:1.2 Sat Jan 15 20:50:43 2005 +++ climacs/text-syntax.lisp Sat Jan 15 22:35:53 2005 @@ -90,3 +90,37 @@ :buffer buffer :offset offset)) (incf pos1)) (t nil))))))) + +(defgeneric beginning-of-paragraph (mark text-syntax)) + +(defmethod beginning-of-paragraph (mark (syntax text-syntax)) + (with-slots (paragraphs) syntax + (let* ((nb-paragraphs (nb-elements paragraphs)) + (pos2 nb-paragraphs) + (pos1 0) + (offset (offset mark))) + (loop until (= pos1 pos2) + do (if (mark>= (element* paragraphs (floor (+ pos1 pos2) 2)) offset) + (setf pos2 (floor (+ pos1 pos2) 2)) + (setf pos1 (floor (+ pos1 1 pos2) 2)))) + (when (> pos1 0) + (setf (offset mark) + (if (typep (element* paragraphs (1- pos1)) 'right-sticky-mark) + (offset (element* paragraphs (- pos1 2))) + (offset (element* paragraphs (1- pos1))))))))) + +(defmethod end-of-paragraph (mark (syntax text-syntax)) + (with-slots (paragraphs) syntax + (let* ((nb-paragraphs (nb-elements paragraphs)) + (pos2 nb-paragraphs) + (pos1 0) + (offset (offset mark))) + (loop until (= pos1 pos2) + do (if (mark<= (element* paragraphs (floor (+ pos1 pos2) 2)) offset) + (setf pos1 (floor (+ pos1 1 pos2) 2)) + (setf pos2 (floor (+ pos1 pos2) 2)))) + (when (< pos1 nb-paragraphs) + (setf (offset mark) + (if (typep (element* paragraphs pos1) 'left-sticky-mark) + (offset (element* paragraphs (1+ pos1))) + (offset (element* paragraphs pos1)))))))) From abakic at common-lisp.net Sat Jan 15 23:13:49 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 16 Jan 2005 00:13:49 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer.lisp Message-ID: <20050115231349.C8E6A884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18415 Modified Files: buffer.lisp Log Message: Minor bug fixes. Date: Sun Jan 16 00:13:48 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.20 climacs/buffer.lisp:1.21 --- climacs/buffer.lisp:1.20 Sat Jan 15 18:39:24 2005 +++ climacs/buffer.lisp Sun Jan 16 00:13:46 2005 @@ -95,6 +95,8 @@ (defmethod initialize-instance :after ((mark left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) + (assert (<= 0 offset (size (buffer mark))) () + (make-condition 'no-such-offset :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-flexicursor :chain (slot-value (buffer mark) 'contents) @@ -103,6 +105,8 @@ (defmethod initialize-instance :after ((mark right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) + (assert (<= 0 offset (size (buffer mark))) () + (make-condition 'no-such-offset :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-flexicursor :chain (slot-value (buffer mark) 'contents) @@ -398,7 +402,7 @@ (defmethod delete-region ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) - (when (> (offset mark1) (offset mark2)) + (when (> (offset mark2) (offset mark1)) (delete-buffer-range (buffer mark1) (offset mark1) (- (offset mark2) (offset mark1))))) From abakic at common-lisp.net Sat Jan 15 23:20:23 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 16 Jan 2005 00:20:23 +0100 (CET) Subject: [climacs-cvs] CVS update: Directory change: climacs/testing Message-ID: <20050115232023.86137884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs/testing In directory common-lisp.net:/tmp/cvs-serv19164/testing Log Message: Directory /project/climacs/cvsroot/climacs/testing added to the repository Date: Sun Jan 16 00:20:22 2005 Author: abakic New directory climacs/testing added From abakic at common-lisp.net Sat Jan 15 23:23:47 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 16 Jan 2005 00:23:47 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp climacs/climacs.asd Message-ID: <20050115232347.B9773884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19214 Modified Files: climacs.asd Added Files: buffer-test.lisp Log Message: Added a regression testing infrastructure and initial tests for code in buffer.lisp. Date: Sun Jan 16 00:23:46 2005 Author: abakic Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.11 climacs/climacs.asd:1.12 --- climacs/climacs.asd:1.11 Sat Jan 15 20:50:43 2005 +++ climacs/climacs.asd Sun Jan 16 00:23:45 2005 @@ -59,7 +59,10 @@ "text-syntax" "kill-ring" "pane" - "gui") + "gui" + ;;---- optional ---- + "testing/rt" + "buffer-test") #+asdf (defmethod asdf:perform :around ((o asdf:compile-op) From abakic at common-lisp.net Sat Jan 15 23:23:54 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 16 Jan 2005 00:23:54 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/testing/rt-doc.txt climacs/testing/rt-original.lisp climacs/testing/rt-test.lisp climacs/testing/rt.lisp Message-ID: <20050115232354.0675C884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs/testing In directory common-lisp.net:/tmp/cvs-serv19214/testing Added Files: rt-doc.txt rt-original.lisp rt-test.lisp rt.lisp Log Message: Added a regression testing infrastructure and initial tests for code in buffer.lisp. Date: Sun Jan 16 00:23:48 2005 Author: abakic From abakic at common-lisp.net Sun Jan 16 00:41:45 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 16 Jan 2005 01:41:45 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp Message-ID: <20050116004145.AEEB9884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23248 Modified Files: buffer-test.lisp Log Message: A bug fix in a test. Date: Sun Jan 16 01:41:44 2005 Author: abakic Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.1 climacs/buffer-test.lisp:1.2 --- climacs/buffer-test.lisp:1.1 Sun Jan 16 00:23:45 2005 +++ climacs/buffer-test.lisp Sun Jan 16 01:41:44 2005 @@ -37,11 +37,11 @@ (deftest standard-buffer-clone-mark.test-1 (flet ((%all-eq (&optional x y) (cond - ((or (null x) (null y) t)) + ((null x) nil) (t (when (eq x y) y)))) (%all-= (&optional x y) (cond - ((or (null x) (null y) t)) + ((null x) nil) (t (when (= x y) y))))) (let* ((buffer (make-instance 'standard-buffer)) (low (slot-value buffer 'low-mark)) @@ -50,13 +50,12 @@ (high2 (clone-mark high)) (low3 (clone-mark high 'standard-left-sticky-mark)) (high3 (clone-mark low 'standard-right-sticky-mark))) - (and (every #'%all-eq + (and (reduce #'%all-eq (list (class-of low) (class-of low2) (class-of low3))) - (every #'%all-eq + (reduce #'%all-eq (list (class-of high) (class-of high2) (class-of high3))) - (every #'%all-= - (list (offset low) (offset low2) (offset low3) - (offset high) (offset high2) (offset high3) 0))))) + (= (offset low) (offset low2) (offset low3) + (offset high) (offset high2) (offset high3) 0)))) t) ;;; NOTE: the current implementation uses vectors wherever sequences are From rstrandh at common-lisp.net Sun Jan 16 06:03:37 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 16 Jan 2005 07:03:37 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp Message-ID: <20050116060337.A01A8884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7449 Modified Files: buffer-test.lisp Log Message: Added eval-when around use-package to avoid symbol conflicts during loading. Date: Sun Jan 16 07:03:36 2005 Author: rstrandh Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.2 climacs/buffer-test.lisp:1.3 --- climacs/buffer-test.lisp:1.2 Sun Jan 16 01:41:44 2005 +++ climacs/buffer-test.lisp Sun Jan 16 07:03:35 2005 @@ -4,8 +4,9 @@ ;;; (in-package :cl-user) -(use-package :rtest) -(use-package :climacs-buffer) +(eval-when (:compile-toplevel :load-toplevel) + (use-package :rtest) + (use-package :climacs-buffer)) (deftest standard-buffer-make-instance.test-1 (let* ((buffer (make-instance 'standard-buffer)) From rstrandh at common-lisp.net Sun Jan 16 14:42:25 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 16 Jan 2005 15:42:25 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp Message-ID: <20050116144225.D5817884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv758 Modified Files: buffer-test.lisp Log Message: Put the buffer test in its own package to prevent symbol collisions. Thanks to Rudi Schlatte. Date: Sun Jan 16 15:42:24 2005 Author: rstrandh Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.3 climacs/buffer-test.lisp:1.4 --- climacs/buffer-test.lisp:1.3 Sun Jan 16 07:03:35 2005 +++ climacs/buffer-test.lisp Sun Jan 16 15:42:23 2005 @@ -3,10 +3,10 @@ ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) ;;; -(in-package :cl-user) -(eval-when (:compile-toplevel :load-toplevel) - (use-package :rtest) - (use-package :climacs-buffer)) +(cl:defpackage :climacs-tests + (:use :rtest :climacs-buffer)) + +(in-package :climacs-tests) (deftest standard-buffer-make-instance.test-1 (let* ((buffer (make-instance 'standard-buffer)) From abakic at common-lisp.net Sun Jan 16 17:58:14 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 16 Jan 2005 18:58:14 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp Message-ID: <20050116175814.93777884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10884 Modified Files: buffer-test.lisp Log Message: One more patch... Sorry for the inconvenience. If testing proves worthwhile, :rtest and :climacs-testing defpackages may be moved to packages.lisp. Date: Sun Jan 16 18:58:13 2005 Author: abakic Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.4 climacs/buffer-test.lisp:1.5 --- climacs/buffer-test.lisp:1.4 Sun Jan 16 15:42:23 2005 +++ climacs/buffer-test.lisp Sun Jan 16 18:58:13 2005 @@ -4,7 +4,7 @@ ;;; (cl:defpackage :climacs-tests - (:use :rtest :climacs-buffer)) + (:use :rtest :climacs-buffer #+cmu :cl)) (in-package :climacs-tests) @@ -19,7 +19,7 @@ (eq (buffer high) buffer))) t) -(deftest standard-buffer-mark-make-instance.test-2 +(deftest standard-buffer-mark-make-instance.test-1 (handler-case (let ((buffer (make-instance 'standard-buffer))) (make-instance 'standard-left-sticky-mark :buffer buffer :offset 1)) @@ -27,7 +27,7 @@ (= (climacs-buffer::condition-offset c) 1))) t) -(deftest standard-buffer-mark-make-instance.test-3 +(deftest standard-buffer-mark-make-instance.test-2 (handler-case (let ((buffer (make-instance 'standard-buffer))) (make-instance 'standard-right-sticky-mark :buffer buffer :offset 1)) @@ -39,11 +39,7 @@ (flet ((%all-eq (&optional x y) (cond ((null x) nil) - (t (when (eq x y) y)))) - (%all-= (&optional x y) - (cond - ((null x) nil) - (t (when (= x y) y))))) + (t (when (eq x y) y))))) (let* ((buffer (make-instance 'standard-buffer)) (low (slot-value buffer 'low-mark)) (high (slot-value buffer 'high-mark)) From abakic at common-lisp.net Sun Jan 16 17:58:16 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 16 Jan 2005 18:58:16 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/testing/rt.lisp Message-ID: <20050116175816.48190884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs/testing In directory common-lisp.net:/tmp/cvs-serv10884/testing Modified Files: rt.lisp Log Message: One more patch... Sorry for the inconvenience. If testing proves worthwhile, :rtest and :climacs-testing defpackages may be moved to packages.lisp. Date: Sun Jan 16 18:58:14 2005 Author: abakic Index: climacs/testing/rt.lisp diff -u climacs/testing/rt.lisp:1.1 climacs/testing/rt.lisp:1.2 --- climacs/testing/rt.lisp:1.1 Sun Jan 16 00:23:47 2005 +++ climacs/testing/rt.lisp Sun Jan 16 18:58:14 2005 @@ -19,7 +19,7 @@ | SOFTWARE. | |----------------------------------------------------------------------------|# -(defpackage #:regression-test +(cl:defpackage #:regression-test (:nicknames #:rtest #-lispworks #:rt) (:use #:cl) (:export #:*do-tests-when-defined* #:*test* #:continue-testing From mvilleneuve at common-lisp.net Sun Jan 16 20:05:03 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sun, 16 Jan 2005 21:05:03 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050116200503.7078B884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17711 Modified Files: base.lisp gui.lisp packages.lisp Log Message: Added delete-indentation Date: Sun Jan 16 21:05:00 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.17 climacs/base.lisp:1.18 --- climacs/base.lisp:1.17 Sat Jan 15 18:39:23 2005 +++ climacs/base.lisp Sun Jan 16 21:04:59 2005 @@ -348,6 +348,21 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Delete indentation + +(defun delete-indentation (mark) + (beginning-of-line mark) + (unless (beginning-of-buffer-p mark) + (loop until (end-of-buffer-p mark) + until (constituentp (object-after mark)) + do (delete-range mark 1)) + (loop until (beginning-of-buffer-p mark) + until (constituentp (object-before mark)) + do (delete-range mark -1)) + (insert-object mark #\Space))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Named objects (defgeneric name (obj)) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.71 climacs/gui.lisp:1.72 --- climacs/gui.lisp:1.71 Sat Jan 15 22:35:53 2005 +++ climacs/gui.lisp Sun Jan 16 21:04:59 2005 @@ -407,6 +407,9 @@ (multiple-value-bind (start end) (region-limits pane) (untabify-region start end (tab-space-count (stream-default-view pane)))))) +(define-named-command com-delete-indentation () + (delete-indentation (point (win *application-frame*)))) + (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.33 climacs/packages.lisp:1.34 --- climacs/packages.lisp:1.33 Sat Jan 15 22:35:53 2005 +++ climacs/packages.lisp Sun Jan 16 21:04:59 2005 @@ -56,6 +56,7 @@ #:upcase-region #:downcase-region #:capitalize-region #:upcase-word #:downcase-word #:capitalize-word #:tabify-region #:untabify-region + #:delete-indentation #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-lookin-at #:looking-at From mvilleneuve at common-lisp.net Sun Jan 16 20:08:56 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sun, 16 Jan 2005 21:08:56 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050116200856.5A7DA884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17758 Modified Files: gui.lisp Log Message: Added key binding for delete-indentation Date: Sun Jan 16 21:08:55 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.72 climacs/gui.lisp:1.73 --- climacs/gui.lisp:1.72 Sun Jan 16 21:04:59 2005 +++ climacs/gui.lisp Sun Jan 16 21:08:54 2005 @@ -741,6 +741,7 @@ (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\m :meta) 'com-back-to-indentation) +(global-set-key '(#\^ :meta) 'com-delete-indentation) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) (global-set-key '(#\/ :meta) 'com-dabbrev-expand) From mvilleneuve at common-lisp.net Sun Jan 16 20:24:09 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sun, 16 Jan 2005 21:24:09 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050116202409.7E2AD884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18562 Modified Files: gui.lisp Log Message: Fixed key binding for delete-indentation Date: Sun Jan 16 21:24:08 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.73 climacs/gui.lisp:1.74 --- climacs/gui.lisp:1.73 Sun Jan 16 21:08:54 2005 +++ climacs/gui.lisp Sun Jan 16 21:24:07 2005 @@ -741,7 +741,7 @@ (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\m :meta) 'com-back-to-indentation) -(global-set-key '(#\^ :meta) 'com-delete-indentation) +(global-set-key '(#\^ :shift :meta) 'com-delete-indentation) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) (global-set-key '(#\/ :meta) 'com-dabbrev-expand) From rstrandh at common-lisp.net Mon Jan 17 07:10:22 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 17 Jan 2005 08:10:22 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp climacs/syntax.lisp Message-ID: <20050117071022.25C97884A5@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18965 Modified Files: gui.lisp pane.lisp syntax.lisp Log Message: implemented full-redisplay (C-l). implemented multi-buffer support, with C-x b bound to the command switch-to-buffer. Buffer completion works as expected. Date: Mon Jan 17 08:10:19 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.74 climacs/gui.lisp:1.75 --- climacs/gui.lisp:1.74 Sun Jan 16 21:24:07 2005 +++ climacs/gui.lisp Mon Jan 17 08:10:19 2005 @@ -46,7 +46,8 @@ (window-clear pane)) (define-application-frame climacs () - ((win :reader win)) + ((win :reader win) + (buffers :initform '() :accessor buffers)) (:panes (win (make-pane 'extended-pane :width 900 :height 400 @@ -183,7 +184,9 @@ command-parser command-unparser partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) - (setf (slot-value frame 'win) (find-pane-named frame 'win)) + (with-slots (win) frame + (setf win (find-pane-named frame 'win)) + (push (buffer win) (buffers frame))) (let ((*standard-output* (find-pane-named frame 'win)) (*standard-input* (find-pane-named frame 'int)) (*print-pretty* nil) @@ -505,6 +508,7 @@ :prompt "Find File")) (buffer (make-instance 'climacs-buffer)) (pane (win *application-frame*))) + (push buffer (buffers *application-frame*)) (setf (buffer (win *application-frame*)) buffer) (setf (syntax buffer) (make-instance 'basic-syntax)) (with-open-file (stream filename :direction :input :if-does-not-exist :create) @@ -543,6 +547,31 @@ (needs-saving buffer) nil) (display-message "Wrote: ~a" (filename buffer)))) +(define-presentation-method accept + ((type buffer) stream (view textual-view) &key) + (multiple-value-bind (object success string) + (complete-input stream + (lambda (so-far action) + (complete-from-possibilities + so-far (buffers *application-frame*) '() :action action + :name-key #'name + :value-key #'identity)) + :partial-completers '(#\Space) + :allow-any-input t) + (declare (ignore success string)) + object)) + +(define-named-command com-switch-to-buffer () + (let ((buffer (accept 'buffer + :prompt "Switch to buffer"))) + (setf (buffer (win *application-frame*)) buffer) + (setf (syntax buffer) (make-instance 'basic-syntax)) + (beginning-of-buffer (point (win *application-frame*))) + (full-redisplay (win *application-frame*)))) + +(define-named-command com-full-redisplay () + (full-redisplay (win *application-frame*))) + (define-named-command com-load-file () (let ((filename (accept 'completable-pathname :prompt "Load File"))) @@ -720,6 +749,7 @@ (global-set-key '(#\e :control) 'com-end-of-line) (global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*)) (global-set-key '(#\p :control) 'com-previous-line) +(global-set-key '(#\l :control) 'com-full-redisplay) (global-set-key '(#\n :control) 'com-next-line) (global-set-key '(#\o :control) 'com-open-line) (global-set-key '(#\k :control) 'com-kill-line) @@ -779,6 +809,7 @@ (add-command-to-command-table command 'c-x-climacs-table :keystroke gesture :errorp nil)) +(c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\l :control) 'com-load-file) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.1 climacs/pane.lisp:1.2 --- climacs/pane.lisp:1.1 Sat Jan 15 20:50:43 2005 +++ climacs/pane.lisp Mon Jan 17 08:10:19 2005 @@ -67,6 +67,7 @@ (cursor-y :initform 2) (space-width :initform nil) (tab-width :initform nil) + (full-redisplay-p :initform nil :accessor full-redisplay-p) (cache :initform (let ((cache (make-instance 'standard-flexichain))) (insert* cache 0 nil) cache)))) @@ -223,7 +224,7 @@ ;;; of the pane by moving top half a pane-size up. (defun reposition-window (pane) (let ((nb-lines-in-pane (nb-lines-in-pane pane))) - (with-slots (top bot cache) pane + (with-slots (top cache) pane (empty-cache cache) (setf (offset top) (offset (point pane))) (loop do (beginning-of-line top) @@ -296,15 +297,11 @@ (beginning-of-line (point pane)) (empty-cache cache))))) -(defgeneric redisplay-pane (pane)) - -(defmethod redisplay-pane ((pane climacs-pane)) +(defun display-cache (pane) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) (height (text-style-height style medium))) (with-slots (top bot scan cache cursor-x cursor-y) pane - (adjust-cache pane) - (fill-cache pane) (loop with start-offset = (offset top) for id from 0 below (nb-elements cache) do (setf scan start-offset) @@ -327,7 +324,20 @@ (draw-rectangle* pane (1- cursor-x) (- cursor-y (* 0.2 height)) (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink +red+))))) + :ink +red+))))) + +(defgeneric redisplay-pane (pane)) + +(defmethod redisplay-pane ((pane climacs-pane)) + (if (full-redisplay-p pane) + (progn (reposition-window pane) + (adjust-cache-size-and-bot pane) + (setf (full-redisplay-p pane) nil)) + (adjust-cache pane)) + (fill-cache pane) + (display-cache pane)) (defgeneric full-redisplay (pane)) +(defmethod full-redisplay ((pane climacs-pane)) + (setf (full-redisplay-p pane) t)) \ No newline at end of file Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.25 climacs/syntax.lisp:1.26 --- climacs/syntax.lisp:1.25 Sat Jan 15 20:50:43 2005 +++ climacs/syntax.lisp Mon Jan 17 08:10:19 2005 @@ -40,7 +40,7 @@ (define-presentation-method accept ((type syntax) stream (view textual-view) &key) - (multiple-value-bind (pathname success string) + (multiple-value-bind (object success string) (complete-input stream (lambda (so-far action) (complete-from-possibilities @@ -49,8 +49,8 @@ :value-key #'cdr)) :partial-completers '(#\Space) :allow-any-input t) - (declare (ignore success)) - (or pathname string))) + (declare (ignore success string)) + object)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From rstrandh at common-lisp.net Mon Jan 17 08:04:45 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 17 Jan 2005 09:04:45 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050117080445.33325884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21951 Modified Files: gui.lisp Log Message: Create a new buffer when a name that corresponds to no existing buffer is issued by the user when prompted for a buffer name. Date: Mon Jan 17 09:04:45 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.75 climacs/gui.lisp:1.76 --- climacs/gui.lisp:1.75 Mon Jan 17 08:10:19 2005 +++ climacs/gui.lisp Mon Jan 17 09:04:44 2005 @@ -558,8 +558,10 @@ :value-key #'identity)) :partial-completers '(#\Space) :allow-any-input t) - (declare (ignore success string)) - object)) + (declare (ignore success)) + (or object + (car (push (make-instance 'climacs-buffer :name string) + (buffers *application-frame*)))))) (define-named-command com-switch-to-buffer () (let ((buffer (accept 'buffer From rstrandh at common-lisp.net Mon Jan 17 12:26:13 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 17 Jan 2005 13:26:13 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050117122613.8FD26884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2459 Modified Files: gui.lisp Log Message: preliminary multi-window support. Date: Mon Jan 17 13:26:12 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.76 climacs/gui.lisp:1.77 --- climacs/gui.lisp:1.76 Mon Jan 17 09:04:44 2005 +++ climacs/gui.lisp Mon Jan 17 13:26:11 2005 @@ -49,15 +49,29 @@ ((win :reader win) (buffers :initform '() :accessor buffers)) (:panes - (win (make-pane 'extended-pane - :width 900 :height 400 - :name 'win - :incremental-redisplay t - :display-function 'display-win)) + (win (vertically () + (scrolling () + (make-pane 'extended-pane + :width 900 :height 400 + :name 'bla + :incremental-redisplay t + :display-function 'display-win)) + (make-pane 'application-pane + :width 900 :height 20 :max-height 20 :min-height 20 + ::background +gray85+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info))) +; (win (make-pane 'extended-pane +; :width 900 :height 400 +; :name 'bla +; :incremental-redisplay t +; :display-function 'display-win)) (info :application - :width 900 :height 20 :max-height 20 - :name 'info :background +light-gray+ + :width 900 :height 20 :max-height 30 :min-height 30 + :name 'info :background +gray85+ :scroll-bars nil :borders nil :incremental-redisplay t @@ -68,8 +82,7 @@ (:layouts (default (vertically (:scroll-bars nil) - (scrolling (:width 900 :height 400) win) - info + win int)) (without-interactor (vertically (:scroll-bars nil) @@ -180,51 +193,61 @@ (t (unread-gesture gesture :stream stream) (values 1 nil))))) +;;; we know the vbox pane has a scroller pane and an info +;;; pane in it. The scroller pane has a viewport in it, +;;; and the viewport contains the climacs-pane as its only child. +(defun find-climacs-pane (vbox) + (first (sheet-children + (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane)) + (sheet-children + (find-if (lambda (pane) (typep pane 'scroller-pane)) + (sheet-children vbox))))))) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (with-slots (win) frame - (setf win (find-pane-named frame 'win)) - (push (buffer win) (buffers frame))) - (let ((*standard-output* (find-pane-named frame 'win)) - (*standard-input* (find-pane-named frame 'int)) - (*print-pretty* nil) - (*abort-gestures* nil)) - (redisplay-frame-panes frame :force-p t) - (loop (catch 'outer-loop - (loop for gestures = '() - for numarg = (read-numeric-argument :stream *standard-input*) - do (loop (setf *current-gesture* (climacs-read-gesture)) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (return)) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (handler-case - (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf (previous-command *standard-output*) - (if (consp command) - (car command) - command)) - (return))) - (t nil)))) - (let ((buffer (buffer (win frame)))) - (when (modified-p buffer) - (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame))) - (beep) - (let ((buffer (buffer (win frame)))) - (when (modified-p buffer) - (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame)))) + (setf win (find-climacs-pane (find-pane-named frame 'win))) + (push (buffer win) (buffers frame)) + (let ((*standard-output* win) + (*standard-input* (find-pane-named frame 'int)) + (*print-pretty* nil) + (*abort-gestures* nil)) + (redisplay-frame-panes frame :force-p t) + (loop (catch 'outer-loop + (loop for gestures = '() + for numarg = (read-numeric-argument :stream *standard-input*) + do (loop (setf *current-gesture* (climacs-read-gesture)) + (setf gestures (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-table))) + (cond ((not item) + (beep) (return)) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf (previous-command *standard-output*) + (if (consp command) + (car command) + command)) + (return))) + (t nil)))) + (let ((buffer (buffer (win frame)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (redisplay-frame-panes frame))) + (beep) + (let ((buffer (buffer (win frame)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (redisplay-frame-panes frame))))) (defun region-limits (pane) (if (mark< (mark pane) (point pane)) @@ -636,6 +659,36 @@ (setf (offset (low-mark buffer)) 0 (offset (high-mark buffer)) (size buffer)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Commands for splitting windows + +(define-named-command com-split-window-vertically () + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (let* ((pane (win *application-frame*)) + (new-pane (make-pane 'extended-pane + :width 900 :height 400 + :name 'win + :incremental-redisplay t + :display-function 'display-win)) + (parent (sheet-parent (sheet-parent (sheet-parent pane))))) + (setf (buffer new-pane) (buffer pane)) + (sheet-adopt-child parent + (vertically () + (scrolling () new-pane) + (make-pane 'application-pane + :width 900 :height 20 + :max-height 20 :min-height 20 + ::background +gray85+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info))) + (setf (sheet-enabled-p new-pane) t) + (full-redisplay pane) + (full-redisplay new-pane)))) + ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands @@ -811,6 +864,7 @@ (add-command-to-command-table command 'c-x-climacs-table :keystroke gesture :errorp nil)) +(c-x-set-key '(#\2) 'com-split-window-vertically) (c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) From rstrandh at common-lisp.net Mon Jan 17 13:35:56 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 17 Jan 2005 14:35:56 +0100 (CET) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp climacs/syntax.lisp climacs/text-syntax.lisp Message-ID: <20050117133556.EE3BB884A9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6156 Modified Files: gui.lisp pane.lisp syntax.lisp text-syntax.lisp Log Message: Code factoring in text-syntax.lisp (thanks to Rudi Schlatte). Date: Mon Jan 17 14:35:53 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.77 climacs/gui.lisp:1.78 --- climacs/gui.lisp:1.77 Mon Jan 17 13:26:11 2005 +++ climacs/gui.lisp Mon Jan 17 14:35:52 2005 @@ -457,7 +457,9 @@ (let* ((directory-prefix (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) "" - (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory)))) + (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) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.2 climacs/pane.lisp:1.3 --- climacs/pane.lisp:1.2 Mon Jan 17 08:10:19 2005 +++ climacs/pane.lisp Mon Jan 17 14:35:52 2005 @@ -34,7 +34,7 @@ ((space-width :initform nil :reader space-width) (tab-width :initform nil :reader tab-width))) -(defmethod tab-space-count (tabify) +(defmethod tab-space-count ((tabify t)) 1) (defmethod tab-space-count ((tabify tabify-mixin)) @@ -122,6 +122,7 @@ (defgeneric display-line (pane line offset syntax view)) (defmethod display-line (pane line offset (syntax basic-syntax) (view textual-view)) + (declare (ignore offset)) (let ((saved-index nil) (id 0)) (flet ((output-word (index) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.26 climacs/syntax.lisp:1.27 --- climacs/syntax.lisp:1.26 Mon Jan 17 08:10:19 2005 +++ climacs/syntax.lisp Mon Jan 17 14:35:52 2005 @@ -60,4 +60,5 @@ ()) (defmethod update-syntax (buffer (syntax basic-syntax)) + (declare (ignore buffer)) nil) Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.3 climacs/text-syntax.lisp:1.4 --- climacs/text-syntax.lisp:1.3 Sat Jan 15 22:35:53 2005 +++ climacs/text-syntax.lisp Mon Jan 17 14:35:52 2005 @@ -44,6 +44,17 @@ (in-package :climacs-syntax) ;;; Put this in a separate package once it works +(defun index-of-mark-after-offset (flexichain offset) + "Searches for the mark after `offset' in the marks stored in `flexichain'." + (loop with low-position = 0 + with high-position = (nb-elements flexichain) + for middle-position = (floor (+ low-position high-position) 2) + until (= low-position high-position) + do (if (mark>= (element* flexichain middle-position) offset) + (setf high-position middle-position) + (setf low-position (floor (+ low-position 1 high-position) 2))) + finally (return low-position))) + (define-syntax text-syntax ("Text" (basic-syntax)) ((paragraphs :initform (make-instance 'standard-flexichain)))) @@ -51,18 +62,10 @@ (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer))) (low-offset (max (- (offset (low-mark buffer)) 3) 0))) (with-slots (paragraphs) syntax - (let* ((nb-paragraphs (nb-elements paragraphs)) - (pos2 nb-paragraphs) - (pos1 0)) + (let ((pos1 (index-of-mark-after-offset paragraphs low-offset))) ;; start by deleting all syntax marks that are between the low and ;; the high marks - (loop until (= pos1 pos2) - do (cond ((mark< (element* paragraphs (floor (+ pos1 pos2) 2)) - low-offset) - (setf pos1 (floor (+ pos1 1 pos2) 2))) - (t - (setf pos2 (floor (+ pos1 pos2) 2))))) - (loop repeat (- nb-paragraphs pos1) + (loop repeat (- (nb-elements paragraphs) pos1) while (mark<= (element* paragraphs pos1) high-offset) do (delete* paragraphs pos1)) ;; check the zone between low-offset and high-offset for @@ -95,31 +98,23 @@ (defmethod beginning-of-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax - (let* ((nb-paragraphs (nb-elements paragraphs)) - (pos2 nb-paragraphs) - (pos1 0) - (offset (offset mark))) - (loop until (= pos1 pos2) - do (if (mark>= (element* paragraphs (floor (+ pos1 pos2) 2)) offset) - (setf pos2 (floor (+ pos1 pos2) 2)) - (setf pos1 (floor (+ pos1 1 pos2) 2)))) + (let ((pos1 (index-of-mark-after-offset paragraphs (offset mark)))) (when (> pos1 0) (setf (offset mark) (if (typep (element* paragraphs (1- pos1)) 'right-sticky-mark) (offset (element* paragraphs (- pos1 2))) (offset (element* paragraphs (1- pos1))))))))) +(defgeneric end-of-paragraph (mark text-syntax)) + (defmethod end-of-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax - (let* ((nb-paragraphs (nb-elements paragraphs)) - (pos2 nb-paragraphs) - (pos1 0) - (offset (offset mark))) - (loop until (= pos1 pos2) - do (if (mark<= (element* paragraphs (floor (+ pos1 pos2) 2)) offset) - (setf pos1 (floor (+ pos1 1 pos2) 2)) - (setf pos2 (floor (+ pos1 pos2) 2)))) - (when (< pos1 nb-paragraphs) + (let ((pos1 (index-of-mark-after-offset + paragraphs + ;; if mark is at paragraph-end, jump to end of next + ;; paragraph + (1+ (offset mark))))) + (when (< pos1 (nb-elements paragraphs)) (setf (offset mark) (if (typep (element* paragraphs pos1) 'left-sticky-mark) (offset (element* paragraphs (1+ pos1))) From mvilleneuve at common-lisp.net Mon Jan 17 23:10:30 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Mon, 17 Jan 2005 15:10:30 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp climacs/text-syntax.lisp Message-ID: <20050117231030.82E7688026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3050 Modified Files: base.lisp gui.lisp packages.lisp pane.lisp syntax.lisp text-syntax.lisp Log Message: Added indent-line and newline-and-indent (bound to C-j) Date: Mon Jan 17 15:10:25 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.18 climacs/base.lisp:1.19 --- climacs/base.lisp:1.18 Sun Jan 16 12:04:59 2005 +++ climacs/base.lisp Mon Jan 17 15:10:23 2005 @@ -89,6 +89,24 @@ (end-of-line mark) (delete-region offset mark)))) +(defun empty-line-p (mark) + "Check whether the mark is in an empty line." + (and (beginning-of-line-p mark) (end-of-line-p mark))) + +(defun line-indentation (mark tab-width) + "Return the distance from the beginning of the line and the first +constituent character of the line." + (let ((mark2 (clone-mark mark))) + (beginning-of-line mark2) + (loop with indentation = 0 + until (end-of-buffer-p mark2) + as object = (object-after mark2) + while (or (eql object #\Space) (eql object #\Tab)) + do (incf indentation + (if (eql (object-after mark2) #\Tab) tab-width 1)) + (incf (offset mark2)) + finally (return indentation)))) + (defun buffer-number-of-lines-in-region (buffer offset1 offset2) "Helper function for number-of-lines-in-region. Count newline characters in the region between offset1 and offset2" @@ -328,7 +346,6 @@ (loop repeat count do (insert-buffer-object buffer offset #\Space)) (incf offset (1- count)) - (finish-output *error-output*) (incf offset2 (1- count))))) (defgeneric untabify-region (mark1 mark2 tab-width) @@ -348,7 +365,24 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Delete indentation +;;; Indentation + +(defun indent-line (mark indentation tab-width) + "Indent the line containing mark with indentation spaces. Use tabs and spaces +if tab-width is not nil, otherwise use spaces only." + (let ((mark2 (clone-mark mark))) + (beginning-of-line mark2) + (loop until (end-of-buffer-p mark2) + as object = (object-after mark2) + while (or (eql object #\Space) (eql object #\Tab)) + do (delete-range mark2 1)) + (loop until (zerop indentation) + do (cond ((and tab-width (>= indentation tab-width)) + (insert-object mark2 #\Tab) + (decf indentation tab-width)) + (t + (insert-object mark2 #\Space) + (decf indentation)))))) (defun delete-indentation (mark) (beginning-of-line mark) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.78 climacs/gui.lisp:1.79 --- climacs/gui.lisp:1.78 Mon Jan 17 05:35:52 2005 +++ climacs/gui.lisp Mon Jan 17 15:10:23 2005 @@ -433,6 +433,27 @@ (multiple-value-bind (start end) (region-limits pane) (untabify-region start end (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-named-command com-indent-line () + (let* ((pane (win *application-frame*)) + (point (point pane))) + (indent-current-line pane point))) + +(define-named-command com-newline-and-indent () + (let* ((pane (win *application-frame*)) + (point (point pane))) + (insert-object point #\Newline) + (indent-current-line pane point))) + (define-named-command com-delete-indentation () (delete-indentation (point (win *application-frame*)))) @@ -799,7 +820,8 @@ do (global-set-key (code-char code) 'com-self-insert)) (global-set-key #\newline 'com-self-insert) -(global-set-key #\tab 'com-self-insert) +(global-set-key #\tab 'com-indent-line) +(global-set-key '(#\j :control) 'com-newline-and-indent) (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*)) (global-set-key '(#\a :control) 'com-beginning-of-line) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.34 climacs/packages.lisp:1.35 --- climacs/packages.lisp:1.34 Sun Jan 16 12:04:59 2005 +++ climacs/packages.lisp Mon Jan 17 15:10:24 2005 @@ -49,6 +49,8 @@ #:forward-object #:backward-object #:previous-line #:next-line #:open-line #:kill-line + #:empty-line-p + #:line-indentation #:number-of-lines-in-region #:constituentp #:whitespacep #:forward-word #:backward-word @@ -56,6 +58,7 @@ #:upcase-region #:downcase-region #:capitalize-region #:upcase-word #:downcase-word #:capitalize-word #:tabify-region #:untabify-region + #:indent-line #:delete-indentation #:input-from-stream #:output-to-stream #:name-mixin #:name @@ -74,6 +77,7 @@ (:export #:syntax #:define-syntax #:basic-syntax #:update-syntax + #:syntax-line-indentation #:beginning-of-paragraph #:end-of-paragraph)) (defpackage :climacs-kill-ring @@ -90,6 +94,7 @@ #:redisplay-pane #:full-redisplay #:page-down #:page-up #:tab-space-count + #:indent-tabs-mode #:url)) (defpackage :climacs-gui Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.3 climacs/pane.lisp:1.4 --- climacs/pane.lisp:1.3 Mon Jan 17 05:35:52 2005 +++ climacs/pane.lisp Mon Jan 17 15:10:24 2005 @@ -2,6 +2,8 @@ ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh at labri.fr) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -50,9 +52,13 @@ (defclass filename-mixin () ((filename :initform nil :accessor filename))) +;(defgeneric indent-tabs-mode (climacs-buffer)) + (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin) ((needs-saving :initform nil :accessor needs-saving) - (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax)) + (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) + (indent-tabs-mode :initarg indent-tabs-mode :initform t + :accessor indent-tabs-mode)) (:default-initargs :name "*scratch*")) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.27 climacs/syntax.lisp:1.28 --- climacs/syntax.lisp:1.27 Mon Jan 17 05:35:52 2005 +++ climacs/syntax.lisp Mon Jan 17 15:10:24 2005 @@ -26,6 +26,10 @@ (defgeneric update-syntax (buffer syntax)) +(defgeneric syntax-line-indentation (mark tab-width syntax) + (:documentation "Return the correct indentation for the line containing +the mark, according to the specified syntax.")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax completion @@ -62,3 +66,7 @@ (defmethod update-syntax (buffer (syntax basic-syntax)) (declare (ignore buffer)) nil) + +(defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax)) + (declare (ignore mark tab-width)) + 0) Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.4 climacs/text-syntax.lisp:1.5 --- climacs/text-syntax.lisp:1.4 Mon Jan 17 05:35:52 2005 +++ climacs/text-syntax.lisp Mon Jan 17 15:10:24 2005 @@ -2,6 +2,8 @@ ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh at labri.fr) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -119,3 +121,12 @@ (if (typep (element* paragraphs pos1) 'left-sticky-mark) (offset (element* paragraphs (1+ pos1))) (offset (element* paragraphs pos1)))))))) + +(defmethod syntax-line-indentation (mark tab-width (syntax text-syntax)) + (loop with indentation = 0 + with mark2 = (clone-mark mark) + until (beginning-of-buffer-p mark2) + do (previous-line mark2) + (setf indentation (line-indentation mark2 tab-width)) + while (empty-line-p mark2) + finally (return indentation))) From rstrandh at common-lisp.net Tue Jan 18 05:58:28 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 17 Jan 2005 21:58:28 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050118055828.0C01788026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24090 Modified Files: gui.lisp Log Message: Cleaned up some useless code. Introduced a macro `current-window' in preparation for true multi-window support. Please use it now instead of the previous idiom (win *application-frame*). A key sequence such as ESC now works the same way as they keystroke M-. (thanks to Ignas Mikalajunas) Date: Mon Jan 17 21:58:27 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.79 climacs/gui.lisp:1.80 --- climacs/gui.lisp:1.79 Mon Jan 17 15:10:23 2005 +++ climacs/gui.lisp Mon Jan 17 21:58:24 2005 @@ -63,19 +63,6 @@ :borders nil :incremental-redisplay t :display-function 'display-info))) -; (win (make-pane 'extended-pane -; :width 900 :height 400 -; :name 'bla -; :incremental-redisplay t -; :display-function 'display-win)) - - (info :application - :width 900 :height 20 :max-height 30 :min-height 30 - :name 'info :background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info) (int (make-pane 'minibuffer-pane :width 900 :height 20 :max-height 20 :min-height 20 :scroll-bars nil))) @@ -83,21 +70,18 @@ (default (vertically (:scroll-bars nil) win - int)) - (without-interactor - (vertically (:scroll-bars nil) - (scrolling (:width 900 :height 400) win) - info))) + int))) (:top-level (climacs-top-level))) -(defmethod redisplay-frame-panes :before ((frame climacs) &rest args) - (declare (ignore args)) - (let ((buffer (buffer (win frame)))) - (update-syntax buffer (syntax buffer)))) +(defmacro current-window () + `(win *application-frame*)) -(defmethod redisplay-frame-panes :after ((frame climacs) &rest args) +(defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) - (clear-modify (buffer (win frame)))) + (let ((buffer (buffer (win frame)))) + (update-syntax buffer (syntax buffer)) + (call-next-method) + (clear-modify buffer))) (defun climacs () "Starts up a climacs session" @@ -263,12 +247,12 @@ (frame-exit *application-frame*)) (define-named-command com-toggle-overwrite-mode () - (let ((win (win *application-frame*))) + (let ((win (current-window))) (setf (slot-value win 'overwrite-mode) (not (slot-value win 'overwrite-mode))))) (define-command com-self-insert () - (let* ((win (win *application-frame*)) + (let* ((win (current-window)) (point (point win))) (unless (constituentp *current-gesture*) (possibly-expand-abbrev point)) @@ -279,19 +263,19 @@ (insert-object point *current-gesture*)))) (define-named-command com-beginning-of-line () - (beginning-of-line (point (win *application-frame*)))) + (beginning-of-line (point (current-window)))) (define-named-command com-end-of-line () - (end-of-line (point (win *application-frame*)))) + (end-of-line (point (current-window)))) (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects")) - (delete-range (point (win *application-frame*)) count)) + (delete-range (point (current-window)) count)) (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects")) - (delete-range (point (win *application-frame*)) (- count))) + (delete-range (point (current-window)) (- count))) (define-named-command com-transpose-objects () - (let* ((point (point (win *application-frame*)))) + (let* ((point (point (current-window)))) (unless (beginning-of-buffer-p point) (when (end-of-line-p point) (backward-object point)) @@ -302,13 +286,13 @@ (forward-object point))))) (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects")) - (backward-object (point (win *application-frame*)) count)) + (backward-object (point (current-window)) count)) (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects")) - (forward-object (point (win *application-frame*)) count)) + (forward-object (point (current-window)) count)) (define-named-command com-transpose-words () - (let* ((point (point (win *application-frame*)))) + (let* ((point (point (current-window)))) (let (bw1 bw2 ew1 ew2) (backward-word point) (setf bw1 (offset point)) @@ -332,7 +316,7 @@ (forward-word point))))) (define-named-command com-transpose-lines () - (let ((point (point (win *application-frame*)))) + (let ((point (point (current-window)))) (beginning-of-line point) (unless (beginning-of-buffer-p point) (previous-line point)) @@ -355,7 +339,7 @@ (insert-object point #\Newline)))) (define-named-command com-previous-line () - (let* ((win (win *application-frame*)) + (let* ((win (current-window)) (point (point win))) (unless (or (eq (previous-command win) 'com-previous-line) (eq (previous-command win) 'com-next-line)) @@ -363,7 +347,7 @@ (previous-line point (slot-value win 'goal-column)))) (define-named-command com-next-line () - (let* ((win (win *application-frame*)) + (let* ((win (current-window)) (point (point win))) (unless (or (eq (previous-command win) 'com-previous-line) (eq (previous-command win) 'com-next-line)) @@ -371,10 +355,10 @@ (next-line point (slot-value win 'goal-column)))) (define-named-command com-open-line () - (open-line (point (win *application-frame*)))) + (open-line (point (current-window)))) (define-named-command com-kill-line () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane)) (mark (offset point))) (cond ((end-of-buffer-p point) nil) @@ -391,45 +375,45 @@ (delete-region mark point))) (define-named-command com-forward-word () - (forward-word (point (win *application-frame*)))) + (forward-word (point (current-window)))) (define-named-command com-backward-word () - (backward-word (point (win *application-frame*)))) + (backward-word (point (current-window)))) (define-named-command com-delete-word () - (delete-word (point (win *application-frame*)))) + (delete-word (point (current-window)))) (define-named-command com-backward-delete-word () - (backward-delete-word (point (win *application-frame*)))) + (backward-delete-word (point (current-window)))) (define-named-command com-upcase-region () - (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (multiple-value-bind (start end) (region-limits (current-window)) (upcase-region start end))) (define-named-command com-downcase-region () - (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (multiple-value-bind (start end) (region-limits (current-window)) (downcase-region start end))) (define-named-command com-capitalize-region () - (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (multiple-value-bind (start end) (region-limits (current-window)) (capitalize-region start end))) (define-named-command com-upcase-word () - (upcase-word (point (win *application-frame*)))) + (upcase-word (point (current-window)))) (define-named-command com-downcase-word () - (downcase-word (point (win *application-frame*)))) + (downcase-word (point (current-window)))) (define-named-command com-capitalize-word () - (capitalize-word (point (win *application-frame*)))) + (capitalize-word (point (current-window)))) (define-named-command com-tabify-region () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (multiple-value-bind (start end) (region-limits pane) (tabify-region start end (tab-space-count (stream-default-view pane)))))) (define-named-command com-untabify-region () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (multiple-value-bind (start end) (region-limits pane) (untabify-region start end (tab-space-count (stream-default-view pane)))))) @@ -444,24 +428,18 @@ tab-space-count)))) (define-named-command com-indent-line () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane))) (indent-current-line pane point))) (define-named-command com-newline-and-indent () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane))) (insert-object point #\Newline) (indent-current-line pane point))) (define-named-command com-delete-indentation () - (delete-indentation (point (win *application-frame*)))) - -(define-named-command com-toggle-layout () - (setf (frame-current-layout *application-frame*) - (if (eq (frame-current-layout *application-frame*) 'default) - 'without-interactor - 'default))) + (delete-indentation (point (current-window)))) (define-command com-extended-command () (let ((item (accept 'command :prompt "Extended Command"))) @@ -553,9 +531,9 @@ (let ((filename (accept 'completable-pathname :prompt "Find File")) (buffer (make-instance 'climacs-buffer)) - (pane (win *application-frame*))) + (pane (current-window))) (push buffer (buffers *application-frame*)) - (setf (buffer (win *application-frame*)) buffer) + (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance 'basic-syntax)) (with-open-file (stream filename :direction :input :if-does-not-exist :create) (input-from-stream stream buffer 0)) @@ -568,7 +546,7 @@ (redisplay-frame-panes *application-frame*))) (define-named-command com-save-buffer () - (let* ((buffer (buffer (win *application-frame*))) + (let* ((buffer (buffer (current-window))) (filename (or (filename buffer) (accept 'completable-pathname :prompt "Save Buffer to File")))) @@ -585,7 +563,7 @@ (define-named-command com-write-buffer () (let ((filename (accept 'completable-pathname :prompt "Write Buffer to File")) - (buffer (buffer (win *application-frame*)))) + (buffer (buffer (current-window)))) (with-open-file (stream filename :direction :output :if-exists :supersede) (output-to-stream stream buffer 0 (size buffer))) (setf (filename buffer) filename @@ -612,13 +590,13 @@ (define-named-command com-switch-to-buffer () (let ((buffer (accept 'buffer :prompt "Switch to buffer"))) - (setf (buffer (win *application-frame*)) buffer) + (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance 'basic-syntax)) - (beginning-of-buffer (point (win *application-frame*))) - (full-redisplay (win *application-frame*)))) + (beginning-of-buffer (point (current-window))) + (full-redisplay (current-window)))) (define-named-command com-full-redisplay () - (full-redisplay (win *application-frame*))) + (full-redisplay (current-window))) (define-named-command com-load-file () (let ((filename (accept 'completable-pathname @@ -626,56 +604,56 @@ (load filename))) (define-named-command com-beginning-of-buffer () - (beginning-of-buffer (point (win *application-frame*)))) + (beginning-of-buffer (point (current-window)))) (define-named-command com-page-down () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (page-down pane))) (define-named-command com-page-up () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (page-up pane))) (define-named-command com-end-of-buffer () - (end-of-buffer (point (win *application-frame*)))) + (end-of-buffer (point (current-window)))) (define-named-command com-back-to-indentation () - (let ((point (point (win *application-frame*)))) + (let ((point (point (current-window)))) (beginning-of-line point) (loop until (end-of-line-p point) while (whitespacep (object-after point)) do (incf (offset point))))) (define-named-command com-goto-position () - (setf (offset (point (win *application-frame*))) + (setf (offset (point (current-window))) (accept 'integer :prompt "Goto Position"))) (define-named-command com-goto-line () (loop with mark = (make-instance 'standard-right-sticky-mark - :buffer (buffer (win *application-frame*))) + :buffer (buffer (current-window))) do (end-of-line mark) until (end-of-buffer-p mark) repeat (accept 'integer :prompt "Goto Line") do (incf (offset mark)) (end-of-line mark) finally (beginning-of-line mark) - (setf (offset (point (win *application-frame*))) + (setf (offset (point (current-window))) (offset mark)))) (define-named-command com-browse-url () (accept 'url :prompt "Browse URL")) (define-named-command com-set-mark () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (setf (mark pane) (clone-mark (point pane))))) (define-named-command com-exchange-point-and-mark () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (psetf (offset (mark pane)) (offset (point pane)) (offset (point pane)) (offset (mark pane))))) (define-named-command com-set-syntax () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (buffer (buffer pane))) (setf (syntax buffer) (make-instance (accept 'syntax :prompt "Set Syntax"))) @@ -689,7 +667,7 @@ (define-named-command com-split-window-vertically () (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (new-pane (make-pane 'extended-pane :width 900 :height 400 :name 'win @@ -717,21 +695,21 @@ ;; Copies an element from a kill-ring to a buffer at the given offset (define-named-command com-yank () - (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*))) + (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))) ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () - (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (multiple-value-bind (start end) (region-limits (current-window)) (kill-ring-standard-push *kill-ring* (region-to-sequence start end)) (delete-region (offset start) end))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane))))) (define-named-command com-rotate-yank () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane)) (last-yank (kill-ring-yank *kill-ring*))) (if (eq (previous-command pane) @@ -746,19 +724,19 @@ (setf (kill-ring-max-size *kill-ring*) size))) (define-named-command com-search-forward () - (search-forward (point (win *application-frame*)) + (search-forward (point (current-window)) (accept 'string :prompt "Search Forward") :test (lambda (a b) (and (characterp b) (char-equal a b))))) (define-named-command com-search-backward () - (search-backward (point (win *application-frame*)) + (search-backward (point (current-window)) (accept 'string :prompt "Search Backward") :test (lambda (a b) (and (characterp b) (char-equal a b))))) (define-named-command com-dabbrev-expand () - (let* ((win (win *application-frame*)) + (let* ((win (current-window)) (point (point win))) (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) @@ -795,26 +773,40 @@ (move)))))))) (define-named-command com-beginning-of-paragraph () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) (beginning-of-paragraph point syntax))) (define-named-command com-end-of-paragraph () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) (end-of-paragraph point syntax))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Global command table +;;; Global and dead-escape command tables (make-command-table 'global-climacs-table :errorp nil) +(make-command-table 'dead-escape-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-escape" + :menu 'dead-escape-climacs-table + :keystroke '(:escape)) + +(defun dead-escape-set-key (gesture command) + (add-command-to-command-table command 'dead-escape-climacs-table + :keystroke gesture :errorp nil)) + (defun global-set-key (gesture command) (add-command-to-command-table command 'global-climacs-table - :keystroke gesture :errorp nil)) + :keystroke gesture :errorp nil) + (when (and + (listp gesture) + (find :meta gesture)) + (dead-escape-set-key (remove :meta gesture) command))) (loop for code from (char-code #\space) to (char-code #\~) do (global-set-key (code-char code) 'com-self-insert)) @@ -903,7 +895,7 @@ ;;; Some Unicode stuff (define-named-command com-insert-charcode ((code 'integer :prompt "Code point")) - (insert-object (point (win *application-frame*)) (code-char code))) + (insert-object (point (current-window)) (code-char code))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From rstrandh at common-lisp.net Tue Jan 18 06:55:48 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 17 Jan 2005 22:55:48 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050118065548.11C7688026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27111 Modified Files: gui.lisp Log Message: The info pane now displays info about its own associated Climacs pane. Date: Mon Jan 17 22:55:47 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.80 climacs/gui.lisp:1.81 --- climacs/gui.lisp:1.80 Mon Jan 17 21:58:24 2005 +++ climacs/gui.lisp Mon Jan 17 22:55:47 2005 @@ -39,6 +39,9 @@ (dabbrev-expansion-mark :initform nil) (overwrite-mode :initform nil))) +(defclass info-pane (application-pane) + ((climacs-pane :initarg :climacs-pane))) + (defclass minibuffer-pane (application-pane) ()) (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args) @@ -49,20 +52,25 @@ ((win :reader win) (buffers :initform '() :accessor buffers)) (:panes - (win (vertically () - (scrolling () - (make-pane 'extended-pane - :width 900 :height 400 - :name 'bla - :incremental-redisplay t - :display-function 'display-win)) - (make-pane 'application-pane - :width 900 :height 20 :max-height 20 :min-height 20 - ::background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info))) + (win (let* ((extended-pane + (make-pane 'extended-pane + :width 900 :height 400 + :name 'bla + :incremental-redisplay t + :display-function 'display-win)) + (info-pane + (make-pane 'info-pane + :climacs-pane extended-pane + :width 900 :height 20 :max-height 20 :min-height 20 + ::background +gray85+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info))) + (vertically () + (scrolling () + extended-pane) + info-pane))) (int (make-pane 'minibuffer-pane :width 900 :height 20 :max-height 20 :min-height 20 :scroll-bars nil))) @@ -92,16 +100,17 @@ (apply #'format *standard-input* format-string format-args)) (defun display-info (frame pane) - (let* ((win (win frame)) - (buf (buffer win)) - (name-info (format nil " ~a ~a Syntax: ~a ~a" - (if (needs-saving buf) "**" "--") - (name buf) - (name (syntax buf)) - (if (slot-value win 'overwrite-mode) - "Ovwrt" - "")))) - (princ name-info pane))) + (declare (ignore frame)) + (with-slots (climacs-pane) pane + (let* ((buf (buffer climacs-pane)) + (name-info (format nil " ~a ~a Syntax: ~a ~a" + (if (needs-saving buf) "**" "--") + (name buf) + (name (syntax buf)) + (if (slot-value climacs-pane 'overwrite-mode) + "Ovwrt" + "")))) + (princ name-info pane)))) (defun display-win (frame pane) "The display function used by the climacs application frame." @@ -678,7 +687,8 @@ (sheet-adopt-child parent (vertically () (scrolling () new-pane) - (make-pane 'application-pane + (make-pane 'info-pane + :climacs-pane new-pane :width 900 :height 20 :max-height 20 :min-height 20 ::background +gray85+ From rstrandh at common-lisp.net Tue Jan 18 10:11:33 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 18 Jan 2005 02:11:33 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/buffer.lisp climacs/pane.lisp Message-ID: <20050118101133.4AC3F88027@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4423 Modified Files: buffer.lisp pane.lisp Log Message: Added :stream argument to presentations of characters Date: Tue Jan 18 02:11:30 2005 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.21 climacs/buffer.lisp:1.22 --- climacs/buffer.lisp:1.21 Sat Jan 15 15:13:46 2005 +++ climacs/buffer.lisp Tue Jan 18 02:11:29 2005 @@ -451,9 +451,13 @@ (make-condition 'no-such-offset :offset offset1)) (assert (<= 0 offset2 (size buffer)) () (make-condition 'no-such-offset :offset offset2)) - (coerce (loop for offset from offset1 below offset2 - collect (buffer-object buffer offset)) - 'vector)) + (if (< offset1 offset2) + (loop with result = (make-array (- offset2 offset1)) + for offset from offset1 below offset2 + for i upfrom 0 + do (setf (aref result i) (buffer-object buffer offset)) + finally (return result)) + (make-array 0))) (defgeneric object-before (mark) (:documentation "Return the object that is immediately before the mark. If mark is at Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.4 climacs/pane.lisp:1.5 --- climacs/pane.lisp:1.4 Mon Jan 17 15:10:24 2005 +++ climacs/pane.lisp Tue Jan 18 02:11:29 2005 @@ -165,13 +165,13 @@ (output-word index) (updating-output (pane :unique-id (incf id) :cache-value obj) - (present obj))) + (present obj 'character :stream pane))) (t (output-word index) (updating-output (pane :unique-id (incf id) :cache-value obj :cache-test #'eq) - (present obj)))) + (present obj 'character :stream pane)))) (incf scan) finally (output-word index) (when (mark= scan (point pane)) From rstrandh at common-lisp.net Tue Jan 18 13:53:29 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 18 Jan 2005 05:53:29 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp Message-ID: <20050118135329.6D97D88028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16261 Modified Files: base.lisp Log Message: Fixes for indent commands. (thanks to Rudi Schlatte) Date: Tue Jan 18 05:53:28 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.19 climacs/base.lisp:1.20 --- climacs/base.lisp:1.19 Mon Jan 17 15:10:23 2005 +++ climacs/base.lisp Tue Jan 18 05:53:28 2005 @@ -124,11 +124,14 @@ finally (return column)))) (defgeneric number-of-lines-in-region (mark1 mark2) - (:documentation "Return the number of lines (or rather the number of -Newline characters) in the region between MARK and MARK2. It is -acceptable to pass an offset in place of one of the marks")) + (:documentation "Return the number of lines (or rather the +number of Newline characters) in the region between MARK and +MARK2. An error is signaled if the two marks are positioned in +different buffers. It is acceptable to pass an offset in place of +one of the marks")) (defmethod number-of-lines-in-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) (buffer-number-of-lines-in-region (buffer mark1) (offset mark1) (offset mark2))) (defmethod number-of-lines-in-region ((offset integer) (mark mark)) @@ -177,21 +180,15 @@ (defun delete-word (mark) "Delete until the end of the word" - (loop until (end-of-buffer-p mark) - until (constituentp (object-after mark)) - do (delete-range mark)) - (loop until (end-of-buffer-p mark) - while (constituentp (object-after mark)) - do (delete-range mark))) + (let ((mark2 (clone-mark mark))) + (forward-word mark2) + (delete-range mark (- (offset mark2) (offset mark))))) (defun backward-delete-word (mark) "Delete until the beginning of the word" - (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) - do (delete-range mark -1)) - (loop until (beginning-of-buffer-p mark) - while (constituentp (object-before mark)) - do (delete-range mark -1))) + (let ((mark2 (clone-mark mark))) + (backward-word mark2) + (delete-range mark (- (offset mark2) (offset mark))))) (defun previous-word (mark) "Return a freshly allocated sequence, that is word before the mark" @@ -388,10 +385,10 @@ (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (loop until (end-of-buffer-p mark) - until (constituentp (object-after mark)) + while (whitespacep (object-after mark)) do (delete-range mark 1)) (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) + while (whitespacep (object-before mark)) do (delete-range mark -1)) (insert-object mark #\Space))) From abakic at common-lisp.net Tue Jan 18 18:59:55 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Tue, 18 Jan 2005 10:59:55 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/buffer-test.lisp climacs/buffer.lisp climacs/gui.lisp Message-ID: <20050118185955.2105A88028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32053 Modified Files: base.lisp buffer-test.lisp buffer.lisp gui.lisp Log Message: Rudi's change to delete-region (the relative order of marks should not matter) and one more related to insertions at the end of buffer. Date: Tue Jan 18 10:59:52 2005 Author: abakic Index: climacs/base.lisp diff -u climacs/base.lisp:1.20 climacs/base.lisp:1.21 --- climacs/base.lisp:1.20 Tue Jan 18 05:53:28 2005 +++ climacs/base.lisp Tue Jan 18 10:59:51 2005 @@ -182,13 +182,13 @@ "Delete until the end of the word" (let ((mark2 (clone-mark mark))) (forward-word mark2) - (delete-range mark (- (offset mark2) (offset mark))))) + (delete-region mark mark2))) (defun backward-delete-word (mark) "Delete until the beginning of the word" (let ((mark2 (clone-mark mark))) (backward-word mark2) - (delete-range mark (- (offset mark2) (offset mark))))) + (delete-region mark mark2))) (defun previous-word (mark) "Return a freshly allocated sequence, that is word before the mark" Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.5 climacs/buffer-test.lisp:1.6 --- climacs/buffer-test.lisp:1.5 Sun Jan 16 09:58:13 2005 +++ climacs/buffer-test.lisp Tue Jan 18 10:59:51 2005 @@ -4,9 +4,9 @@ ;;; (cl:defpackage :climacs-tests - (:use :rtest :climacs-buffer #+cmu :cl)) + (:use :rtest :climacs-buffer :cl)) -(in-package :climacs-tests) +(cl:in-package :climacs-tests) (deftest standard-buffer-make-instance.test-1 (let* ((buffer (make-instance 'standard-buffer)) @@ -302,13 +302,13 @@ (m2 (make-instance 'standard-left-sticky-mark :buffer buffer :offset 5))) (delete-region m2 m) - (and (= (size buffer) 7) + (and (= (size buffer) 5) (eq (buffer m) buffer) (eq (buffer m2) buffer) (= (offset m) 3) - (= (offset m2) 5) - (buffer-sequence buffer 0 7)))) - "climacs") + (= (offset m2) 3) + (buffer-sequence buffer 0 5)))) + "clics") (deftest standard-buffer-delete-region.test-4 (let ((buffer (make-instance 'standard-buffer))) @@ -318,13 +318,13 @@ (m2 (make-instance 'standard-right-sticky-mark :buffer buffer :offset 5))) (delete-region m2 m) - (and (= (size buffer) 7) + (and (= (size buffer) 5) (eq (buffer m) buffer) (eq (buffer m2) buffer) (= (offset m) 3) - (= (offset m2) 5) - (buffer-sequence buffer 0 7)))) - "climacs") + (= (offset m2) 3) + (buffer-sequence buffer 0 5)))) + "clics") (deftest standard-buffer-delete-region.test-5 (handler-case Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.22 climacs/buffer.lisp:1.23 --- climacs/buffer.lisp:1.22 Tue Jan 18 02:11:29 2005 +++ climacs/buffer.lisp Tue Jan 18 10:59:51 2005 @@ -124,15 +124,9 @@ returned. Otherwise type is the name of a class (subclass of the mark class) to be used as a class of the clone.")) -(defmethod clone-mark ((mark standard-left-sticky-mark) &optional type) - (unless type - (setf type 'standard-left-sticky-mark)) - (make-instance type :buffer (buffer mark) :offset (offset mark))) - -(defmethod clone-mark ((mark standard-right-sticky-mark) &optional type) - (unless type - (setf type 'standard-right-sticky-mark)) - (make-instance type :buffer (buffer mark) :offset (offset mark))) +(defmethod clone-mark ((mark mark) &optional type) + (make-instance (or type (class-of mark)) + :buffer (buffer mark) :offset (offset mark))) (define-condition no-such-offset (simple-error) ((offset :reader condition-offset :initarg :offset)) @@ -392,32 +386,30 @@ (t nil))) (defgeneric delete-region (mark1 mark2) - (:documentation "Delete the objects in the buffer that are after mark1 and before -mark2. An error is signaled if the two marks are positioned in -different buffers. If mark1 is positioned at an offset equal to or -greater than that of mark2, no objects are deleted. If objects are -to be deleted, this function calls delete-buffer-range with the -appropriate arguments. It is acceptable to pass an offset in place -of one of the marks.")) + (:documentation "Delete the objects in the buffer that are +between mark1 and mark2. An error is signaled if the two marks +are positioned in different buffers. It is acceptable to pass an +offset in place of one of the marks.")) (defmethod delete-region ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) - (when (> (offset mark2) (offset mark1)) - (delete-buffer-range (buffer mark1) - (offset mark1) - (- (offset mark2) (offset mark1))))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region ((mark1 mark-mixin) offset2) - (when (> offset2 (offset mark1)) - (delete-buffer-range (buffer mark1) - (offset mark1) - (- offset2 (offset mark1))))) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region (offset1 (mark2 mark-mixin)) - (when (> (offset mark2) offset1) - (delete-buffer-range (buffer mark2) - offset1 - (- (offset mark2) offset1)))) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1)))) (defgeneric buffer-object (buffer offset) (:documentation "Return the object at the offset in the buffer. The first object Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.81 climacs/gui.lisp:1.82 --- climacs/gui.lisp:1.81 Mon Jan 17 22:55:47 2005 +++ climacs/gui.lisp Tue Jan 18 10:59:51 2005 @@ -340,10 +340,10 @@ ;; 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. - (when (progn (end-of-line point) - (end-of-buffer-p point)) + (end-of-line point) + (when (end-of-buffer-p point) (insert-object point #\Newline)) - (next-line point) + (next-line point 0) (insert-sequence point line) (insert-object point #\Newline)))) From abakic at common-lisp.net Tue Jan 18 18:59:56 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Tue, 18 Jan 2005 10:59:56 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi Message-ID: <20050118185956.6BBAD88028@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv32053/Doc Modified Files: climacs-internals.texi Log Message: Rudi's change to delete-region (the relative order of marks should not matter) and one more related to insertions at the end of buffer. Date: Tue Jan 18 10:59:55 2005 Author: abakic Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.7 climacs/Doc/climacs-internals.texi:1.8 --- climacs/Doc/climacs-internals.texi:1.7 Fri Jan 7 22:04:21 2005 +++ climacs/Doc/climacs-internals.texi Tue Jan 18 10:59:54 2005 @@ -307,13 +307,12 @@ @deffn {Generic Function} {delete-region} mark1 mark2 -Delete the objects in the buffer that are after mark1 and before -mark2. An error is signaled if the two marks are positioned in -different buffers. If mark1 is positioned at an offset equal to or -greater than that of mark2, no objects are deleted. If objects are -to be deleted, this function calls delete-buffer-range with the -appropriate arguments. It is acceptable to pass an offset in place -of one of the marks. +Delete the objects in the buffer that are +between mark1 and mark2. An error is signaled if the two marks +are positioned in different buffers. It is acceptable to pass an +offset in place of one of the marks. + +This function calls delete-buffer-range with the appropriate arguments. @end deffn @section Getting objects out of the buffer From rstrandh at common-lisp.net Wed Jan 19 05:21:19 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 18 Jan 2005 21:21:19 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp Message-ID: <20050119052119.87ADD88028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32010 Modified Files: gui.lisp pane.lisp Log Message: implemented preliminary multi-window support. C-x 2 splits the window vertically, C-x splits horizontally. C-x 0 deletes the current window. This is still preliminary code. One annoying problem is that the entire frame gets resized whenever a new window is added or deleted. Date: Tue Jan 18 21:21:17 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.82 climacs/gui.lisp:1.83 --- climacs/gui.lisp:1.82 Tue Jan 18 10:59:51 2005 +++ climacs/gui.lisp Tue Jan 18 21:21:16 2005 @@ -49,7 +49,7 @@ (window-clear pane)) (define-application-frame climacs () - ((win :reader win) + ((windows :accessor windows) (buffers :initform '() :accessor buffers)) (:panes (win (let* ((extended-pane @@ -82,14 +82,16 @@ (:top-level (climacs-top-level))) (defmacro current-window () - `(win *application-frame*)) + `(car (windows *application-frame*))) (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) - (let ((buffer (buffer (win frame)))) - (update-syntax buffer (syntax buffer)) + (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame))))) + (loop for buffer in buffers + do (update-syntax buffer (syntax buffer))) (call-next-method) - (clear-modify buffer))) + (loop for buffer in buffers + do (clear-modify buffer)))) (defun climacs () "Starts up a climacs session" @@ -115,7 +117,7 @@ (defun display-win (frame pane) "The display function used by the climacs application frame." (declare (ignore frame)) - (redisplay-pane pane)) + (redisplay-pane pane (eq pane (car (windows *application-frame*))))) (defun find-gestures (gestures start-table) (loop with table = (find-command-table start-table) @@ -200,10 +202,10 @@ command-parser command-unparser partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) - (with-slots (win) frame - (setf win (find-climacs-pane (find-pane-named frame 'win))) - (push (buffer win) (buffers frame)) - (let ((*standard-output* win) + (with-slots (windows) frame + (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) + (push (buffer (car windows)) (buffers frame)) + (let ((*standard-output* (car windows)) (*standard-input* (find-pane-named frame 'int)) (*print-pretty* nil) (*abort-gestures* nil)) @@ -232,12 +234,12 @@ command)) (return))) (t nil)))) - (let ((buffer (buffer (win frame)))) + (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) (redisplay-frame-panes frame))) (beep) - (let ((buffer (buffer (win frame)))) + (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) (redisplay-frame-panes frame))))) @@ -673,32 +675,106 @@ ;;; ;;; 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))) + (assert (member constellation children)) + (cond ((eq constellation first) + (sheet-disown-child parent constellation) + (let ((new (if vertical-p + (vertically () constellation additional-constellation) + (horizontally () constellation additional-constellation)))) + (sheet-adopt-child parent new) + (reorder-sheets parent (list new second)))) + (t + (sheet-disown-child parent constellation) + (let ((new (if vertical-p + (vertically () constellation additional-constellation) + (horizontally () constellation additional-constellation)))) + (sheet-adopt-child parent new) + (reorder-sheets parent (list first new))))))) + +(defun parent3 (sheet) + (sheet-parent (sheet-parent (sheet-parent sheet)))) + +(defun make-pane-constellation () + "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" + (let* ((extended-pane + (make-pane 'extended-pane + :width 900 :height 400 + :name 'win + :incremental-redisplay t + :display-function 'display-win)) + (vbox + (vertically () + (scrolling () extended-pane) + (make-pane 'info-pane + :climacs-pane extended-pane + :width 900 :height 20 + :max-height 20 :min-height 20 + ::background +gray85+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info)))) + (values vbox extended-pane))) + (define-named-command com-split-window-vertically () (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) - (let* ((pane (current-window)) - (new-pane (make-pane 'extended-pane - :width 900 :height 400 - :name 'win - :incremental-redisplay t - :display-function 'display-win)) - (parent (sheet-parent (sheet-parent (sheet-parent pane))))) - (setf (buffer new-pane) (buffer pane)) - (sheet-adopt-child parent - (vertically () - (scrolling () new-pane) - (make-pane 'info-pane - :climacs-pane new-pane - :width 900 :height 20 - :max-height 20 :min-height 20 - ::background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info))) - (setf (sheet-enabled-p new-pane) t) - (full-redisplay pane) - (full-redisplay new-pane)))) + (multiple-value-bind (vbox new-pane) (make-pane-constellation) + (let* ((current-window (current-window)) + (constellation-root (parent3 current-window))) + (setf (buffer new-pane) (buffer current-window)) + (push new-pane (windows *application-frame*)) + (replace-constellation constellation-root vbox t) + (full-redisplay current-window) + (full-redisplay new-pane))))) + +(define-named-command com-split-window-horizontally () + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (multiple-value-bind (vbox new-pane) (make-pane-constellation) + (let* ((current-window (current-window)) + (constellation-root (parent3 current-window))) + (setf (buffer new-pane) (buffer current-window)) + (push new-pane (windows *application-frame*)) + (replace-constellation constellation-root vbox nil) + (full-redisplay current-window) + (full-redisplay new-pane))))) + +(define-named-command com-other-window () + (setf (windows *application-frame*) + (append (cdr (windows *application-frame*)) + (list (car (windows *application-frame*)))))) + +(define-named-command com-delete-window () + (unless (null (cdr (windows *application-frame*))) + (let* ((constellation (parent3 (current-window))) + (box (sheet-parent constellation)) + (box-children (sheet-children box)) + (other (if (eq constellation (first box-children)) + (second box-children) + (first box-children))) + (parent (sheet-parent box)) + (children (sheet-children parent)) + (first (first children)) + (second (second children))) + (pop (windows *application-frame*)) + (sheet-disown-child box other) + (cond ((eq box first) + (sheet-disown-child parent box) + (sheet-adopt-child parent other) + (reorder-sheets parent (list other second))) + (t + (sheet-disown-child parent box) + (sheet-adopt-child parent other) + (reorder-sheets parent (list first other))))))) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands @@ -890,11 +966,14 @@ (add-command-to-command-table command 'c-x-climacs-table :keystroke gesture :errorp nil)) +(c-x-set-key '(#\0) 'com-delete-window) (c-x-set-key '(#\2) 'com-split-window-vertically) +(c-x-set-key '(#\3) 'com-split-window-horizontally) (c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\l :control) 'com-load-file) +(c-x-set-key '(#\o) 'com-other-window) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.5 climacs/pane.lisp:1.6 --- climacs/pane.lisp:1.5 Tue Jan 18 02:11:29 2005 +++ climacs/pane.lisp Tue Jan 18 21:21:16 2005 @@ -304,7 +304,7 @@ (beginning-of-line (point pane)) (empty-cache cache))))) -(defun display-cache (pane) +(defun display-cache (pane cursor-ink) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) (height (text-style-height style medium))) @@ -331,18 +331,18 @@ (draw-rectangle* pane (1- cursor-x) (- cursor-y (* 0.2 height)) (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink +red+))))) + :ink cursor-ink))))) -(defgeneric redisplay-pane (pane)) +(defgeneric redisplay-pane (pane current-p)) -(defmethod redisplay-pane ((pane climacs-pane)) +(defmethod redisplay-pane ((pane climacs-pane) current-p) (if (full-redisplay-p pane) (progn (reposition-window pane) (adjust-cache-size-and-bot pane) (setf (full-redisplay-p pane) nil)) (adjust-cache pane)) (fill-cache pane) - (display-cache pane)) + (display-cache pane (if current-p +red+ +blue+))) (defgeneric full-redisplay (pane)) From rstrandh at common-lisp.net Wed Jan 19 05:28:38 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 18 Jan 2005 21:28:38 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050119052838.F1CA188028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32062 Modified Files: gui.lisp Log Message: find-file does not create the file if it does not exist. (thanks to Lawrence Mitchell) Date: Tue Jan 18 21:28:38 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.83 climacs/gui.lisp:1.84 --- climacs/gui.lisp:1.83 Tue Jan 18 21:21:16 2005 +++ climacs/gui.lisp Tue Jan 18 21:28:38 2005 @@ -546,8 +546,10 @@ (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance 'basic-syntax)) - (with-open-file (stream filename :direction :input :if-does-not-exist :create) - (input-from-stream stream buffer 0)) + ;; Don't want to create the file if it doesn't exist. + (when (probe-file filename) + (with-open-file (stream filename :direction :input) + (input-from-stream stream buffer 0))) (setf (filename buffer) filename (name buffer) (pathname-filename filename) (needs-saving buffer) nil) From rstrandh at common-lisp.net Wed Jan 19 14:38:50 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 19 Jan 2005 06:38:50 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050119143850.12E0E88027@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27404 Modified Files: gui.lisp Log Message: Implemented keyboard macros, except that there is a bug that do not have time to track down right now, leaving an extra 'e' in the buffer. Date: Wed Jan 19 06:38:48 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.84 climacs/gui.lisp:1.85 --- climacs/gui.lisp:1.84 Tue Jan 18 21:28:38 2005 +++ climacs/gui.lisp Wed Jan 19 06:38:47 2005 @@ -50,7 +50,11 @@ (define-application-frame climacs () ((windows :accessor windows) - (buffers :initform '() :accessor buffers)) + (buffers :initform '() :accessor buffers) + (recordingp :initform nil :accessor recordingp) + (executingp :initform nil :accessor executingp) + (recorded-keys :initform '() :accessor recorded-keys) + (remaining-keys :initform '() :accessor remaining-keys)) (:panes (win (let* ((extended-pane (make-pane 'extended-pane @@ -105,12 +109,15 @@ (declare (ignore frame)) (with-slots (climacs-pane) pane (let* ((buf (buffer climacs-pane)) - (name-info (format nil " ~a ~a Syntax: ~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a ~a ~a" (if (needs-saving buf) "**" "--") (name buf) (name (syntax buf)) (if (slot-value climacs-pane 'overwrite-mode) "Ovwrt" + "") + (if (recordingp *application-frame*) + "Def" "")))) (princ name-info pane)))) @@ -139,8 +146,11 @@ :test #'event-matches-gesture-name-p)) (defun climacs-read-gesture () + (unless (null (remaining-keys *application-frame*)) + (return-from climacs-read-gesture + (pop (remaining-keys *application-frame*)))) (loop for gesture = (read-gesture :stream *standard-input*) - when (event-matches-gesture-name-p gesture '(#\g :control)) + when (event-matches-gesture-name-p gesture '(:keyboard #\g 512)) ; FIXME do (throw 'outer-loop nil) until (or (characterp gesture) (and (typep gesture 'keyboard-event) @@ -154,7 +164,16 @@ :hyper-left :hyper-right :shift-lock :caps-lock :alt-left :alt-right)))))) - finally (return gesture))) + finally (progn (when (recordingp *application-frame*) + (push gesture (recorded-keys *application-frame*))) + (return gesture)))) + +(defun climacs-unread-gesture (gesture stream) + (cond ((recordingp *application-frame*) + (pop (recorded-keys *application-frame*))) + ((executingp *application-frame*) + (push gesture (remaining-keys *application-frame*)))) + (unread-gesture gesture :stream stream)) (defun read-numeric-argument (&key (stream *standard-input*)) (let ((gesture (climacs-read-gesture))) @@ -163,7 +182,7 @@ (loop for gesture = (climacs-read-gesture) while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME do (setf numarg (* 4 numarg)) - finally (unread-gesture gesture :stream stream)) + finally (climacs-unread-gesture gesture stream)) (let ((gesture (climacs-read-gesture))) (cond ((and (characterp gesture) (digit-char-p gesture 10)) @@ -173,19 +192,19 @@ (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) (- (char-code gesture) (char-code #\0)))) - finally (unread-gesture gesture :stream stream) + finally (climacs-unread-gesture gesture stream) (return (values numarg t)))) (t - (unread-gesture gesture :stream stream) + (climacs-unread-gesture gesture stream) (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) (loop for gesture = (climacs-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) - finally (unread-gesture gesture :stream stream) + finally (climacs-unread-gesture gesture stream) (return (values numarg t))))) - (t (unread-gesture gesture :stream stream) + (t (climacs-unread-gesture gesture stream) (values 1 nil))))) ;;; we know the vbox pane has a scroller pane and an info @@ -237,12 +256,16 @@ (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame))) + (when (null (remaining-keys *application-frame*)) + (setf (executingp *application-frame*) nil) + (redisplay-frame-panes frame)))) (beep) (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame))))) + (when (null (remaining-keys *application-frame*)) + (setf (executingp *application-frame*) nil) + (redisplay-frame-panes frame)))))) (defun region-limits (pane) (if (mark< (mark pane) (point pane)) @@ -675,6 +698,25 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Keyboard macros + +(define-named-command com-start-kbd-macro () + (setf (recordingp *application-frame*) t) + (setf (recorded-keys *application-frame*) '())) + +(define-named-command com-end-kbd-macro () + (setf (recordingp *application-frame*) nil) + (setf (recorded-keys *application-frame*) + ;; this won't work if the command was invoked in any old way + (reverse (cddr (recorded-keys *application-frame*))))) + +(define-named-command com-call-last-kbd-macro () + (setf (remaining-keys *application-frame*) + (recorded-keys *application-frame*)) + (setf (executingp *application-frame*) t)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Commands for splitting windows (defun replace-constellation (constellation additional-constellation vertical-p) @@ -971,7 +1013,10 @@ (c-x-set-key '(#\0) 'com-delete-window) (c-x-set-key '(#\2) 'com-split-window-vertically) (c-x-set-key '(#\3) 'com-split-window-horizontally) +(c-x-set-key '(#\() 'com-start-kbd-macro) +(c-x-set-key '(#\)) 'com-end-kbd-macro) (c-x-set-key '(#\b) 'com-switch-to-buffer) +(c-x-set-key '(#\e) 'com-call-last-kbd-macro) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\l :control) 'com-load-file) From abakic at common-lisp.net Thu Jan 20 01:22:21 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Wed, 19 Jan 2005 17:22:21 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/buffer-test.lisp Message-ID: <20050120012221.4ED5288027@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29136 Modified Files: gui.lisp buffer-test.lisp Log Message: A note/comment about macro use and a few buffer performance tests. Date: Wed Jan 19 17:22:20 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.86 climacs/gui.lisp:1.87 --- climacs/gui.lisp:1.86 Wed Jan 19 12:04:39 2005 +++ climacs/gui.lisp Wed Jan 19 17:22:19 2005 @@ -85,7 +85,7 @@ int))) (:top-level (climacs-top-level))) -(defmacro current-window () +(defmacro current-window () ; shouldn't this be an inlined function? --amb `(car (windows *application-frame*))) (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) @@ -284,9 +284,8 @@ (frame-exit *application-frame*)) (define-named-command com-toggle-overwrite-mode () - (let ((win (current-window))) - (setf (slot-value win 'overwrite-mode) - (not (slot-value win 'overwrite-mode))))) + (with-slots (overwrite-mode) (current-window) + (setf overwrite-mode (not overwrite-mode)))) (defun insert-character (char) (let* ((win (current-window)) Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.6 climacs/buffer-test.lisp:1.7 --- climacs/buffer-test.lisp:1.6 Tue Jan 18 10:59:51 2005 +++ climacs/buffer-test.lisp Wed Jan 19 17:22:19 2005 @@ -692,4 +692,118 @@ (error (c) (declare (ignore c)) 'caught)) - caught) \ No newline at end of file + caught) + + +;;;; performance tests + +(defmacro deftimetest (name form &rest results) + `(deftest ,name + (time + (progn + (format t "~&; Performance test ~a" ',name) + ,form)) + , at results)) + +(deftimetest standard-buffer-performance.test-1 + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b 0 #\a) + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-1a + (let ((b (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b 0 #\a) + finally (return b)))) + (loop for i from 0 below 100000 + do (delete-buffer-range b 0 1) + finally (return (size b)))) + 0) + +(deftimetest standard-buffer-performance.test-1b + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (size b) #\a) + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-1ba + (let ((b (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (size b) #\a) + finally (return b)))) + (loop for i from 0 below 100000 + do (delete-buffer-range b 0 1) + finally (return (size b)))) + 0) + +(deftimetest standard-buffer-performance.test-1c + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (floor (size b) 2) #\a) + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-1ca + (let ((b (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (floor (size b) 2) #\a) + finally (return b)))) + (loop for i from 0 below 100000 + do (delete-buffer-range b 0 1) + finally (return (size b)))) + 0) + +(deftimetest standard-buffer-performance.test-1cb + (let ((b (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (floor (size b) 2) #\a) + finally (return b)))) + (loop for i from 0 below 100000 + do (delete-buffer-range b (floor (size b) 2) 1) + finally (return (size b)))) + 0) + +(deftimetest standard-buffer-performance.test-2 + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b 0 "a") + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-2b + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b (size b) "a") + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-2c + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b (floor (size b) 2) "a") + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-3 + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b 0 "abcdefghij") + finally (return (size b))) + 1000000) + +(deftimetest standard-buffer-performance.test-3b + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b (size b) "abcdefghij") + finally (return (size b))) + 1000000) + +(deftimetest standard-buffer-performance.test-3c + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b (floor (size b) 2) "abcdefghij") + finally (return (size b))) + 1000000) \ No newline at end of file From mvilleneuve at common-lisp.net Wed Jan 19 20:04:41 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Wed, 19 Jan 2005 12:04:41 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp Message-ID: <20050119200441.EA5A588027@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12217 Modified Files: base.lisp gui.lisp packages.lisp pane.lisp Log Message: Added auto-fill mode Date: Wed Jan 19 12:04:39 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.21 climacs/base.lisp:1.22 --- climacs/base.lisp:1.21 Tue Jan 18 10:59:51 2005 +++ climacs/base.lisp Wed Jan 19 12:04:39 2005 @@ -114,7 +114,7 @@ count (eql (buffer-object buffer offset1) #\Newline) do (incf offset1))) -(defun buffer-display-column-number (buffer offset tab-width) +(defun buffer-display-column (buffer offset tab-width) (let ((line-start-offset (- offset (buffer-column-number buffer offset)))) (loop with column = 0 for i from line-start-offset below offset @@ -308,7 +308,7 @@ finally (return t)))) (loop for offset = offset1 then (1+ offset) until (>= offset offset2) - do (let* ((column (buffer-display-column-number + do (let* ((column (buffer-display-column buffer offset tab-width)) (count (- tab-width (mod column tab-width)))) (when (looking-at-spaces buffer offset count) @@ -336,8 +336,9 @@ (loop for offset = offset1 then (1+ offset) until (>= offset offset2) when (char= (buffer-object buffer offset) #\Tab) - do (let* ((column (buffer-display-column-number - buffer offset tab-width)) + do (let* ((column (buffer-display-column buffer + offset + tab-width)) (count (- tab-width (mod column tab-width)))) (delete-buffer-range buffer offset 1) (loop repeat count @@ -391,6 +392,37 @@ while (whitespacep (object-before mark)) do (delete-range mark -1)) (insert-object mark #\Space))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Auto fill + +(defun fill-line (mark syntax-line-indentation-function fill-column tab-width) + (let ((begin-mark (clone-mark mark))) + (beginning-of-line begin-mark) + (loop with column = 0 + with walking-mark = (clone-mark begin-mark) + while (mark< walking-mark mark) + as object = (object-after walking-mark) + do (case object + (#\Space + (setf (offset begin-mark) (offset walking-mark)) + (incf column)) + (#\Tab + (setf (offset begin-mark) (offset walking-mark)) + (incf column (- tab-width (mod column tab-width)))) + (t + (incf column))) + (when (>= column fill-column) + (insert-object begin-mark #\Newline) + (incf (offset begin-mark)) + (let ((indentation + (funcall syntax-line-indentation-function begin-mark))) + (indent-line begin-mark indentation tab-width)) + (beginning-of-line begin-mark) + (setf (offset walking-mark) (offset begin-mark)) + (setf column 0)) + (incf (offset walking-mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.85 climacs/gui.lisp:1.86 --- climacs/gui.lisp:1.85 Wed Jan 19 06:38:47 2005 +++ climacs/gui.lisp Wed Jan 19 12:04:39 2005 @@ -109,13 +109,16 @@ (declare (ignore frame)) (with-slots (climacs-pane) pane (let* ((buf (buffer climacs-pane)) - (name-info (format nil " ~a ~a Syntax: ~a ~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a~a~a ~a" (if (needs-saving buf) "**" "--") (name buf) (name (syntax buf)) (if (slot-value climacs-pane 'overwrite-mode) - "Ovwrt" + " Ovwrt" "") + (if (auto-fill-mode buf) + " Fill" + "") (if (recordingp *application-frame*) "Def" "")))) @@ -285,16 +288,37 @@ (setf (slot-value win 'overwrite-mode) (not (slot-value win 'overwrite-mode))))) -(define-command com-self-insert () +(defun insert-character (char) (let* ((win (current-window)) (point (point win))) - (unless (constituentp *current-gesture*) + (unless (constituentp char) (possibly-expand-abbrev point)) (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point))) (progn (delete-range point) - (insert-object point *current-gesture*)) - (insert-object point *current-gesture*)))) + (insert-object point char)) + (insert-object point char)))) + +(define-command com-self-insert () + (insert-character *current-gesture*)) + +(define-command com-self-filling-insert () + (let* ((pane (current-window)) + (buffer (buffer pane))) + (when (auto-fill-mode buffer) + (let* ((fill-column (auto-fill-column buffer)) + (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- (auto-fill-column buffer))) + (fill-line point + (lambda (mark) + (syntax-line-indentation mark tab-width syntax)) + fill-column + tab-width))))) + (insert-character *current-gesture*)) (define-named-command com-beginning-of-line () (beginning-of-line (point (current-window)))) @@ -475,6 +499,10 @@ (define-named-command com-delete-indentation () (delete-indentation (point (current-window)))) +(define-named-command com-auto-fill-mode () + (let ((buffer (buffer (current-window)))) + (setf (auto-fill-mode buffer) (not (auto-fill-mode buffer))))) + (define-command com-extended-command () (let ((item (accept 'command :prompt "Extended Command"))) (execute-frame-command *application-frame* item))) @@ -938,11 +966,12 @@ (find :meta gesture)) (dead-escape-set-key (remove :meta gesture) command))) -(loop for code from (char-code #\space) to (char-code #\~) +(loop for code from (char-code #\!) to (char-code #\~) do (global-set-key (code-char code) 'com-self-insert)) -(global-set-key #\newline 'com-self-insert) -(global-set-key #\tab 'com-indent-line) +(global-set-key #\Space 'com-self-filling-insert) +(global-set-key #\Newline 'com-self-filling-insert) +(global-set-key #\Tab 'com-indent-line) (global-set-key '(#\j :control) 'com-newline-and-indent) (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*)) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.35 climacs/packages.lisp:1.36 --- climacs/packages.lisp:1.35 Mon Jan 17 15:10:24 2005 +++ climacs/packages.lisp Wed Jan 19 12:04:39 2005 @@ -51,6 +51,7 @@ #:open-line #:kill-line #:empty-line-p #:line-indentation + #:buffer-display-column #:number-of-lines-in-region #:constituentp #:whitespacep #:forward-word #:backward-word @@ -60,6 +61,7 @@ #:tabify-region #:untabify-region #:indent-line #:delete-indentation + #:fill-line #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-lookin-at #:looking-at @@ -95,6 +97,7 @@ #:page-down #:page-up #:tab-space-count #:indent-tabs-mode + #:auto-fill-mode #:auto-fill-column #:url)) (defpackage :climacs-gui Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.6 climacs/pane.lisp:1.7 --- climacs/pane.lisp:1.6 Tue Jan 18 21:21:16 2005 +++ climacs/pane.lisp Wed Jan 19 12:04:39 2005 @@ -58,7 +58,9 @@ ((needs-saving :initform nil :accessor needs-saving) (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t - :accessor indent-tabs-mode)) + :accessor indent-tabs-mode) + (auto-fill-mode :initform t :accessor auto-fill-mode) + (auto-fill-column :initform 70 :accessor auto-fill-column)) (:default-initargs :name "*scratch*")) From rstrandh at common-lisp.net Thu Jan 20 06:01:58 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 19 Jan 2005 22:01:58 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050120060158.973F488027@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11314 Modified Files: gui.lisp Log Message: Fixed bug in keyboard macros. Date: Wed Jan 19 22:01:57 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.87 climacs/gui.lisp:1.88 --- climacs/gui.lisp:1.87 Wed Jan 19 17:22:19 2005 +++ climacs/gui.lisp Wed Jan 19 22:01:56 2005 @@ -173,10 +173,12 @@ (defun climacs-unread-gesture (gesture stream) (cond ((recordingp *application-frame*) - (pop (recorded-keys *application-frame*))) + (pop (recorded-keys *application-frame*)) + (unread-gesture gesture :stream stream)) ((executingp *application-frame*) - (push gesture (remaining-keys *application-frame*)))) - (unread-gesture gesture :stream stream)) + (push gesture (remaining-keys *application-frame*))) + (t + (unread-gesture gesture :stream stream)))) (defun read-numeric-argument (&key (stream *standard-input*)) (let ((gesture (climacs-read-gesture))) From abakic at common-lisp.net Thu Jan 20 23:21:54 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Thu, 20 Jan 2005 15:21:54 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base-test.lisp climacs/climacs.asd climacs/buffer-test.lisp Message-ID: <20050120232154.AD86F88026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32470 Modified Files: climacs.asd buffer-test.lisp Added Files: base-test.lisp Log Message: Tests for previous-line and next-line in combination with standard buffer and mark. Date: Thu Jan 20 15:21:53 2005 Author: abakic Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.12 climacs/climacs.asd:1.13 --- climacs/climacs.asd:1.12 Sat Jan 15 15:23:45 2005 +++ climacs/climacs.asd Thu Jan 20 15:21:52 2005 @@ -62,7 +62,8 @@ "gui" ;;---- optional ---- "testing/rt" - "buffer-test") + "buffer-test" + "base-test") #+asdf (defmethod asdf:perform :around ((o asdf:compile-op) Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.7 climacs/buffer-test.lisp:1.8 --- climacs/buffer-test.lisp:1.7 Wed Jan 19 17:22:19 2005 +++ climacs/buffer-test.lisp Thu Jan 20 15:21:52 2005 @@ -4,7 +4,7 @@ ;;; (cl:defpackage :climacs-tests - (:use :rtest :climacs-buffer :cl)) + (:use :cl :rtest :climacs-buffer :climacs-base)) (cl:in-package :climacs-tests) From mvilleneuve at common-lisp.net Thu Jan 20 19:12:53 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Thu, 20 Jan 2005 11:12:53 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp Message-ID: <20050120191253.94EB488026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19202 Modified Files: base.lisp gui.lisp Log Message: Fixed bug in fill-line with words longer than fill-column Date: Thu Jan 20 11:12:49 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.22 climacs/base.lisp:1.23 --- climacs/base.lisp:1.22 Wed Jan 19 12:04:39 2005 +++ climacs/base.lisp Thu Jan 20 11:12:48 2005 @@ -401,6 +401,7 @@ (let ((begin-mark (clone-mark mark))) (beginning-of-line begin-mark) (loop with column = 0 + with line-beginning-offset = (offset begin-mark) with walking-mark = (clone-mark begin-mark) while (mark< walking-mark mark) as object = (object-after walking-mark) @@ -413,13 +414,15 @@ (incf column (- tab-width (mod column tab-width)))) (t (incf column))) - (when (>= column fill-column) + (when (and (>= column fill-column) + (/= (offset begin-mark) line-beginning-offset)) (insert-object begin-mark #\Newline) (incf (offset begin-mark)) (let ((indentation (funcall syntax-line-indentation-function begin-mark))) (indent-line begin-mark indentation tab-width)) (beginning-of-line begin-mark) + (setf line-beginning-offset (offset begin-mark)) (setf (offset walking-mark) (offset begin-mark)) (setf column 0)) (incf (offset walking-mark))))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.88 climacs/gui.lisp:1.89 --- climacs/gui.lisp:1.88 Wed Jan 19 22:01:56 2005 +++ climacs/gui.lisp Thu Jan 20 11:12:48 2005 @@ -289,21 +289,7 @@ (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) -(defun insert-character (char) - (let* ((win (current-window)) - (point (point win))) - (unless (constituentp char) - (possibly-expand-abbrev point)) - (if (and (slot-value win '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 () - (insert-character *current-gesture*)) - -(define-command com-self-filling-insert () +(defun possibly-fill-line () (let* ((pane (current-window)) (buffer (buffer pane))) (when (auto-fill-mode buffer) @@ -318,7 +304,22 @@ (lambda (mark) (syntax-line-indentation mark tab-width syntax)) fill-column - tab-width))))) + tab-width)))))) + +(defun insert-character (char) + (let* ((win (current-window)) + (point (point win))) + (unless (constituentp char) + (possibly-expand-abbrev point)) + (when (whitespacep char) + (possibly-fill-line)) + (if (and (slot-value win '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 () (insert-character *current-gesture*)) (define-named-command com-beginning-of-line () @@ -967,11 +968,10 @@ (find :meta gesture)) (dead-escape-set-key (remove :meta gesture) command))) -(loop for code from (char-code #\!) to (char-code #\~) +(loop for code from (char-code #\Space) to (char-code #\~) do (global-set-key (code-char code) 'com-self-insert)) -(global-set-key #\Space 'com-self-filling-insert) -(global-set-key #\Newline 'com-self-filling-insert) +(global-set-key #\Newline 'com-self-insert) (global-set-key #\Tab 'com-indent-line) (global-set-key '(#\j :control) 'com-newline-and-indent) (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) From mvilleneuve at common-lisp.net Thu Jan 20 23:37:39 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Thu, 20 Jan 2005 15:37:39 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp Message-ID: <20050120233739.33C9988026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv804 Modified Files: base.lisp Log Message: Fixed bug in do-buffer-region Date: Thu Jan 20 15:37:38 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.23 climacs/base.lisp:1.24 --- climacs/base.lisp:1.23 Thu Jan 20 11:12:48 2005 +++ climacs/base.lisp Thu Jan 20 15:37:38 2005 @@ -36,7 +36,7 @@ The body is executed for each element, with object being the current object (setf-able), and offset being its offset." `(symbol-macrolet ((,object (buffer-object ,buffer ,offset))) - (loop for ,offset from ,offset1 to ,offset2 + (loop for ,offset from ,offset1 below ,offset2 do , at body))) (defgeneric backward-object (mark &optional count)) From mvilleneuve at common-lisp.net Thu Jan 20 23:42:06 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Thu, 20 Jan 2005 15:42:06 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050120234206.E9E8588026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv867 Modified Files: gui.lisp Log Message: Added command fill-paragraph (bound to M-q) Date: Thu Jan 20 15:42:05 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.89 climacs/gui.lisp:1.90 --- climacs/gui.lisp:1.89 Thu Jan 20 11:12:48 2005 +++ climacs/gui.lisp Thu Jan 20 15:42:04 2005 @@ -505,6 +505,26 @@ (let ((buffer (buffer (current-window)))) (setf (auto-fill-mode buffer) (not (auto-fill-mode buffer))))) +(define-named-command com-fill-paragraph () + (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) + (beginning-of-paragraph begin-mark syntax)) + (unless (eql (object-after end-mark) #\Newline) + (end-of-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))))) + (define-command com-extended-command () (let ((item (accept 'command :prompt "Extended Command"))) (execute-frame-command *application-frame* item))) @@ -1003,6 +1023,7 @@ (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\^ :shift :meta) 'com-delete-indentation) +(global-set-key '(#\q :meta) 'com-fill-paragraph) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) (global-set-key '(#\/ :meta) 'com-dabbrev-expand) From rstrandh at common-lisp.net Fri Jan 21 06:54:58 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 20 Jan 2005 22:54:58 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp Message-ID: <20050121065458.2769B88026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23154 Modified Files: gui.lisp packages.lisp Log Message: Box ajuster gadget for changing size of windows (thanks to Nicolas Lamirault) [though I did not put this in yet, because it seems to break com-delete-window. If someone can figure out why, I'll put it in.] Kill-buffer command (thanks to Lawrence Mitchell) Date: Thu Jan 20 22:54:55 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.90 climacs/gui.lisp:1.91 --- climacs/gui.lisp:1.90 Thu Jan 20 15:42:04 2005 +++ climacs/gui.lisp Thu Jan 20 22:54:54 2005 @@ -681,6 +681,19 @@ (beginning-of-buffer (point (current-window))) (full-redisplay (current-window)))) +(define-named-command com-kill-buffer () + (with-slots (buffers) *application-frame* + (let ((buffer (buffer (current-window)))) + (when (and (needs-saving buffer) + (accept 'boolean :prompt "Save buffer first?")) + (com-save-buffer)) + (setf buffers (remove buffer buffers)) + ;; Always need one buffer. + (when (null buffers) + (push (make-instance 'climacs-buffer :name "*scratch*") + buffers)) + (setf (buffer (current-window)) (car buffers))))) + (define-named-command com-full-redisplay () (full-redisplay (current-window))) @@ -769,6 +782,34 @@ ;;; ;;; Commands for splitting windows +;;; put this in for real when we find a solution for the problem +;;; it causes for com-delete-window +;; (defun replace-constellation (constellation additional-constellation vertical-p) +;; (let* ((parent (sheet-parent constellation)) +;; (children (sheet-children parent)) +;; (first (first children)) +;; (second (second children)) +;; (adjust (make-pane 'clim-extensions:box-adjuster-gadget))) +;; (assert (member constellation children)) +;; (cond ((eq constellation first) +;; (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 (list new second)))) +;; (t +;; (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 (list first new))))))) + (defun replace-constellation (constellation additional-constellation vertical-p) (let* ((parent (sheet-parent constellation)) (children (sheet-children parent)) @@ -1070,6 +1111,7 @@ (c-x-set-key '(#\e) 'com-call-last-kbd-macro) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) +(c-x-set-key '(#\k) 'com-kill-buffer) (c-x-set-key '(#\l :control) 'com-load-file) (c-x-set-key '(#\o) 'com-other-window) (c-x-set-key '(#\s :control) 'com-save-buffer) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.36 climacs/packages.lisp:1.37 --- climacs/packages.lisp:1.36 Wed Jan 19 12:04:39 2005 +++ climacs/packages.lisp Thu Jan 20 22:54:54 2005 @@ -102,5 +102,5 @@ (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax - :climacs-kill-ring :climacs-pane)) + :climacs-kill-ring :climacs-pane :clim-extensions)) From mvilleneuve at common-lisp.net Fri Jan 21 19:39:51 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Fri, 21 Jan 2005 11:39:51 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp Message-ID: <20050121193951.0830288028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29715 Modified Files: gui.lisp pane.lisp Log Message: Moved auto-fill-mode from buffer to pane Date: Fri Jan 21 11:39:50 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.91 climacs/gui.lisp:1.92 --- climacs/gui.lisp:1.91 Thu Jan 20 22:54:54 2005 +++ climacs/gui.lisp Fri Jan 21 11:39:50 2005 @@ -116,7 +116,7 @@ (if (slot-value climacs-pane 'overwrite-mode) " Ovwrt" "") - (if (auto-fill-mode buf) + (if (auto-fill-mode climacs-pane) " Fill" "") (if (recordingp *application-frame*) @@ -292,7 +292,7 @@ (defun possibly-fill-line () (let* ((pane (current-window)) (buffer (buffer pane))) - (when (auto-fill-mode buffer) + (when (auto-fill-mode pane) (let* ((fill-column (auto-fill-column buffer)) (point (point pane)) (offset (offset point)) @@ -502,8 +502,8 @@ (delete-indentation (point (current-window)))) (define-named-command com-auto-fill-mode () - (let ((buffer (buffer (current-window)))) - (setf (auto-fill-mode buffer) (not (auto-fill-mode buffer))))) + (let ((pane (current-window))) + (setf (auto-fill-mode pane) (not (auto-fill-mode pane))))) (define-named-command com-fill-paragraph () (let* ((pane (current-window)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.7 climacs/pane.lisp:1.8 --- climacs/pane.lisp:1.7 Wed Jan 19 12:04:39 2005 +++ climacs/pane.lisp Fri Jan 21 11:39:50 2005 @@ -59,7 +59,6 @@ (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t :accessor indent-tabs-mode) - (auto-fill-mode :initform t :accessor auto-fill-mode) (auto-fill-column :initform 70 :accessor auto-fill-column)) (:default-initargs :name "*scratch*")) @@ -75,6 +74,7 @@ (cursor-y :initform 2) (space-width :initform nil) (tab-width :initform nil) + (auto-fill-mode :initform t :accessor auto-fill-mode) (full-redisplay-p :initform nil :accessor full-redisplay-p) (cache :initform (let ((cache (make-instance 'standard-flexichain))) (insert* cache 0 nil) From rstrandh at common-lisp.net Sat Jan 22 05:15:54 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 21 Jan 2005 21:15:54 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi Message-ID: <20050122051554.5164C88028@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv27428 Modified Files: climacs-internals.texi Log Message: Separated syntax from redisplay. Date: Fri Jan 21 21:15:52 2005 Author: rstrandh Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.8 climacs/Doc/climacs-internals.texi:1.9 --- climacs/Doc/climacs-internals.texi:1.8 Tue Jan 18 10:59:54 2005 +++ climacs/Doc/climacs-internals.texi Fri Jan 21 21:15:50 2005 @@ -558,77 +558,77 @@ implementations may implement it fairly efficiently, say O(log n) where n is the number of lines in the buffer. - at chapter Redisplay and the syntax protocol + at chapter The syntax protocol @section General -A buffer can be on display in several panes. The redisplay -algorithm is invoked on each such pane. Each pane is associated -with a distinguished mark called the `point' of the pane. The point -is a right-sticky mark independently of whether you are typing -left-to-right or right-to-left. - -The redisplay function works by dispatching on an object of type -syntax, which determines exactly how the buffer contents is going to -be rendered in this particular pane. +A buffer may have a syntax module associated with it. The syntax +module usually consists of an incremental parser that analyzes the +contents of the buffer and creates some kind of parse tree or other +representation of the contents in order that it can be exploited by +the redisplay module and by user commands. @deftp {Protocol Class} syntax The base class for all syntaxes. - -A syntax object is a placeholder for many kinds of information -depending on the exact syntax, but in particular, it holds information -(in the form of two marks) about what part of the buffer was on -display after the previous invocation of the redisplay algorithm. @end deftp - at deftp {:initarg} :pane -Indicates the pane where rendering is to take place. - at end deftp +The redisplay module exploits the syntax module for several things: + + at itemize @bullet + at item highlighting of various syntactic entities of the buffer + at item highlighting of matching parenthesis, + at item turning syntactic entities into clickable presentations, + at item marking lines with inconsistent indentation, + at item etc. + at end itemize -All subclasses of the syntax class must support the :pane initarg. -The pane that is passed as an initarg must have a valid buffer -associated with it. +User commands can use the syntax module for: - at deffn {Function} {redisplay-pane} pane + at itemize @bullet + at item moving point by units that are specific to a particular buffer +syntax, such as expressions, statements, or paragraphs, + at item transposing syntactic units, + at item sending the text of a syntactic unit to a language processor, + at item indenting lines according to the syntax, + at item etc. + at end itemize -This function is called by the command loop on every pane that is on -display. It simply calls redisplay-with-syntax with the pane and the -syntax of the pane. - at end deffn +The view that the syntax module has of the buffer is updated only when +needed, and then only for the parts of the buffer that are needed. +Most syntax modules (such as for programming languages) need to +compute their representations from the beginning of the buffer up to a +particular point beyond which the structure of the buffer does not +need to be known. + +There are two situations where updating might be needed: - at deffn {Generic Function} {redisplay-with-syntax} pane syntax + at itemize @bullet + at item before redisplay is about to show the contents of part of the +buffer in a pane. + at item as a result of a command that exploits the syntactic entities of +the buffer contents. + at end itemize + +The first case is handled by the redisplay invoking the following +generic function before proceeding to display the buffer contents in a +pane: -Redisplay a pane using a given syntax. + at deffn {Generic Function} {update-syntax} buffer syntax mark + +Inform the syntax module that it must update its view of the buffer +contents up to the point indicated by the mark. It is acceptable to +pass an offset instead of the mark. @end deffn -This function can behave radically differently for different syntaxes. -In all cases, however, it starts by determining the current dimensions -of the pane, and compare that to the size of the region of the buffer -that is currently on display. Adjustments are made as necessary. It -then determines whether the point of the pane is within the region on -display. If not, a new region is computed in a way that the point is -as close to the middle of the pane as possible. It is important to -maintain the region on display as much as possible, so as to avoid -unnecessary scrolling. +The second case is handled by the syntax module itself when needed in +order to correctly compute the effects of a command. -The final step of this function is to render the region of the buffer -that is to be displayed. Some syntaxes can use simple algorithms that -simply draw everything in the region. Others can optimize so that -only the portions of the pane that have actually changed are redrawn. - -The redisplay-with-syntax function also implements parsing of the -buffer text. - -Simple parsers may be restricted to dividing the text into words, -possibly recognizing special words like URLs or email addresses, and -then using `present' to render these words. - -More complicated parsers may use incremental parsing techniques to -maintain sophisticated information of the buffer contents. Such a -parser needs to use the low-mark and high-mark to determine which -parts of the buffer have changed, and recompute parsing information as -necessary. +It is important to realize that the syntax module is not directly +involved in displaying buffer contents in a pane. In fact, the syntax +module should work even if there is no graphic user interface +present, and it should be exploitable by several, potentially totally +different, display units. @section Common Lisp syntax @@ -1404,6 +1404,58 @@ top element, increment the expression count of the new top entry, and perform a count check again. @end deffn + + at chapter Redisplay + +A buffer can be on display in several panes. The redisplay +algorithm is invoked on each such pane. Each pane is associated +with a distinguished mark called the `point' of the pane. The point +is a right-sticky mark independently of whether you are typing +left-to-right or right-to-left. + + at deffn {Generic Function} {redisplay-pane} pane view current-p + +This function is invoked on all panes at the end of each iteration of +the command loop. The current-p argument is a boolean that indicates +whether the pane is the one that currently has the input focus + at end deffn + +For maximum flexibility, the redisplay-pane function dispatches off of +two objects, a pane and a CLIM view. The reason for this is that the +same type of pane, such as a simple CLIM application pane, can be used +to show the buffer contents in slightly different ways: + + at itemize @bullet + at item highlighted or not, + at item highlighting tabulation characters (for makefiles) + at item showing control characters in a special font + at item etc. + at end itemize + +These minor variations are obtained by creating a special view type +and a method that dispatches on that type. + +Major differences such as the need to have pane-specific output +recording are best handled by creating a different pane type. + +The redisplay-pane function may use the current-p argument to slightly +alter the presentation such as drawing the cursor in a different +color. + +The redisplay-pane function starts by determining the current +dimensions of the pane, and compare that to the size of the region of +the buffer that is currently on display. Adjustments are made as +necessary. It then determines whether the point of the pane is within +the region on display. If not, a new region is computed in a way that +the point is as close to the middle of the pane as possible. It is +important to maintain the region on display as much as possible, so as +to avoid unnecessary scrolling. + +The final step of this function is to render the region of the buffer +that is to be displayed. Some pane types can use simple algorithms +that simply draw everything in the region. Others can optimize so +that only the portions of the pane that have actually changed are +redrawn. @chapter The undo protocol From rstrandh at common-lisp.net Sat Jan 22 05:45:28 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 21 Jan 2005 21:45:28 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050122054528.4503188028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28656 Modified Files: gui.lisp Log Message: Factored out buffer saving into a separate function. Improved on com-quit so that it asks the user to save buffers before quitting. Date: Fri Jan 21 21:45:26 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.92 climacs/gui.lisp:1.93 --- climacs/gui.lisp:1.92 Fri Jan 21 11:39:50 2005 +++ climacs/gui.lisp Fri Jan 21 21:45:25 2005 @@ -282,9 +282,6 @@ `(, at command-name :name t) `(,command-name :name t)) ,args , at body)) -(define-named-command (com-quit) () - (frame-exit *application-frame*)) - (define-named-command com-toggle-overwrite-mode () (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) @@ -631,20 +628,34 @@ ;; resets the low and high marks after redisplay (redisplay-frame-panes *application-frame*))) +(defun save-buffer (buffer) + (let ((filename (or (filename buffer) + (accept 'completable-pathname + :prompt "Save Buffer to File")))) + (with-open-file (stream filename :direction :output :if-exists :supersede) + (output-to-stream stream buffer 0 (size buffer))) + (setf (filename buffer) filename + (name buffer) (pathname-filename filename)) + (display-message "Wrote: ~a" (filename buffer)) + (setf (needs-saving buffer) nil))) + (define-named-command com-save-buffer () - (let* ((buffer (buffer (current-window))) - (filename (or (filename buffer) - (accept 'completable-pathname - :prompt "Save Buffer to File")))) + (let ((buffer (buffer (current-window)))) (if (or (null (filename buffer)) (needs-saving buffer)) - (progn (with-open-file (stream filename :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filename buffer) filename - (name buffer) (pathname-filename filename)) - (display-message "Wrote: ~a" (filename buffer))) - (display-message "No changes need to be saved from ~a" (name buffer))) - (setf (needs-saving buffer) nil))) + (save-buffer buffer) + (display-message "No changes need to be saved from ~a" (name buffer))))) + +(define-named-command (com-quit) () + (loop for buffer in (buffers *application-frame*) + when (and (needs-saving buffer) + (accept 'boolean + :prompt (format nil "Save buffer: ~a ?" (name buffer)))) + do (save-buffer buffer)) + (when (or (notany #'needs-saving + (buffers *application-frame*)) + (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")) + (frame-exit *application-frame*))) (define-named-command com-write-buffer () (let ((filename (accept 'completable-pathname From rstrandh at common-lisp.net Sat Jan 22 08:04:38 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sat, 22 Jan 2005 00:04:38 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp Message-ID: <20050122080438.28F4B88026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3538 Modified Files: gui.lisp pane.lisp Log Message: Prepare for the day when McCLIM moves output records instead of recomputing them. Date: Sat Jan 22 00:04:37 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.93 climacs/gui.lisp:1.94 --- climacs/gui.lisp:1.93 Fri Jan 21 21:45:25 2005 +++ climacs/gui.lisp Sat Jan 22 00:04:35 2005 @@ -922,6 +922,30 @@ (sheet-adopt-child parent other) (reorder-sheets parent (list first other))))))) +;; (define-named-command com-delete-window () +;; (unless (null (cdr (windows *application-frame*))) +;; (let* ((constellation (parent3 (current-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))) +;; (pop (windows *application-frame*)) +;; (sheet-disown-child box other) +;; (cond ((eq box first) +;; (sheet-disown-child parent box) +;; (sheet-adopt-child parent other) +;; (reorder-sheets parent (list other second third))) +;; (t +;; (sheet-disown-child parent box) +;; (sheet-adopt-child parent other) +;; (reorder-sheets parent (list first second other))))))) + ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.8 climacs/pane.lisp:1.9 --- climacs/pane.lisp:1.8 Fri Jan 21 11:39:50 2005 +++ climacs/pane.lisp Sat Jan 22 00:04:35 2005 @@ -315,7 +315,7 @@ for id from 0 below (nb-elements cache) do (setf scan start-offset) (updating-output - (pane :unique-id id + (pane :unique-id (element* cache id) :cache-value (if (<= start-offset (offset (point pane)) (+ start-offset (length (element* cache id)))) From mvilleneuve at common-lisp.net Sat Jan 22 15:20:46 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sat, 22 Jan 2005 07:20:46 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp Message-ID: <20050122152046.53A428802B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25661 Modified Files: gui.lisp pane.lisp Log Message: Copy auto-fill parameters when splitting panes, moved auto-fill-column to pane Date: Sat Jan 22 07:20:45 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.94 climacs/gui.lisp:1.95 --- climacs/gui.lisp:1.94 Sat Jan 22 00:04:35 2005 +++ climacs/gui.lisp Sat Jan 22 07:20:44 2005 @@ -290,13 +290,13 @@ (let* ((pane (current-window)) (buffer (buffer pane))) (when (auto-fill-mode pane) - (let* ((fill-column (auto-fill-column buffer)) + (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- (auto-fill-column buffer))) + (1- fill-column)) (fill-line point (lambda (mark) (syntax-line-indentation mark tab-width syntax)) @@ -876,7 +876,9 @@ (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window (current-window)) (constellation-root (parent3 current-window))) - (setf (buffer new-pane) (buffer current-window)) + (setf (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*)) (replace-constellation constellation-root vbox t) (full-redisplay current-window) @@ -888,7 +890,9 @@ (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window (current-window)) (constellation-root (parent3 current-window))) - (setf (buffer new-pane) (buffer current-window)) + (setf (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*)) (replace-constellation constellation-root vbox nil) (full-redisplay current-window) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.9 climacs/pane.lisp:1.10 --- climacs/pane.lisp:1.9 Sat Jan 22 00:04:35 2005 +++ climacs/pane.lisp Sat Jan 22 07:20:44 2005 @@ -58,8 +58,7 @@ ((needs-saving :initform nil :accessor needs-saving) (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t - :accessor indent-tabs-mode) - (auto-fill-column :initform 70 :accessor auto-fill-column)) + :accessor indent-tabs-mode)) (:default-initargs :name "*scratch*")) @@ -75,6 +74,7 @@ (space-width :initform nil) (tab-width :initform nil) (auto-fill-mode :initform t :accessor auto-fill-mode) + (auto-fill-column :initform 70 :accessor auto-fill-column) (full-redisplay-p :initform nil :accessor full-redisplay-p) (cache :initform (let ((cache (make-instance 'standard-flexichain))) (insert* cache 0 nil) From mvilleneuve at common-lisp.net Sun Jan 23 10:21:11 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sun, 23 Jan 2005 02:21:11 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp Message-ID: <20050123102111.9489C88028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20514 Modified Files: gui.lisp packages.lisp pane.lisp Log Message: Added basic Isearch support Date: Sun Jan 23 02:21:09 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.95 climacs/gui.lisp:1.96 --- climacs/gui.lisp:1.95 Sat Jan 22 07:20:44 2005 +++ climacs/gui.lisp Sun Jan 23 02:21:08 2005 @@ -109,7 +109,7 @@ (declare (ignore frame)) (with-slots (climacs-pane) pane (let* ((buf (buffer climacs-pane)) - (name-info (format nil " ~a ~a Syntax: ~a~a~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a" (if (needs-saving buf) "**" "--") (name buf) (name (syntax buf)) @@ -119,6 +119,9 @@ (if (auto-fill-mode climacs-pane) " Fill" "") + (if (isearch-mode climacs-pane) + " Isearch" + "") (if (recordingp *application-frame*) "Def" "")))) @@ -983,17 +986,102 @@ (let ((size (accept 'integer :prompt "New kill ring size"))) (setf (kill-ring-max-size *kill-ring*) size))) -(define-named-command com-search-forward () - (search-forward (point (current-window)) - (accept 'string :prompt "Search Forward") - :test (lambda (a b) - (and (characterp b) (char-equal a b))))) - -(define-named-command com-search-backward () - (search-backward (point (current-window)) - (accept 'string :prompt "Search Backward") - :test (lambda (a b) - (and (characterp b) (char-equal a b))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Incremental search + +(define-named-command com-isearch-mode () + (let* ((pane (current-window)) + (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)))) + (redisplay-frame-panes *application-frame*) + (loop while (isearch-mode pane) + as gesture = (climacs-read-gesture) + as item = (find-gestures (list gesture) 'isearch-climacs-table) + do (cond ((and item (eq (command-menu-item-type item) :command)) + (setf *current-gesture* gesture) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (handler-case + (execute-frame-command *application-frame* command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))))) + (t + (unread-gesture gesture) + (setf (isearch-mode pane) nil))) + (redisplay-frame-panes *application-frame*)))) + +(defun isearch-from-mark (pane mark string) + (let* ((point (point pane)) + (mark2 (clone-mark mark))) + (when (search-forward mark2 string + :test (lambda (x y) + (if (characterp x) + (and (characterp y) (char-equal x y)) + (eql x y)))) + (setf (offset point) (offset mark2)) + (setf (offset mark) (- (offset mark2) (length string)))))) + +(define-named-command com-isearch-append-char () + (let* ((pane (current-window)) + (point (point pane)) + (states (isearch-states pane)) + (string (concatenate 'string + (search-string (first states)) + (string *current-gesture*))) + (mark (clone-mark (search-mark (first states)))) + (previous-point-offset (offset point))) + (isearch-from-mark pane mark string) + (if (/= (offset point) previous-point-offset) + (push (make-instance 'isearch-state + :search-string string + :search-mark mark) + (isearch-states pane)) + (beep)))) + +(define-named-command com-isearch-delete-char () + (let* ((pane (current-window))) + (cond ((null (second (isearch-states pane))) + (beep)) + (t + (pop (isearch-states pane)) + (let ((state (first (isearch-states pane)))) + (setf (offset (point pane)) + (+ (offset (search-mark state)) + (length (search-string state))))))))) + +(define-named-command com-isearch-forward () + (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)) + (previous-point-offset (offset point))) + (isearch-from-mark pane mark string) + (if (/= (offset point) previous-point-offset) + (push (make-instance 'isearch-state + :search-string string + :search-mark mark) + (isearch-states pane)) + (beep)))) + +(define-named-command com-isearch-exit () + (setf (isearch-mode (current-window)) nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dynamic abbrevs (define-named-command com-dabbrev-expand () (let* ((win (current-window)) @@ -1109,6 +1197,7 @@ (global-set-key '(#\/ :meta) 'com-dabbrev-expand) (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph) (global-set-key '(#\e :control :meta) 'com-end-of-paragraph) +(global-set-key '(#\s :control) 'com-isearch-mode) (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) @@ -1316,3 +1405,21 @@ (dead-circumflex-set-key '(#\o) '(com-insert-charcode 244)) (dead-circumflex-set-key '(#\u) '(com-insert-charcode 251)) (dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Isearch command table + +(make-command-table 'isearch-climacs-table :errorp 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-forward) + Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.37 climacs/packages.lisp:1.38 --- climacs/packages.lisp:1.37 Thu Jan 20 22:54:54 2005 +++ climacs/packages.lisp Sun Jan 23 02:21:08 2005 @@ -98,6 +98,8 @@ #:tab-space-count #:indent-tabs-mode #:auto-fill-mode #:auto-fill-column + #:isearch-state #:search-string #:search-mark + #:isearch-mode #:isearch-states #:isearch-previous-string #:url)) (defpackage :climacs-gui Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.10 climacs/pane.lisp:1.11 --- climacs/pane.lisp:1.10 Sat Jan 22 07:20:44 2005 +++ climacs/pane.lisp Sun Jan 23 02:21:08 2005 @@ -44,6 +44,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Isearch + +(defclass isearch-state () + ((search-string :initarg :search-string :accessor search-string) + (search-mark :initarg :search-mark :accessor search-mark))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; View (defclass climacs-textual-view (textual-view tabify-mixin) @@ -75,6 +83,9 @@ (tab-width :initform nil) (auto-fill-mode :initform t :accessor auto-fill-mode) (auto-fill-column :initform 70 :accessor auto-fill-column) + (isearch-mode :initform nil :accessor isearch-mode) + (isearch-states :initform '() :accessor isearch-states) + (isearch-previous-string :initform nil :accessor isearch-previous-string) (full-redisplay-p :initform nil :accessor full-redisplay-p) (cache :initform (let ((cache (make-instance 'standard-flexichain))) (insert* cache 0 nil) From rstrandh at common-lisp.net Sun Jan 23 16:37:51 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 23 Jan 2005 08:37:51 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/INSTALL Message-ID: <20050123163751.7640288026@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7225 Modified Files: INSTALL Log Message: Added warning agains using old versions of McCLIM. Date: Sun Jan 23 08:37:30 2005 Author: rstrandh Index: climacs/INSTALL diff -u climacs/INSTALL:1.3 climacs/INSTALL:1.4 --- climacs/INSTALL:1.3 Sat Jan 8 10:07:30 2005 +++ climacs/INSTALL Sun Jan 23 08:37:24 2005 @@ -33,5 +33,12 @@ Start the Climacs editor. +Finally, please notice that as we develop Climacs, we occasionally +find bugs in McCLIM, or ask for functionality of McCLIM that can be +useful to us. + +For that reason, McCLIM often depend on very fresh CVS versions of +McCLIM. If you discover a bug, please try to install a new version of +McCLIM before looking to hard for any other reasons. From mvilleneuve at common-lisp.net Sun Jan 23 23:30:38 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sun, 23 Jan 2005 15:30:38 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp Message-ID: <20050123233038.B1DB788394@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28339 Modified Files: gui.lisp packages.lisp pane.lisp Log Message: Added backward isearch Date: Sun Jan 23 15:30:35 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.96 climacs/gui.lisp:1.97 --- climacs/gui.lisp:1.96 Sun Jan 23 02:21:08 2005 +++ climacs/gui.lisp Sun Jan 23 15:30:34 2005 @@ -990,9 +990,8 @@ ;;; ;;; Incremental search -(define-named-command com-isearch-mode () - (let* ((pane (current-window)) - (point (point pane))) +(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))))) @@ -1000,7 +999,8 @@ (setf (isearch-states pane) (list (make-instance 'isearch-state :search-string "" - :search-mark (clone-mark point)))) + :search-mark (clone-mark point) + :search-forward-p forwardp))) (redisplay-frame-panes *application-frame*) (loop while (isearch-mode pane) as gesture = (climacs-read-gesture) @@ -1020,33 +1020,47 @@ (setf (isearch-mode pane) nil))) (redisplay-frame-panes *application-frame*)))) -(defun isearch-from-mark (pane mark string) - (let* ((point (point pane)) - (mark2 (clone-mark mark))) - (when (search-forward mark2 string - :test (lambda (x y) - (if (characterp x) - (and (characterp y) (char-equal x y)) - (eql x y)))) - (setf (offset point) (offset mark2)) - (setf (offset mark) (- (offset mark2) (length string)))))) +(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))) + (cond (success + (setf (offset point) (offset mark2) + (offset mark) (if forwardp + (- (offset mark2) (length string)) + (+ (offset mark2) (length string)))) + (push (make-instance 'isearch-state + :search-string string + :search-mark mark + :search-forward-p forwardp) + (isearch-states pane))) + (t + (beep)))))) + +(define-named-command com-isearch-mode-forward () + (isearch-command-loop (current-window) t)) + +(define-named-command com-isearch-mode-backward () + (isearch-command-loop (current-window) nil)) (define-named-command com-isearch-append-char () (let* ((pane (current-window)) - (point (point pane)) (states (isearch-states pane)) (string (concatenate 'string (search-string (first states)) (string *current-gesture*))) (mark (clone-mark (search-mark (first states)))) - (previous-point-offset (offset point))) - (isearch-from-mark pane mark string) - (if (/= (offset point) previous-point-offset) - (push (make-instance 'isearch-state - :search-string string - :search-mark mark) - (isearch-states pane)) - (beep)))) + (forwardp (search-forward-p (first states)))) + (unless forwardp + (incf (offset mark))) + (isearch-from-mark pane mark string forwardp))) (define-named-command com-isearch-delete-char () (let* ((pane (current-window))) @@ -1056,8 +1070,11 @@ (pop (isearch-states pane)) (let ((state (first (isearch-states pane)))) (setf (offset (point pane)) - (+ (offset (search-mark state)) - (length (search-string state))))))))) + (if (search-forward-p state) + (+ (offset (search-mark state)) + (length (search-string state))) + (- (offset (search-mark state)) + (length (search-string state)))))))))) (define-named-command com-isearch-forward () (let* ((pane (current-window)) @@ -1066,15 +1083,18 @@ (string (if (null (second states)) (isearch-previous-string pane) (search-string (first states)))) - (mark (clone-mark point)) - (previous-point-offset (offset point))) - (isearch-from-mark pane mark string) - (if (/= (offset point) previous-point-offset) - (push (make-instance 'isearch-state - :search-string string - :search-mark mark) - (isearch-states pane)) - (beep)))) + (mark (clone-mark point))) + (isearch-from-mark pane mark string t))) + +(define-named-command com-isearch-backward () + (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-named-command com-isearch-exit () (setf (isearch-mode (current-window)) nil)) @@ -1197,7 +1217,8 @@ (global-set-key '(#\/ :meta) 'com-dabbrev-expand) (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph) (global-set-key '(#\e :control :meta) 'com-end-of-paragraph) -(global-set-key '(#\s :control) 'com-isearch-mode) +(global-set-key '(#\s :control) 'com-isearch-mode-forward) +(global-set-key '(#\r :control) 'com-isearch-mode-backward) (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) @@ -1422,4 +1443,4 @@ (isearch-set-key '(#\Newline) 'com-isearch-exit) (isearch-set-key '(#\Backspace) 'com-isearch-delete-char) (isearch-set-key '(#\s :control) 'com-isearch-forward) - +(isearch-set-key '(#\r :control) 'com-isearch-backward) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.38 climacs/packages.lisp:1.39 --- climacs/packages.lisp:1.38 Sun Jan 23 02:21:08 2005 +++ climacs/packages.lisp Sun Jan 23 15:30:34 2005 @@ -98,7 +98,7 @@ #:tab-space-count #:indent-tabs-mode #:auto-fill-mode #:auto-fill-column - #:isearch-state #:search-string #:search-mark + #:isearch-state #:search-string #:search-mark #:search-forward-p #:isearch-mode #:isearch-states #:isearch-previous-string #:url)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.11 climacs/pane.lisp:1.12 --- climacs/pane.lisp:1.11 Sun Jan 23 02:21:08 2005 +++ climacs/pane.lisp Sun Jan 23 15:30:35 2005 @@ -48,7 +48,8 @@ (defclass isearch-state () ((search-string :initarg :search-string :accessor search-string) - (search-mark :initarg :search-mark :accessor search-mark))) + (search-mark :initarg :search-mark :accessor search-mark) + (search-forward-p :initarg :search-forward-p :accessor search-forward-p))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From rstrandh at common-lisp.net Mon Jan 24 12:49:10 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 24 Jan 2005 04:49:10 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp Message-ID: <20050124124910.00A6F8802B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3921 Modified Files: climacs.asd gui.lisp packages.lisp pane.lisp Log Message: Implemented undo and redo. Date: Mon Jan 24 04:49:09 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.13 climacs/climacs.asd:1.14 --- climacs/climacs.asd:1.13 Thu Jan 20 15:21:52 2005 +++ climacs/climacs.asd Mon Jan 24 04:49:08 2005 @@ -59,6 +59,7 @@ "text-syntax" "kill-ring" "pane" + "undo" "gui" ;;---- optional ---- "testing/rt" Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.97 climacs/gui.lisp:1.98 --- climacs/gui.lisp:1.97 Sun Jan 23 15:30:34 2005 +++ climacs/gui.lisp Mon Jan 24 04:49:09 2005 @@ -88,6 +88,11 @@ (defmacro current-window () ; shouldn't this be an inlined function? --amb `(car (windows *application-frame*))) +(defmethod execute-frame-command :around ((frame climacs) command) + (declare (ignore command)) + (with-undo ((buffer (current-window))) + (call-next-method))) + (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame))))) @@ -1099,6 +1104,12 @@ (define-named-command com-isearch-exit () (setf (isearch-mode (current-window)) nil)) +(define-named-command com-undo () + (undo (undo-tree (buffer (current-window))))) + +(define-named-command com-redo () + (redo (undo-tree (buffer (current-window))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Dynamic abbrevs @@ -1263,6 +1274,8 @@ (c-x-set-key '(#\k) 'com-kill-buffer) (c-x-set-key '(#\l :control) 'com-load-file) (c-x-set-key '(#\o) 'com-other-window) +(c-x-set-key '(#\r) 'com-redo) +(c-x-set-key '(#\u) 'com-undo) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.39 climacs/packages.lisp:1.40 --- climacs/packages.lisp:1.39 Sun Jan 23 15:30:34 2005 +++ climacs/packages.lisp Mon Jan 24 04:49:09 2005 @@ -88,9 +88,16 @@ #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push)) +(defpackage :undo + (:use :common-lisp) + (:export #:no-more-undo + #:undo-tree #:standard-undo-tree + #:undo-record #:standard-undo-record + #:add-undo #:flip-undo-record #:undo #:redo)) + (defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev - :climacs-syntax :flexichain) + :climacs-syntax :flexichain :undo) (:export #:climacs-buffer #:needs-saving #:filename #:climacs-pane #:point #:mark #:redisplay-pane #:full-redisplay @@ -100,9 +107,10 @@ #:auto-fill-mode #:auto-fill-column #:isearch-state #:search-string #:search-mark #:search-forward-p #:isearch-mode #:isearch-states #:isearch-previous-string + #:with-undo #:url)) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax - :climacs-kill-ring :climacs-pane :clim-extensions)) + :climacs-kill-ring :climacs-pane :clim-extensions :undo)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.12 climacs/pane.lisp:1.13 --- climacs/pane.lisp:1.12 Sun Jan 23 15:30:35 2005 +++ climacs/pane.lisp Mon Jan 24 04:49:09 2005 @@ -44,6 +44,99 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Undo + +(defclass undo-mixin () + ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree) + (undo-accumulate :initform '() :accessor undo-accumulate) + (performing-undo :initform nil :accessor performing-undo))) + +(defclass climacs-undo-record (standard-undo-record) + ((buffer :initarg :buffer))) + +(defclass simple-undo-record (climacs-undo-record) + ((offset :initarg :offset))) + +(defclass insert-record (simple-undo-record) + ((objects :initarg :objects))) + +(defclass delete-record (simple-undo-record) + ((length :initarg :length))) + +(defclass compound-record (climacs-undo-record) + ((records :initform '() :initarg :records))) + +(defmethod print-object ((object delete-record) stream) + (with-slots (offset length) object + (format stream "[offset: ~a length: ~a]" offset length))) + +(defmethod print-object ((object insert-record) stream) + (with-slots (offset objects) object + (format stream "[offset: ~a objects: ~a]" offset objects))) + +(defmethod print-object ((object compound-record) stream) + (with-slots (records) object + (format stream "[records: ~a]" records))) + +(defmethod insert-buffer-object :before ((buffer undo-mixin) offset object) + (declare (ignore object)) + (unless (performing-undo buffer) + (push (make-instance 'delete-record + :buffer buffer :offset offset :length 1) + (undo-accumulate buffer)))) + +(defmethod insert-buffer-sequence :before ((buffer undo-mixin) offset sequence) + (unless (performing-undo buffer) + (push (make-instance 'delete-record + :buffer buffer :offset offset :length (length sequence)) + (undo-accumulate buffer)))) + + +(defmethod delete-buffer-range :before ((buffer undo-mixin) offset n) + (unless (performing-undo buffer) + (push (make-instance 'insert-record + :buffer buffer :offset offset + :objects (buffer-sequence buffer offset (+ offset n))) + (undo-accumulate buffer)))) + +(defmacro with-undo ((buffer) &body body) + (let ((buffer-var (gensym))) + `(let ((,buffer-var ,buffer)) + (setf (undo-accumulate ,buffer-var) '()) + , at body + (cond ((null (undo-accumulate ,buffer-var)) nil) + ((null (cdr (undo-accumulate ,buffer-var))) + (add-undo (car (undo-accumulate ,buffer-var)) (undo-tree ,buffer-var))) + (t + (add-undo (make-instance 'compound-record :records (undo-accumulate ,buffer-var)) + (undo-tree ,buffer-var))))))) + +(defmethod flip-undo-record :around ((record climacs-undo-record)) + (with-slots (buffer) record + (let ((performing-undo (performing-undo buffer))) + (setf (performing-undo buffer) t) + (unwind-protect (call-next-method) + (setf (performing-undo buffer) performing-undo))))) + +(defmethod flip-undo-record ((record insert-record)) + (with-slots (buffer offset objects) record + (change-class record 'delete-record + :length (length objects)) + (insert-buffer-sequence buffer offset objects))) + +(defmethod flip-undo-record ((record delete-record)) + (with-slots (buffer offset length) record + (change-class record 'insert-record + :objects (buffer-sequence buffer offset (+ offset length))) + (delete-buffer-range buffer offset length))) + +(defmethod flip-undo-record ((record compound-record)) + (with-slots (records) record + (mapc #'flip-undo-record records) + (setf records (nreverse records)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Isearch (defclass isearch-state () @@ -63,7 +156,7 @@ ;(defgeneric indent-tabs-mode (climacs-buffer)) -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin) +(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) ((needs-saving :initform nil :accessor needs-saving) (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t From rstrandh at common-lisp.net Mon Jan 24 13:12:53 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 24 Jan 2005 05:12:53 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/undo.lisp Message-ID: <20050124131253.569068802B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5047 Added Files: undo.lisp Log Message: Undo Date: Mon Jan 24 05:12:52 2005 Author: rstrandh From mvilleneuve at common-lisp.net Mon Jan 24 23:01:44 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Mon, 24 Jan 2005 15:01:44 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/climacs.asd Message-ID: <20050124230144.E66738802B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2689 Modified Files: climacs.asd Log Message: Fixed file order issue preventing compilation in CMUCL Date: Mon Jan 24 15:01:39 2005 Author: mvilleneuve Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.14 climacs/climacs.asd:1.15 --- climacs/climacs.asd:1.14 Mon Jan 24 04:49:08 2005 +++ climacs/climacs.asd Mon Jan 24 15:01:37 2005 @@ -58,8 +58,8 @@ "syntax" "text-syntax" "kill-ring" - "pane" "undo" + "pane" "gui" ;;---- optional ---- "testing/rt" From abakic at common-lisp.net Mon Jan 24 23:53:54 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Mon, 24 Jan 2005 15:53:54 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/base-test.lisp climacs/buffer-test.lisp Message-ID: <20050124235354.C472E8802B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5683 Modified Files: base.lisp base-test.lisp buffer-test.lisp Log Message: Changes in open-line and number-of-lines-in-region, and more tests. Date: Mon Jan 24 15:53:53 2005 Author: abakic Index: climacs/base.lisp diff -u climacs/base.lisp:1.24 climacs/base.lisp:1.25 --- climacs/base.lisp:1.24 Thu Jan 20 15:37:38 2005 +++ climacs/base.lisp Mon Jan 24 15:53:52 2005 @@ -75,8 +75,12 @@ (beginning-of-line mark) (incf (offset mark) column))))) -(defun open-line (mark) - "Create a new line in a buffer." +(defmethod open-line ((mark left-sticky-mark)) + "Create a new line in a buffer after the mark." + (insert-object mark #\Newline)) + +(defmethod open-line ((mark right-sticky-mark)) + "Create a new line in a buffer after the mark." (insert-object mark #\Newline) (decf (offset mark))) @@ -132,13 +136,23 @@ (defmethod number-of-lines-in-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) - (buffer-number-of-lines-in-region (buffer mark1) (offset mark1) (offset mark2))) - -(defmethod number-of-lines-in-region ((offset integer) (mark mark)) - (buffer-number-of-lines-in-region (buffer mark) offset (offset mark))) - -(defmethod number-of-lines-in-region ((mark mark) (offset integer)) - (buffer-number-of-lines-in-region (buffer mark) (offset mark) offset)) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2))) + +(defmethod number-of-lines-in-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (buffer-number-of-lines-in-region (buffer mark2) offset1 offset2))) + +(defmethod number-of-lines-in-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2))) (defun constituentp (obj) "A predicate to ensure that an object is a constituent character." @@ -153,7 +167,7 @@ #-sbcl (member obj '(#\Space #\Tab)))) (defun forward-to-word-boundary (mark) - "Forward the mark forward to the beginning of the next word." + "Move the mark forward to the beginning of the next word." (loop until (end-of-buffer-p mark) until (constituentp (object-after mark)) do (incf (offset mark)))) Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.1 climacs/base-test.lisp:1.2 --- climacs/base-test.lisp:1.1 Thu Jan 20 15:21:53 2005 +++ climacs/base-test.lisp Mon Jan 24 15:53:52 2005 @@ -143,4 +143,482 @@ :buffer buffer :offset 0))) (next-line mark) (offset mark))) - 8) \ No newline at end of file + 8) + +(deftest standard-buffer-open-line.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0))) + (open-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + " +climacs" 0) + +(deftest standard-buffer-open-line.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (open-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + " +climacs" 0) + +(deftest standard-buffer-open-line.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 7))) + (open-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacs +" 7) + +(deftest standard-buffer-open-line.test-4 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7))) + (open-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacs +" 7) + +(deftest standard-buffer-kill-line.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + #() 0) + +(deftest standard-buffer-kill-line.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + #() 0) + +(deftest standard-buffer-kill-line.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 7))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacs" 7) + +(deftest standard-buffer-kill-line.test-4 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacs" 7) + +(deftest standard-buffer-kill-line.test-5 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs") + (let ((mark (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 7))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacsclimacs" 7) + +(deftest standard-buffer-kill-line.test-6 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs") + (let ((mark (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7))) + (kill-line mark) + (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) + "climacsclimacs" 7) + +(deftest standard-buffer-empty-line-p.test-1 + (let* ((buffer (make-instance 'standard-buffer)) + (m1 (make-instance 'standard-left-sticky-mark :buffer buffer)) + (m2 (make-instance 'standard-right-sticky-mark :buffer buffer))) + (values (empty-line-p m1) (empty-line-p m2))) + t t) + +(deftest standard-buffer-empty-line-p.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-object buffer 0 #\a) + (let ((m1 (make-instance 'standard-left-sticky-mark :buffer buffer)) + (m2 (make-instance 'standard-right-sticky-mark :buffer buffer))) + (values (empty-line-p m1) (empty-line-p m2)))) + nil nil) + +(deftest standard-buffer-empty-line-p.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-object buffer 0 #\a) + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 1))) + (values (empty-line-p m1) (empty-line-p m2)))) + nil nil) + +(deftest standard-buffer-empty-line-p.test-4 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "a +b") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 1))) + (values (empty-line-p m1) (empty-line-p m2)))) + nil nil) + +(deftest standard-buffer-line-indentation.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m3 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 10)) + (m4 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 10))) + (values + (line-indentation m1 8) + (line-indentation m2 8) + (line-indentation m3 8) + (line-indentation m4 8) + (offset m1) + (offset m2) + (offset m3) + (offset m4)))) + 10 10 10 10 0 0 10 10) + +(deftest standard-buffer-line-indentation.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m3 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 11)) + (m4 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 11))) + (values + (line-indentation m1 8) + (line-indentation m2 8) + (line-indentation m3 8) + (line-indentation m4 8) + (offset m1) + (offset m2) + (offset m3) + (offset m4)))) + 18 18 18 18 0 0 11 11) + +(deftest standard-buffer-line-indentation.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs ") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m3 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 11)) + (m4 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 11))) + (values + (line-indentation m1 8) + (line-indentation m2 8) + (line-indentation m3 8) + (line-indentation m4 8) + (offset m1) + (offset m2) + (offset m3) + (offset m4)))) + 10 10 10 10 0 0 11 11) + +(deftest standard-buffer-buffer-number-of-lines-in-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs") + (values + (climacs-base::buffer-number-of-lines-in-region buffer 0 6) + (climacs-base::buffer-number-of-lines-in-region buffer 0 7) + (climacs-base::buffer-number-of-lines-in-region buffer 0 10) + (climacs-base::buffer-number-of-lines-in-region buffer 0 13) + (climacs-base::buffer-number-of-lines-in-region buffer 0 14) + (climacs-base::buffer-number-of-lines-in-region buffer 7 10) + (climacs-base::buffer-number-of-lines-in-region buffer 8 13) + (climacs-base::buffer-number-of-lines-in-region buffer 8 14))) + 0 0 1 1 1 1 0 0) + +(deftest standard-buffer-buffer-display-column.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " cli macs") + (values + (buffer-display-column buffer 0 8) + (buffer-display-column buffer 1 8) + (buffer-display-column buffer 2 8) + (buffer-display-column buffer 5 8) + (buffer-display-column buffer 6 8))) + 0 8 16 19 24) + +(deftest standard-buffer-number-of-lines-in-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " +climacs +climacs +") + (let ((m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2r (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m3l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 3)) + (m3r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 3)) + (m4l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 8)) + (m4r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 8)) + (m5l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 15)) + (m5r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 15)) + (m6l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 16)) + (m6r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 16))) + (values + (number-of-lines-in-region m1l m1r) + (number-of-lines-in-region m1r m1l) + (number-of-lines-in-region m1l m2l) + (number-of-lines-in-region m2r m1r) + (number-of-lines-in-region m1l m2r) + (number-of-lines-in-region m2r m1l) + (number-of-lines-in-region m1r m2l) + (number-of-lines-in-region m1l m3l) + (number-of-lines-in-region m1r m3r) + (number-of-lines-in-region m4r m1l) + (number-of-lines-in-region m4l m1r) + (number-of-lines-in-region m3l m5l) + (number-of-lines-in-region m5r m4r) + (number-of-lines-in-region m5l m6l) + (number-of-lines-in-region m6r m5r) + (number-of-lines-in-region m6l m6r) + (number-of-lines-in-region m1l m6r) + (number-of-lines-in-region m3r m6l)))) + 0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 2 1) + +(deftest standard-buffer-number-of-lines-in-region.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs") + (let ((m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 6)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 6)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 7)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7))) + (values + (number-of-lines-in-region m1l 10) + (number-of-lines-in-region 10 m1l) + (number-of-lines-in-region m1r 10) + (number-of-lines-in-region 10 m1r) + (number-of-lines-in-region m1l 3) + (number-of-lines-in-region 3 m2l) + (number-of-lines-in-region 3 m2r) + (number-of-lines-in-region m2l 10) + (number-of-lines-in-region 10 m2r)))) + 1 1 1 1 0 0 0 1 1) + +(deftest constituentp.test-1 ; NOTE: more tests may be needed for sbcl + (values + (constituentp #\a) + (constituentp #\Newline) + (constituentp #\Space) + (constituentp #\Tab) + (constituentp "a") + (constituentp #\Null)) + t nil nil nil nil nil) + +(deftest whitespacep.test-1 + (values + (not (null (whitespacep #\a))) + (not (null (whitespacep #\Newline))) + (not (null (whitespacep #\Space))) + (not (null (whitespacep #\Tab))) + (not (null (whitespacep " "))) + (not (null (whitespacep #\Null)))) + nil nil t t nil nil) + +(deftest standard-buffer-forward-to-word-boundary.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs +climacs") + (let ((m0l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m0r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 5)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 5)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 17)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 17))) + (values + (progn (climacs-base::forward-to-word-boundary m0l) (offset m0l)) + (progn (climacs-base::forward-to-word-boundary m0r) (offset m0r)) + (progn (climacs-base::forward-to-word-boundary m1l) (offset m1l)) + (progn (climacs-base::forward-to-word-boundary m1r) (offset m1r)) + (progn (climacs-base::forward-to-word-boundary m2l) (offset m2l)) + (progn (climacs-base::forward-to-word-boundary m2r) (offset m2r))))) + 2 2 5 5 17 17) + +(deftest standard-buffer-backward-to-word-boundary.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs ") + (let ((m0l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 17)) + (m0r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 17)) + (m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 10)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 10)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (values + (progn (climacs-base::backward-to-word-boundary m0l) (offset m0l)) + (progn (climacs-base::backward-to-word-boundary m0r) (offset m0r)) + (progn (climacs-base::backward-to-word-boundary m1l) (offset m1l)) + (progn (climacs-base::backward-to-word-boundary m1r) (offset m1r)) + (progn (climacs-base::backward-to-word-boundary m2l) (offset m2l)) + (progn (climacs-base::backward-to-word-boundary m2r) (offset m2r))))) + 15 15 10 10 0 0) + +(deftest standard-buffer-forward-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs +climacs") + (let ((m0l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m0r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0)) + (m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 5)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 15)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 17)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 17))) + (values + (progn (forward-word m0l) (offset m0l)) + (progn (forward-word m0r) (offset m0r)) + (progn (forward-word m1l) (offset m1l)) + (progn (forward-word m1r) (offset m1r)) + (progn (forward-word m2l) (offset m2l)) + (progn (forward-word m2r) (offset m2r))))) + 9 9 9 17 17 17) + +(deftest standard-buffer-backward-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs +climacs ") + (let ((m0l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 17)) + (m0r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 17)) + (m1l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 10)) + (m1r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 5)) + (m2l (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 0)) + (m2r (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (values + (progn (backward-word m0l) (offset m0l)) + (progn (backward-word m0r) (offset m0r)) + (progn (backward-word m1l) (offset m1l)) + (progn (backward-word m1r) (offset m1r)) + (progn (backward-word m2l) (offset m2l)) + (progn (backward-word m2r) (offset m2r))))) + 8 8 8 0 0 0) + +(deftest standard-buffer-delete-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((m (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 3))) + (delete-word m) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "cli" 3) + +(deftest standard-buffer-delete-word.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs") + (let ((m (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (delete-word m) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + #() 0) + +(deftest standard-buffer-backward-delete-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs") + (let ((m (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 3))) + (backward-delete-word m) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "macs" 0) + +(deftest standard-buffer-backward-delete-word.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs ") + (let ((m (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 9))) + (backward-delete-word m) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + #() 0) + +(deftest standard-buffer-previous-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "climacs climacs") + (let ((m0 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 7)) + (m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 8)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 10))) + (values + (climacs-base::previous-word m0) + (climacs-base::previous-word m1) + (climacs-base::previous-word m2)))) + "climacs" #() "cl") \ No newline at end of file Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.8 climacs/buffer-test.lisp:1.9 --- climacs/buffer-test.lisp:1.8 Thu Jan 20 15:21:52 2005 +++ climacs/buffer-test.lisp Mon Jan 24 15:53:52 2005 @@ -526,6 +526,23 @@ (= 0 (line-number m1) (1- (line-number m2))))) t) +(deftest standard-buffer-buffer-column-number.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " climacs") + (values + (buffer-object buffer 2) + (buffer-column-number buffer 2))) + #\c 2) + +(deftest standard-buffer-buffer-column-number.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 " + climacs") + (values + (buffer-object buffer 3) + (buffer-column-number buffer 3))) + #\c 2) + (deftest standard-buffer-column-number.test-1 (let ((buffer (make-instance 'standard-buffer))) (insert-buffer-sequence buffer 0 "climacs From abakic at common-lisp.net Wed Jan 26 15:59:42 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Wed, 26 Jan 2005 07:59:42 -0800 (PST) Subject: [climacs-cvs] CVS update: Directory change: climacs/Persistent Message-ID: <20050126155942.F12298802D@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv1060/Persistent Log Message: Directory /project/climacs/cvsroot/climacs/Persistent added to the repository Date: Wed Jan 26 07:59:42 2005 Author: abakic New directory climacs/Persistent added From abakic at common-lisp.net Wed Jan 26 16:10:45 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Wed, 26 Jan 2005 08:10:45 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/buffer.lisp climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp Message-ID: <20050126161045.D28C88802D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1821 Modified Files: buffer.lisp climacs.asd gui.lisp packages.lisp pane.lisp Log Message: Persistent/balanced-tree buffer implementations with tests. Date: Wed Jan 26 08:10:41 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.23 climacs/buffer.lisp:1.24 --- climacs/buffer.lisp:1.23 Tue Jan 18 10:59:51 2005 +++ climacs/buffer.lisp Wed Jan 26 08:10:40 2005 @@ -92,7 +92,7 @@ (defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) () (:documentation "A right-sticky-mark subclass suitable for use in a standard-buffer")) -(defmethod initialize-instance :after ((mark left-sticky-mark) &rest args &key (offset 0)) +(defmethod initialize-instance :after ((mark standard-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) (assert (<= 0 offset (size (buffer mark))) () @@ -102,7 +102,7 @@ :chain (slot-value (buffer mark) 'contents) :position offset))) -(defmethod initialize-instance :after ((mark right-sticky-mark) &rest args &key (offset 0)) +(defmethod initialize-instance :after ((mark standard-right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args)) (assert (<= 0 offset (size (buffer mark))) () @@ -287,7 +287,7 @@ either immediately before the closest following newline character, or at the end of the buffer if no following newline character exists.")) -(defmethod end-of-line ((mark mark-mixin)) +(defmethod end-of-line ((mark mark-mixin)) ;PB (let* ((offset (offset mark)) (buffer (buffer mark)) (chain (slot-value buffer 'contents)) Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.15 climacs/climacs.asd:1.16 --- climacs/climacs.asd:1.15 Mon Jan 24 15:01:37 2005 +++ climacs/climacs.asd Wed Jan 26 08:10:40 2005 @@ -49,9 +49,13 @@ "Flexichain/utilities" "Flexichain/flexichain" "Flexichain/flexicursor" + "Persistent/binseq-package" + "Persistent/binseq" + "Persistent/obinseq" "translate" "packages" "buffer" + "Persistent/persistent-buffer" "base" "io" "abbrev" @@ -64,7 +68,9 @@ ;;---- optional ---- "testing/rt" "buffer-test" - "base-test") + "base-test" + "Persistent/persistent-buffer-test" + "Persistent/persistent-base-test") #+asdf (defmethod asdf:perform :around ((o asdf:compile-op) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.98 climacs/gui.lisp:1.99 --- climacs/gui.lisp:1.98 Mon Jan 24 04:49:09 2005 +++ climacs/gui.lisp Wed Jan 26 08:10:40 2005 @@ -747,7 +747,7 @@ (accept 'integer :prompt "Goto Position"))) (define-named-command com-goto-line () - (loop with mark = (make-instance 'standard-right-sticky-mark + (loop with mark = (make-instance 'standard-right-sticky-mark ;PB :buffer (buffer (current-window))) do (end-of-line mark) until (end-of-buffer-p mark) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.40 climacs/packages.lisp:1.41 --- climacs/packages.lisp:1.40 Mon Jan 24 04:49:09 2005 +++ climacs/packages.lisp Wed Jan 26 08:10:40 2005 @@ -23,7 +23,7 @@ ;;; Package definitions for the Climacs editor. (defpackage :climacs-buffer - (:use :clim-lisp :flexichain) + (:use :clim-lisp :flexichain :binseq) (:export #:buffer #:standard-buffer #:mark #:left-sticky-mark #:right-sticky-mark #:standard-left-sticky-mark #:standard-right-sticky-mark @@ -41,7 +41,10 @@ #:delete-region #:buffer-object #:buffer-sequence #:object-before #:object-after #:region-to-sequence - #:low-mark #:high-mark #:modified-p #:clear-modify)) + #:low-mark #:high-mark #:modified-p #:clear-modify + + #:binseq-buffer #:obinseq-buffer + #:persistent-left-sticky-mark #:persistent-right-sticky-mark)) (defpackage :climacs-base (:use :clim-lisp :climacs-buffer) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.13 climacs/pane.lisp:1.14 --- climacs/pane.lisp:1.13 Mon Jan 24 04:49:09 2005 +++ climacs/pane.lisp Wed Jan 26 08:10:41 2005 @@ -156,7 +156,7 @@ ;(defgeneric indent-tabs-mode (climacs-buffer)) -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) +(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) ;PB ((needs-saving :initform nil :accessor needs-saving) (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t @@ -195,14 +195,14 @@ (declare (ignore args)) (with-slots (buffer point mark) pane (when (null point) - (setf point (make-instance 'standard-right-sticky-mark + (setf point (make-instance 'standard-right-sticky-mark ;PB :buffer buffer))) (when (null mark) - (setf mark (make-instance 'standard-right-sticky-mark + (setf mark (make-instance 'standard-right-sticky-mark ;PB :buffer buffer)))) (with-slots (buffer top bot scan) pane - (setf top (make-instance 'standard-left-sticky-mark :buffer buffer) - bot (make-instance 'standard-right-sticky-mark :buffer buffer))) + (setf top (make-instance 'standard-left-sticky-mark :buffer buffer) ;PB + bot (make-instance 'standard-right-sticky-mark :buffer buffer))) ;PB (setf (stream-default-view pane) (make-instance 'climacs-textual-view)) (with-slots (space-width tab-width) (stream-default-view pane) (let* ((medium (sheet-medium pane)) @@ -212,12 +212,12 @@ (defmethod (setf buffer) :after (buffer (pane climacs-pane)) (with-slots (point mark top bot) pane - (setf point (make-instance 'standard-right-sticky-mark + (setf point (make-instance 'standard-right-sticky-mark ;PB :buffer buffer) - mark (make-instance 'standard-right-sticky-mark + mark (make-instance 'standard-right-sticky-mark ;PB :buffer buffer) - top (make-instance 'standard-left-sticky-mark :buffer buffer) - bot (make-instance 'standard-right-sticky-mark :buffer buffer)))) + top (make-instance 'standard-left-sticky-mark :buffer buffer) ;PB + bot (make-instance 'standard-right-sticky-mark :buffer buffer)))) ;PB (define-presentation-type url () :inherit-from 'string) From abakic at common-lisp.net Wed Jan 26 16:10:49 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Wed, 26 Jan 2005 08:10:49 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/Persistent/README climacs/Persistent/binseq-package.lisp climacs/Persistent/binseq.lisp climacs/Persistent/obinseq.lisp climacs/Persistent/persistent-base-test.lisp climacs/Persistent/persistent-buffer-test.lisp climacs/Persistent/persistent-buffer.lisp Message-ID: <20050126161049.6DD178802D@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv1821/Persistent Added Files: README binseq-package.lisp binseq.lisp obinseq.lisp persistent-base-test.lisp persistent-buffer-test.lisp persistent-buffer.lisp Log Message: Persistent/balanced-tree buffer implementations with tests. Date: Wed Jan 26 08:10:45 2005 Author: abakic From abakic at common-lisp.net Wed Jan 26 18:29:00 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Wed, 26 Jan 2005 10:29:00 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/Persistent/persistent-base-test.lisp climacs/Persistent/persistent-buffer.lisp climacs/Persistent/persistent-buffer-test.lisp Message-ID: <20050126182900.8F3238802D@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv9143 Modified Files: persistent-base-test.lisp persistent-buffer.lisp persistent-buffer-test.lisp Log Message: Cleanup and some more info. Date: Wed Jan 26 10:28:57 2005 Author: abakic Index: climacs/Persistent/persistent-base-test.lisp diff -u climacs/Persistent/persistent-base-test.lisp:1.1 climacs/Persistent/persistent-base-test.lisp:1.2 --- climacs/Persistent/persistent-base-test.lisp:1.1 Wed Jan 26 08:10:45 2005 +++ climacs/Persistent/persistent-base-test.lisp Wed Jan 26 10:28:56 2005 @@ -461,26 +461,6 @@ (number-of-lines-in-region 10 m2r)))) 1 1 1 1 0 0 0 1 1) -(deftest constituentp.test-1 ; NOTE: more tests may be needed for sbcl - (values - (constituentp #\a) - (constituentp #\Newline) - (constituentp #\Space) - (constituentp #\Tab) - (constituentp "a") - (constituentp #\Null)) - t nil nil nil nil nil) - -(deftest whitespacep.test-1 - (values - (not (null (whitespacep #\a))) - (not (null (whitespacep #\Newline))) - (not (null (whitespacep #\Space))) - (not (null (whitespacep #\Tab))) - (not (null (whitespacep " "))) - (not (null (whitespacep #\Null)))) - nil nil t t nil nil) - (deftest binseq-buffer-forward-to-word-boundary.test-1 (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-sequence buffer 0 " climacs @@ -1080,26 +1060,6 @@ (number-of-lines-in-region m2l 10) (number-of-lines-in-region 10 m2r)))) 1 1 1 1 0 0 0 1 1) - -(deftest constituentp.test-1 ; NOTE: more tests may be needed for sbcl - (values - (constituentp #\a) - (constituentp #\Newline) - (constituentp #\Space) - (constituentp #\Tab) - (constituentp "a") - (constituentp #\Null)) - t nil nil nil nil nil) - -(deftest whitespacep.test-1 - (values - (not (null (whitespacep #\a))) - (not (null (whitespacep #\Newline))) - (not (null (whitespacep #\Space))) - (not (null (whitespacep #\Tab))) - (not (null (whitespacep " "))) - (not (null (whitespacep #\Null)))) - nil nil t t nil nil) (deftest obinseq-buffer-forward-to-word-boundary.test-1 (let ((buffer (make-instance 'obinseq-buffer))) Index: climacs/Persistent/persistent-buffer.lisp diff -u climacs/Persistent/persistent-buffer.lisp:1.1 climacs/Persistent/persistent-buffer.lisp:1.2 --- climacs/Persistent/persistent-buffer.lisp:1.1 Wed Jan 26 08:10:45 2005 +++ climacs/Persistent/persistent-buffer.lisp Wed Jan 26 10:28:56 2005 @@ -24,6 +24,9 @@ (in-package :climacs-buffer) +;;; For now, pos contains just an integer, while it might contain a cons +;;; of two adjacent buffer elements for higher performance (with the help +;;; of buffer implementation, especially the rebalancing part). (defclass persistent-cursor () ((buffer :reader buffer :initarg :buffer) ; TODO: fix overlap with mark? (pos :accessor cursor-pos)) @@ -151,6 +154,9 @@ while (> i 0) until (eql (buffer-object buffer (1- i)) #\Newline) count t)) + +;;; the old value of the CONTENTS slot is dropped upon modification +;;; it can be saved for UNDO purposes in a history tree, by an UNDOABLE-BUFFER (defmethod insert-buffer-object ((buffer binseq-buffer) offset object) (assert (<= 0 offset (size buffer)) () Index: climacs/Persistent/persistent-buffer-test.lisp diff -u climacs/Persistent/persistent-buffer-test.lisp:1.1 climacs/Persistent/persistent-buffer-test.lisp:1.2 --- climacs/Persistent/persistent-buffer-test.lisp:1.1 Wed Jan 26 08:10:45 2005 +++ climacs/Persistent/persistent-buffer-test.lisp Wed Jan 26 10:28:56 2005 @@ -53,11 +53,7 @@ (flet ((%all-eq (&optional x y) (cond ((null x) nil) - (t (when (eq x y) y)))) - (%all-= (&optional x y) - (cond - ((null x) nil) - (t (when (= x y) y))))) + (t (when (eq x y) y))))) (let* ((buffer (make-instance 'binseq-buffer)) (low (slot-value buffer 'low-mark)) (high (slot-value buffer 'high-mark)) @@ -762,11 +758,7 @@ (flet ((%all-eq (&optional x y) (cond ((null x) nil) - (t (when (eq x y) y)))) - (%all-= (&optional x y) - (cond - ((null x) nil) - (t (when (= x y) y))))) + (t (when (eq x y) y))))) (let* ((buffer (make-instance 'obinseq-buffer)) (low (slot-value buffer 'low-mark)) (high (slot-value buffer 'high-mark)) From mvilleneuve at common-lisp.net Wed Jan 26 22:49:50 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Wed, 26 Jan 2005 14:49:50 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp Message-ID: <20050126224950.404D58802D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23005 Modified Files: gui.lisp packages.lisp pane.lisp Log Message: Added basic query-replace support. First humble try at command loop factoring Date: Wed Jan 26 14:49:47 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.99 climacs/gui.lisp:1.100 --- climacs/gui.lisp:1.99 Wed Jan 26 08:10:40 2005 +++ climacs/gui.lisp Wed Jan 26 14:49:46 2005 @@ -280,6 +280,32 @@ (setf (executingp *application-frame*) nil) (redisplay-frame-panes frame)))))) +(defmacro simple-command-loop (command-table loop-condition end-clauses) + (let ((gesture (gensym)) + (item (gensym)) + (command (gensym)) + (condition (gensym))) + `(progn + (redisplay-frame-panes *application-frame*) + (loop while ,loop-condition + as ,gesture = (climacs-read-gesture) + as ,item = (find-gestures (list ,gesture) ,command-table) + do (cond ((and ,item (eq (command-menu-item-type ,item) :command)) + (setf *current-gesture* ,gesture) + (let ((,command (command-menu-item-value ,item))) + (unless (consp ,command) + (setf ,command (list ,command))) + (handler-case + (execute-frame-command *application-frame* + ,command) + (error (,condition) + (beep) + (format *error-output* "~a~%" ,condition))))) + (t + (unread-gesture ,gesture) + , at end-clauses)) + (redisplay-frame-panes *application-frame*))))) + (defun region-limits (pane) (if (mark< (mark pane) (point pane)) (values (mark pane) (point pane)) @@ -1006,24 +1032,9 @@ :search-string "" :search-mark (clone-mark point) :search-forward-p forwardp))) - (redisplay-frame-panes *application-frame*) - (loop while (isearch-mode pane) - as gesture = (climacs-read-gesture) - as item = (find-gestures (list gesture) 'isearch-climacs-table) - do (cond ((and item (eq (command-menu-item-type item) :command)) - (setf *current-gesture* gesture) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (handler-case - (execute-frame-command *application-frame* command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))))) - (t - (unread-gesture gesture) - (setf (isearch-mode pane) nil))) - (redisplay-frame-panes *application-frame*)))) + (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) @@ -1104,6 +1115,56 @@ (define-named-command com-isearch-exit () (setf (isearch-mode (current-window)) nil)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Query replace + +(defun query-replace-find-next-match (mark string) + (let ((offset-before (offset mark))) + (search-forward mark string) + (/= (offset mark) offset-before))) + +(define-named-command com-query-replace () + (let* ((string1 (accept 'string :prompt "Query replace")) + (string2 (accept 'string + :prompt (format nil "Query replace ~A with" + string1))) + (pane (current-window)) + (point (point pane))) + (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) + (simple-command-loop 'query-replace-climacs-table + (query-replace-mode pane) + ((setf (query-replace-mode pane) nil)))))) + +(define-named-command com-query-replace-replace () + (let* ((pane (current-window)) + (point (point pane)) + (state (query-replace-state pane)) + (string1-length (length (string1 state)))) + (backward-object point string1-length) + (delete-range point string1-length) + (insert-sequence point (string2 state)) + (unless (query-replace-find-next-match point (string1 state)) + (setf (query-replace-mode pane) nil)))) + +(define-named-command com-query-replace-skip () + (let* ((pane (current-window)) + (point (point pane)) + (state (query-replace-state pane))) + (unless (query-replace-find-next-match point (string1 state)) + (setf (query-replace-mode pane) nil)))) + +(define-named-command com-query-replace-exit () + (setf (query-replace-mode (current-window)) nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Undo/redo + (define-named-command com-undo () (undo (undo-tree (buffer (current-window))))) @@ -1230,6 +1291,7 @@ (global-set-key '(#\e :control :meta) 'com-end-of-paragraph) (global-set-key '(#\s :control) 'com-isearch-mode-forward) (global-set-key '(#\r :control) 'com-isearch-mode-backward) +(global-set-key '(#\% :shift :meta) 'com-query-replace) (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) @@ -1457,3 +1519,21 @@ (isearch-set-key '(#\Backspace) 'com-isearch-delete-char) (isearch-set-key '(#\s :control) 'com-isearch-forward) (isearch-set-key '(#\r :control) 'com-isearch-backward) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Query replace command table + +(make-command-table 'query-replace-climacs-table :errorp 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) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.41 climacs/packages.lisp:1.42 --- climacs/packages.lisp:1.41 Wed Jan 26 08:10:40 2005 +++ climacs/packages.lisp Wed Jan 26 14:49:47 2005 @@ -110,6 +110,8 @@ #:auto-fill-mode #:auto-fill-column #:isearch-state #:search-string #:search-mark #:search-forward-p #:isearch-mode #:isearch-states #:isearch-previous-string + #:query-replace-state #:string1 #:string2 + #:query-replace-mode #:with-undo #:url)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.14 climacs/pane.lisp:1.15 --- climacs/pane.lisp:1.14 Wed Jan 26 08:10:41 2005 +++ climacs/pane.lisp Wed Jan 26 14:49:47 2005 @@ -146,6 +146,14 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Query replace + +(defclass query-replace-state () + ((string1 :initarg :string1 :accessor string1) + (string2 :initarg :string2 :accessor string2))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; View (defclass climacs-textual-view (textual-view tabify-mixin) @@ -180,6 +188,8 @@ (isearch-mode :initform nil :accessor isearch-mode) (isearch-states :initform '() :accessor isearch-states) (isearch-previous-string :initform nil :accessor isearch-previous-string) + (query-replace-mode :initform nil :accessor query-replace-mode) + (query-replace-state :initform nil :accessor query-replace-state) (full-redisplay-p :initform nil :accessor full-redisplay-p) (cache :initform (let ((cache (make-instance 'standard-flexichain))) (insert* cache 0 nil) From abakic at common-lisp.net Fri Jan 28 18:47:36 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Fri, 28 Jan 2005 10:47:36 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base-test.lisp climacs/base.lisp climacs/buffer-test.lisp climacs/gui.lisp Message-ID: <20050128184736.E1B548802A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31513 Modified Files: base-test.lisp base.lisp buffer-test.lisp gui.lisp Log Message: Changed downcase, upcase and capitalize methods to be symmetrical wrt. marks. Added (setf buffer-object) methods to binseq-buffer and obinseq-buffer. More tests and comments. Date: Fri Jan 28 10:47:31 2005 Author: abakic Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.2 climacs/base-test.lisp:1.3 --- climacs/base-test.lisp:1.2 Mon Jan 24 15:53:52 2005 +++ climacs/base-test.lisp Fri Jan 28 10:47:29 2005 @@ -621,4 +621,152 @@ (climacs-base::previous-word m0) (climacs-base::previous-word m1) (climacs-base::previous-word m2)))) - "climacs" #() "cl") \ No newline at end of file + "climacs" #() "cl") + +(deftest standard-buffer-downcase-buffer-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "Cli mac5") + (climacs-base::downcase-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "cli mac5") + +(deftest standard-buffer-downcase-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 8))) + (downcase-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest standard-buffer-downcase-region.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 1))) + (downcase-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest standard-buffer-downcase-region.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 8))) + (downcase-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest standard-buffer-downcase-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "CLI MA CS") + (let ((m (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (downcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "cli ma cs" 9) + +(deftest standard-buffer-upcase-buffer-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "Cli mac5") + (climacs-base::upcase-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "CLI MAC5") + +(deftest standard-buffer-upcase-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 8))) + (upcase-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest standard-buffer-upcase-region.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 1))) + (upcase-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest standard-buffer-upcase-region.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 8))) + (upcase-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest standard-buffer-upcase-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (let ((m (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (upcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "CLI MA CS" 9) + +(deftest standard-buffer-capitalize-buffer-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (climacs-base::capitalize-buffer-region buffer 1 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "cli Ma Cs") + +(deftest standard-buffer-capitalize-buffer-region.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "CLI mA Cs") + (climacs-base::capitalize-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "Cli Ma Cs") + +(deftest standard-buffer-capitalize-region.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 8))) + (capitalize-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest standard-buffer-capitalize-region.test-2 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 1))) + (capitalize-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest standard-buffer-capitalize-region.test-3 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'standard-left-sticky-mark + :buffer buffer :offset 8))) + (capitalize-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest standard-buffer-capitalize-word.test-1 + (let ((buffer (make-instance 'standard-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (let ((m (make-instance 'standard-right-sticky-mark + :buffer buffer :offset 0))) + (capitalize-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "Cli Ma Cs" 9) Index: climacs/base.lisp diff -u climacs/base.lisp:1.25 climacs/base.lisp:1.26 --- climacs/base.lisp:1.25 Mon Jan 24 15:53:52 2005 +++ climacs/base.lisp Fri Jan 28 10:47:29 2005 @@ -217,6 +217,8 @@ ;;; ;;; Character case +;;; I'd rather have update-buffer-range methods spec. on buffer for this, +;;; for performance and history-size reasons --amb (defun downcase-buffer-region (buffer offset1 offset2) (do-buffer-region (object offset buffer offset1 offset2) (when (and (constituentp object) (upper-case-p object)) @@ -229,13 +231,23 @@ (defmethod downcase-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) - (downcase-buffer-region (buffer mark1) (offset mark1) (offset mark2))) - -(defmethod downcase-region ((offset integer) (mark mark)) - (downcase-buffer-region (buffer mark) offset (offset mark))) - -(defmethod downcase-region ((mark mark) (offset integer)) - (downcase-buffer-region (buffer mark) (offset mark) offset)) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod downcase-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod downcase-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark1) offset1 offset2))) (defun downcase-word (mark &optional (n 1)) "Convert the next N words to lowercase, leaving mark after the last word." @@ -257,13 +269,23 @@ (defmethod upcase-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) - (upcase-buffer-region (buffer mark1) (offset mark1) (offset mark2))) - -(defmethod upcase-region ((offset integer) (mark mark)) - (upcase-buffer-region (buffer mark) offset (offset mark))) - -(defmethod upcase-region ((mark mark) (offset integer)) - (upcase-buffer-region (buffer mark) (offset mark) offset)) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod upcase-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod upcase-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark1) offset1 offset2))) (defun upcase-word (mark &optional (n 1)) "Convert the next N words to uppercase, leaving mark after the last word." @@ -293,13 +315,23 @@ (defmethod capitalize-region ((mark1 mark) (mark2 mark)) (assert (eq (buffer mark1) (buffer mark2))) - (capitalize-buffer-region (buffer mark1) (offset mark1) (offset mark2))) - -(defmethod capitalize-region ((offset integer) (mark mark)) - (capitalize-buffer-region (buffer mark) offset (offset mark))) - -(defmethod capitalize-region ((mark mark) (offset integer)) - (capitalize-buffer-region (buffer mark) (offset mark) offset)) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod capitalize-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod capitalize-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark1) offset1 offset2))) (defun capitalize-word (mark &optional (n 1)) "Capitalize the next N words, leaving mark after the last word." Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.9 climacs/buffer-test.lisp:1.10 --- climacs/buffer-test.lisp:1.9 Mon Jan 24 15:53:52 2005 +++ climacs/buffer-test.lisp Fri Jan 28 10:47:29 2005 @@ -61,22 +61,37 @@ (deftest standard-buffer-insert-buffer-object.test-1 (let ((buffer (make-instance 'standard-buffer))) (insert-buffer-object buffer 0 #\a) - (and (= (size buffer) 1) (buffer-sequence buffer 0 1))) - "a") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 1))) + 0 1 t 1 "a") (deftest standard-buffer-insert-buffer-object.test-2 (let ((buffer (make-instance 'standard-buffer))) (insert-buffer-object buffer 0 #\b) (insert-buffer-object buffer 0 #\a) - (and (= (size buffer) 2) (buffer-sequence buffer 0 2))) - "ab") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 2))) + 0 2 t 2 "ab") (deftest standard-buffer-insert-buffer-object.test-3 (let ((buffer (make-instance 'standard-buffer))) (insert-buffer-object buffer 0 #\b) (insert-buffer-object buffer 1 #\a) - (and (= (size buffer) 2) (buffer-sequence buffer 0 2))) - "ba") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 2))) + 0 2 t 2 "ba") (deftest standard-buffer-insert-buffer-object.test-4 (handler-case @@ -140,15 +155,24 @@ (let ((buffer (make-instance 'standard-buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 0 7) - (size buffer)) - 0) + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer))) + 0 0 t 0) (deftest standard-buffer-delete-buffer-range.test-2 (let ((buffer (make-instance 'standard-buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 0 3) - (and (= (size buffer) 4) (buffer-sequence buffer 0 4))) - "macs") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 4))) + 0 4 t 4 "macs") (deftest standard-buffer-delete-buffer-range.test-3 (let ((buffer (make-instance 'standard-buffer))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.100 climacs/gui.lisp:1.101 --- climacs/gui.lisp:1.100 Wed Jan 26 14:49:46 2005 +++ climacs/gui.lisp Fri Jan 28 10:47:29 2005 @@ -478,16 +478,16 @@ (backward-delete-word (point (current-window)))) (define-named-command com-upcase-region () - (multiple-value-bind (start end) (region-limits (current-window)) - (upcase-region start end))) + (let ((cw (current-window))) + (upcase-region (mark cw) (point cw)))) (define-named-command com-downcase-region () - (multiple-value-bind (start end) (region-limits (current-window)) - (downcase-region start end))) + (let ((cw (current-window))) + (downcase-region (mark cw) (point cw)))) (define-named-command com-capitalize-region () - (multiple-value-bind (start end) (region-limits (current-window)) - (capitalize-region start end))) + (let ((cw (current-window))) + (capitalize-region (mark cw) (point cw)))) (define-named-command com-upcase-word () (upcase-word (point (current-window)))) From abakic at common-lisp.net Fri Jan 28 18:47:47 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Fri, 28 Jan 2005 10:47:47 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/Persistent/README climacs/Persistent/persistent-base-test.lisp climacs/Persistent/persistent-buffer-test.lisp climacs/Persistent/persistent-buffer.lisp Message-ID: <20050128184747.2B0208864F@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv31513/Persistent Modified Files: README persistent-base-test.lisp persistent-buffer-test.lisp persistent-buffer.lisp Log Message: Changed downcase, upcase and capitalize methods to be symmetrical wrt. marks. Added (setf buffer-object) methods to binseq-buffer and obinseq-buffer. More tests and comments. Date: Fri Jan 28 10:47:37 2005 Author: abakic Index: climacs/Persistent/README diff -u climacs/Persistent/README:1.1 climacs/Persistent/README:1.2 --- climacs/Persistent/README:1.1 Wed Jan 26 08:10:45 2005 +++ climacs/Persistent/README Fri Jan 28 10:47:34 2005 @@ -20,8 +20,8 @@ (setf (offset mark) offset))) (It is currently "broken" for performance reasons.) Until then, -(o)binseq-end-of-line and (o)binseq-next-line tests will fail (20 of -them). +(o)binseq-end-of-line, (o)binseq-next-line and (o)binseq-kill-line +tests will fail (20 of them). NOTE: There is a dependency of Persistent/persistent-buffer.lisp on Flexichain/utilities.lisp (the weak pointer handling). Index: climacs/Persistent/persistent-base-test.lisp diff -u climacs/Persistent/persistent-base-test.lisp:1.2 climacs/Persistent/persistent-base-test.lisp:1.3 --- climacs/Persistent/persistent-base-test.lisp:1.2 Wed Jan 26 10:28:56 2005 +++ climacs/Persistent/persistent-base-test.lisp Fri Jan 28 10:47:34 2005 @@ -620,6 +620,154 @@ (climacs-base::previous-word m2)))) "climacs" #() "cl") +(deftest binseq-buffer-downcase-buffer-region.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "Cli mac5") + (climacs-base::downcase-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "cli mac5") + +(deftest binseq-buffer-downcase-region.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 8))) + (downcase-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest binseq-buffer-downcase-region.test-2 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 1))) + (downcase-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest binseq-buffer-downcase-region.test-3 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 8))) + (downcase-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest binseq-buffer-downcase-word.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "CLI MA CS") + (let ((m (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 0))) + (downcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "cli ma cs" 9) + +(deftest binseq-buffer-upcase-buffer-region.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "Cli mac5") + (climacs-base::upcase-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "CLI MAC5") + +(deftest binseq-buffer-upcase-region.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 8))) + (upcase-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest binseq-buffer-upcase-region.test-2 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 1))) + (upcase-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest binseq-buffer-upcase-region.test-3 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 8))) + (upcase-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest binseq-buffer-upcase-word.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (let ((m (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 0))) + (upcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "CLI MA CS" 9) + +(deftest binseq-buffer-capitalize-buffer-region.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (climacs-base::capitalize-buffer-region buffer 1 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "cli Ma Cs") + +(deftest binseq-buffer-capitalize-buffer-region.test-2 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "CLI mA Cs") + (climacs-base::capitalize-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "Cli Ma Cs") + +(deftest binseq-buffer-capitalize-region.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 8))) + (capitalize-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest binseq-buffer-capitalize-region.test-2 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 1))) + (capitalize-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest binseq-buffer-capitalize-region.test-3 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 8))) + (capitalize-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest binseq-buffer-capitalize-word.test-1 + (let ((buffer (make-instance 'binseq-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (let ((m (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 0))) + (capitalize-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "Cli Ma Cs" 9) + ;;; obinseq tests (deftest obinseq-buffer-previous-line.test-1 @@ -1219,3 +1367,151 @@ (climacs-base::previous-word m1) (climacs-base::previous-word m2)))) "climacs" #() "cl") + +(deftest obinseq-buffer-downcase-buffer-region.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "Cli mac5") + (climacs-base::downcase-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "cli mac5") + +(deftest obinseq-buffer-downcase-region.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 8))) + (downcase-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest obinseq-buffer-downcase-region.test-2 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 1))) + (downcase-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest obinseq-buffer-downcase-region.test-3 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 8))) + (downcase-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_cli mac5_") + +(deftest obinseq-buffer-downcase-word.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "CLI MA CS") + (let ((m (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 0))) + (downcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "cli ma cs" 9) + +(deftest obinseq-buffer-upcase-buffer-region.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "Cli mac5") + (climacs-base::upcase-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "CLI MAC5") + +(deftest obinseq-buffer-upcase-region.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 8))) + (upcase-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest obinseq-buffer-upcase-region.test-2 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 1))) + (upcase-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest obinseq-buffer-upcase-region.test-3 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 8))) + (upcase-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_CLI MAC5_") + +(deftest obinseq-buffer-upcase-word.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (let ((m (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 0))) + (upcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "CLI MA CS" 9) + +(deftest obinseq-buffer-capitalize-buffer-region.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (climacs-base::capitalize-buffer-region buffer 1 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "cli Ma Cs") + +(deftest obinseq-buffer-capitalize-buffer-region.test-2 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "CLI mA Cs") + (climacs-base::capitalize-buffer-region buffer 0 (size buffer)) + (buffer-sequence buffer 0 (size buffer))) + "Cli Ma Cs") + +(deftest obinseq-buffer-capitalize-region.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 1)) + (m2 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 8))) + (capitalize-region m2 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest obinseq-buffer-capitalize-region.test-2 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 1))) + (capitalize-region 8 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest obinseq-buffer-capitalize-region.test-3 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "_Cli mac5_") + (let ((m1 (make-instance 'persistent-left-sticky-mark + :buffer buffer :offset 8))) + (capitalize-region 1 m1) + (buffer-sequence buffer 0 (size buffer)))) + "_Cli Mac5_") + +(deftest obinseq-buffer-capitalize-word.test-1 + (let ((buffer (make-instance 'obinseq-buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs") + (let ((m (make-instance 'persistent-right-sticky-mark + :buffer buffer :offset 0))) + (capitalize-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "Cli Ma Cs" 9) \ No newline at end of file Index: climacs/Persistent/persistent-buffer-test.lisp diff -u climacs/Persistent/persistent-buffer-test.lisp:1.2 climacs/Persistent/persistent-buffer-test.lisp:1.3 --- climacs/Persistent/persistent-buffer-test.lisp:1.2 Wed Jan 26 10:28:56 2005 +++ climacs/Persistent/persistent-buffer-test.lisp Fri Jan 28 10:47:34 2005 @@ -75,22 +75,37 @@ (deftest binseq-buffer-insert-buffer-object.test-1 (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-object buffer 0 #\a) - (and (= (size buffer) 1) (buffer-sequence buffer 0 1))) - "a") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 1))) + 0 1 t 1 "a") (deftest binseq-buffer-insert-buffer-object.test-2 (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-object buffer 0 #\b) (insert-buffer-object buffer 0 #\a) - (and (= (size buffer) 2) (buffer-sequence buffer 0 2))) - "ab") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 2))) + 0 2 t 2 "ab") (deftest binseq-buffer-insert-buffer-object.test-3 (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-object buffer 0 #\b) (insert-buffer-object buffer 1 #\a) - (and (= (size buffer) 2) (buffer-sequence buffer 0 2))) - "ba") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 2))) + 0 2 t 2 "ba") (deftest binseq-buffer-insert-buffer-object.test-4 (handler-case @@ -154,15 +169,24 @@ (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 0 7) - (size buffer)) - 0) + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer))) + 0 0 t 0) (deftest binseq-buffer-delete-buffer-range.test-2 (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 0 3) - (and (= (size buffer) 4) (buffer-sequence buffer 0 4))) - "macs") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 4))) + 0 4 t 4 "macs") (deftest binseq-buffer-delete-buffer-range.test-3 (let ((buffer (make-instance 'binseq-buffer))) @@ -780,22 +804,37 @@ (deftest obinseq-buffer-insert-buffer-object.test-1 (let ((buffer (make-instance 'obinseq-buffer))) (insert-buffer-object buffer 0 #\a) - (and (= (size buffer) 1) (buffer-sequence buffer 0 1))) - "a") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 1))) + 0 1 t 1 "a") (deftest obinseq-buffer-insert-buffer-object.test-2 (let ((buffer (make-instance 'obinseq-buffer))) (insert-buffer-object buffer 0 #\b) (insert-buffer-object buffer 0 #\a) - (and (= (size buffer) 2) (buffer-sequence buffer 0 2))) - "ab") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 2))) + 0 2 t 2 "ab") (deftest obinseq-buffer-insert-buffer-object.test-3 (let ((buffer (make-instance 'obinseq-buffer))) (insert-buffer-object buffer 0 #\b) (insert-buffer-object buffer 1 #\a) - (and (= (size buffer) 2) (buffer-sequence buffer 0 2))) - "ba") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 2))) + 0 2 t 2 "ba") (deftest obinseq-buffer-insert-buffer-object.test-4 (handler-case @@ -859,15 +898,24 @@ (let ((buffer (make-instance 'obinseq-buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 0 7) - (size buffer)) - 0) + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer))) + 0 0 t 0) (deftest obinseq-buffer-delete-buffer-range.test-2 (let ((buffer (make-instance 'obinseq-buffer))) (insert-buffer-sequence buffer 0 "climacs") (delete-buffer-range buffer 0 3) - (and (= (size buffer) 4) (buffer-sequence buffer 0 4))) - "macs") + (values + (offset (low-mark buffer)) + (offset (high-mark buffer)) + (modified-p buffer) + (size buffer) + (buffer-sequence buffer 0 4))) + 0 4 t 4 "macs") (deftest obinseq-buffer-delete-buffer-range.test-3 (let ((buffer (make-instance 'obinseq-buffer))) Index: climacs/Persistent/persistent-buffer.lisp diff -u climacs/Persistent/persistent-buffer.lisp:1.2 climacs/Persistent/persistent-buffer.lisp:1.3 --- climacs/Persistent/persistent-buffer.lisp:1.2 Wed Jan 26 10:28:56 2005 +++ climacs/Persistent/persistent-buffer.lisp Fri Jan 28 10:47:36 2005 @@ -197,10 +197,22 @@ (make-condition 'no-such-offset :offset offset)) (binseq-get (slot-value buffer 'contents) offset)) +(defmethod (setf buffer-object) (object (buffer binseq-buffer) offset) + (assert (<= 0 offset (1- (size buffer))) () + (make-condition 'no-such-offset :offset offset)) + (setf (slot-value buffer 'contents) + (binseq-set (slot-value buffer 'contents) offset object))) + (defmethod buffer-object ((buffer obinseq-buffer) offset) (assert (<= 0 offset (1- (size buffer))) () (make-condition 'no-such-offset :offset offset)) (obinseq-get (slot-value buffer 'contents) offset)) + +(defmethod (setf buffer-object) (object (buffer obinseq-buffer) offset) + (assert (<= 0 offset (1- (size buffer))) () + (make-condition 'no-such-offset :offset offset)) + (setf (slot-value buffer 'contents) + (obinseq-set (slot-value buffer 'contents) offset object))) (defmethod buffer-sequence ((buffer binseq-buffer) offset1 offset2) (assert (<= 0 offset1 (size buffer)) () From rstrandh at common-lisp.net Sat Jan 29 06:53:46 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 28 Jan 2005 22:53:46 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp Message-ID: <20050129065346.3ED6388029@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5499 Modified Files: base.lisp gui.lisp Log Message: The functions forward-word and backward-word now thake an optional count argument. The corresponding Climacs command now accept numeric arguments. Date: Fri Jan 28 22:53:45 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.26 climacs/base.lisp:1.27 --- climacs/base.lisp:1.26 Fri Jan 28 10:47:29 2005 +++ climacs/base.lisp Fri Jan 28 22:53:44 2005 @@ -178,19 +178,21 @@ until (constituentp (object-before mark)) do (decf (offset mark)))) -(defun forward-word (mark) +(defun forward-word (mark &optional (count 1)) "Forward the mark to the next word." - (forward-to-word-boundary mark) - (loop until (end-of-buffer-p mark) - while (constituentp (object-after mark)) - do (incf (offset mark)))) + (loop repeat count + do (forward-to-word-boundary mark) + (loop until (end-of-buffer-p mark) + while (constituentp (object-after mark)) + do (incf (offset mark))))) -(defun backward-word (mark) +(defun backward-word (mark &optional (count 1)) "Shuttle the mark to the start of the previous word." - (backward-to-word-boundary mark) - (loop until (beginning-of-buffer-p mark) - while (constituentp (object-before mark)) - do (decf (offset mark)))) + (loop repeat count + do (backward-to-word-boundary mark) + (loop until (beginning-of-buffer-p mark) + while (constituentp (object-before mark)) + do (decf (offset mark))))) (defun delete-word (mark) "Delete until the end of the word" Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.101 climacs/gui.lisp:1.102 --- climacs/gui.lisp:1.101 Fri Jan 28 10:47:29 2005 +++ climacs/gui.lisp Fri Jan 28 22:53:44 2005 @@ -465,11 +465,11 @@ (region-to-sequence mark point))) (delete-region mark point))) -(define-named-command com-forward-word () - (forward-word (point (current-window)))) +(define-named-command com-forward-word ((count 'integer :prompt "Number of words")) + (forward-word (point (current-window)) count)) -(define-named-command com-backward-word () - (backward-word (point (current-window)))) +(define-named-command com-backward-word ((count 'integer :prompt "Number of words")) + (backward-word (point (current-window)) count)) (define-named-command com-delete-word () (delete-word (point (current-window)))) @@ -1268,8 +1268,8 @@ (global-set-key '(#\Space :control) 'com-set-mark) (global-set-key '(#\y :control) 'com-yank) (global-set-key '(#\w :control) 'com-cut-out) -(global-set-key '(#\f :meta) 'com-forward-word) -(global-set-key '(#\b :meta) 'com-backward-word) +(global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*)) +(global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*)) (global-set-key '(#\t :meta) 'com-transpose-words) (global-set-key '(#\u :meta) 'com-upcase-word) (global-set-key '(#\l :meta) 'com-downcase-word) @@ -1297,8 +1297,8 @@ (global-set-key '(:down) 'com-next-line) (global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*)) (global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*)) -(global-set-key '(:left :control) 'com-backward-word) -(global-set-key '(:right :control) 'com-forward-word) +(global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*)) +(global-set-key '(:right :control) `(com-forward-word ,*numeric-argument-marker*)) (global-set-key '(:home) 'com-beginning-of-line) (global-set-key '(:end) 'com-end-of-line) (global-set-key '(:prior) 'com-page-up) From rstrandh at common-lisp.net Sat Jan 29 07:05:46 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 28 Jan 2005 23:05:46 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp Message-ID: <20050129070546.EFEE988029@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6295 Modified Files: base.lisp gui.lisp Log Message: The functions delete-word and backward-delete-word now take an optional count argument. The corresponding Climacs commands now accept numeric arguments. Date: Fri Jan 28 23:05:42 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.27 climacs/base.lisp:1.28 --- climacs/base.lisp:1.27 Fri Jan 28 22:53:44 2005 +++ climacs/base.lisp Fri Jan 28 23:05:42 2005 @@ -194,16 +194,16 @@ while (constituentp (object-before mark)) do (decf (offset mark))))) -(defun delete-word (mark) +(defun delete-word (mark &optional (count 1)) "Delete until the end of the word" (let ((mark2 (clone-mark mark))) - (forward-word mark2) + (forward-word mark2 count) (delete-region mark mark2))) -(defun backward-delete-word (mark) +(defun backward-delete-word (mark &optional (count 1)) "Delete until the beginning of the word" (let ((mark2 (clone-mark mark))) - (backward-word mark2) + (backward-word mark2 count) (delete-region mark mark2))) (defun previous-word (mark) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.102 climacs/gui.lisp:1.103 --- climacs/gui.lisp:1.102 Fri Jan 28 22:53:44 2005 +++ climacs/gui.lisp Fri Jan 28 23:05:42 2005 @@ -471,11 +471,11 @@ (define-named-command com-backward-word ((count 'integer :prompt "Number of words")) (backward-word (point (current-window)) count)) -(define-named-command com-delete-word () - (delete-word (point (current-window)))) +(define-named-command com-delete-word ((count 'integer :prompt "Number of words")) + (delete-word (point (current-window)) count)) -(define-named-command com-backward-delete-word () - (backward-delete-word (point (current-window)))) +(define-named-command com-backward-delete-word ((count 'integer :prompt "Number of words")) + (backward-delete-word (point (current-window)) count)) (define-named-command com-upcase-region () (let ((cw (current-window))) @@ -1284,8 +1284,8 @@ (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\^ :shift :meta) 'com-delete-indentation) (global-set-key '(#\q :meta) 'com-fill-paragraph) -(global-set-key '(#\d :meta) 'com-delete-word) -(global-set-key '(#\Backspace :meta) 'com-backward-delete-word) +(global-set-key '(#\d :meta) `(com-delete-word ,*numeric-argument-marker*)) +(global-set-key '(#\Backspace :meta) `(com-backward-delete-word ,*numeric-argument-marker*)) (global-set-key '(#\/ :meta) 'com-dabbrev-expand) (global-set-key '(#\a :control :meta) 'com-beginning-of-paragraph) (global-set-key '(#\e :control :meta) 'com-end-of-paragraph) From mvilleneuve at common-lisp.net Sat Jan 29 13:16:27 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sat, 29 Jan 2005 05:16:27 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp Message-ID: <20050129131627.93C6E8802D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25515 Modified Files: base.lisp Log Message: Fixed capitalize-buffer-region's behavior Date: Sat Jan 29 05:16:25 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.28 climacs/base.lisp:1.29 --- climacs/base.lisp:1.28 Fri Jan 28 23:05:42 2005 +++ climacs/base.lisp Sat Jan 29 05:16:25 2005 @@ -298,9 +298,7 @@ (upcase-region offset mark)))) (defun capitalize-buffer-region (buffer offset1 offset2) - (let ((previous-char-constituent-p - (and (plusp offset1) - (constituentp (buffer-object buffer (1- offset1)))))) + (let ((previous-char-constituent-p nil)) (do-buffer-region (object offset buffer offset1 offset2) (when (constituentp object) (if previous-char-constituent-p From abakic at common-lisp.net Sat Jan 29 22:23:13 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sat, 29 Jan 2005 14:23:13 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base-test.lisp Message-ID: <20050129222313.3531A8802D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20755 Modified Files: base-test.lisp Log Message: Test updates. Date: Sat Jan 29 14:23:09 2005 Author: abakic Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.3 climacs/base-test.lisp:1.4 --- climacs/base-test.lisp:1.3 Fri Jan 28 10:47:29 2005 +++ climacs/base-test.lisp Sat Jan 29 14:23:08 2005 @@ -577,10 +577,10 @@ (deftest standard-buffer-delete-word.test-2 (let ((buffer (make-instance 'standard-buffer))) - (insert-buffer-sequence buffer 0 " climacs") + (insert-buffer-sequence buffer 0 " climacs climacs") (let ((m (make-instance 'standard-right-sticky-mark :buffer buffer :offset 0))) - (delete-word m) + (delete-word m 2) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) @@ -599,10 +599,10 @@ (deftest standard-buffer-backward-delete-word.test-2 (let ((buffer (make-instance 'standard-buffer))) - (insert-buffer-sequence buffer 0 "climacs ") + (insert-buffer-sequence buffer 0 "climacs climacs ") (let ((m (make-instance 'standard-right-sticky-mark - :buffer buffer :offset 9))) - (backward-delete-word m) + :buffer buffer :offset 17))) + (backward-delete-word m 2) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) @@ -625,10 +625,10 @@ (deftest standard-buffer-downcase-buffer-region.test-1 (let ((buffer (make-instance 'standard-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::downcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "CLi mac5") + (climacs-base::downcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli mac5") + "Cli mac5") (deftest standard-buffer-downcase-region.test-1 (let ((buffer (make-instance 'standard-buffer))) @@ -661,21 +661,21 @@ (deftest standard-buffer-downcase-word.test-1 (let ((buffer (make-instance 'standard-buffer))) - (insert-buffer-sequence buffer 0 "CLI MA CS") + (insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS") (let ((m (make-instance 'standard-right-sticky-mark :buffer buffer :offset 0))) (downcase-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "cli ma cs" 9) + "cli ma cs CLIMACS" 9) (deftest standard-buffer-upcase-buffer-region.test-1 (let ((buffer (make-instance 'standard-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::upcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "cli mac5") + (climacs-base::upcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "CLI MAC5") + "cLI MAC5") (deftest standard-buffer-upcase-region.test-1 (let ((buffer (make-instance 'standard-buffer))) @@ -708,21 +708,21 @@ (deftest standard-buffer-upcase-word.test-1 (let ((buffer (make-instance 'standard-buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs") + (insert-buffer-sequence buffer 0 "cli ma cs climacs") (let ((m (make-instance 'standard-right-sticky-mark :buffer buffer :offset 0))) (upcase-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "CLI MA CS" 9) + "CLI MA CS climacs" 9) (deftest standard-buffer-capitalize-buffer-region.test-1 (let ((buffer (make-instance 'standard-buffer))) (insert-buffer-sequence buffer 0 "cli ma cs") (climacs-base::capitalize-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli Ma Cs") + "cLi Ma Cs") (deftest standard-buffer-capitalize-buffer-region.test-2 (let ((buffer (make-instance 'standard-buffer))) @@ -762,11 +762,11 @@ (deftest standard-buffer-capitalize-word.test-1 (let ((buffer (make-instance 'standard-buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs") + (insert-buffer-sequence buffer 0 "cli ma cs climacs") (let ((m (make-instance 'standard-right-sticky-mark :buffer buffer :offset 0))) (capitalize-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "Cli Ma Cs" 9) + "Cli Ma Cs climacs" 9) From abakic at common-lisp.net Sat Jan 29 22:23:21 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sat, 29 Jan 2005 14:23:21 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/Persistent/persistent-base-test.lisp Message-ID: <20050129222321.8A1CB8802D@common-lisp.net> Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv20755/Persistent Modified Files: persistent-base-test.lisp Log Message: Test updates. Date: Sat Jan 29 14:23:17 2005 Author: abakic Index: climacs/Persistent/persistent-base-test.lisp diff -u climacs/Persistent/persistent-base-test.lisp:1.3 climacs/Persistent/persistent-base-test.lisp:1.4 --- climacs/Persistent/persistent-base-test.lisp:1.3 Fri Jan 28 10:47:34 2005 +++ climacs/Persistent/persistent-base-test.lisp Sat Jan 29 14:23:14 2005 @@ -622,10 +622,10 @@ (deftest binseq-buffer-downcase-buffer-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::downcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "CLi mac5") + (climacs-base::downcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli mac5") + "Cli mac5") (deftest binseq-buffer-downcase-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) @@ -658,21 +658,21 @@ (deftest binseq-buffer-downcase-word.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "CLI MA CS") + (insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS") (let ((m (make-instance 'persistent-right-sticky-mark :buffer buffer :offset 0))) (downcase-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "cli ma cs" 9) + "cli ma cs CLIMACS" 9) (deftest binseq-buffer-upcase-buffer-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::upcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "cli mac5") + (climacs-base::upcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "CLI MAC5") + "cLI MAC5") (deftest binseq-buffer-upcase-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) @@ -705,21 +705,21 @@ (deftest binseq-buffer-upcase-word.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs") + (insert-buffer-sequence buffer 0 "cli ma cs climacs") (let ((m (make-instance 'persistent-right-sticky-mark :buffer buffer :offset 0))) (upcase-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "CLI MA CS" 9) + "CLI MA CS climacs" 9) (deftest binseq-buffer-capitalize-buffer-region.test-1 (let ((buffer (make-instance 'binseq-buffer))) (insert-buffer-sequence buffer 0 "cli ma cs") (climacs-base::capitalize-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli Ma Cs") + "cLi Ma Cs") (deftest binseq-buffer-capitalize-buffer-region.test-2 (let ((buffer (make-instance 'binseq-buffer))) @@ -759,14 +759,14 @@ (deftest binseq-buffer-capitalize-word.test-1 (let ((buffer (make-instance 'binseq-buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs") + (insert-buffer-sequence buffer 0 "cli ma cs climacs") (let ((m (make-instance 'persistent-right-sticky-mark :buffer buffer :offset 0))) (capitalize-word m 3) (values (buffer-sequence buffer 0 (size buffer)) (offset m)))) - "Cli Ma Cs" 9) + "Cli Ma Cs climacs" 9) ;;; obinseq tests @@ -1370,10 +1370,10 @@ (deftest obinseq-buffer-downcase-buffer-region.test-1 (let ((buffer (make-instance 'obinseq-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::downcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "CLi mac5") + (climacs-base::downcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli mac5") + "Cli mac5") (deftest obinseq-buffer-downcase-region.test-1 (let ((buffer (make-instance 'obinseq-buffer))) @@ -1417,10 +1417,10 @@ (deftest obinseq-buffer-upcase-buffer-region.test-1 (let ((buffer (make-instance 'obinseq-buffer))) - (insert-buffer-sequence buffer 0 "Cli mac5") - (climacs-base::upcase-buffer-region buffer 0 (size buffer)) + (insert-buffer-sequence buffer 0 "cli mac5") + (climacs-base::upcase-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "CLI MAC5") + "cLI MAC5") (deftest obinseq-buffer-upcase-region.test-1 (let ((buffer (make-instance 'obinseq-buffer))) @@ -1467,7 +1467,7 @@ (insert-buffer-sequence buffer 0 "cli ma cs") (climacs-base::capitalize-buffer-region buffer 1 (size buffer)) (buffer-sequence buffer 0 (size buffer))) - "cli Ma Cs") + "cLi Ma Cs") (deftest obinseq-buffer-capitalize-buffer-region.test-2 (let ((buffer (make-instance 'obinseq-buffer))) From mvilleneuve at common-lisp.net Sun Jan 30 19:56:55 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sun, 30 Jan 2005 11:56:55 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050130195655.6833B8864B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23067 Modified Files: base.lisp gui.lisp packages.lisp Log Message: Made query-replace respect the case of replaced strings. Date: Sun Jan 30 11:56:54 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.29 climacs/base.lisp:1.30 --- climacs/base.lisp:1.29 Sat Jan 29 05:16:25 2005 +++ climacs/base.lisp Sun Jan 30 11:56:53 2005 @@ -219,6 +219,29 @@ ;;; ;;; Character case +(defun buffer-region-case (buffer offset1 offset2) + (let ((possibly-uppercase t) + (possibly-lowercase t) + (possibly-capitalized t)) + (do-buffer-region (object offset buffer offset1 offset2) + (unless (characterp object) + (return-from buffer-region-case nil)) + (when (lower-case-p object) + (setf possibly-uppercase nil)) + (when (upper-case-p object) + (setf possibly-lowercase nil)) + (when (plusp offset) + (let ((previous-object (buffer-object buffer (1- offset)))) + (when (and (characterp previous-object) + (if (constituentp previous-object) + (upper-case-p object) + (lower-case-p object))) + (setf possibly-capitalized nil))))) + (cond (possibly-uppercase :upper-case) + (possibly-lowercase :lower-case) + (possibly-capitalized :capitalized) + (t nil)))) + ;;; I'd rather have update-buffer-range methods spec. on buffer for this, ;;; for performance and history-size reasons --amb (defun downcase-buffer-region (buffer offset1 offset2) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.103 climacs/gui.lisp:1.104 --- climacs/gui.lisp:1.103 Fri Jan 28 23:05:42 2005 +++ climacs/gui.lisp Sun Jan 30 11:56:53 2005 @@ -1120,9 +1120,13 @@ ;;; Query replace (defun query-replace-find-next-match (mark string) - (let ((offset-before (offset mark))) - (search-forward mark string) - (/= (offset mark) offset-before))) + (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-named-command com-query-replace () (let* ((string1 (accept 'string :prompt "Query replace")) @@ -1143,11 +1147,21 @@ (define-named-command com-query-replace-replace () (let* ((pane (current-window)) (point (point pane)) + (buffer (buffer pane)) (state (query-replace-state pane)) (string1-length (length (string1 state)))) (backward-object point string1-length) - (delete-range point string1-length) - (insert-sequence point (string2 state)) + (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 state)) + (setf offset2 (+ offset1 (length (string2 state)))) + (finish-output *error-output*) + (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)))) (unless (query-replace-find-next-match point (string1 state)) (setf (query-replace-mode pane) nil)))) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.42 climacs/packages.lisp:1.43 --- climacs/packages.lisp:1.42 Wed Jan 26 14:49:47 2005 +++ climacs/packages.lisp Sun Jan 30 11:56:53 2005 @@ -59,7 +59,10 @@ #:constituentp #:whitespacep #:forward-word #:backward-word #:delete-word #:backward-delete-word - #:upcase-region #:downcase-region #:capitalize-region + #:buffer-region-case + #:upcase-buffer-region #:upcase-region + #:downcase-buffer-region #:downcase-region + #:capitalize-buffer-region #:capitalize-region #:upcase-word #:downcase-word #:capitalize-word #:tabify-region #:untabify-region #:indent-line From mvilleneuve at common-lisp.net Sun Jan 30 22:17:33 2005 From: mvilleneuve at common-lisp.net (Matthieu Villeneuve) Date: Sun, 30 Jan 2005 14:17:33 -0800 (PST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp Message-ID: <20050130221733.2B7638864B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30608 Modified Files: gui.lisp packages.lisp pane.lisp Log Message: Fixed bad isearch behaviour when searching after a failure Date: Sun Jan 30 14:17:31 2005 Author: mvilleneuve Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.104 climacs/gui.lisp:1.105 --- climacs/gui.lisp:1.104 Sun Jan 30 11:56:53 2005 +++ climacs/gui.lisp Sun Jan 30 14:17:30 2005 @@ -1031,7 +1031,8 @@ (list (make-instance 'isearch-state :search-string "" :search-mark (clone-mark point) - :search-forward-p forwardp))) + :search-forward-p forwardp + :search-success-p t))) (simple-command-loop 'isearch-climacs-table (isearch-mode pane) ((setf (isearch-mode pane) nil))))) @@ -1047,18 +1048,19 @@ mark2 string :test #'object-equal))) - (cond (success - (setf (offset point) (offset mark2) - (offset mark) (if forwardp - (- (offset mark2) (length string)) - (+ (offset mark2) (length string)))) - (push (make-instance 'isearch-state - :search-string string - :search-mark mark - :search-forward-p forwardp) - (isearch-states pane))) - (t - (beep)))))) + (when success + (setf (offset point) (offset mark2) + (offset mark) (if forwardp + (- (offset mark2) (length string)) + (+ (offset mark2) (length 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-named-command com-isearch-mode-forward () (isearch-command-loop (current-window) t)) @@ -1084,6 +1086,9 @@ (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) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.43 climacs/packages.lisp:1.44 --- climacs/packages.lisp:1.43 Sun Jan 30 11:56:53 2005 +++ climacs/packages.lisp Sun Jan 30 14:17:31 2005 @@ -111,7 +111,8 @@ #:tab-space-count #:indent-tabs-mode #:auto-fill-mode #:auto-fill-column - #:isearch-state #:search-string #:search-mark #:search-forward-p + #:isearch-state #:search-string #:search-mark + #:search-forward-p #:search-success-p #:isearch-mode #:isearch-states #:isearch-previous-string #:query-replace-state #:string1 #:string2 #:query-replace-mode Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.15 climacs/pane.lisp:1.16 --- climacs/pane.lisp:1.15 Wed Jan 26 14:49:47 2005 +++ climacs/pane.lisp Sun Jan 30 14:17:31 2005 @@ -142,7 +142,8 @@ (defclass isearch-state () ((search-string :initarg :search-string :accessor search-string) (search-mark :initarg :search-mark :accessor search-mark) - (search-forward-p :initarg :search-forward-p :accessor search-forward-p))) + (search-forward-p :initarg :search-forward-p :accessor search-forward-p) + (search-success-p :initarg :search-success-p :accessor search-success-p))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;