Commits

Phil Hargett  committed b0e462b

Source code datastructures available again

  • Participants
  • Parent commits e7f5748
  • Branches parsing

Comments (0)

Files changed (10)

File continue.lisp

-(in-package :hh-parse)
-
-(defmethod continue-parse :around ( parser thread node )
-  "Protect parser from any errors in a single node"
-  (handler-case (call-next-method)
-    (error (c) (progn
-		 (format *standard-output* "Error encountered during parsing: ~a~%" c)
-		 (format *standard-output* "~t~tParse stack at error: ~{~a~%~}" 
-			 (loop for frame in (stack-of thread)
-			    collect (node-in frame)
-			      )
-			 )
-		 (abort-thread parser thread)
-		 )
-	   )
-    )
-  )
-
-(defmethod continue-parse ( parser thread (node literal-node))
-  (with-slots (called literal index) node
-    (if called
-	;; handle a character
-	(let (
-	      (parse-character (value-of thread) )
-	      (literal-character (elt literal index) )
-	      )
-	  (if (or (not (characterp (value-of thread))) 
-		  (char/= parse-character literal-character) 
-		  )
-	      (return-from-node parser thread nil)
-	      (progn
-		(incf index)
-		(when (>= index (length literal) )
-		  ;; succeeded
-		  (return-from-node parser thread (lit literal) )
-		  )
-		)
-	      )
-	  )
-	;; prepare
-	(setf called t)
-	)
-    )
-  )
-
-(defmethod continue-parse ( parser thread (node sequence-node) )
-  (with-slots (called index elements) node
-    (if called
-	(progn
-	  (if (value-of thread)
-	      (progn
-		(assimilate-result thread node (value-of thread))
-		(incf index)
-		(if (< index (length elements) )
-		    ;; not done
-		    (call-node parser thread (elt elements index))
-		    ;; must have succeeded
-		    (return-from-node parser thread (consolidated-results thread node) )
-		    )
-		)
-	      ;; no value--must have failed
-	      (return-from-node parser thread nil)
-	      )
-	  )
-	;; prepare to be called
-	(progn
-	  (setf called t)
-	  (call-node parser thread (elt elements index))
-	  )
-	)
-    )
-  )
-
-(defmethod continue-parse ( parser thread (node alternatives-node) )
-  (with-slots (called alternatives succeeded) node
-    (if called
-	;; return whatever worked
-	;; note: if both threads succeed, will this be a problem?
-	;; ambiguous grammars could cause issues here
-	(return-from-node parser thread (value-of thread) )
-	;; try each alternative
-	(progn
-	  (setf called t)
-	  (loop for alternative in alternatives
-	     ;; we give the alternatives the same stack as this node
-	     do (start-thread parser alternative thread)
-	       )
-	  ;; we abort the original thread, because
-	  ;; all of its alternatives will continue its action
-	  (abort-thread parser thread)
-	  )
-	)
-    )
-  )
-
-(defmethod continue-parse ( parser thread (node optional-node) )
-  (with-slots (called element) node
-    (if called
-	;; return whatever worked
-	(return-from-node parser thread (value-of thread) )
-	(progn
-	  (setf called t)
-	  ;; try both an empty node and the optional element
-	  (call-node parser thread (alt (make-instance 'empty-node)
-					element
-					)
-		     )
-	  )
-	)
-    )
-  )
-
-(defmethod continue-parse ( parser thread (node empty-node) )
-  (with-slots (called) node
-    (if called
-	(return-from-node parser thread (make-instance 'empty-node))
-	(setf called t)
-	)
-    )
-  )
-
-(defmethod continue-parse ( parser thread (node repeat-node) )
-  (with-slots (called element) node
-    (if called
-	(progn
-	  (if (value-of thread)
-	      (progn
-		(assimilate-result thread node (value-of thread))
-		;; and in another thread, try to keep going
-		(start-thread parser (funcall element) thread )
-		;; in this thread, just return what we've got
-		(return-from-node parser thread (consolidated-results thread node) )
-		)
-	      ;; (return-from-node parser thread (consolidated-results thread node) )
-	      (return-from-node parser thread nil )
-	      )
-	  )
-	;; prepare to be called
-	(progn
-	  (setf called t)
-	  (call-node parser thread (funcall element) )
-	  )
-	)
-    )
-  )
-
-(defmethod continue-parse ( parser thread (node character-class-node))
-  (with-slots (called test) node
-    (if called
-	(if (value-of thread) ;; skip nil
-	    ;; test characer
-	    (if (funcall test (value-of thread))
-		(return-from-node parser thread (value-of thread))
-		;; (abort-thread parser thread)
-		(return-from-node parser thread nil )
-		)
-	    ;; failed
-	    (return-from-node parser thread nil )
-	    )
-	;; prepare
-	(setf called t)
-	)
-    )
-  )
-
-(defmethod continue-parse ( parser thread (node capture-node))
-  (with-slots (called slot target value) node
-    (if called
-	;; capture
-	(if (value-of thread)
-	    ;; succeeded
-	    (progn
-	      (capture-value node (value-of thread))
-	      (trace-parser "#~a: captured ~a in slot ~a for ~a~%"
-			    (id-of thread)
-			    (value-of thread)
-			    slot
-			    target
-			    )
-	      (return-from-node parser thread (value-of thread))
-	      )
-	    ;; failed
-	    (return-from-node parser thread nil)
-	    )
-	;; prepare
-	(progn
-	  (setf called t)
-	  (call-node parser thread value)
-	  )
-	)
-    )
-  )

File copying.lisp

-(in-package :hh-parse)
-
-(defmacro copy-if-needed ( (copy-context node) &rest body )
-  `(let (
-	 (copy (when ,copy-context 
-		 (gethash ,node ,copy-context nil) 
-		 )
-	   )
-	 )
-     (or copy
-	 (let (
-	       (new-copy (progn ,@body) )
-	       )
-	   (when ,copy-context
-	     (setf (gethash ,node ,copy-context) new-copy)
-	     )
-	   new-copy
-	   )
-	 )
-     )
-  )
-
-(defun make-thread-copy-context ()
-  (make-hash-table)
-  )
-
-(defmethod copy-node ( ( node t) &optional (copy-context nil) )
-  (declare (ignorable copy-context) )
-  node
-  )
-
-(defmethod copy-node ( ( node list) &optional (copy-context nil) )
-  (loop for n in node
-     collect (copy-node n copy-context)
-       )
-  )
-
-(defmethod copy-node ( (node literal-node) &optional (copy-context nil) )
-  (copy-if-needed (copy-context node)
-		  (with-slots (called results index literal) node
-		    (make-instance 'literal-node
-				   :called called
-				   :results (copy-node results copy-context)
-				   :literal literal
-				   :index index
-				   )
-		    )
-		  )
-  )
-
-(defmethod copy-node ( ( node repeat-node) &optional (copy-context nil) )
-  (copy-if-needed (copy-context node)
-		  (with-slots (called results element) node
-		    (make-instance 'repeat-node 
-				   :called called
-				   :results (copy-node results copy-context)
-				   :element (copy-node element copy-context) 
-				   )
-		    )
-		  )
-  )
-
-(defmethod copy-node ( ( node alternatives-node) &optional (copy-context nil) )
-  (copy-if-needed (copy-context node)
-		  (with-slots (called results alternatives) node
-		    (make-instance 'alternatives-node 
-				   :called called
-				   :results (copy-node results copy-context)
-				   :alternatives (copy-node (alternatives-of node) copy-context) 
-				   )
-		    )
-		  )
-  )
-
-(defmethod copy-node ( ( node capture-node) &optional (copy-context nil) )
-  (copy-if-needed (copy-context node)
-		  (with-slots (called results target slot value transform) node
-		    (make-instance 'capture-node
-				   :called called
-				   :results (copy-node results copy-context)
-				   :target (copy-node target copy-context)
-				   :slot slot
-				   :value (copy-node value copy-context)
-				   :transform transform
-				   )
-		    )
-		  )
-  )
-
-(defmethod copy-node ( ( node optional-node) &optional (copy-context nil) )
-  (copy-if-needed (copy-context node)
-		  (with-slots (called results element) node
-		    (make-instance 'optional-node 
-				   :called called
-				   :results (copy-node results copy-context)
-				   :element (copy-node element copy-context) 
-				   )
-		    )
-		  )
-  )
-
-(defmethod copy-node ( ( node sequence-node) &optional (copy-context nil) )
-  (copy-if-needed (copy-context node)
-		  (with-slots (called results elements index) node
-		    (make-instance 'sequence-node 
-				   :called called
-				   :results (copy-node results copy-context)
-				   :elements (copy-node elements copy-context)
-				   :index index
-				   )
-		    )
-		  )
-  )
-
-(defun copy-frame ( a-frame copy-context )
-  (with-slots (node position) a-frame
-    (make-instance 'parse-frame 
-		   :position position
-		   :node (copy-node node copy-context)
-		   )
-    )
-  )
-
-(defun copy-thread ( a-thread &optional (copy-context (make-thread-copy-context)) )
-  (with-slots (id node-results status stack value) a-thread
-    (make-instance 'parse-thread
-		   :id (id-of a-thread)
-		   :status status
-		   :stack (loop for frame in stack
-			     collect (copy-frame frame copy-context)
-			       )
-		   :value (copy-node value copy-context)
-		   )
-    )
-  )
-
-(defun copy-parser ( a-parser )
-  (with-slots ( threads thread-counter results position ready-for-token last-token-read-successfully) a-parser
-    (make-instance 'parser 
-		   ;; :code  not serialized at this time, because we may not be able to do that
-		   :position position
-		   :results (copy-node results)
-		   :counter thread-counter
-		   :threads (loop for thread in threads
-				 collect (copy-thread thread)
-				 )
-		   :ready ready-for-token
-		   :last last-token-read-successfully
-		   )
-    )
-  )

File equality.lisp

-(in-package :hh-parse)
-
-;; equality
-(defmethod node-equal ( (left t) (right t) )
-  (equal left right)
-  )
-
-(defmethod node-equal ( (left list) (right list) )
-  (loop for el in left
-       for er in right
-       with is-equal = t
-       do (setf is-equal (and is-equal (node-equal el er) ) )
-       finally (return is-equal)
-       )
-  )
-
-(defmethod node-equal ( (left repeat-node) (right repeat-node) )
-  (node-equal (element-of left) (element-of right) )
-  )
-
-(defmethod node-equal ( (left optional-node) (right optional-node) )
-  (node-equal (element-of left) (element-of right) )
-  )
-
-(defmethod node-equal ( (left alternatives-node) (right alternatives-node) )
-  (node-equal (alternatives-of left) (alternatives-of right) )
-  )
-
-(defmethod node-equal ( (left sequence-node) (right sequence-node) )
-  (node-equal (elements-of left) (elements-of right) )
-  )
-
-(defmethod node-equal ( (left literal-node) (right literal-node) )
-  (equal (literal left) (literal right) )
-  )
-
-(defmethod node-equal ( (left empty-node) (right empty-node) )
-  t
-  )

File extended.lisp

-(in-package :hh-parse)
-
-(export
- (list
-
-  '? ;; optional term
-  '^ ;; alternative terms
-  ;; '+ repeat term one or more times -- symbol already exported by CL
-  ;; '* repeat term zero or more timers -- symbol already exported by CL
-
-  ;; 'define-extended-grammar
-  ;; 'define-extended-parser
-
-  'grammar-transform
-
-  )
- )
-
-(defun make-new-production-name (symbol)
-  (gensym (format nil "~a_" (symbol-name symbol)))
-  )
-
-(defun make-new-production (symbol rhss)
-  `(,(make-new-production-name symbol) ,@rhss)
-  )
-
-(defun make-new-rhs (rhs action)
-  (let (
-	(normalized-rhs (if (listp rhs)
-			    `(,@rhs)
-			    `(,rhs)
-			    )
-	  )
-	)
-    (if action
-	`(,@normalized-rhs ,action)
-	`(,@normalized-rhs)
-	)
-    )
-  )
-
-(defun replace-first-term (expr test replacement)
-  (cond ( (funcall test expr)
-	 (values (funcall replacement expr) t)
-	  )
-	( (listp expr)
-	 (let* (
-		(changed nil)
-		(new-expr (loop for term in expr
-			     for change = (if changed
-					      term
-					      (multiple-value-bind (result new-changes) (replace-first-term term test replacement)
-						(setf changed (or changed new-changes) )
-						result
-						)
-					      )
-			     if change ;; skip nil
-			     collect change
-			       )
-		  )
-		)
-	   (values new-expr changed)
-	   )
-	  )
-	(t (values expr nil) )
-	)
-  )
-
-(defun replace-term (expr test replacement)
-  (cond ( (funcall test expr)
-	 (values (funcall replacement expr) t)
-	  )
-	( (listp expr)
-	 (let* (
-		(changed nil)
-		(new-expr (loop for term in expr
-			     for change = (multiple-value-bind (result new-changes) (replace-term term test replacement)
-					    (setf changed (or changed new-changes) )
-					    result
-					    )
-			     if change ;; skip nil
-			     collect change
-			       )
-		  )
-		)
-	   (values new-expr changed)
-	   )
-	  )
-	(t (values expr nil) )
-	)
-  )
-
-(defmacro for-each-production ( (&optional (production-var 'production) (symbol-var 'symbol) (rhss-var 'rhss) ) productions &rest body)
-  `(loop for ,production-var in ,productions
-      do (destructuring-bind (,symbol-var &rest ,rhss-var) ,production-var
-	     ,@body
-	   )
-	)
-  )
-
-(defun extended-term-p (term)
-  "Useful for differentiating actions from terms in a consistent manner (perhaps other uses as well)"
-  (or (symbolp term)
-      ;; can't be explicit functional or action term, like #'identity or #'list
-      (and (listp term) (not (eql 'function (car term) ) ) ) 
-      (and (listp term)
-	   (member (car term) `(? ^ * +) )
-	   )
-      )
-  )
-
-(defmacro for-each-rhs ((&optional (rhs-var 'rhs) (action-var 'action) ) rhss &rest body)
-  `(loop for stuff in ,rhss
-      do (cond
-	   ((and (symbolp stuff) (not (null stuff)))
-	    (let (
-		  (,rhs-var (list stuff) )
-		  (,action-var #'identity )
-		  )
-	      ,@body
-	      )
-	    )
-	   ((listp stuff)
-	    (let ((l (car (last stuff))))
-	      (let ((,rhs-var (if (extended-term-p l) stuff (butlast stuff)))
-		    (,action-var (if (extended-term-p l) '#'list l)))
-		,@body
-		))
-	    )
-	   (t (error "Unexpected production ~S" stuff))
-	   )
-	)
-  )
-
-(defmacro apply-rhs-transform ( (productions) &rest body)
-  `(let (
-	(new-productions () )
-	(no-changes t)
-	)
-    (for-each-production 
-     (production symbol rhss) ,productions
-     (format *standard-output* "Production ~a for ~a~%" production symbol)
-     (format *standard-output* "Rhss ~a for ~a~%" rhss symbol)
-     (let (
-	   (new-rhss () )
-	   )
-       (for-each-rhs (rhs action) rhss
-		     (format *standard-output* "Transforming ~a for ~a~%" rhs symbol)
-		      ,@body
-		     )
-       (putend `(,symbol ,@new-rhss) new-productions)
-       )
-     )
-    (values new-productions (not no-changes))
-    )
-  )
-
-(defun transform-for-alternative-terms (productions) 
-  (apply-rhs-transform (productions)
-		   (multiple-value-bind (new-rhs new-changes) 
-		       (replace-term rhs
-				     (lambda (term) 
-				       (and (listp term) (eql '^ (car term) ) )
-				       )
-				     (lambda (term) 
-				       (let (
-					     (new-production (make-new-production symbol (cdr term)) )
-					     )
-					 (putend new-production new-productions)
-					 (car new-production) ;; use the symbolic name of new production
-					 )
-				       )
-				     )
-		     (putend (make-new-rhs new-rhs action) new-rhss)
-		     ;; (putend new-rhs new-rhss)
-		     (setf no-changes (and no-changes (not new-changes) ) )
-		     )
-		   )
-  )
-
-(defun transform-for-repeat-terms-zero-or-more-times (productions) 
-  (apply-rhs-transform (productions)
-		   (multiple-value-bind (new-rhs new-changes) 
-		       (replace-term rhs
-				     (lambda (term) 
-				       (and (listp term) (eql '* (car term) ) )
-				       )
-				     (lambda (term) 
-				       `(? (+ ,@(cdr term)))
-				       )
-				     )
-		     (putend (make-new-rhs new-rhs action) new-rhss)
-		     ;; (putend new-rhs new-rhss)
-		     (setf no-changes (and no-changes (not new-changes) ) )
-		     )
-		   )
-  )
-
-(defun transform-for-repeat-terms-one-or-more-times (productions) 
-  (apply-rhs-transform (productions)
-		   (multiple-value-bind (new-rhs new-changes) 
-		       (replace-term rhs
-				     (lambda (term) 
-				       (and (listp term) (eql '+ (car term) ) )
-				       )
-				     (lambda (term) 
-				       (let* (
-					      (new-symbol (gensym (format nil "~a_" (symbol-name symbol))) )
-					      (new-production `(,new-symbol ( ,@(cdr term) )
-									    (,new-symbol ,@(cdr term) )
-									    )
-						)
-					      )
-					 (putend new-production new-productions)
-					 ;; use the symbolic name of new production
-					 ;; TODO replacing as a list for now, with the expectation the group transfrom
-					 ;; will flatten it.  This is because rhs containing only (+ some-rule) will
-					 ;; result in a rhs that is just a symbol--not ideal
-					 new-symbol
-					 )
-				       )
-				     )
-		     (putend (make-new-rhs new-rhs action) new-rhss)
-		     ;; (putend new-rhs new-rhss)
-		     (setf no-changes (and no-changes (not new-changes) ) )
-		     )
-		   )
-  )
-
-(defun transform-for-optional-terms (productions) 
-  (apply-rhs-transform (productions)
-		   ;; once with term skipped
-		   (multiple-value-bind (new-rhs new-changes) 
-		       (replace-first-term rhs
-					   (lambda (term) 
-					     (and (listp term) (eql '? (car term) )) ;; (<= (length term) 2) )
-					     )
-					   (lambda (term) 
-					     nil ;; one rhs will now skip the term
-					     )
-					   )
-		     (unless new-rhs
-		       (error "Optional production resulted in empty rhs; production requires rewrite")
-		       )
-		     (putend (make-new-rhs new-rhs action) new-rhss)
-		     ;; (putend new-rhs new-rhss)
-		     (setf no-changes (and no-changes (not new-changes) ) )
-
-		     ;; once with the term included
-		     (when new-changes
-		       (multiple-value-bind (new-rhs new-changes) 
-			   (replace-first-term rhs
-					       (lambda (term) 
-						 (and (listp term) (eql '? (car term) )) ;; (<= (length term) 2) )
-						 )
-					       (lambda (term) 
-						 (cdr term)
-						 )
-					       )
-			 (putend (make-new-rhs new-rhs action) new-rhss)
-			 ;; (putend new-rhs new-rhss)
-			 (setf no-changes (and no-changes (not new-changes) ) )
-			 )
-		       )
-		     )
-
-		   )
-  ) 
-
-(defun transform-for-grouped-terms (productions) 
-  (apply-rhs-transform (productions)
-		   (let* (
-			  (new-changes nil)
-			  (new-rhs (loop for item in rhs
-				      if (listp item)
-				      append (progn 
-					       (setf no-changes t)
-					       item
-					       )
-				      else
-				      collect item
-					)
-			    )
-			  )
-		     (putend (make-new-rhs new-rhs action) new-rhss)
-		     ;; (putend new-rhs new-rhss)
-		     (setf no-changes (and no-changes (not new-changes) ) )
-		     )
-		   )
-  )
-
-;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
-;; 
-;; Transform productions from using ?,*,+ to productions understood by CL-YACC.
-;; 
-;;   -- In every production, replace any rhs containing ? (optional) with 2 new rhs, 1 containing
-;;      the term supplied as argument to ? and one without.  Report an error if results in an empty
-;;      rhs.
-;;   -- In every production, replace all terms containing ^ (alternatives) with a reference to a new production
-;;      that has the alternatives as possible rhss (name of new production based on where ^ was found).
-;;   -- In every production, replace any rhs containing + (1 or more repeat) with rhs referencing a new production (with a name
-;;      based on the production where the + was found) that contains the repeated term supplied as argument to +.
-;;   -- In every production, replace any term in rhs containing * (0 or more repeat) with a term that is (? (+ term) ).
-;;      May produce an error if results in an empty rhs.
-;;   -- In every production, flatten each rhs to be a simple list of symbols
-;;      
-;;  Transformation continues until the basic transforms above result in no changes to the list of productions.
-;; 
-;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;; ;;
-
-(defun grammar-transform (raw-productions)
-  "Transform an enhanced grammar (one that includes * and + for repetion, ^ for alternatives, and ? for optional terms),
-   into a grammar usable by :yacc"
-  
-  (let (
-	(productions raw-productions )
-	)
-    (macrolet (
-	       (pipe-step (func)
-		 `(progn
-		    (format *standard-output* "Transforming with ~a~%" (quote ,func))
-		    (loop with changing = nil
-		       do (multiple-value-bind (new-productions changed) (,func productions)
-			    (setf productions new-productions)
-			    (setf changing (and changing changed) )
-			    )
-		       unless changing
-		       return productions
-			 )
-		    )
-		 )
-	       )
-      (pipe-step transform-for-alternative-terms)
-      (pipe-step transform-for-repeat-terms-zero-or-more-times)
-      (pipe-step transform-for-repeat-terms-one-or-more-times)
-      (pipe-step transform-for-optional-terms)
-      (pipe-step transform-for-grouped-terms)
-      )
-    productions
-    )
-  )
-
-;; (defmacro define-extended-grammar (name (&rest options) &body productions)
-;;   `(define-grammar ,name
-;;      ,@options
-;;      ,@(grammar-transform productions)
-;;      )
-;; )
-
-;; (defmacro define-extended-parser (name (&rest options) &body productions)
-;;   (let (
-;; 	(transformed-grammar (grammar-transform productions) )
-;; 	)
-;;     `(progn
-;;        ;; (format *standard-output* "Productions : ~a~%" (quote ,transformed-grammar) )
-;;        (define-parser ,name
-;; 	 ,@options
-;; 	 ,@transformed-grammar
-;; 	 )
-;;        )
-;;     )
-;;   )
-

File generics.lisp

-(in-package :hh-parse)
-
-;; =====================================================================================================================
-;;
-;; Generics
-;;
-;; =====================================================================================================================
-
-(defgeneric parse-input (parser)
-  )
-
-(defgeneric parse-result (parser)
-  )
-
-(defgeneric parse-results-valid-p ( parser ) 
-  )
-
-(defgeneric parser-completed-p (parser)
-  (:documentation "Return true if parser has finished it's work (successfully or note).  This typically happens at end
-   of input, or if all of its threads have completed, but can vary by implementation")
-  )
-
-(defgeneric start-thread (parser node &optional base-thread)
-  )
-
-(defgeneric thread-completed-p (thread)
-  )
-
-(defgeneric call-node (parser thread node)
-  )
-
-(defgeneric return-from-node (parser thread value)
-  )
-
-(defgeneric return-value-to-parser (parser thread value)
-  )
-
-(defgeneric abort-thread (parser thread)
-  )
-
-(defgeneric node-equal (left right)
-  )
-
-(defgeneric assimilate-result (thread node result)
-  )
-
-(defgeneric consolidated-results (thread node)
-  )
-
-(defgeneric empty-node-p (node)
-  )
-
-(defgeneric continue-parse (parser thread node)
-  )
-
-(defgeneric wants-token-p (node)
-  )
-
-(defgeneric next-token ( parser )
-  )
-
-(defgeneric end-p ( parser )
-  )
-
-(defgeneric node-print-name ( node )
-  )
-
-(defgeneric copy-node ( node &optional context-hash)
-  )
-
-(defgeneric capture-value ( node value )
-  )
-
-;; Token stream methods
-
-(defgeneric parse-position ( tokens )
-  )
-
-(defgeneric (setf parse-position ) ( tokens position )
-  )
-
-(defgeneric next-parse-token ( tokens )
-  )
-
-(defgeneric end-parse-token-p ( tokens )
-  )
-
-(defgeneric positions-equal ( left right)
-  (:documentation "Return true if the left and right positions are equal")
-  )
-

File hh-parse.asd

 	       ;; (:file "equality")
 	       ;; (:file "printing")
 	       ;; (:file "tracing")
-	       ;; (:file "source")
+	       (:file "source")
 	       )
   :depends-on (
 	       ; external packages

File printing.lisp

-(in-package :hh-parse)
-
-;; TODO these are now out of sync with creation/copying code, as we are not currently relying upon serialization
-
-(defmethod node-print-name ( ( node parse-node) )
-  (string "node") 
-  )
-
-(defmethod node-print-name ( (node literal-node) )
-  (string "lit")
-  )
-
-(defmethod node-print-name ( ( node repeat-node) )
-  (string "rep")
-  )
-
-(defmethod node-print-name ( ( node alternatives-node) )
-  (string "alt")
-  )
-
-(defmethod node-print-name ( ( node capture-node) )
-  (string "capture")
-  )
-
-(defmethod node-print-name ( ( node capture-accumulate-node) )
-  (string "accumulate")
-  )
-
-(defmethod node-print-name ( ( node optional-node) )
-  (string "opt")
-  )
-
-(defmethod node-print-name ( ( node sequence-node) )
-  (string "seq")
-  )
-
-;; Print helpers
-
-(defmacro print-readable-node ( (node stream) &rest body)
-  `(progn
-     (write-string "(" ,stream)
-     (write-string (node-print-name ,node) ,stream)
-     ,@body
-     (write-string ")" ,stream)
-     )
-  )
-
-(defmethod print-object ( (obj literal-node) stream)
-  (print-readable-node (obj stream)
-		       (write-char #\Space stream)
-		       (write (literal obj) :stream stream)
-		       (when (and (index-of obj) (> (index-of obj) 0) )
-			   (write-string " :index " stream)
-			   (write (index-of obj) :stream stream)
-			   )
-		       (when (wants-token obj)
-			   (write-string " :wants " stream)
-			   (write (wants-token obj) :stream stream)
-			   )
-		       )
-  )
-
-(defmethod print-object ( (obj sequence-node) stream)
-  (print-readable-node (obj stream)
-		       (write-char #\Space stream)
-		       (pprint-linear stream (elements-of obj) nil)
-    )
-  )
-
-(defmethod print-object ( (obj repeat-node) stream)
-  (print-readable-node (obj stream)
-		       (write-string " :element " stream)
-		       (write (element-of obj) :stream stream)
-		       (when (results-of obj)
-			 (write-string " :results " stream)
-			 (pprint-linear stream (results-of obj) nil)
-			 )
-    )
-  )
-
-(defmethod print-object ( (obj sequence-node) stream)
-  (print-readable-node (obj stream)
-		       (write-char #\Space stream)
-		       (pprint-linear stream (elements-of obj) nil)
-    )
-  )
-
-(defmethod print-object ( (obj alternatives-node) stream)
-  (print-readable-node (obj stream)
-		       (write-char #\Space stream)
-		       (pprint-linear stream (alternatives-of obj) nil)
-    )
-  )
-
-(defmethod print-object ( (obj capture-node) stream)
-  (print-readable-node (obj stream)
-		       (write-string " :target " stream) 
-		       (write (if (slot-boundp obj 'target) 
-				  (slot-value obj 'target)
-				  "<unbound>"
-				  )
-			      :stream stream
-			      )
-		       (write-string " :slot " stream) 
-		       (write (if (slot-boundp obj 'slot) 
-				  (slot-value obj 'slot)
-				  "<unbound>"
-				  ) 
-			      :stream stream
-			      )
-		       (write-string " :value " stream) 
-		       (write (if (slot-boundp obj 'value) 
-				  (slot-value obj 'value)
-				  "<unbound>"
-				  )
-			      :stream stream
-			      )
-		       (write-string " :transform " stream) 
-		       (write (if (slot-boundp obj 'transform) 
-				  (slot-value obj 'transform)
-				  "<unbound>"
-				  ) 
-			      :stream stream
-			      )
-		       )
-  )
-
-(defmethod print-object ( (obj parser) stream)
-  (write-string "(parser" stream)
-
-  (when (slot-boundp obj 'position)
-    (format stream " :position ~s" (position-of obj) )
-    )
-  (when (stop-position-of obj)
-    (format stream " :stop ~s" (stop-position-of obj) )
-    )
-  (format stream " :counter ~s" (thread-count obj) )
-  (format stream " :max ~s" (max-threads-of obj) )
-  (format stream " :threads ~s" (threads-of obj) )
-  (format stream " :results ~s" (results-of obj) )
- 
-  (write-string ")" stream)
-  )
-
-(defmethod print-object ( (obj parse-thread) stream)
-  (write-string "(thread" stream)
-
-  (with-slots (status stack value) obj
-    (when (slot-boundp obj 'id)
-      (format stream " :id ~s" (id-of obj) )
-      )
-    (format stream " :status ~s" status )
-    (format stream " :stack ~s" stack )
-    (format stream " :value ~s" value )
-      )
- 
-  (write-string ")" stream)
-  )
-
-(defmethod print-object ( (obj parse-frame) stream)
-  (write-string "(frame" stream)
-
-  (with-slots (node position) obj
-    (format stream " :node ~s" node )
-    (format stream " :position ~s" position )
-      )
- 
-  (write-string ")" stream)
-
-  )
 (defgeneric (setf current-column-position) ( column source )
   )
 
+(defgeneric parse-position ( code ) )
+
+(defgeneric (setf parse-position ) ( position code ) )
+
 (defgeneric next-column ( position )
   (:documentation "Increment the column component of position")
   )
   )
 
 (defmethod parse-position ( (code source-code-file) )
-  (current-position code)
-  )
+  (current-position code))
 
 (defmethod (setf parse-position ) ( position (code source-code-file) )
-  (setf (current-position code) position)
-  )
+  (setf (current-position code) position))
 
 (defmethod flush-parsers ( (source source-code-file) &optional (line nil) )
   (loop for i from (or line (current-line-position source) ) below (length (lines-of source) )
-       do (setf (parser-of (elt (lines-of source) i) ) nil)
-       )
-  )
+       do (setf (parser-of (elt (lines-of source) i) ) nil)))
 
 (defmethod reparse ( (source source-code-file) top-node)
-  (loop for i from 0 below (length (lines-of source) )
-     for line = (elt (lines-of source) i)
-     with last-parser = (let (
-			      (parser (make-instance 'parser :code source))
-			      )
-			  (start-thread parser top-node)
-			  parser
-			  )
-     unless (parser-of line) do (let (
-				      (new-parser (copy-parser last-parser) )
-				      )
-				  (setf (stop-position-of new-parser) 
-					;; stop at beginning of next line
-					(make-instance 'source-code-position :line (+ 1 line) :column 0)
-					)
-				  (multiple-value-bind (results changed-parser) (parse-input new-parser)
-				    (declare (ignorable results) )
-				    (setf (parser-of line) changed-parser)
-				    )
-				  )
-     do (setf last-parser (parser-of line) )
-       )
-  )
-
-
+  t)
 
 ;; =====================================================================================================================
 ;;

File tracing.lisp

-(in-package :hh-parse)
-
-(defmethod call-node :around (parser thread node)
-  (trace-parser "#~a: ~a calling ~a~%" 
-	  (id-of thread)
-	  (let* (
-		 (stack (stack-of thread))
-		 (frame (first stack) )
-		 (caller (node-in frame))
-		 )
-	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
-	    )
-	  (string-downcase (symbol-name (class-name (class-of node) ) ) )
-	  )
-  (call-next-method)
-  )
-
-(defmethod return-from-node :around (parser thread value)
-  (trace-parser "#~a: ~a returning ~s~%" 
-	  (id-of thread)
-	  (let* (
-		 (stack (stack-of thread))
-		 (frame (first stack) )
-		 (caller (node-in frame))
-		 )
-	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
-	    )
-	  value
-	  ) 
-  (call-next-method)
-  )
-
-(defmethod abort-thread :around (parser thread)	  (id-of thread)
-
-  (trace-parser "#~a: ~a aborting~%" 
-	  (id-of thread)
-	  (let* (
-		 (stack (stack-of thread))
-		 (frame (first stack) )
-		 (caller (node-in frame))
-		 )
-	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
-	    )
-	  )
-  (call-next-method)
-  )
-
-(defmethod start-thread :around (parser node &optional thread)
-  (let (
-	(new-thread (call-next-method))
-	)
-    (trace-parser "#~a: thread started by ~a (~a threads running)~%"
-	    (id-of new-thread)
-	    (when (and thread (stack-of thread) )
-	      (let (
-		    (caller (node-in (car (stack-of thread) )) )
-		    )
-		(string-downcase (symbol-name (class-name (class-of caller) ) ) )
-		)
-	      )
-	    (length (threads-of parser))
-	    ;; stack
-	    )
-    new-thread
-    )
-  )
-
-(defmethod assimilate-result :around ( thread (node parse-node ) result)
-  (trace-parser "#~a: ~a assimilating result ~s~%" 
-	  (id-of thread)
-	  (let* (
-		 (stack (stack-of thread))
-		 (frame (first stack) )
-		 (caller (node-in frame))
-		 )
-	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
-	    )
-	  result
-	  )
-  (call-next-method)
-  )
-
-(defmethod continue-parse :around (parser thread node)
-  (trace-parser "#~a: continuing ~a with value ~s~%" 
-	  (id-of thread)
-	  (let* (
-		 (stack (stack-of thread))
-		 (frame (first stack) )
-		 (caller (node-in frame))
-		 )
-	    (string-downcase (symbol-name (class-name (class-of caller) ) ) )
-	    )
-	  (value-of thread)
-	  )
-  (call-next-method)
-  )
-
-(defmethod parse-result :around (parser)
-  (let (
-	(result (call-next-method) )
-	)
-    (trace-parser "P: Parse result ~s~%" result)
-    result
-    )
-  )
-
-(defmethod (setf threads-of) :after (value (parser parser) )
-  (setf (max-threads-of parser)
-	(max (max-threads-of parser)
-	     (length (threads-of parser) )
-	     )
-	)
-  )

File types.lisp

-(in-package :hh-parse)
-
-;; =====================================================================================================================
-;;
-;; Types
-;;
-;; =====================================================================================================================
-
-(defclass parser ()
-  (
-   ;; serialized state
-   (threads :initform () :initarg :threads :accessor threads-of)
-   (thread-counter :initform 0 :initarg :counter :accessor thread-count)
-   (max-threads :initform 0 :initarg :max :accessor max-threads-of)
-   (results :initform () :initarg :results :accessor results-of)
-   (position :initarg :position :accessor position-of)
-   (stop-postion :initform () :initarg :stop :accessor stop-position-of)
-   ;; non-serialized state
-   (code :initarg :code :accessor code)
-   (ready-for-token :initform t :initarg :ready :accessor ready-for-token)
-   (last-token-read-successfully :initform t :initarg :last :accessor last-token-read-successfully)
-   )
-  )
-
-(defclass token-stream ()
-  (
-   )
-  (:documentation "A marker type for indicating streams supporting a parsing position interface")
-  )
-
-(defclass parse-frame ()
-  (
-   (node :initarg :node :accessor node-in)
-   (position :initarg :position :accessor position-for)
-   )
-  )
-
-(deftype thread-completion-status ()
-  `(or (eql :failed)
-       (eql :succeeded)
-       )
-  )
-
-(deftype thread-status ()
-  `(or thread-completion-status
-       (eql :continuing)
-       )
-  )
-
-(defclass parse-thread ()
-  (
-   (id :initarg :id :accessor id-of)
-   (status :initform :continuing :type thread-status :initarg :status :accessor status-of)
-   (stack :initform () :initarg :stack :accessor stack-of)
-   (value :initform nil :initarg :value :accessor value-of)
-   )
-  )
-
-(defclass parse-node ()
-  (
-   (called :initform nil :initarg :called)
-   (results :initform nil :initarg :results :accessor results-of)
-   )
-  )
-
-(defclass literal-node (parse-node)
-  (
-   (index :initform 0 :initarg :index :accessor index-of)
-   (literal :initarg :literal :accessor literal)
-   (wants-token :initform nil :initarg :wants :accessor wants-token)
-   )
-  )
-
-(defclass sequence-node (parse-node)
-  (
-   (index :initform 0 :initarg :index :accessor index-of)
-   (elements :initform () :initarg :elements :accessor elements-of)
-   )
-  )
-
-(defclass alternatives-node (parse-node)
-  (
-   (succeeded :initform () )
-   (alternatives :initform () :initarg :alternatives :accessor alternatives-of)
-   )
-  )
-
-(defclass repeat-node (parse-node)
-  (
-   ;; element is actually a factory function, so that
-   ;; each time it used a fresh set of element node can be obtained
-   (element :initarg :element :accessor element-of)
-   (seen :initform nil)
-   )
-  )
-
-(defclass empty-node (parse-node)
-  (
-   )
-  (:documentation "Placeholder node returned in cases of a successful optional parse")
-  )
-
-(defclass optional-node (parse-node)
-  (
-   (element :initarg :element :accessor element-of)
-   )
-  )
-
-(defclass character-class-node (parse-node)
-  (
-   (test :initarg :test)
-   )
-  )
-
-(defclass capture-node (parse-node)
-  (
-   (target :initarg :target)
-   (slot :initarg :slot)
-   (value :initarg :value)
-   (transform :initarg :transform)
-   )
-  )
-
-(defclass capture-accumulate-node (capture-node)
-  (
-   )
-  (:documentation "This class accumulates values as a list")
-  )
-
-(defclass rule-node (parse-node)
-  (
-   )
-  )