[climacs-cvs] CVS update: climacs/lisp-syntax.lisp

[Robert Strandh]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv27858

Modified Files:
	lisp-syntax.lisp 
Log Message:
Order-of-magnitude improvement in the speed of the incremental
LR parser.

Date: Wed Jun  1 18:42:28 2005
Author: rstrandh

Index: climacs/lisp-syntax.lisp
diff -u climacs/lisp-syntax.lisp:1.4 climacs/lisp-syntax.lisp:1.5
--- climacs/lisp-syntax.lisp:1.4	Mon May 30 15:47:21 2005
+++ climacs/lisp-syntax.lisp	Wed Jun  1 18:42:28 2005
@@ -365,6 +365,15 @@
 	do (push (pop-one syntax) result)
 	finally (return result)))
 
+(defmacro reduce-fixed-number (symbol nb-children)
+  `(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children))))
+     (when (zerop ,nb-children)
+       (with-slots (scan) syntax
+	  (with-slots (start-mark size) result
+	     (setf start-mark (clone-mark scan :right)
+		   size 0))))
+     result))
+
 (defun pop-until-type (syntax type)
   (with-slots (stack-top) syntax
      (loop with result = '()
@@ -373,6 +382,16 @@
 	   until (typep child type)
 	   finally (return result))))
 
+(defmacro reduce-until-type (symbol type)
+  `(let ((result (make-instance ',symbol
+		    :children (pop-until-type syntax ',type))))
+     (when (null (children result))
+       (with-slots (scan) syntax
+	  (with-slots (start-mark size) result
+	     (setf start-mark (clone-mark scan :right)
+		   size 0))))
+     result))
+
 (defun pop-all (syntax)
   (with-slots (stack-top) syntax
      (loop with result = '()
@@ -380,6 +399,15 @@
 	   do (push (pop-one syntax) result)
 	   finally (return result))))
 
+(defmacro reduce-all (symbol)
+  `(let ((result (make-instance ',symbol :children (pop-all syntax))))
+     (when (null (children result))
+       (with-slots (scan) syntax
+	  (with-slots (start-mark size) result
+	     (setf start-mark (clone-mark scan :right)
+		   size 0))))
+     result))     
+
 (define-parser-state error-state (lexer-toplevel-state parser-state) ())
 (define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ())
 
@@ -392,7 +420,7 @@
 
 ;;; the action on end-of-buffer is to reduce to the error symbol
 (define-lisp-action (t (eql nil))
-  (make-instance 'error-symbol :children (pop-all syntax)))
+  (reduce-all error-symbol))
 
 ;;; the default new state is the error state
 (define-new-lisp-state (t parser-symbol) error-state)
@@ -400,8 +428,6 @@
 ;;; the new state when an error-state 
 (define-new-lisp-state (t error-symbol) error-reduce-state)
 
-(defmacro reduce-rule (symbol nb-children)
-  `(make-instance ',symbol :children (pop-number syntax ,nb-children)))
 
 ;;;;;;;;;;;;;;;; Top-level 
 
@@ -420,7 +446,7 @@
 (define-new-lisp-state (|initial-state | form) |initial-state |)
 
 (define-lisp-action (|initial-state | (eql nil))
-  (make-instance 'form* :children (pop-all syntax)))
+  (reduce-all form*))
 
 (define-new-lisp-state (|initial-state | form*) |form* | )
   
@@ -445,8 +471,7 @@
 
 ;;; reduce according to the rule form -> ( form* )
 (define-lisp-action (|( form* ) | t)
-  (make-instance 'list-form
-     :children (pop-until-type syntax 'left-parenthesis-lexeme)))
+  (reduce-until-type list-form left-parenthesis-lexeme))
 
 ;;;;;;;;;;;;;;;; String
 
@@ -463,8 +488,7 @@
 
 ;;; reduce according to the rule form -> " word* "
 (define-lisp-action (|" word* " | t)
-  (make-instance 'string-form
-     :children (pop-until-type syntax 'string-start-lexeme)))
+  (reduce-until-type string-form string-start-lexeme))
 
 ;;;;;;;;;;;;;;;; Line comment
 
@@ -481,8 +505,7 @@
 
 ;;; reduce according to the rule form -> ; word* NL
 (define-lisp-action (|; word* NL | t)
-  (make-instance 'line-comment-form
-     :children (pop-until-type syntax 'line-comment-start-lexeme)))
+  (reduce-until-type line-comment-form line-comment-start-lexeme))
 
 ;;;;;;;;;;;;;;;; Long comment
 
@@ -503,8 +526,7 @@
 
 ;;; reduce according to the rule form -> #| word* |#
 (define-lisp-action (|#\| word* \|# | t)
-  (make-instance 'long-comment-form
-     :children (pop-until-type syntax 'long-comment-start-lexeme)))
+  (reduce-until-type long-comment-form long-comment-start-lexeme))
 
 ;;;;;;;;;;;;;;;; Symbol name surrounded with vertical bars
 
@@ -520,8 +542,7 @@
 
 ;;; reduce according to the rule form -> | text* |
 (define-lisp-action (|\| text* \| | t)
-  (make-instance 'symbol-form
-     :children (pop-until-type syntax 'symbol-start-lexeme)))
+  (reduce-until-type symbol-form symbol-start-lexeme))
 
 ;;;;;;;;;;;;;;;; Quote
 
@@ -536,7 +557,7 @@
 
 ;;; reduce according to the rule form -> ' form
 (define-lisp-action (|' form | t)
-  (reduce-rule quote-form 2))
+  (reduce-fixed-number quote-form 2))
 
 ;;;;;;;;;;;;;;;; Backquote
 
@@ -551,7 +572,7 @@
 
 ;;; reduce according to the rule form -> ` form
 (define-lisp-action (|` form | t)
-  (reduce-rule backquote-form 2))
+  (reduce-fixed-number backquote-form 2))
 
 ;;;;;;;;;;;;;;;; Comma
 
@@ -566,7 +587,7 @@
 
 ;;; reduce according to the rule form -> , form
 (define-lisp-action (|, form | t)
-  (reduce-rule backquote-form 2))
+  (reduce-fixed-number backquote-form 2))
 
 ;;;;;;;;;;;;;;;; Function
 
@@ -581,7 +602,7 @@
 
 ;;; reduce according to the rule form -> #' form
 (define-lisp-action (|#' form | t)
-  (reduce-rule function-form 2))
+  (reduce-fixed-number function-form 2))
 
 ;;;;;;;;;;;;;;;; Reader conditionals
 
@@ -604,10 +625,10 @@
 (define-new-lisp-state (|#- form | form) |#- form form |)
   
 (define-lisp-action (|#+ form form | t)
-  (reduce-rule reader-conditional-positive-form 3))
+  (reduce-fixed-number reader-conditional-positive-form 3))
 
 (define-lisp-action (|#- form form | t)
-  (reduce-rule reader-conditional-negative-form 3))
+  (reduce-fixed-number reader-conditional-negative-form 3))
 
 ;;;;;;;;;;;;;;;; uninterned symbol
 
@@ -622,7 +643,7 @@
 
 ;;; reduce according to the rule form -> #: form
 (define-lisp-action (|#: form | t)
-  (reduce-rule uninterned-symbol-form 2))
+  (reduce-fixed-number uninterned-symbol-form 2))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -640,12 +661,7 @@
 	  (setf parser-state current-state
 		current-state new-state
 		preceding-parse-tree stack-top
-		stack-top new-parser-symbol)))))
-
-(defun parse-until-shift (syntax)
-  (with-slots (stack-top scan) syntax
-     (loop do (parser-step syntax)
-	   until (typep stack-top 'lexeme))
+		stack-top new-parser-symbol)))
      (setf (offset scan) (end-offset stack-top))))
 
 (defun prev-tree (tree)
@@ -691,35 +707,39 @@
 	       finally (return tree)))
 	(t (car parse-trees))))
 
-(defun find-next-lexeme (parse-tree)
-  (loop for tree = (next-tree parse-tree) then (next-tree tree)
-	until (or (null tree) (typep tree 'lexeme))
-	finally (return tree)))
-
 (defun parse-tree-equal (tree1 tree2)
   (and (eq (class-of tree1) (class-of tree2))
        (eq (parser-state tree1) (parser-state tree2))
-       (= (start-offset tree1) (start-offset tree2))
        (= (end-offset tree1) (end-offset tree2))))
 
+(defmethod print-object ((mark mark) stream)
+  (print-unreadable-object (mark stream :type t :identity t)
+    (format stream "~s" (offset mark))))
+
 (defun parse-patch (syntax)
   (with-slots (current-state stack-top scan potentially-valid-trees) syntax
-     (parse-until-shift syntax)
+     (parser-step syntax)
+     (finish-output *trace-output*)
      (cond ((parse-tree-equal stack-top potentially-valid-trees)
-	    (setf (slot-value potentially-valid-trees 'preceding-parse-tree)
-		  (slot-value stack-top 'preceding-parse-tree))
+	    (unless (or (null (parent potentially-valid-trees))
+			(eq potentially-valid-trees
+			    (car (last (children (parent potentially-valid-trees))))))
+	      (loop for tree = (cadr (member potentially-valid-trees
+					     (children (parent potentially-valid-trees))
+					     :test #'eq))
+		      then (car (children tree))
+		    until (null tree)
+		    do (setf (slot-value tree 'preceding-parse-tree)
+			     stack-top))
+	      (setf stack-top (prev-tree (parent potentially-valid-trees))))
 	    (setf potentially-valid-trees (parent potentially-valid-trees))
-	    (setf stack-top potentially-valid-trees)
-	    (loop until (typep stack-top 'lexeme)
-		  do (setf stack-top (prev-tree stack-top)))
 	    (setf current-state (new-state syntax (parser-state stack-top) stack-top))
-	    (setf potentially-valid-trees (find-next-lexeme potentially-valid-trees)
-		  (offset scan) (end-offset stack-top)))
+	    (setf (offset scan) (end-offset stack-top)))
 	   (t (loop until (or (null potentially-valid-trees)
 			      (>= (start-offset potentially-valid-trees)
 				  (end-offset stack-top)))
 		    do (setf potentially-valid-trees
-			     (find-next-lexeme potentially-valid-trees)))))))
+			     (next-tree potentially-valid-trees)))))))	    
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;