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

[climacs-cvs] CVS update: climacs/html-syntax.lisp
by rstrandh＠common-lisp.net 16 Mar '05

16 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31861 Modified Files: html-syntax.lisp Log Message: Cleanups and code factoring in HTML syntax. Fixed a bug in update-syntax. Date: Wed Mar 16 08:47:49 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.16 climacs/html-syntax.lisp:1.17 --- climacs/html-syntax.lisp:1.16 Wed Mar 16 07:12:09 2005 +++ climacs/html-syntax.lisp Wed Mar 16 08:47:49 2005 @@ -26,14 +26,14 @@ ;;; ;;; grammar classes -(defclass html-sym (parse-tree) +(defclass html-parse-tree (parse-tree) ((badness :initform 0 :initarg :badness :reader badness))) -(defmethod parse-tree-better ((t1 html-sym) (t2 html-sym)) +(defmethod parse-tree-better ((t1 html-parse-tree) (t2 html-parse-tree)) (and (eq (class-of t1) (class-of t2)) (< (badness t1) (badness t2)))) -(defclass html-nonterminal (html-sym) ()) +(defclass html-nonterminal (html-parse-tree) ()) (defclass words (html-nonterminal) ()) @@ -63,31 +63,11 @@ (defclass a (html-words) ()) (defclass para (html-words) ()) -(defclass html-token (html-sym) +(defclass html-token (html-parse-tree) ((ink) (face))) (defclass html-tag (html-token) ()) -(defclass <html> (html-tag) ()) -(defclass </html> (html-tag) ()) -(defclass <head> (html-tag) ()) -(defclass </head> (html-tag) ()) -(defclass <title> (html-tag) ()) -(defclass </title> (html-tag) ()) -(defclass <body> (html-tag) ()) -(defclass </body> (html-tag) ()) -(defclass <h1> (html-tag) ()) -(defclass </h1> (html-tag) ()) -(defclass <h2> (html-tag) ()) -(defclass </h2> (html-tag) ()) -(defclass <h3> (html-tag) ()) -(defclass </h3> (html-tag) ()) -(defclass <p> (html-tag) ()) -(defclass </p> (html-tag) ()) -(defclass <ul> (html-tag) ()) -(defclass </ul> (html-tag) ()) -(defclass <li> (html-tag) ()) -(defclass </li> (html-tag) ()) (defclass <a> (html-tag) ((start :initarg :start) (word :initarg :word) @@ -100,15 +80,15 @@ ;;; ;;; lexer -(defclass html-element (html-token) +(defclass html-lexeme (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) ()) +(defclass start-lexeme (html-lexeme) ()) +(defclass tag-start (html-lexeme) ()) +(defclass tag-end (html-lexeme) ()) +(defclass slash (html-lexeme) ()) +(defclass word (html-lexeme) ()) +(defclass delimiter (html-lexeme) ()) (defclass html-lexer (incremental-lexer) ()) @@ -142,42 +122,6 @@ (defparameter *html-grammar* (grammar - (<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))))) - (</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))))) - (<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))))) - (</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))))) - (<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))))) - (</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))))) - (<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))))) - (</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))))) (<a> -> (tag-start (word (and (= (end-offset tag-start) (start-offset word)) (word-is word "a"))) @@ -202,6 +146,73 @@ :words words :word word)))) +(defmacro define-start-tag (name string) + `(progn + (defclass ,name (html-tag) ()) + + (add-rule (grammar-rule + (,name -> (tag-start + (word (and (= (end-offset tag-start) (start-offset word)) + (word-is word ,string))) + (tag-end (= (end-offset word) (start-offset tag-end)))))) + *html-grammar*))) + +(defmacro define-end-tag (name string) + `(progn + (defclass ,name (html-tag) ()) + + (add-rule (grammar-rule + (,name -> (tag-start + (slash (= (end-offset tag-start) (start-offset slash))) + (word (and (= (end-offset slash) (start-offset word)) + (word-is word ,string))) + (tag-end (= (end-offset word) (start-offset tag-end)))))) + *html-grammar*))) + +(defmacro define-tag-pair (start-name end-name string) + `(progn (define-start-tag ,start-name ,string) + (define-end-tag ,end-name ,string))) + +(define-tag-pair <html> </html> "html") +(define-tag-pair <head> </head> "head") +(define-tag-pair <title> </title> "title") +(define-tag-pair <body> </body> "body") +(define-tag-pair <h1> </h1> "h1") +(define-tag-pair <h2> </h2> "h2") +(define-tag-pair <h3> </h3> "h3") +(define-tag-pair <p> </p> "p") +(define-tag-pair <ul> </ul> "ul") +(define-tag-pair <li> </li> "li") + +(defmacro define-list (name empty-name nonempty-name item-name) + `(progn + (defclass ,name (html-nonterminal) ()) + (defclass ,empty-name (,name) ()) + + (defclass ,nonempty-name (,name) + ((items :initarg :items) + (item :initarg :item))) + + (add-rule (grammar-rule (,name -> () + (make-instance ',empty-name))) + *html-grammar*) + + (add-rule (grammar-rule (,name -> (,name ,item-name) + (make-instance ',nonempty-name + :items ,name :item ,item-name))) + *html-grammar*) + + (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane) + (declare (ignore pane)) + nil) + + (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane) + (with-slots (items item) entity + (display-parse-tree items syntax pane) + (display-parse-tree item syntax pane))))) + +;;;;;;;;;;;;;;; title-item, title-items + (defclass title-item (html-nonterminal) ((item :initarg :item))) @@ -212,36 +223,7 @@ (with-slots (item) entity (display-parse-tree item syntax pane))) -;;;;;;;;;;;;;;; title-items - -(defclass title-items (html-nonterminal) ()) -(defclass empty-title-items (title-items) ()) - -(defclass nonempty-title-items (title-items) - ((items :initarg :items) - (item :initarg :item))) - -(add-rule (grammar-rule (title-items -> () - (make-instance 'empty-title-items))) - *html-grammar*) - -(add-rule (grammar-rule (title-items -> (title-items title-item) - (make-instance 'nonempty-title-items - :items title-items :item title-item))) - *html-grammar*) - -(defmethod display-parse-tree ((entity empty-title-items) (syntax html-syntax) pane) - (declare (ignore pane)) - nil) - -(defmethod display-parse-tree :around ((entity empty-title-items) syntax pane) - (declare (ignore syntax pane)) - nil) - -(defmethod display-parse-tree ((entity nonempty-title-items) (syntax html-syntax) pane) - (with-slots (items item) entity - (display-parse-tree items syntax pane) - (display-parse-tree item syntax pane))) +(define-list title-items empty-title-items nonempty-title-items title-item) ;;;;;;;;;;;;;;; title @@ -261,7 +243,7 @@ (display-parse-tree items syntax pane)) (display-parse-tree </title> syntax pane))) -;;;;;;;;;;;;;;; body-item +;;;;;;;;;;;;;;; body-item body-items (defclass body-item (html-nonterminal) ((item :initarg :item))) @@ -274,36 +256,7 @@ (with-slots (item) entity (display-parse-tree item syntax pane))) -;;;;;;;;;;;;;;; body-items - -(defclass body-items (html-nonterminal) ()) -(defclass empty-body-items (body-items) ()) - -(defclass nonempty-body-items (body-items) - ((items :initarg :items) - (item :initarg :item))) - -(add-rule (grammar-rule (body-items -> () - (make-instance 'empty-body-items))) - *html-grammar*) - -(add-rule (grammar-rule (body-items -> (body-items body-item) - (make-instance 'nonempty-body-items - :items body-items :item body-item))) - *html-grammar*) - -(defmethod display-parse-tree ((entity empty-body-items) (syntax html-syntax) pane) - (declare (ignore pane)) - nil) - -(defmethod display-parse-tree :around ((entity empty-body-items) syntax pane) - (declare (ignore syntax pane)) - nil) - -(defmethod display-parse-tree ((entity nonempty-body-items) (syntax html-syntax) pane) - (with-slots (items item) entity - (display-parse-tree items syntax pane) - (display-parse-tree item syntax pane))) +(define-list body-items empty-body-items nonempty-body-items body-item) ;;;;;;;;;;;;;;; body @@ -331,7 +284,7 @@ (setf lexer (make-instance 'html-lexer :buffer (buffer syntax))) (let ((m (clone-mark (low-mark buffer) :left))) (setf (offset m) 0) - (insert-lexeme lexer 0 (make-instance 'start-element + (insert-lexeme lexer 0 (make-instance 'start-lexeme :start-mark m :size 0 :state (initial-state parser)))))) @@ -357,10 +310,11 @@ (defmethod update-syntax (buffer (syntax html-syntax)) (with-slots (lexer valid-parse) syntax (let* ((low-mark (low-mark buffer)) - (high-mark (high-mark buffer)) - (first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark))) - (setf valid-parse first-invalid-position) - (update-lex lexer first-invalid-position high-mark)))) + (high-mark (high-mark buffer))) + (when (mark<= low-mark high-mark) + (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark))) + (setf valid-parse first-invalid-position) + (update-lex lexer first-invalid-position high-mark)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -388,14 +342,10 @@ pane (- tab-width (mod x tab-width)) 0)))) (incf start)))) -(defmethod display-parse-tree :around ((entity html-sym) syntax pane) +(defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane) (with-slots (top bot) pane - (when (mark> (end-offset entity) top) + (when (and (end-offset entity) (mark> (end-offset entity) top)) (call-next-method)))) - -(defmethod display-parse-tree :around ((entity empty-words) syntax pane) - (declare (ignore syntax pane)) - nil) (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane) (flet ((cache-test (t1 t2)

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 16 Mar '05

16 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv26142 Modified Files: html-syntax.lisp syntax.lisp Log Message: The start-mark and size of parse trees are now automatically updated in syntax.lisp, so there is no need for individual syntax modules to be concerned with updating them. Started restructuring the grammar in html-syntax so that for some grammatical entity, grammar rules, display function, class definition, etc are grouped together. This will probably be the preferable way of structuring most grammars for other syntax modules as well. Date: Wed Mar 16 07:12:10 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.15 climacs/html-syntax.lisp:1.16 --- climacs/html-syntax.lisp:1.15 Tue Mar 15 13:51:39 2005 +++ climacs/html-syntax.lisp Wed Mar 16 07:12:09 2005 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- +;;; -*- Mode: Lisp; Package: CLIMACS-HTML-SYNTAX -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) @@ -57,8 +57,6 @@ (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) ()) @@ -70,32 +68,32 @@ (defclass html-tag (html-token) ()) -(defclass <html> (html-tag) () (:default-initargs :size 6)) -(defclass </html> (html-tag) ()(:default-initargs :size 7)) -(defclass <head> (html-tag) () (:default-initargs :size 6)) -(defclass </head> (html-tag) () (:default-initargs :size 7)) -(defclass <title> (html-tag) () (:default-initargs :size 7)) -(defclass </title> (html-tag) () (:default-initargs :size 8)) -(defclass <body> (html-tag) () (:default-initargs :size 6)) -(defclass </body> (html-tag) () (:default-initargs :size 7)) -(defclass <h1> (html-tag) () (:default-initargs :size 4)) -(defclass </h1> (html-tag) () (:default-initargs :size 5)) -(defclass <h2> (html-tag) () (:default-initargs :size 4)) -(defclass </h2> (html-tag) () (:default-initargs :size 5)) -(defclass <h3> (html-tag) () (:default-initargs :size 4)) -(defclass </h3> (html-tag) () (:default-initargs :size 5)) -(defclass <p> (html-tag) () (:default-initargs :size 3)) -(defclass </p> (html-tag) () (:default-initargs :size 4)) -(defclass <ul> (html-tag) () (:default-initargs :size 4)) -(defclass </ul> (html-tag) () (:default-initargs :size 5)) -(defclass <li> (html-tag) () (:default-initargs :size 4)) -(defclass </li> (html-tag) () (:default-initargs :size 5)) +(defclass <html> (html-tag) ()) +(defclass </html> (html-tag) ()) +(defclass <head> (html-tag) ()) +(defclass </head> (html-tag) ()) +(defclass <title> (html-tag) ()) +(defclass </title> (html-tag) ()) +(defclass <body> (html-tag) ()) +(defclass </body> (html-tag) ()) +(defclass <h1> (html-tag) ()) +(defclass </h1> (html-tag) ()) +(defclass <h2> (html-tag) ()) +(defclass </h2> (html-tag) ()) +(defclass <h3> (html-tag) ()) +(defclass </h3> (html-tag) ()) +(defclass <p> (html-tag) ()) +(defclass </p> (html-tag) ()) +(defclass <ul> (html-tag) ()) +(defclass </ul> (html-tag) ()) +(defclass <li> (html-tag) ()) +(defclass </li> (html-tag) ()) (defclass <a> (html-tag) ((start :initarg :start) (word :initarg :word) (words :initarg :words) (end :initarg :end))) -(defclass </a> (html-tag) () (:default-initargs :size 4)) +(defclass </a> (html-tag) ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -147,96 +145,183 @@ (<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)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (</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)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (<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)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (</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)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (<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)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (</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)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (<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)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (</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)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (<a> -> (tag-start (word (and (= (end-offset tag-start) (start-offset word)) (word-is word "a"))) words tag-end) - :start-mark (start-mark tag-start) - :size (- (end-offset tag-end) (start-offset tag-start)) :start tag-start :word word :words words :end tag-end) (</a> -> (tag-start (slash (= (end-offset tag-start) (start-offset slash))) (word (and (= (end-offset slash) (start-offset word)) (word-is word "a"))) - (tag-end (= (end-offset word) (start-offset tag-end)))) - :start-mark (start-mark tag-start)) + (tag-end (= (end-offset word) (start-offset tag-end))))) (html -> (<html> head body </html>) - :start-mark (start-mark <html>) - :size (- (end-offset </html>) (start-offset <html>)) :start <html> :head head :body body :end </html>) (head -> (<head> title </head>) - :start-mark (start-mark <head>) - :size (- (end-offset </head>) (start-offset <head>)) :start <head> :title title :end </head>) - (title -> (<title> words </title>) - :start-mark (start-mark <title>) - :size (- (end-offset </title>) (start-offset <title>)) - :start <title> :words words :end </title>) - (body -> (<body> words </body>) - :start-mark (start-mark <body>) - :size (- (end-offset </body>) (start-offset <body>)) - :start <body> :words words :end </body>) (a -> (<a> words </a>) - :start-mark (start-mark <a>) - :size (- (end-offset </a>) (start-offset <a>)) :start <a> :words words :end </a>) (words -> () - (make-instance 'empty-words :start-mark nil)) + (make-instance 'empty-words)) (words -> (words word) (make-instance 'nonempty-words - :start-mark (or (start-mark words) (start-mark word)) - :size (- (end-offset word) (offset (or (start-mark words) (start-mark word)))) - :words words :word word)) - (word -> (a) - :start-mark (start-mark a) - :size (- (end-offset a) (start-offset a))) - (word -> (delimiter) - :start-mark (start-mark delimiter) - :size (- (end-offset delimiter) (start-offset delimiter))))) + :words words :word word)))) +(defclass title-item (html-nonterminal) + ((item :initarg :item))) + +(add-rule (grammar-rule (title-item -> (word) :item word)) *html-grammar*) +(add-rule (grammar-rule (title-item -> (delimiter) :item delimiter)) *html-grammar*) + +(defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane) + (with-slots (item) entity + (display-parse-tree item syntax pane))) + +;;;;;;;;;;;;;;; title-items + +(defclass title-items (html-nonterminal) ()) +(defclass empty-title-items (title-items) ()) + +(defclass nonempty-title-items (title-items) + ((items :initarg :items) + (item :initarg :item))) + +(add-rule (grammar-rule (title-items -> () + (make-instance 'empty-title-items))) + *html-grammar*) + +(add-rule (grammar-rule (title-items -> (title-items title-item) + (make-instance 'nonempty-title-items + :items title-items :item title-item))) + *html-grammar*) + +(defmethod display-parse-tree ((entity empty-title-items) (syntax html-syntax) pane) + (declare (ignore pane)) + nil) + +(defmethod display-parse-tree :around ((entity empty-title-items) syntax pane) + (declare (ignore syntax pane)) + nil) + +(defmethod display-parse-tree ((entity nonempty-title-items) (syntax html-syntax) pane) + (with-slots (items item) entity + (display-parse-tree items syntax pane) + (display-parse-tree item syntax pane))) + +;;;;;;;;;;;;;;; title + +(defclass title (html-nonterminal) + ((<title> :initarg :<title>) + (items :initarg :items) + (</title> :initarg :</title>))) + +(add-rule (grammar-rule (title -> (<title> title-items </title>) + :<title> <title> :items title-items :</title> </title>)) + *html-grammar*) + +(defmethod display-parse-tree ((entity title) (syntax html-syntax) pane) + (with-slots (<title> items </title>) entity + (display-parse-tree <title> syntax pane) + (with-text-face (pane :bold) + (display-parse-tree items syntax pane)) + (display-parse-tree </title> syntax pane))) + +;;;;;;;;;;;;;;; body-item + +(defclass body-item (html-nonterminal) + ((item :initarg :item))) + +(add-rule (grammar-rule (body-item -> (word) :item word)) *html-grammar*) +(add-rule (grammar-rule (body-item -> (delimiter) :item delimiter)) *html-grammar*) +(add-rule (grammar-rule (body-item -> (a) :item a)) *html-grammar*) + +(defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane) + (with-slots (item) entity + (display-parse-tree item syntax pane))) + +;;;;;;;;;;;;;;; body-items + +(defclass body-items (html-nonterminal) ()) +(defclass empty-body-items (body-items) ()) + +(defclass nonempty-body-items (body-items) + ((items :initarg :items) + (item :initarg :item))) + +(add-rule (grammar-rule (body-items -> () + (make-instance 'empty-body-items))) + *html-grammar*) + +(add-rule (grammar-rule (body-items -> (body-items body-item) + (make-instance 'nonempty-body-items + :items body-items :item body-item))) + *html-grammar*) + +(defmethod display-parse-tree ((entity empty-body-items) (syntax html-syntax) pane) + (declare (ignore pane)) + nil) + +(defmethod display-parse-tree :around ((entity empty-body-items) syntax pane) + (declare (ignore syntax pane)) + nil) + +(defmethod display-parse-tree ((entity nonempty-body-items) (syntax html-syntax) pane) + (with-slots (items item) entity + (display-parse-tree items syntax pane) + (display-parse-tree item syntax pane))) + +;;;;;;;;;;;;;;; body + +(defclass body (html-nonterminal) + ((<body> :initarg :<body>) + (items :initarg :items) + (</body> :initarg :</body>))) + +(add-rule (grammar-rule (body -> (<body> body-items </body>) + :<body> <body> :items body-items :</body> </body>)) + *html-grammar*) + +(defmethod display-parse-tree ((entity body) (syntax html-syntax) pane) + (with-slots (<body> items </body>) entity + (display-parse-tree <body> syntax pane) + (display-parse-tree items syntax pane) + (display-parse-tree </body> syntax pane))) + (defmethod initialize-instance :after ((syntax html-syntax) &rest args) (declare (ignore args)) (with-slots (parser lexer buffer) syntax @@ -347,10 +432,6 @@ (defmethod display-parse-tree :after ((entity html-balanced) (syntax html-syntax) pane) (with-slots (end) entity (display-parse-tree end syntax pane))) - -(defmethod display-parse-tree :around ((entity title) (syntax html-syntax) pane) - (with-text-face (pane :bold) - (call-next-method))) (defmethod display-parse-tree ((entity html-words) (syntax html-syntax) pane) (with-slots (words) entity Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.39 climacs/syntax.lisp:1.40 --- climacs/syntax.lisp:1.39 Tue Mar 15 13:51:39 2005 +++ climacs/syntax.lisp Wed Mar 16 07:12:10 2005 @@ -87,19 +87,22 @@ ;;; parse tree (defclass parse-tree () - ((start-mark :initarg :start-mark :reader start-mark) - (size :initarg :size))) + ((start-mark :initform nil :initarg :start-mark :reader start-mark) + (size :initform nil :initarg :size))) (defgeneric start-offset (parse-tree)) (defmethod start-offset ((tree parse-tree)) - (offset (start-mark tree))) + (let ((mark (start-mark tree))) + (when mark + (offset mark)))) (defgeneric end-offset (parse-tree)) (defmethod end-offset ((tree parse-tree)) (with-slots (start-mark size) tree - (+ (offset start-mark) size))) + (when start-mark + (+ (offset start-mark) size)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -275,9 +278,17 @@ :parse-trees (cons parse-tree (parse-trees prev-item)) :suffix remaining)) (t - (make-instance 'complete-item - :parse-tree remaining - :parse-trees (cons parse-tree (parse-trees prev-item))))))) + (let* ((parse-trees (cons parse-tree (parse-trees prev-item))) + (start (find-if-not #'null parse-trees + :from-end t :key #'start-offset)) + (end (find-if-not #'null parse-trees :key #'end-offset))) + (with-slots (start-mark size) remaining + (when start + (setf start-mark (start-mark start) + size (- (end-offset end) (start-offset start)))) + (make-instance 'complete-item + :parse-tree remaining + :parse-trees parse-trees))))))) (defgeneric item-equal (item1 item2))

1 0

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

15 Mar '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv19196/Persistent Modified Files: binseq2.lisp persistent-buffer.lisp Log Message: And end-of-line bug fix and related cleanup. Date: Tue Mar 15 19:41:19 2005 Author: abakic Index: climacs/Persistent/binseq2.lisp diff -u climacs/Persistent/binseq2.lisp:1.1 climacs/Persistent/binseq2.lisp:1.2 --- climacs/Persistent/binseq2.lisp:1.1 Sun Mar 13 21:51:53 2005 +++ climacs/Persistent/binseq2.lisp Tue Mar 15 19:41:19 2005 @@ -65,7 +65,7 @@ for e in l do (push e curr) - (when (eq e #\Newline) + (when (eql e #\Newline) (push (list-obinseq (nreverse curr)) ll) (setf curr nil)) finally @@ -136,7 +136,7 @@ "If the last line of A does not end with a newline, remove the first line of B and append it to the last line of A; otherwise, do nothing." (let ((a-last-line (cdr (binseq2-back a 1)))) - (if (eq (obinseq-back a-last-line 1) #\Newline) + (if (eql (obinseq-back a-last-line 1) #\Newline) (values a b) (values (binseq2-set a (1- (binseq2-length a)) @@ -227,11 +227,11 @@ (defun binseq2-offset (s i) (labels ((%offset (s i o) (cond - ((or (<= i 0) (eq s 'empty) (eq (car s) 'leaf)) o) - ((<= i (binseq2-length (caddr s))) (%offset (caddr s) i o)) + ((or (eq s 'empty) (<= i 0) (eq (car s) 'leaf)) o) + ((< i (binseq2-length (caddr s))) (%offset (caddr s) i o)) (t (%offset (cdddr s) (- i (binseq2-length (caddr s))) (+ o (binseq2-size (caddr s)))))))) - (%offset s (1+ i) 0))) + (%offset s i 0))) (defun binseq2-front2 (s i) (cond @@ -246,11 +246,11 @@ (defun binseq2-line2 (s i) (labels ((%line (s i o) (cond - ((or (<= i 0) (eq s 'empty) (eq (car s) 'leaf)) o) - ((<= i (binseq2-size (caddr s))) (%line (caddr s) i o)) + ((or (eq s 'empty) (<= i 0) (eq (car s) 'leaf)) o) + ((< i (binseq2-size (caddr s))) (%line (caddr s) i o)) (t (%line (cdddr s) (- i (binseq2-size (caddr s))) (+ o (binseq2-length (caddr s)))))))) - (%line s (1+ i) 0))) + (%line s i 0))) (defun binseq2-back (s i) (cond Index: climacs/Persistent/persistent-buffer.lisp diff -u climacs/Persistent/persistent-buffer.lisp:1.10 climacs/Persistent/persistent-buffer.lisp:1.11 --- climacs/Persistent/persistent-buffer.lisp:1.10 Sun Mar 13 21:51:53 2005 +++ climacs/Persistent/persistent-buffer.lisp Tue Mar 15 19:41:19 2005 @@ -373,14 +373,18 @@ (setf (offset mark) offset))) (defmethod end-of-line ((mark p-line-mark-mixin)) - (let* ((curr-offset (offset mark)) - (contents (slot-value (buffer mark) 'contents)) - (next-line-offset (binseq2-offset - contents - (1+ (binseq2-line2 contents curr-offset))))) - (if (> next-line-offset curr-offset) - (setf (offset mark) (1- next-line-offset)) - (setf (offset mark) (size (buffer mark)))))) + (let* ((offset (offset mark)) + (buffer (buffer mark)) + (size (size buffer)) + (contents (slot-value buffer 'contents)) + (next-line-offset + (binseq2-offset contents (1+ (binseq2-line2 contents offset))))) + (setf (offset mark) + (cond + ((> next-line-offset offset) (1- next-line-offset)) + ((and (> size 0) (eql (binseq2-get2 contents (1- size)) #\Newline)) + (1- size)) + (t size))))) (defmethod buffer-line-number ((buffer persistent-buffer) (offset integer)) (loop for i from 0 below offset

1 0

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

15 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19196 Modified Files: buffer-test.lisp Log Message: And end-of-line bug fix and related cleanup. Date: Tue Mar 15 19:41:18 2005 Author: abakic Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.19 climacs/buffer-test.lisp:1.20 --- climacs/buffer-test.lisp:1.19 Sun Mar 13 21:51:48 2005 +++ climacs/buffer-test.lisp Tue Mar 15 19:41:18 2005 @@ -703,6 +703,19 @@ (progn (end-of-line m) (end-of-line-p m))))) t) +(defmultitest end-of-line.test-2 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "climacs +") + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 1) + (and (not (end-of-line-p m)) + (progn (end-of-line m) + (values + (= (offset m) 7) + (buffer-object (buffer m) (offset m))))))) + t #\Newline) + (defmultitest beginning-of-buffer.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 15 Mar '05

15 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31557 Modified Files: html-syntax.lisp packages.lisp pane.lisp syntax.lisp Log Message: Minor fixes Date: Tue Mar 15 13:51:40 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.14 climacs/html-syntax.lisp:1.15 --- climacs/html-syntax.lisp:1.14 Tue Mar 15 06:39:24 2005 +++ climacs/html-syntax.lisp Tue Mar 15 13:51:39 2005 @@ -112,6 +112,8 @@ (defclass word (html-element) ()) (defclass delimiter (html-element) ()) +(defclass html-lexer (incremental-lexer) ()) + (defmethod next-lexeme ((lexer html-lexer) scan) (flet ((fo () (forward-object scan))) (let ((object (object-after scan))) @@ -126,8 +128,6 @@ (make-instance 'word)) (t (fo) (make-instance 'delimiter)))))))) - -(defclass html-lexer (incremental-lexer) ()) (define-syntax html-syntax ("HTML" (basic-syntax)) ((lexer :reader lexer) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.57 climacs/packages.lisp:1.58 --- climacs/packages.lisp:1.57 Tue Mar 15 06:39:24 2005 +++ climacs/packages.lisp Tue Mar 15 13:51:39 2005 @@ -105,6 +105,7 @@ #:parse-stack-next #:parse-stack-symbol #:parse-stack-parse-trees #:map-over-parse-trees #:syntax-line-indentation + #:redisplay-pane-with-syntax #:beginning-of-paragraph #:end-of-paragraph)) (defpackage :climacs-cl-syntax @@ -141,7 +142,6 @@ #:query-replace-state #:string1 #:string2 #:query-replace-mode #:with-undo - #:redisplay-pane-with-syntax #:url)) (defpackage :climacs-html-syntax Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.21 climacs/pane.lisp:1.22 --- climacs/pane.lisp:1.21 Sun Mar 13 21:51:48 2005 +++ climacs/pane.lisp Tue Mar 15 13:51:39 2005 @@ -477,8 +477,6 @@ (+ cursor-x 2) (+ cursor-y (* 0.8 height)) :ink cursor-ink))))) -(defgeneric redisplay-pane-with-syntax (pane syntax current-p)) - (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p) (display-cache pane (if current-p +red+ +blue+))) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.38 climacs/syntax.lisp:1.39 --- climacs/syntax.lisp:1.38 Tue Mar 15 06:39:24 2005 +++ climacs/syntax.lisp Tue Mar 15 13:51:39 2005 @@ -456,3 +456,10 @@ (return-from map-over-parse-trees nil)) (incomplete-items state)) (funcall function (state-contains-target-p state)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Display + +(defgeneric redisplay-pane-with-syntax (pane syntax current-p)) +

1 0

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

15 Mar '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv9534 Modified Files: climacs-internals.texi Log Message: Documented the incremental lexer protocol. Date: Tue Mar 15 07:19:23 2005 Author: rstrandh Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.16 climacs/Doc/climacs-internals.texi:1.17 --- climacs/Doc/climacs-internals.texi:1.16 Sat Mar 5 12:53:52 2005 +++ climacs/Doc/climacs-internals.texi Tue Mar 15 07:19:21 2005 @@ -718,6 +718,117 @@ @section Incremental parsing framework +@deftp {Protocol Class} parse-tree + +The base class for all parse trees. +@end deftp + +We use the term parse tree in a wider sense than what is common in the +parsing literature, in that a lexeme is a (trivial) parse tree. The +parser does not distinguish between lexemes and other parse trees, and +a grammar rule can produce a lexeme if that should be desired. + +@deffn {Generic Function} {start-offset} parse-tree + +The offset in the buffer of the first character of a parse tree. +@end deffn + +@deffn {Generic Function} {end-offset} parse-tree + +The offset in the buffer of the character following the last one of a +parse tree. +@end deffn + +The length of a parse-tree is thus the difference of its end offset +and its start offset. + +The start offset and the end offset may be NIL which is typically the +case when a parse tree is derived from the empty sequence of lexemes. + +@subsection Lexical analysis + +@deftp {Protocol Class} lexer + +The base class for all lexers. +@end deftp + +@deftp {initarg} :buffer + +Associate a buffer with a lexer +@end deftp + +@deffn {Generic Function} {buffer} lexer + +Return the buffer associated with the lexer +@end deffn + +@deftp {Class} incremental-lexer + +A subclass of lexer which maintains the buffer in the form of a +sequence of lexemes that is updated incrementally. +@end deftp + +In the sequence of lexemes maintained by the incremental lexer, the +lexemes are indexed by a position starting from zero. + +@deffn {Generic Function} {nb-lexemes} lexer + +Return the number of lexemes in the lexer. +@end deffn + +@deffn {Generic Function} {lexeme} lexer pos + +Given a lexer and a position, return the lexeme in that position in +the lexer. +@end deffn + +@deffn {Generic Function} {insert-lexeme} lexer pos lexeme + +Insert a lexeme at the position in the lexer. All lexemes following +POS are moved to one position higher. +@end deffn + +@deffn {Generic Function} {delete-invalid-lexemes} lexer from to + +Invalidate all lexemes that could have changed as a result of +modifications to the buffer +@end deffn + +@deffn {Generic Function} {inter-lexeme-object-p} lexer object + +This generic function is called by the incremental lexer to determine +whether a buffer object is an inter-lexeme object, typically +whitespace. Client code must supply a method for this generic +function. +@end deffn + +@deffn {Generic Function} {skip-inter-lexeme-objects} lexer scan + +This generic function is called by the incremental lexer to skip +inter-lexeme buffer objects. The default method for this generic +function increments the scan mark until the object after the mark is +not an inter-lexeme object, or until the end of the buffer has been +reached. +@end deffn + +@deffn {Generic Function} {update-lex} lexer start-pos end + +This function is called by client code as part of the buffer-update +protocol to inform the lexer that it needs to analyze the contents of +the buffer at least up to the END mark of the buffer. START-POS is +the position in the lexeme sequence at which new lexemes should be +inserted. +@end deffn + +@deffn {Generic Function} {next-lexeme} lexer scan +This generic function is called by the incremental lexer to get a new +lexeme from the buffer. Client code must supply a method for this +function that specializes on the lexer class. It is guaranteed that +scan is not at the end of the buffer, and that the first object after +scan is not an inter-lexeme object. Thus, a lexeme should always be +returned by this function. +@end deffn + @subsection Earley parser Climacs contains an incremental parser that uses the Earley

1 0

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

15 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6981 Modified Files: html-syntax.lisp packages.lisp syntax.lisp Log Message: The incremental lexer is now in the climacs-syntax package in the syntax.lisp file. Date: Tue Mar 15 06:39:25 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.13 climacs/html-syntax.lisp:1.14 --- climacs/html-syntax.lisp:1.13 Tue Mar 15 05:31:59 2005 +++ climacs/html-syntax.lisp Tue Mar 15 06:39:24 2005 @@ -24,92 +24,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; this should really go in syntax.lisp - -(defclass parse-tree () - ((start-mark :initarg :start-mark :reader start-mark) - (size :initarg :size))) - -(defgeneric start-offset (parse-tree)) - -(defmethod start-offset ((tree parse-tree)) - (offset (start-mark tree))) - -(defgeneric end-offset (parse-tree)) - -(defmethod end-offset ((tree parse-tree)) - (with-slots (start-mark size) tree - (+ (offset start-mark) size))) - -(defclass lexer () - ((buffer :initarg :buffer :reader buffer))) - -(defgeneric nb-lexemes (lexer)) -(defgeneric lexeme (lexer pos)) -(defgeneric insert-lexeme (lexer pos lexeme)) -(defgeneric delete-invalid-lexemes (lexer from to)) -(defgeneric inter-lexeme-object-p (lexer object)) -(defgeneric skip-inter-lexeme-objects (lexer scan)) -(defgeneric update-lex (lexer start-pos end)) - -(defclass incremental-lexer (lexer) - ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes))) - -(defmethod nb-lexemes ((lexer incremental-lexer)) - (nb-elements (lexemes lexer))) - -(defmethod lexeme ((lexer incremental-lexer) pos) - (element* (lexemes lexer) pos)) - -(defmethod insert-lexeme ((lexer incremental-lexer) pos lexeme) - (insert* (lexemes lexer) pos lexeme)) - -(defmethod delete-invalid-lexemes ((lexer incremental-lexer) from to) - "delete all lexemes between FROM and TO and return the first invalid -position in the lexemes of LEXER" - (with-slots (lexemes) lexer - (let ((start 1) - (end (nb-elements lexemes))) - ;; use binary search to find the first lexeme to delete - (loop while (< start end) - do (let ((middle (floor (+ start end) 2))) - (if (mark< (end-offset (element* lexemes middle)) from) - (setf start (1+ middle)) - (setf end middle)))) - ;; delete lexemes - (loop until (or (= start (nb-elements lexemes)) - (mark> (start-mark (element* lexemes start)) to)) - do (delete* lexemes start)) - start))) - -(defmethod skip-inter-lexeme-objects ((lexer incremental-lexer) scan) - (loop until (end-of-buffer-p scan) - while (inter-lexeme-object-p lexer (object-after scan)) - do (forward-object scan))) - -(defmethod update-lex ((lexer incremental-lexer) start-pos end) - (let ((scan (clone-mark (low-mark (buffer lexer)) :left))) - (setf (offset scan) - (end-offset (lexeme lexer (1- start-pos)))) - (loop do (skip-inter-lexeme-objects lexer scan) - until (if (end-of-buffer-p end) - (end-of-buffer-p scan) - (mark> scan end)) - do (let* ((start-mark (clone-mark scan)) - (lexeme (next-lexeme scan)) - (size (- (offset scan) (offset start-mark)))) - (setf (slot-value lexeme 'start-mark) start-mark - (slot-value lexeme 'size) size) - (insert-lexeme lexer start-pos lexeme)) - (incf start-pos)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; grammar classes (defclass html-sym (parse-tree) - ((badness :initform 0 :initarg :badness :reader badness) - (message :initform "" :initarg :message :reader message))) + ((badness :initform 0 :initarg :badness :reader badness))) (defmethod parse-tree-better ((t1 html-sym) (t2 html-sym)) (and (eq (class-of t1) (class-of t2)) @@ -194,7 +112,7 @@ (defclass word (html-element) ()) (defclass delimiter (html-element) ()) -(defun next-lexeme (scan) +(defmethod next-lexeme ((lexer html-lexer) scan) (flet ((fo () (forward-object scan))) (let ((object (object-after scan))) (case object Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.56 climacs/packages.lisp:1.57 --- climacs/packages.lisp:1.56 Sun Mar 13 21:51:48 2005 +++ climacs/packages.lisp Tue Mar 15 06:39:24 2005 @@ -92,8 +92,15 @@ (:export #:syntax #:define-syntax #:basic-syntax #:update-syntax #:update-syntax-for-display - #:grammar #:parser #:initial-state + #:grammar #:grammar-rule #:add-rule + #:parser #:initial-state #:advance-parse + #:parse-tree #:start-offset #:end-offset + #:start-mark ; FIXME remove this + #:lexer #:nb-lexemes #:lexeme #:insert-lexeme + #:incremental-lexer #:next-lexeme + #:delete-invalid-lexemes #:inter-lexeme-object-p + #:skip-inter-lexeme-objects #:update-lex #:parse-stack-top #:target-parse-tree #:parse-state-empty-p #:parse-stack-next #:parse-stack-symbol #:parse-stack-parse-trees #:map-over-parse-trees Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.37 climacs/syntax.lisp:1.38 --- climacs/syntax.lisp:1.37 Tue Mar 15 05:31:59 2005 +++ climacs/syntax.lisp Tue Mar 15 06:39:24 2005 @@ -82,6 +82,92 @@ ;;; ;;; Incremental Earley parser +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; parse tree + +(defclass parse-tree () + ((start-mark :initarg :start-mark :reader start-mark) + (size :initarg :size))) + +(defgeneric start-offset (parse-tree)) + +(defmethod start-offset ((tree parse-tree)) + (offset (start-mark tree))) + +(defgeneric end-offset (parse-tree)) + +(defmethod end-offset ((tree parse-tree)) + (with-slots (start-mark size) tree + (+ (offset start-mark) size))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; lexer + +(defclass lexer () + ((buffer :initarg :buffer :reader buffer))) + +(defgeneric nb-lexemes (lexer)) +(defgeneric lexeme (lexer pos)) +(defgeneric insert-lexeme (lexer pos lexeme)) +(defgeneric delete-invalid-lexemes (lexer from to)) +(defgeneric inter-lexeme-object-p (lexer object)) +(defgeneric skip-inter-lexeme-objects (lexer scan)) +(defgeneric update-lex (lexer start-pos end)) +(defgeneric next-lexeme (lexer scan)) + +(defclass incremental-lexer (lexer) + ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes))) + +(defmethod nb-lexemes ((lexer incremental-lexer)) + (nb-elements (lexemes lexer))) + +(defmethod lexeme ((lexer incremental-lexer) pos) + (element* (lexemes lexer) pos)) + +(defmethod insert-lexeme ((lexer incremental-lexer) pos lexeme) + (insert* (lexemes lexer) pos lexeme)) + +(defmethod delete-invalid-lexemes ((lexer incremental-lexer) from to) + "delete all lexemes between FROM and TO and return the first invalid +position in the lexemes of LEXER" + (with-slots (lexemes) lexer + (let ((start 1) + (end (nb-elements lexemes))) + ;; use binary search to find the first lexeme to delete + (loop while (< start end) + do (let ((middle (floor (+ start end) 2))) + (if (mark< (end-offset (element* lexemes middle)) from) + (setf start (1+ middle)) + (setf end middle)))) + ;; delete lexemes + (loop until (or (= start (nb-elements lexemes)) + (mark> (start-mark (element* lexemes start)) to)) + do (delete* lexemes start)) + start))) + +(defmethod skip-inter-lexeme-objects ((lexer incremental-lexer) scan) + (loop until (end-of-buffer-p scan) + while (inter-lexeme-object-p lexer (object-after scan)) + do (forward-object scan))) + +(defmethod update-lex ((lexer incremental-lexer) start-pos end) + (let ((scan (clone-mark (low-mark (buffer lexer)) :left))) + (setf (offset scan) + (end-offset (lexeme lexer (1- start-pos)))) + (loop do (skip-inter-lexeme-objects lexer scan) + until (if (end-of-buffer-p end) + (end-of-buffer-p scan) + (mark> scan end)) + do (let* ((start-mark (clone-mark scan)) + (lexeme (next-lexeme lexer scan)) + (size (- (offset scan) (offset start-mark)))) + (setf (slot-value lexeme 'start-mark) start-mark + (slot-value lexeme 'size) size) + (insert-lexeme lexer start-pos lexeme)) + (incf start-pos)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; grammar @@ -92,9 +178,10 @@ (symbols :initarg :symbols :reader symbols))) (defclass grammar () - ((rules :initarg :rules :reader rules))) + ((rules :initarg :rules :accessor rules))) -(defmacro grammar (&body body) +(defmacro grammar-rule ((left-hand-side arrow arglist &body body)) + (declare (ignore arrow)) (labels ((var-of (arg) (if (symbolp arg) arg @@ -110,25 +197,33 @@ ((symbolp (cadr arg)) t) (t (cadr arg)))) (build-rule (arglist body) - (if (null arglist) - body - (let ((arg (car arglist))) - `(lambda (,(var-of arg)) - (when (and (typep ,(var-of arg) ',(sym-of arg)) - ,(test-of arg)) - ,(build-rule (cdr arglist) body)))))) - (make-rule (rule) - `(make-instance 'rule - :left-hand-side ',(car rule) - :right-hand-side - ,(build-rule (caddr rule) - (if (or (= (length rule) 3) - (symbolp (cadddr rule))) - `(make-instance ',(car rule) ,@(cdddr rule)) - `(progn ,@(cdddr rule)))) - :symbols ,(coerce (mapcar #'sym-of (caddr rule)) 'vector)))) - `(make-instance 'grammar - :rules (list ,@(mapcar #'make-rule body))))) + (if (null arglist) + body + (let ((arg (car arglist))) + `(lambda (,(var-of arg)) + (when (and (typep ,(var-of arg) ',(sym-of arg)) + ,(test-of arg)) + ,(build-rule (cdr arglist) body))))))) + `(make-instance 'rule + :left-hand-side ',left-hand-side + :right-hand-side + ,(build-rule arglist + (if (or (null body) + (symbolp (car body))) + `(make-instance ',left-hand-side ,@body) + `(progn ,@body))) + :symbols ,(coerce (mapcar #'sym-of arglist) 'vector)))) + + +(defmacro grammar (&body body) + `(make-instance 'grammar + :rules (list ,@(loop for rule in body + collect `(grammar-rule ,rule))))) + +(defgeneric add-rule (rule grammar)) + +(defmethod add-rule (rule (grammar grammar)) + (push rule (rules grammar))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS update: climacs/html-syntax.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 15 Mar '05

15 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv3123 Modified Files: html-syntax.lisp syntax.lisp Log Message: factored out the incremental lexer from html-syntax. The code is still physically in the file html-syntax.lisp, but that will change soon. Date: Tue Mar 15 05:31:59 2005 Author: rstrandh Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.12 climacs/html-syntax.lisp:1.13 --- climacs/html-syntax.lisp:1.12 Sun Mar 13 21:51:48 2005 +++ climacs/html-syntax.lisp Tue Mar 15 05:31:59 2005 @@ -46,6 +46,11 @@ (defgeneric nb-lexemes (lexer)) (defgeneric lexeme (lexer pos)) +(defgeneric insert-lexeme (lexer pos lexeme)) +(defgeneric delete-invalid-lexemes (lexer from to)) +(defgeneric inter-lexeme-object-p (lexer object)) +(defgeneric skip-inter-lexeme-objects (lexer scan)) +(defgeneric update-lex (lexer start-pos end)) (defclass incremental-lexer (lexer) ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes))) @@ -56,6 +61,48 @@ (defmethod lexeme ((lexer incremental-lexer) pos) (element* (lexemes lexer) pos)) +(defmethod insert-lexeme ((lexer incremental-lexer) pos lexeme) + (insert* (lexemes lexer) pos lexeme)) + +(defmethod delete-invalid-lexemes ((lexer incremental-lexer) from to) + "delete all lexemes between FROM and TO and return the first invalid +position in the lexemes of LEXER" + (with-slots (lexemes) lexer + (let ((start 1) + (end (nb-elements lexemes))) + ;; use binary search to find the first lexeme to delete + (loop while (< start end) + do (let ((middle (floor (+ start end) 2))) + (if (mark< (end-offset (element* lexemes middle)) from) + (setf start (1+ middle)) + (setf end middle)))) + ;; delete lexemes + (loop until (or (= start (nb-elements lexemes)) + (mark> (start-mark (element* lexemes start)) to)) + do (delete* lexemes start)) + start))) + +(defmethod skip-inter-lexeme-objects ((lexer incremental-lexer) scan) + (loop until (end-of-buffer-p scan) + while (inter-lexeme-object-p lexer (object-after scan)) + do (forward-object scan))) + +(defmethod update-lex ((lexer incremental-lexer) start-pos end) + (let ((scan (clone-mark (low-mark (buffer lexer)) :left))) + (setf (offset scan) + (end-offset (lexeme lexer (1- start-pos)))) + (loop do (skip-inter-lexeme-objects lexer scan) + until (if (end-of-buffer-p end) + (end-of-buffer-p scan) + (mark> scan end)) + do (let* ((start-mark (clone-mark scan)) + (lexeme (next-lexeme scan)) + (size (- (offset scan) (offset start-mark)))) + (setf (slot-value lexeme 'start-mark) start-mark + (slot-value lexeme 'size) size) + (insert-lexeme lexer start-pos lexeme)) + (incf start-pos)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; grammar classes @@ -162,8 +209,10 @@ (t (fo) (make-instance 'delimiter)))))))) +(defclass html-lexer (incremental-lexer) ()) + (define-syntax html-syntax ("HTML" (basic-syntax)) - ((lexemes :initform (make-instance 'standard-flexichain)) + ((lexer :reader lexer) (valid-parse :initform 1) (parser))) @@ -272,82 +321,43 @@ (defmethod initialize-instance :after ((syntax html-syntax) &rest args) (declare (ignore args)) - (with-slots (parser lexemes buffer) syntax + (with-slots (parser lexer buffer) syntax (setf parser (make-instance 'parser :grammar *html-grammar* :target 'html)) + (setf lexer (make-instance 'html-lexer :buffer (buffer syntax))) (let ((m (clone-mark (low-mark buffer) :left))) (setf (offset m) 0) - (insert* lexemes 0 (make-instance 'start-element - :start-mark m - :size 0 - :state (initial-state parser)))))) + (insert-lexeme lexer 0 (make-instance 'start-element + :start-mark m + :size 0 + :state (initial-state parser)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; update syntax + (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot) - (with-slots (parser lexemes valid-parse) syntax - (loop until (= valid-parse (nb-elements lexemes)) - while (mark<= (end-offset (element* lexemes valid-parse)) bot) - do (let ((current-token (element* lexemes (1- valid-parse))) - (next-lexeme (element* lexemes valid-parse))) + (with-slots (parser lexer valid-parse) syntax + (loop until (= valid-parse (nb-lexemes lexer)) + while (mark<= (end-offset (lexeme lexer valid-parse)) bot) + do (let ((current-token (lexeme lexer (1- valid-parse))) + (next-lexeme (lexeme lexer valid-parse))) (setf (slot-value next-lexeme 'state) (advance-parse parser (list next-lexeme) (slot-value current-token 'state)))) (incf valid-parse)))) -(defun delete-invalid-lexemes (lexemes from to) - "delete all lexemes between FROM and TO and return the first invalid -position in LEXEMES" - (let ((start 1) - (end (nb-elements lexemes))) - ;; use binary search to find the first lexeme to delete - (loop while (< start end) - do (let ((middle (floor (+ start end) 2))) - (if (mark< (end-offset (element* lexemes middle)) from) - (setf start (1+ middle)) - (setf end middle)))) - ;; delete lexemes - (loop until (or (= start (nb-elements lexemes)) - (mark> (start-mark (element* lexemes start)) to)) - do (delete* lexemes start)) - start)) - - -(defun inter-lexeme-object-p (lexemes object) - (declare (ignore lexemes)) +(defmethod inter-lexeme-object-p ((lexer html-lexer) object) (whitespacep object)) -(defun skip-inter-lexeme-objects (lexemes scan) - (loop until (end-of-buffer-p scan) - while (inter-lexeme-object-p lexemes (object-after scan)) - do (forward-object scan))) - -(defun update-lex (lexemes start-pos end) - (let ((scan (clone-mark (low-mark (buffer end)) :left))) - ;; FIXME, eventually use the buffer of the lexer - (setf (offset scan) - (end-offset (element* lexemes (1- start-pos)))) - (loop do (skip-inter-lexeme-objects lexemes scan) - until (if (end-of-buffer-p end) - (end-of-buffer-p scan) - (mark> scan end)) - do (let* ((start-mark (clone-mark scan)) - (lexeme (next-lexeme scan)) - (size (- (offset scan) (offset start-mark)))) - (setf (slot-value lexeme 'start-mark) start-mark - (slot-value lexeme 'size) size) - (insert* lexemes start-pos lexeme)) - (incf start-pos)))) - (defmethod update-syntax (buffer (syntax html-syntax)) - (with-slots (lexemes valid-parse) syntax + (with-slots (lexer valid-parse) syntax (let* ((low-mark (low-mark buffer)) (high-mark (high-mark buffer)) - (first-invalid-position (delete-invalid-lexemes lexemes low-mark high-mark))) + (first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark))) (setf valid-parse first-invalid-position) - (update-lex lexemes first-invalid-position high-mark)))) + (update-lex lexer first-invalid-position high-mark)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -473,35 +483,35 @@ (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot))) *current-line* 0 (aref *cursor-positions* 0) (stream-cursor-position pane)) - (with-slots (lexemes) syntax - (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements lexemes))) + (with-slots (lexer) syntax + (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer))) 1.0))) ;; find the last token before bot (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1))) ;; go back to a token before bot - (loop until (mark<= (end-offset (element* lexemes (1- end-token-index))) bot) + (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot) do (decf end-token-index)) ;; go forward to the last token before bot - (loop until (or (= end-token-index (nb-elements lexemes)) - (mark> (start-offset (element* lexemes end-token-index)) bot)) + (loop until (or (= end-token-index (nb-lexemes lexer)) + (mark> (start-offset (lexeme lexer end-token-index)) bot)) do (incf end-token-index)) (let ((start-token-index end-token-index)) ;; go back to the first token after top, or until the previous token ;; contains a valid parser state - (loop until (or (mark<= (end-offset (element* lexemes (1- start-token-index))) top) + (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top) (not (parse-state-empty-p - (slot-value (element* lexemes (1- start-token-index)) 'state)))) + (slot-value (lexeme lexer (1- start-token-index)) 'state)))) do (decf start-token-index)) (let ((*white-space-start* (offset top))) ;; display the parse tree if any - (unless (parse-state-empty-p (slot-value (element* lexemes (1- start-token-index)) 'state)) - (display-parse-state (slot-value (element* lexemes (1- start-token-index)) 'state) + (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state)) + (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state) syntax pane)) ;; display the lexemes (with-drawing-options (pane :ink +red+) (loop while (< start-token-index end-token-index) - do (let ((token (element* lexemes start-token-index))) + do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax pane)) (incf start-token-index)))))))) (let* ((cursor-line (number-of-lines-in-region top (point pane))) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.36 climacs/syntax.lisp:1.37 --- climacs/syntax.lisp:1.36 Fri Mar 11 08:03:31 2005 +++ climacs/syntax.lisp Tue Mar 15 05:31:59 2005 @@ -23,7 +23,7 @@ (in-package :climacs-syntax) (defclass syntax (name-mixin) - ((buffer :initarg :buffer))) + ((buffer :initarg :buffer :reader buffer))) (defgeneric update-syntax (buffer syntax))

1 0

[climacs-cvs] CVS update: climacs/Persistent/binseq2.lisp climacs/Persistent/binseq-package.lisp climacs/Persistent/binseq.lisp climacs/Persistent/obinseq.lisp climacs/Persistent/persistent-buffer.lisp
by abakic＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/climacs/cvsroot/climacs/Persistent In directory common-lisp.net:/tmp/cvs-serv22428/Persistent Modified Files: binseq-package.lisp binseq.lisp obinseq.lisp persistent-buffer.lisp Added Files: binseq2.lisp Log Message: Line-oriented persistent buffer (binseq2). Warning: Need to fix minor bugs (related to number-of-lines-in-region, I believe). base.lisp: Added faster methods on previous-line, next-line, buffer-number-of-lines-in-region. pane.lisp, cl-syntax.lisp, html-syntax.lisp, text-syntax.lisp: Replaced some calls to make-instance to calls to clone-mark and (setf offset), in order to avoid passing climacs-buffer to marks. This also made possible to get rid of delegating methods on syntax. climacs.asd: Added Persistent/binseq2. packages.lisp: Added binseq2-related symbols. Persistent/binseq.lisp, Persistent/obinseq.lisp: Cleanup. Persistent/persistent-buffer.lisp: Added code for binseq2-buffer and related marks. Also some minor fixes. Date: Sun Mar 13 21:51:54 2005 Author: abakic Index: climacs/Persistent/binseq-package.lisp diff -u climacs/Persistent/binseq-package.lisp:1.2 climacs/Persistent/binseq-package.lisp:1.3 --- climacs/Persistent/binseq-package.lisp:1.2 Sun Mar 6 00:24:41 2005 +++ climacs/Persistent/binseq-package.lisp Sun Mar 13 21:51:52 2005 @@ -59,4 +59,36 @@ #:obinseq-insert #:obinseq-insert* #:obinseq-remove - #:obinseq-remove*)) \ No newline at end of file + #:obinseq-remove* + + #:binseq2-p + #:list-binseq2 + #:binseq2-list + #:vector-binseq2 + #:binseq2-vector + #:binseq2-empty + #:binseq2-length + #:binseq2-size + #:binseq2-front + #:binseq2-offset + #:binseq2-back + #:binseq2-front2 + #:binseq2-line2 + #:binseq2-back2 + #:binseq2-get + #:binseq2-set + #:binseq2-get2 + #:binseq2-set2 + #:binseq2-sub + #:binseq2-sub2 + #:binseq2-cons + #:binseq2-snoc + #:binseq2-append + #:binseq2-insert + #:binseq2-insert2 + #:binseq2-insert* + #:binseq2-insert*2 + #:binseq2-remove + #:binseq2-remove2 + #:binseq2-remove* + #:binseq2-remove*2)) \ No newline at end of file Index: climacs/Persistent/binseq.lisp diff -u climacs/Persistent/binseq.lisp:1.2 climacs/Persistent/binseq.lisp:1.3 --- climacs/Persistent/binseq.lisp:1.2 Sun Mar 6 00:23:53 2005 +++ climacs/Persistent/binseq.lisp Sun Mar 13 21:51:53 2005 @@ -22,7 +22,7 @@ (in-package :binseq) -(defun binseq-p (s) +(defun binseq-p (s) ; NOTE: should use a 3-vector instead of the 3-list... (or (eq s 'empty) (and (consp s) (or (eq (car s) 'leaf) @@ -160,21 +160,19 @@ (cond ((<= i 0) 'empty) ((<= (binseq-length s) i) s) - (t (cond - ((<= i (binseq-length (caddr s))) (binseq-front (caddr s) i)) - (t (binseq-append - (caddr s) - (binseq-front (cdddr s) (- i (binseq-length (caddr s)))))))))) + ((<= i (binseq-length (caddr s))) (binseq-front (caddr s) i)) + (t (binseq-append + (caddr s) + (binseq-front (cdddr s) (- i (binseq-length (caddr s)))))))) (defun binseq-back (s i) (cond ((<= i 0) 'empty) ((<= (binseq-length s) i) s) - (t (cond - ((<= i (binseq-length (cdddr s))) (binseq-back (cdddr s) i)) - (t (binseq-append - (binseq-back (caddr s) (- i (binseq-length (cdddr s)))) - (cdddr s))))))) + ((<= i (binseq-length (cdddr s))) (binseq-back (cdddr s) i)) + (t (binseq-append + (binseq-back (caddr s) (- i (binseq-length (cdddr s)))) + (cdddr s))))) (defun %has-index (s i) (and (<= 0 i) (< i (binseq-length s)))) Index: climacs/Persistent/obinseq.lisp diff -u climacs/Persistent/obinseq.lisp:1.2 climacs/Persistent/obinseq.lisp:1.3 --- climacs/Persistent/obinseq.lisp:1.2 Sun Mar 6 00:23:54 2005 +++ climacs/Persistent/obinseq.lisp Sun Mar 13 21:51:53 2005 @@ -28,7 +28,7 @@ (or (null s) (atom s) (and (consp s) - (and (integerp (car s)) + (and (integerp (car s)) ; might wanna check the value (consp (cdr s)) (obinseq-p (cadr s)) (obinseq-p (cddr s)))))) @@ -167,21 +167,19 @@ (cond ((<= i 0) nil) ((<= (obinseq-length s) i) s) - (t (cond - ((<= i (obinseq-length (cadr s))) (obinseq-front (cadr s) i)) - (t (obinseq-append - (cadr s) - (obinseq-front (cddr s) (- i (obinseq-length (cadr s)))))))))) + ((<= i (obinseq-length (cadr s))) (obinseq-front (cadr s) i)) + (t (obinseq-append + (cadr s) + (obinseq-front (cddr s) (- i (obinseq-length (cadr s)))))))) (defun obinseq-back (s i) (cond ((<= i 0) nil) ((<= (obinseq-length s) i) s) - (t (cond - ((<= i (obinseq-length (cddr s))) (obinseq-back (cddr s) i)) - (t (obinseq-append - (obinseq-back (cadr s) (- i (obinseq-length (cddr s)))) - (cddr s))))))) + ((<= i (obinseq-length (cddr s))) (obinseq-back (cddr s) i)) + (t (obinseq-append + (obinseq-back (cadr s) (- i (obinseq-length (cddr s)))) + (cddr s))))) (defun %ohas-index (s i) (and (<= 0 i) (< i (obinseq-length s)))) Index: climacs/Persistent/persistent-buffer.lisp diff -u climacs/Persistent/persistent-buffer.lisp:1.9 climacs/Persistent/persistent-buffer.lisp:1.10 --- climacs/Persistent/persistent-buffer.lisp:1.9 Sun Mar 6 00:23:54 2005 +++ climacs/Persistent/persistent-buffer.lisp Sun Mar 13 21:51:53 2005 @@ -36,6 +36,15 @@ (defclass right-sticky-persistent-cursor (persistent-cursor) ()) +(defclass line-cursor-mixin () () + (:documentation "Support for line-oriented buffers.")) + +(defclass left-sticky-line-persistent-cursor + (left-sticky-persistent-cursor line-cursor-mixin) ()) + +(defclass right-sticky-line-persistent-cursor + (right-sticky-persistent-cursor line-cursor-mixin) ()) + (defmethod cursor-pos ((cursor left-sticky-persistent-cursor)) (1+ (slot-value cursor 'pos))) @@ -79,13 +88,19 @@ (defclass binseq-buffer (persistent-buffer) ((contents :initform (list-binseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that -uses a binary sequence for the CONTENTS.")) +uses a binary sequence for the CONTENTS slot.")) (defclass obinseq-buffer (persistent-buffer) ((contents :initform (list-obinseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses an optimized binary sequence (only non-nil atoms are allowed as -elements) for the CONTENTS.")) +elements) for the CONTENTS slot.")) + +(defclass binseq2-buffer (persistent-buffer) + ((contents :initform (list-binseq2 nil))) + (:documentation "An instantiable subclass of PERSISTENT-BUFFER that +uses a binary sequence for lines and optimized binary sequences for +line contents, all kept in the CONTENTS slot.")) (defclass p-mark-mixin () ((buffer :initarg :buffer :reader buffer) @@ -93,6 +108,10 @@ (:documentation "A mixin class used in the initialization of a mark that is used in a PERSISTENT-BUFFER.")) +(defclass p-line-mark-mixin (p-mark-mixin) () + (:documentation "A persistent mark mixin class that works with +cursors that can efficiently work with lines.")) + (defmethod backward-object ((mark p-mark-mixin) &optional (count 1)) (decf (offset mark) count)) @@ -117,6 +136,14 @@ (:documentation "A RIGHT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER.")) +(defclass persistent-left-sticky-line-mark (left-sticky-mark p-line-mark-mixin) () + (:documentation "A LEFT-STICKY-MARK subclass with line support, +suitable for use in a PERSISTENT-BUFFER.")) + +(defclass persistent-right-sticky-line-mark (right-sticky-mark p-line-mark-mixin) () + (:documentation "A RIGHT-STICKY-MARK subclass with line support, +suitable for use in a PERSISTENT-BUFFER.")) + (defmethod initialize-instance :after ((mark persistent-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." @@ -143,7 +170,33 @@ :buffer (buffer mark) :position offset))) -(defmethod initialize-instance :after ((buffer persistent-buffer) &rest args) +(defmethod initialize-instance :after ((mark persistent-left-sticky-line-mark) + &rest args &key (offset 0)) + "Associates a created mark with the buffer for which it was created." + (declare (ignorable args)) + (assert (<= 0 offset) () + (make-condition 'motion-before-beginning :offset offset)) + (assert (<= offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset offset)) + (setf (slot-value mark 'cursor) + (make-instance 'left-sticky-line-persistent-cursor + :buffer (buffer mark) + :position offset))) + +(defmethod initialize-instance :after ((mark persistent-right-sticky-line-mark) + &rest args &key (offset 0)) + "Associates a created mark with the buffer for which it was created." + (declare (ignorable args)) + (assert (<= 0 offset) () + (make-condition 'motion-before-beginning :offset offset)) + (assert (<= offset (size (buffer mark))) () + (make-condition 'motion-after-end :offset offset)) + (setf (slot-value mark 'cursor) + (make-instance 'right-sticky-line-persistent-cursor + :buffer (buffer mark) + :position offset))) + +(defmethod initialize-instance :after ((buffer binseq-buffer) &rest args) "Create the low-mark and high-mark." (declare (ignorable args)) (with-slots (low-mark high-mark) buffer @@ -151,6 +204,23 @@ (setf high-mark (make-instance 'persistent-right-sticky-mark :buffer buffer)))) +(defmethod initialize-instance :after ((buffer obinseq-buffer) &rest args) + "Create the low-mark and high-mark." + (declare (ignorable args)) + (with-slots (low-mark high-mark) buffer + (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer)) + (setf high-mark (make-instance 'persistent-right-sticky-mark + :buffer buffer)))) + +(defmethod initialize-instance :after ((buffer binseq2-buffer) &rest args) + "Create the low-mark and high-mark." + (declare (ignorable args)) + (with-slots (low-mark high-mark) buffer + (setf low-mark + (make-instance 'persistent-left-sticky-line-mark :buffer buffer)) + (setf high-mark + (make-instance 'persistent-right-sticky-line-mark :buffer buffer)))) + (defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) @@ -171,16 +241,49 @@ :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) +(defmethod clone-mark ((mark persistent-left-sticky-line-mark) + &optional stick-to) + (cond + ((or (null stick-to) (eq stick-to :left)) + (make-instance 'persistent-left-sticky-line-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :right) + (make-instance 'persistent-right-sticky-line-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) + +(defmethod clone-mark ((mark persistent-right-sticky-line-mark) + &optional stick-to) + (cond + ((or (null stick-to) (eq stick-to :right)) + (make-instance 'persistent-right-sticky-line-mark + :buffer (buffer mark) :offset (offset mark))) + ((eq stick-to :left) + (make-instance 'persistent-left-sticky-line-mark + :buffer (buffer mark) :offset (offset mark))) + (t (error "invalid value for stick-to")))) + (defmethod size ((buffer binseq-buffer)) (binseq-length (slot-value buffer 'contents))) (defmethod size ((buffer obinseq-buffer)) (obinseq-length (slot-value buffer 'contents))) +(defmethod size ((buffer binseq2-buffer)) + (binseq2-size (slot-value buffer 'contents))) + (defmethod number-of-lines ((buffer persistent-buffer)) (loop for offset from 0 below (size buffer) count (eql (buffer-object buffer offset) #\Newline))) +(defmethod number-of-lines ((buffer binseq2-buffer)) + (let ((len (binseq2-length (slot-value buffer 'contents))) + (size (size buffer))) + (if (or (eql 0 size) + (eq (buffer-object buffer (1- size)) #\Newline)) + len + (max 0 (1- len))))) ; weird? + (defmethod mark< ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (< (offset mark1) (offset mark2))) @@ -255,6 +358,11 @@ (loop until (beginning-of-line-p mark) do (decf (offset mark)))) +(defmethod beginning-of-line ((mark p-line-mark-mixin)) + (setf (offset mark) + (binseq2-offset + (slot-value (buffer mark) 'contents) (line-number mark)))) + (defmethod end-of-line ((mark p-mark-mixin)) (let* ((offset (offset mark)) (buffer (buffer mark)) @@ -264,19 +372,40 @@ do (incf offset)) (setf (offset mark) offset))) +(defmethod end-of-line ((mark p-line-mark-mixin)) + (let* ((curr-offset (offset mark)) + (contents (slot-value (buffer mark) 'contents)) + (next-line-offset (binseq2-offset + contents + (1+ (binseq2-line2 contents curr-offset))))) + (if (> next-line-offset curr-offset) + (setf (offset mark) (1- next-line-offset)) + (setf (offset mark) (size (buffer mark)))))) + (defmethod buffer-line-number ((buffer persistent-buffer) (offset integer)) (loop for i from 0 below offset count (eql (buffer-object buffer i) #\Newline))) +(defmethod buffer-line-number ((buffer binseq2-buffer) (offset integer)) + (binseq2-line2 (slot-value buffer 'contents) offset)) + (defmethod line-number ((mark p-mark-mixin)) (buffer-line-number (buffer mark) (offset mark))) +(defmethod buffer-line-offset ((buffer binseq2-buffer) (line-no integer)) + (binseq2-offset (slot-value buffer 'contents) line-no)) + (defmethod buffer-column-number ((buffer persistent-buffer) (offset integer)) (loop for i downfrom offset while (> i 0) until (eql (buffer-object buffer (1- i)) #\Newline) count t)) +(defmethod buffer-column-number ((buffer binseq2-buffer) (offset integer)) + (- offset + (binseq2-offset + (slot-value buffer 'contents) (buffer-line-number buffer offset)))) + (defmethod column-number ((mark p-mark-mixin)) (buffer-column-number (buffer mark) (offset mark))) @@ -292,24 +421,51 @@ (binseq-insert (slot-value buffer 'contents) offset object))) (defmethod insert-buffer-object ((buffer obinseq-buffer) offset object) - (assert (<= 0 offset (size buffer)) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (obinseq-insert (slot-value buffer 'contents) offset object))) +(defmethod insert-buffer-object ((buffer binseq2-buffer) offset object) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) + (setf (slot-value buffer 'contents) + (binseq2-insert2 (slot-value buffer 'contents) offset object))) + (defmethod insert-object ((mark p-mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) (defmethod insert-buffer-sequence ((buffer binseq-buffer) offset sequence) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (let ((binseq (vector-binseq sequence))) (setf (slot-value buffer 'contents) (binseq-insert* (slot-value buffer 'contents) offset binseq)))) (defmethod insert-buffer-sequence ((buffer obinseq-buffer) offset sequence) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (let ((obinseq (vector-obinseq sequence))) (setf (slot-value buffer 'contents) (obinseq-insert* (slot-value buffer 'contents) offset obinseq)))) +(defmethod insert-buffer-sequence ((buffer binseq2-buffer) offset sequence) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) + (let ((binseq2 (vector-binseq2 sequence))) + (setf (slot-value buffer 'contents) + (binseq2-insert*2 (slot-value buffer 'contents) offset binseq2)))) + (defmethod insert-sequence ((mark p-mark-mixin) sequence) (insert-buffer-sequence (buffer mark) (offset mark) sequence)) @@ -322,11 +478,21 @@ (binseq-remove* (slot-value buffer 'contents) offset n))) (defmethod delete-buffer-range ((buffer obinseq-buffer) offset n) - (assert (<= 0 offset (size buffer)) () - (make-condition 'no-such-offset :offset offset)) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) (setf (slot-value buffer 'contents) (obinseq-remove* (slot-value buffer 'contents) offset n))) +(defmethod delete-buffer-range ((buffer binseq2-buffer) offset n) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (size buffer)) () + (make-condition 'offset-after-end :offset offset)) + (setf (slot-value buffer 'contents) + (binseq2-remove*2 (slot-value buffer 'contents) offset n))) + (defmethod delete-range ((mark p-mark-mixin) &optional (n 1)) (cond ((plusp n) (delete-buffer-range (buffer mark) (offset mark) n)) @@ -383,6 +549,21 @@ (setf (slot-value buffer 'contents) (obinseq-set (slot-value buffer 'contents) offset object))) +(defmethod buffer-object ((buffer binseq2-buffer) offset) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) + (binseq2-get2 (slot-value buffer 'contents) offset)) + +(defmethod (setf buffer-object) (object (buffer binseq2-buffer) offset) + (assert (<= 0 offset) () + (make-condition 'offset-before-beginning :offset offset)) + (assert (<= offset (1- (size buffer))) () + (make-condition 'offset-after-end :offset offset)) + (setf (slot-value buffer 'contents) + (binseq2-set2 (slot-value buffer 'contents) offset object))) + (defmethod buffer-sequence ((buffer binseq-buffer) offset1 offset2) (assert (<= 0 offset1) () (make-condition 'offset-before-beginning :offset offset1)) @@ -411,6 +592,21 @@ (if (> len 0) (obinseq-vector (obinseq-sub (slot-value buffer 'contents) offset1 len)) + (make-array 0)))) + +(defmethod buffer-sequence ((buffer binseq2-buffer) offset1 offset2) + (assert (<= 0 offset1) () + (make-condition 'offset-before-beginning :offset offset1)) + (assert (<= offset1 (size buffer)) () + (make-condition 'offset-after-end :offset offset1)) + (assert (<= 0 offset2) () + (make-condition 'offset-before-beginning :offset offset2)) + (assert (<= offset2 (size buffer)) () + (make-condition 'offset-after-end :offset offset2)) + (let ((len (- offset2 offset1))) + (if (> len 0) + (binseq2-vector + (binseq2-sub2 (slot-value buffer 'contents) offset1 len)) (make-array 0)))) (defmethod object-before ((mark p-mark-mixin))

1 0

[climacs-cvs] CVS update: climacs/TODO climacs/base-test.lisp climacs/base.lisp climacs/buffer-test.lisp climacs/cl-syntax.lisp climacs/climacs.asd climacs/html-syntax.lisp climacs/packages.lisp climacs/pane.lisp climacs/text-syntax.lisp
by abakic＠common-lisp.net 13 Mar '05

13 Mar '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv22428 Modified Files: TODO base-test.lisp base.lisp buffer-test.lisp cl-syntax.lisp climacs.asd html-syntax.lisp packages.lisp pane.lisp text-syntax.lisp Log Message: Line-oriented persistent buffer (binseq2). Warning: Need to fix minor bugs (related to number-of-lines-in-region, I believe). base.lisp: Added faster methods on previous-line, next-line, buffer-number-of-lines-in-region. pane.lisp, cl-syntax.lisp, html-syntax.lisp, text-syntax.lisp: Replaced some calls to make-instance to calls to clone-mark and (setf offset), in order to avoid passing climacs-buffer to marks. This also made possible to get rid of delegating methods on syntax. climacs.asd: Added Persistent/binseq2. packages.lisp: Added binseq2-related symbols. Persistent/binseq.lisp, Persistent/obinseq.lisp: Cleanup. Persistent/persistent-buffer.lisp: Added code for binseq2-buffer and related marks. Also some minor fixes. Date: Sun Mar 13 21:51:48 2005 Author: abakic Index: climacs/TODO diff -u climacs/TODO:1.5 climacs/TODO:1.6 --- climacs/TODO:1.5 Sun Feb 20 06:39:15 2005 +++ climacs/TODO Sun Mar 13 21:51:48 2005 @@ -1,8 +1,6 @@ - modify standard-buffer to use obinseq with leafs containing flexichain-based lines -- implement a persistent buffer as a binseq of obinseqs (or similar, - one sequence type for lines, the other for line contents), then - upgrade it to an undoable buffer +- upgrade persistent buffer based on binseq2 to an undoable buffer - replace the use of the scroller pane by custom pane Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.12 climacs/base-test.lisp:1.13 --- climacs/base-test.lisp:1.12 Sun Feb 27 19:52:00 2005 +++ climacs/base-test.lisp Sun Mar 13 21:51:48 2005 @@ -350,16 +350,18 @@ (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") + (print (climacs-buffer::buffer-line-number buffer 15)) (values (climacs-base::buffer-number-of-lines-in-region buffer 0 6) (climacs-base::buffer-number-of-lines-in-region buffer 0 7) + (climacs-base::buffer-number-of-lines-in-region buffer 0 8) (climacs-base::buffer-number-of-lines-in-region buffer 0 10) (climacs-base::buffer-number-of-lines-in-region buffer 0 13) (climacs-base::buffer-number-of-lines-in-region buffer 0 14) (climacs-base::buffer-number-of-lines-in-region buffer 7 10) (climacs-base::buffer-number-of-lines-in-region buffer 8 13) (climacs-base::buffer-number-of-lines-in-region buffer 8 14))) - 0 0 1 1 1 1 0 0) + 0 0 1 1 1 1 1 0 0) (defmultitest buffer-display-column.test-1 (let ((buffer (make-instance %%buffer))) Index: climacs/base.lisp diff -u climacs/base.lisp:1.37 climacs/base.lisp:1.38 --- climacs/base.lisp:1.37 Sat Feb 19 07:19:06 2005 +++ climacs/base.lisp Sun Mar 13 21:51:48 2005 @@ -36,13 +36,13 @@ &body body) "Iterate over the elements of the region delimited by offset1 and offset2. The body is executed for each element, with object being the current object -(setf-able), and offset being its offset." +\(setf-able), and offset being its offset." `(symbol-macrolet ((,object (buffer-object ,buffer ,offset))) (loop for ,offset from ,offset1 below ,offset2 do ,@body))) -(defun previous-line (mark &optional column (count 1)) - "Move a mark up one line conserving horizontal position." +(defmethod previous-line (mark &optional column (count 1)) + "Move a mark up COUNT lines conserving horizontal position." (unless column (setf column (column-number mark))) (loop repeat count @@ -54,8 +54,17 @@ (beginning-of-line mark) (incf (offset mark) column))) -(defun next-line (mark &optional column (count 1)) - "Move a mark down one line conserving horizontal position." +(defmethod previous-line ((mark p-line-mark-mixin) &optional column (count 1)) + "Move a mark up COUNT lines conserving horizontal position." + (unless column + (setf column (column-number mark))) + (let* ((line (line-number mark)) + (goto-line (max 0 (- line count)))) + (setf (offset mark) + (+ column (buffer-line-offset (buffer mark) goto-line))))) + +(defmethod next-line (mark &optional column (count 1)) + "Move a mark down COUNT lines conserving horizontal position." (unless column (setf column (column-number mark))) (loop repeat count @@ -67,16 +76,26 @@ (beginning-of-line mark) (incf (offset mark) column))) +(defmethod next-line ((mark p-line-mark-mixin) &optional column (count 1)) + "Move a mark down COUNT lines conserving horizontal position." + (unless column + (setf column (column-number mark))) + (let* ((line (line-number mark)) + (goto-line (min (number-of-lines (buffer mark)) + (+ line count)))) + (setf (offset mark) + (+ column (buffer-line-offset (buffer mark) goto-line))))) + (defmethod open-line ((mark left-sticky-mark) &optional (count 1)) "Create a new line in a buffer after the mark." (loop repeat count - do (insert-object mark #\Newline))) + do (insert-object mark #\Newline))) (defmethod open-line ((mark right-sticky-mark) &optional (count 1)) "Create a new line in a buffer after the mark." (loop repeat count - do (insert-object mark #\Newline) - (decf (offset mark)))) + do (insert-object mark #\Newline) + (decf (offset mark)))) (defun kill-line (mark) "Remove a line from a buffer." @@ -105,13 +124,19 @@ (incf (offset mark2)) finally (return indentation)))) -(defun buffer-number-of-lines-in-region (buffer offset1 offset2) - "Helper function for number-of-lines-in-region. Count newline -characters in the region between offset1 and offset2" +(defmethod buffer-number-of-lines-in-region (buffer offset1 offset2) + "Helper method for number-of-lines-in-region. Count newline +characters in the region between offset1 and offset2." (loop while (< offset1 offset2) count (eql (buffer-object buffer offset1) #\Newline) do (incf offset1))) +(defmethod buffer-number-of-lines-in-region + ((buffer binseq2-buffer) offset1 offset2) + "Helper method for NUMBER-OF-LINES-IN-REGION." + (- (buffer-line-number buffer offset2) + (buffer-line-number buffer offset1))) + (defun buffer-display-column (buffer offset tab-width) (let ((line-start-offset (- offset (buffer-column-number buffer offset)))) (loop with column = 0 @@ -578,7 +603,7 @@ (loop for i downfrom (- offset (length vector)) to 0 when (buffer-looking-at buffer i vector :test test) return i - finally (return nil))) + finally (return nil))) (defun search-forward (mark vector &key (test #'eql)) "move MARK forward after the first occurence of VECTOR after MARK" Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.18 climacs/buffer-test.lisp:1.19 --- climacs/buffer-test.lisp:1.18 Sun Feb 27 19:52:01 2005 +++ climacs/buffer-test.lisp Sun Mar 13 21:51:48 2005 @@ -48,6 +48,13 @@ ''persistent-right-sticky-mark (intern (concatenate 'string "OBINSEQ-BUFFER-" name-string)) form + results) + ,(%deftest-wrapper + ''binseq2-buffer + ''persistent-left-sticky-line-mark + ''persistent-right-sticky-line-mark + (intern (concatenate 'string "BINSEQ2-BUFFER-" name-string)) + form results))))) (defmultitest buffer-make-instance.test-1 @@ -966,3 +973,76 @@ do (insert-buffer-sequence b (floor (size b) 2) "abcdefghij") finally (return (size b)))) 1000000) + +(defmultitest performance.test-4 + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) + (let ((m (clone-mark (low-mark b)))) + (loop + for i from 0 below 1000 + for f = t then (not b) + do (if f + (end-of-line m) + (beginning-of-line m)))))) + nil) + +(defmultitest performance.test-4b + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-object b 0 #\Newline) + (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) + (insert-buffer-object b 0 #\Newline) + (let ((m (clone-mark (low-mark b)))) + (loop + for i from 0 below 1000 + for f = t then (not b) + do (if f + (end-of-line m) + (beginning-of-line m)))))) + nil) + +(defmultitest performance.test-4c + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-object b 0 #\Newline) + (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) + (insert-buffer-object b 0 #\Newline) + (let ((m (clone-mark (low-mark b)))) + (incf (offset m)) + (loop + for i from 0 below 1000 + for f = t then (not b) + do (if f + (end-of-line m) + (beginning-of-line m)))))) + nil) + +(defmultitest performance.test-4d + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-object b 0 #\Newline) + (insert-buffer-sequence b 0 (make-array '(100000) :initial-element #\a)) + (insert-buffer-object b 0 #\Newline) + (let ((m (clone-mark (low-mark b)))) + (setf (offset m) (floor (size b) 2)) + (loop + for i from 0 below 10 + collect (list (line-number m) (column-number m)))))) + ((1 50000) (1 50000) (1 50000) (1 50000) (1 50000) (1 50000) + (1 50000) (1 50000) (1 50000) (1 50000))) + +(defmultitest performance.test-4e + (time + (let ((b (make-instance %%buffer))) + (insert-buffer-sequence + b 0 (make-array '(100000) :initial-element #\Newline)) + (let ((m (clone-mark (low-mark b)))) + (loop + for i from 0 below 1000 + for f = t then (not b) + do (if f + (next-line m 0 100000) + (previous-line m 0 100000)) + finally (return (number-of-lines b)))))) + 100000) \ No newline at end of file Index: climacs/cl-syntax.lisp diff -u climacs/cl-syntax.lisp:1.5 climacs/cl-syntax.lisp:1.6 --- climacs/cl-syntax.lisp:1.5 Wed Mar 2 04:59:03 2005 +++ climacs/cl-syntax.lisp Sun Mar 13 21:51:48 2005 @@ -166,9 +166,8 @@ (defmethod initialize-instance :after ((syntax cl-syntax) &rest args) (declare (ignore args)) (with-slots (buffer elements) syntax - (let ((mark (make-instance 'standard-left-sticky-mark - :buffer buffer - :offset 0))) + (let ((mark (clone-mark (low-mark buffer) :left))) + (setf (offset mark) 0) (insert* elements 0 (make-instance 'start-entry :start-mark mark :size 0))))) @@ -257,11 +256,12 @@ (loop until (or (= guess-pos (nb-elements elements)) (mark> (start-mark (element* elements guess-pos)) high-mark)) do (delete* elements guess-pos)) - (setf scan (make-instance 'standard-left-sticky-mark - :buffer buffer - :offset (if (zerop guess-pos) - 0 - (end-offset (element* elements (1- guess-pos)))))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) + (if (zerop guess-pos) + 0 + (end-offset (element* elements (1- guess-pos))))) + (setf scan m)) ;; scan (loop with start-mark = nil do (loop until (end-of-buffer-p scan) Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.23 climacs/climacs.asd:1.24 --- climacs/climacs.asd:1.23 Fri Mar 11 11:23:33 2005 +++ climacs/climacs.asd Sun Mar 13 21:51:48 2005 @@ -46,6 +46,7 @@ "Persistent/binseq-package" "Persistent/binseq" "Persistent/obinseq" + "Persistent/binseq2" "translate" "packages" "buffer" Index: climacs/html-syntax.lisp diff -u climacs/html-syntax.lisp:1.11 climacs/html-syntax.lisp:1.12 --- climacs/html-syntax.lisp:1.11 Sun Mar 13 07:55:27 2005 +++ climacs/html-syntax.lisp Sun Mar 13 21:51:48 2005 @@ -276,12 +276,12 @@ (setf parser (make-instance 'parser :grammar *html-grammar* :target 'html)) - (insert* lexemes 0 (make-instance 'start-element - :start-mark (make-instance 'standard-left-sticky-mark - :buffer buffer - :offset 0) - :size 0 - :state (initial-state parser))))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) 0) + (insert* lexemes 0 (make-instance 'start-element + :start-mark m + :size 0 + :state (initial-state parser)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -325,9 +325,10 @@ do (forward-object scan))) (defun update-lex (lexemes start-pos end) - (let ((scan (make-instance 'standard-left-sticky-mark - :buffer (buffer end) ; FIXME, eventually use the buffer of the lexer - :offset (end-offset (element* lexemes (1- start-pos)))))) + (let ((scan (clone-mark (low-mark (buffer end)) :left))) + ;; FIXME, eventually use the buffer of the lexer + (setf (offset scan) + (end-offset (element* lexemes (1- start-pos)))) (loop do (skip-inter-lexeme-objects lexemes scan) until (if (end-of-buffer-p end) (end-of-buffer-p scan) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.55 climacs/packages.lisp:1.56 --- climacs/packages.lisp:1.55 Thu Mar 10 07:37:40 2005 +++ climacs/packages.lisp Sun Mar 13 21:51:48 2005 @@ -47,8 +47,10 @@ #:object-before #:object-after #:region-to-sequence #:low-mark #:high-mark #:modified-p #:clear-modify - #:binseq-buffer #:obinseq-buffer + #:binseq-buffer #:obinseq-buffer #:binseq2-buffer #:persistent-left-sticky-mark #:persistent-right-sticky-mark + #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark + #:p-line-mark-mixin #:buffer-line-offset #:delegating-buffer #:implementation)) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.20 climacs/pane.lisp:1.21 --- climacs/pane.lisp:1.20 Sat Mar 5 08:03:53 2005 +++ climacs/pane.lisp Sun Mar 13 21:51:48 2005 @@ -182,20 +182,10 @@ ;(defgeneric indent-tabs-mode (climacs-buffer)) -;;; 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) () +(defclass extended-binseq2-buffer (binseq2-buffer undo-mixin abbrev-mixin) () (:documentation "Extensions accessible via marks.")) (defclass climacs-buffer (delegating-buffer filename-mixin name-mixin) Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.5 climacs/text-syntax.lisp:1.6 --- climacs/text-syntax.lisp:1.5 Tue Jan 18 00:10:24 2005 +++ climacs/text-syntax.lisp Sun Mar 13 21:51:48 2005 @@ -80,9 +80,9 @@ (and (eql (buffer-object buffer (1- offset)) #\Newline) (or (= offset 1) (eql (buffer-object buffer (- offset 2)) #\Newline))))) - (insert* paragraphs pos1 - (make-instance 'standard-left-sticky-mark - :buffer buffer :offset offset)) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) offset) + (insert* paragraphs pos1 m)) (incf pos1)) ((and (plusp offset) (not (eql (buffer-object buffer (1- offset)) #\Newline)) @@ -90,9 +90,9 @@ (and (eql (buffer-object buffer offset) #\Newline) (or (= offset (1- buffer-size)) (eql (buffer-object buffer (1+ offset)) #\Newline))))) - (insert* paragraphs pos1 - (make-instance 'standard-right-sticky-mark - :buffer buffer :offset offset)) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) offset) + (insert* paragraphs pos1 m)) (incf pos1)) (t nil)))))))

1 0