From 77b405bb6291a86a259bbb96a580084b71ae041d Mon Sep 17 00:00:00 2001
From: Ramarren <ramarren@gmail.com>
Date: Wed, 2 Feb 2011 08:16:15 +0100
Subject: [PATCH] Fix curtail?

---
 basic.lisp        |  2 --
 recurse.lisp      | 37 ++++++++++++++++++-------------------
 test-parsers.lisp |  4 ++++
 3 files changed, 22 insertions(+), 21 deletions(-)

diff --git a/basic.lisp b/basic.lisp
index a78783f..03c2b4d 100644
--- a/basic.lisp
+++ b/basic.lisp
@@ -101,13 +101,11 @@
   (with-unique-names (ignore-gensym)
     (do-notation spec 'bind ignore-gensym)))
 
-(defparameter *curtail-table* (make-hash-table))
 (defparameter *memo-table* (make-hash-table))
 
 (defun parse-string (parser string)
   "Parse a string, return a PARSE-RESULT object. All returned values may share structure."
   (let ((*memo-table* (make-hash-table))
-        (*curtail-table* (make-hash-table))
         (context (make-context string)))
     (values (make-parse-result (funcall parser context))
             (front-of context))))
diff --git a/recurse.lisp b/recurse.lisp
index b8c9240..71aa59f 100644
--- a/recurse.lisp
+++ b/recurse.lisp
@@ -1,21 +1,20 @@
 (in-package :parser-combinators)
 
-(defun curtail? (parser &optional (label (gensym)))
-  "Add recursion curtailing to promise."
-  (unless (gethash label *curtail-table*)
-    (setf (gethash label *curtail-table*) (make-hash-table)))
-  (let ((curtail-table (gethash label *curtail-table*)))
-    (labels ((curtailed (inp)
-               (multiple-value-bind (counter counter-p) (gethash (position-of inp) curtail-table)
-                 (cond (counter-p
-                        (destructuring-bind (c . l) counter
-                          (cond ((>= c (1+ l))
-                                 (funcall (zero) inp))
-                                (t
-                                 (incf (car counter))
-                                 (funcall parser inp)))))
-                       (t
-                        (setf (gethash (position-of inp) curtail-table)
-                              (cons 1 (- (length-of inp) (position-of inp))))
-                        (funcall parser inp))))))
-      #'curtailed)))
+;; This is a hack, really.
+(defvar *curtail* nil)
+
+(defmacro curtail? (name &body body)
+  "Parser modifier: add recursion curtailing to PARSER, naming the curtailed parser NAME. Left
+recursive parser parser will only be nested once per remaining length of the input string. Note:
+this is only necessary for a limited class of left recursive parsers. Non-left recursive parsers
+should be implemented using just `named?`, and most left-recursive parsers using that in combination
+with `chainl1?`. Also see `expression?`."
+  (with-unique-names (inp curtail)
+    `(named? ,name
+       #'(lambda (,inp)
+           (let ((,curtail (if *curtail* *curtail* 0)))
+             (if (>= (+ ,curtail (position-of ,inp))
+                     (length-of ,inp))
+                 (funcall (zero) ,inp)
+                 (let ((*curtail* (1+ ,curtail)))
+                   (funcall ,@body ,inp))))))))
diff --git a/test-parsers.lisp b/test-parsers.lisp
index b83c907..9005a92 100644
--- a/test-parsers.lisp
+++ b/test-parsers.lisp
@@ -289,3 +289,7 @@
   ("AA(A(AA)A)A" '(#\A #\A (#\A (#\A #\A) #\A) #\A)
    "AAAA" '(#\A #\A #\A #\A))
   ("BAF"))
+
+(defparsertest test-curtail? (curtail? e (choice (seq-list? e #\+ e) #\A))
+  ("A" #\A "A+A" '(#\A #\+ #\A) "A+A+A" '((#\A #\+ #\A) #\+ #\A))
+  ())