From bc5f82255fbdeeb11f3b3cfef555856ec2dcb8cf Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 27 Mar 2008 17:24:05 +1300
Subject: [PATCH 01/20] peg refactorings

---
 extra/peg/peg.factor | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 10c9ce907d..0ae2aba2ee 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -24,8 +24,13 @@ SYMBOL: packrat
 
 GENERIC: (compile) ( parser -- quot )
 
+: input-from ( input -- n )
+  #! Return the index from the original string that the
+  #! input slice is based on.
+  dup slice? [ slice-from ] [ drop 0 ] if ;
+
 :: run-packrat-parser ( input quot c -- result )
-  input slice? [ input slice-from ] [ 0 ] if
+  input input-from
   quot c [ drop H{ } clone ] cache 
   [
     drop input quot call  

From 4c50daed2213b9442954aec3a38abb51586fd05c Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 27 Mar 2008 17:45:59 +1300
Subject: [PATCH 02/20] Testcase for packrat behaviour

---
 extra/peg/peg-tests.factor | 20 ++++++++++++++++++++
 extra/peg/peg.factor       | 18 ++++++++++++++----
 2 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index 89cc243863..bd4699f097 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -158,3 +158,23 @@ IN: peg.tests
   "a]" "[" token hide "a" token "]" token hide 3array seq parse 
 ] unit-test
 
+
+{ V{ "1" "-" "1" } V{ "1" "+" "1" } } [
+  [
+    [ "1" token , "-" token , "1" token , ] seq* ,
+    [ "1" token , "+" token , "1" token , ] seq* ,
+  ] choice* 
+  "1-1" over parse parse-result-ast swap
+  "1+1" swap parse parse-result-ast
+] unit-test
+
+{ V{ "1" "-" "1" } V{ "1" "+" "1" } } [
+  [ 
+    [
+      [ "1" token , "-" token , "1" token , ] seq* ,
+      [ "1" token , "+" token , "1" token , ] seq* ,
+    ] choice* 
+    "1-1" over parse parse-result-ast swap
+    "1+1" swap parse parse-result-ast
+  ] with-packrat
+] unit-test
\ No newline at end of file
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 0ae2aba2ee..bbd55ec6fa 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -29,12 +29,22 @@ GENERIC: (compile) ( parser -- quot )
   #! input slice is based on.
   dup slice? [ slice-from ] [ drop 0 ] if ;
 
+: input-cache ( quot cache -- cache )
+  #! From the packrat cache, obtain the cache for the parser quotation 
+  #! that maps the input string position to the parser result.
+  [ drop H{ } clone ] cache ;
+
+: cached-result ( n input-cache input quot -- result )
+  #! Get the cached result for input position n
+  #! from the input cache. If the item is not in the cache,
+  #! call 'quot' with 'input' on the stack to get the result
+  #! and store that in the cache and return it.
+  [ nip ] swap compose curry cache ; inline
+
 :: run-packrat-parser ( input quot c -- result )
   input input-from
-  quot c [ drop H{ } clone ] cache 
-  [
-    drop input quot call  
-  ] cache ; inline
+  quot c input-cache 
+  input quot cached-result ; inline
 
 : run-parser ( input quot -- result )
   #! If a packrat cache is available, use memoization for

From 4e29081e93aadb902ebbcc27d9c2049d73434adb Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 27 Mar 2008 18:07:30 +1300
Subject: [PATCH 03/20] Make left recursion in pegs a failed parse Eventually
 left recursion will work fine, but this is prevents an infinite loop for now.

---
 extra/peg/peg-tests.factor | 4 +++-
 extra/peg/peg.factor       | 4 ++--
 2 files changed, 5 insertions(+), 3 deletions(-)

diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index bd4699f097..bd8abb63e6 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -175,6 +175,8 @@ IN: peg.tests
       [ "1" token , "+" token , "1" token , ] seq* ,
     ] choice* 
     "1-1" over parse parse-result-ast swap
-    "1+1" swap parse parse-result-ast
   ] with-packrat
+  [
+    "1+1" swap parse parse-result-ast
+  ] with-packrat 
 ] unit-test
\ No newline at end of file
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index bbd55ec6fa..1361f9fdbd 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -34,12 +34,12 @@ GENERIC: (compile) ( parser -- quot )
   #! that maps the input string position to the parser result.
   [ drop H{ } clone ] cache ;
 
-: cached-result ( n input-cache input quot -- result )
+:: cached-result ( n input-cache input quot -- result )
   #! Get the cached result for input position n
   #! from the input cache. If the item is not in the cache,
   #! call 'quot' with 'input' on the stack to get the result
   #! and store that in the cache and return it.
-  [ nip ] swap compose curry cache ; inline
+  n input-cache [ drop input quot call ] cache ; inline
 
 :: run-packrat-parser ( input quot c -- result )
   input input-from

From f6b7f8197e5e1bf033157bdcd389aa216383a29e Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 27 Mar 2008 23:54:34 +1300
Subject: [PATCH 04/20] Add tests for left recusion in pegs

---
 extra/peg/ebnf/ebnf-tests.factor | 30 +++++++++++++++++++++++++++++-
 extra/peg/ebnf/ebnf.factor       |  4 ++--
 extra/peg/peg-tests.factor       | 18 +++++++++++++++++-
 extra/peg/peg.factor             |  6 +++++-
 4 files changed, 53 insertions(+), 5 deletions(-)

diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index c9b9f5d977..dea549eb37 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -142,4 +142,32 @@ IN: peg.ebnf.tests
 
 { f } [
   "Z" [EBNF foo=[^A-Z] EBNF] call  
-] unit-test
\ No newline at end of file
+] unit-test
+
+[ 
+  #! Test direct left recursion. Currently left recursion should cause a
+  #! failure of that parser.
+  #! Not using packrat, so recursion causes data stack overflow  
+  "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call
+] must-fail
+
+{ V{ 49 } } [ 
+  #! Test direct left recursion. Currently left recursion should cause a
+  #! failure of that parser.
+  #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
+  "1+1" [ [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ] with-packrat parse-result-ast
+] unit-test
+
+[ 
+  #! Test indirect left recursion. Currently left recursion should cause a
+  #! failure of that parser.
+  #! Not using packrat, so recursion causes data stack overflow  
+  "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call
+] must-fail
+
+{ V{ 49 } } [ 
+  #! Test indirect left recursion. Currently left recursion should cause a
+  #! failure of that parser.
+  #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
+  "1+1" [ [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ] with-packrat parse-result-ast
+] unit-test
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 11e1e2ea64..be4beab3f1 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -266,7 +266,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   ] [ ] make delay sp ;
 
 : transform-ebnf ( string -- object )
-  'ebnf' parse parse-result-ast transform ;
+  'ebnf' [ parse ] packrat-parse parse-result-ast transform ;
 
 : check-parse-result ( result -- result )
   dup [
@@ -281,7 +281,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   ] if ;
 
 : ebnf>quot ( string -- hashtable quot )
-  'ebnf' parse check-parse-result 
+  'ebnf' [ parse ] with-packrat check-parse-result 
   parse-result-ast transform dup main swap at compile 1quotation ;
 
 : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index bd8abb63e6..cd95bd3b93 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -179,4 +179,20 @@ IN: peg.tests
   [
     "1+1" swap parse parse-result-ast
   ] with-packrat 
-] unit-test
\ No newline at end of file
+] unit-test
+
+: expr ( -- parser ) 
+  #! Test direct left recursion. Currently left recursion should cause a
+  #! failure of that parser.
+  [ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
+
+[
+  #! Not using packrat, so recursion causes data stack overflow  
+  "1+1" expr parse parse-result-ast   
+] must-fail
+
+{ "1" } [
+  #! Using packrat, so expr fails, causing the 2nd choice to be used.  
+  "1+1" expr [ parse ] with-packrat parse-result-ast   
+] unit-test
+
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 1361f9fdbd..e5632d645c 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -39,7 +39,11 @@ GENERIC: (compile) ( parser -- quot )
   #! from the input cache. If the item is not in the cache,
   #! call 'quot' with 'input' on the stack to get the result
   #! and store that in the cache and return it.
-  n input-cache [ drop input quot call ] cache ; inline
+  n input-cache [ 
+    drop
+    f n input-cache set-at
+    input quot call 
+  ] cache ; inline
 
 :: run-packrat-parser ( input quot c -- result )
   input input-from

From fa8b311b277582adbcdf5fe9e6aca747b1cd5322 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 28 Mar 2008 00:04:08 +1300
Subject: [PATCH 05/20] Add packrat-parse, etc

---
 extra/peg/ebnf/ebnf.factor |  4 ++--
 extra/peg/peg-docs.factor  | 30 ++++++++++++++++++++++++++----
 extra/peg/peg.factor       | 10 ++++++++--
 3 files changed, 36 insertions(+), 8 deletions(-)

diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index be4beab3f1..ed0dea0410 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -266,7 +266,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   ] [ ] make delay sp ;
 
 : transform-ebnf ( string -- object )
-  'ebnf' [ parse ] packrat-parse parse-result-ast transform ;
+  'ebnf' packrat-parse parse-result-ast transform ;
 
 : check-parse-result ( result -- result )
   dup [
@@ -281,7 +281,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   ] if ;
 
 : ebnf>quot ( string -- hashtable quot )
-  'ebnf' [ parse ] with-packrat check-parse-result 
+  'ebnf' packrat-parse check-parse-result 
   parse-result-ast transform dup main swap at compile 1quotation ;
 
 : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor
index 30e7f0e72f..c93d1af830 100644
--- a/extra/peg/peg-docs.factor
+++ b/extra/peg/peg-docs.factor
@@ -12,7 +12,7 @@ HELP: parse
 { $description 
     "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
     "the parse was successful, otherwise it is f." } 
-{ $see-also compile with-packrat } ;
+{ $see-also compile with-packrat packrat-parse } ;
 
 HELP: with-packrat
 { $values 
@@ -23,8 +23,30 @@ HELP: with-packrat
     "Calls the quotation with a packrat cache in scope. Usually the quotation will "
     "call " { $link parse } " or call a word produced by " { $link compile } "."
     "The cache is used to avoid the possible exponential time performace that pegs "
-    "can have, instead giving linear time at the cost of increased memory usage."  } 
-{ $see-also compile parse } ;
+    "can have, instead giving linear time at the cost of increased memory usage. "
+    "Use of this packrat option also allows direct and indirect recursion to "
+    "be handled in the parser without entering an infinite loop."  } 
+{ $see-also compile parse packrat-parse packrat-call } ;
+
+HELP: packrat-parse
+{ $values 
+  { "input" "a string" } 
+  { "parser" "a parser" } 
+  { "result" "a parse-result or f" } 
+}
+{ $description 
+    "Compiles and calls the parser with a packrat cache in scope."  } 
+{ $see-also compile parse packrat-call with-packrat } ;
+
+HELP: packrat-call
+{ $values 
+  { "input" "a string" } 
+  { "quot" "a quotation with stack effect ( input -- result )" } 
+  { "result" "a parse-result or f" } 
+}
+{ $description 
+    "Calls the compiled parser with a packrat cache in scope."  } 
+{ $see-also compile packrat-call packrat-parse with-packrat } ;
 
 HELP: compile
 { $values 
@@ -36,7 +58,7 @@ HELP: compile
     "The mapping from parser to compiled word is kept in a cache. If you later change "
     "the definition of a parser you'll need to clear this cache with " 
     { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." } 
-{ $see-also compile with-packrat reset-compiled-parsers } ;
+{ $see-also compile with-packrat reset-compiled-parsers packrat-call packrat-parse } ;
 
 HELP: reset-compiled-parsers
 { $description 
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index e5632d645c..246dbc7962 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -67,11 +67,17 @@ GENERIC: (compile) ( parser -- quot )
   [ compiled-parser ] with-compilation-unit ;
 
 : parse ( state parser -- result )
-  compile execute ;
+  compile execute ; inline
 
 : with-packrat ( quot -- result )
   #! Run the quotation with a packrat cache active.
-  [ H{ } clone packrat ] dip with-variable ;
+  [ H{ } clone packrat ] dip with-variable ; inline
+
+: packrat-parse ( state parser -- result )
+  [ parse ] with-packrat ;
+
+: packrat-call ( state quot -- result )
+  with-packrat ; inline
 
 <PRIVATE
 

From 89c76987388ad917247caed9f618c2253dfeb5da Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 28 Mar 2008 11:30:46 +1300
Subject: [PATCH 06/20] Fix MEMO problem with seq* and choice*

---
 extra/peg/peg.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 246dbc7962..709052b7dd 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -338,7 +338,7 @@ MEMO: 3seq ( parser1 parser2 parser3 -- parser )
 MEMO: 4seq ( parser1 parser2 parser3 parser4 -- parser )
   4array seq ;
 
-MEMO: seq* ( quot -- paser )
+: seq* ( quot -- paser )
   { } make seq ; inline 
 
 MEMO: choice ( seq -- parser )
@@ -353,7 +353,7 @@ MEMO: 3choice ( parser1 parser2 parser3 -- parser )
 MEMO: 4choice ( parser1 parser2 parser3 parser4 -- parser )
   4array choice ;
 
-MEMO: choice* ( quot -- paser )
+: choice* ( quot -- paser )
   { } make choice ; inline 
 
 MEMO: repeat0 ( parser -- parser )

From f96a251f8a1bdae231e4bc87fc7310a3e72e6b7e Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 28 Mar 2008 12:00:36 +1300
Subject: [PATCH 07/20] Refactor pegs to remove MEMO: and use unique id's

---
 extra/peg/parsers/parsers.factor |   3 +-
 extra/peg/peg.factor             | 139 +++++++++++++++++++------------
 2 files changed, 85 insertions(+), 57 deletions(-)

diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor
index fa6801dc1c..7a82418c27 100755
--- a/extra/peg/parsers/parsers.factor
+++ b/extra/peg/parsers/parsers.factor
@@ -7,7 +7,6 @@ USING: kernel sequences strings namespaces math assocs shuffle
 IN: peg.parsers
 
 TUPLE: just-parser p1 ;
-M: just-parser equal? 2drop f ;
 
 : just-pattern
   [
@@ -21,7 +20,7 @@ M: just-parser (compile) ( parser -- quot )
   just-parser-p1 compiled-parser just-pattern curry ;
 
 MEMO: just ( parser -- parser )
-  just-parser construct-boa ;
+  just-parser construct-boa init-parser ;
 
 : 1token ( ch -- parser ) 1string token ;
 
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 709052b7dd..eadbe2528f 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -29,25 +29,24 @@ GENERIC: (compile) ( parser -- quot )
   #! input slice is based on.
   dup slice? [ slice-from ] [ drop 0 ] if ;
 
-: input-cache ( quot cache -- cache )
+: input-cache ( id -- cache )
   #! From the packrat cache, obtain the cache for the parser quotation 
   #! that maps the input string position to the parser result.
-  [ drop H{ } clone ] cache ;
+  packrat get [ drop H{ } clone ] cache ;
 
-:: cached-result ( n input-cache input quot -- result )
-  #! Get the cached result for input position n
+:: cached-result ( input-cache input quot -- result )
+  #! Get the cached result for input position 
   #! from the input cache. If the item is not in the cache,
   #! call 'quot' with 'input' on the stack to get the result
   #! and store that in the cache and return it.
-  n input-cache [ 
+  input input-from input-cache [ 
     drop
-    f n input-cache set-at
+    f input input-from input-cache set-at
     input quot call 
   ] cache ; inline
 
-:: run-packrat-parser ( input quot c -- result )
-  input input-from
-  quot c input-cache 
+:: run-packrat-parser ( input quot id -- result )
+  id input-cache 
   input quot cached-result ; inline
 
 : run-parser ( input quot -- result )
@@ -55,12 +54,28 @@ GENERIC: (compile) ( parser -- quot )
   #! packrat parsing, otherwise do a standard peg call.
   packrat get [ run-packrat-parser ] [ call ] if* ; inline
 
+:: parser-body ( parser -- quot )
+  #! Return the body of the word that is the compiled version
+  #! of the parser.
+  [let* | parser-quot [ parser (compile) ] 
+          id          [ parser id>>      ]
+        |
+    [
+      packrat get [ 
+        parser-quot id run-packrat-parser
+      ] [
+        parser-quot call
+      ] if
+    ] 
+  ] ;
+ 
 : compiled-parser ( parser -- word )
   #! Look to see if the given parser has been compiled.
   #! If not, compile it to a temporary word, cache it,
   #! and return it. Otherwise return the existing one.
   compiled-parsers [
-    (compile) [ run-parser ] curry define-temp
+    dup parser-body define-temp 
+    tuck swap "peg" set-word-prop
   ] cache ;
 
 : compile ( parser -- word )
@@ -81,8 +96,34 @@ GENERIC: (compile) ( parser -- quot )
 
 <PRIVATE
 
+SYMBOL: id 
+
+: next-id ( -- n )
+  #! Return the next unique id for a parser
+  id get-global [
+    dup 1+ id set-global
+  ] [
+    1 id set-global 0
+  ] if* ;
+
+TUPLE: parser id ;
+M: parser equal? [ id>> ] 2apply = ;
+C: <parser> parser
+
+: delegates ( -- cache )
+  \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
+
+: reset-delegates ( -- )
+  H{ } clone \ delegates set-global ;
+
+: init-parser ( parser -- parser )
+  #! Set the delegate for the parser. Equivalent parsers
+  #! get a delegate with the same id.
+  dup clone delegates [
+    drop next-id <parser> 
+  ] cache over set-delegate ;
+
 TUPLE: token-parser symbol ;
-M: token-parser equal? 2drop f ;
 
 MATCH-VARS: ?token ;
 
@@ -98,7 +139,6 @@ M: token-parser (compile) ( parser -- quot )
   symbol>> [ parse-token ] curry ;
       
 TUPLE: satisfy-parser quot ;
-M: satisfy-parser equal? 2drop f ;
 
 MATCH-VARS: ?quot ;
 
@@ -119,7 +159,6 @@ M: satisfy-parser (compile) ( parser -- quot )
   quot>> \ ?quot satisfy-pattern match-replace ;
 
 TUPLE: range-parser min max ;
-M: range-parser equal? 2drop f ;
 
 MATCH-VARS: ?min ?max ;
 
@@ -141,7 +180,6 @@ M: range-parser (compile) ( parser -- quot )
   T{ range-parser _ ?min ?max } range-pattern match-replace ;
 
 TUPLE: seq-parser parsers ;
-M: seq-parser equal? 2drop f ;
 
 : seq-pattern ( -- quot )
   [
@@ -168,7 +206,6 @@ M: seq-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: choice-parser parsers ;
-M: choice-parser equal? 2drop f ;
 
 : choice-pattern ( -- quot )
   [
@@ -187,7 +224,6 @@ M: choice-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: repeat0-parser p1 ;
-M: repeat0-parser equal? 2drop f ;
 
 : (repeat0) ( quot result -- result )
   2dup remaining>> swap call [
@@ -210,7 +246,6 @@ M: repeat0-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: repeat1-parser p1 ;
-M: repeat1-parser equal? 2drop f ;
 
 : repeat1-pattern ( -- quot )
   [
@@ -230,7 +265,6 @@ M: repeat1-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: optional-parser p1 ;
-M: optional-parser equal? 2drop f ;
 
 : optional-pattern ( -- quot )
   [
@@ -241,7 +275,6 @@ M: optional-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot optional-pattern match-replace ;
 
 TUPLE: ensure-parser p1 ;
-M: ensure-parser equal? 2drop f ;
 
 : ensure-pattern ( -- quot )
   [
@@ -256,7 +289,6 @@ M: ensure-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot ensure-pattern match-replace ;
 
 TUPLE: ensure-not-parser p1 ;
-M: ensure-not-parser equal? 2drop f ;
 
 : ensure-not-pattern ( -- quot )
   [
@@ -271,7 +303,6 @@ M: ensure-not-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ;
 
 TUPLE: action-parser p1 quot ;
-M: action-parser equal? 2drop f ;
 
 MATCH-VARS: ?action ;
 
@@ -295,7 +326,6 @@ M: action-parser (compile) ( parser -- quot )
   ] unless ;
 
 TUPLE: sp-parser p1 ;
-M: sp-parser equal? 2drop f ;
 
 M: sp-parser (compile) ( parser -- quot )
   [
@@ -303,7 +333,6 @@ M: sp-parser (compile) ( parser -- quot )
   ] [ ] make ;
 
 TUPLE: delay-parser quot ;
-M: delay-parser equal? 2drop f ;
 
 M: delay-parser (compile) ( parser -- quot )
   #! For efficiency we memoize the quotation.
@@ -317,71 +346,71 @@ M: delay-parser (compile) ( parser -- quot )
 
 PRIVATE>
 
-MEMO: token ( string -- parser )
-  token-parser construct-boa ;      
+: token ( string -- parser )
+  token-parser construct-boa init-parser ;      
 
-MEMO: satisfy ( quot -- parser )
-  satisfy-parser construct-boa ;
+: satisfy ( quot -- parser )
+  satisfy-parser construct-boa init-parser ;
 
-MEMO: range ( min max -- parser )
-  range-parser construct-boa ;
+: range ( min max -- parser )
+  range-parser construct-boa init-parser ;
 
-MEMO: seq ( seq -- parser )
-  seq-parser construct-boa ;
+: seq ( seq -- parser )
+  seq-parser construct-boa init-parser ;
 
-MEMO: 2seq ( parser1 parser2 -- parser )
+: 2seq ( parser1 parser2 -- parser )
   2array seq ;
 
-MEMO: 3seq ( parser1 parser2 parser3 -- parser )
+: 3seq ( parser1 parser2 parser3 -- parser )
   3array seq ;
 
-MEMO: 4seq ( parser1 parser2 parser3 parser4 -- parser )
+: 4seq ( parser1 parser2 parser3 parser4 -- parser )
   4array seq ;
 
 : seq* ( quot -- paser )
   { } make seq ; inline 
 
-MEMO: choice ( seq -- parser )
-  choice-parser construct-boa ;
+: choice ( seq -- parser )
+  choice-parser construct-boa init-parser ;
 
-MEMO: 2choice ( parser1 parser2 -- parser )
+: 2choice ( parser1 parser2 -- parser )
   2array choice ;
 
-MEMO: 3choice ( parser1 parser2 parser3 -- parser )
+: 3choice ( parser1 parser2 parser3 -- parser )
   3array choice ;
 
-MEMO: 4choice ( parser1 parser2 parser3 parser4 -- parser )
+: 4choice ( parser1 parser2 parser3 parser4 -- parser )
   4array choice ;
 
 : choice* ( quot -- paser )
   { } make choice ; inline 
 
-MEMO: repeat0 ( parser -- parser )
-  repeat0-parser construct-boa ;
+: repeat0 ( parser -- parser )
+  repeat0-parser construct-boa init-parser ;
 
-MEMO: repeat1 ( parser -- parser )
-  repeat1-parser construct-boa ;
+: repeat1 ( parser -- parser )
+  repeat1-parser construct-boa init-parser ;
 
-MEMO: optional ( parser -- parser )
-  optional-parser construct-boa ;
+: optional ( parser -- parser )
+  optional-parser construct-boa init-parser ;
 
-MEMO: ensure ( parser -- parser )
-  ensure-parser construct-boa ;
+: ensure ( parser -- parser )
+  ensure-parser construct-boa init-parser ;
 
-MEMO: ensure-not ( parser -- parser )
-  ensure-not-parser construct-boa ;
+: ensure-not ( parser -- parser )
+  ensure-not-parser construct-boa init-parser ;
 
-MEMO: action ( parser quot -- parser )
-  action-parser construct-boa ;
+: action ( parser quot -- parser )
+  action-parser construct-boa init-parser ;
 
-MEMO: sp ( parser -- parser )
-  sp-parser construct-boa ;
+: sp ( parser -- parser )
+  sp-parser construct-boa init-parser ;
 
 : hide ( parser -- parser )
   [ drop ignore ] action ;
 
-MEMO: delay ( quot -- parser )
-  delay-parser construct-boa ;
+: delay ( quot -- parser )
+  delay-parser construct-boa init-parser ;
 
 : PEG:
   (:) [

From f596aa2d71f1f6dba6b94304b9754e83afde43fc Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 28 Mar 2008 14:10:33 +1300
Subject: [PATCH 08/20] Handle compilation of circular parsers

---
 extra/peg/peg-tests.factor |  8 +++++++-
 extra/peg/peg.factor       | 12 ++++++++----
 2 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index cd95bd3b93..7e2701bc48 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
+USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words ;
 IN: peg.tests
 
 { f } [
@@ -196,3 +196,9 @@ IN: peg.tests
   "1+1" expr [ parse ] with-packrat parse-result-ast   
 ] unit-test
 
+{ t } [
+  #! Ensure a circular parser doesn't loop infinitely
+  [ f , "a" token , ] seq*
+  dup parsers>>
+  dupd 0 swap set-nth compile word?
+] unit-test
\ No newline at end of file
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index eadbe2528f..9db23d9779 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -73,10 +73,14 @@ GENERIC: (compile) ( parser -- quot )
   #! Look to see if the given parser has been compiled.
   #! If not, compile it to a temporary word, cache it,
   #! and return it. Otherwise return the existing one.
-  compiled-parsers [
-    dup parser-body define-temp 
-    tuck swap "peg" set-word-prop
-  ] cache ;
+  #! Circular parsers are supported by getting the word
+  #! name and storing it in the cache, before compiling, 
+  #! so it is picked up when re-entered.
+  dup id>> compiled-parsers [
+    drop dup gensym swap 2dup id>> compiled-parsers set-at
+    2dup parser-body define 
+    dupd "peg" set-word-prop
+  ] cache nip ;
 
 : compile ( parser -- word )
   [ compiled-parser ] with-compilation-unit ;

From 749f10ba9fd39954e1d2162ae10ec91880b23921 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 28 Mar 2008 00:50:46 +1300
Subject: [PATCH 09/20] Implement direct left recursion As per VPRI Technical
 Report TR-2007-002 section 3.2

---
 extra/peg/peg.factor | 49 +++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 46 insertions(+), 3 deletions(-)

diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 9db23d9779..f93fd5ae9b 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -34,16 +34,59 @@ GENERIC: (compile) ( parser -- quot )
   #! that maps the input string position to the parser result.
   packrat get [ drop H{ } clone ] cache ;
 
+TUPLE: left-recursion detected? ;
+C: <left-recursion> left-recursion
+
+USE: prettyprint
+
+:: handle-left-recursive-result ( result -- result )
+  #! If the result is from a left-recursive call,
+  #! note this and fail, otherwise return normal result
+  #! See figure 4 of packrat_TR-2007-002.pdf.
+  result [
+    [let* | ast [ result ast>> ] |
+      ast left-recursion? [ t ast (>>detected?) f ] [ result ] if
+    ]
+  ] [ 
+    f
+  ] if ;
+         
+USE: io
+
+:: grow-lr ( input quot m -- result )
+  #! 'Grow the Seed' algorithm to handle left recursion
+  [let* | ans [ input quot call ] |
+    [ ans not ] [ ans [ ans remaining>> input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ 
+      "recursion exiting with = " write ans . "m was " write m . 
+      ans        
+    ] [
+      "recursion with = " write ans . 
+      input quot ans grow-lr
+    ] if
+  ] ;
+
 :: cached-result ( input-cache input quot -- result )
   #! Get the cached result for input position 
   #! from the input cache. If the item is not in the cache,
   #! call 'quot' with 'input' on the stack to get the result
   #! and store that in the cache and return it.
+  #! See figure 4 of packrat_TR-2007-002.pdf.
+  "cached-result " write input . "quot is " write quot . 
   input input-from input-cache [ 
     drop
-    f input input-from input-cache set-at
-    input quot call 
-  ] cache ; inline
+    [let* | lr  [ f <left-recursion> ] 
+            m   [ input lr <parse-result> ]
+            ans [ m input input-from input-cache set-at input quot call ]
+          |
+      lr detected?>> ans and [
+        input quot ans grow-lr
+      ] [
+        ans
+      ] if
+    ]
+  ] cache 
+  "found in cache: " write dup . "for quot " write quot .  
+  handle-left-recursive-result "after handle " write dup . ;
 
 :: run-packrat-parser ( input quot id -- result )
   id input-cache 

From d2190fd1ecdfc7c6f3a261b35dc0959a5ac863ac Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 28 Mar 2008 13:40:26 +1300
Subject: [PATCH 10/20] Direct left recurson working

---
 extra/peg/peg.factor | 36 +++++++++++++++++++++---------------
 1 file changed, 21 insertions(+), 15 deletions(-)

diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index f93fd5ae9b..84ccefdf35 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -38,23 +38,26 @@ TUPLE: left-recursion detected? ;
 C: <left-recursion> left-recursion
 
 USE: prettyprint
+USE: io
+
 
 :: handle-left-recursive-result ( result -- result )
   #! If the result is from a left-recursive call,
   #! note this and fail, otherwise return normal result
   #! See figure 4 of packrat_TR-2007-002.pdf.
+  ">>handle-left-recursive-result " write result . 
   result [
     [let* | ast [ result ast>> ] |
       ast left-recursion? [ t ast (>>detected?) f ] [ result ] if
     ]
   ] [ 
     f
-  ] if ;
+  ] if 
+  "<<handle-left-recursive-result " write dup . ;
          
-USE: io
-
-:: grow-lr ( input quot m -- result )
+:: grow-lr ( input quot parser m -- result )
   #! 'Grow the Seed' algorithm to handle left recursion
+  ">>grow-lr " write input . " for parser " write parser . " m is " write m . 
   [let* | ans [ input quot call ] |
     [ ans not ] [ ans [ ans remaining>> input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ 
       "recursion exiting with = " write ans . "m was " write m . 
@@ -63,34 +66,38 @@ USE: io
       "recursion with = " write ans . 
       input quot ans grow-lr
     ] if
-  ] ;
+  ] 
+  "<<grow-lr " write input . " for parser " write parser . " m is " write m . " result is " write dup .  
+  ;
 
-:: cached-result ( input-cache input quot -- result )
+:: cached-result ( input-cache input quot parser -- result )
   #! Get the cached result for input position 
   #! from the input cache. If the item is not in the cache,
   #! call 'quot' with 'input' on the stack to get the result
   #! and store that in the cache and return it.
   #! See figure 4 of packrat_TR-2007-002.pdf.
-  "cached-result " write input . "quot is " write quot . 
+  ">>cached-result " write input . "  for parser " write parser .
   input input-from input-cache [ 
     drop
     [let* | lr  [ f <left-recursion> ] 
             m   [ input lr <parse-result> ]
             ans [ m input input-from input-cache set-at input quot call ]
           |
+      "--lr is " write lr . " ans is " write ans . " for parser " write parser .
+      ans input input-from input-cache set-at
       lr detected?>> ans and [
-        input quot ans grow-lr
+        input quot parser ans grow-lr
       ] [
         ans
       ] if
     ]
   ] cache 
-  "found in cache: " write dup . "for quot " write quot .  
-  handle-left-recursive-result "after handle " write dup . ;
+  dup [ handle-left-recursive-result ] when  
+  "<<cached-result " write dup . " for parser " write parser . ;
 
-:: run-packrat-parser ( input quot id -- result )
-  id input-cache 
-  input quot cached-result ; inline
+:: run-packrat-parser ( input quot parser -- result )
+  parser id>> input-cache 
+  input quot parser cached-result ; inline
 
 : run-parser ( input quot -- result )
   #! If a packrat cache is available, use memoization for
@@ -101,11 +108,10 @@ USE: io
   #! Return the body of the word that is the compiled version
   #! of the parser.
   [let* | parser-quot [ parser (compile) ] 
-          id          [ parser id>>      ]
         |
     [
       packrat get [ 
-        parser-quot id run-packrat-parser
+        parser-quot parser run-packrat-parser
       ] [
         parser-quot call
       ] if

From 1d87e513f554df459c449a9b7de94788e72c7ab4 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 28 Mar 2008 15:51:18 +1300
Subject: [PATCH 11/20] lr2 wip

---
 extra/peg/peg.factor | 162 +++++++++++++++++++++++++++++++++++++------
 1 file changed, 140 insertions(+), 22 deletions(-)

diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 84ccefdf35..96fe36f85f 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -15,6 +15,19 @@ SYMBOL: ignore
   parse-result construct-boa ;
 
 SYMBOL: packrat
+SYMBOL: lrstack
+
+TUPLE: phead rule involved-set eval-set ;
+C: <head> phead 
+
+: input-from ( input -- n )
+  #! Return the index from the original string that the
+  #! input slice is based on.
+  dup slice? [ slice-from ] [ drop 0 ] if ;
+
+: heads ( input -- h )
+  input-from \ heads get at ;
+
 
 : compiled-parsers ( -- cache )
   \ compiled-parsers get-global [ H{ } clone dup \ compiled-parsers set-global ] unless* ;
@@ -24,17 +37,12 @@ SYMBOL: packrat
 
 GENERIC: (compile) ( parser -- quot )
 
-: input-from ( input -- n )
-  #! Return the index from the original string that the
-  #! input slice is based on.
-  dup slice? [ slice-from ] [ drop 0 ] if ;
-
 : input-cache ( id -- cache )
   #! From the packrat cache, obtain the cache for the parser quotation 
   #! that maps the input string position to the parser result.
   packrat get [ drop H{ } clone ] cache ;
 
-TUPLE: left-recursion detected? ;
+TUPLE: left-recursion seed rule head next ;
 C: <left-recursion> left-recursion
 
 USE: prettyprint
@@ -54,22 +62,138 @@ USE: io
     f
   ] if 
   "<<handle-left-recursive-result " write dup . ;
-         
-:: grow-lr ( input quot parser m -- result )
+   
+:: (grow-lr) ( input quot parser m h -- result )
   #! 'Grow the Seed' algorithm to handle left recursion
-  ">>grow-lr " write input . " for parser " write parser . " m is " write m . 
-  [let* | ans [ input quot call ] |
-    [ ans not ] [ ans [ ans remaining>> input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ 
+  ">>(grow-lr) " write input . " for parser " write parser . " m is " write m . 
+  [let* |
+          pos [ input ]  
+          ans [ h involved-set>> clone h (>>eval-set) input quot call ] 
+        |
+    [ ans not ] [ ans [ pos input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ 
       "recursion exiting with = " write ans . "m was " write m . 
-      ans        
+      m        
     ] [
       "recursion with = " write ans . 
-      input quot ans grow-lr
+      pos quot parser pos ans ast>> <parse-result> h (grow-lr)
     ] if
   ] 
-  "<<grow-lr " write input . " for parser " write parser . " m is " write m . " result is " write dup .  
+  "<<(grow-lr) " write input . " for parser " write parser . " m is " write m . " result is " write dup .  
   ;
 
+:: grow-lr ( input quot parser m h -- result )
+  h input input-from \ heads get set-at
+  input quot parser m h (grow-lr) 
+  f input input-from \ heads get set-at ;
+
+SYMBOL: not-found
+
+: memo ( parser input -- result )
+  input-from swap id>> input-cache at* [ drop not-found ] unless ;
+
+
+:: involved? ( parser h -- ? )
+  h rule>> parser = [
+    t
+  ] [
+    parser h involved-set>> member?
+  ] if ;
+
+:: recall ( input quot parser -- result )
+  [let* |
+          m [ parser input memo ]
+          h [ input heads ]
+        |
+    #! If not growing a seed pass, just return what is stored
+    #! in the memo table.
+    h [
+      m not-found = parser h involved? not and [
+        f
+      ] [
+        parser h eval-set>> member? [
+          parser h eval-set>> remove h (>>eval-set)
+          input quot call          
+        ] [
+          m
+        ] if
+      ] if
+    ] [
+      m
+    ] if
+  ] ;
+
+:: (setup-lr) ( parser l s -- )
+  s head>> l head>> = [
+    l head>> s (>>head)
+    l head>> [ s rule>> add ] change-involved-set drop
+    parser l s next>> (setup-lr)
+  ] unless ;
+
+:: setup-lr ( parser l -- )
+  [let* |
+          s [ lrstack get ] 
+        |
+    l head>> [ parser V{ } clone V{ } clone <head> l (>>head) ] unless
+    parser l s (setup-lr)
+  ] ;
+
+:: lr-answer ( quot parser input m -- result )
+  [let* |
+          h [ m ast>> head>> ]
+        |
+    h rule>> parser = [
+      "changing memo ast to seed " write 
+      m [ seed>> ast>> dup . ] change-ast drop
+      m input input-from parser id>> input-cache set-at
+      m ast>> not [
+        f
+      ] [
+        input quot parser m h grow-lr
+      ] if      
+    ] [
+      m ast>> seed>>
+    ] if
+  ] ;  
+
+:: (apply-rule) ( quot parser input -- result )
+  [let* |
+          lr  [ f parser f lrstack get <left-recursion> ]
+          m   [ lr lrstack set input lr <parse-result> ]
+          ans [ m input input-from parser id>> input-cache set-at input quot call ]
+        |
+    lrstack get next>> lrstack set
+    lr head>> [
+"setting seed to ans " write ans . 
+      ans lr (>>seed)
+      quot parser input m lr-answer      
+    ] [ 
+      ans 
+    ] if
+  ] ;
+
+:: apply-rule ( quot parser input -- result )
+  [let* |
+          m [ input quot parser recall ]
+        |
+    m not-found = [
+      quot parser input (apply-rule)       
+      dup input input-from parser id>> input-cache set-at      
+    ] [
+      m [
+        m ast>> left-recursion? [
+          "Found left recursion..." print
+          parser m ast>> setup-lr m remaining>> m ast>> seed>> <parse-result>
+          dup input input-from parser id>> input-cache set-at
+        ] [
+          m 
+          dup input input-from parser id>> input-cache set-at
+        ] if
+      ] [
+        f f input input-from parser id>> input-cache set-at
+      ] if
+    ] if
+  ] ;
+
 :: cached-result ( input-cache input quot parser -- result )
   #! Get the cached result for input position 
   #! from the input cache. If the item is not in the cache,
@@ -96,13 +220,7 @@ USE: io
   "<<cached-result " write dup . " for parser " write parser . ;
 
 :: run-packrat-parser ( input quot parser -- result )
-  parser id>> input-cache 
-  input quot parser cached-result ; inline
-
-: run-parser ( input quot -- result )
-  #! If a packrat cache is available, use memoization for
-  #! packrat parsing, otherwise do a standard peg call.
-  packrat get [ run-packrat-parser ] [ call ] if* ; inline
+  quot parser input apply-rule ;
 
 :: parser-body ( parser -- quot )
   #! Return the body of the word that is the compiled version
@@ -139,7 +257,7 @@ USE: io
 
 : with-packrat ( quot -- result )
   #! Run the quotation with a packrat cache active.
-  [ H{ } clone packrat ] dip with-variable ; inline
+  H{ } clone \ heads [ [ H{ } clone packrat ] dip with-variable ] with-variable ; inline
 
 : packrat-parse ( state parser -- result )
   [ parse ] with-packrat ;

From 4b353c75297e2ab0eb7cf23ed0c9e91caaffe90a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 28 Mar 2008 23:20:43 +1300
Subject: [PATCH 12/20] Rewrite peg internals

---
 extra/peg/peg-docs.factor  |  43 +----
 extra/peg/peg-tests.factor |  21 +--
 extra/peg/peg.factor       | 323 +++++++++++--------------------------
 3 files changed, 104 insertions(+), 283 deletions(-)

diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor
index c93d1af830..d2ca353ba1 100644
--- a/extra/peg/peg-docs.factor
+++ b/extra/peg/peg-docs.factor
@@ -12,41 +12,7 @@ HELP: parse
 { $description 
     "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
     "the parse was successful, otherwise it is f." } 
-{ $see-also compile with-packrat packrat-parse } ;
-
-HELP: with-packrat
-{ $values 
-  { "quot" "a quotation with stack effect ( input -- result )" } 
-  { "result" "the result of the quotation" } 
-}
-{ $description 
-    "Calls the quotation with a packrat cache in scope. Usually the quotation will "
-    "call " { $link parse } " or call a word produced by " { $link compile } "."
-    "The cache is used to avoid the possible exponential time performace that pegs "
-    "can have, instead giving linear time at the cost of increased memory usage. "
-    "Use of this packrat option also allows direct and indirect recursion to "
-    "be handled in the parser without entering an infinite loop."  } 
-{ $see-also compile parse packrat-parse packrat-call } ;
-
-HELP: packrat-parse
-{ $values 
-  { "input" "a string" } 
-  { "parser" "a parser" } 
-  { "result" "a parse-result or f" } 
-}
-{ $description 
-    "Compiles and calls the parser with a packrat cache in scope."  } 
-{ $see-also compile parse packrat-call with-packrat } ;
-
-HELP: packrat-call
-{ $values 
-  { "input" "a string" } 
-  { "quot" "a quotation with stack effect ( input -- result )" } 
-  { "result" "a parse-result or f" } 
-}
-{ $description 
-    "Calls the compiled parser with a packrat cache in scope."  } 
-{ $see-also compile packrat-call packrat-parse with-packrat } ;
+{ $see-also compile } ;
 
 HELP: compile
 { $values 
@@ -54,11 +20,12 @@ HELP: compile
   { "word" "a word" } 
 }
 { $description 
-    "Compile the parser to a word. The word will have stack effect ( input -- result )."
+    "Compile the parser to a word. The word will have stack effect ( -- result )."
     "The mapping from parser to compiled word is kept in a cache. If you later change "
     "the definition of a parser you'll need to clear this cache with " 
-    { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." } 
-{ $see-also compile with-packrat reset-compiled-parsers packrat-call packrat-parse } ;
+    { $link reset-compiled-parsers } " before using " { $link compile } " on that parser again." 
+} 
+{ $see-also parse } ;
 
 HELP: reset-compiled-parsers
 { $description 
diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index 7e2701bc48..7467a4111a 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -168,32 +168,13 @@ IN: peg.tests
   "1+1" swap parse parse-result-ast
 ] unit-test
 
-{ V{ "1" "-" "1" } V{ "1" "+" "1" } } [
-  [ 
-    [
-      [ "1" token , "-" token , "1" token , ] seq* ,
-      [ "1" token , "+" token , "1" token , ] seq* ,
-    ] choice* 
-    "1-1" over parse parse-result-ast swap
-  ] with-packrat
-  [
-    "1+1" swap parse parse-result-ast
-  ] with-packrat 
-] unit-test
-
 : expr ( -- parser ) 
   #! Test direct left recursion. Currently left recursion should cause a
   #! failure of that parser.
   [ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
 
-[
-  #! Not using packrat, so recursion causes data stack overflow  
-  "1+1" expr parse parse-result-ast   
-] must-fail
-
 { "1" } [
-  #! Using packrat, so expr fails, causing the 2nd choice to be used.  
-  "1+1" expr [ parse ] with-packrat parse-result-ast   
+  "1+1" expr parse parse-result-ast   
 ] unit-test
 
 { t } [
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 96fe36f85f..81a9ed8ace 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -7,6 +7,8 @@ USING: kernel sequences strings namespaces math assocs shuffle
        combinators.cleave locals ;
 IN: peg
 
+USE: prettyprint
+
 TUPLE: parse-result remaining ast ;
 
 SYMBOL: ignore 
@@ -15,18 +17,83 @@ SYMBOL: ignore
   parse-result construct-boa ;
 
 SYMBOL: packrat
-SYMBOL: lrstack
+SYMBOL: pos
+SYMBOL: input
+SYMBOL: fail
 
-TUPLE: phead rule involved-set eval-set ;
-C: <head> phead 
+TUPLE: memo-entry ans pos ;
+C: <memo-entry> memo-entry
+
+: rule-parser ( rule -- parser ) 
+  #! A rule is the parser compiled down to a word. It has
+  #! a "peg" property containing the original parser.
+  "peg" word-prop ;
+
+: input-slice ( -- slice )
+  #! Return a slice of the input from the current parse position
+  input get pos get tail-slice ;
 
 : input-from ( input -- n )
   #! Return the index from the original string that the
   #! input slice is based on.
   dup slice? [ slice-from ] [ drop 0 ] if ;
 
-: heads ( input -- h )
-  input-from \ heads get at ;
+: input-cache ( parser -- cache )
+  #! From the packrat cache, obtain the cache for the parser 
+  #! that maps the position to the parser result.
+  id>> packrat get [ drop H{ } clone ] cache ;
+
+: eval-rule ( rule -- ast )
+  #! Evaluate a rule, return an ast resulting from it.
+  #! Return fail if the rule failed. The rule has
+  #! stack effect ( input -- parse-result )
+  pos get swap 
+  execute [
+    nip
+    [ ast>> ] [ remaining>> ] bi
+    input-from pos set    
+  ] [ 
+    pos set   
+    fail
+  ] if* ;
+
+: memo ( pos rule -- memo-entry )
+  #! Return the result from the memo cache. 
+  rule-parser input-cache at ;
+
+: set-memo ( memo-entry pos rule -- )
+  #! Store an entry in the cache
+  rule-parser input-cache set-at ;
+
+:: apply-non-memo-rule ( r p -- ast )
+  [let* |
+          ans [ r eval-rule ]
+          m   [ ans pos get <memo-entry> ]
+        |
+    m p r set-memo ans 
+  ] ;
+
+: apply-memo-rule ( m -- ast )
+  [ ans>> ] [ pos>> ] bi pos set ;
+
+:: apply-rule ( r p -- ast )
+  [let* |
+          m [ p r memo ]
+        | 
+    m [
+      m apply-memo-rule
+    ] [
+      r p apply-non-memo-rule
+    ] if 
+  ] ;
+
+: with-packrat ( input quot -- result )
+  #! Run the quotation with a packrat cache active.
+  swap [ 
+    input set
+    0 pos set
+    H{ } clone packrat set
+  ] H{ } make-assoc swap bind ;
 
 
 : compiled-parsers ( -- cache )
@@ -35,203 +102,21 @@ C: <head> phead
 : reset-compiled-parsers ( -- )
   H{ } clone \ compiled-parsers set-global ;
 
+reset-compiled-parsers
+
 GENERIC: (compile) ( parser -- quot )
 
-: input-cache ( id -- cache )
-  #! From the packrat cache, obtain the cache for the parser quotation 
-  #! that maps the input string position to the parser result.
-  packrat get [ drop H{ } clone ] cache ;
-
-TUPLE: left-recursion seed rule head next ;
-C: <left-recursion> left-recursion
-
-USE: prettyprint
-USE: io
-
-
-:: handle-left-recursive-result ( result -- result )
-  #! If the result is from a left-recursive call,
-  #! note this and fail, otherwise return normal result
-  #! See figure 4 of packrat_TR-2007-002.pdf.
-  ">>handle-left-recursive-result " write result . 
-  result [
-    [let* | ast [ result ast>> ] |
-      ast left-recursion? [ t ast (>>detected?) f ] [ result ] if
-    ]
-  ] [ 
-    f
-  ] if 
-  "<<handle-left-recursive-result " write dup . ;
-   
-:: (grow-lr) ( input quot parser m h -- result )
-  #! 'Grow the Seed' algorithm to handle left recursion
-  ">>(grow-lr) " write input . " for parser " write parser . " m is " write m . 
-  [let* |
-          pos [ input ]  
-          ans [ h involved-set>> clone h (>>eval-set) input quot call ] 
-        |
-    [ ans not ] [ ans [ pos input-from m remaining>> input-from <= ] [ f ] if ] 2array || [ 
-      "recursion exiting with = " write ans . "m was " write m . 
-      m        
-    ] [
-      "recursion with = " write ans . 
-      pos quot parser pos ans ast>> <parse-result> h (grow-lr)
-    ] if
-  ] 
-  "<<(grow-lr) " write input . " for parser " write parser . " m is " write m . " result is " write dup .  
-  ;
-
-:: grow-lr ( input quot parser m h -- result )
-  h input input-from \ heads get set-at
-  input quot parser m h (grow-lr) 
-  f input input-from \ heads get set-at ;
-
-SYMBOL: not-found
-
-: memo ( parser input -- result )
-  input-from swap id>> input-cache at* [ drop not-found ] unless ;
-
-
-:: involved? ( parser h -- ? )
-  h rule>> parser = [
-    t
-  ] [
-    parser h involved-set>> member?
-  ] if ;
-
-:: recall ( input quot parser -- result )
-  [let* |
-          m [ parser input memo ]
-          h [ input heads ]
-        |
-    #! If not growing a seed pass, just return what is stored
-    #! in the memo table.
-    h [
-      m not-found = parser h involved? not and [
-        f
-      ] [
-        parser h eval-set>> member? [
-          parser h eval-set>> remove h (>>eval-set)
-          input quot call          
-        ] [
-          m
-        ] if
-      ] if
-    ] [
-      m
-    ] if
-  ] ;
-
-:: (setup-lr) ( parser l s -- )
-  s head>> l head>> = [
-    l head>> s (>>head)
-    l head>> [ s rule>> add ] change-involved-set drop
-    parser l s next>> (setup-lr)
-  ] unless ;
-
-:: setup-lr ( parser l -- )
-  [let* |
-          s [ lrstack get ] 
-        |
-    l head>> [ parser V{ } clone V{ } clone <head> l (>>head) ] unless
-    parser l s (setup-lr)
-  ] ;
-
-:: lr-answer ( quot parser input m -- result )
-  [let* |
-          h [ m ast>> head>> ]
-        |
-    h rule>> parser = [
-      "changing memo ast to seed " write 
-      m [ seed>> ast>> dup . ] change-ast drop
-      m input input-from parser id>> input-cache set-at
-      m ast>> not [
-        f
-      ] [
-        input quot parser m h grow-lr
-      ] if      
-    ] [
-      m ast>> seed>>
-    ] if
-  ] ;  
-
-:: (apply-rule) ( quot parser input -- result )
-  [let* |
-          lr  [ f parser f lrstack get <left-recursion> ]
-          m   [ lr lrstack set input lr <parse-result> ]
-          ans [ m input input-from parser id>> input-cache set-at input quot call ]
-        |
-    lrstack get next>> lrstack set
-    lr head>> [
-"setting seed to ans " write ans . 
-      ans lr (>>seed)
-      quot parser input m lr-answer      
-    ] [ 
-      ans 
-    ] if
-  ] ;
-
-:: apply-rule ( quot parser input -- result )
-  [let* |
-          m [ input quot parser recall ]
-        |
-    m not-found = [
-      quot parser input (apply-rule)       
-      dup input input-from parser id>> input-cache set-at      
-    ] [
-      m [
-        m ast>> left-recursion? [
-          "Found left recursion..." print
-          parser m ast>> setup-lr m remaining>> m ast>> seed>> <parse-result>
-          dup input input-from parser id>> input-cache set-at
-        ] [
-          m 
-          dup input input-from parser id>> input-cache set-at
-        ] if
-      ] [
-        f f input input-from parser id>> input-cache set-at
-      ] if
-    ] if
-  ] ;
-
-:: cached-result ( input-cache input quot parser -- result )
-  #! Get the cached result for input position 
-  #! from the input cache. If the item is not in the cache,
-  #! call 'quot' with 'input' on the stack to get the result
-  #! and store that in the cache and return it.
-  #! See figure 4 of packrat_TR-2007-002.pdf.
-  ">>cached-result " write input . "  for parser " write parser .
-  input input-from input-cache [ 
-    drop
-    [let* | lr  [ f <left-recursion> ] 
-            m   [ input lr <parse-result> ]
-            ans [ m input input-from input-cache set-at input quot call ]
-          |
-      "--lr is " write lr . " ans is " write ans . " for parser " write parser .
-      ans input input-from input-cache set-at
-      lr detected?>> ans and [
-        input quot parser ans grow-lr
-      ] [
-        ans
-      ] if
-    ]
-  ] cache 
-  dup [ handle-left-recursive-result ] when  
-  "<<cached-result " write dup . " for parser " write parser . ;
-
-:: run-packrat-parser ( input quot parser -- result )
-  quot parser input apply-rule ;
 
 :: parser-body ( parser -- quot )
   #! Return the body of the word that is the compiled version
   #! of the parser.
-  [let* | parser-quot [ parser (compile) ] 
+  [let* | rule [ parser (compile) define-temp dup parser "peg" set-word-prop ] 
         |
     [
-      packrat get [ 
-        parser-quot parser run-packrat-parser
+      rule pos get apply-rule dup fail = [ 
+        drop f 
       ] [
-        parser-quot call
+        input-slice swap <parse-result>
       ] if
     ] 
   ] ;
@@ -253,17 +138,8 @@ SYMBOL: not-found
   [ compiled-parser ] with-compilation-unit ;
 
 : parse ( state parser -- result )
-  compile execute ; inline
-
-: with-packrat ( quot -- result )
-  #! Run the quotation with a packrat cache active.
-  H{ } clone \ heads [ [ H{ } clone packrat ] dip with-variable ] with-variable ; inline
-
-: packrat-parse ( state parser -- result )
-  [ parse ] with-packrat ;
-
-: packrat-call ( state quot -- result )
-  with-packrat ; inline
+  dup word? [ compile ] unless
+  [ execute ] curry with-packrat ;
 
 <PRIVATE
 
@@ -287,6 +163,8 @@ C: <parser> parser
 : reset-delegates ( -- )
   H{ } clone \ delegates set-global ;
 
+reset-delegates 
+
 : init-parser ( parser -- parser )
   #! Set the delegate for the parser. Equivalent parsers
   #! get a delegate with the same id.
@@ -307,15 +185,15 @@ MATCH-VARS: ?token ;
   ] if ;
 
 M: token-parser (compile) ( parser -- quot )
-  symbol>> [ parse-token ] curry ;
-      
+  [ \ input-slice , symbol>> , \ parse-token , ] [ ] make ;
+   
 TUPLE: satisfy-parser quot ;
 
 MATCH-VARS: ?quot ;
 
 : satisfy-pattern ( -- quot )
   [
-    dup empty? [
+    input-slice dup empty? [
       drop f 
     ] [
       unclip-slice dup ?quot call [  
@@ -335,7 +213,7 @@ MATCH-VARS: ?min ?max ;
 
 : range-pattern ( -- quot )
   [
-    dup empty? [
+    input-slice dup empty? [
       drop f
     ] [
       0 over nth dup 
@@ -355,7 +233,7 @@ TUPLE: seq-parser parsers ;
 : seq-pattern ( -- quot )
   [
     dup [
-      dup remaining>> ?quot [
+      ?quot [
         [ remaining>> swap (>>remaining) ] 2keep
         ast>> dup ignore = [ 
           drop  
@@ -372,7 +250,7 @@ TUPLE: seq-parser parsers ;
 
 M: seq-parser (compile) ( parser -- quot )
   [
-    [ V{ } clone <parse-result> ] %
+    [ input-slice V{ } clone <parse-result> ] %
     parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each 
   ] [ ] make ;
 
@@ -380,24 +258,19 @@ TUPLE: choice-parser parsers ;
 
 : choice-pattern ( -- quot )
   [
-    dup [
-          
-    ] [
-      drop dup ?quot 
-    ] if
+    [ ?quot ] unless* 
   ] ;
 
 M: choice-parser (compile) ( parser -- quot )
-  [
+  [ 
     f ,
     parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each
-    \ nip ,
   ] [ ] make ;
 
 TUPLE: repeat0-parser p1 ;
 
 : (repeat0) ( quot result -- result )
-  2dup remaining>> swap call [
+  over call [
     [ remaining>> swap (>>remaining) ] 2keep 
     ast>> swap [ ast>> push ] keep
     (repeat0) 
@@ -412,7 +285,7 @@ TUPLE: repeat0-parser p1 ;
 
 M: repeat0-parser (compile) ( parser -- quot )
   [
-    [ V{ } clone <parse-result> ] %
+    [ input-slice V{ } clone <parse-result> ] %
     p1>> compiled-parser \ ?quot repeat0-pattern match-replace %        
   ] [ ] make ;
 
@@ -431,7 +304,7 @@ TUPLE: repeat1-parser p1 ;
 
 M: repeat1-parser (compile) ( parser -- quot )
   [
-    [ V{ } clone <parse-result> ] %
+    [ input-slice V{ } clone <parse-result> ] %
     p1>> compiled-parser \ ?quot repeat1-pattern match-replace % 
   ] [ ] make ;
 
@@ -439,7 +312,7 @@ TUPLE: optional-parser p1 ;
 
 : optional-pattern ( -- quot )
   [
-    dup ?quot swap f <parse-result> or 
+    ?quot [ input-slice f <parse-result> ] unless* 
   ] ;
 
 M: optional-parser (compile) ( parser -- quot )
@@ -449,7 +322,7 @@ TUPLE: ensure-parser p1 ;
 
 : ensure-pattern ( -- quot )
   [
-    dup ?quot [
+    input-slice ?quot [
       ignore <parse-result>
     ] [
       drop f
@@ -463,7 +336,7 @@ TUPLE: ensure-not-parser p1 ;
 
 : ensure-not-pattern ( -- quot )
   [
-    dup ?quot [
+    input-slice ?quot [
       drop f
     ] [
       ignore <parse-result>
@@ -486,7 +359,7 @@ MATCH-VARS: ?action ;
   ] ;
 
 M: action-parser (compile) ( parser -- quot )
-  { [ p1>> ] [ quot>> ] } cleave [ compiled-parser ] dip 
+  [ p1>> compiled-parser ] [ quot>> ] bi  
   2array { ?quot ?action } action-pattern match-replace ;
 
 : left-trim-slice ( string -- string )
@@ -500,7 +373,7 @@ TUPLE: sp-parser p1 ;
 
 M: sp-parser (compile) ( parser -- quot )
   [
-    \ left-trim-slice , p1>> compiled-parser , 
+    \ input-slice , \ left-trim-slice , \ input-from , \ pos , \ set , p1>> compiled-parser , 
   ] [ ] make ;
 
 TUPLE: delay-parser quot ;

From cca4700e490f26ef8394df099582313537cf575c Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 29 Mar 2008 00:41:41 +1300
Subject: [PATCH 13/20] Fix ebnf for peg changes

---
 extra/peg/ebnf/ebnf-tests.factor | 16 +---------------
 extra/peg/ebnf/ebnf.factor       |  6 +++---
 2 files changed, 4 insertions(+), 18 deletions(-)

diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index dea549eb37..a511e271c2 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -147,27 +147,13 @@ IN: peg.ebnf.tests
 [ 
   #! Test direct left recursion. Currently left recursion should cause a
   #! failure of that parser.
-  #! Not using packrat, so recursion causes data stack overflow  
   "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call
 ] must-fail
 
-{ V{ 49 } } [ 
-  #! Test direct left recursion. Currently left recursion should cause a
-  #! failure of that parser.
-  #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
-  "1+1" [ [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ] with-packrat parse-result-ast
-] unit-test
-
 [ 
   #! Test indirect left recursion. Currently left recursion should cause a
   #! failure of that parser.
-  #! Not using packrat, so recursion causes data stack overflow  
+  #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
   "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call
 ] must-fail
 
-{ V{ 49 } } [ 
-  #! Test indirect left recursion. Currently left recursion should cause a
-  #! failure of that parser.
-  #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
-  "1+1" [ [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ] with-packrat parse-result-ast
-] unit-test
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index ed0dea0410..3efe2d6979 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -266,7 +266,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   ] [ ] make delay sp ;
 
 : transform-ebnf ( string -- object )
-  'ebnf' packrat-parse parse-result-ast transform ;
+  'ebnf' parse parse-result-ast transform ;
 
 : check-parse-result ( result -- result )
   dup [
@@ -281,8 +281,8 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   ] if ;
 
 : ebnf>quot ( string -- hashtable quot )
-  'ebnf' packrat-parse check-parse-result 
-  parse-result-ast transform dup main swap at compile 1quotation ;
+  'ebnf' parse check-parse-result 
+  parse-result-ast transform dup main swap at compile [ parse ] curry ;
 
 : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
 

From 010ce8007607a2867c6bb2586b7cfb4890fc81c0 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 29 Mar 2008 00:49:39 +1300
Subject: [PATCH 14/20] Handle left recursion by failing again

---
 extra/peg/ebnf/ebnf-tests.factor | 13 +++++++------
 extra/peg/peg.factor             |  6 ++++--
 2 files changed, 11 insertions(+), 8 deletions(-)

diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index a511e271c2..aa47d37e55 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -144,16 +144,17 @@ IN: peg.ebnf.tests
   "Z" [EBNF foo=[^A-Z] EBNF] call  
 ] unit-test
 
-[ 
+{ V{ 49 } } [ 
   #! Test direct left recursion. Currently left recursion should cause a
   #! failure of that parser.
-  "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call
-] must-fail
+  #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
+  "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
+] unit-test
 
-[ 
+{ V{ 49 } } [ 
   #! Test indirect left recursion. Currently left recursion should cause a
   #! failure of that parser.
   #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
-  "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call
-] must-fail
+  "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
+] unit-test
 
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 81a9ed8ace..1d2f67f52e 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -67,10 +67,12 @@ C: <memo-entry> memo-entry
 
 :: apply-non-memo-rule ( r p -- ast )
   [let* |
+          m   [ fail p <memo-entry> dup p r set-memo ]
           ans [ r eval-rule ]
-          m   [ ans pos get <memo-entry> ]
         |
-    m p r set-memo ans 
+    ans m (>>ans)
+    pos get m (>>pos)
+    ans 
   ] ;
 
 : apply-memo-rule ( m -- ast )

From 68cbdf76aa05aa684ecbe966aba04e4ca3797fe4 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 29 Mar 2008 01:17:54 +1300
Subject: [PATCH 15/20] Handle direct left recusion

---
 extra/peg/peg.factor | 39 +++++++++++++++++++++++++++++++++++----
 1 file changed, 35 insertions(+), 4 deletions(-)

diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 1d2f67f52e..b24ee0aa62 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -24,6 +24,9 @@ SYMBOL: fail
 TUPLE: memo-entry ans pos ;
 C: <memo-entry> memo-entry
 
+TUPLE: left-recursion detected? ;
+C: <left-recursion> left-recursion
+ 
 : rule-parser ( rule -- parser ) 
   #! A rule is the parser compiled down to a word. It has
   #! a "peg" property containing the original parser.
@@ -48,7 +51,9 @@ C: <memo-entry> memo-entry
   #! Return fail if the rule failed. The rule has
   #! stack effect ( input -- parse-result )
   pos get swap 
-  execute [
+  execute 
+!  drop f f <parse-result>
+  [
     nip
     [ ast>> ] [ remaining>> ] bi
     input-from pos set    
@@ -65,18 +70,44 @@ C: <memo-entry> memo-entry
   #! Store an entry in the cache
   rule-parser input-cache set-at ;
 
+:: (grow-lr) ( r p m h -- )
+  p pos set
+  r eval-rule
+  dup fail = pos get m pos>> <= or [
+    drop
+  ] [
+    m (>>ans)
+    pos get m (>>pos)
+    r p m h (grow-lr)
+  ] if ;
+ 
+:: grow-lr ( r p m h -- ast )
+  #! Placeholder for full left recursion implementation
+  r p m h (grow-lr) m pos>> pos set m ans>>
+  ;
+
 :: apply-non-memo-rule ( r p -- ast )
   [let* |
-          m   [ fail p <memo-entry> dup p r set-memo ]
+          lr  [ f <left-recursion> ]
+          m   [ lr p <memo-entry> dup p r set-memo ]
           ans [ r eval-rule ]
         |
     ans m (>>ans)
     pos get m (>>pos)
-    ans 
+    lr detected?>> ans fail = not and [
+      r p m f grow-lr
+    ] [
+      ans
+    ] if 
   ] ;
 
 : apply-memo-rule ( m -- ast )
-  [ ans>> ] [ pos>> ] bi pos set ;
+  [ ans>> ] [ pos>> ] bi 
+  pos set 
+  dup left-recursion? [
+    t swap (>>detected?)
+    fail  
+  ] when ;
 
 :: apply-rule ( r p -- ast )
   [let* |

From dd979c8b3b42b5da7ed5832bff4b9a2882d3c2ee Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 29 Mar 2008 02:45:21 +1300
Subject: [PATCH 16/20] Indirect Left recursive grammars working

---
 extra/peg/peg.factor | 102 +++++++++++++++++++++++++++++++++++--------
 1 file changed, 84 insertions(+), 18 deletions(-)

diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index b24ee0aa62..fd00c3d2ae 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -20,13 +20,18 @@ SYMBOL: packrat
 SYMBOL: pos
 SYMBOL: input
 SYMBOL: fail
+SYMBOL: lrstack
+SYMBOL: heads
 
 TUPLE: memo-entry ans pos ;
 C: <memo-entry> memo-entry
 
-TUPLE: left-recursion detected? ;
+TUPLE: left-recursion seed rule head next ;
 C: <left-recursion> left-recursion
  
+TUPLE: peg-head rule involved-set eval-set ;
+C: <head> peg-head
+
 : rule-parser ( rule -- parser ) 
   #! A rule is the parser compiled down to a word. It has
   #! a "peg" property containing the original parser.
@@ -72,6 +77,7 @@ C: <left-recursion> left-recursion
 
 :: (grow-lr) ( r p m h -- )
   p pos set
+  h involved-set>> clone h (>>eval-set)
   r eval-rule
   dup fail = pos get m pos>> <= or [
     drop
@@ -82,39 +88,97 @@ C: <left-recursion> left-recursion
   ] if ;
  
 :: grow-lr ( r p m h -- ast )
-  #! Placeholder for full left recursion implementation
-  r p m h (grow-lr) m pos>> pos set m ans>>
+  h p heads get set-at
+  r p m h (grow-lr) 
+  p heads get delete-at
+  m pos>> pos set m ans>>
   ;
 
+:: (setup-lr) ( r l s -- )
+  s head>> l head>> eq? [
+    l head>> s (>>head)
+    l head>> [ s rule>> add ] change-involved-set drop
+    r l s next>> (setup-lr)
+  ] unless ;
+
+:: setup-lr ( r l -- )
+  l head>> [
+    r V{ } clone V{ } clone <head> l (>>head)
+  ] unless
+  r l lrstack get (setup-lr) ;
+
+:: lr-answer ( r p m -- ast )
+  [let* |
+          h [ m ans>> head>> ]
+        |
+    h rule>> r eq? [
+      m ans>> seed>> m (>>ans)
+      m ans>> fail = [
+        fail
+      ] [
+        r p m h grow-lr
+      ] if
+    ] [
+      m ans>> seed>>
+    ] if
+  ] ;
+
+:: recall ( r p -- memo-entry )
+  [let* |
+          m [ p r memo ]
+          h [ p heads get at ]
+        |
+    h [
+      m r h involved-set>> h rule>> add member? not and [
+        fail p <memo-entry>
+      ] [
+        r h eval-set>> member? [
+          h [ r swap remove ] change-eval-set drop
+          r eval-rule
+          m (>>ans)
+          pos get m (>>pos)
+          m
+        ] [ 
+          m
+        ] if
+      ] if
+    ] [
+      m
+    ] if
+  ] ;
+
 :: apply-non-memo-rule ( r p -- ast )
   [let* |
-          lr  [ f <left-recursion> ]
-          m   [ lr p <memo-entry> dup p r set-memo ]
+          lr  [ fail r f lrstack get <left-recursion> ]
+          m   [ lr lrstack set lr p <memo-entry> dup p r set-memo ]
           ans [ r eval-rule ]
         |
-    ans m (>>ans)
+    lrstack get next>> lrstack set
     pos get m (>>pos)
-    lr detected?>> ans fail = not and [
-      r p m f grow-lr
+    lr head>> [
+      ans lr (>>seed)
+      r p m lr-answer
     ] [
+      ans m (>>ans)
       ans
-    ] if 
+    ] if
   ] ;
 
-: apply-memo-rule ( m -- ast )
-  [ ans>> ] [ pos>> ] bi 
-  pos set 
-  dup left-recursion? [
-    t swap (>>detected?)
-    fail  
-  ] when ;
+:: apply-memo-rule ( r m -- ast )
+  m pos>> pos set 
+  m ans>> left-recursion? [ 
+    r m ans>> setup-lr
+    m ans>> seed>>
+  ] [
+    m ans>>
+  ] if ;
 
 :: apply-rule ( r p -- ast )
   [let* |
-          m [ p r memo ]
+          m [ r p recall ]
         | 
     m [
-      m apply-memo-rule
+      r m apply-memo-rule
     ] [
       r p apply-non-memo-rule
     ] if 
@@ -125,6 +189,8 @@ C: <left-recursion> left-recursion
   swap [ 
     input set
     0 pos set
+    f lrstack set
+    H{ } clone heads set
     H{ } clone packrat set
   ] H{ } make-assoc swap bind ;
 

From 261539a86ab13a9cc5c3be69cc8de2e317f8d6d9 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 29 Mar 2008 02:47:03 +1300
Subject: [PATCH 17/20] Unit test for left recursive grammar

---
 extra/peg/peg-tests.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index 7467a4111a..f57fe83220 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -173,8 +173,8 @@ IN: peg.tests
   #! failure of that parser.
   [ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
 
-{ "1" } [
-  "1+1" expr parse parse-result-ast   
+{ V{ V{ "1" "+" "1" } "+" "1" } } [
+  "1+1+1" expr parse parse-result-ast   
 ] unit-test
 
 { t } [

From 25eea7ea1b6d115e749dd9650b8975b3a86495e6 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 29 Mar 2008 02:51:49 +1300
Subject: [PATCH 18/20] Fix ebnf tests for left recursion

---
 extra/peg/ebnf/ebnf-tests.factor | 18 +++++++++++-------
 1 file changed, 11 insertions(+), 7 deletions(-)

diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index aa47d37e55..fbf13f69a2 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -144,17 +144,21 @@ IN: peg.ebnf.tests
   "Z" [EBNF foo=[^A-Z] EBNF] call  
 ] unit-test
 
-{ V{ 49 } } [ 
-  #! Test direct left recursion. Currently left recursion should cause a
-  #! failure of that parser.
+{ V{ V{ 49 } "+" V{ 49 } } } [ 
+  #! Test direct left recursion. 
   #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
   "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
 ] unit-test
 
-{ V{ 49 } } [ 
-  #! Test indirect left recursion. Currently left recursion should cause a
-  #! failure of that parser.
+{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [ 
+  #! Test direct left recursion. 
   #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
-  "1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
+  "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
+] unit-test
+
+{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [ 
+  #! Test indirect left recursion. 
+  #! Using packrat, so first part of expr fails, causing 2nd choice to be used  
+  "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
 ] unit-test
 

From 7bf27a5eb2034ad704ecadd131da0e8c655f69fb Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 29 Mar 2008 03:41:40 +1300
Subject: [PATCH 19/20] EBNF test using Java Primary production

---
 extra/peg/ebnf/ebnf-tests.factor | 44 ++++++++++++++++++++++++++++++++
 1 file changed, 44 insertions(+)

diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index fbf13f69a2..c2c0a50a59 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -162,3 +162,47 @@ IN: peg.ebnf.tests
   "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
 ] unit-test
 
+EBNF: primary 
+Primary = PrimaryNoNewArray
+PrimaryNoNewArray =  ClassInstanceCreationExpression 
+                   | MethodInvocation
+                   | FieldAccess
+                   | ArrayAccess
+                   | "this"
+ClassInstanceCreationExpression =  "new" ClassOrInterfaceType "(" ")"
+                                 | Primary "." "new" Identifier "(" ")"
+MethodInvocation =  Primary "." MethodName "(" ")"
+                  | MethodName "(" ")"
+FieldAccess =  Primary "." Identifier
+             | "super" "." Identifier  
+ArrayAccess =  Primary "[" Expression "]"
+             | ExpressionName "[" Expression "]"
+ClassOrInterfaceType = ClassName | InterfaceTypeName
+ClassName = "C" | "D"
+InterfaceTypeName = "I" | "J"
+Identifier = "x" | "y" | ClassOrInterfaceType
+MethodName = "m" | "n"
+ExpressionName = Identifier
+Expression = "i" | "j"
+main = Primary
+;EBNF 
+
+{ "this" } [
+  "this" primary parse-result-ast
+] unit-test
+
+{ V{ "this" "." "x" } } [
+  "this.x" primary parse-result-ast
+] unit-test
+
+{ V{ V{ "this" "." "x" } "." "y" } } [
+  "this.x.y" primary parse-result-ast
+] unit-test
+
+{ V{ V{ "this" "." "x" } "." "m" "(" ")" } } [
+  "this.x.m()" primary parse-result-ast
+] unit-test
+
+{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
+  "x[i][j].y" primary parse-result-ast
+] unit-test

From 5f37b4fc72d87336574810cce0e458ddda5ea8c6 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sat, 29 Mar 2008 16:11:08 +1300
Subject: [PATCH 20/20] compiled pegs infer

---
 extra/peg/peg.factor | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index fd00c3d2ae..8f7522bda9 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -65,7 +65,7 @@ C: <head> peg-head
   ] [ 
     pos set   
     fail
-  ] if* ;
+  ] if* ; inline
 
 : memo ( pos rule -- memo-entry )
   #! Return the result from the memo cache. 
@@ -85,14 +85,14 @@ C: <head> peg-head
     m (>>ans)
     pos get m (>>pos)
     r p m h (grow-lr)
-  ] if ;
+  ] if ; inline
  
 :: grow-lr ( r p m h -- ast )
   h p heads get set-at
   r p m h (grow-lr) 
   p heads get delete-at
   m pos>> pos set m ans>>
-  ;
+  ; inline
 
 :: (setup-lr) ( r l s -- )
   s head>> l head>> eq? [
@@ -121,7 +121,7 @@ C: <head> peg-head
     ] [
       m ans>> seed>>
     ] if
-  ] ;
+  ] ; inline
 
 :: recall ( r p -- memo-entry )
   [let* |
@@ -145,7 +145,7 @@ C: <head> peg-head
     ] [
       m
     ] if
-  ] ;
+  ] ; inline
 
 :: apply-non-memo-rule ( r p -- ast )
   [let* |
@@ -162,7 +162,7 @@ C: <head> peg-head
       ans m (>>ans)
       ans
     ] if
-  ] ;
+  ] ; inline
 
 :: apply-memo-rule ( r m -- ast )
   m pos>> pos set 
@@ -182,7 +182,7 @@ C: <head> peg-head
     ] [
       r p apply-non-memo-rule
     ] if 
-  ] ;
+  ] ; inline
 
 : with-packrat ( input quot -- result )
   #! Run the quotation with a packrat cache active.