? abbrev.fasl
? base-test.fasl
? base.fasl
? buffer-test.fasl
? buffer.fasl
? cl-syntax.fasl
? delegating-buffer.fasl
? gui.fasl
? html-syntax.fasl
? io.fasl
? kill-ring.fasl
? packages.fasl
? pane.fasl
? prolog-syntax.fasl
? syntax.fasl
? text-syntax.fasl
? translate.fasl
? undo.fasl
? Persistent/binseq-package.fasl
? Persistent/binseq.fasl
? Persistent/binseq2.fasl
? Persistent/obinseq.fasl
? Persistent/persistent-buffer.fasl
? Persistent/persistent-undo.fasl
? testing/rt.fasl
Index: syntax.lisp
===================================================================
RCS file: /project/climacs/cvsroot/climacs/syntax.lisp,v
retrieving revision 1.41
diff -u -r1.41 syntax.lisp
--- syntax.lisp	18 Mar 2005 07:49:17 -0000	1.41
+++ syntax.lisp	12 Apr 2005 18:06:42 -0000
@@ -207,7 +207,8 @@
    (symbols :initarg :symbols :reader symbols)))
 
 (defclass grammar ()
-  ((rules :initarg :rules :accessor rules)))
+  ((rules :initform nil :accessor rules)
+   (hash :initform (make-hash-table) :accessor hash)))
 
 (defmacro grammar-rule ((left-hand-side arrow arglist &body body))
   (declare (ignore arrow))
@@ -245,14 +246,29 @@
 
 
 (defmacro grammar (&body body)
-  `(make-instance 'grammar
-      :rules (list ,@(loop for rule in body
-			   collect `(grammar-rule ,rule)))))
+  (let ((rule (gensym "RULE"))
+	(rules (gensym "RULES"))
+	(result (gensym "RESULT")))
+    `(let* ((,rules (list ,@(loop for rule in body 
+				  collect `(grammar-rule ,rule))))
+	    (,result (make-instance 'grammar)))
+       (dolist (,rule ,rules ,result)
+	 (add-rule ,rule ,result)))))
 
 (defgeneric add-rule (rule grammar))
 
 (defmethod add-rule (rule (grammar grammar))
-  (push rule (rules grammar)))
+  (push rule (rules grammar))
+  (clrhash (hash grammar))
+  (let (rhs-symbols)
+    (dolist (rule (rules grammar))
+      (setf rhs-symbols (union rhs-symbols (coerce (symbols rule) 'list))))
+    (dolist (rule (rules grammar))
+      (let ((lhs-symbol (left-hand-side rule)))
+	(dolist (rhs-symbol rhs-symbols)
+	  (when (or (subtypep lhs-symbol rhs-symbol)
+		    (subtypep rhs-symbol lhs-symbol))
+	    (pushnew rule (gethash rhs-symbol (hash grammar)))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -316,19 +332,18 @@
 		   :parse-tree remaining
 		   :parse-trees parse-trees)))))))
 
-(defgeneric item-equal (item1 item2))
-
-(defgeneric parse-tree-equal (tree1 tree2))
-
-(defmethod item-equal ((item1 rule-item) (item2 rule-item))
-  nil)
-
-(defmethod item-equal ((item1 incomplete-item) (item2 incomplete-item))
+(defun item-equal (item1 item2)
+  (declare (optimize speed))
   (and (eq (rule item1) (rule item2))
-       (eq (length (parse-trees item1)) (length (parse-trees item2)))
-       (every #'parse-tree-equal (parse-trees item1) (parse-trees item2))))
+       (do ((trees1 (parse-trees item1) (cdr trees1))
+	    (trees2 (parse-trees item2) (cdr trees2)))
+	   ((and (null trees1) (null trees2)) t)
+	 (when (or (null trees1) (null trees2))
+	   (return nil))
+	 (when (not (parse-tree-equal (car trees1) (car trees2)))
+	   (return nil)))))
 
-(defmethod parse-tree-equal (tree1 tree2)
+(defun parse-tree-equal (tree1 tree2)
   (eq (class-of tree1) (class-of tree2)))
 
 (defgeneric parse-tree-better (tree1 tree2))
@@ -375,26 +390,30 @@
 (defmethod handle-item ((item (eql nil)) orig-state to-state)
   nil)
 
+;;; for all symbols[1] that are on the left-hand side of a rule
+;;;   for all symbols[2] that are in the right-hand side of a rule
+;;;     if (subtypep 1 2) or (subtypep 2 1)
+;;;       store, indexed by the [2] symbol, the [1] rule
+
 (defmethod handle-item ((item incomplete-item) orig-state to-state)
-   (cond ((find item (gethash orig-state (incomplete-items to-state))
+  (declare (optimize speed))
+  (cond ((find item (the list (gethash orig-state (incomplete-items to-state)))
  	       :test #'item-equal)
 	  nil)
  	(t
  	 (push item (gethash orig-state (incomplete-items 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)))
-		    (handle-item (if (functionp (right-hand-side rule))
-				     (make-instance 'incomplete-item
-					:orig-state to-state
-					:predicted-from item
-					:rule rule
-					:dot-position 0
-					:suffix (right-hand-side rule))
-				     (make-instance 'complete-item
-					:parse-tree (right-hand-side rule)))
-				 to-state to-state)))
+	 (dolist (rule (gethash (aref (symbols (rule item)) (dot-position item))
+				(hash (parser-grammar (parser to-state)))))
+	   (handle-item (if (functionp (right-hand-side rule))
+			    (make-instance 'incomplete-item
+					   :orig-state to-state
+					   :predicted-from item
+					   :rule rule
+					   :dot-position 0
+					   :suffix (right-hand-side rule))
+			    (make-instance 'complete-item
+					   :parse-tree (right-hand-side rule)))
+			to-state to-state))
 	 (loop for parse-tree in (gethash to-state (parse-trees to-state))
  	       do (handle-item (derive-item item parse-tree)
 			       to-state to-state)))))
