From f66774e87564aa5f6d66f80dd00c72b2db456700 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 31 Mar 2008 16:50:05 +1300
Subject: [PATCH] Add tests for semantic and add syntax for it to ebnf Syntax
 is ?[ ...]? For example: [EBNF num=. ?[ number? ]? list=list:x num:y => [[
 drop x y + ]] | num EBNF] { 1 2 3 4 5 6 } swap call .

---
 extra/peg/ebnf/ebnf-tests.factor | 12 ++++++++++++
 extra/peg/ebnf/ebnf.factor       | 16 ++++++++++++----
 extra/peg/peg-tests.factor       | 13 +++++++++++--
 3 files changed, 35 insertions(+), 6 deletions(-)

diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index cf16fad2cd..4f802c5207 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/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  
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 74b3e3540d..4f00edbd3c 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/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 ;
diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index f57fe83220..fcec33f7c2 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 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
\ No newline at end of file
+] 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
+