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

[Robert Strandh]

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