Compile pegs down to words

extra/peg/parsers/parsers.factor

@@ -16,11 +16,11 @@ TUPLE: just-parser p1 ;
   ] ;
 
 
-M: just-parser compile ( parser -- quot )
+M: just-parser (compile) ( parser -- quot )
-  just-parser-p1 compile just-pattern append ;
+  just-parser-p1 compiled-parser just-pattern curry ;
 
 : just ( parser -- parser )
-  just-parser construct-boa ;
+  just-parser construct-boa init-parser ;
 
 : 1token ( ch -- parser ) 1string token ;
 

extra/peg/peg.factor

@@ -8,16 +8,42 @@ IN: peg
 
 TUPLE: parse-result remaining ast ;
 
-GENERIC: compile ( parser -- quot )
-
-: parse ( state parser -- result )
-  compile call ;
-
 SYMBOL: ignore 
 
 : <parse-result> ( remaining ast -- parse-result )
   parse-result construct-boa ;
 
+TUPLE: parser ;
+C: <parser> parser
+M: parser equal? eq? ;
+
+: init-parser ( parser -- parser )
+  #! Set the delegate for the parser
+  <parser> over set-delegate ;
+
+SYMBOL: compiled-parsers
+
+GENERIC: (compile) ( parser -- quot )
+
+: compiled-parser ( parser -- word )
+  #! Look to see if the given parser has been compied.
+  #! If not, compile it to a temporary word, cache it,
+  #! and return it. Otherwise return the existing one.
+  dup compiled-parsers get at [
+    nip
+  ] [
+    dup (compile) define-temp 
+    [ swap compiled-parsers get set-at ] keep
+  ] if* ;
+
+: compile ( parser -- word )
+  H{ } clone compiled-parsers [ 
+    [ compiled-parser ] with-compilation-unit 
+  ] with-variable ;
+
+: parse ( state parser -- result )
+  compile call ;
+
 <PRIVATE
 
 TUPLE: token-parser symbol ;
@@ -33,7 +59,7 @@ MATCH-VARS: ?token ;
     ] if 
   ] ;
   
-M: token-parser compile ( parser -- quot )
+M: token-parser (compile) ( parser -- quot )
   token-parser-symbol \ ?token token-pattern match-replace ;
       
 TUPLE: satisfy-parser quot ;
@@ -53,7 +79,7 @@ MATCH-VARS: ?quot ;
     ] if 
   ] ;
 
-M: satisfy-parser compile ( parser -- quot )
+M: satisfy-parser (compile) ( parser -- quot )
   satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
 
 TUPLE: range-parser min max ;
@@ -74,7 +100,7 @@ MATCH-VARS: ?min ?max ;
     ] if 
   ] ;
 
-M: range-parser compile ( parser -- quot )
+M: range-parser (compile) ( parser -- quot )
   T{ range-parser _ ?min ?max } range-pattern match-replace ;
 
 TUPLE: seq-parser parsers ;
@@ -82,7 +108,7 @@ TUPLE: seq-parser parsers ;
 : seq-pattern ( -- quot )
   [
     dup [
-      dup parse-result-remaining ?quot call [
+      dup parse-result-remaining ?quot [
         [ parse-result-remaining swap set-parse-result-remaining ] 2keep
         parse-result-ast dup ignore = [ 
           drop  
@@ -97,10 +123,10 @@ TUPLE: seq-parser parsers ;
     ] if  
   ] ;
 
-M: seq-parser compile ( parser -- quot )
+M: seq-parser (compile) ( parser -- quot )
   [
     [ V{ } clone <parse-result> ] %
-    seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each 
+    seq-parser-parsers [ compiled-parser \ ?quot seq-pattern match-replace % ] each 
   ] [ ] make ;
 
 TUPLE: choice-parser parsers ;
@@ -110,14 +136,14 @@ TUPLE: choice-parser parsers ;
     dup [
           
     ] [
-      drop dup ?quot call   
+      drop dup ?quot 
     ] if
   ] ;
 
-M: choice-parser compile ( parser -- quot )
+M: choice-parser (compile) ( parser -- quot )
   [
     f ,
-    choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
+    choice-parser-parsers [ compiled-parser \ ?quot choice-pattern match-replace % ] each
     \ nip ,
   ] [ ] make ;
 
@@ -134,20 +160,20 @@ TUPLE: repeat0-parser p1 ;
 
 : repeat0-pattern ( -- quot )
   [
-    ?quot swap (repeat0) 
+    [ ?quot ] swap (repeat0) 
   ] ;
 
-M: repeat0-parser compile ( parser -- quot )
+M: repeat0-parser (compile) ( parser -- quot )
   [
     [ V{ } clone <parse-result> ] %
-    repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %        
+    repeat0-parser-p1 compiled-parser \ ?quot repeat0-pattern match-replace %        
   ] [ ] make ;
 
 TUPLE: repeat1-parser p1 ;
 
 : repeat1-pattern ( -- quot )
   [
-    ?quot swap (repeat0) [
+    [ ?quot ] swap (repeat0) [
       dup parse-result-ast empty? [
         drop f
       ] when  
@@ -156,49 +182,49 @@ TUPLE: repeat1-parser p1 ;
     ] if*
   ] ;
 
-M: repeat1-parser compile ( parser -- quot )
+M: repeat1-parser (compile) ( parser -- quot )
   [
     [ V{ } clone <parse-result> ] %
-    repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace % 
+    repeat1-parser-p1 compiled-parser \ ?quot repeat1-pattern match-replace % 
   ] [ ] make ;
 
 TUPLE: optional-parser p1 ;
 
 : optional-pattern ( -- quot )
   [
-    dup ?quot call swap f <parse-result> or 
+    dup ?quot swap f <parse-result> or 
   ] ;
 
-M: optional-parser compile ( parser -- quot )
+M: optional-parser (compile) ( parser -- quot )
-  optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
+  optional-parser-p1 compiled-parser \ ?quot optional-pattern match-replace ;
 
 TUPLE: ensure-parser p1 ;
 
 : ensure-pattern ( -- quot )
   [
-    dup ?quot call [
+    dup ?quot [
       ignore <parse-result>
     ] [
       drop f
     ] if
   ] ;
 
-M: ensure-parser compile ( parser -- quot )
+M: ensure-parser (compile) ( parser -- quot )
-  ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
+  ensure-parser-p1 compiled-parser \ ?quot ensure-pattern match-replace ;
 
 TUPLE: ensure-not-parser p1 ;
 
 : ensure-not-pattern ( -- quot )
   [
-    dup ?quot call [
+    dup ?quot [
       drop f
     ] [
       ignore <parse-result>
     ] if
   ] ;
 
-M: ensure-not-parser compile ( parser -- quot )
+M: ensure-not-parser (compile) ( parser -- quot )
-  ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
+  ensure-not-parser-p1 compiled-parser \ ?quot ensure-not-pattern match-replace ;
 
 TUPLE: action-parser p1 quot ;
 
@@ -206,14 +232,14 @@ MATCH-VARS: ?action ;
 
 : action-pattern ( -- quot )
   [
-    ?quot call dup [ 
+    ?quot dup [ 
       dup parse-result-ast ?action call
       swap [ set-parse-result-ast ] keep
     ] when 
   ] ;
 
-M: action-parser compile ( parser -- quot )
+M: action-parser (compile) ( parser -- quot )
-  { action-parser-p1 action-parser-quot } get-slots [ compile ] dip 
+  { action-parser-p1 action-parser-quot } get-slots [ compiled-parser ] dip 
   2array { ?quot ?action } action-pattern match-replace ;
 
 : left-trim-slice ( string -- string )
@@ -225,31 +251,31 @@ M: action-parser compile ( parser -- quot )
 
 TUPLE: sp-parser p1 ;
 
-M: sp-parser compile ( parser -- quot )
+M: sp-parser (compile) ( parser -- quot )
   [
-    \ left-trim-slice , sp-parser-p1 compile % 
+    \ left-trim-slice , sp-parser-p1 compiled-parser , 
   ] [ ] make ;
 
 TUPLE: delay-parser quot ;
 
-M: delay-parser compile ( parser -- quot )
+M: delay-parser (compile) ( parser -- quot )
   [
-    delay-parser-quot % \ compile , \ call ,
+    delay-parser-quot % \ (compile) , \ call ,
   ] [ ] make ;
 
 PRIVATE>
 
 : token ( string -- parser )
-  token-parser construct-boa ;      
+  token-parser construct-boa init-parser ;      
 
 : satisfy ( quot -- parser )
-  satisfy-parser construct-boa ;
+  satisfy-parser construct-boa init-parser ;
 
 : range ( min max -- parser )
-  range-parser construct-boa ;
+  range-parser construct-boa init-parser ;
 
 : seq ( seq -- parser )
-  seq-parser construct-boa ;
+  seq-parser construct-boa init-parser ;
 
 : 2seq ( parser1 parser2 -- parser )
   2array seq ;
@@ -264,7 +290,7 @@ PRIVATE>
   { } make seq ; inline 
 
 : choice ( seq -- parser )
-  choice-parser construct-boa ;
+  choice-parser construct-boa init-parser ;
 
 : 2choice ( parser1 parser2 -- parser )
   2array choice ;
@@ -279,31 +305,31 @@ PRIVATE>
   { } make choice ; inline 
 
 : repeat0 ( parser -- parser )
-  repeat0-parser construct-boa ;
+  repeat0-parser construct-boa init-parser ;
 
 : repeat1 ( parser -- parser )
-  repeat1-parser construct-boa ;
+  repeat1-parser construct-boa init-parser ;
 
 : optional ( parser -- parser )
-  optional-parser construct-boa ;
+  optional-parser construct-boa init-parser ;
 
 : ensure ( parser -- parser )
-  ensure-parser construct-boa ;
+  ensure-parser construct-boa init-parser ;
 
 : ensure-not ( parser -- parser )
-  ensure-not-parser construct-boa ;
+  ensure-not-parser construct-boa init-parser ;
 
 : action ( parser quot -- parser )
-  action-parser construct-boa ;
+  action-parser construct-boa init-parser ;
 
 : sp ( parser -- parser )
-  sp-parser construct-boa ;
+  sp-parser construct-boa init-parser ;
 
 : hide ( parser -- parser )
   [ drop ignore ] action ;
 
 : delay ( quot -- parser )
-  delay-parser construct-boa ;
+  delay-parser construct-boa init-parser ;
 
 : PEG:
   (:) [