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

[climacs-cvs] CVS update: climacs/gui.lisp climacs/html-syntax.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23495 Modified Files: gui.lisp html-syntax.lisp packages.lisp Log Message: Improvements to HTML syntax. This syntax module now uses an incremental lexer, and and incremental parser based on the existing Earley parser in syntax.lisp. Removed backward-to-error and forward-to-error, since I am not sure that these are what we want. Date: Mon Feb 28 09:51:36 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.125 climacs/gui.lisp:1.126 --- climacs/gui.lisp:1.125 Sun Feb 27 19:52:01 2005 +++ climacs/gui.lisp Mon Feb 28 09:51:33 2005 @@ -1282,18 +1282,6 @@ (syntax (syntax (buffer pane)))) (end-of-paragraph point syntax))) -(define-named-command com-backward-to-error () - (let* ((pane (current-window)) - (point (point pane)) - (syntax (syntax (buffer pane)))) - (display-message "~a" (backward-to-error point syntax)))) - -(define-named-command com-forward-to-error () - (let* ((pane (current-window)) - (point (point pane)) - (syntax (syntax (buffer pane)))) - (display-message "~a" (forward-to-error point syntax)))) - (define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?")) (let* ((*package* (find-package :climacs-gui)) (string (handler-case (accept 'string :prompt "Eval") Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.3 climacs/html-syntax.lisp:1.4 --- climacs/html-syntax.lisp:1.3 Sat Feb 5 07:49:53 2005 +++ climacs/html-syntax.lisp Mon Feb 28 09:51:34 2005 @@ -34,183 +34,237 @@ (and (eq (class-of t1) (class-of t2)) (< (badness t1) (badness t2)))) -(defclass html (html-sym) ()) -(defclass head (html-sym) ()) -(defclass title (html-sym) ()) -(defclass body (html-sym) ()) -(defclass h1 (html-sym) ()) -(defclass h2 (html-sym) ()) -(defclass h3 (html-sym) ()) -(defclass para (html-sym) ()) -(defclass ul (html-sym) ()) -(defclass li (html-sym) ()) -(defclass texts (html-sym) ()) - -(defclass error-token (html-sym) ()) -(defclass text (html-sym) ()) - -(defclass <html> (html-sym) ()) -(defclass </html> (html-sym) ()) -(defclass <head> (html-sym) ()) -(defclass </head> (html-sym) ()) -(defclass <title> (html-sym) ()) -(defclass </title> (html-sym) ()) -(defclass <body> (html-sym) ()) -(defclass </body> (html-sym) ()) -(defclass <h1> (html-sym) ()) -(defclass </h1> (html-sym) ()) -(defclass <h2> (html-sym) ()) -(defclass </h2> (html-sym) ()) -(defclass <h3> (html-sym) ()) -(defclass </h3> (html-sym) ()) -(defclass <p> (html-sym) ()) -(defclass </p> (html-sym) ()) -(defclass <ul> (html-sym) ()) -(defclass </ul> (html-sym) ()) -(defclass <li> (html-sym) ()) -(defclass </li> (html-sym) ()) +(defclass words (html-sym) ()) + +(defclass empty-words (words) ()) + +(defclass nonempty-words (words) + ((words :initarg :words) + (word :initarg :word))) + +(defclass html-balanced (html-sym) + ((start :initarg :start) + (end :initarg :end))) + +(defclass html (html-balanced) + ((head :initarg :head) + (body :initarg :body))) + +(defclass head (html-balanced) + ((title :initarg :title))) + +(defclass html-words (html-balanced) + ((words :initarg :words))) + +(defclass title (html-words) ()) +(defclass body (html-words) ()) +(defclass h1 (html-words) ()) +(defclass h2 (html-words) ()) +(defclass h3 (html-words) ()) +(defclass para (html-words) ()) + +(defclass html-token (html-sym) + ((start-mark :initarg :start-mark :reader start-mark) + (size :initarg :size))) + +(defgeneric end-offset (html-token)) + +(defmethod end-offset ((token html-token)) + (with-slots (start-mark size) token + (+ (offset start-mark) size))) + +(defgeneric start-offset (html-token)) + +(defmethod start-offset ((token html-token)) + (offset (start-mark token))) + +(defclass <html> (html-token) () (:default-initargs :size 6)) +(defclass </html> (html-token) ()(:default-initargs :size 7)) +(defclass <head> (html-token) () (:default-initargs :size 6)) +(defclass </head> (html-token) () (:default-initargs :size 7)) +(defclass <title> (html-token) () (:default-initargs :size 7)) +(defclass </title> (html-token) () (:default-initargs :size 8)) +(defclass <body> (html-token) () (:default-initargs :size 6)) +(defclass </body> (html-token) () (:default-initargs :size 7)) +(defclass <h1> (html-token) () (:default-initargs :size 4)) +(defclass </h1> (html-token) () (:default-initargs :size 5)) +(defclass <h2> (html-token) () (:default-initargs :size 4)) +(defclass </h2> (html-token) () (:default-initargs :size 5)) +(defclass <h3> (html-token) () (:default-initargs :size 4)) +(defclass </h3> (html-token) () (:default-initargs :size 5)) +(defclass <p> (html-token) () (:default-initargs :size 3)) +(defclass </p> (html-token) () (:default-initargs :size 4)) +(defclass <ul> (html-token) () (:default-initargs :size 4)) +(defclass </ul> (html-token) () (:default-initargs :size 5)) +(defclass <li> (html-token) () (:default-initargs :size 4)) +(defclass </li> (html-token) () (:default-initargs :size 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lexer -(defparameter *token-table* - '(("<html>" . <html>) - ("</html>" . </html>) - ("<head>" . <head>) - ("</head>" . </head>) - ("<title>" . <title>) - ("</title>" . </title>) - ("<body>" . <body>) - ("</body>" . </body>) - ("<h1>" . <h1>) - ("</h1>" . </h1>) - ("<h2>" . <h2>) - ("</h2>" . </h2>) - ("<h3>" . <h3>) - ("</h3>" . </h3>) - ("<p>" . <p>) - ("</p>" . </p>) - ("<ul>" . <ul>) - ("</ul>" . </ul>) - ("<li>" . <li>) - ("</li>" . </li>))) - -(defclass html-lexer (lexer) - ((mark :initarg :mark))) - -(defmethod lex ((lexer html-lexer)) - (with-slots (mark) lexer - (assert (not (end-of-buffer-p mark))) - (cond ((or (end-of-line-p mark) - (not (eql (object-after mark) #\<))) - (when (end-of-line-p mark) - (forward-object mark)) - (loop until (or (end-of-line-p mark) - (eql (object-after mark) #\<)) - do (forward-object mark)) - (make-instance 'text)) - (t - (let ((offset (offset mark))) - (forward-object mark) - (loop until (or (end-of-line-p mark) - (whitespacep (object-after mark)) - (eql (object-before mark) #\>)) - do (forward-object mark)) - (let* ((word (region-to-sequence offset mark)) - (class-name (cdr (assoc word *token-table* :test #'equalp)))) - (make-instance (or class-name 'error-token)))))))) +(defclass html-element (html-token) + ((state :initarg :state))) + +(defclass start-element (html-element) ()) +(defclass tag-start (html-element) ()) +(defclass tag-end (html-element) ()) +(defclass slash (html-element) ()) +(defclass word (html-element) ()) +(defclass delimiter (html-element) ()) + +(defun next-token (scan) + (let ((start-mark (clone-mark scan))) + (flet ((fo () (forward-object scan))) + (macrolet ((make-entry (type) + `(return-from next-token + (make-instance ,type :start-mark start-mark + :size (- (offset scan) (offset start-mark)))))) + (loop with object = (object-after scan) + until (end-of-buffer-p scan) + do (case object + (#\< (fo) (make-entry 'tag-start)) + (#\> (fo) (make-entry 'tag-end)) + (#\/ (fo) (make-entry 'slash)) + (t (cond ((alphanumericp object) + (loop until (end-of-buffer-p scan) + while (alphanumericp (object-after scan)) + do (fo)) + (make-entry 'word)) + (t + (fo) (make-entry 'delimiter)))))))))) + +(define-syntax html-syntax ("HTML" (basic-syntax)) + ((tokens :initform (make-instance 'standard-flexichain)) + (guess-pos :initform 1) + (valid-parse :initform 1) + (parser))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; parser +(defun word-is (word string) + (string-equal (coerce (region-to-sequence (start-mark word) (end-offset word)) 'string) + string)) + (defparameter *html-grammar* (grammar - (html -> (<html> head body </html>)) - (head -> (<head> title </head>)) - (title -> (<title> texts </title>)) - (body -> (<body> texts </body>)) - (texts -> ()) - (texts -> (texts text)))) - -(define-syntax html-syntax ("HTML" (basic-syntax)) - ((parser) - (states))) + (<html> -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "html"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) + (</html> -> (tag-start + (slash (= (end-offset tag-start) (start-offset slash))) + (word (and (= (end-offset slash) (start-offset word)) + (word-is word "html"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) + (<head> -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "head"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) + (</head> -> (tag-start + (slash (= (end-offset tag-start) (start-offset slash))) + (word (and (= (end-offset slash) (start-offset word)) + (word-is word "head"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) + (<title> -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "title"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) + (</title> -> (tag-start + (slash (= (end-offset tag-start) (start-offset slash))) + (word (and (= (end-offset slash) (start-offset word)) + (word-is word "title"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) + (<body> -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word "body"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) + (</body> -> (tag-start + (slash (= (end-offset tag-start) (start-offset slash))) + (word (and (= (end-offset slash) (start-offset word)) + (word-is word "body"))) + (tag-end (= (end-offset word) (start-offset tag-end)))) + :start-mark (start-mark tag-start)) + (html -> (<html> head body </html>) + :start <html> :head head :body body :end </html>) + (head -> (<head> title </head>) + :start <head> :title title :end </head>) + (title -> (<title> words </title>) + :start <title> :words words :end </title>) + (body -> (<body> words </body>) + :start <body> :words words :end </body>) + (words -> () + (make-instance 'empty-words)) + (words -> (words word) + (make-instance 'nonempty-words :words words :word word)))) (defmethod initialize-instance :after ((syntax html-syntax) &rest args) (declare (ignore args)) - (with-slots (parser states buffer) syntax + (with-slots (parser tokens buffer) syntax (setf parser (make-instance 'parser :grammar *html-grammar* - :lexer (make-instance 'html-lexer - :mark (make-instance 'standard-left-sticky-mark :buffer buffer)) :target 'html)) - (setf states (list (cons (make-instance 'standard-left-sticky-mark :buffer buffer) - (initial-state parser)))))) + (insert* tokens 0 (make-instance 'start-element + :start-mark (make-instance 'standard-left-sticky-mark + :buffer buffer + :offset 0) + :size 0 + :state (initial-state parser))))) + +(defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot) + (with-slots (parser tokens valid-parse) syntax + (loop until (= valid-parse (nb-elements tokens)) + while (mark< (end-offset (element* tokens valid-parse)) bot) + do (let ((current-token (element* tokens (1- valid-parse))) + (next-token (element* tokens valid-parse))) + (setf (slot-value next-token 'state) + (advance-parse parser (list next-token) (slot-value current-token 'state)))) + (incf valid-parse)))) (defmethod update-syntax (buffer (syntax html-syntax)) - (let ((low-mark (low-mark buffer))) - (with-slots (parser states) syntax - (with-slots (lexer) parser - (with-slots (mark) lexer - (loop until (or (null (cdr states)) - (< (offset (caar states)) (offset low-mark))) - do (pop states)) - (setf (offset mark) (offset (caar states))) - (loop until (end-of-buffer-p mark) - do (let ((token (lex lexer))) - (push (cons (clone-mark mark) - (advance-parse parser (list token) (cdar states))) - states))))) - (print (find 'html (gethash (initial-state parser) (parse-trees (cdar states))) - :key #'type-of) - *query-io*) - (finish-output *query-io*)))) - -(defgeneric forward-to-error (point syntax)) -(defgeneric backward-to-error (point syntax)) - -(defun find-bad-parse-tree (state) - (maphash (lambda (key parse-trees) - (declare (ignore key)) - (let ((parse-tree (find-if (lambda (parse-tree) - (plusp (badness parse-tree))) - parse-trees))) - (when parse-tree - (return-from find-bad-parse-tree parse-tree)))) - (parse-trees state))) - -(defgeneric empty-state-p (state)) - -(defmethod empty-state-p (state) - (maphash (lambda (key val) - (declare (ignore key)) - (loop for parse-tree in val - do (return-from empty-state-p nil))) - (parse-trees state)) - (maphash (lambda (key val) - (declare (ignore key)) - (loop for parse-tree in val - do (return-from empty-state-p nil))) - (incomplete-items state))) - -(defmethod backward-to-error (point (syntax html-syntax)) - (let ((states (slot-value syntax 'states))) - ;; find the last state before point - (loop until (or (null states) - (mark< (caar states) point)) - do (pop states)) - (when (null states) - (return-from backward-to-error "no more errors")) - (when (empty-state-p (cdar states)) - (loop for ((m1 . s1) (m2 . s2)) on states - until (not (empty-state-p s2)) - finally (setf (offset point) (offset m1))) - (return-from backward-to-error "no valid parse from this point")) - (loop for (mark . state) in states - for tree = (find-bad-parse-tree state) - when tree - do (setf (offset point) (offset mark)) - (return (message tree)) - finally (return "no more errors")))) + (let ((low-mark (low-mark buffer)) + (high-mark (high-mark buffer)) + (scan)) + (with-slots (tokens guess-pos valid-parse) syntax + (when (mark<= low-mark high-mark) + ;; go back to a position before low-mark + (loop until (or (= guess-pos 1) + (mark< (end-offset (element* tokens (1- guess-pos))) low-mark)) + do (decf guess-pos)) + ;; go forward to the last position before low-mark + (loop with nb-elements = (nb-elements tokens) + until (or (= guess-pos nb-elements) + (mark>= (end-offset (element* tokens guess-pos)) low-mark)) + do (incf guess-pos)) + ;; mark valid parse + (setf valid-parse guess-pos) + ;; delete entries that must be reparsed + (loop until (or (= guess-pos (nb-elements tokens)) + (mark> (start-mark (element* tokens guess-pos)) high-mark)) + do (delete* tokens guess-pos)) + (setf scan (make-instance 'standard-left-sticky-mark + :buffer buffer + :offset (if (zerop guess-pos) + 0 + (end-offset (element* tokens (1- guess-pos)))))) + ;; scan + (loop with start-mark = nil + do (loop until (end-of-buffer-p scan) + while (whitespacep (object-after scan)) + do (forward-object scan)) + until (if (end-of-buffer-p high-mark) + (end-of-buffer-p scan) + (mark> scan high-mark)) + do (setf start-mark (clone-mark scan)) + (insert* tokens guess-pos (next-token scan)) + (incf guess-pos)))))) + Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.51 climacs/packages.lisp:1.52 --- climacs/packages.lisp:1.51 Sun Feb 27 19:52:01 2005 +++ climacs/packages.lisp Mon Feb 28 09:51:35 2005 @@ -91,8 +91,7 @@ #:basic-syntax #:update-syntax #:update-syntax-for-display #:syntax-line-indentation - #:beginning-of-paragraph #:end-of-paragraph - #:forward-to-error #:backward-to-error)) + #:beginning-of-paragraph #:end-of-paragraph)) (defpackage :climacs-cl-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-syntax)

1 0

[climacs-cvs] CVS update: climacs/delegating-buffer.lisp
by abakic＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17788 Modified Files: delegating-buffer.lisp Log Message: Fixed description... Date: Sun Feb 27 22:21:51 2005 Author: abakic Index: climacs/delegating-buffer.lisp diff -u climacs/delegating-buffer.lisp:1.3 climacs/delegating-buffer.lisp:1.4 --- climacs/delegating-buffer.lisp:1.3 Sun Feb 27 20:16:14 2005 +++ climacs/delegating-buffer.lisp Sun Feb 27 22:21:51 2005 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; Buffer class that allow specifying buffer implementation at run time. +;;; Buffer class that allows for specifying buffer implementation at run time. (in-package :climacs-buffer)

1 0

[climacs-cvs] CVS update: climacs/delegating-buffer.lisp
by abakic＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11262 Modified Files: delegating-buffer.lisp Log Message: Added description. Date: Sun Feb 27 20:16:16 2005 Author: abakic Index: climacs/delegating-buffer.lisp diff -u climacs/delegating-buffer.lisp:1.2 climacs/delegating-buffer.lisp:1.3 --- climacs/delegating-buffer.lisp:1.2 Sun Feb 27 20:15:27 2005 +++ climacs/delegating-buffer.lisp Sun Feb 27 20:16:14 2005 @@ -18,7 +18,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; GUI for the Climacs editor. +;;; Buffer class that allow specifying buffer implementation at run time. (in-package :climacs-buffer)

1 0

[climacs-cvs] CVS update: climacs/delegating-buffer.lisp
by abakic＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10897 Modified Files: delegating-buffer.lisp Log Message: Added license. Date: Sun Feb 27 20:15:28 2005 Author: abakic Index: climacs/delegating-buffer.lisp diff -u climacs/delegating-buffer.lisp:1.1 climacs/delegating-buffer.lisp:1.2 --- climacs/delegating-buffer.lisp:1.1 Sun Feb 27 20:02:15 2005 +++ climacs/delegating-buffer.lisp Sun Feb 27 20:15:27 2005 @@ -3,6 +3,23 @@ ;;; (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 +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. + +;;; GUI for the Climacs editor. + (in-package :climacs-buffer) (defclass delegating-buffer (buffer)

1 0

[climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
by abakic＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv10718 Modified Files: climacs-internals.texi Log Message: Added descriptions of buffer-line-number and buffer-column-number. Date: Sun Feb 27 20:13:48 2005 Author: abakic Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.13 climacs/Doc/climacs-internals.texi:1.14 --- climacs/Doc/climacs-internals.texi:1.13 Sat Feb 26 06:33:37 2005 +++ climacs/Doc/climacs-internals.texi Sun Feb 27 20:13:47 2005 @@ -305,12 +305,24 @@ end of the buffer), nil otherwise. @end deffn +@deffn {Generic Function} {buffer-line-number} buffer offset + +Return the line number of the line at offset. Lines are numbered from +zero. +@end deffn + +@deffn {Generic Function} {buffer-column-number} buffer offset + +Return the column number of the line at offset. It is the number of +objects between it and the preceding newline, or between it and the +beginning of the buffer if offset is on the first line of the buffer. +@end deffn + @deffn {Generic Function} {line-number} mark Return the line number of the mark. Lines are numbered from zero. @end deffn - @deffn {Generic Function} {column-number} mark Return the column number of the mark. The column number of a mark is @@ -318,7 +330,6 @@ between it and the beginning of the buffer if the mark is on the first line of the buffer. @end deffn - @section Inserting and deleting objects

1 0

[climacs-cvs] CVS update: climacs/delegating-buffer.lisp
by abakic＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10609 Added Files: delegating-buffer.lisp Log Message: Delegating-buffer class implementation. Date: Sun Feb 27 20:02:15 2005 Author: abakic

1 0

[climacs-cvs] CVS update: climacs/base-test.lisp climacs/buffer-test.lisp climacs/climacs.asd climacs/gui.lisp climacs/kill-ring.lisp climacs/packages.lisp climacs/pane.lisp
by abakic＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9768 Modified Files: base-test.lisp buffer-test.lisp climacs.asd gui.lisp kill-ring.lisp packages.lisp pane.lisp Log Message: package.lisp, pane.lisp: Added delegation-buffer class, allowing for dynamic buffer implementation choices. Modified climacs-buffer accordingly and added two extended buffer implementation classes and a few methods delegating undo and syntax functionality. Removed hard-coded uses of standard-buffer and standard mark classes. Modified :buffer arguments to syntax creation to make sure they are buffer implementations. gui.lisp: Removed obsolete region-limits. Modified :buffer arguments to syntax creation to make sure they are buffer implementations. Removed hard-coded uses of standard-buffer and standard mark classes. kill-ring.lisp: Fixed parameter order in (setf kill-ring-max-size). buffer-test.lisp, base-test.lisp: Added tests for delegating-standard-buffer. Replaced all but two mark instantiations with calls to clone-mark. Date: Sun Feb 27 19:52:01 2005 Author: abakic Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.11 climacs/base-test.lisp:1.12 --- climacs/base-test.lisp:1.11 Fri Feb 25 21:45:07 2005 +++ climacs/base-test.lisp Sun Feb 27 19:52:00 2005 @@ -10,8 +10,8 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 16))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 16) (previous-line mark nil 2) (offset mark))) 0) @@ -21,8 +21,8 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 19))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 19) (previous-line mark 2 2) (offset mark))) 2) @@ -31,8 +31,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 7))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 7) (previous-line mark) (offset mark))) 7) @@ -41,8 +41,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 7))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 7) (previous-line mark 2) (offset mark))) 2) @@ -51,8 +51,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 0) (previous-line mark) (offset mark))) 0) @@ -61,8 +61,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 0) (previous-line mark 2) (offset mark))) 2) @@ -71,8 +71,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs2") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 15))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 15) (previous-line mark) (offset mark))) 7) @@ -82,8 +82,8 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 6))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 6) (next-line mark nil 2) (offset mark))) 22) @@ -93,8 +93,8 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 3) (next-line mark 2 2) (offset mark))) 18) @@ -103,8 +103,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 8))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 8) (next-line mark) (offset mark))) 8) @@ -113,8 +113,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 8))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 8) (next-line mark 2) (offset mark))) 10) @@ -123,8 +123,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 15))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 15) (next-line mark) (offset mark))) 15) @@ -133,8 +133,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 15))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 15) (next-line mark 2) (offset mark))) 10) @@ -143,8 +143,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 0) (next-line mark) (offset mark))) 8) @@ -152,8 +152,8 @@ (defmultitest open-line.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 0) (open-line mark 2) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) " @@ -163,8 +163,8 @@ (defmultitest open-line.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 0) (open-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) " @@ -173,8 +173,8 @@ (defmultitest open-line.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 7))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 7) (open-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacs @@ -183,8 +183,8 @@ (defmultitest open-line.test-4 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 7))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 7) (open-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacs @@ -193,8 +193,8 @@ (defmultitest kill-line.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 0) (kill-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) #() 0) @@ -202,8 +202,8 @@ (defmultitest kill-line.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 0) (kill-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) #() 0) @@ -211,8 +211,8 @@ (defmultitest kill-line.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 7))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 7) (kill-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacs" 7) @@ -220,8 +220,8 @@ (defmultitest kill-line.test-4 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 7))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 7) (kill-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacs" 7) @@ -230,8 +230,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%left-sticky-mark - :buffer buffer :offset 7))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 7) (kill-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacsclimacs" 7) @@ -240,34 +240,32 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((mark (make-instance %%right-sticky-mark - :buffer buffer :offset 7))) + (let ((mark (clone-mark (low-mark buffer) :right))) + (setf (offset mark) 7) (kill-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacsclimacs" 7) (defmultitest empty-line-p.test-1 (let* ((buffer (make-instance %%buffer)) - (m1 (make-instance %%left-sticky-mark :buffer buffer)) - (m2 (make-instance %%right-sticky-mark :buffer buffer))) + (m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) (values (empty-line-p m1) (empty-line-p m2))) t t) (defmultitest empty-line-p.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-object buffer 0 #\a) - (let ((m1 (make-instance %%left-sticky-mark :buffer buffer)) - (m2 (make-instance %%right-sticky-mark :buffer buffer))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) (values (empty-line-p m1) (empty-line-p m2)))) nil nil) (defmultitest empty-line-p.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-object buffer 0 #\a) - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 1)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 1))) + (let ((m1 (clone-mark (high-mark buffer) :left)) + (m2 (clone-mark (high-mark buffer) :right))) (values (empty-line-p m1) (empty-line-p m2)))) nil nil) @@ -275,24 +273,24 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "a b") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 1)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 1))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 1 + (offset m2) 1) (values (empty-line-p m1) (empty-line-p m2)))) nil nil) (defmultitest line-indentation.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 0)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 0)) - (m3 (make-instance %%left-sticky-mark - :buffer buffer :offset 10)) - (m4 (make-instance %%right-sticky-mark - :buffer buffer :offset 10))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right)) + (m3 (clone-mark (low-mark buffer) :left)) + (m4 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 0 + (offset m2) 0 + (offset m3) 10 + (offset m4) 10) (values (line-indentation m1 8) (line-indentation m2 8) @@ -307,14 +305,14 @@ (defmultitest line-indentation.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 0)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 0)) - (m3 (make-instance %%left-sticky-mark - :buffer buffer :offset 11)) - (m4 (make-instance %%right-sticky-mark - :buffer buffer :offset 11))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right)) + (m3 (clone-mark (low-mark buffer) :left)) + (m4 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 0 + (offset m2) 0 + (offset m3) 11 + (offset m4) 11) (values (line-indentation m1 8) (line-indentation m2 8) @@ -329,14 +327,14 @@ (defmultitest line-indentation.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 0)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 0)) - (m3 (make-instance %%left-sticky-mark - :buffer buffer :offset 11)) - (m4 (make-instance %%right-sticky-mark - :buffer buffer :offset 11))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right)) + (m3 (clone-mark (low-mark buffer) :left)) + (m4 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 0 + (offset m2) 0 + (offset m3) 11 + (offset m4) 11) (values (line-indentation m1 8) (line-indentation m2 8) @@ -380,30 +378,30 @@ climacs climacs ") - (let ((m1l (make-instance %%left-sticky-mark - :buffer buffer :offset 0)) - (m1r (make-instance %%right-sticky-mark - :buffer buffer :offset 0)) - (m2l (make-instance %%left-sticky-mark - :buffer buffer :offset 1)) - (m2r (make-instance %%left-sticky-mark - :buffer buffer :offset 1)) - (m3l (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m3r (make-instance %%right-sticky-mark - :buffer buffer :offset 3)) - (m4l (make-instance %%left-sticky-mark - :buffer buffer :offset 8)) - (m4r (make-instance %%right-sticky-mark - :buffer buffer :offset 8)) - (m5l (make-instance %%left-sticky-mark - :buffer buffer :offset 15)) - (m5r (make-instance %%right-sticky-mark - :buffer buffer :offset 15)) - (m6l (make-instance %%left-sticky-mark - :buffer buffer :offset 16)) - (m6r (make-instance %%right-sticky-mark - :buffer buffer :offset 16))) + (let ((m1l (clone-mark (low-mark buffer) :left)) + (m1r (clone-mark (low-mark buffer) :right)) + (m2l (clone-mark (low-mark buffer) :left)) + (m2r (clone-mark (low-mark buffer) :right)) + (m3l (clone-mark (low-mark buffer) :left)) + (m3r (clone-mark (low-mark buffer) :right)) + (m4l (clone-mark (low-mark buffer) :left)) + (m4r (clone-mark (low-mark buffer) :right)) + (m5l (clone-mark (low-mark buffer) :left)) + (m5r (clone-mark (low-mark buffer) :right)) + (m6l (clone-mark (low-mark buffer) :left)) + (m6r (clone-mark (low-mark buffer) :right))) + (setf (offset m1l) 0 + (offset m1r) 0 + (offset m2l) 1 + (offset m2r) 1 + (offset m3l) 3 + (offset m3r) 3 + (offset m4l) 8 + (offset m4r) 8 + (offset m5l) 15 + (offset m5r) 15 + (offset m6l) 16 + (offset m6r) 16) (values (number-of-lines-in-region m1l m1r) (number-of-lines-in-region m1r m1l) @@ -429,14 +427,14 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((m1l (make-instance %%left-sticky-mark - :buffer buffer :offset 6)) - (m1r (make-instance %%right-sticky-mark - :buffer buffer :offset 6)) - (m2l (make-instance %%left-sticky-mark - :buffer buffer :offset 7)) - (m2r (make-instance %%right-sticky-mark - :buffer buffer :offset 7))) + (let ((m1l (clone-mark (low-mark buffer) :left)) + (m1r (clone-mark (low-mark buffer) :right)) + (m2l (clone-mark (low-mark buffer) :left)) + (m2r (clone-mark (low-mark buffer) :right))) + (setf (offset m1l) 6 + (offset m1r) 6 + (offset m2l) 7 + (offset m2r) 7) (values (number-of-lines-in-region m1l 10) (number-of-lines-in-region 10 m1l) @@ -473,18 +471,18 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs climacs") - (let ((m0l (make-instance %%left-sticky-mark - :buffer buffer :offset 0)) - (m0r (make-instance %%right-sticky-mark - :buffer buffer :offset 0)) - (m1l (make-instance %%left-sticky-mark - :buffer buffer :offset 5)) - (m1r (make-instance %%right-sticky-mark - :buffer buffer :offset 5)) - (m2l (make-instance %%left-sticky-mark - :buffer buffer :offset 17)) - (m2r (make-instance %%right-sticky-mark - :buffer buffer :offset 17))) + (let ((m0l (clone-mark (low-mark buffer) :left)) + (m0r (clone-mark (low-mark buffer) :right)) + (m1l (clone-mark (low-mark buffer) :left)) + (m1r (clone-mark (low-mark buffer) :right)) + (m2l (clone-mark (low-mark buffer) :left)) + (m2r (clone-mark (low-mark buffer) :right))) + (setf (offset m0l) 0 + (offset m0r) 0 + (offset m1l) 5 + (offset m1r) 5 + (offset m2l) 17 + (offset m2r) 17) (values (progn (climacs-base::forward-to-word-boundary m0l) (offset m0l)) (progn (climacs-base::forward-to-word-boundary m0r) (offset m0r)) @@ -498,18 +496,18 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs ") - (let ((m0l (make-instance %%left-sticky-mark - :buffer buffer :offset 17)) - (m0r (make-instance %%right-sticky-mark - :buffer buffer :offset 17)) - (m1l (make-instance %%left-sticky-mark - :buffer buffer :offset 10)) - (m1r (make-instance %%right-sticky-mark - :buffer buffer :offset 10)) - (m2l (make-instance %%left-sticky-mark - :buffer buffer :offset 0)) - (m2r (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((m0l (clone-mark (low-mark buffer) :left)) + (m0r (clone-mark (low-mark buffer) :right)) + (m1l (clone-mark (low-mark buffer) :left)) + (m1r (clone-mark (low-mark buffer) :right)) + (m2l (clone-mark (low-mark buffer) :left)) + (m2r (clone-mark (low-mark buffer) :right))) + (setf (offset m0l) 17 + (offset m0r) 17 + (offset m1l) 10 + (offset m1r) 10 + (offset m2l) 0 + (offset m2r) 0) (values (progn (climacs-base::backward-to-word-boundary m0l) (offset m0l)) (progn (climacs-base::backward-to-word-boundary m0r) (offset m0r)) @@ -523,18 +521,18 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs climacs") - (let ((m0l (make-instance %%left-sticky-mark - :buffer buffer :offset 0)) - (m0r (make-instance %%right-sticky-mark - :buffer buffer :offset 0)) - (m1l (make-instance %%left-sticky-mark - :buffer buffer :offset 5)) - (m1r (make-instance %%right-sticky-mark - :buffer buffer :offset 15)) - (m2l (make-instance %%left-sticky-mark - :buffer buffer :offset 17)) - (m2r (make-instance %%right-sticky-mark - :buffer buffer :offset 17))) + (let ((m0l (clone-mark (low-mark buffer) :left)) + (m0r (clone-mark (low-mark buffer) :right)) + (m1l (clone-mark (low-mark buffer) :left)) + (m1r (clone-mark (low-mark buffer) :right)) + (m2l (clone-mark (low-mark buffer) :left)) + (m2r (clone-mark (low-mark buffer) :right))) + (setf (offset m0l) 0 + (offset m0r) 0 + (offset m1l) 5 + (offset m1r) 15 + (offset m2l) 17 + (offset m2r) 17) (values (progn (forward-word m0l) (offset m0l)) (progn (forward-word m0r) (offset m0r)) @@ -548,18 +546,18 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs ") - (let ((m0l (make-instance %%left-sticky-mark - :buffer buffer :offset 17)) - (m0r (make-instance %%right-sticky-mark - :buffer buffer :offset 17)) - (m1l (make-instance %%left-sticky-mark - :buffer buffer :offset 10)) - (m1r (make-instance %%right-sticky-mark - :buffer buffer :offset 5)) - (m2l (make-instance %%left-sticky-mark - :buffer buffer :offset 0)) - (m2r (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((m0l (clone-mark (low-mark buffer) :left)) + (m0r (clone-mark (low-mark buffer) :right)) + (m1l (clone-mark (low-mark buffer) :left)) + (m1r (clone-mark (low-mark buffer) :right)) + (m2l (clone-mark (low-mark buffer) :left)) + (m2r (clone-mark (low-mark buffer) :right))) + (setf (offset m0l) 17 + (offset m0r) 17 + (offset m1l) 10 + (offset m1r) 5 + (offset m2l) 0 + (offset m2r) 0) (values (progn (backward-word m0l) (offset m0l)) (progn (backward-word m0r) (offset m0r)) @@ -572,8 +570,8 @@ (defmultitest delete-word.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3) (delete-word m) (values (buffer-sequence buffer 0 (size buffer)) @@ -583,8 +581,8 @@ (defmultitest delete-word.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) (delete-word m 2) (values (buffer-sequence buffer 0 (size buffer)) @@ -594,8 +592,8 @@ (defmultitest backward-delete-word.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3) (backward-delete-word m) (values (buffer-sequence buffer 0 (size buffer)) @@ -605,8 +603,8 @@ (defmultitest backward-delete-word.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs ") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 17))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 17) (backward-delete-word m 2) (values (buffer-sequence buffer 0 (size buffer)) @@ -616,12 +614,12 @@ (defmultitest previous-word.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((m0 (make-instance %%right-sticky-mark - :buffer buffer :offset 7)) - (m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 8)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 10))) + (let ((m0 (clone-mark (low-mark buffer) :right)) + (m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m0) 7 + (offset m1) 8 + (offset m2) 10) (values (climacs-base::previous-word m0) (climacs-base::previous-word m1) @@ -638,10 +636,10 @@ (defmultitest downcase-region.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 1)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 8))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 1 + (offset m2) 8) (downcase-region m2 m1) (buffer-sequence buffer 0 (size buffer)))) "_cli mac5_") @@ -649,8 +647,8 @@ (defmultitest downcase-region.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%right-sticky-mark - :buffer buffer :offset 1))) + (let ((m1 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 1) (downcase-region 8 m1) (buffer-sequence buffer 0 (size buffer)))) "_cli mac5_") @@ -658,8 +656,8 @@ (defmultitest downcase-region.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 8))) + (let ((m1 (clone-mark (low-mark buffer) :left))) + (setf (offset m1) 8) (downcase-region 1 m1) (buffer-sequence buffer 0 (size buffer)))) "_cli mac5_") @@ -667,8 +665,8 @@ (defmultitest downcase-word.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) (downcase-word m 3) (values (buffer-sequence buffer 0 (size buffer)) @@ -685,10 +683,10 @@ (defmultitest upcase-region.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 1)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 8))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 1 + (offset m2) 8) (upcase-region m2 m1) (buffer-sequence buffer 0 (size buffer)))) "_CLI MAC5_") @@ -696,8 +694,8 @@ (defmultitest upcase-region.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%right-sticky-mark - :buffer buffer :offset 1))) + (let ((m1 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 1) (upcase-region 8 m1) (buffer-sequence buffer 0 (size buffer)))) "_CLI MAC5_") @@ -705,8 +703,8 @@ (defmultitest upcase-region.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 8))) + (let ((m1 (clone-mark (low-mark buffer) :left))) + (setf (offset m1) 8) (upcase-region 1 m1) (buffer-sequence buffer 0 (size buffer)))) "_CLI MAC5_") @@ -714,8 +712,8 @@ (defmultitest upcase-word.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "cli ma cs climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) (upcase-word m 3) (values (buffer-sequence buffer 0 (size buffer)) @@ -739,10 +737,10 @@ (defmultitest capitalize-region.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 1)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 8))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 1 + (offset m2) 8) (capitalize-region m2 m1) (buffer-sequence buffer 0 (size buffer)))) "_Cli Mac5_") @@ -750,8 +748,8 @@ (defmultitest capitalize-region.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%right-sticky-mark - :buffer buffer :offset 1))) + (let ((m1 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 1) (capitalize-region 8 m1) (buffer-sequence buffer 0 (size buffer)))) "_Cli Mac5_") @@ -759,8 +757,8 @@ (defmultitest capitalize-region.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "_Cli mac5_") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 8))) + (let ((m1 (clone-mark (low-mark buffer) :left))) + (setf (offset m1) 8) (capitalize-region 1 m1) (buffer-sequence buffer 0 (size buffer)))) "_Cli Mac5_") @@ -768,8 +766,8 @@ (defmultitest capitalize-word.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "cli ma cs climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 0))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) (capitalize-word m 3) (values (buffer-sequence buffer 0 (size buffer)) @@ -793,10 +791,10 @@ (defmultitest tabify-region.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 7))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 3 + (offset m2) 7) (tabify-region m2 m1 4) (buffer-sequence buffer 0 (size buffer)))) "clim acs") @@ -804,8 +802,8 @@ (defmultitest tabify-region.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") - (let ((m1 (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((m1 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 3) (tabify-region 7 m1 4) (buffer-sequence buffer 0 (size buffer)))) "clim acs") @@ -813,8 +811,8 @@ (defmultitest tabify-region.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 7))) + (let ((m1 (clone-mark (low-mark buffer) :left))) + (setf (offset m1) 7) (tabify-region 3 m1 4) (buffer-sequence buffer 0 (size buffer)))) "clim acs") @@ -836,10 +834,10 @@ (defmultitest untabify-region.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 5))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 3 + (offset m2) 5) (untabify-region m2 m1 4) (buffer-sequence buffer 0 (size buffer)))) "clim acs") @@ -847,8 +845,8 @@ (defmultitest untabify-region.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") - (let ((m1 (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((m1 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 3) (untabify-region 5 m1 4) (buffer-sequence buffer 0 (size buffer)))) "clim acs") @@ -856,8 +854,8 @@ (defmultitest untabify-region.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "clim acs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 5))) + (let ((m1 (clone-mark (low-mark buffer) :left))) + (setf (offset m1) 5) (untabify-region 3 m1 4) (buffer-sequence buffer 0 (size buffer)))) "clim acs") @@ -865,8 +863,8 @@ (defmultitest indent-line.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3) (indent-line m 4 nil) (values (offset m) @@ -876,8 +874,8 @@ (defmultitest indent-line.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 4))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 4) (indent-line m 5 4) (values (offset m) @@ -887,8 +885,8 @@ (defmultitest indent-line.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3) (indent-line m 5 4) (values (offset m) @@ -899,8 +897,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3) (delete-indentation m) (values (offset m) @@ -911,8 +909,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 7))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 7) (delete-indentation m) (values (offset m) @@ -922,8 +920,8 @@ (defmultitest delete-indentation.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 7))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 7) (delete-indentation m) (values (offset m) @@ -934,8 +932,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs ") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 12))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 12) (delete-indentation m) (values (offset m) @@ -947,8 +945,8 @@ (insert-buffer-sequence buffer 0 " climacs ") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 12))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 12) (delete-indentation m) (values (offset m) @@ -959,8 +957,8 @@ (defmultitest fill-line.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 25))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 25) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8) (values (offset m) @@ -972,8 +970,8 @@ (defmultitest fill-line.test-1a (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 25))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 25) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 nil) (values (offset m) @@ -985,8 +983,8 @@ (defmultitest fill-line.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 25))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 25) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8) (values (offset m) @@ -998,8 +996,8 @@ (defmultitest fill-line.test-2a (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 25))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 25) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 nil) (values (offset m) @@ -1011,8 +1009,8 @@ (defmultitest fill-line.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "c l i m a c s") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 1))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 1) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8) (values (offset m) @@ -1022,8 +1020,8 @@ (defmultitest fill-line.test-3a (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "c l i m a c s") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 1))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 1) (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 nil) (values (offset m) @@ -1057,10 +1055,10 @@ (defmultitest looking-at.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 1)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 1 + (offset m2) 3) (values (looking-at m1 "lima") (looking-at m2 "mac") @@ -1108,8 +1106,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 0))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 0) (search-forward m "Mac" :test #'char-equal) (offset m))) 7) @@ -1117,8 +1115,8 @@ (defmultitest search-forward.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3) (search-forward m "Mac" :test #'char-equal) (offset m))) 6) @@ -1126,8 +1124,8 @@ (defmultitest search-forward.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3) (search-forward m "klimaks") (offset m))) 3) @@ -1136,8 +1134,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs ") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 8))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 8) (search-backward m "Mac" :test #'char-equal) (offset m))) 3) @@ -1145,8 +1143,8 @@ (defmultitest search-backward.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 6))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 6) (search-backward m "Mac" :test #'char-equal) (offset m))) 3) @@ -1154,8 +1152,8 @@ (defmultitest search-backward.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3) (search-backward m "klimaks") (offset m))) 3) @@ -1182,4 +1180,4 @@ (climacs-base::buffer-search-word-backward buffer 4 "clim") (climacs-base::buffer-search-word-backward buffer 8 "macs") (climacs-base::buffer-search-word-backward buffer 8 ""))) - 0 nil nil nil 8) + 0 nil nil nil 8) \ No newline at end of file Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.17 climacs/buffer-test.lisp:1.18 --- climacs/buffer-test.lisp:1.17 Fri Feb 25 21:45:07 2005 +++ climacs/buffer-test.lisp Sun Feb 27 19:52:01 2005 @@ -8,6 +8,9 @@ (cl:in-package :climacs-tests) +(defclass delegating-standard-buffer (delegating-buffer) () + (:default-initargs :implementation (make-instance 'standard-buffer))) + (defmacro defmultitest (name form &rest results) (let ((name-string (symbol-name name))) (flet ((%deftest-wrapper (bc lsm rsm tn f rs) @@ -26,6 +29,13 @@ form results) ,(%deftest-wrapper + ''delegating-standard-buffer + ''standard-left-sticky-mark + ''standard-right-sticky-mark + (intern (concatenate 'string "DELEGATING-STANDARD-BUFFER-" name-string)) + form + results) + ,(%deftest-wrapper ''binseq-buffer ''persistent-left-sticky-mark ''persistent-right-sticky-mark @@ -42,13 +52,12 @@ (defmultitest buffer-make-instance.test-1 (let* ((buffer (make-instance %%buffer)) - (low (slot-value buffer 'low-mark)) - (high (slot-value buffer 'high-mark))) + (low (low-mark buffer)) + (high (low-mark buffer))) (and (= (offset low) 0) (= (offset high) 0) (null (modified-p buffer)) - (eq (buffer low) buffer) - (eq (buffer high) buffer))) + (eq (buffer low) (buffer high)))) t) (defmultitest mark-make-instance.test-1 @@ -73,8 +82,8 @@ ((null x) nil) (t (when (eq x y) y))))) (let* ((buffer (make-instance %%buffer)) - (low (slot-value buffer 'low-mark)) - (high (slot-value buffer 'high-mark)) + (low (low-mark buffer)) + (high (high-mark buffer)) (low2 (clone-mark low)) (high2 (clone-mark high)) (low3 (clone-mark high :left)) @@ -241,11 +250,10 @@ (defmultitest insert-object.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3) (insert-object m #\X) (and (= (size buffer) 8) - (eq (buffer m) buffer) (= (offset m) 3) (buffer-sequence buffer 0 8)))) "cliXmacs") @@ -253,11 +261,10 @@ (defmultitest insert-object.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3) (insert-object m #\X) (and (= (size buffer) 8) - (eq (buffer m) buffer) (= (offset m) 4) (buffer-sequence buffer 0 8)))) "cliXmacs") @@ -265,13 +272,13 @@ (defmultitest insert-sequence.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3 + (offset m2) 5) (insert-sequence m "ClimacS") (and (= (size buffer) 14) - (eq (buffer m) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 3) (= (offset m2) 12) (buffer-sequence buffer 0 14)))) @@ -280,13 +287,13 @@ (defmultitest insert-sequence.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :right)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3 + (offset m2) 5) (insert-sequence m "ClimacS") (and (= (size buffer) 14) - (eq (buffer m) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 10) (= (offset m2) 12) (buffer-sequence buffer 0 14)))) @@ -295,14 +302,13 @@ (defmultitest delete-range.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3 + (offset m2) 5) (delete-range m 2) (and (= (size buffer) 5) - (eq (buffer m) buffer) - (eq (buffer m2) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 3) (= (offset m2) 3) (buffer-sequence buffer 0 5)))) @@ -311,14 +317,13 @@ (defmultitest delete-range.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :right)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3 + (offset m2) 5) (delete-range m -2) (and (= (size buffer) 5) - (eq (buffer m) buffer) - (eq (buffer m2) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 1) (= (offset m2) 3) (buffer-sequence buffer 0 5)))) @@ -327,14 +332,13 @@ (defmultitest delete-region.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3 + (offset m2) 5) (delete-region m m2) (and (= (size buffer) 5) - (eq (buffer m) buffer) - (eq (buffer m2) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 3) (= (offset m2) 3) (buffer-sequence buffer 0 5)))) @@ -343,14 +347,13 @@ (defmultitest delete-region.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :right)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3 + (offset m2) 5) (delete-region m m2) (and (= (size buffer) 5) - (eq (buffer m) buffer) - (eq (buffer m2) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 3) (= (offset m2) 3) (buffer-sequence buffer 0 5)))) @@ -359,14 +362,13 @@ (defmultitest delete-region.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3 + (offset m2) 5) (delete-region m2 m) (and (= (size buffer) 5) - (eq (buffer m) buffer) - (eq (buffer m2) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 3) (= (offset m2) 3) (buffer-sequence buffer 0 5)))) @@ -375,14 +377,13 @@ (defmultitest delete-region.test-4 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :right)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m) 3 + (offset m2) 5) (delete-region m2 m) (and (= (size buffer) 5) - (eq (buffer m) buffer) - (eq (buffer m2) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 3) (= (offset m2) 3) (buffer-sequence buffer 0 5)))) @@ -394,10 +395,10 @@ (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") - (let ((m (make-instance %%right-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer2 :offset 5))) + (let ((m (clone-mark (low-mark buffer) :right)) + (m2 (clone-mark (low-mark buffer2) :right))) + (setf (offset m) 3 + (offset m2) 5) (delete-region m2 m))) (error (c) (declare (ignore c)) @@ -407,15 +408,14 @@ (defmultitest delete-region.test-6 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer :offset 5))) + (let ((m (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :left))) + (setf (offset m) 3 + (offset m2) 5) (delete-region m 5) (delete-region 1 m2) (and (= (size buffer) 3) - (eq (buffer m) buffer) - (eq (buffer m2) buffer) + (eq (buffer m) (buffer m2)) (= (offset m) 1) (= (offset m2) 1) (buffer-sequence buffer 0 3)))) @@ -437,19 +437,18 @@ (defmultitest mark-relations.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m0 (make-instance %%right-sticky-mark - :buffer buffer :offset 0)) - (m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m1a (make-instance %%right-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 4)) - (m2a (make-instance %%left-sticky-mark - :buffer buffer :offset 5)) - (m3 (make-instance %%left-sticky-mark - :buffer buffer :offset 7))) - (setf (offset m2) 5) + (let ((m0 (clone-mark (low-mark buffer) :right)) + (m1 (clone-mark (low-mark buffer) :left)) + (m1a (clone-mark (low-mark buffer) :right)) + (m2 (clone-mark (low-mark buffer) :right)) + (m2a (clone-mark (low-mark buffer) :left)) + (m3 (clone-mark (low-mark buffer) :left))) + (setf (offset m0) 0 + (offset m1) 3 + (offset m1a) 3 + (offset m2) 5 + (offset m2a) 5 + (offset m3) 7) (and (mark< m0 m1) (not (mark> m0 m1)) (not (mark>= m0 m1)) (mark< m0 m2) (not (mark> m0 m2)) (not (mark>= m0 m2)) (mark< m0 m3) (not (mark> m0 m3)) (not (mark>= m0 m3)) @@ -479,8 +478,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 4))) + (let ((m (clone-mark (low-mark buffer) :left))) (setf (offset m) -1))) (climacs-buffer::motion-before-beginning (c) (= (climacs-buffer::condition-offset c) -1))) @@ -490,8 +488,7 @@ (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 4))) + (let ((m (clone-mark (low-mark buffer) :left))) (setf (offset m) 8))) (climacs-buffer::motion-after-end (c) (= (climacs-buffer::condition-offset c) 8))) @@ -500,9 +497,10 @@ (defmultitest backward-object.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let* ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 4)) + (let* ((m1 (clone-mark (low-mark buffer) :left)) (m2 (clone-mark m1))) + (setf (offset m1) 4 + (offset m2) 4) (backward-object m1 2) (region-to-sequence m1 m2))) "im") @@ -511,9 +509,10 @@ (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let* ((m1 (make-instance %%right-sticky-mark - :buffer buffer :offset 2)) + (let* ((m1 (clone-mark (low-mark buffer) :right)) (m2 (clone-mark m1))) + (setf (offset m1) 2 + (offset m2) 2) (backward-object m1 3) (region-to-sequence m1 m2))) (climacs-buffer::motion-before-beginning (c) @@ -523,9 +522,10 @@ (defmultitest forward-object.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let* ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 4)) + (let* ((m1 (clone-mark (low-mark buffer) :left)) (m2 (clone-mark m1))) + (setf (offset m1) 4 + (offset m2) 4) (forward-object m1 2) (region-to-sequence m1 m2))) "ac") @@ -534,9 +534,10 @@ (handler-case (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") - (let* ((m1 (make-instance %%right-sticky-mark - :buffer buffer :offset 6)) + (let* ((m1 (clone-mark (low-mark buffer) :right)) (m2 (clone-mark m1))) + (setf (offset m1) 6 + (offset m2) 6) (forward-object m1 3) (region-to-sequence m1 m2))) (climacs-buffer::motion-after-end (c) @@ -572,10 +573,8 @@ (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 4)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer2 :offset 4))) + (let ((m1 (clone-mark (low-mark buffer))) + (m2 (clone-mark (low-mark buffer2)))) (mark< m1 m2))) (error (c) (declare (ignore c)) @@ -588,10 +587,8 @@ (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 4)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer2 :offset 4))) + (let ((m1 (clone-mark (low-mark buffer))) + (m2 (clone-mark (low-mark buffer2)))) (mark> m1 m2))) (error (c) (declare (ignore c)) @@ -604,10 +601,8 @@ (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 4)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer2 :offset 4))) + (let ((m1 (clone-mark (low-mark buffer))) + (m2 (clone-mark (low-mark buffer2)))) (mark<= m1 m2))) (error (c) (declare (ignore c)) @@ -620,10 +615,8 @@ (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 4)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer2 :offset 4))) + (let ((m1 (clone-mark (low-mark buffer))) + (m2 (clone-mark (low-mark buffer2)))) (mark>= m1 m2))) (error (c) (declare (ignore c)) @@ -636,10 +629,8 @@ (buffer2 (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (insert-buffer-sequence buffer2 0 "climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 4)) - (m2 (make-instance %%left-sticky-mark - :buffer buffer2 :offset 4))) + (let ((m1 (clone-mark (low-mark buffer))) + (m2 (clone-mark (low-mark buffer2)))) (mark= m1 m2))) (error (c) (declare (ignore c)) @@ -650,10 +641,10 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 11))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 3 + (offset m2) 11) (= 0 (line-number m1) (1- (line-number m2))))) t) @@ -678,10 +669,10 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((m1 (make-instance %%left-sticky-mark - :buffer buffer :offset 3)) - (m2 (make-instance %%right-sticky-mark - :buffer buffer :offset 11))) + (let ((m1 (clone-mark (low-mark buffer) :left)) + (m2 (clone-mark (low-mark buffer) :right))) + (setf (offset m1) 3 + (offset m2) 11) (= 3 (column-number m1) (column-number m2)))) t) @@ -689,8 +680,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 11))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 11) (and (not (beginning-of-line-p m)) (progn (beginning-of-line m) (beginning-of-line-p m))))) t) @@ -699,8 +690,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 11))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 11) (and (not (end-of-line-p m)) (progn (end-of-line m) (end-of-line-p m))))) t) @@ -709,8 +700,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 11))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 11) (and (not (beginning-of-buffer-p m)) (progn (beginning-of-buffer m) (beginning-of-buffer-p m))))) t) @@ -719,8 +710,8 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") - (let ((m (make-instance %%left-sticky-mark - :buffer buffer :offset 11))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 11) (and (not (end-of-buffer-p m)) (progn (end-of-buffer m) (end-of-buffer-p m))))) t) Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.19 climacs/climacs.asd:1.20 --- climacs/climacs.asd:1.19 Thu Feb 10 01:27:07 2005 +++ climacs/climacs.asd Sun Feb 27 19:52:01 2005 @@ -65,6 +65,7 @@ "cl-syntax" "kill-ring" "undo" + "delegating-buffer" "pane" "gui" ;;---- optional ---- Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.124 climacs/gui.lisp:1.125 --- climacs/gui.lisp:1.124 Thu Feb 24 09:30:28 2005 +++ climacs/gui.lisp Sun Feb 27 19:52:01 2005 @@ -346,11 +346,6 @@ ,@end-clauses)) (redisplay-frame-panes *application-frame*))))) -(defun region-limits (pane) - (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) `(,@command-name :name t) @@ -546,13 +541,13 @@ (define-named-command com-tabify-region () (let ((pane (current-window))) - (multiple-value-bind (start end) (region-limits pane) - (tabify-region start end (tab-space-count (stream-default-view pane)))))) + (tabify-region + (mark pane) (point pane) (tab-space-count (stream-default-view pane))))) (define-named-command com-untabify-region () (let ((pane (current-window))) - (multiple-value-bind (start end) (region-limits pane) - (untabify-region start end (tab-space-count (stream-default-view pane)))))) + (untabify-region + (mark pane) (point pane) (tab-space-count (stream-default-view pane))))) (defun indent-current-line (pane point) (let* ((buffer (buffer pane)) @@ -698,7 +693,8 @@ (pane (current-window))) (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) - (setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer)) + (setf (syntax buffer) (make-instance + 'basic-syntax :buffer (buffer (point pane)))) ;; Don't want to create the file if it doesn't exist. (when (probe-file filename) (with-open-file (stream filename :direction :input) @@ -775,11 +771,13 @@ (define-named-command com-switch-to-buffer () (let ((buffer (accept 'buffer - :prompt "Switch to buffer"))) - (setf (buffer (current-window)) buffer) - (setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer)) - (beginning-of-buffer (point (current-window))) - (full-redisplay (current-window)))) + :prompt "Switch to buffer")) + (pane (current-window))) + (setf (buffer pane) buffer) + (setf (syntax buffer) (make-instance + 'basic-syntax :buffer (buffer (point pane)))) + (beginning-of-buffer (point pane)) + (full-redisplay pane))) (define-named-command com-kill-buffer () (with-slots (buffers) *application-frame* @@ -834,8 +832,11 @@ (return-from com-goto-position nil)))))) (define-named-command com-goto-line () - (loop with mark = (make-instance 'standard-right-sticky-mark ;PB - :buffer (buffer (current-window))) + (loop with mark = (let ((m (clone-mark + (low-mark (buffer (current-window))) + :right))) + (beginning-of-buffer m) + m) do (end-of-line mark) until (end-of-buffer-p mark) repeat (handler-case (accept 'integer :prompt "Goto Line") @@ -868,7 +869,7 @@ (progn (beep) (display-message "No such syntax") (return-from com-set-syntax nil))) - :buffer buffer)) + :buffer (buffer (point pane)))) (setf (offset (low-mark buffer)) 0 (offset (high-mark buffer)) (size buffer)))) @@ -1021,9 +1022,10 @@ ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () - (multiple-value-bind (start end) (region-limits (current-window)) - (kill-ring-standard-push *kill-ring* (region-to-sequence start end)) - (delete-region (offset start) end))) + (let ((pane (current-window))) + (kill-ring-standard-push + *kill-ring* (region-to-sequence (mark pane) (point pane))) + (delete-region (mark pane) (point pane)))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.5 climacs/kill-ring.lisp:1.6 --- climacs/kill-ring.lisp:1.5 Fri Jan 7 19:58:08 2005 +++ climacs/kill-ring.lisp Sun Feb 27 19:52:01 2005 @@ -87,7 +87,7 @@ (with-slots (max-size) kr max-size)) -(defmethod (setf kill-ring-max-size) ((kr kill-ring) size) +(defmethod (setf kill-ring-max-size) (size (kr kill-ring)) (unless (typep size 'integer) (error "Error, ~S, is not an integer value" size)) (if (< size 5) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.50 climacs/packages.lisp:1.51 --- climacs/packages.lisp:1.50 Wed Feb 23 19:15:32 2005 +++ climacs/packages.lisp Sun Feb 27 19:52:01 2005 @@ -48,7 +48,9 @@ #:low-mark #:high-mark #:modified-p #:clear-modify #:binseq-buffer #:obinseq-buffer - #:persistent-left-sticky-mark #:persistent-right-sticky-mark)) + #:persistent-left-sticky-mark #:persistent-right-sticky-mark + + #:delegating-buffer #:implementation)) (defpackage :climacs-base (:use :clim-lisp :climacs-buffer) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.18 climacs/pane.lisp:1.19 --- climacs/pane.lisp:1.18 Sat Feb 5 07:49:53 2005 +++ climacs/pane.lisp Sun Feb 27 19:52:01 2005 @@ -135,6 +135,23 @@ (mapc #'flip-undo-record records) (setf records (nreverse records)))) +;;; undo-mixin delegation (here because of the package) + +(defmethod undo-tree ((buffer delegating-buffer)) + (undo-tree (implementation buffer))) + +(defmethod undo-accumulate ((buffer delegating-buffer)) + (undo-accumulate (implementation buffer))) + +(defmethod (setf undo-accumulate) (object (buffer delegating-buffer)) + (setf (undo-accumulate (implementation buffer)) object)) + +(defmethod performing-undo ((buffer delegating-buffer)) + (performing-undo (implementation buffer))) + +(defmethod (setf performing-undo) (object (buffer delegating-buffer)) + (setf (performing-undo (implementation buffer)) object)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Isearch @@ -165,17 +182,36 @@ ;(defgeneric indent-tabs-mode (climacs-buffer)) -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) ;PB +;;; syntax delegation + +(defmethod update-syntax ((buffer delegating-buffer) syntax) + (update-syntax (implementation buffer) syntax)) + +(defmethod update-syntax-for-redisplay ((buffer delegating-buffer) syntax from to) + (update-syntax-for-redisplay (implementation buffer) syntax from to)) + +;;; buffers + +(defclass extended-standard-buffer (standard-buffer undo-mixin abbrev-mixin) () + (:documentation "Extensions accessible via marks.")) + +(defclass extended-obinseq-buffer (obinseq-buffer undo-mixin abbrev-mixin) () + (:documentation "Extensions accessible via marks.")) + +(defclass climacs-buffer (delegating-buffer filename-mixin name-mixin) ((needs-saving :initform nil :accessor needs-saving) (syntax :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t :accessor indent-tabs-mode)) - (:default-initargs :name "*scratch*")) + (:default-initargs + :name "*scratch*" + :implementation (make-instance 'extended-standard-buffer))) (defmethod initialize-instance :after ((buffer climacs-buffer) &rest args) (declare (ignore args)) (with-slots (syntax) buffer - (setf syntax (make-instance 'basic-syntax :buffer buffer)))) + (setf syntax (make-instance + 'basic-syntax :buffer (implementation buffer))))) (defclass climacs-pane (application-pane) ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) @@ -210,14 +246,12 @@ (declare (ignore args)) (with-slots (buffer point mark) pane (when (null point) - (setf point (make-instance 'standard-right-sticky-mark ;PB - :buffer buffer))) + (setf point (clone-mark (low-mark buffer) :right))) (when (null mark) - (setf mark (make-instance 'standard-right-sticky-mark ;PB - :buffer buffer)))) + (setf mark (clone-mark (low-mark buffer) :right)))) (with-slots (buffer top bot scan) pane - (setf top (make-instance 'standard-left-sticky-mark :buffer buffer) ;PB - bot (make-instance 'standard-right-sticky-mark :buffer buffer))) ;PB + (setf top (clone-mark (low-mark buffer) :left) + bot (clone-mark (high-mark buffer) :right))) (setf (stream-default-view pane) (make-instance 'climacs-textual-view)) (with-slots (space-width tab-width) (stream-default-view pane) (let* ((medium (sheet-medium pane)) @@ -227,12 +261,10 @@ (defmethod (setf buffer) :after (buffer (pane climacs-pane)) (with-slots (point mark top bot) pane - (setf point (make-instance 'standard-right-sticky-mark ;PB - :buffer buffer) - mark (make-instance 'standard-right-sticky-mark ;PB - :buffer buffer) - top (make-instance 'standard-left-sticky-mark :buffer buffer) ;PB - bot (make-instance 'standard-right-sticky-mark :buffer buffer)))) ;PB + (setf point (clone-mark (low-mark (implementation buffer)) :right) + mark (clone-mark (low-mark (implementation buffer)) :right) + top (clone-mark (low-mark (implementation buffer)) :left) + bot (clone-mark (high-mark (implementation buffer)) :right)))) (define-presentation-type url () :inherit-from 'string) @@ -470,4 +502,4 @@ (defgeneric full-redisplay (pane)) (defmethod full-redisplay ((pane climacs-pane)) - (setf (full-redisplay-p pane) t)) \ No newline at end of file + (setf (full-redisplay-p pane) t))

1 0

[climacs-cvs] CVS update: climacs/cl-syntax.lisp
by rstrandh＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1744 Modified Files: cl-syntax.lisp Log Message: Improved performance some more by considering line comments to be single entries. Date: Sun Feb 27 07:23:28 2005 Author: rstrandh Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.3 climacs/cl-syntax.lisp:1.4 --- climacs/cl-syntax.lisp:1.3 Sun Feb 27 07:16:48 2005 +++ climacs/cl-syntax.lisp Sun Feb 27 07:23:28 2005 @@ -187,7 +187,9 @@ do (case object (#\( (fo) (make-entry 'list-start-entry)) (#\) (fo) (make-entry 'list-end-entry)) - (#\; (fo) (make-entry 'comment-entry)) + (#\; (loop do (fo) + until (end-of-line-p scan)) + (make-entry 'comment-entry)) (#\" (fo) (make-entry 'double-quote-entry)) (#\' (fo) (make-entry 'quote-entry)) (#\` (fo) (make-entry 'backquote-entry))

1 0

[climacs-cvs] CVS update: climacs/cl-syntax.lisp
by rstrandh＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1114 Modified Files: cl-syntax.lisp Log Message: Decreased consing by a third, and improved performance at the same time, by having a single mark and a size instead of two marks in a stack entry. Date: Sun Feb 27 07:16:52 2005 Author: rstrandh Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.2 climacs/cl-syntax.lisp:1.3 --- climacs/cl-syntax.lisp:1.2 Fri Feb 25 08:11:24 2005 +++ climacs/cl-syntax.lisp Sun Feb 27 07:16:48 2005 @@ -24,9 +24,15 @@ (defclass stack-entry () ((start-mark :initarg :start-mark :reader start-mark) - (end-mark :initarg :end-mark :reader end-mark)) + (size :initarg :size)) (:documentation "A stack entry corresponds to a syntactic category")) +(defgeneric end-offset (stack-entry)) + +(defmethod end-offset ((entry stack-entry)) + (with-slots (start-mark size) entry + (+ (offset start-mark) size))) + (defclass error-entry (stack-entry) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -167,14 +173,15 @@ :buffer buffer :offset 0))) (insert* elements 0 (make-instance 'start-entry - :start-mark mark :end-mark mark))))) + :start-mark mark :size 0))))) (defun next-entry (scan) (let ((start-mark (clone-mark scan))) (flet ((fo () (forward-object scan))) (macrolet ((make-entry (type) `(return-from next-entry - (make-instance ,type :start-mark start-mark :end-mark (clone-mark scan))))) + (make-instance ,type :start-mark start-mark + :size (- (offset scan) (offset start-mark)))))) (loop with object = (object-after scan) until (end-of-buffer-p scan) do (case object @@ -245,12 +252,12 @@ (when (mark<= low-mark high-mark) ;; go back to a position before low-mark (loop until (or (= guess-pos 1) - (mark< (end-mark (element* elements (1- guess-pos))) low-mark)) + (mark< (end-offset (element* elements (1- guess-pos))) low-mark)) do (decf guess-pos)) ;; go forward to the last position before low-mark (loop with nb-elements = (nb-elements elements) until (or (= guess-pos nb-elements) - (mark>= (end-mark (element* elements guess-pos)) low-mark)) + (mark>= (end-offset (element* elements guess-pos)) low-mark)) do (incf guess-pos)) ;; delete entries that must be reparsed (loop until (or (= guess-pos (nb-elements elements)) @@ -260,7 +267,7 @@ :buffer buffer :offset (if (zerop guess-pos) 0 - (offset (end-mark (element* elements (1- guess-pos))))))) + (end-offset (element* elements (1- guess-pos)))))) ;; scan (unless (end-of-buffer-p scan) (loop with start-mark = nil

1 0

[climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
by rstrandh＠common-lisp.net 26 Feb '05

26 Feb '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv17346/Doc Modified Files: climacs-internals.texi Log Message: Updated the description of the buffer protocol to reflect recent changes with respect to conditions and clone-mark. Date: Sat Feb 26 06:33:39 2005 Author: rstrandh Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.12 climacs/Doc/climacs-internals.texi:1.13 --- climacs/Doc/climacs-internals.texi:1.12 Sat Feb 5 14:49:22 2005 +++ climacs/Doc/climacs-internals.texi Sat Feb 26 06:33:37 2005 @@ -113,11 +113,12 @@ mark will be positioned to the right of the object. @end deftp -@deffn {Generic Function} {clone-mark} (mark &key type) +@deffn {Generic Function} {clone-mark} (mark &optional stick-to) -Clone a mark. By default (when type is NIL) the same type of mark is -returned. Otherwise type is the name of a class (subclass of the mark -class) to be used as a class of the clone. +Clone a mark. By default (when stick-to is NIL) the same type of mark +is returned. Otherwise stick-to is either :left, indicating that a +left-sticky-mark should be created, or :right indicating that a +right-sticky-mark should be created. @end deffn @deffn {Generic Function} {buffer} mark @@ -127,8 +128,42 @@ @deftp {Error Condition} no-such-offset -This condition is signaled whenever an attempt is made at an operation -that is before the beginning or after the end of the buffer. +This condition is signaled whenever an attempt is made to access an +object that is before the beginning or after the end of the buffer. +@end deftp + +@deftp {Error Condition} offset-before-beginning + +This condition is signaled whenever an attempt is made to access +buffer contents that is before the beginning of the buffer. +This condition is a subclass of no-such-offset +@end deftp + +@deftp {Error Condition} offset-after-end + +This condition is signaled whenever an attempt is made to access +buffer contents that is after the end of the buffer. +This condition is a subclass of no-such-offset +@end deftp + +@deftp {Error Condition} invalid-motion + +This condition is signaled whenever an attempt is made to move a mark +before the beginning or after the end of the buffer. +@end deftp + +@deftp {Error Condition} motion-before-beginning + +This condition is signaled whenever an attempt is made to move a mark +before the beginning of the buffer. +This condition is a subclass of invalid-motion. +@end deftp + +@deftp {Error Condition} motion-after-end + +This condition is signaled whenever an attempt is made to move a mark +after the end of the buffer. +This condition is a subclass of invalid-motion. @end deftp @deffn {Generic Function} {size} buffer @@ -152,25 +187,32 @@ @deffn {Generic Function} {(setf offset)} offset mark -Set the offset of the mark into the buffer. A no-such-offset -condition is signaled if the offset is less than zero or greater than -the size of the buffer. +Set the offset of the mark into the buffer. A motion-before-beginning +condition is signaled if the offset is less than zero. A +motion-after-end condition is signaled if the offset is greater than +the size of the buffer. @end deffn @deffn {Generic Function} {forward-object} mark &optional (count 1) -Move the mark forward the number of positions indicated by count. +Move the mark forward the number of positions indicated by count. This function could be implemented by an incf on the offset of the mark, but many buffer implementations can implement this function much -more efficiently in a different way. +more efficiently in a different way. A motion-before-beginning +condition is signaled if the resulting offset of the mark is less than +zero. A motion-after-end condition is signaled if the resulting offset +of the mark is greater than the size of the buffer. @end deffn @deffn {Generic Function} {backward-object} mark &optional (count 1) -Move the mark backward the number of positions indicated by count. +Move the mark backward the number of positions indicated by count. This function could be implemented by a decf on the offset of the mark, but many buffer implementations can implement this function much -more efficiently in a different way. +more efficiently in a different way. A motion-before-beginning +condition is signaled if the resulting offset of the mark is less than +zero. A motion-after-end condition is signaled if the resulting offset +of the mark is greater than the size of the buffer. @end deffn @deffn {Generic Function} {mark<} mark1 mark2 @@ -309,9 +351,10 @@ @deffn {Generic Function} {delete-buffer-range} buffer offset n -Delete n objects from the buffer starting at the offset. If offset -is negative or offset+n is greater than the size of the buffer, a -no-such-offset condition is signaled. +Delete n objects from the buffer starting at the offset. If offset is +negative, a offset-before-beginning condition is signaled. If +offset+n is greater than the size of the buffer, a offset-after-end +condition is signaled. @end deffn @deffn {Generic Function} {delete-range} mark &optional (n 1) @@ -336,31 +379,33 @@ @deffn {Generic Function} {buffer-object} buffer offset Return 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. +has offset 0. If offset is less than zero, an offset-before-beginning +condition is signaled. If offset is greater than or equal to +the size of the buffer, an offset-after-end condition is signaled. @end deffn @deffn {Generic Function} {buffer-sequence} buffer offset1 offset2 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 -or greater than or equal to the size of the buffer, a no-such-offset -condition is signaled. If offset2 is smaller than or equal to -offset1, an empty sequence will be returned. +offset2-1 as a sequence. If either of the offsets is less than zero, +an offset-before-beginning condition is signaled. If either of the +offsets is greater than or equal to the size of the buffer, an +offset-after-end condition is signaled. If offset2 is smaller than or +equal to offset1, an empty sequence will be returned. @end deffn @deffn {Generic Function} {object-before} mark Return the object that is immediately before the mark. If mark is at -the beginning of the buffer, a no-such-offset condition is signaled. -If the mark is at the beginning of a line, but not at the beginning -of the buffer, a newline character is returned. +the beginning of the buffer, an offset-before-beginning condition is +signaled. If the mark is at the beginning of a line, but not at the +beginning of the buffer, a newline character is returned. @end deffn @deffn {Generic Function} {object-after} mark Return the object that is immediately after the mark. If mark is at -the end of the buffer, a no-such-offset condition is signaled. If +the end of the buffer, an offset-after-end condition is signaled. If the mark is at the end of a line, but not at the end of the buffer, a newline character is returned. @end deffn @@ -371,6 +416,8 @@ mark2. An error is signaled if the two marks are positioned in different buffers. It is acceptable to pass an offset in place of one of the marks. + +This function calls buffer-sequence with the appropriate arguments. @end deffn @section Implementation hints

1 0