From 688cbfaafacf383374b162d6163ca957f7b84032 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 11 Apr 2008 14:46:11 +1200
Subject: [PATCH 1/2] Delocalise grow-lr
---
extra/peg/peg.factor | 24 ++++++++++++------------
1 file changed, 12 insertions(+), 12 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 7390c15684..164f7c9ee9 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -100,21 +100,21 @@ C: <head> peg-head
: setup-growth ( h p -- )
pos set dup involved-set>> clone >>eval-set drop ;
-:: (grow-lr) ( h p r m -- )
- h p setup-growth
- r eval-rule
- dup m stop-growth? [
- drop
+: (grow-lr) ( h p r m -- )
+ >r >r [ setup-growth ] 2keep r> r>
+ >r dup eval-rule r> swap
+ dup pick stop-growth? [
+ 4drop drop
] [
- m update-m
- h p r m (grow-lr)
+ over update-m
+ (grow-lr)
] if ; inline
-:: grow-lr ( h p r m -- ast )
- h p heads get set-at
- h p r m (grow-lr)
- p heads get delete-at
- m pos>> pos set m ans>>
+: grow-lr ( h p r m -- ast )
+ >r >r [ heads get set-at ] 2keep r> r>
+ pick over >r >r (grow-lr) r> r>
+ swap heads get delete-at
+ dup pos>> pos set ans>>
; inline
:: (setup-lr) ( r l s -- )
From 9f0f2d0bbc0346046414b00f270c39d72d58042b Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 14 Apr 2008 22:42:45 +1200
Subject: [PATCH 2/2] peg delay parsers now infer
---
extra/peg/ebnf/ebnf-tests.factor | 2 ++
extra/peg/peg.factor | 17 +++++++++++++++--
2 files changed, 17 insertions(+), 2 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 0879ecda49..0292a88ad9 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -295,3 +295,5 @@ main = Primary
{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
"x[i][j].y" primary parse-result-ast
] unit-test
+
+'ebnf' compile must-infer
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 164f7c9ee9..8fe6664807 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -240,8 +240,21 @@ GENERIC: (compile) ( parser -- quot )
gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
] if* ;
+SYMBOL: delayed
+
+: fixup-delayed ( -- )
+ #! Work through all delayed parsers and recompile their
+ #! words to have the correct bodies.
+ delayed get [
+ call compiled-parser 1quotation 0 1 <effect> define-declared
+ ] assoc-each ;
+
: compile ( parser -- word )
- [ compiled-parser ] with-compilation-unit ;
+ [
+ H{ } clone delayed [
+ compiled-parser fixup-delayed
+ ] with-variable
+ ] with-compilation-unit ;
: compiled-parse ( state word -- result )
swap [ execute ] with-packrat ; inline
@@ -451,7 +464,7 @@ 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.
- quot>> '[ @ compile ] { } { "word" } <effect> memoize-quot '[ @ execute ] ;
+ quot>> gensym [ delayed get set-at ] keep 1quotation ;
TUPLE: box-parser quot ;