climacs-cvs March 2005

climacs-cvs@common-lisp.net

3 participants
40 discussions

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

11 Mar '05

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> (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)) +(defclass <html> (html-tag) () (:default-initargs :size 6)) +(defclass </html> (html-tag) ()(:default-initargs :size 7)) +(defclass <head> (html-tag) () (:default-initargs :size 6)) +(defclass </head> (html-tag) () (:default-initargs :size 7)) +(defclass <title> (html-tag) () (:default-initargs :size 7)) +(defclass </title> (html-tag) () (:default-initargs :size 8)) +(defclass <body> (html-tag) () (:default-initargs :size 6)) +(defclass </body> (html-tag) () (:default-initargs :size 7)) +(defclass <h1> (html-tag) () (:default-initargs :size 4)) +(defclass </h1> (html-tag) () (:default-initargs :size 5)) +(defclass <h2> (html-tag) () (:default-initargs :size 4)) +(defclass </h2> (html-tag) () (:default-initargs :size 5)) +(defclass <h3> (html-tag) () (:default-initargs :size 4)) +(defclass </h3> (html-tag) () (:default-initargs :size 5)) +(defclass <p> (html-tag) () (:default-initargs :size 3)) +(defclass </p> (html-tag) () (:default-initargs :size 4)) +(defclass <ul> (html-tag) () (:default-initargs :size 4)) +(defclass </ul> (html-tag) () (:default-initargs :size 5)) +(defclass <li> (html-tag) () (:default-initargs :size 4)) +(defclass </li> (html-tag) () (:default-initargs :size 5)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -199,23 +206,27 @@ (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-mark (start-mark <html>) + :size (- (end-offset </html>) (start-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-mark (start-mark <head>) + :size (- (end-offset </head>) (start-offset <head>)) :start <head> :title title :end </head>) (title -> (<title> words </title>) - :start-offset (start-offset <title>) :end-offset (end-offset </title>) + :start-mark (start-mark <title>) + :size (- (end-offset </title>) (start-offset <title>)) :start <title> :words words :end </title>) (body -> (<body> words </body>) - :start-offset (start-offset <body>) :end-offset (end-offset </body>) + :start-mark (start-mark <body>) + :size (- (end-offset </body>) (start-offset <body>)) :start <body> :words words :end </body>) (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)))

1 0

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

10 Mar '05

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

1 0

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

07 Mar '05

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

1 0

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

05 Mar '05

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

1 0

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

05 Mar '05

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

1 0

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

05 Mar '05

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

1 0

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

05 Mar '05

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

1 0

[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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs March 2005