Browse files

Bind seen-positions hashtable to a context

This is so that it doesn't invalidate when used with parse-sequence,
which will continue parsing to obtain additional results after leaving
parse-sequence dynamic scope as required.

Also make type declaration in note-position use long-form to placate
ECL compiler (fixes #11).
  • Loading branch information...
1 parent 8dec19a commit 9c7569a4f6af5e60c0d3a51d9c15c16d1714c845 @Ramarren committed Oct 23, 2013
Showing with 33 additions and 31 deletions.
  1. +20 −26 basic.lisp
  2. +13 −5 contexts.lisp
View
46 basic.lisp
@@ -113,20 +113,15 @@ realising the non-realised ones in the backing store."
(do-notation spec 'bind ignore-gensym)))
(defparameter *memo-table* (make-hash-table))
-(defparameter *seen-positions-table* nil)
-
-(defun note-position (posn)
- (declare ((integer 0) posn)
- (special *seen-positions-table*))
- (incf (gethash posn *seen-positions-table* 0)))
(defun parse-sequence (parser sequence)
"Parse a sequence (where a sequence is any object which implementes CONTEXT interface), return a
PARSE-RESULT object. All returned values may share structure."
(let ((*memo-table* (make-hash-table))
(context (make-context sequence)))
(values (make-parse-result (funcall parser context))
- (front-of context))))
+ (front-of context)
+ (seen-positions-of context))))
(defun parse-string (parser string)
"Synonym for parse-sequence. Parse a string, return a PARSE-RESULT object. All returned values may share structure."
@@ -145,25 +140,24 @@ position -- which should provide a rough hint at how problematic that particular
If COMPLETE is T, return the first parse to consume the input
completely. If COMPLETE is :FIRST return the first result only when it the whole input was consumed,
or immediately return nil."
- (let ((*seen-positions-table* (make-hash-table)))
- (multiple-value-bind (parse-result front) (parse-sequence (ensure-parser parser) sequence)
- (ecase complete
- ((nil :first)
- (let ((result
- (current-result parse-result)))
- (cond ((or (null result)
- (and (eql complete :first)
- (not (end-context-p (suffix-of result)))))
- (values nil nil nil front))
- ((not (end-context-p (suffix-of result)))
- (values (tree-of result) (suffix-of result) t front *seen-positions-table*))
- (t (values (tree-of result) nil t nil *seen-positions-table*)))))
- (t (iter (with results = parse-result)
- (for result = (next-result results))
- (while result)
- (when (end-context-p (suffix-of result))
- (return (values (tree-of result) nil t nil *seen-positions-table*)))
- (finally (return (values nil nil nil front)))))))))
+ (multiple-value-bind (parse-result front seen-positions) (parse-sequence (ensure-parser parser) sequence)
+ (ecase complete
+ ((nil :first)
+ (let ((result
+ (current-result parse-result)))
+ (cond ((or (null result)
+ (and (eql complete :first)
+ (not (end-context-p (suffix-of result)))))
+ (values nil nil nil front))
+ ((not (end-context-p (suffix-of result)))
+ (values (tree-of result) (suffix-of result) t front seen-positions))
+ (t (values (tree-of result) nil t nil seen-positions)))))
+ (t (iter (with results = parse-result)
+ (for result = (next-result results))
+ (while result)
+ (when (end-context-p (suffix-of result))
+ (return (values (tree-of result) nil t nil seen-positions)))
+ (finally (return (values nil nil nil front))))))))
(defun parse-string* (parser string &key (complete nil))
"Synonym for parse-sequence*. Parse a string and return as multiple values the first result,
View
18 contexts.lisp
@@ -7,9 +7,10 @@
(tags :accessor tags-of :initarg :tags :initform nil)))
(defclass context-common ()
- ((length :accessor length-of :initarg :length :initform 0)
- (front :accessor front-of :initarg :front :initform (make-instance 'context-front))
- (cache :accessor cache-of :initarg :cache :initform nil)))
+ ((length :accessor length-of :initarg :length :initform 0)
+ (front :accessor front-of :initarg :front :initform (make-instance 'context-front))
+ (cache :accessor cache-of :initarg :cache :initform nil)
+ (seen-postions :accessor seen-postions-of :initarg :seen-position :initform (make-hash-table))))
(defclass context ()
((common :accessor common-of :initarg :common)
@@ -24,6 +25,9 @@
(defmethod front-of ((context context))
(front-of (common-of context)))
+(defmethod seen-positions-of ((context context))
+ (seen-postions-of (common-of context)))
+
(defmethod (setf front-of) (new-value (context context))
(setf (front-of (common-of context)) new-value))
@@ -41,13 +45,17 @@
`(,initarg (,accessor ,context)))))
,@additional-arguments))
+(defun note-position (context posn)
+ (declare (type (integer 0) posn))
+ (incf (gethash posn (seen-positions-of context) 0)))
+
(defgeneric context-peek (context))
(defgeneric make-context-at-position (base-context position))
(defmethod make-context-at-position :around ((context context) position)
(let ((cache (cache-of context)))
- (note-position position)
+ (note-position context position)
(etypecase cache
(null (call-next-method))
(vector (or (aref cache position)
@@ -183,7 +191,7 @@
(defmethod initialize-instance :around ((context context) &rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(let ((rest (call-next-method)))
- (note-position (slot-value rest 'position))
+ (note-position context (slot-value rest 'position))
rest))
(defmethod make-context ((vector vector) &optional (cache-type *default-context-cache*))

0 comments on commit 9c7569a

Please sign in to comment.