Merge branch 'master' of git://double.co.nz/git/factor

extra/peg/ebnf/ebnf-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test peg peg.ebnf ;
+USING: kernel tools.test peg peg.ebnf words ;
 IN: peg.ebnf.tests
 
 { T{ ebnf-non-terminal f "abc" } } [

extra/peg/ebnf/ebnf.factor

@@ -278,7 +278,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
 
 : ebnf>quot ( string -- hashtable quot )
   'ebnf' parse check-parse-result 
-  parse-result-ast transform dup main swap at compile ;
+  parse-result-ast transform dup main swap at compile 1quotation ;
 
 : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
 

extra/peg/parsers/parsers.factor

@@ -16,8 +16,8 @@ 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 ;

extra/peg/peg.factor

@@ -3,24 +3,43 @@
 USING: kernel sequences strings namespaces math assocs shuffle 
        vectors arrays combinators.lib math.parser match
        unicode.categories sequences.lib compiler.units parser
-       words ;
+       words quotations effects memoize ;
 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 ;
 
+SYMBOL: compiled-parsers
+
+GENERIC: (compile) ( parser -- quot )
+
+: 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.
+  dup compiled-parsers get at [
+    nip
+  ] [
+    dup (compile) define-temp 
+    [ swap compiled-parsers get set-at ] keep
+  ] if* ;
+
+MEMO: compile ( parser -- word )
+  H{ } clone compiled-parsers [ 
+    [ compiled-parser ] with-compilation-unit 
+  ] with-variable ;
+
+: parse ( state parser -- result )
+  compile execute ;
+
 <PRIVATE
 
 TUPLE: token-parser symbol ;
+! M: token-parser equal? eq? ;
 
 MATCH-VARS: ?token ;
 
@@ -33,7 +52,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 +72,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 +93,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 +101,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 +116,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 +129,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 +153,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 +175,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 +225,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,17 +244,22 @@ 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 )
+  #! For efficiency we memoize the quotation.
+  #! This way it is run only once and the 
+  #! parser constructed once at run time.
   [
-    delay-parser-quot % \ compile , \ call ,
+    delay-parser-quot % \ compile ,
-  ] [ ] make ;
+  ] [ ] make 
+  { } { "word" } <effect> memoize-quot 
+  [ % \ execute , ] [ ] make ;
 
 PRIVATE>
 
@@ -308,7 +332,7 @@ PRIVATE>
 : PEG:
   (:) [
     [
-        call compile
+        call compile 1quotation
         [ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
         append define
     ] with-compilation-unit