From rstrandh at common-lisp.net Tue Mar 1 04:56:27 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 1 Mar 2005 05:56:27 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/climacs.asd
Message-ID: <20050301045627.9C4A288665@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv24900
Modified Files:
climacs.asd
Log Message:
Added section on incremental parsing.
Date: Tue Mar 1 05:56:09 2005
Author: rstrandh
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.20 climacs/climacs.asd:1.21
--- climacs/climacs.asd:1.20 Sun Feb 27 19:52:01 2005
+++ climacs/climacs.asd Tue Mar 1 05:56:06 2005
@@ -42,13 +42,7 @@
:defaults *climacs-directory*))
collect `(:file ,(pathname-name p) :pathname ,p))))))
-(climacs-defsystem (:climacs :depends-on (:clim-clx))
- "Flexichain/skiplist-package"
- "Flexichain/skiplist"
- "Flexichain/flexichain-package"
- "Flexichain/utilities"
- "Flexichain/flexichain"
- "Flexichain/flexicursor"
+(climacs-defsystem (:climacs :depends-on (:clim-clx :flexichain))
"Persistent/binseq-package"
"Persistent/binseq"
"Persistent/obinseq"
From rstrandh at common-lisp.net Tue Mar 1 04:56:37 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 1 Mar 2005 05:56:37 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
Message-ID: <20050301045637.1383088665@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Doc
In directory common-lisp.net:/tmp/cvs-serv24900/Doc
Modified Files:
climacs-internals.texi
Log Message:
Added section on incremental parsing.
Date: Tue Mar 1 05:56:29 2005
Author: rstrandh
Index: climacs/Doc/climacs-internals.texi
diff -u climacs/Doc/climacs-internals.texi:1.14 climacs/Doc/climacs-internals.texi:1.15
--- climacs/Doc/climacs-internals.texi:1.14 Sun Feb 27 20:13:47 2005
+++ climacs/Doc/climacs-internals.texi Tue Mar 1 05:56:27 2005
@@ -716,6 +716,91 @@
present, and it should be exploitable by several, potentially totally
different, display units.
+ at section Incremental parsing framework
+
+ at subsection Earley parser
+
+Climacs contains an incremental parser that uses the Earley
+algorithm. This algorithm accepts the full set of context-free
+grammars, allowing greater freedom for the developer to define natural
+grammars without having to think about restrictions such as LL(k) or
+LALR(k).
+
+Beware, though, that the Earley algorithm can be quite inefficient if
+the grammar is sufficiently complicated, in particular if the grammar
+is ambiguous.
+
+ at subsection Specifying a grammar
+
+An incremental parser is created from a grammar.
+
+ at deffn {Macro} {grammar} &body rules
+
+Create a grammar object from a set of rules
+ at end deffn
+
+ at deffn {Rule} {} symbol -> (&rest arguments) &optional body
+
+Each rule is a list of this form.
+ at end deffn
+
+ at noindent
+Here @var{symbol} is the target symbol of the rule, and should be the name of
+a CLOS class.
+
+ at deffn {Rule argument} {} (var type test)
+
+The most general form of a rule argument.
+ at end deffn
+
+ at noindent
+Here @var{var} is the name of a lexical variable. The scope of the
+variable contains the test, all the following arguments and the body
+of the rule. The @var{type} is a Common Lisp type specification. The
+rule applies only of the @var{type} of the object contain in var is of
+that type. The @var{test} contains arbitrary Common Lisp code for
+additional checks as to the applicability of the rule.
+
+ at deffn {Rule argument} {} (var type)
+
+Abbreviated form of a rule argument.
+ at end deffn
+
+ at noindent
+Here, @var{type} must be a symbol typically the name of a CLOS class.
+This form is an abbreviation for @code{(@var{var} @var{type} t)}.
+
+ at deffn {Rule argument} {} (var test)
+
+Abbreviated form of a rule argument.
+ at end deffn
+
+ at noindent
+Here, @var{test} must not be a symbol. This form is an abbreviation
+of @code{(@var{var} @var{var} @var{test})}, i.e., the name of the
+variable is also the name of a type, typically a CLOS class.
+
+ at deffn {Rule argument} {} var
+
+Abbreviated form of a rule argument.
+ at end deffn
+
+ at noindent
+This form is an abbreviation of @code{(@var{var} @var{var} t)}.
+
+The @var{body} of a rule, if present, contains an expression that should
+have an instance (not necessarily direct) of the class named by the
+symbol (the left-hand-side) of the rule. It is important that this
+restriction be respected, since the Earley algorithm will not work
+otherwise.
+
+If the @var{body} is absent, it is the same as if a body of the form
+ at code{(make-instance '@var{symbol})} had been given.
+
+The body can also be a sequence of forms, the first one of which
+must be a symbol. These forms typically contain initargs, and will be
+passed as additional arguments to @code{(make-instance '@var{symbol})}.
+
@section Common Lisp syntax
Technically, comments and such are not expressions, but it is OK for
From rstrandh at common-lisp.net Wed Mar 2 03:59:09 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 2 Mar 2005 04:59:09 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/cl-syntax.lisp
Message-ID: <20050302035909.81B778866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv3501
Modified Files:
cl-syntax.lisp
Log Message:
Whitespace is no longer considered a syntax element, and is skipped
over instead. This makes the incremental lexer even faster.
Date: Wed Mar 2 04:59:07 2005
Author: rstrandh
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.4 climacs/cl-syntax.lisp:1.5
--- climacs/cl-syntax.lisp:1.4 Sun Feb 27 07:23:28 2005
+++ climacs/cl-syntax.lisp Wed Mar 2 04:59:03 2005
@@ -48,9 +48,6 @@
()
(:documentation "dummy entry before all the others."))
-(defclass whitespace-entry (terminal-entry)
- ())
-
(defclass token-entry (terminal-entry)
()
(:documentation "the syntactic class of tokens."))
@@ -233,12 +230,7 @@
do (fo))
(make-entry 'character-entry))))
(t (make-entry 'error-entry)))))
- (t (cond ((whitespacep object)
- (loop until (end-of-buffer-p scan)
- while (whitespacep (object-after scan))
- do (fo))
- (make-entry 'whitespace-entry))
- ((constituentp object)
+ (t (cond ((constituentp object)
(loop until (end-of-buffer-p scan)
while (constituentp (object-after scan))
do (fo))
@@ -271,11 +263,13 @@
0
(end-offset (element* elements (1- guess-pos))))))
;; scan
- (unless (end-of-buffer-p scan)
- (loop with start-mark = nil
- 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* elements guess-pos (next-entry scan))
- (incf guess-pos)))))))
+ (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* elements guess-pos (next-entry scan))
+ (incf guess-pos))))))
From rstrandh at common-lisp.net Wed Mar 2 04:07:27 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 2 Mar 2005 05:07:27 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/syntax.lisp
Message-ID: <20050302040727.36D178866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv4425
Modified Files:
syntax.lisp
Log Message:
An incomplete item now stores its state of origin. The chain of
states of origin will define a "parse stack" that can be exploited by
syntax modules and display code.
Date: Wed Mar 2 05:07:26 2005
Author: rstrandh
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.30 climacs/syntax.lisp:1.31
--- climacs/syntax.lisp:1.30 Sat Feb 5 07:49:53 2005
+++ climacs/syntax.lisp Wed Mar 2 05:07:26 2005
@@ -143,7 +143,8 @@
(defclass rule-item () ())
(defclass incomplete-item (rule-item)
- ((rule :initarg :rule :reader rule)
+ ((orig-state :initarg :orig-state :reader orig-state)
+ (rule :initarg :rule :reader rule)
(dot-position :initarg :dot-position :reader dot-position)
(parse-trees :initarg :parse-trees :reader parse-trees)
(suffix :initarg :suffix :reader suffix)))
@@ -171,6 +172,7 @@
nil)
((functionp remaining)
(make-instance 'incomplete-item
+ :orig-state (orig-state prev-item)
:rule (rule prev-item)
:dot-position (1+ (dot-position prev-item))
:parse-trees (cons parse-tree (parse-trees prev-item))
@@ -249,6 +251,7 @@
(or (subtypep sym1 sym2) (subtypep sym2 sym1)))
(handle-item (if (functionp (right-hand-side rule))
(make-instance 'incomplete-item
+ :orig-state to-state
:rule rule
:dot-position 0
:parse-trees '()
@@ -273,6 +276,7 @@
(subtypep sym (target parser))))
(handle-item (if (functionp (right-hand-side rule))
(make-instance 'incomplete-item
+ :orig-state initial-state
:rule rule
:dot-position 0
:parse-trees '()
From rstrandh at common-lisp.net Wed Mar 2 05:21:08 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 2 Mar 2005 06:21:08 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/syntax.lisp
Message-ID: <20050302052108.EBDB08866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv8925
Modified Files:
syntax.lisp
Log Message:
A parser state now stores its parser instead of just the grammar of
the parser so that we can get to the initial state and the target of
the parser from a given state.
Added functions for analysing parse stack.
Date: Wed Mar 2 06:21:08 2005
Author: rstrandh
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.31 climacs/syntax.lisp:1.32
--- climacs/syntax.lisp:1.31 Wed Mar 2 05:07:26 2005
+++ climacs/syntax.lisp Wed Mar 2 06:21:07 2005
@@ -135,10 +135,9 @@
;;; parser
(defclass parser ()
- ((grammar :initarg :grammar)
+ ((grammar :initarg :grammar :reader parser-grammar)
(target :initarg :target :reader target)
- (initial-state :reader initial-state)
- (lexer :initarg :lexer)))
+ (initial-state :reader initial-state)))
(defclass rule-item () ())
@@ -202,7 +201,7 @@
nil)
(defclass parser-state ()
- ((grammar :initarg :grammar :reader state-grammar)
+ ((parser :initarg :parser :reader parser)
(incomplete-items :initform (make-hash-table :test #'eq)
:reader incomplete-items)
(parse-trees :initform (make-hash-table :test #'eq)
@@ -245,7 +244,7 @@
nil)
(t
(push item (gethash orig-state (incomplete-items to-state)))
- (loop for rule in (rules (state-grammar to-state))
+ (loop for rule in (rules (parser-grammar (parser to-state)))
do (when (let ((sym1 (aref (symbols (rule item)) (dot-position item)))
(sym2 (left-hand-side rule)))
(or (subtypep sym1 sym2) (subtypep sym2 sym1)))
@@ -269,7 +268,7 @@
(defmethod initialize-instance :after ((parser parser) &rest args)
(declare (ignore args))
(with-slots (grammar initial-state) parser
- (setf initial-state (make-instance 'parser-state :grammar grammar))
+ (setf initial-state (make-instance 'parser-state :parser parser))
(loop for rule in (rules grammar)
do (when (let ((sym (left-hand-side rule)))
(or (subtypep (target parser) sym)
@@ -286,12 +285,44 @@
initial-state initial-state)))))
(defun advance-parse (parser tokens state)
- (with-slots (grammar) parser
- (let ((new-state (make-instance 'parser-state :grammar grammar)))
- (loop for token in tokens
- do (potentially-handle-parse-tree token state new-state))
- new-state)))
-
-(defclass lexer () ())
-
-(defgeneric lex (lexer))
+ (let ((new-state (make-instance 'parser-state :parser parser)))
+ (loop for token in tokens
+ do (potentially-handle-parse-tree token state new-state))
+ new-state))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Code for analysing parse stack
+
+(defun parse-stack-top (state)
+ "given a parse state, return a list of all incomplete items that did
+not originate in that state, or if no such items exist, a list of all
+parse trees of state that originated in the initial state."
+ (let ((items '()))
+ (map-over-incomplete-items
+ state
+ (lambda (key item)
+ (unless (eq key state)
+ (push item items))))
+ (unless items
+ (loop with target = (target (parser state))
+ for parse-tree in (gethash (initial-state (parser state))
+ (parse-trees state))
+ when (subtypep parse-tree target)
+ do (push parse-tree items)))
+ items))
+
+(defun parse-stack-next (incomplete-item)
+ "given an incomplete item, return a list of all incomplete items it
+could have been predicted from."
+ (let ((items '())
+ (orig-state (orig-state incomplete-item))
+ (sym1 (left-hand-side (rule incomplete-item))))
+ (map-over-incomplete-items
+ orig-state
+ (lambda (key item)
+ (unless (eq key orig-state)
+ (when (let ((sym2 (aref (symbols (rule item)) (dot-position item))))
+ (or (subtypep sym1 sym2) (subtypep sym2 sym1)))
+ (push item items)))))
+ items))
From rstrandh at common-lisp.net Fri Mar 4 07:17:45 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Fri, 4 Mar 2005 08:17:45 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/syntax.lisp
Message-ID: <20050304071745.068EF8866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv18478
Modified Files:
html-syntax.lisp syntax.lisp
Log Message:
Intoduced a function `map-over-parse-trees' that syntax modules can
use to traverse the parse tree. This function traverses but one of
the paths through the parser data structure. In general, there can be
an exponential number of such paths, but we assume anyone will do as
far as buffer syntax is concerned.
Date: Fri Mar 4 08:17:44 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.4 climacs/html-syntax.lisp:1.5
--- climacs/html-syntax.lisp:1.4 Mon Feb 28 09:51:34 2005
+++ climacs/html-syntax.lisp Fri Mar 4 08:17:44 2005
@@ -223,7 +223,7 @@
(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)
+ 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)
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.32 climacs/syntax.lisp:1.33
--- climacs/syntax.lisp:1.32 Wed Mar 2 06:21:07 2005
+++ climacs/syntax.lisp Fri Mar 4 08:17:44 2005
@@ -143,6 +143,7 @@
(defclass incomplete-item (rule-item)
((orig-state :initarg :orig-state :reader orig-state)
+ (predicted-from :initarg :predicted-from :reader predicted-from)
(rule :initarg :rule :reader rule)
(dot-position :initarg :dot-position :reader dot-position)
(parse-trees :initarg :parse-trees :reader parse-trees)
@@ -172,6 +173,7 @@
((functionp remaining)
(make-instance 'incomplete-item
:orig-state (orig-state prev-item)
+ :predicted-from (predicted-from prev-item)
:rule (rule prev-item)
:dot-position (1+ (dot-position prev-item))
:parse-trees (cons parse-tree (parse-trees prev-item))
@@ -205,7 +207,8 @@
(incomplete-items :initform (make-hash-table :test #'eq)
:reader incomplete-items)
(parse-trees :initform (make-hash-table :test #'eq)
- :reader parse-trees)))
+ :reader parse-trees)
+ (last-nonempty-state :initarg :last-nonempty-state :accessor last-nonempty-state)))
(defun map-over-incomplete-items (state fun)
(maphash (lambda (key incomplete-items)
@@ -251,6 +254,7 @@
(handle-item (if (functionp (right-hand-side rule))
(make-instance 'incomplete-item
:orig-state to-state
+ :predicted-from item
:rule rule
:dot-position 0
:parse-trees '()
@@ -269,6 +273,7 @@
(declare (ignore args))
(with-slots (grammar initial-state) parser
(setf initial-state (make-instance 'parser-state :parser parser))
+ (setf (last-nonempty-state initial-state) initial-state)
(loop for rule in (rules grammar)
do (when (let ((sym (left-hand-side rule)))
(or (subtypep (target parser) sym)
@@ -276,6 +281,7 @@
(handle-item (if (functionp (right-hand-side rule))
(make-instance 'incomplete-item
:orig-state initial-state
+ :predicted-from nil
:rule rule
:dot-position 0
:parse-trees '()
@@ -284,45 +290,39 @@
:parse-tree (right-hand-side rule)))
initial-state initial-state)))))
+(defun state-contains-target-p (state)
+ (loop with target = (target (parser state))
+ for parse-tree in (gethash (initial-state (parser state))
+ (parse-trees state))
+ when (typep parse-tree target)
+ do (return parse-tree)))
+
(defun advance-parse (parser tokens state)
(let ((new-state (make-instance 'parser-state :parser parser)))
(loop for token in tokens
do (potentially-handle-parse-tree token state new-state))
+ (setf (last-nonempty-state new-state)
+ (if (or (plusp (hash-table-count (incomplete-items new-state)))
+ (state-contains-target-p new-state))
+ new-state
+ (last-nonempty-state state)))
new-state))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Code for analysing parse stack
-(defun parse-stack-top (state)
- "given a parse state, return a list of all incomplete items that did
-not originate in that state, or if no such items exist, a list of all
-parse trees of state that originated in the initial state."
- (let ((items '()))
- (map-over-incomplete-items
- state
- (lambda (key item)
- (unless (eq key state)
- (push item items))))
- (unless items
- (loop with target = (target (parser state))
- for parse-tree in (gethash (initial-state (parser state))
- (parse-trees state))
- when (subtypep parse-tree target)
- do (push parse-tree items)))
- items))
-
-(defun parse-stack-next (incomplete-item)
- "given an incomplete item, return a list of all incomplete items it
-could have been predicted from."
- (let ((items '())
- (orig-state (orig-state incomplete-item))
- (sym1 (left-hand-side (rule incomplete-item))))
- (map-over-incomplete-items
- orig-state
- (lambda (key item)
- (unless (eq key orig-state)
- (when (let ((sym2 (aref (symbols (rule item)) (dot-position item))))
- (or (subtypep sym1 sym2) (subtypep sym2 sym1)))
- (push item items)))))
- items))
+(defun map-over-parse-trees (function state)
+ (labels ((map-incomplete-item (item)
+ (unless (null (predicted-from item))
+ (map-incomplete-item (predicted-from item)))
+ (loop for parse-tree in (reverse (parse-trees item))
+ do (funcall function parse-tree))))
+ (let ((state (last-nonempty-state state)))
+ (if (plusp (hash-table-count (incomplete-items state)))
+ (maphash (lambda (state items)
+ (declare (ignore state))
+ (map-incomplete-item (car items))
+ (return-from map-over-parse-trees nil))
+ (incomplete-items state))
+ (funcall function (state-contains-target-p state))))))
From rstrandh at common-lisp.net Sat Mar 5 07:03:55 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 5 Mar 2005 08:03:55 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/html-syntax.lisp
climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp
Message-ID: <20050305070355.CDE7488678@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv3124
Modified Files:
gui.lisp html-syntax.lisp packages.lisp pane.lisp syntax.lisp
Log Message:
Split off the climacs-html-syntax package from the climacs-syntax
package. Exported some more symbols from the climacs-syntax package.
Implemented a few more functions in the climacs-syntax package that
can be used to travarse the parse stack.
The redisplay-pane function now calls a generic function
redisplay-pane-with-syntax that also takes a syntax object as argument.
Date: Sat Mar 5 08:03:53 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.126 climacs/gui.lisp:1.127
--- climacs/gui.lisp:1.126 Mon Feb 28 09:51:33 2005
+++ climacs/gui.lisp Sat Mar 5 08:03:52 2005
@@ -146,7 +146,7 @@
(defun display-win (frame pane)
"The display function used by the climacs application frame."
(declare (ignore frame))
- (redisplay-pane pane (eq pane (car (windows *application-frame*)))))
+ (redisplay-pane pane (eq pane (current-window))))
(defmethod handle-repaint :before ((pane extended-pane) region)
(declare (ignore region))
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.5 climacs/html-syntax.lisp:1.6
--- climacs/html-syntax.lisp:1.5 Fri Mar 4 08:17:44 2005
+++ climacs/html-syntax.lisp Sat Mar 5 08:03:53 2005
@@ -20,7 +20,7 @@
;;; Syntax for analysing HTML
-(in-package :climacs-syntax) ;;; Put this in a separate package once it works
+(in-package :climacs-html-syntax)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -34,7 +34,11 @@
(and (eq (class-of t1) (class-of t2))
(< (badness t1) (badness t2))))
-(defclass words (html-sym) ())
+(defclass html-nonterminal (html-sym)
+ ((start-offset :initarg :start-offset :reader start-offset)
+ (end-offset :initarg :end-offset :reader end-offset)))
+
+(defclass words (html-nonterminal) ())
(defclass empty-words (words) ())
@@ -42,7 +46,7 @@
((words :initarg :words)
(word :initarg :word)))
-(defclass html-balanced (html-sym)
+(defclass html-balanced (html-nonterminal)
((start :initarg :start)
(end :initarg :end)))
@@ -195,17 +199,24 @@
(tag-end (= (end-offset word) (start-offset tag-end))))
:start-mark (start-mark tag-start))
(html -> ( head body )
+ :start-offset (start-offset ) :end-offset (end-offset )
:start :head head :body body :end )
(head -> ( title )
+ :start-offset (start-offset ) :end-offset (end-offset )
:start :title title :end )
(title -> ( words )
+ :start-offset (start-offset ) :end-offset (end-offset )
:start :words words :end )
(body -> ( words )
+ :start-offset (start-offset ) :end-offset (end-offset )
:start :words words :end )
(words -> ()
- (make-instance 'empty-words))
+ (make-instance 'empty-words :start-offset nil))
(words -> (words word)
- (make-instance 'nonempty-words :words words :word word))))
+ (make-instance 'nonempty-words
+ :start-offset (or (start-offset words) (start-offset word))
+ :end-offset (end-offset word)
+ :words words :word word))))
(defmethod initialize-instance :after ((syntax html-syntax) &rest args)
(declare (ignore args))
@@ -220,6 +231,10 @@
:size 0
:state (initial-state parser)))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; update syntax
+
(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))
@@ -267,4 +282,10 @@
do (setf start-mark (clone-mark scan))
(insert* tokens guess-pos (next-token scan))
(incf guess-pos))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; display
+
+
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.52 climacs/packages.lisp:1.53
--- climacs/packages.lisp:1.52 Mon Feb 28 09:51:35 2005
+++ climacs/packages.lisp Sat Mar 5 08:03:53 2005
@@ -90,6 +90,11 @@
(:export #:syntax #:define-syntax
#:basic-syntax
#:update-syntax #:update-syntax-for-display
+ #:grammar #:parser #:initial-state
+ #:advance-parse
+ #:parse-stack-top #:target-parse-tree
+ #:parse-stack-next #:parse-stack-symbol
+ #:parse-stack-parse-trees #:map-over-parse-trees
#:syntax-line-indentation
#:beginning-of-paragraph #:end-of-paragraph))
@@ -126,7 +131,12 @@
#:query-replace-state #:string1 #:string2
#:query-replace-mode
#:with-undo
+ #:redisplay-pane-with-syntax
#:url))
+
+(defpackage :climacs-html-syntax
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ :climacs-syntax :flexichain :climacs-pane))
(defpackage :climacs-gui
(:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.19 climacs/pane.lisp:1.20
--- climacs/pane.lisp:1.19 Sun Feb 27 19:52:01 2005
+++ climacs/pane.lisp Sat Mar 5 08:03:53 2005
@@ -487,6 +487,11 @@
(+ 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+)))
+
(defgeneric redisplay-pane (pane current-p))
(defmethod redisplay-pane ((pane climacs-pane) current-p)
@@ -497,7 +502,7 @@
(adjust-cache pane))
(fill-cache pane)
(update-syntax-for-display (buffer pane) (syntax (buffer pane)) (top pane) (bot pane))
- (display-cache pane (if current-p +red+ +blue+)))
+ (redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p))
(defgeneric full-redisplay (pane))
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.33 climacs/syntax.lisp:1.34
--- climacs/syntax.lisp:1.33 Fri Mar 4 08:17:44 2005
+++ climacs/syntax.lisp Sat Mar 5 08:03:53 2005
@@ -312,6 +312,37 @@
;;;
;;; Code for analysing parse stack
+(defun parse-stack-top (state)
+ "for a given state, return the top of the parse stack, or NIL if the parse stack
+is empty in that state."
+ (when (plusp (hash-table-count (incomplete-items state)))
+ (maphash (lambda (state items)
+ (declare (ignore state))
+ (return-from parse-stack-top (car items)))
+ (incomplete-items state))))
+
+(defun target-parse-tree (state)
+ "for a given state, return a target parse tree, or NIL if this state does not
+represent a complete parse of the target."
+ (state-contains-target-p state))
+
+(defun parse-stack-next (parse-stack)
+ "given a parse stack frame, return the next frame in the stack."
+ (assert (not (null parse-stack)))
+ (predicted-from parse-stack))
+
+(defun parse-stack-symbol (parse-stack)
+ "given a parse stack frame, return the target symbol of the frame."
+ (assert (not (null parse-stack)))
+ (left-hand-side (rule parse-stack)))
+
+(defun parse-stack-parse-trees (parse-stack)
+ "given a parse stack frame, return a list (in the reverse order of
+analysis) of the parse trees recognized. The return value reveals
+internal state of the parser. Do not alter it!"
+ (assert (not (null parse-stack)))
+ (parse-trees parse-stack))
+
(defun map-over-parse-trees (function state)
(labels ((map-incomplete-item (item)
(unless (null (predicted-from item))
From abakic at common-lisp.net Sat Mar 5 11:53:53 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Mar 2005 12:53:53 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
Message-ID: <20050305115353.C7CAC8866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Doc
In directory common-lisp.net:/tmp/cvs-serv20229/Doc
Modified Files:
climacs-internals.texi
Log Message:
Typo fixes.
Date: Sat Mar 5 12:53:52 2005
Author: abakic
Index: climacs/Doc/climacs-internals.texi
diff -u climacs/Doc/climacs-internals.texi:1.15 climacs/Doc/climacs-internals.texi:1.16
--- climacs/Doc/climacs-internals.texi:1.15 Tue Mar 1 05:56:27 2005
+++ climacs/Doc/climacs-internals.texi Sat Mar 5 12:53:52 2005
@@ -1212,7 +1212,7 @@
@deffn {generic function} parse-stack buffer-stream
Return the current parse stack of the buffer stream. The parse stack
-contains either all nonterminal, or all but the top element
+contains either all nonterminals, or all but the top element
nonterminal. The list of entries is initially a list of a single
entry corresponding to the syntactic category `program-entry' with a
start offset of 0 and an expression count of 0.
@@ -1908,7 +1908,7 @@
Returns the value of a kill ring's maximum size.
@end deffn
- at deffn {generic function} {(setf kill-ring-max-size)} kill-ring size
+ at deffn {generic function} {(setf kill-ring-max-size)} size kill-ring
Alters the maximum size of a kill ring even if it means dropping
elements to do so.
@end deffn
From abakic at common-lisp.net Sat Mar 5 11:55:11 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Mar 2005 12:55:11 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Persistent/README
Message-ID: <20050305115511.8B0EC8866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv20268/Persistent
Modified Files:
README
Log Message:
Update related to the intro of delegating-buffer.
Date: Sat Mar 5 12:55:10 2005
Author: abakic
Index: climacs/Persistent/README
diff -u climacs/Persistent/README:1.3 climacs/Persistent/README:1.4
--- climacs/Persistent/README:1.3 Sat Feb 5 21:59:51 2005
+++ climacs/Persistent/README Sat Mar 5 12:55:10 2005
@@ -3,14 +3,8 @@
used as just balanced trees.
To use any of these buffer implementations (binseq-buffer or
-obinseq-buffer), substitute "standard-buffer" in the superclass list
-of climacs-buffer class in pane.lisp (marked by a "PB" comment). At
-all other places marked with "PB" comments, substitute "standard" for
-"persistent" in order to use the corresponding mark classes.
+obinseq-buffer), pass them as the :implementation argument when
+instatiating climacs-buffer class in pane.lisp.
NOTE: There is a dependency of Persistent/persistent-buffer.lisp on
-Flexichain/utilities.lisp (the weak pointer handling).
-
-NOTE: Package :binseq is now used by package :climacs-buffer, and
-the latter also exports persistent buffer and mark related symbols
-mentioned above in connection to "PB" comments.
+Flexichain/utilities.lisp (the weak pointer handling).
\ No newline at end of file
From abakic at common-lisp.net Sat Mar 5 11:56:16 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Mar 2005 12:56:16 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Persistent/persistent-buffer.lisp
Message-ID: <20050305115616.EACBF8866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv20289/Persistent
Modified Files:
persistent-buffer.lisp
Log Message:
Cursor-adjustment performance improvements.
Date: Sat Mar 5 12:56:15 2005
Author: abakic
Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.7 climacs/Persistent/persistent-buffer.lisp:1.8
--- climacs/Persistent/persistent-buffer.lisp:1.7 Fri Feb 25 21:45:11 2005
+++ climacs/Persistent/persistent-buffer.lisp Sat Mar 5 12:56:15 2005
@@ -55,7 +55,7 @@
(defclass persistent-buffer (buffer)
((low-mark :reader low-mark)
(high-mark :reader high-mark)
- (cursors :reader cursors :initform nil)
+ (cursors :accessor cursors :initform nil)
(modified :initform nil :reader modified-p))
(:documentation "The Climacs persistent buffer base class
\(non-instantiable)."))
@@ -481,42 +481,53 @@
(end-of-buffer (low-mark buffer))
(setf (slot-value buffer 'modified) nil))
-;;; I hope the code below is not wrong, although it is slow for now. It should
-;;; look like flexichain::adjust-cursors, but I am planning to write that in
-;;; a more compact form. The two functions below should not return anything.
+(defmacro filter-and-update (l filter-fn update-fn)
+ (let ((prev (gensym))
+ (curr (gensym))
+ (kept (gensym)))
+ `(loop
+ with ,prev = nil
+ and ,curr = ,l
+ and ,kept = nil
+ do (cond
+ ((null ,curr) (return))
+ ((setf ,kept (funcall ,filter-fn (car ,curr)))
+ (funcall ,update-fn ,kept)
+ (setf ,prev ,curr
+ ,curr (cdr ,curr)))
+ (t (if ,prev
+ (setf (cdr ,prev) (cdr ,curr))
+ (setf ,l (cdr ,l)))
+ (setf ,curr (cdr ,curr)))))))
+
(defun adjust-cursors-on-insert (buffer start &optional (increment 1))
- (loop for c in (cursors buffer); TODO: use side-effects to get rid of consing
- as wpc = (flexichain::weak-pointer-value c buffer)
- when wpc
- collect (progn
- (when (<= start (slot-value wpc 'pos))
- (incf (slot-value wpc 'pos) increment))
- c)))
+ (filter-and-update
+ (cursors buffer)
+ #'(lambda (c) (flexichain::weak-pointer-value c buffer))
+ #'(lambda (wpc)
+ (when (<= start (slot-value wpc 'pos))
+ (incf (slot-value wpc 'pos) increment)))))
(defun adjust-cursors-on-delete (buffer start n)
- (loop with end = (+ start n) ; TODO: use side-effects to get rid of consing
- for c in (cursors buffer)
- as wpc = (flexichain::weak-pointer-value c buffer)
- when wpc
- collect (progn
- (cond
- ((<= (cursor-pos wpc) start))
- ((< start (cursor-pos wpc) end)
- (setf (cursor-pos wpc) start))
- (t (decf (cursor-pos wpc) n)))
- c)))
+ (let ((end (+ start n)))
+ (filter-and-update
+ (cursors buffer)
+ #'(lambda (c) (flexichain::weak-pointer-value c buffer))
+ #'(lambda (wpc)
+ (cond
+ ((<= (cursor-pos wpc) start))
+ ((< start (cursor-pos wpc) end)
+ (setf (cursor-pos wpc) start))
+ (t (decf (cursor-pos wpc) n)))))))
(defmethod insert-buffer-object
:after ((buffer persistent-buffer) offset object)
- (with-slots (cursors) buffer
- (setf cursors (adjust-cursors-on-insert buffer offset))))
+ (adjust-cursors-on-insert buffer offset))
(defmethod insert-buffer-sequence
:after ((buffer persistent-buffer) offset sequence)
- (with-slots (cursors) buffer
- (setf cursors (adjust-cursors-on-insert buffer offset (length sequence)))))
+ (adjust-cursors-on-insert buffer offset (length sequence)))
(defmethod delete-buffer-range
:after ((buffer persistent-buffer) offset n)
- (with-slots (cursors) buffer
- (setf cursors (adjust-cursors-on-delete buffer offset n))))
+ (adjust-cursors-on-delete buffer offset n))
From abakic at common-lisp.net Sat Mar 5 23:23:59 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 6 Mar 2005 00:23:59 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Persistent/binseq.lisp
climacs/Persistent/obinseq.lisp
climacs/Persistent/persistent-buffer.lisp
Message-ID: <20050305232359.75E8B8866D@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv27045/Persistent
Modified Files:
binseq.lisp obinseq.lisp persistent-buffer.lisp
Log Message:
Cleanup and performance improvements.
Date: Sun Mar 6 00:23:54 2005
Author: abakic
Index: climacs/Persistent/binseq.lisp
diff -u climacs/Persistent/binseq.lisp:1.1 climacs/Persistent/binseq.lisp:1.2
--- climacs/Persistent/binseq.lisp:1.1 Wed Jan 26 17:10:45 2005
+++ climacs/Persistent/binseq.lisp Sun Mar 6 00:23:53 2005
@@ -55,6 +55,28 @@
(t (%to-list (caddr s) (%to-list (cdddr s) l))))))
(%to-list s nil)))
+(defun vector-binseq (v &optional (start 0) (end (length v)))
+ (cond
+ ((= start end) 'empty)
+ ((= (- end start) 1) `(leaf . ,(aref v start)))
+ (t (let* ((len (- end start))
+ (mid (+ start (floor len 2))))
+ `(node . (,len . (,(vector-binseq v start mid) .
+ ,(vector-binseq v mid end))))))))
+
+(defun binseq-vector (s)
+ (let ((v (make-array (binseq-length s))))
+ (labels ((%set-v (s o)
+ (cond
+ ((eq s 'empty))
+ ((eq (car s) 'leaf) (setf (aref v o) (cdr s)))
+ (t (let ((a (caddr s))
+ (b (cdddr s)))
+ (%set-v a o)
+ (%set-v b (+ o (binseq-length a))))))))
+ (%set-v s 0)
+ v)))
+
(defun binseq-empty (s)
(eq s 'empty))
Index: climacs/Persistent/obinseq.lisp
diff -u climacs/Persistent/obinseq.lisp:1.1 climacs/Persistent/obinseq.lisp:1.2
--- climacs/Persistent/obinseq.lisp:1.1 Wed Jan 26 17:10:45 2005
+++ climacs/Persistent/obinseq.lisp Sun Mar 6 00:23:54 2005
@@ -60,6 +60,32 @@
(t (%to-list (cadr s) (%to-list (cddr s) l))))))
(%to-list s nil)))
+(defun vector-obinseq (v &optional (start 0) (end (length v)))
+ (cond
+ ((= start end) nil)
+ ((= (- end start) 1)
+ (let ((e (aref v start)))
+ (assert (and e (atom e)) nil
+ "Sequence element must be a non-nil atom: ~S" e)
+ e))
+ (t (let* ((len (- end start))
+ (mid (+ start (floor len 2))))
+ `(,len . (,(vector-obinseq v start mid) .
+ ,(vector-obinseq v mid end)))))))
+
+(defun obinseq-vector (s)
+ (let ((v (make-array (obinseq-length s))))
+ (labels ((%set-v (s o)
+ (cond
+ ((null s))
+ ((atom s) (setf (aref v o) s))
+ (t (let ((a (cadr s))
+ (b (cddr s)))
+ (%set-v a o)
+ (%set-v b (+ o (obinseq-length a))))))))
+ (%set-v s 0)
+ v)))
+
(defun obinseq-empty (s)
(null s))
Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.8 climacs/Persistent/persistent-buffer.lisp:1.9
--- climacs/Persistent/persistent-buffer.lisp:1.8 Sat Mar 5 12:56:15 2005
+++ climacs/Persistent/persistent-buffer.lisp Sun Mar 6 00:23:54 2005
@@ -301,12 +301,12 @@
(insert-buffer-object (buffer mark) (offset mark) object))
(defmethod insert-buffer-sequence ((buffer binseq-buffer) offset sequence)
- (let ((binseq (list-binseq (loop for e across sequence collect e))))
+ (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)
- (let ((obinseq (list-obinseq (loop for e across sequence collect e))))
+ (let ((obinseq (vector-obinseq sequence)))
(setf (slot-value buffer 'contents)
(obinseq-insert* (slot-value buffer 'contents) offset obinseq))))
@@ -392,26 +392,26 @@
(make-condition 'offset-before-beginning :offset offset2))
(assert (<= offset2 (size buffer)) ()
(make-condition 'offset-after-end :offset offset2))
- (coerce
- (let ((len (- offset2 offset1)))
- (if (> len 0)
- (binseq-list
- (binseq-sub (slot-value buffer 'contents) offset1 len))
- nil))
- 'vector))
+ (let ((len (- offset2 offset1)))
+ (if (> len 0)
+ (binseq-vector
+ (binseq-sub (slot-value buffer 'contents) offset1 len))
+ (make-array 0))))
(defmethod buffer-sequence ((buffer obinseq-buffer) offset1 offset2)
- (assert (<= 0 offset1 (size buffer)) ()
- (make-condition 'no-such-offset :offset offset1))
- (assert (<= 0 offset2 (size buffer)) ()
- (make-condition 'no-such-offset :offset offset2))
- (coerce
- (let ((len (- offset2 offset1)))
- (if (> len 0)
- (obinseq-list
- (obinseq-sub (slot-value buffer 'contents) offset1 len))
- nil))
- 'vector))
+ (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)
+ (obinseq-vector
+ (obinseq-sub (slot-value buffer 'contents) offset1 len))
+ (make-array 0))))
(defmethod object-before ((mark p-mark-mixin))
(buffer-object (buffer mark) (1- (offset mark))))
From abakic at common-lisp.net Sat Mar 5 23:24:44 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 6 Mar 2005 00:24:44 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Persistent/binseq-package.lisp
Message-ID: <20050305232444.3FB2E8866D@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv27092/Persistent
Modified Files:
binseq-package.lisp
Log Message:
Cleanup and performance improvements.
Date: Sun Mar 6 00:24:41 2005
Author: abakic
Index: climacs/Persistent/binseq-package.lisp
diff -u climacs/Persistent/binseq-package.lisp:1.1 climacs/Persistent/binseq-package.lisp:1.2
--- climacs/Persistent/binseq-package.lisp:1.1 Wed Jan 26 17:10:45 2005
+++ climacs/Persistent/binseq-package.lisp Sun Mar 6 00:24:41 2005
@@ -24,6 +24,8 @@
#:binseq-p
#:list-binseq
#:binseq-list
+ #:vector-binseq
+ #:binseq-vector
#:binseq-empty
#:binseq-length
#:binseq-front
@@ -42,6 +44,8 @@
#:obinseq-p
#:list-obinseq
#:obinseq-list
+ #:vector-obinseq
+ #:obinseq-vector
#:obinseq-empty
#:obinseq-length
#:obinseq-front
From rstrandh at common-lisp.net Mon Mar 7 06:51:06 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Mon, 7 Mar 2005 07:51:06 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/climacs.asd
climacs/html-syntax.lisp climacs/packages.lisp
Message-ID: <20050307065106.CBFAD8866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv4561
Modified Files:
climacs.asd html-syntax.lisp packages.lisp
Log Message:
First attempt at a display function (for html syntax) that uses the
output of an incremental lexer and parser. This code is not complete
yet:
* right now, it uses only the lexer output, and not the parser
* the cursor is not displayed yet
* it is too slow, most likely because the output records are all in
one big bag, as opposed to being tree structured, such as the
lines of basic syntax.
The slowness is not a serious problem, because one day, McCLIM will
have tree-structured output records itself, and because most syntax
modules (including this one, very soon) will have some tree structure
itself. It might be worthwhile to display the part of the buffer
beyond a parse error in some artificially structured way, such as by
lines as in the current basic syntax.
Date: Mon Mar 7 07:51:03 2005
Author: rstrandh
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.21 climacs/climacs.asd:1.22
--- climacs/climacs.asd:1.21 Tue Mar 1 05:56:06 2005
+++ climacs/climacs.asd Mon Mar 7 07:51:02 2005
@@ -55,12 +55,12 @@
"abbrev"
"syntax"
"text-syntax"
- "html-syntax"
"cl-syntax"
"kill-ring"
"undo"
"delegating-buffer"
"pane"
+ "html-syntax"
"gui"
;;---- optional ----
"testing/rt"
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.6 climacs/html-syntax.lisp:1.7
--- climacs/html-syntax.lisp:1.6 Sat Mar 5 08:03:53 2005
+++ climacs/html-syntax.lisp Mon Mar 7 07:51:02 2005
@@ -287,5 +287,52 @@
;;;
;;; display
+(defun handle-whitespace (pane buffer start end)
+ (let ((space-width (space-width pane))
+ (tab-width (tab-width pane)))
+ (loop while (< start end)
+ do (ecase (buffer-object buffer start)
+ (#\Newline (terpri pane))
+ (#\Space (stream-increment-cursor-position
+ pane space-width 0))
+ (#\Tab (let ((x (stream-cursor-position pane)))
+ (stream-increment-cursor-position
+ pane (- tab-width (mod x tab-width)) 0))))
+ (incf start))))
-
+(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
+ (with-slots (top bot) pane
+ (with-slots (tokens) syntax
+ (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements tokens)))
+ 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* tokens (1- end-token-index))) bot)
+ do (decf end-token-index))
+ ;; for forward to the last token before bot
+ (loop until (or (= end-token-index (nb-elements tokens))
+ (mark> (start-offset (element* tokens end-token-index)) bot))
+ do (incf end-token-index))
+ (let ((start-token-index end-token-index))
+ ;; go back to the first token after top
+ (loop until (mark<= (end-offset (element* tokens (1- start-token-index))) top)
+ do (decf start-token-index))
+ ;; display the tokens
+ (loop with prev-offset = (offset top)
+ while (< start-token-index end-token-index)
+ do (let ((token (element* tokens start-token-index)))
+ (handle-whitespace pane (buffer pane) prev-offset (start-offset token))
+ (updating-output (pane :unique-id token
+ :id-test #'eq
+ :cache-value token
+ :cache-test #'eq)
+ (present (coerce (region-to-sequence (start-mark token)
+ (end-offset token))
+ 'string)
+ 'string
+ :stream pane))
+ (setf prev-offset (end-offset token)))
+ (incf start-token-index))))))))
+
+
\ No newline at end of file
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.53 climacs/packages.lisp:1.54
--- climacs/packages.lisp:1.53 Sat Mar 5 08:03:53 2005
+++ climacs/packages.lisp Mon Mar 7 07:51:03 2005
@@ -122,7 +122,8 @@
#:climacs-pane #:point #:mark
#:redisplay-pane #:full-redisplay
#:page-down #:page-up
- #:tab-space-count
+ #:top #:bot
+ #:tab-space-count #:space-width #:tab-width
#:indent-tabs-mode
#:auto-fill-mode #:auto-fill-column
#:isearch-state #:search-string #:search-mark
From rstrandh at common-lisp.net Thu Mar 10 06:37:43 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Thu, 10 Mar 2005 07:37:43 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/packages.lisp climacs/syntax.lisp
Message-ID: <20050310063743.EB4FB88665@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv20617
Modified Files:
html-syntax.lisp packages.lisp syntax.lisp
Log Message:
More progress on html-syntax, which may eventually become a model
for many different language syntax modules.
The display function now traverses the parse tree up as long as a
valid parse tree exists. The rest of the display is done from the
token sequence. It is likely that all of this can be abstracted out
and put into syntax.lisp so that html-syntax would just become a
client among others for this traversal.
Not only is the cursor still not displayed, whitespace is not handled
during the traversal of the parse tree. This will likely be fixed in
the next few day.
Date: Thu Mar 10 07:37:41 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.7 climacs/html-syntax.lisp:1.8
--- climacs/html-syntax.lisp:1.7 Mon Mar 7 07:51:02 2005
+++ climacs/html-syntax.lisp Thu Mar 10 07:37:40 2005
@@ -300,6 +300,71 @@
pane (- tab-width (mod x tab-width)) 0))))
(incf start))))
+(defmethod display-parse-tree :around ((entity html-sym) syntax pane)
+ (with-slots (top bot) pane
+ (when (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)
+ (updating-output (pane :unique-id entity
+ :id-test #'eq
+ :cache-value entity
+ :cache-test #'eq)
+ (present (coerce (region-to-sequence (start-mark entity)
+ (end-offset entity))
+ 'string)
+ 'string
+ :stream pane)))
+
+(defmethod display-parse-tree :before ((entity html-balanced) (syntax html-syntax) pane)
+ (with-slots (start) entity
+ (display-parse-tree start syntax pane)))
+
+(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 ((entity html-words) (syntax html-syntax) pane)
+ (with-slots (words) entity
+ (display-parse-tree words syntax pane)))
+
+(defmethod display-parse-tree ((entity empty-words) (syntax html-syntax) pane)
+ (declare (ignore pane))
+ nil)
+
+(defmethod display-parse-tree ((entity nonempty-words) (syntax html-syntax) pane)
+ (with-slots (words word) entity
+ (display-parse-tree words syntax pane)
+ (display-parse-tree word syntax pane)))
+
+(defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
+ (with-slots (head body) entity
+ (display-parse-tree head syntax pane)
+ (display-parse-tree body syntax pane)))
+
+(defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
+ (with-slots (title) entity
+ (display-parse-tree title syntax pane)))
+
+(defgeneric display-parse-stack (symbol stack syntax pane))
+
+(defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
+ (let ((next (parse-stack-next stack)))
+ (unless (null next)
+ (display-parse-stack (parse-stack-symbol next) next syntax pane))
+ (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
+ do (display-parse-tree parse-tree syntax pane))))
+
+(defun display-parse-state (state syntax pane)
+ (let ((top (parse-stack-top state)))
+ (if (not (null top))
+ (display-parse-stack (parse-stack-symbol top) top syntax pane)
+ (display-parse-tree (target-parse-tree state) syntax pane))))
+
(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
(with-slots (top bot) pane
(with-slots (tokens) syntax
@@ -310,16 +375,24 @@
;; go back to a token before bot
(loop until (mark<= (end-offset (element* tokens (1- end-token-index))) bot)
do (decf end-token-index))
- ;; for forward to the last token before bot
+ ;; go forward to the last token before bot
(loop until (or (= end-token-index (nb-elements tokens))
(mark> (start-offset (element* tokens end-token-index)) bot))
do (incf end-token-index))
(let ((start-token-index end-token-index))
- ;; go back to the first token after top
- (loop until (mark<= (end-offset (element* tokens (1- start-token-index))) top)
+ ;; 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* tokens (1- start-token-index))) top)
+ (not (null (parse-stack-top
+ (slot-value (element* tokens (1- start-token-index)) 'state)))))
do (decf start-token-index))
+ ;; display the parse tree if any
+ (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state))
+ (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state)
+ syntax
+ pane))
;; display the tokens
- (loop with prev-offset = (offset top)
+ (loop with prev-offset = (end-offset (element* tokens (1- start-token-index)))
while (< start-token-index end-token-index)
do (let ((token (element* tokens start-token-index)))
(handle-whitespace pane (buffer pane) prev-offset (start-offset token))
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.54 climacs/packages.lisp:1.55
--- climacs/packages.lisp:1.54 Mon Mar 7 07:51:03 2005
+++ climacs/packages.lisp Thu Mar 10 07:37:40 2005
@@ -92,7 +92,7 @@
#:update-syntax #:update-syntax-for-display
#:grammar #:parser #:initial-state
#:advance-parse
- #:parse-stack-top #:target-parse-tree
+ #:parse-stack-top #:target-parse-tree #:parse-state-empty-p
#:parse-stack-next #:parse-stack-symbol
#:parse-stack-parse-trees #:map-over-parse-trees
#:syntax-line-indentation
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.34 climacs/syntax.lisp:1.35
--- climacs/syntax.lisp:1.34 Sat Mar 5 08:03:53 2005
+++ climacs/syntax.lisp Thu Mar 10 07:37:40 2005
@@ -326,6 +326,10 @@
represent a complete parse of the target."
(state-contains-target-p state))
+(defun parse-state-empty-p (state)
+ (and (null (parse-stack-top state))
+ (null (target-parse-tree state))))
+
(defun parse-stack-next (parse-stack)
"given a parse stack frame, return the next frame in the stack."
(assert (not (null parse-stack)))
From rstrandh at common-lisp.net Fri Mar 11 07:03:38 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Fri, 11 Mar 2005 08:03:38 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/syntax.lisp
Message-ID: <20050311070338.1E310884E2@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv5279
Modified Files:
html-syntax.lisp syntax.lisp
Log Message:
HTML syntax now does syntax highlighting.
The current code is a mess, because I haven't figured out how much of
html-syntax.lisp can be factored out and put in syntax.lisp for use
with other syntax modules.
Also, the HTML syntax module is nowhere near complete. It exists
merely as an illustration of what can be done with incremental
parsing. It is definitely premature to try to turn it into something
more complete and truly useful for editing HTML.
Date: Fri Mar 11 08:03:32 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.8 climacs/html-syntax.lisp:1.9
--- climacs/html-syntax.lisp:1.8 Thu Mar 10 07:37:40 2005
+++ climacs/html-syntax.lisp Fri Mar 11 08:03:31 2005
@@ -24,9 +24,28 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
+;;; 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)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
;;; grammar classes
-(defclass html-sym ()
+(defclass html-sym (parse-tree)
((badness :initform 0 :initarg :badness :reader badness)
(message :initform "" :initarg :message :reader message)))
@@ -34,9 +53,7 @@
(and (eq (class-of t1) (class-of t2))
(< (badness t1) (badness t2))))
-(defclass html-nonterminal (html-sym)
- ((start-offset :initarg :start-offset :reader start-offset)
- (end-offset :initarg :end-offset :reader end-offset)))
+(defclass html-nonterminal (html-sym) ())
(defclass words (html-nonterminal) ())
@@ -68,40 +85,30 @@
(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))
+ ((ink) (face)))
-(defmethod start-offset ((token html-token))
- (offset (start-mark token)))
+(defclass html-tag (html-token) ())
-(defclass (html-token) () (:default-initargs :size 6))
-(defclass (html-token) ()(:default-initargs :size 7))
-(defclass (html-token) () (:default-initargs :size 6))
-(defclass (html-token) () (:default-initargs :size 7))
-(defclass (html-token) () (:default-initargs :size 7))
-(defclass (html-token) () (:default-initargs :size 8))
-(defclass (html-token) () (:default-initargs :size 6))
-(defclass (html-token) () (:default-initargs :size 7))
-(defclass (html-token) () (:default-initargs :size 4))
-(defclass
(html-token) () (:default-initargs :size 5))
-(defclass (html-token) () (:default-initargs :size 4))
-(defclass
(html-token) () (:default-initargs :size 5))
-(defclass (html-token) () (:default-initargs :size 4))
-(defclass
(html-token) () (:default-initargs :size 5))
-(defclass (html-token) () (:default-initargs :size 3))
-(defclass
(html-token) () (:default-initargs :size 4))
-(defclass (html-token) () (:default-initargs :size 4))
-(defclass
(html-token) () (:default-initargs :size 5))
-(defclass (html-token) () (:default-initargs :size 4))
-(defclass (html-token) () (:default-initargs :size 5))
+(defclass (html-tag) () (:default-initargs :size 6))
+(defclass (html-tag) ()(:default-initargs :size 7))
+(defclass (html-tag) () (:default-initargs :size 6))
+(defclass (html-tag) () (:default-initargs :size 7))
+(defclass (html-tag) () (:default-initargs :size 7))
+(defclass (html-tag) () (:default-initargs :size 8))
+(defclass (html-tag) () (:default-initargs :size 6))
+(defclass (html-tag) () (:default-initargs :size 7))
+(defclass (html-tag) () (:default-initargs :size 4))
+(defclass
(html-tag) () (:default-initargs :size 5))
+(defclass (html-tag) () (:default-initargs :size 4))
+(defclass
(html-tag) () (:default-initargs :size 5))
+(defclass (html-tag) () (:default-initargs :size 4))
+(defclass
(html-tag) () (:default-initargs :size 5))
+(defclass (html-tag) () (:default-initargs :size 3))
+(defclass
(html-tag) () (:default-initargs :size 4))
+(defclass (html-tag) () (:default-initargs :size 4))
+(defclass
(html-tag) () (:default-initargs :size 5))
+(defclass (html-tag) () (:default-initargs :size 4))
+(defclass (html-tag) () (:default-initargs :size 5))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -199,23 +206,27 @@
(tag-end (= (end-offset word) (start-offset tag-end))))
:start-mark (start-mark tag-start))
(html -> ( head body )
- :start-offset (start-offset ) :end-offset (end-offset )
+ :start-mark (start-mark )
+ :size (- (end-offset ) (start-offset ))
:start :head head :body body :end )
(head -> ( title )
- :start-offset (start-offset ) :end-offset (end-offset )
+ :start-mark (start-mark )
+ :size (- (end-offset ) (start-offset ))
:start :title title :end )
(title -> ( words )
- :start-offset (start-offset ) :end-offset (end-offset )
+ :start-mark (start-mark )
+ :size (- (end-offset ) (start-offset ))
:start <title> :words words :end )
(body -> ( words )
- :start-offset (start-offset ) :end-offset (end-offset )
+ :start-mark (start-mark )
+ :size (- (end-offset ) (start-offset ))
:start :words words :end )
(words -> ()
- (make-instance 'empty-words :start-offset nil))
+ (make-instance 'empty-words :start-mark nil))
(words -> (words word)
(make-instance 'nonempty-words
- :start-offset (or (start-offset words) (start-offset word))
- :end-offset (end-offset word)
+ :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))))
(defmethod initialize-instance :after ((syntax html-syntax) &rest args)
@@ -287,12 +298,20 @@
;;;
;;; display
+(defvar *white-space-start* nil)
+
+(defvar *cursor-positions* nil)
+(defvar *current-line* 0)
+
(defun handle-whitespace (pane buffer start end)
(let ((space-width (space-width pane))
(tab-width (tab-width pane)))
(loop while (< start end)
do (ecase (buffer-object buffer start)
- (#\Newline (terpri pane))
+ (#\Newline (terpri pane)
+ (setf (aref *cursor-positions* (incf *current-line*))
+ (multiple-value-bind (x y) (stream-cursor-position pane)
+ y)))
(#\Space (stream-increment-cursor-position
pane space-width 0))
(#\Tab (let ((x (stream-cursor-position pane)))
@@ -310,15 +329,32 @@
nil)
(defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane)
- (updating-output (pane :unique-id entity
- :id-test #'eq
- :cache-value entity
- :cache-test #'eq)
- (present (coerce (region-to-sequence (start-mark entity)
- (end-offset entity))
- 'string)
- 'string
- :stream pane)))
+ (flet ((cache-test (t1 t2)
+ (and (eq t1 t2)
+ (eq (slot-value t1 'ink)
+ (medium-ink (sheet-medium pane)))
+ (eq (slot-value t1 'face)
+ (text-style-face (medium-text-style (sheet-medium pane)))))))
+ (updating-output (pane :unique-id entity
+ :id-test #'eq
+ :cache-value entity
+ :cache-test #'cache-test)
+ (with-slots (ink face) entity
+ (setf ink (medium-ink (sheet-medium pane))
+ face (text-style-face (medium-text-style (sheet-medium pane))))
+ (present (coerce (region-to-sequence (start-mark entity)
+ (end-offset entity))
+ 'string)
+ 'string
+ :stream pane)))))
+
+(defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
+ (with-drawing-options (pane :ink +green+)
+ (call-next-method)))
+
+(defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane)
+ (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
+ (setf *white-space-start* (end-offset entity)))
(defmethod display-parse-tree :before ((entity html-balanced) (syntax html-syntax) pane)
(with-slots (start) entity
@@ -328,6 +364,10 @@
(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
(display-parse-tree words syntax pane)))
@@ -367,6 +407,9 @@
(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
(with-slots (top bot) pane
+ (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 (tokens) syntax
(let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements tokens)))
1.0)))
@@ -383,29 +426,30 @@
;; 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* tokens (1- start-token-index))) top)
- (not (null (parse-stack-top
- (slot-value (element* tokens (1- start-token-index)) 'state)))))
+ (not (parse-state-empty-p
+ (slot-value (element* tokens (1- start-token-index)) 'state))))
do (decf start-token-index))
- ;; display the parse tree if any
- (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state))
- (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state)
- syntax
- pane))
- ;; display the tokens
- (loop with prev-offset = (end-offset (element* tokens (1- start-token-index)))
- while (< start-token-index end-token-index)
- do (let ((token (element* tokens start-token-index)))
- (handle-whitespace pane (buffer pane) prev-offset (start-offset token))
- (updating-output (pane :unique-id token
- :id-test #'eq
- :cache-value token
- :cache-test #'eq)
- (present (coerce (region-to-sequence (start-mark token)
- (end-offset token))
- 'string)
- 'string
- :stream pane))
- (setf prev-offset (end-offset token)))
- (incf start-token-index))))))))
+ (let ((*white-space-start* (offset top)))
+ ;; display the parse tree if any
+ (unless (parse-state-empty-p (slot-value (element* tokens (1- start-token-index)) 'state))
+ (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state)
+ syntax
+ pane))
+ ;; display the tokens
+ (with-drawing-options (pane :ink +red+)
+ (loop while (< start-token-index end-token-index)
+ do (let ((token (element* tokens start-token-index)))
+ (display-parse-tree token syntax pane))
+ (incf start-token-index))))))))
+ (let* ((cursor-line (number-of-lines-in-region top (point pane)))
+ (height (text-style-height (medium-text-style pane) pane))
+ (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
+ (cursor-column (column-number (point pane)))
+ (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
+ (updating-output (pane :unique-id -1)
+ (draw-rectangle* pane
+ (1- cursor-x) (- cursor-y (* 0.2 height))
+ (+ cursor-x 2) (+ cursor-y (* 0.8 height))
+ :ink (if current-p +red+ +blue+))))))
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.35 climacs/syntax.lisp:1.36
--- climacs/syntax.lisp:1.35 Thu Mar 10 07:37:40 2005
+++ climacs/syntax.lisp Fri Mar 11 08:03:31 2005
@@ -139,14 +139,15 @@
(target :initarg :target :reader target)
(initial-state :reader initial-state)))
-(defclass rule-item () ())
+(defclass rule-item ()
+ ((parse-trees :initform '() :initarg :parse-trees :reader parse-trees)))
+
(defclass incomplete-item (rule-item)
((orig-state :initarg :orig-state :reader orig-state)
(predicted-from :initarg :predicted-from :reader predicted-from)
(rule :initarg :rule :reader rule)
(dot-position :initarg :dot-position :reader dot-position)
- (parse-trees :initarg :parse-trees :reader parse-trees)
(suffix :initarg :suffix :reader suffix)))
(defmethod print-object ((item incomplete-item) stream)
@@ -180,7 +181,8 @@
:suffix remaining))
(t
(make-instance 'complete-item
- :parse-tree remaining)))))
+ :parse-tree remaining
+ :parse-trees (cons parse-tree (parse-trees prev-item)))))))
(defgeneric item-equal (item1 item2))
@@ -257,7 +259,6 @@
:predicted-from item
:rule rule
:dot-position 0
- :parse-trees '()
:suffix (right-hand-side rule))
(make-instance 'complete-item
:parse-tree (right-hand-side rule)))
@@ -284,7 +285,6 @@
:predicted-from nil
:rule rule
:dot-position 0
- :parse-trees '()
:suffix (right-hand-side rule))
(make-instance 'complete-item
:parse-tree (right-hand-side rule)))
From rstrandh at common-lisp.net Fri Mar 11 10:23:34 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Fri, 11 Mar 2005 11:23:34 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/climacs.asd
Message-ID: <20050311102334.30F2188663@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv16440
Modified Files:
climacs.asd
Log Message:
Patch from Andreas Fuchs that makes Climacs no longer depend on
a specific McCLIM backend.
Date: Fri Mar 11 11:23:33 2005
Author: rstrandh
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.22 climacs/climacs.asd:1.23
--- climacs/climacs.asd:1.22 Mon Mar 7 07:51:02 2005
+++ climacs/climacs.asd Fri Mar 11 11:23:33 2005
@@ -42,7 +42,7 @@
:defaults *climacs-directory*))
collect `(:file ,(pathname-name p) :pathname ,p))))))
-(climacs-defsystem (:climacs :depends-on (:clim-clx :flexichain))
+(climacs-defsystem (:climacs :depends-on (:mcclim :flexichain))
"Persistent/binseq-package"
"Persistent/binseq"
"Persistent/obinseq"
From rstrandh at common-lisp.net Fri Mar 11 10:25:59 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Fri, 11 Mar 2005 11:25:59 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
Message-ID: <20050311102559.570DE88663@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv16497
Modified Files:
html-syntax.lisp
Log Message:
recognize the and tags
Date: Fri Mar 11 11:25:58 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.9 climacs/html-syntax.lisp:1.10
--- climacs/html-syntax.lisp:1.9 Fri Mar 11 08:03:31 2005
+++ climacs/html-syntax.lisp Fri Mar 11 11:25:58 2005
@@ -82,6 +82,7 @@
(defclass h1 (html-words) ())
(defclass h2 (html-words) ())
(defclass h3 (html-words) ())
+(defclass a (html-words) ())
(defclass para (html-words) ())
(defclass html-token (html-sym)
@@ -109,6 +110,13 @@
(defclass (html-tag) () (:default-initargs :size 5))
(defclass (html-tag) () (:default-initargs :size 4))
(defclass (html-tag) () (:default-initargs :size 5))
+(defclass (html-tag)
+ ((start :initarg :start)
+ (word :initarg :word)
+ (words :initarg :words)
+ (end :initarg :end)))
+(defclass (html-tag) () (:default-initargs :size 4))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -205,6 +213,20 @@
(word-is word "body")))
(tag-end (= (end-offset word) (start-offset tag-end))))
:start-mark (start-mark tag-start))
+ ( -> (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)
+ ( -> (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))
(html -> ( head body )
:start-mark (start-mark )
:size (- (end-offset ) (start-offset ))
@@ -221,13 +243,24 @@
:start-mark (start-mark )
:size (- (end-offset ) (start-offset ))
:start :words words :end )
+ (a -> ( words )
+ :start-mark (start-mark )
+ :size (- (end-offset ) (start-offset ))
+ :start :words words :end )
(words -> ()
(make-instance 'empty-words :start-mark nil))
(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))))
+ :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)))))
+
(defmethod initialize-instance :after ((syntax html-syntax) &rest args)
(declare (ignore args))
@@ -311,6 +344,7 @@
(#\Newline (terpri pane)
(setf (aref *cursor-positions* (incf *current-line*))
(multiple-value-bind (x y) (stream-cursor-position pane)
+ (declare (ignore x))
y)))
(#\Space (stream-increment-cursor-position
pane space-width 0))
@@ -390,6 +424,13 @@
(with-slots (title) entity
(display-parse-tree title syntax pane)))
+(defmethod display-parse-tree ((entity ) (syntax html-syntax) pane)
+ (with-slots (start word words end) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree word syntax pane)
+ (display-parse-tree words syntax pane)
+ (display-parse-tree end syntax pane)))
+
(defgeneric display-parse-stack (symbol stack syntax pane))
(defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
@@ -452,4 +493,3 @@
(+ cursor-x 2) (+ cursor-y (* 0.8 height))
:ink (if current-p +red+ +blue+))))))
-
\ No newline at end of file
From rstrandh at common-lisp.net Sun Mar 13 06:55:29 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sun, 13 Mar 2005 07:55:29 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
Message-ID: <20050313065529.720AE88663@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv5617
Modified Files:
html-syntax.lisp
Log Message:
A step on the way to factoring out the incremental lexer.
Date: Sun Mar 13 07:55:28 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.10 climacs/html-syntax.lisp:1.11
--- climacs/html-syntax.lisp:1.10 Fri Mar 11 11:25:58 2005
+++ climacs/html-syntax.lisp Sun Mar 13 07:55:27 2005
@@ -41,6 +41,21 @@
(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))
+
+(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))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; grammar classes
@@ -132,30 +147,23 @@
(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))))))))))
+(defun next-lexeme (scan)
+ (flet ((fo () (forward-object scan)))
+ (let ((object (object-after scan)))
+ (case object
+ (#\< (fo) (make-instance 'tag-start))
+ (#\> (fo) (make-instance 'tag-end))
+ (#\/ (fo) (make-instance 'slash))
+ (t (cond ((alphanumericp object)
+ (loop until (end-of-buffer-p scan)
+ while (alphanumericp (object-after scan))
+ do (fo))
+ (make-instance 'word))
+ (t
+ (fo) (make-instance 'delimiter))))))))
(define-syntax html-syntax ("HTML" (basic-syntax))
- ((tokens :initform (make-instance 'standard-flexichain))
- (guess-pos :initform 1)
+ ((lexemes :initform (make-instance 'standard-flexichain))
(valid-parse :initform 1)
(parser)))
@@ -264,11 +272,11 @@
(defmethod initialize-instance :after ((syntax html-syntax) &rest args)
(declare (ignore args))
- (with-slots (parser tokens buffer) syntax
+ (with-slots (parser lexemes buffer) syntax
(setf parser (make-instance 'parser
:grammar *html-grammar*
:target 'html))
- (insert* tokens 0 (make-instance 'start-element
+ (insert* lexemes 0 (make-instance 'start-element
:start-mark (make-instance 'standard-left-sticky-mark
:buffer buffer
:offset 0)
@@ -280,52 +288,65 @@
;;; update syntax
(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))))
+ (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)))
+ (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))
+ (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 (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))))))
+ (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))
- (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))))))
+ (with-slots (lexemes 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)))
+ (setf valid-parse first-invalid-position)
+ (update-lex lexemes first-invalid-position high-mark))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -451,35 +472,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 (tokens) syntax
- (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements tokens)))
+ (with-slots (lexemes) syntax
+ (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-elements lexemes)))
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* tokens (1- end-token-index))) bot)
+ (loop until (mark<= (end-offset (element* lexemes (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 tokens))
- (mark> (start-offset (element* tokens end-token-index)) bot))
+ (loop until (or (= end-token-index (nb-elements lexemes))
+ (mark> (start-offset (element* lexemes 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* tokens (1- start-token-index))) top)
+ (loop until (or (mark<= (end-offset (element* lexemes (1- start-token-index))) top)
(not (parse-state-empty-p
- (slot-value (element* tokens (1- start-token-index)) 'state))))
+ (slot-value (element* lexemes (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* tokens (1- start-token-index)) 'state))
- (display-parse-state (slot-value (element* tokens (1- start-token-index)) 'state)
+ (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)
syntax
pane))
- ;; display the tokens
+ ;; display the lexemes
(with-drawing-options (pane :ink +red+)
(loop while (< start-token-index end-token-index)
- do (let ((token (element* tokens start-token-index)))
+ do (let ((token (element* lexemes start-token-index)))
(display-parse-tree token syntax pane))
(incf start-token-index))))))))
(let* ((cursor-line (number-of-lines-in-region top (point pane)))
From abakic at common-lisp.net Sun Mar 13 20:51:53 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 13 Mar 2005 21:51:53 +0100 (CET)
Subject: [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
Message-ID: <20050313205153.BFE4088669@common-lisp.net>
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 , at 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)))))))
From abakic at common-lisp.net Sun Mar 13 20:51:56 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 13 Mar 2005 21:51:56 +0100 (CET)
Subject: [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
Message-ID: <20050313205156.9451788669@common-lisp.net>
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))
From rstrandh at common-lisp.net Tue Mar 15 04:32:00 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 15 Mar 2005 05:32:00 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/syntax.lisp
Message-ID: <20050315043200.107B488441@common-lisp.net>
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))
From rstrandh at common-lisp.net Tue Mar 15 05:39:29 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 15 Mar 2005 06:39:29 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/packages.lisp climacs/syntax.lisp
Message-ID: <20050315053929.B321A88441@common-lisp.net>
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 , at body)
+ `(progn , at 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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
From rstrandh at common-lisp.net Tue Mar 15 06:19:26 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 15 Mar 2005 07:19:26 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
Message-ID: <20050315061926.5F5DF88441@common-lisp.net>
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
+ at deftp {Protocol Class} parse-tree
+
+The base class for all parse trees.
+ at 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.
+
+ at deffn {Generic Function} {start-offset} parse-tree
+
+The offset in the buffer of the first character of a parse tree.
+ at end deffn
+
+ at deffn {Generic Function} {end-offset} parse-tree
+
+The offset in the buffer of the character following the last one of a
+parse tree.
+ at 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.
+
+ at subsection Lexical analysis
+
+ at deftp {Protocol Class} lexer
+
+The base class for all lexers.
+ at end deftp
+
+ at deftp {initarg} :buffer
+
+Associate a buffer with a lexer
+ at end deftp
+
+ at deffn {Generic Function} {buffer} lexer
+
+Return the buffer associated with the lexer
+ at end deffn
+
+ at deftp {Class} incremental-lexer
+
+A subclass of lexer which maintains the buffer in the form of a
+sequence of lexemes that is updated incrementally.
+ at end deftp
+
+In the sequence of lexemes maintained by the incremental lexer, the
+lexemes are indexed by a position starting from zero.
+
+ at deffn {Generic Function} {nb-lexemes} lexer
+
+Return the number of lexemes in the lexer.
+ at end deffn
+
+ at deffn {Generic Function} {lexeme} lexer pos
+
+Given a lexer and a position, return the lexeme in that position in
+the lexer.
+ at end deffn
+
+ at 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.
+ at end deffn
+
+ at deffn {Generic Function} {delete-invalid-lexemes} lexer from to
+
+Invalidate all lexemes that could have changed as a result of
+modifications to the buffer
+ at end deffn
+
+ at 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.
+ at end deffn
+
+ at 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.
+ at end deffn
+
+ at 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.
+ at end deffn
+
+ at 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.
+ at end deffn
+
@subsection Earley parser
Climacs contains an incremental parser that uses the Earley
From rstrandh at common-lisp.net Tue Mar 15 12:51:44 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 15 Mar 2005 13:51:44 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp
Message-ID: <20050315125144.984018866B@common-lisp.net>
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))
+
From abakic at common-lisp.net Tue Mar 15 18:41:19 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Tue, 15 Mar 2005 19:41:19 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp
Message-ID: <20050315184119.867808866B@common-lisp.net>
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
From abakic at common-lisp.net Tue Mar 15 18:41:24 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Tue, 15 Mar 2005 19:41:24 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Persistent/binseq2.lisp
climacs/Persistent/persistent-buffer.lisp
Message-ID: <20050315184124.061678866B@common-lisp.net>
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
From rstrandh at common-lisp.net Wed Mar 16 06:12:11 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 16 Mar 2005 07:12:11 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/syntax.lisp
Message-ID: <20050316061211.E02A88866B@common-lisp.net>
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 at 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-tag) () (:default-initargs :size 6))
-(defclass (html-tag) ()(:default-initargs :size 7))
-(defclass (html-tag) () (:default-initargs :size 6))
-(defclass (html-tag) () (:default-initargs :size 7))
-(defclass (html-tag) () (:default-initargs :size 7))
-(defclass (html-tag) () (:default-initargs :size 8))
-(defclass (html-tag) () (:default-initargs :size 6))
-(defclass (html-tag) () (:default-initargs :size 7))
-(defclass (html-tag) () (:default-initargs :size 4))
-(defclass
(html-tag) () (:default-initargs :size 5))
-(defclass (html-tag) () (:default-initargs :size 4))
-(defclass
(html-tag) () (:default-initargs :size 5))
-(defclass (html-tag) () (:default-initargs :size 4))
-(defclass
(html-tag) () (:default-initargs :size 5))
-(defclass (html-tag) () (:default-initargs :size 3))
-(defclass
(html-tag) () (:default-initargs :size 4))
-(defclass (html-tag) () (:default-initargs :size 4))
-(defclass
(html-tag) () (:default-initargs :size 5))
-(defclass (html-tag) () (:default-initargs :size 4))
-(defclass (html-tag) () (:default-initargs :size 5))
+(defclass (html-tag) ())
+(defclass (html-tag) ())
+(defclass (html-tag) ())
+(defclass (html-tag) ())
+(defclass (html-tag) ())
+(defclass (html-tag) ())
+(defclass (html-tag) ())
+(defclass (html-tag) ())
+(defclass (html-tag) ())
+(defclass
(html-tag) ())
+(defclass (html-tag) ())
+(defclass
(html-tag) ())
+(defclass (html-tag) ())
+(defclass
(html-tag) ())
+(defclass (html-tag) ())
+(defclass
(html-tag) ())
+(defclass (html-tag) ())
+(defclass
(html-tag) ())
+(defclass (html-tag) ())
+(defclass (html-tag) ())
(defclass (html-tag)
((start :initarg :start)
(word :initarg :word)
(words :initarg :words)
(end :initarg :end)))
-(defclass (html-tag) () (:default-initargs :size 4))
+(defclass (html-tag) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -147,96 +145,183 @@
( -> (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)))))
( -> (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)))))
( -> (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)))))
( -> (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)))))
( -> (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)))))
( -> (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)))))
( -> (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)))))
( -> (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)))))
( -> (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)
( -> (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 -> ( head body )
- :start-mark (start-mark )
- :size (- (end-offset ) (start-offset ))
:start :head head :body body :end )
(head -> ( title )
- :start-mark (start-mark )
- :size (- (end-offset ) (start-offset ))
:start :title title :end )
- (title -> ( words )
- :start-mark (start-mark )
- :size (- (end-offset ) (start-offset ))
- :start <title> :words words :end )
- (body -> ( words )
- :start-mark (start-mark )
- :size (- (end-offset ) (start-offset ))
- :start :words words :end )
(a -> ( words )
- :start-mark (start-mark )
- :size (- (end-offset ) (start-offset ))
:start :words words :end )
(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)
+ (( :initarg :<title>)
+ (items :initarg :items)
+ ( :initarg :)))
+
+(add-rule (grammar-rule (title -> ( title-items )
+ : <title> :items title-items : ))
+ *html-grammar*)
+
+(defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
+ (with-slots ( items ) entity
+ (display-parse-tree syntax pane)
+ (with-text-face (pane :bold)
+ (display-parse-tree items syntax pane))
+ (display-parse-tree 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)
+ (( :initarg :)
+ (items :initarg :items)
+ ( :initarg :)))
+
+(add-rule (grammar-rule (body -> ( body-items )
+ : :items body-items : ))
+ *html-grammar*)
+
+(defmethod display-parse-tree ((entity body) (syntax html-syntax) pane)
+ (with-slots ( items ) entity
+ (display-parse-tree syntax pane)
+ (display-parse-tree items syntax pane)
+ (display-parse-tree 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))
From rstrandh at common-lisp.net Wed Mar 16 07:47:50 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 16 Mar 2005 08:47:50 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
Message-ID: <20050316074750.BAE308866B@common-lisp.net>
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-tag) ())
-(defclass (html-tag) ())
-(defclass (html-tag) ())
-(defclass (html-tag) ())
-(defclass (html-tag) ())
-(defclass (html-tag) ())
-(defclass (html-tag) ())
-(defclass (html-tag) ())
-(defclass (html-tag) ())
-(defclass
(html-tag) ())
-(defclass (html-tag) ())
-(defclass
(html-tag) ())
-(defclass (html-tag) ())
-(defclass
(html-tag) ())
-(defclass (html-tag) ())
-(defclass
(html-tag) ())
-(defclass (html-tag) ())
-(defclass
(html-tag) ())
-(defclass (html-tag) ())
-(defclass (html-tag) ())
(defclass (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
- ( -> (tag-start
- (word (and (= (end-offset tag-start) (start-offset word))
- (word-is word "html")))
- (tag-end (= (end-offset word) (start-offset tag-end)))))
- ( -> (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)))))
- ( -> (tag-start
- (word (and (= (end-offset tag-start) (start-offset word))
- (word-is word "head")))
- (tag-end (= (end-offset word) (start-offset tag-end)))))
- ( -> (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)))))
- ( -> (tag-start
- (word (and (= (end-offset tag-start) (start-offset word))
- (word-is word "title")))
- (tag-end (= (end-offset word) (start-offset tag-end)))))
- ( -> (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)))))
- ( -> (tag-start
- (word (and (= (end-offset tag-start) (start-offset word))
- (word-is word "body")))
- (tag-end (= (end-offset word) (start-offset tag-end)))))
- ( -> (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)))))
( -> (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")
+(define-tag-pair "head")
+(define-tag-pair "title")
+(define-tag-pair "body")
+(define-tag-pair
"h1")
+(define-tag-pair
"h2")
+(define-tag-pair
"h3")
+(define-tag-pair
"p")
+(define-tag-pair "ul")
+(define-tag-pair "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 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)
From rstrandh at common-lisp.net Thu Mar 17 05:07:16 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Thu, 17 Mar 2005 06:07:16 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
Message-ID: <20050317050716.5E8A988669@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv9729
Modified Files:
html-syntax.lisp
Log Message:
The HTML syntax module is far from being complete, but it is now
almost entirely cleaned up so that it can be used as a model for
other syntax modules, in particular the Common Lisp syntax module.
Date: Thu Mar 17 06:07:13 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.17 climacs/html-syntax.lisp:1.18
--- climacs/html-syntax.lisp:1.17 Wed Mar 16 08:47:49 2005
+++ climacs/html-syntax.lisp Thu Mar 17 06:07:12 2005
@@ -35,47 +35,11 @@
(defclass html-nonterminal (html-parse-tree) ())
-(defclass words (html-nonterminal) ())
-
-(defclass empty-words (words) ())
-
-(defclass nonempty-words (words)
- ((words :initarg :words)
- (word :initarg :word)))
-
-(defclass html-balanced (html-nonterminal)
- ((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 h1 (html-words) ())
-(defclass h2 (html-words) ())
-(defclass h3 (html-words) ())
-(defclass a (html-words) ())
-(defclass para (html-words) ())
-
(defclass html-token (html-parse-tree)
((ink) (face)))
(defclass html-tag (html-token) ())
-(defclass (html-tag)
- ((start :initarg :start)
- (word :initarg :word)
- (words :initarg :words)
- (end :initarg :end)))
-(defclass (html-tag) ())
-
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; lexer
@@ -116,35 +80,16 @@
;;;
;;; parser
-(defun word-is (word string)
- (string-equal (coerce (region-to-sequence (start-mark word) (end-offset word)) 'string)
- string))
-
(defparameter *html-grammar*
(grammar
- ( -> (tag-start
- (word (and (= (end-offset tag-start) (start-offset word))
- (word-is word "a")))
- words
- tag-end)
- :start tag-start :word word :words words :end tag-end)
- ( -> (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)))))
(html -> ( head body )
- :start :head head :body body :end )
+ : :head head :body body : )
(head -> ( title )
- :start :title title :end )
- (a -> ( words )
- :start :words words :end )
- (words -> ()
- (make-instance 'empty-words))
- (words -> (words word)
- (make-instance 'nonempty-words
- :words words :word word))))
-
+ : :title title : )))
+
+(defun word-is (word string)
+ (string-equal (coerce (region-to-sequence (start-mark word) (end-offset word)) 'string)
+ string))
(defmacro define-start-tag (name string)
`(progn
@@ -275,6 +220,88 @@
(display-parse-tree items syntax pane)
(display-parse-tree syntax pane)))
+;;;;;;;;;;;;;;; -tag
+
+(defclass a-tag-item (html-nonterminal)
+ ((item :initarg :item)))
+
+(add-rule (grammar-rule (a-tag-item -> (word) :item word)) *html-grammar*)
+(add-rule (grammar-rule (a-tag-item -> (delimiter) :item delimiter)) *html-grammar*)
+
+(defmethod display-parse-tree ((entity a-tag-item) (syntax html-syntax) pane)
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
+
+(define-list a-tag-items empty-a-tag-items nonempty-a-tag-items a-tag-item)
+
+(defclass (html-tag)
+ ((start :initarg :start)
+ (name :initarg :name)
+ (items :initarg :items)
+ (end :initarg :end)))
+
+(add-rule (grammar-rule ( -> (tag-start
+ (word (and (= (end-offset tag-start) (start-offset word))
+ (word-is word "a")))
+ a-tag-items
+ tag-end)
+ :start tag-start :name word :items a-tag-items :end tag-end))
+ *html-grammar*)
+
+(defmethod display-parse-tree ((entity ) (syntax html-syntax) pane)
+ (with-slots (start name items end) entity
+ (display-parse-tree start syntax pane)
+ (display-parse-tree name syntax pane)
+ (display-parse-tree items syntax pane)
+ (display-parse-tree end syntax pane)))
+
+(define-end-tag "a")
+
+(defclass a (html-nonterminal)
+ (( :initarg :)
+ (items :initarg :items)
+ ( :initarg :)))
+
+(add-rule (grammar-rule (a -> ( body-items )
+ : :items body-items : ))
+ *html-grammar*)
+
+(defmethod display-parse-tree ((entity a) (syntax html-syntax) pane)
+ (with-slots ( items ) entity
+ (display-parse-tree syntax pane)
+ (display-parse-tree items syntax pane)
+ (display-parse-tree syntax pane)))
+
+;;;;;;;;;;;;;;; head
+
+(defclass head (html-nonterminal)
+ (( :initarg :)
+ (title :initarg :title)
+ ( :initarg :)))
+
+(defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
+ (with-slots ( title ) entity
+ (display-parse-tree syntax pane)
+ (display-parse-tree title syntax pane)
+ (display-parse-tree syntax pane)))
+
+;;;;;;;;;;;;;;; html
+
+(defclass html (html-nonterminal)
+ (( :initarg :)
+ (head :initarg :head)
+ (body :initarg :body)
+ ( :initarg :)))
+
+(defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
+ (with-slots ( head body ) entity
+ (display-parse-tree syntax pane)
+ (display-parse-tree head syntax pane)
+ (display-parse-tree body syntax pane)
+ (display-parse-tree syntax pane)))
+
+;;;;;;;;;;;;;;;
+
(defmethod initialize-instance :after ((syntax html-syntax) &rest args)
(declare (ignore args))
(with-slots (parser lexer buffer) syntax
@@ -374,43 +401,6 @@
(defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane)
(handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
(setf *white-space-start* (end-offset entity)))
-
-(defmethod display-parse-tree :before ((entity html-balanced) (syntax html-syntax) pane)
- (with-slots (start) entity
- (display-parse-tree start syntax pane)))
-
-(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 ((entity html-words) (syntax html-syntax) pane)
- (with-slots (words) entity
- (display-parse-tree words syntax pane)))
-
-(defmethod display-parse-tree ((entity empty-words) (syntax html-syntax) pane)
- (declare (ignore pane))
- nil)
-
-(defmethod display-parse-tree ((entity nonempty-words) (syntax html-syntax) pane)
- (with-slots (words word) entity
- (display-parse-tree words syntax pane)
- (display-parse-tree word syntax pane)))
-
-(defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
- (with-slots (head body) entity
- (display-parse-tree head syntax pane)
- (display-parse-tree body syntax pane)))
-
-(defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
- (with-slots (title) entity
- (display-parse-tree title syntax pane)))
-
-(defmethod display-parse-tree ((entity ) (syntax html-syntax) pane)
- (with-slots (start word words end) entity
- (display-parse-tree start syntax pane)
- (display-parse-tree word syntax pane)
- (display-parse-tree words syntax pane)
- (display-parse-tree end syntax pane)))
(defgeneric display-parse-stack (symbol stack syntax pane))
From rstrandh at common-lisp.net Fri Mar 18 07:49:19 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Fri, 18 Mar 2005 08:49:19 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/packages.lisp climacs/syntax.lisp
Message-ID: <20050318074919.23FC288704@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv4578
Modified Files:
html-syntax.lisp packages.lisp syntax.lisp
Log Message:
Added setf methods for offset of parse-trees. Either a numerical
offset can be given, in which case, the start-mark must exist (since
we don't know the buffer), or else a mark can be given, in which case
it is cloned.
Removed references to start-mark from html-syntax.lisp, and removed it
from the export list of the climacs-syntax package.
Date: Fri Mar 18 08:49:18 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.18 climacs/html-syntax.lisp:1.19
--- climacs/html-syntax.lisp:1.18 Thu Mar 17 06:07:12 2005
+++ climacs/html-syntax.lisp Fri Mar 18 08:49:17 2005
@@ -88,7 +88,7 @@
: :title title : )))
(defun word-is (word string)
- (string-equal (coerce (region-to-sequence (start-mark word) (end-offset word)) 'string)
+ (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
string))
(defmacro define-start-tag (name string)
@@ -309,12 +309,12 @@
:grammar *html-grammar*
:target 'html))
(setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
- (let ((m (clone-mark (low-mark buffer) :left)))
+ (let ((m (clone-mark (low-mark buffer) :left))
+ (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
(setf (offset m) 0)
- (insert-lexeme lexer 0 (make-instance 'start-lexeme
- :start-mark m
- :size 0
- :state (initial-state parser))))))
+ (setf (start-offset lexeme) m
+ (end-offset lexeme) 0)
+ (insert-lexeme lexer 0 lexeme))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -388,8 +388,9 @@
(with-slots (ink face) entity
(setf ink (medium-ink (sheet-medium pane))
face (text-style-face (medium-text-style (sheet-medium pane))))
- (present (coerce (region-to-sequence (start-mark entity)
- (end-offset entity))
+ (present (coerce (buffer-sequence (buffer syntax)
+ (start-offset entity)
+ (end-offset entity))
'string)
'string
:stream pane)))))
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.58 climacs/packages.lisp:1.59
--- climacs/packages.lisp:1.58 Tue Mar 15 13:51:39 2005
+++ climacs/packages.lisp Fri Mar 18 08:49:17 2005
@@ -96,7 +96,6 @@
#: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
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.40 climacs/syntax.lisp:1.41
--- climacs/syntax.lisp:1.40 Wed Mar 16 07:12:10 2005
+++ climacs/syntax.lisp Fri Mar 18 08:49:17 2005
@@ -97,12 +97,38 @@
(when mark
(offset mark))))
+(defmethod (setf start-offset) ((offset number) (tree parse-tree))
+ (let ((mark (start-mark tree)))
+ (assert (not (null mark)))
+ (setf (offset mark) offset)))
+
+(defmethod (setf start-offset) ((offset mark) (tree parse-tree))
+ (with-slots (start-mark) tree
+ (if (null start-mark)
+ (setf start-mark (clone-mark offset))
+ (setf (offset start-mark) (offset offset)))))
+
(defgeneric end-offset (parse-tree))
(defmethod end-offset ((tree parse-tree))
(with-slots (start-mark size) tree
(when start-mark
(+ (offset start-mark) size))))
+
+(defmethod (setf end-offset) ((offset number) (tree parse-tree))
+ (with-slots (start-mark size) tree
+ (assert (not (null start-mark)))
+ (setf size (- offset (offset start-mark)))))
+
+(defmethod (setf end-offset) ((offset mark) (tree parse-tree))
+ (with-slots (start-mark size) tree
+ (assert (not (null start-mark)))
+ (setf size (- (offset offset) (offset start-mark)))))
+
+(defmethod buffer ((tree parse-tree))
+ (let ((start-mark (start-mark tree)))
+ (when start-mark
+ (buffer start-mark))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
From abakic at common-lisp.net Sat Mar 19 22:08:33 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 19 Mar 2005 23:08:33 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp
climacs/pane.lisp
Message-ID: <20050319220833.70B6F88665@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv6185
Modified Files:
climacs.asd gui.lisp pane.lisp
Log Message:
Persistent/persistent-undo.lisp: new file containing the simple
version of the Undo protocol that relies on persistent buffers. Marks
are not persistent (yet?), they are only "fixed" to prevent trivial
errors.
climacs.asd: added Persistent/persistent-undo.lisp.
gui.lisp: added calls to full-redisplay at the end of com-undo and
com-redo (could not find a better way).
pane.lisp: added copyright info; fixed a bug in with-undo macro;
modified extended-binseq2-buffer to inherit from p-undo-mixin; cleaned
up some mark cloning code.
Date: Sat Mar 19 23:08:31 2005
Author: abakic
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.24 climacs/climacs.asd:1.25
--- climacs/climacs.asd:1.24 Sun Mar 13 21:51:48 2005
+++ climacs/climacs.asd Sat Mar 19 23:08:31 2005
@@ -61,6 +61,7 @@
"undo"
"delegating-buffer"
"pane"
+ "Persistent/persistent-undo"
"html-syntax"
"gui"
;;---- optional ----
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.127 climacs/gui.lisp:1.128
--- climacs/gui.lisp:1.127 Sat Mar 5 08:03:52 2005
+++ climacs/gui.lisp Sat Mar 19 23:08:31 2005
@@ -1224,10 +1224,12 @@
;;; Undo/redo
(define-named-command com-undo ()
- (undo (undo-tree (buffer (current-window)))))
+ (undo (undo-tree (buffer (current-window))))
+ (full-redisplay (current-window)))
(define-named-command com-redo ()
- (redo (undo-tree (buffer (current-window)))))
+ (redo (undo-tree (buffer (current-window))))
+ (full-redisplay (current-window)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.22 climacs/pane.lisp:1.23
--- climacs/pane.lisp:1.22 Tue Mar 15 13:51:39 2005
+++ climacs/pane.lisp Sat Mar 19 23:08:31 2005
@@ -4,6 +4,8 @@
;;; Robert Strandh (strandh at labri.fr)
;;; (c) copyright 2005 by
;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr)
+;;; (c) copyright 2005 by
+;;; Aleksandar Bakic (a_bakic at yahoo.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
@@ -106,9 +108,12 @@
, at body
(cond ((null (undo-accumulate ,buffer-var)) nil)
((null (cdr (undo-accumulate ,buffer-var)))
- (add-undo (car (undo-accumulate ,buffer-var)) (undo-tree ,buffer-var)))
+ (add-undo (car (undo-accumulate ,buffer-var))
+ (undo-tree ,buffer-var)))
(t
- (add-undo (make-instance 'compound-record :records (undo-accumulate ,buffer-var))
+ (add-undo (make-instance 'compound-record
+ :buffer ,buffer-var
+ :records (undo-accumulate ,buffer-var))
(undo-tree ,buffer-var)))))))
(defmethod flip-undo-record :around ((record climacs-undo-record))
@@ -185,7 +190,7 @@
(defclass extended-standard-buffer (standard-buffer undo-mixin abbrev-mixin) ()
(:documentation "Extensions accessible via marks."))
-(defclass extended-binseq2-buffer (binseq2-buffer undo-mixin abbrev-mixin) ()
+(defclass extended-binseq2-buffer (binseq2-buffer p-undo-mixin abbrev-mixin) ()
(:documentation "Extensions accessible via marks."))
(defclass climacs-buffer (delegating-buffer filename-mixin name-mixin)
@@ -251,10 +256,10 @@
(defmethod (setf buffer) :after (buffer (pane climacs-pane))
(with-slots (point mark top bot) pane
- (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))))
+ (setf point (clone-mark (low-mark buffer) :right)
+ mark (clone-mark (low-mark buffer) :right)
+ top (clone-mark (low-mark buffer) :left)
+ bot (clone-mark (high-mark buffer) :right))))
(define-presentation-type url ()
:inherit-from 'string)
From abakic at common-lisp.net Sat Mar 19 22:08:34 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 19 Mar 2005 23:08:34 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Persistent/persistent-undo.lisp
Message-ID: <20050319220834.AA40488704@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv6185/Persistent
Added Files:
persistent-undo.lisp
Log Message:
Persistent/persistent-undo.lisp: new file containing the simple
version of the Undo protocol that relies on persistent buffers. Marks
are not persistent (yet?), they are only "fixed" to prevent trivial
errors.
climacs.asd: added Persistent/persistent-undo.lisp.
gui.lisp: added calls to full-redisplay at the end of com-undo and
com-redo (could not find a better way).
pane.lisp: added copyright info; fixed a bug in with-undo macro;
modified extended-binseq2-buffer to inherit from p-undo-mixin; cleaned
up some mark cloning code.
Date: Sat Mar 19 23:08:33 2005
Author: abakic
From rstrandh at common-lisp.net Sun Mar 20 08:25:25 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sun, 20 Mar 2005 09:25:25 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
Message-ID: <20050320082525.68F3088704@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv9267
Modified Files:
html-syntax.lisp
Log Message:
Factored out the rules for `html' and `head' so that they now
use add-rule.
Date: Sun Mar 20 09:25:21 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.19 climacs/html-syntax.lisp:1.20
--- climacs/html-syntax.lisp:1.19 Fri Mar 18 08:49:17 2005
+++ climacs/html-syntax.lisp Sun Mar 20 09:25:21 2005
@@ -80,12 +80,7 @@
;;;
;;; parser
-(defparameter *html-grammar*
- (grammar
- (html -> ( head body )
- : :head head :body body : )
- (head -> ( title )
- : :title title : )))
+(defparameter *html-grammar* (grammar))
(defun word-is (word string)
(string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
@@ -279,6 +274,10 @@
(title :initarg :title)
( :initarg :)))
+(add-rule (grammar-rule (head -> ( title )
+ : :title title : ))
+ *html-grammar*)
+
(defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
(with-slots ( title ) entity
(display-parse-tree syntax pane)
@@ -292,6 +291,10 @@
(head :initarg :head)
(body :initarg :body)
( :initarg :)))
+
+(add-rule (grammar-rule (html -> ( head body )
+ : :head head :body body : ))
+ *html-grammar*)
(defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
(with-slots ( head body ) entity
From abakic at common-lisp.net Sun Mar 20 22:03:41 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 20 Mar 2005 23:03:41 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/TODO
Message-ID: <20050320220341.6A857886FB@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv28527
Modified Files:
TODO
Log Message:
Update.
Date: Sun Mar 20 23:03:40 2005
Author: abakic
Index: climacs/TODO
diff -u climacs/TODO:1.6 climacs/TODO:1.7
--- climacs/TODO:1.6 Sun Mar 13 21:51:48 2005
+++ climacs/TODO Sun Mar 20 23:03:40 2005
@@ -1,6 +1,6 @@
-- modify standard-buffer to use obinseq with leafs containing
- flexichain-based lines
+- modify standard-buffer to use an obinseq-based structure for faster
+ line operations
-- upgrade persistent buffer based on binseq2 to an undoable buffer
+- speed up com-goto-line (when possible)
- replace the use of the scroller pane by custom pane
From abakic at common-lisp.net Wed Mar 23 18:07:05 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Wed, 23 Mar 2005 19:07:05 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/climacs.asd
Message-ID: <20050323180705.506918866D@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv4715
Modified Files:
climacs.asd
Log Message:
File order fix for the new cmucl.
Date: Wed Mar 23 19:07:04 2005
Author: abakic
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.25 climacs/climacs.asd:1.26
--- climacs/climacs.asd:1.25 Sat Mar 19 23:08:31 2005
+++ climacs/climacs.asd Wed Mar 23 19:07:03 2005
@@ -60,8 +60,8 @@
"kill-ring"
"undo"
"delegating-buffer"
- "pane"
"Persistent/persistent-undo"
+ "pane"
"html-syntax"
"gui"
;;---- optional ----
From crhodes at common-lisp.net Sun Mar 27 14:29:34 2005
From: crhodes at common-lisp.net (Christophe Rhodes)
Date: Sun, 27 Mar 2005 16:29:34 +0200 (CEST)
Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp
climacs/climacs.asd climacs/packages.lisp
Message-ID: <20050327142934.38B9A88672@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv31952
Modified Files:
climacs.asd packages.lisp
Added Files:
prolog-syntax.lisp
Log Message:
Add a half-baked half-finished ISO Prolog syntax.
Known internal lacunae:
* does not handle quotations correctly:
** fails to recognize '' as an escaped quote character (and similarly
for other quote characters);
** fails to canonize quoted atoms; will fail to identify the operator
; from the quoted atom ';';
** does not contain any logic for backslash-escaped data.
* does not implement parsing floating point numbers.
* comments before directives get italicized.
* way too long. Expect some refactoring.
Known suboptimal interactions with the syntax framework:
* parses the entire buffer at every keystroke; incremental parsing caused
a problem at some point and has not (yet) been restored.
* displays the entire buffer at every keystroke.
* the incremental lexer gets confused in the presence of comments.
(see forthcoming mail to climacs-devel)
Date: Sun Mar 27 16:29:32 2005
Author: crhodes
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.26 climacs/climacs.asd:1.27
--- climacs/climacs.asd:1.26 Wed Mar 23 19:07:03 2005
+++ climacs/climacs.asd Sun Mar 27 16:29:32 2005
@@ -63,6 +63,7 @@
"Persistent/persistent-undo"
"pane"
"html-syntax"
+ "prolog-syntax"
"gui"
;;---- optional ----
"testing/rt"
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.59 climacs/packages.lisp:1.60
--- climacs/packages.lisp:1.59 Fri Mar 18 08:49:17 2005
+++ climacs/packages.lisp Sun Mar 27 16:29:32 2005
@@ -147,6 +147,11 @@
(:use :clim-lisp :clim :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane))
+(defpackage :climacs-prolog-syntax
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ :climacs-syntax :flexichain :climacs-pane)
+ (:shadow "ATOM" "CLOSE" "EXP" "INTEGER" "OPEN" "VARIABLE"))
+
(defpackage :climacs-gui
(:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax
:climacs-kill-ring :climacs-pane :clim-extensions :undo))
From crhodes at common-lisp.net Sun Mar 27 15:59:01 2005
From: crhodes at common-lisp.net (Christophe Rhodes)
Date: Sun, 27 Mar 2005 17:59:01 +0200 (CEST)
Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp
Message-ID: <20050327155901.B018088672@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv4579
Modified Files:
prolog-syntax.lisp
Log Message:
"Concision is equivalent to powerfulness"
Delete about 120 lines by defining define-prolog-rule to wrap around
ADD-RULE.
More known lacunae
* [A,B] does not parse properly.
* quoted tokens confuse the incremental lexer.
Date: Sun Mar 27 17:59:00 2005
Author: crhodes
Index: climacs/prolog-syntax.lisp
diff -u climacs/prolog-syntax.lisp:1.1 climacs/prolog-syntax.lisp:1.2
--- climacs/prolog-syntax.lisp:1.1 Sun Mar 27 16:29:32 2005
+++ climacs/prolog-syntax.lisp Sun Mar 27 17:59:00 2005
@@ -33,6 +33,9 @@
(defparameter *prolog-grammar* (grammar))
+(defmacro define-prolog-rule ((&rest rule) &body body)
+ `(add-rule (grammar-rule (, at rule , at body)) *prolog-grammar*))
+
(defmethod initialize-instance :after ((syntax prolog-syntax) &rest args)
(declare (ignore args))
(with-slots (parser lexer buffer) syntax
@@ -97,15 +100,11 @@
(layout-text entity) syntax pane))
(display-parse-tree
(syntactic-lexeme entity) syntax pane))
- (add-rule (grammar-rule (,name -> (,(f name))
- (make-instance ',name
- :syntactic-lexeme ,(f name))))
- *prolog-grammar*)
- (add-rule (grammar-rule (,name -> (layout-text ,(f name))
- (make-instance ',name
- :layout-text layout-text
- :syntactic-lexeme ,(f name))))
- *prolog-grammar*)))
+ (define-prolog-rule (,name -> (,(f name)))
+ (make-instance ',name :syntactic-lexeme ,(f name)))
+ (define-prolog-rule (,name -> (layout-text ,(f name)))
+ (make-instance ',name :layout-text layout-text
+ :syntactic-lexeme ,(f name)))))
,@(loop for sub in subs collect
`(defclass ,(f sub) (,(f name)) ()))))))
(def (comment) single-line-comment bracketed-comment)
@@ -128,15 +127,11 @@
(def (error)))
-(add-rule (grammar-rule (layout-text -> (comment-lexeme layout-text)
- (make-instance 'layout-text
- :comment comment-lexeme
- :cont layout-text)))
- *prolog-grammar*)
-(add-rule (grammar-rule (layout-text -> ()
- (make-instance 'layout-text
- :cont nil)))
- *prolog-grammar*)
+;;; 6.4.1
+(define-prolog-rule (layout-text -> (comment-lexeme layout-text))
+ (make-instance 'layout-text :comment comment-lexeme :cont layout-text))
+(define-prolog-rule (layout-text -> ())
+ (make-instance 'layout-text :cont nil))
(defclass prolog-lexer (incremental-lexer) ())
@@ -519,125 +514,79 @@
(display-parse-tree (tlist entity) syntax pane))
;;; 6.2.1
-(add-rule (grammar-rule (prolog-text -> (directive prolog-text)
- (make-instance 'directive-prolog-text
- :directive directive
- :text-rest prolog-text)))
- *prolog-grammar*)
-(add-rule (grammar-rule (prolog-text -> (clause prolog-text)
- (make-instance 'clause-prolog-text
- :clause clause
- :text-rest prolog-text)))
- *prolog-grammar*)
-(add-rule (grammar-rule (prolog-text -> ()
- (make-instance 'empty-prolog-text)))
- *prolog-grammar*)
+(define-prolog-rule (prolog-text -> (directive prolog-text))
+ (make-instance 'directive-prolog-text :directive directive
+ :text-rest prolog-text))
+(define-prolog-rule (prolog-text -> (clause prolog-text))
+ (make-instance 'clause-prolog-text :clause clause :text-rest prolog-text))
+(define-prolog-rule (prolog-text -> ())
+ (make-instance 'empty-prolog-text))
;;; 6.2.1.1
-(add-rule (grammar-rule (directive -> (directive-term end)
- (make-instance 'directive
- :directive-term directive-term
- :end end)))
- *prolog-grammar*)
-(add-rule (grammar-rule (directive-term -> ((term (and (compound-term-p term)
- (string= (lexeme-string (syntactic-lexeme (functor term))) ":-")
- (= (arity term) 1))))
- (make-instance 'directive-term
- :term term)))
- *prolog-grammar*)
+(defun term-directive-p (term)
+ (and (compound-term-p term)
+ (string= (lexeme-string (syntactic-lexeme (functor term))) ":-")
+ (= (arity term) 1)))
+
+(define-prolog-rule (directive -> (directive-term end))
+ (make-instance 'directive :directive-term directive-term :end end))
+(define-prolog-rule (directive-term -> ((term (term-directive-p term))))
+ (make-instance 'directive-term :term term))
;;; 6.2.1.2
-(add-rule (grammar-rule (clause -> (clause-term end)
- (make-instance 'clause
- :clause-term clause-term
- :end end)))
- *prolog-grammar*)
-(add-rule (grammar-rule (clause-term -> ((term (not (and (compound-term-p term)
- (string= (lexeme-string (syntactic-lexeme (functor term))) ":-")
- (= (arity term) 1)))))
- (make-instance 'clause-term
- :term term)))
- *prolog-grammar*)
+(define-prolog-rule (clause -> (clause-term end))
+ (make-instance 'clause :clause-term clause-term :end end))
+(define-prolog-rule (clause-term -> ((term (not (term-directive-p term)))))
+ (make-instance 'clause-term :term term))
;;; 6.3.1.1
-(add-rule (grammar-rule (term -> (integer)
- (make-instance 'constant-term
- :priority 0
- :value integer)))
- *prolog-grammar*)
+(define-prolog-rule (term -> (integer))
+ (make-instance 'constant-term :priority 0 :value integer))
+
;;; 6.3.1.2
-(add-rule (grammar-rule (term -> ((atom (string= (lexeme-string (syntactic-lexeme atom)) "-"))
- integer)
- (make-instance 'constant-term
- :priority 0
- :value (list atom integer))))
- *prolog-grammar*)
+(define-prolog-rule (term -> ((atom
+ (string= (lexeme-string (syntactic-lexeme atom))
+ "-"))
+ integer))
+ ;; FIXME: this doesn't really look right.
+ (make-instance 'constant-term :priority 0 :value (list atom integer)))
+
;;; 6.3.1.3
-(add-rule (grammar-rule (term -> ((atom (not (operatorp atom))))
- (make-instance 'constant-term
- :priority 0
- :value atom)))
- *prolog-grammar*)
-(add-rule (grammar-rule (term -> ((atom (operatorp atom)))
- (make-instance 'constant-term
- :priority 1201
- :value atom)))
- *prolog-grammar*)
-
-(add-rule (grammar-rule (atom -> (name)
- (make-instance 'atom :value name)))
- *prolog-grammar*)
-(add-rule (grammar-rule (atom -> (empty-list)
- (make-instance 'atom :value empty-list)))
- *prolog-grammar*)
-(add-rule (grammar-rule (atom -> (curly-brackets)
- (make-instance 'atom :value curly-brackets)))
- *prolog-grammar*)
-(add-rule (grammar-rule (empty-list -> (open-list close-list)
- (make-instance 'empty-list
- :[ open-list
- :] close-list)))
- *prolog-grammar*)
-(add-rule (grammar-rule (curly-brakets -> (open-curly close-curly)
- (make-instance 'curly-brackets
- :{ open-curly
- :} close-curly)))
- *prolog-grammar*)
+(define-prolog-rule (term -> ((atom (not (operatorp atom)))))
+ (make-instance 'constant-term :priority 0 :value atom))
+(define-prolog-rule (term -> ((atom (operatorp atom))))
+ (make-instance 'constant-term :priority 1201 :value atom))
+
+(define-prolog-rule (atom -> (name))
+ (make-instance 'atom :value name))
+(define-prolog-rule (atom -> (empty-list))
+ (make-instance 'atom :value empty-list))
+(define-prolog-rule (atom -> (curly-brackets))
+ (make-instance 'atom :value curly-brackets))
+(define-prolog-rule (empty-list -> (open-list close-list))
+ (make-instance 'empty-list :[ open-list :] close-list))
+(define-prolog-rule (curly-brakets -> (open-curly close-curly))
+ (make-instance 'curly-brackets :{ open-curly :} close-curly))
;;; 6.3.2
-(add-rule (grammar-rule (term -> (variable)
- (make-instance 'variable-term
- :priority 0
- :name variable)))
- *prolog-grammar*)
+(define-prolog-rule (term -> (variable))
+ (make-instance 'variable-term :priority 0 :name variable))
;;; 6.3.3
-(add-rule (grammar-rule (term -> (atom open-ct-lexeme arg-list close)
- (make-instance 'functional-compound-term
- :priority 0
- :functor atom
- :arg-list arg-list
- :open-ct open-ct-lexeme
- :close close)))
- *prolog-grammar*)
-(add-rule (grammar-rule (arg-list -> (exp)
- (make-instance 'arg-list :exp exp)))
- *prolog-grammar*)
-(add-rule (grammar-rule (arg-list -> (exp comma arg-list)
- (make-instance 'arg-list-pair
- :exp exp
- :comma comma
- :arg-list arg-list)))
- *prolog-grammar*)
+(define-prolog-rule (term -> (atom open-ct-lexeme arg-list close))
+ (make-instance 'functional-compound-term :priority 0 :functor atom
+ :arg-list arg-list :open-ct open-ct-lexeme :close close))
+(define-prolog-rule (arg-list -> (exp))
+ (make-instance 'arg-list :exp exp))
+(define-prolog-rule (arg-list -> (exp comma arg-list))
+ (make-instance 'arg-list-pair :exp exp :comma comma :arg-list arg-list))
;;; 6.3.3.1
-(add-rule (grammar-rule (exp -> ((atom (and (operatorp atom)
- (not (typep (value atom) 'comma)))))
- (make-instance 'exp-atom :atom atom)))
- *prolog-grammar*)
-(add-rule (grammar-rule (exp -> ((term (<= (priority term) 999)))
- (make-instance 'exp-term :term term)))
- *prolog-grammar*)
+(define-prolog-rule (exp -> ((atom (and (operatorp atom)
+ (not (typep (value atom) 'comma))))))
+ (make-instance 'exp-atom :atom atom))
+(define-prolog-rule (exp -> ((term (<= (priority term) 999))))
+ (make-instance 'exp-term :term term))
;;; 6.3.4.1
@@ -658,173 +607,113 @@
;;; term would be, by explicitly writing the second production rule
;;; out here, and by using inegality tests rather than equalities for
;;; priorities elsewhere. LTERMs act as containers for terms.
-(add-rule (grammar-rule (lterm -> (term)
- (make-instance 'lterm
- :term term
- :priority (1+ (priority term)))))
- *prolog-grammar*)
-
-(add-rule (grammar-rule (term -> (open (term (<= (priority term) 1201))
- close)
- (make-instance 'bracketed-term
- :priority 0
- :open open
- :term term
- :close close)))
- *prolog-grammar*)
-(add-rule (grammar-rule (term -> (open-ct-lexeme
- (term (<= (priority term) 1201))
- close)
- (make-instance 'bracketed-term
- :priority 0
- :open open-ct-lexeme
- :term term
- :close close)))
- *prolog-grammar*)
+(define-prolog-rule (lterm -> (term))
+ (make-instance 'lterm :term term :priority (1+ (priority term))))
+
+(define-prolog-rule (term -> (open (term (<= (priority term) 1201)) close))
+ (make-instance 'bracketed-term :priority 0
+ :open open :term term :close close))
+(define-prolog-rule (term -> (open-ct-lexeme
+ (term (<= (priority term) 1201))
+ close))
+ (make-instance 'bracketed-term :priority 0
+ :open open-ct-lexeme :term term :close close))
;;; 6.3.4.2
;;;
;;; NOTE NOTE NOTE
;;;
-;;; We rely here on the (undocumented) fact that returning NIL from
+;;; We rely here on the (undocumented?) fact that returning NIL from
;;; the body of these rules implies a failure.
-(add-rule (grammar-rule (lterm -> ((left term) (op (eql (specifier op) :xfx)) (right term))
- (when (and (< (priority left) (priority op))
- (< (priority right) (priority op)))
- (make-instance 'lterm
- :priority (priority op)
- :term
- (make-instance 'binary-operator-compound-term
- :left left
- :operator op
- :right right)))))
- *prolog-grammar*)
-(add-rule (grammar-rule (lterm -> ((left lterm) (op (eql (specifier op) :yfx)) (right term))
- (when (and (<= (priority left) (priority op))
- (< (priority right) (priority op)))
- (make-instance 'lterm
- :priority (priority op)
- :term
- (make-instance 'binary-operator-compound-term
- :left left
- :operator op
- :right right)))))
- *prolog-grammar*)
-(add-rule (grammar-rule (term -> ((left term) (op (eql (specifier op) :xfy)) (right term))
- (when (and (< (priority left) (priority op))
- (<= (priority right) (priority op)))
- (make-instance 'binary-operator-compound-term
- :priority (priority op)
- :left left
- :operator op
- :right right))))
- *prolog-grammar*)
-(add-rule (grammar-rule (lterm -> (lterm (op (eql (specifier op) :yf)))
- (when (<= (priority lterm) (priority op))
- (make-instance 'lterm
- :priority (priority op)
- :term
- (make-instance 'postfix-operator-compound-term
- :left lterm
- :operator op)))))
- *prolog-grammar*)
-(add-rule (grammar-rule (lterm -> (term (op (eql (specifier op) :xf)))
- (when (< (priority term) (priority op))
- (make-instance 'lterm
- :priority (priority op)
- :term
- (make-instance 'postfix-operator-compound-term
- :left term
- :operator op)))))
- *prolog-grammar*)
-(add-rule (grammar-rule (term -> ((op (eql (specifier op) :fy)) term)
- (when (and (or (not (string= (lexeme-string (syntactic-lexeme op)) "-"))
- (not (numeric-constant-p term)))
- (not (typep (first-lexeme term) 'open-ct-lexeme))
- (<= (priority term) (priority op)))
- (make-instance 'prefix-operator-compound-term
- :right term
- :operator op
- :priority (priority op)))))
- *prolog-grammar*)
-(add-rule (grammar-rule (lterm -> ((op (eql (specifier op) :fx)) term)
- (when (and (or (not (string= (lexeme-string (syntactic-lexeme op)) "-"))
- (not (numeric-constant-p term)))
- (not (typep (first-lexeme term) 'open-ct-lexeme))
- (< (priority term) (priority op)))
- (make-instance 'lterm
- :priority (priority op)
- :term
- (make-instance 'prefix-operator-compound-term
- :right term
- :operator op)))))
- *prolog-grammar*)
+(define-prolog-rule (lterm -> ((left term)
+ (op (eql (specifier op) :xfx))
+ (right term)))
+ (when (and (< (priority left) (priority op))
+ (< (priority right) (priority op)))
+ (make-instance 'lterm :priority (priority op) :term
+ (make-instance 'binary-operator-compound-term
+ :left left :operator op :right right))))
+(define-prolog-rule (lterm -> ((left lterm)
+ (op (eql (specifier op) :yfx))
+ (right term)))
+ (when (and (<= (priority left) (priority op))
+ (< (priority right) (priority op)))
+ (make-instance 'lterm :priority (priority op) :term
+ (make-instance 'binary-operator-compound-term
+ :left left :operator op :right right))))
+(define-prolog-rule (term -> ((left term)
+ (op (eql (specifier op) :xfy))
+ (right term)))
+ (when (and (< (priority left) (priority op))
+ (<= (priority right) (priority op)))
+ (make-instance 'binary-operator-compound-term :priority (priority op)
+ :left left :operator op :right right)))
+(define-prolog-rule (lterm -> (lterm (op (eql (specifier op) :yf))))
+ (when (<= (priority lterm) (priority op))
+ (make-instance 'lterm :priority (priority op) :term
+ (make-instance 'postfix-operator-compound-term
+ :left lterm :operator op))))
+(define-prolog-rule (lterm -> (term (op (eql (specifier op) :xf))))
+ (when (< (priority term) (priority op))
+ (make-instance 'lterm :priority (priority op) :term
+ (make-instance 'postfix-operator-compound-term
+ :left term :operator op))))
+(define-prolog-rule (term -> ((op (eql (specifier op) :fy)) term))
+ (when (and (or (not (string= (lexeme-string (syntactic-lexeme op)) "-"))
+ (not (numeric-constant-p term)))
+ (not (typep (first-lexeme term) 'open-ct-lexeme))
+ (<= (priority term) (priority op)))
+ (make-instance 'prefix-operator-compound-term
+ :right term :operator op :priority (priority op))))
+(define-prolog-rule (lterm -> ((op (eql (specifier op) :fx)) term))
+ (when (and (or (not (string= (lexeme-string (syntactic-lexeme op)) "-"))
+ (not (numeric-constant-p term)))
+ (not (typep (first-lexeme term) 'open-ct-lexeme))
+ (< (priority term) (priority op)))
+ (make-instance 'lterm :priority (priority op) :term
+ (make-instance 'prefix-operator-compound-term
+ :right term :operator op))))
;;; 6.3.4.3
-(macrolet ((add (class &rest specifiers)
+(macrolet ((def (class &rest specifiers)
`(progn
- (add-rule (grammar-rule (,class -> (name)
- (let ((opspec (find-predefined-operator name ',specifiers)))
- (when opspec
- (make-instance ',class
- :name name
- :priority (opspec-priority opspec)
- :specifier (opspec-specifier opspec))))))
- *prolog-grammar*)
- (add-rule (grammar-rule (,class -> (name)
- (let ((opspec (find-defined-operator name ',specifiers)))
- (when opspec
- (make-instance ',class
- :name name
- :priority (opspec-priority opspec)
- :specifier (opspec-specifier opspec))))))
- *prolog-grammar*))))
- (add prefix-op :fx :fy)
- (add binary-op :xfx :xfy :yfx)
- (add postfix-op :xf :yf))
-(add-rule (grammar-rule (op -> (comma)
- (make-instance 'op
- :name comma
- :priority 1000
- :specifier :xfy)))
- *prolog-grammar*)
+ (define-prolog-rule (,class -> (name))
+ (let ((opspec (find-predefined-operator name ',specifiers)))
+ (when opspec
+ (make-instance ',class :name name
+ :priority (opspec-priority opspec)
+ :specifier (opspec-specifier opspec)))))
+ (define-prolog-rule (,class -> (name))
+ (let ((opspec (find-defined-operator name ',specifiers)))
+ (when opspec
+ (make-instance ',class :name name
+ :priority (opspec-priority opspec)
+ :specifier (opspec-specifier opspec))))))))
+ (def prefix-op :fx :fy)
+ (def binary-op :xfx :xfy :yfx)
+ (def postfix-op :xf :yf))
+(define-prolog-rule (op -> (comma))
+ (make-instance 'op :name comma :priority 1000 :specifier :xfy))
;;; 6.3.5
-(add-rule (grammar-rule (term -> (open-list items close-list)
- (make-instance 'list-compound-term
- :priority 0
- :[ open-list
- :items items
- :] close-list)))
- *prolog-grammar*)
-(add-rule (grammar-rule (items -> (exp comma items)
- (make-instance 'items-list
- :exp exp
- :comma comma
- :tlist items)))
- *prolog-grammar*)
-(add-rule (grammar-rule (items -> ((left exp) head-tail-separator (right exp))
- (make-instance 'items-pair
- :exp left
- :htsep head-tail-separator
- :texp right)))
- *prolog-grammar*)
+(define-prolog-rule (term -> (open-list items close-list))
+ (make-instance 'list-compound-term :priority 0
+ :[ open-list :items items :] close-list))
+(define-prolog-rule (items -> (exp comma items))
+ (make-instance 'items-list :exp exp :comma comma :tlist items))
+(define-prolog-rule (items -> ((left exp) head-tail-separator (right exp)))
+ (make-instance 'items-pair :exp left
+ :htsep head-tail-separator :texp right))
;;; 6.3.6
-(add-rule (grammar-rule (term -> (open-curly term close-curly)
- (make-instance 'curly-compound-term
- :priority 0
- :{ open-curly
- :term term
- :} close-curly)))
- *prolog-grammar*)
+(define-prolog-rule (term -> (open-curly term close-curly))
+ (make-instance 'curly-compound-term :priority 0
+ :{ open-curly :term term :} close-curly))
;;; 6.3.7
-(add-rule (grammar-rule (term -> (char-code-list)
- (make-instance 'char-code-list-compound-term
- :priority 0
- :ccl char-code-list)))
- *prolog-grammar*)
+(define-prolog-rule (term -> (char-code-list))
+ (make-instance 'char-code-list-compound-term
+ :priority 0 :ccl char-code-list))
(defparameter *predefined-operators* nil)
(defstruct (opspec (:type list))
@@ -970,7 +859,7 @@
:stream pane))))
;;; KLUDGE: below this line, this is just s/html/prolog/ on the
-;;; definitions in html-syntax.lips
+;;; definitions in html-syntax.lisp
(defmethod display-parse-tree :before ((entity prolog-token) (syntax prolog-syntax) pane)
(handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
From crhodes at common-lisp.net Sun Mar 27 16:22:47 2005
From: crhodes at common-lisp.net (Christophe Rhodes)
Date: Sun, 27 Mar 2005 18:22:47 +0200 (CEST)
Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp
Message-ID: <20050327162247.A48A588672@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv6641
Modified Files:
prolog-syntax.lisp
Log Message:
Parse [A,B]-style lists correctly.
Date: Sun Mar 27 18:22:46 2005
Author: crhodes
Index: climacs/prolog-syntax.lisp
diff -u climacs/prolog-syntax.lisp:1.2 climacs/prolog-syntax.lisp:1.3
--- climacs/prolog-syntax.lisp:1.2 Sun Mar 27 17:59:00 2005
+++ climacs/prolog-syntax.lisp Sun Mar 27 18:22:45 2005
@@ -704,6 +704,8 @@
(define-prolog-rule (items -> ((left exp) head-tail-separator (right exp)))
(make-instance 'items-pair :exp left
:htsep head-tail-separator :texp right))
+(define-prolog-rule (items -> (exp))
+ (make-instance 'items :exp exp))
;;; 6.3.6
(define-prolog-rule (term -> (open-curly term close-curly))
From crhodes at common-lisp.net Sun Mar 27 16:58:21 2005
From: crhodes at common-lisp.net (Christophe Rhodes)
Date: Sun, 27 Mar 2005 18:58:21 +0200 (CEST)
Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp
Message-ID: <20050327165821.9976988672@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv8369
Modified Files:
prolog-syntax.lisp
Log Message:
an alpha numeric char in ISO prolog is either alphanumericp or eql to #\_
Date: Sun Mar 27 18:58:20 2005
Author: crhodes
Index: climacs/prolog-syntax.lisp
diff -u climacs/prolog-syntax.lisp:1.3 climacs/prolog-syntax.lisp:1.4
--- climacs/prolog-syntax.lisp:1.3 Sun Mar 27 18:22:45 2005
+++ climacs/prolog-syntax.lisp Sun Mar 27 18:58:20 2005
@@ -180,7 +180,9 @@
(t (fo) (return (make-instance 'error-lexeme))))
IDENTIFIER
(loop until (end-of-buffer-p scan)
- while (alphanumericp (object-after scan))
+ while (let ((object (object-after scan)))
+ (or (alphanumericp object)
+ (eql object #\_)))
do (fo))
(return (make-instance 'identifier-lexeme))
LINE-COMMENT
@@ -239,12 +241,16 @@
(return (make-instance 'quoted-lexeme))))
VARIABLE
(if (or (end-of-buffer-p scan)
- (not (alphanumericp (object-after scan))))
+ (let ((object (object-after scan)))
+ (not (or (alphanumericp object)
+ (eql object #\_)))))
(return (make-instance 'anonymous-lexeme))
(go NAMED-VARIABLE))
NAMED-VARIABLE
(loop until (end-of-buffer-p scan)
- while (alphanumericp (object-after scan))
+ while (let ((object (object-after scan)))
+ (or (alphanumericp object)
+ (eql object #\_)))
do (fo))
(return (make-instance 'named-lexeme))
NUMBER
From crhodes at common-lisp.net Thu Mar 31 10:16:24 2005
From: crhodes at common-lisp.net (Christophe Rhodes)
Date: Thu, 31 Mar 2005 12:16:24 +0200 (CEST)
Subject: [climacs-cvs] CVS update: climacs/prolog-syntax.lisp
Message-ID: <20050331101624.D6E828866B@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv26897
Modified Files:
prolog-syntax.lisp
Log Message:
Fix a typo: "brakets" -> "brackets"
Date: Thu Mar 31 12:16:23 2005
Author: crhodes
Index: climacs/prolog-syntax.lisp
diff -u climacs/prolog-syntax.lisp:1.4 climacs/prolog-syntax.lisp:1.5
--- climacs/prolog-syntax.lisp:1.4 Sun Mar 27 18:58:20 2005
+++ climacs/prolog-syntax.lisp Thu Mar 31 12:16:23 2005
@@ -571,7 +571,7 @@
(make-instance 'atom :value curly-brackets))
(define-prolog-rule (empty-list -> (open-list close-list))
(make-instance 'empty-list :[ open-list :] close-list))
-(define-prolog-rule (curly-brakets -> (open-curly close-curly))
+(define-prolog-rule (curly-brackets -> (open-curly close-curly))
(make-instance 'curly-brackets :{ open-curly :} close-curly))
;;; 6.3.2