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

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

05 Mar '05

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 -@deffn {generic function} {(setf kill-ring-max-size)} kill-ring size +@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

1 0

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

05 Mar '05

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 -> (<html> head body </html>) + :start-offset (start-offset <html>) :end-offset (end-offset </html>) :start <html> :head head :body body :end </html>) (head -> (<head> title </head>) + :start-offset (start-offset <head>) :end-offset (end-offset </head>) :start <head> :title title :end </head>) (title -> (<title> words </title>) + :start-offset (start-offset <title>) :end-offset (end-offset </title>) :start <title> :words words :end </title>) (body -> (<body> words </body>) + :start-offset (start-offset <body>) :end-offset (end-offset </body>) :start <body> :words words :end </body>) (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))

1 0

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

04 Mar '05

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

1 0

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

02 Mar '05

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

1 0

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

02 Mar '05

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

1 0

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

02 Mar '05

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

1 0

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

01 Mar '05

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. +@section Incremental parsing framework + +@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. + +@subsection Specifying a grammar + +An incremental parser is created from a grammar. + +@deffn {Macro} {grammar} &body rules + +Create a grammar object from a set of rules +@end deffn + +@deffn {Rule} {} symbol -> (&rest arguments) &optional body + +Each rule is a list of this form. +@end deffn + +@noindent +Here @var{symbol} is the target symbol of the rule, and should be the name of +a CLOS class. + +@deffn {Rule argument} {} (var type test) + +The most general form of a rule argument. +@end deffn + +@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. + +@deffn {Rule argument} {} (var type) + +Abbreviated form of a rule argument. +@end deffn + +@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)}. + +@deffn {Rule argument} {} (var test) + +Abbreviated form of a rule argument. +@end deffn + +@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. + +@deffn {Rule argument} {} var + +Abbreviated form of a rule argument. +@end deffn + +@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 +@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

1 0

[climacs-cvs] CVS update: climacs/climacs.asd
by rstrandh＠common-lisp.net 01 Mar '05

01 Mar '05

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"

1 0

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

28 Feb '05

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

1 0

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

27 Feb '05

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

1 0