From 9fc2175403a4108f90f6593aaac53a82b114d597 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Fri, 11 Jul 2008 02:27:28 +1200
Subject: [PATCH] peg refactorings

---
 extra/peg/parsers/parsers.factor |  2 +-
 extra/peg/peg.factor             | 38 ++++++++++++++++++--------------
 2 files changed, 23 insertions(+), 17 deletions(-)

diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor
index f6c2820ac2..b5b2886a5e 100755
--- a/extra/peg/parsers/parsers.factor
+++ b/extra/peg/parsers/parsers.factor
@@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
 
 
 M: just-parser (compile) ( parser -- quot )
-  just-parser-p1 compiled-parser just-pattern curry ;
+  just-parser-p1 compile-parser just-pattern curry ;
 
 : just ( parser -- parser )
   just-parser boa wrap-peg ;
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index eec4007c02..147e5b892e 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -280,7 +280,13 @@ GENERIC: (compile) ( peg -- quot )
   gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
   [ execute-parser ] curry ;
 
-: compiled-parser ( parser -- word )
+: preset-parser-word ( parser -- parser word )
+  gensym [ >>compiled ] keep ;
+
+: define-parser-word ( parser word -- )
+  swap parser-body (( -- result )) define-declared ;
+
+: compile-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.
@@ -290,7 +296,7 @@ GENERIC: (compile) ( peg -- quot )
   dup compiled>> [
     nip
   ] [
-    gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
+    preset-parser-word [ define-parser-word ] keep
   ] if* ;
 
 SYMBOL: delayed
@@ -299,13 +305,13 @@ SYMBOL: 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
+    call compile-parser 1quotation 0 1 <effect> define-declared
   ] assoc-each ;
 
 : compile ( parser -- word )
   [
     H{ } clone delayed [ 
-      compiled-parser fixup-delayed 
+      compile-parser fixup-delayed 
     ] with-variable
   ] with-compilation-unit ;
 
@@ -412,8 +418,8 @@ M: seq-parser (compile) ( peg -- quot )
   [
     [ input-slice V{ } clone <parse-result> ] %
     [
-      parsers>> unclip compiled-parser 1quotation [ parse-seq-element ] curry ,
-      [ compiled-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each 
+      parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
+      [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each 
     ] { } make , \ && , 
   ] [ ] make ;
 
@@ -422,7 +428,7 @@ TUPLE: choice-parser parsers ;
 M: choice-parser (compile) ( peg -- quot )
   [ 
     [
-      parsers>> [ compiled-parser ] map 
+      parsers>> [ compile-parser ] map 
       unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
     ] { } make , \ || ,
   ] [ ] make ;
@@ -439,7 +445,7 @@ TUPLE: repeat0-parser p1 ;
   ] if* ; inline
 
 M: repeat0-parser (compile) ( peg -- quot )
-  p1>> compiled-parser 1quotation '[ 
+  p1>> compile-parser 1quotation '[ 
     input-slice V{ } clone <parse-result> , swap (repeat) 
   ] ; 
 
@@ -453,7 +459,7 @@ TUPLE: repeat1-parser p1 ;
   ] if* ;
 
 M: repeat1-parser (compile) ( peg -- quot )
-  p1>> compiled-parser 1quotation '[ 
+  p1>> compile-parser 1quotation '[ 
     input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check  
   ] ; 
 
@@ -463,7 +469,7 @@ TUPLE: optional-parser p1 ;
   [ input-slice f <parse-result> ] unless* ;
 
 M: optional-parser (compile) ( peg -- quot )
-  p1>> compiled-parser 1quotation '[ @ check-optional ] ;
+  p1>> compile-parser 1quotation '[ @ check-optional ] ;
 
 TUPLE: semantic-parser p1 quot ;
 
@@ -475,7 +481,7 @@ TUPLE: semantic-parser p1 quot ;
   ] if ; inline
 
 M: semantic-parser (compile) ( peg -- quot )
-  [ p1>> compiled-parser 1quotation ] [ quot>> ] bi  
+  [ p1>> compile-parser 1quotation ] [ quot>> ] bi  
   '[ @ , check-semantic ] ;
 
 TUPLE: ensure-parser p1 ;
@@ -484,7 +490,7 @@ TUPLE: ensure-parser p1 ;
   [ ignore <parse-result> ] [ drop f ] if ;
 
 M: ensure-parser (compile) ( peg -- quot )
-  p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ;
+  p1>> compile-parser 1quotation '[ input-slice @ check-ensure ] ;
 
 TUPLE: ensure-not-parser p1 ;
 
@@ -492,7 +498,7 @@ TUPLE: ensure-not-parser p1 ;
   [ drop f ] [ ignore <parse-result> ] if ;
 
 M: ensure-not-parser (compile) ( peg -- quot )
-  p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ;
+  p1>> compile-parser 1quotation '[ input-slice @ check-ensure-not ] ;
 
 TUPLE: action-parser p1 quot ;
 
@@ -504,7 +510,7 @@ TUPLE: action-parser p1 quot ;
   ] if ; inline
 
 M: action-parser (compile) ( peg -- quot )
-  [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
+  [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
 
 : left-trim-slice ( string -- string )
   #! Return a new string without any leading whitespace
@@ -516,7 +522,7 @@ M: action-parser (compile) ( peg -- quot )
 TUPLE: sp-parser p1 ;
 
 M: sp-parser (compile) ( peg -- quot )
-  p1>> compiled-parser 1quotation '[ 
+  p1>> compile-parser 1quotation '[ 
     input-slice left-trim-slice input-from pos set @ 
   ] ;
 
@@ -535,7 +541,7 @@ M: box-parser (compile) ( peg -- quot )
   #! to produce the parser to be compiled.
   #! This differs from 'delay' which calls
   #! it at run time.
-  quot>> call compiled-parser 1quotation ;
+  quot>> call compile-parser 1quotation ;
 
 PRIVATE>