Merge branch 'master' of git://factorcode.org/git/factor

extra/peg/ebnf/ebnf-tests.factor

@@ -168,6 +168,18 @@ IN: peg.ebnf.tests
   "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
 ] unit-test
 
+{ 10 } [
+  { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+  { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call 
+] unit-test
+
+{ 3 } [
+  { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+] unit-test
+
 { V{ V{ 49 } "+" V{ 49 } } } [ 
   #! Test direct left recursion. 
   #! Using packrat, so first part of expr fails, causing 2nd choice to be used  

extra/peg/ebnf/ebnf.factor

@@ -20,6 +20,7 @@ TUPLE: ebnf-optional group ;
 TUPLE: ebnf-rule symbol elements ;
 TUPLE: ebnf-action parser code ;
 TUPLE: ebnf-var parser name ;
+TUPLE: ebnf-semantic parser code ;
 TUPLE: ebnf rules ;
 
 C: <ebnf-non-terminal> ebnf-non-terminal
@@ -36,6 +37,7 @@ C: <ebnf-optional> ebnf-optional
 C: <ebnf-rule> ebnf-rule
 C: <ebnf-action> ebnf-action
 C: <ebnf-var> ebnf-var
+C: <ebnf-semantic> ebnf-semantic
 C: <ebnf> ebnf
 
 : syntax ( string -- parser )
@@ -156,6 +158,7 @@ DEFER: 'choice'
 : 'factor-code' ( -- parser )
   [
     "]]" token ensure-not ,
+    "]?" token ensure-not ,
     [ drop t ] satisfy ,
   ] seq* [ first ] action repeat0 [ >string ] action ;
 
@@ -193,14 +196,15 @@ DEFER: 'choice'
 : 'action' ( -- parser )
    "[[" 'factor-code' "]]" syntax-pack ;
 
+: 'semantic' ( -- parser )
+   "?[" 'factor-code' "]?" syntax-pack ;
+
 : 'sequence' ( -- parser )
   #! A sequence of terminals and non-terminals, including
   #! groupings of those. 
   [
-    [ 
-      ('sequence') ,
-      'action' ,
-    ] seq* [ first2 <ebnf-action> ] action ,
+    [ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
+    [ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,
     ('sequence') ,
   ] choice* repeat1 [ 
      dup length 1 = [ first ] [ <ebnf-sequence> ] if
@@ -295,6 +299,10 @@ M: ebnf-action (transform) ( ast -- parser )
   [ parser>> (transform) ] keep
   code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
 
+M: ebnf-semantic (transform) ( ast -- parser )
+  [ parser>> (transform) ] keep
+  code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ;
+
 M: ebnf-var (transform) ( ast -- parser )
   [ parser>> (transform) ] [ name>> ] bi 
   dup vars get push [ dupd set ] curry action ;

extra/peg/peg-docs.factor

@@ -95,6 +95,19 @@ HELP: optional
     "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
     "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
 
+HELP: semantic
+{ $values 
+  { "parser" "a parser" } 
+  { "quot" "a quotation with stack effect ( object -- bool )" } 
+}
+{ $description 
+    "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
+    "the AST produced by 'p1' on the stack returns true." }
+{ $examples 
+  { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" } 
+  { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" } 
+} ;
+
 HELP: ensure
 { $values 
   { "parser" "a parser" } 
@@ -124,7 +137,7 @@ HELP: action
     "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
     "from that parse. The result of the quotation is then used as the final AST. This can be used "
     "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
-    "the default AST." }
+    "the default AST. If the quotation returns " { $link fail } " then the parser fails." }
 { $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
 
 HELP: sp

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 accessors words ;
+USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
 IN: peg.tests
 
 { f } [
@@ -182,4 +182,13 @@ IN: peg.tests
   [ f , "a" token , ] seq*
   dup parsers>>
   dupd 0 swap set-nth compile word?
-] unit-test
+] unit-test
+
+{ f } [
+  "A" [ drop t ] satisfy [ 66 >= ] semantic parse 
+] unit-test
+
+{ CHAR: B } [
+  "B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
+] unit-test
+

extra/peg/peg.factor

@@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ;
 M: optional-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot optional-pattern match-replace ;
 
+TUPLE: semantic-parser p1 quot ;
+
+MATCH-VARS: ?parser ;
+
+: semantic-pattern ( -- quot )
+  [
+    ?parser [
+      dup parse-result-ast ?quot call [ drop f ] unless
+    ] [
+      f
+    ] if*
+  ] ;
+
+M: semantic-parser (compile) ( parser -- quot )
+  [ p1>> compiled-parser ] [ quot>> ] bi  
+  2array { ?parser ?quot } semantic-pattern match-replace ;
+
 TUPLE: ensure-parser p1 ;
 
 : ensure-pattern ( -- quot )
@@ -546,6 +563,9 @@ PRIVATE>
 : optional ( parser -- parser )
   optional-parser construct-boa init-parser ;
 
+: semantic ( parser quot -- parser )
+  semantic-parser construct-boa init-parser ;
+
 : ensure ( parser -- parser )
   ensure-parser construct-boa init-parser ;
 

extra/random/mersenne-twister/mersenne-twister.factor

@@ -10,7 +10,7 @@ IN: random.mersenne-twister
 <PRIVATE
 
 : curry2 ( w quot1 quot2 -- quot1 quot2 )
-    >r over r> [ curry ] 2bi@ ;
+    >r over r> [ curry ] 2bi@ ; inline
 
 TUPLE: mersenne-twister seq i ;