From a4461ae40834ca48418f9117dca72b99c9535f76 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 29 Nov 2007 17:24:02 +1300
Subject: [PATCH] Tidy up ebnf compilation

---
 extra/peg/ebnf/ebnf.factor | 147 +++++++++++++++++++++----------------
 1 file changed, 85 insertions(+), 62 deletions(-)

diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 4c4c8cd0cc..fea31ce94b 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel parser words arrays strings math.parser sequences quotations vectors namespaces peg ;
+USING: kernel parser words arrays strings math.parser sequences 
+       quotations vectors namespaces math assocs continuations peg ;
 IN: peg.ebnf
 
 TUPLE: ebnf-non-terminal symbol ;
@@ -23,74 +24,77 @@ C: <ebnf-rule> ebnf-rule
 C: <ebnf-action> ebnf-action
 C: <ebnf> ebnf
 
-GENERIC: ebnf-compile ( ast -- quot )
+SYMBOL: parsers
+SYMBOL: non-terminals
+SYMBOL: last-parser
 
-M: ebnf-terminal ebnf-compile ( ast -- quot )
+: reset-parser-generation ( -- ) 
+  V{ } clone parsers set 
+  H{ } clone non-terminals set 
+  f last-parser set ;
+
+: store-parser ( parser -- number )
+  parsers get [ push ] keep length 1- ;
+
+: get-parser ( index -- parser )
+  parsers get nth ;
+  
+: non-terminal-index ( name -- number )
+  dup non-terminals get at [
+    nip
+  ] [
+    f store-parser [ swap non-terminals get set-at ] keep
+  ] if* ;
+
+GENERIC: (generate-parser) ( ast -- id )
+
+: generate-parser ( ast -- id )
+  (generate-parser) dup last-parser set ;
+
+M: ebnf-terminal (generate-parser) ( ast -- id )
+  ebnf-terminal-symbol token sp store-parser ;
+
+M: ebnf-non-terminal (generate-parser) ( ast -- id )
   [
-    ebnf-terminal-symbol , \ token , \ sp , 
-  ] [ ] make ;
+    ebnf-non-terminal-symbol dup non-terminal-index , 
+    parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
+  ] [ ] make delay sp store-parser ;
 
-M: ebnf-non-terminal ebnf-compile ( ast -- quot )
-  [
-    [ ebnf-non-terminal-symbol , \ search , \ execute , \ sp , ] [ ] make 
-    , \ delay ,
-  ] [ ] make ;
+M: ebnf-choice (generate-parser) ( ast -- id )
+  ebnf-choice-options [
+    generate-parser get-parser 
+  ] map choice store-parser ;
 
-M: ebnf-choice ebnf-compile ( ast -- quot )
-  [
-    [
-      ebnf-choice-options [
-        ebnf-compile ,
-      ] each
-    ] { } make ,
-    [ call ] , \ map , \ choice , 
-  ] [ ] make ;
+M: ebnf-sequence (generate-parser) ( ast -- id )
+  ebnf-sequence-elements [
+    generate-parser get-parser
+  ] map seq store-parser ;
 
-M: ebnf-sequence ebnf-compile ( ast -- quot )
-  [
-    [
-      ebnf-sequence-elements [
-        ebnf-compile ,
-      ] each
-    ] { } make ,
-    [ call ] , \ map , \ seq , 
-  ] [ ] make ;
+M: ebnf-repeat0 (generate-parser) ( ast -- id )
+  ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
 
-M: ebnf-repeat0 ebnf-compile ( ast -- quot )
-  [
-    ebnf-repeat0-group ebnf-compile % \ repeat0 , 
-  ] [ ] make ;
+M: ebnf-optional (generate-parser) ( ast -- id )
+  ebnf-optional-elements generate-parser get-parser optional store-parser ;
 
-M: ebnf-optional ebnf-compile ( ast -- quot )
-  [
-    ebnf-optional-elements ebnf-compile % \ optional , 
-  ] [ ] make ;
+M: ebnf-rule (generate-parser) ( ast -- id )
+  dup ebnf-rule-symbol non-terminal-index swap 
+  ebnf-rule-elements generate-parser get-parser ! nt-id body
+  swap [ parsers get set-nth ] keep ;
 
-M: ebnf-rule ebnf-compile ( ast -- quot )
-  [
-    dup ebnf-rule-symbol , \ in , \ get , \ create , 
-    ebnf-rule-elements ebnf-compile , \ define-compound , 
-  ] [ ] make ;
+M: ebnf-action (generate-parser) ( ast -- id )
+  ebnf-action-word search 1quotation 
+  last-parser get swap action generate-parser ;
 
-M: ebnf-action ebnf-compile ( ast -- quot )
-  [
-    ebnf-action-word search 1quotation , \ action , 
-  ] [ ] make ;
+M: vector (generate-parser) ( ast -- id )
+  [ generate-parser ] map peek ;
 
-M: vector ebnf-compile ( ast -- quot )
-  [
-    [ ebnf-compile % ] each 
-  ] [ ] make ;
+M: f (generate-parser) ( ast -- id )
+  drop last-parser get ;
 
-M: f ebnf-compile ( ast -- quot )
-  drop [ ] ;
-
-M: ebnf ebnf-compile ( ast -- quot )
-  [
-    ebnf-rules [
-      ebnf-compile %
-    ] each 
-  ] [ ] make ;
+M: ebnf (generate-parser) ( ast -- id )
+  ebnf-rules [
+    generate-parser 
+  ] map peek ;
 
 DEFER: 'rhs'
 
@@ -124,7 +128,12 @@ DEFER: 'choice'
   3array seq [ first <ebnf-optional> ] action ;
 
 : 'sequence' ( -- parser )
-  'element' sp 'group' sp 'repeat0' sp 'optional' sp 4array choice 
+  [ 
+    'element' sp ,
+    'group' sp , 
+    'repeat0' sp ,
+    'optional' sp , 
+   ] { } make  choice  
    repeat1 [ 
      dup length 1 = [ first ] [ <ebnf-sequence> ] if
    ] action ;  
@@ -133,12 +142,12 @@ DEFER: 'choice'
   'sequence' sp "|" token sp list-of [ 
     dup length 1 = [ first ] [ <ebnf-choice> ] if
    ] action ;
-  
+
 : 'action' ( -- parser )
   "=>" token hide
   [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
   2array seq [ first <ebnf-action> ] action ;
-
+  
 : 'rhs' ( -- parser )
   'choice' 'action' sp optional 2array seq ;
  
@@ -153,7 +162,21 @@ DEFER: 'choice'
 
 : ebnf>quot ( string -- quot )
   'ebnf' parse [
-     parse-result-ast ebnf-compile  
+     parse-result-ast [
+         reset-parser-generation
+         generate-parser drop
+         [
+             non-terminals get
+             [
+               get-parser [
+                 swap , \ in , \ get , \ create ,
+                 1quotation , \ define-compound , 
+               ] [
+                 drop
+               ] if*
+             ] assoc-each
+         ] [ ] make
+     ] with-scope
    ] [
     f
    ] if* ;