January 2005 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
by mvilleneuve＠common-lisp.net 16 Jan '05

16 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/testing/rt.lisp
by abakic＠common-lisp.net 16 Jan '05

16 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/buffer-test.lisp
by abakic＠common-lisp.net 16 Jan '05

16 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/buffer-test.lisp
by rstrandh＠common-lisp.net 16 Jan '05

16 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/buffer-test.lisp
by rstrandh＠common-lisp.net 16 Jan '05

16 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/buffer-test.lisp
by abakic＠common-lisp.net 16 Jan '05

16 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/testing/rt-doc.txt climacs/testing/rt-original.lisp climacs/testing/rt-test.lisp climacs/testing/rt.lisp
by abakic＠common-lisp.net 15 Jan '05

15 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/buffer-test.lisp climacs/climacs.asd
by abakic＠common-lisp.net 15 Jan '05

15 Jan '05

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)

1 0

[climacs-cvs] CVS update: Directory change: climacs/testing
by abakic＠common-lisp.net 15 Jan '05

15 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp
by abakic＠common-lisp.net 15 Jan '05

15 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/text-syntax.lisp
by rstrandh＠common-lisp.net 15 Jan '05

15 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/pane.lisp climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp climacs/text-syntax.lisp
by rstrandh＠common-lisp.net 15 Jan '05

15 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp
by mvilleneuve＠common-lisp.net 15 Jan '05

15 Jan '05

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(a)labri.fr) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve(a)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)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by abakic＠common-lisp.net 14 Jan '05

14 Jan '05

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(a)fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) +;;; (c) copyright 2005 by +;;; Aleksandar Bakic (a_bakic(a)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*))

1 0

[climacs-cvs] CVS update: climacs/text-syntax.lisp climacs/climacs.asd climacs/gui.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 14 Jan '05

14 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by ejohnson＠common-lisp.net 13 Jan '05

13 Jan '05

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)

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp
by mvilleneuve＠common-lisp.net 13 Jan '05

13 Jan '05

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(a)labri.fr) -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson(a)fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve(a)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(a)labri.fr) -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson(a)fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve(a)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(a)labri.fr) -;;; (c) copyright 2004 by +;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson(a)fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve(a)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(a)labri.fr) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
by mvilleneuve＠common-lisp.net 13 Jan '05

13 Jan '05

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 ,@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) `(,@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

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp
by mvilleneuve＠common-lisp.net 13 Jan '05

13 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/abbrev.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 13 Jan '05

13 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 12 Jan '05

12 Jan '05

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) `(,@command-name :name t) `(,command-name :name t)) ,args ,@body)) + `(define-climacs-command ,(if (listp command-name) + `(,@command-name :name t) + `(,command-name :name t)) ,args ,@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+))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 10 Jan '05

10 Jan '05

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)

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 09 Jan '05

09 Jan '05

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

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 09 Jan '05

09 Jan '05

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)

1 0

[climacs-cvs] CVS update: climacs/packages.lisp
by abakic＠common-lisp.net 09 Jan '05

09 Jan '05

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

1 0