From a4700e072e06f3373e3e9d02cd9c9af9127df098 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 01:56:37 +1300 Subject: [PATCH 01/15] delocalise apply-rule --- extra/peg/peg.factor | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 217805ce47..e9f1d05473 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -188,16 +188,12 @@ C: peg-head m ans>> ] if ; -:: apply-rule ( r p -- ast ) - [let* | - m [ r p recall ] - | - m [ - r m apply-memo-rule - ] [ - r p apply-non-memo-rule - ] if - ] ; inline +: apply-rule ( r p -- ast ) + 2dup recall [ + nip apply-memo-rule + ] [ + apply-non-memo-rule + ] if* ; inline : with-packrat ( input quot -- result ) #! Run the quotation with a packrat cache active. From 72dbac6a2900617818a41d726e2016f3b3b810bb Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 02:07:17 +1300 Subject: [PATCH 02/15] delocalise apply-memo-rule --- extra/peg/peg.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index e9f1d05473..b157580f9b 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -179,14 +179,13 @@ C: peg-head ] if ] ; inline -:: apply-memo-rule ( r m -- ast ) - m pos>> pos set - m ans>> left-recursion? [ - r m ans>> setup-lr - m ans>> seed>> +: apply-memo-rule ( r m -- ast ) + [ ans>> ] [ pos>> ] bi pos set + dup left-recursion? [ + [ setup-lr ] keep seed>> ] [ - m ans>> - ] if ; + nip + ] if ; inline : apply-rule ( r p -- ast ) 2dup recall [ From a6b160c447445461a96c973b7d5e6031ff189c03 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 02:26:41 +1300 Subject: [PATCH 03/15] apply-memo-rule doesn't need to be inline --- extra/peg/peg.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index b157580f9b..3828fe7d9e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -185,7 +185,7 @@ C: peg-head [ setup-lr ] keep seed>> ] [ nip - ] if ; inline + ] if ; : apply-rule ( r p -- ast ) 2dup recall [ From 8b16816bf8ae66e0a3ffa0d22fd0376ee2aee974 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:15:43 +1300 Subject: [PATCH 04/15] Refactor satisfy peg parser --- extra/peg/peg.factor | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3828fe7d9e..8b4991eef3 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences strings namespaces math assocs shuffle +USING: kernel sequences strings fry namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser words quotations effects memoize accessors locals effects ; @@ -282,21 +282,20 @@ TUPLE: satisfy-parser quot ; MATCH-VARS: ?quot ; -: satisfy-pattern ( -- quot ) - [ - input-slice dup empty? [ - drop f - ] [ - unclip-slice dup ?quot call [ - - ] [ - 2drop f - ] if - ] if - ] ; +: parse-satisfy ( input quot -- result ) + swap dup empty? [ + 2drop f + ] [ + unclip-slice rot dupd call [ + + ] [ + 2drop f + ] if + ] if ; inline + M: satisfy-parser (compile) ( parser -- quot ) - quot>> \ ?quot satisfy-pattern match-replace ; + quot>> '[ input-slice , parse-satisfy ] ; TUPLE: range-parser min max ; From 80d11405a980c2d21d1a5b7b34ddab1368fdbc44 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:25:04 +1300 Subject: [PATCH 05/15] Refactor token peg parser --- extra/peg/peg.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8b4991eef3..5ee497707d 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -3,7 +3,7 @@ USING: kernel sequences strings fry namespaces math assocs shuffle vectors arrays combinators.lib math.parser match unicode.categories sequences.lib compiler.units parser - words quotations effects memoize accessors locals effects ; + words quotations effects memoize accessors locals effects splitting ; IN: peg USE: prettyprint @@ -269,19 +269,17 @@ MATCH-VARS: ?token ; : parse-token ( input string -- result ) #! Parse the string, returning a parse result - 2dup head? [ - dup >r length tail-slice r> + dup >r ?head-slice [ + r> ] [ - 2drop f + r> 2drop f ] if ; M: token-parser (compile) ( parser -- quot ) - [ \ input-slice , symbol>> , \ parse-token , ] [ ] make ; + symbol>> '[ input-slice , parse-token ] ; TUPLE: satisfy-parser quot ; -MATCH-VARS: ?quot ; - : parse-satisfy ( input quot -- result ) swap dup empty? [ 2drop f @@ -320,6 +318,8 @@ M: range-parser (compile) ( parser -- quot ) TUPLE: seq-parser parsers ; +MATCH-VARS: ?quot ; + : seq-pattern ( -- quot ) [ dup [ From 7b73d2734fde7387c060816ceee79977404d0671 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:30:10 +1300 Subject: [PATCH 06/15] Refactor range peg parser --- extra/peg/peg.factor | 25 ++++++++++--------------- 1 file changed, 10 insertions(+), 15 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 5ee497707d..671b63949f 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -297,24 +297,19 @@ M: satisfy-parser (compile) ( parser -- quot ) TUPLE: range-parser min max ; -MATCH-VARS: ?min ?max ; - -: range-pattern ( -- quot ) - [ - input-slice dup empty? [ +: parse-range ( input min max -- result ) + pick empty? [ + 3drop f + ] [ + pick first -rot between? [ + unclip-slice + ] [ drop f - ] [ - 0 over nth dup - ?min ?max between? [ - [ 1 tail-slice ] dip - ] [ - 2drop f - ] if - ] if - ] ; + ] if + ] if ; M: range-parser (compile) ( parser -- quot ) - T{ range-parser _ ?min ?max } range-pattern match-replace ; + [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ; TUPLE: seq-parser parsers ; From 102178f787aabd5f5e4ca6f9f3e2c61d3447eb91 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:51:42 +1300 Subject: [PATCH 07/15] Refactor seq peg parser --- extra/peg/peg.factor | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 671b63949f..8c92605c44 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -313,34 +313,38 @@ M: range-parser (compile) ( parser -- quot ) TUPLE: seq-parser parsers ; -MATCH-VARS: ?quot ; +: ignore? ( ast -- bool ) + ignore = ; -: seq-pattern ( -- quot ) +: calc-seq-result ( prev-result current-result -- next-result ) [ - dup [ - ?quot [ - [ remaining>> swap (>>remaining) ] 2keep - ast>> dup ignore = [ - drop - ] [ - swap [ ast>> push ] keep - ] if - ] [ - drop f - ] if* + [ remaining>> swap (>>remaining) ] 2keep + ast>> dup ignore? [ + drop ] [ - drop f - ] if - ] ; + swap [ ast>> push ] keep + ] if + ] [ + drop f + ] if* ; + +: parse-seq-element ( result quot -- result ) + over [ + call calc-seq-result + ] [ + 2drop f + ] if ; inline M: seq-parser (compile) ( parser -- quot ) [ [ input-slice V{ } clone ] % - parsers>> [ compiled-parser \ ?quot seq-pattern match-replace % ] each + parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each ] [ ] make ; TUPLE: choice-parser parsers ; +MATCH-VARS: ?quot ; + : choice-pattern ( -- quot ) [ [ ?quot ] unless* From 226d211342bef6b64354396fbcbb06e49700b5dc Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 17:54:18 +1300 Subject: [PATCH 08/15] Refactor choice peg parser --- extra/peg/peg.factor | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8c92605c44..465e0dd757 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -343,21 +343,16 @@ M: seq-parser (compile) ( parser -- quot ) TUPLE: choice-parser parsers ; -MATCH-VARS: ?quot ; - -: choice-pattern ( -- quot ) - [ - [ ?quot ] unless* - ] ; - M: choice-parser (compile) ( parser -- quot ) [ f , - parsers>> [ compiled-parser \ ?quot choice-pattern match-replace % ] each + parsers>> [ compiled-parser 1quotation , \ unless* , ] each ] [ ] make ; TUPLE: repeat0-parser p1 ; +MATCH-VARS: ?quot ; + : (repeat0) ( quot result -- result ) over call [ [ remaining>> swap (>>remaining) ] 2keep From d4897fa007bd12dd2bd56dd7dd11cf4eeb7e885f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:01:18 +1300 Subject: [PATCH 09/15] Refactor repeat0 and repeat1 peg parsers --- extra/peg/peg.factor | 42 +++++++++++++++--------------------------- 1 file changed, 15 insertions(+), 27 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 465e0dd757..8c427d5e27 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -351,48 +351,36 @@ M: choice-parser (compile) ( parser -- quot ) TUPLE: repeat0-parser p1 ; -MATCH-VARS: ?quot ; - -: (repeat0) ( quot result -- result ) +: (repeat) ( quot result -- result ) over call [ [ remaining>> swap (>>remaining) ] 2keep ast>> swap [ ast>> push ] keep - (repeat0) - ] [ + (repeat) + ] [ nip ] if* ; inline -: repeat0-pattern ( -- quot ) - [ - [ ?quot ] swap (repeat0) - ] ; - M: repeat0-parser (compile) ( parser -- quot ) - [ - [ input-slice V{ } clone ] % - p1>> compiled-parser \ ?quot repeat0-pattern match-replace % - ] [ ] make ; + p1>> compiled-parser 1quotation '[ + input-slice V{ } clone , swap (repeat) + ] ; TUPLE: repeat1-parser p1 ; -: repeat1-pattern ( -- quot ) +: repeat1-empty-check ( result -- result ) [ - [ ?quot ] swap (repeat0) [ - dup ast>> empty? [ - drop f - ] when - ] [ - f - ] if* - ] ; + dup ast>> empty? [ drop f ] when + ] [ + f + ] if* ; M: repeat1-parser (compile) ( parser -- quot ) - [ - [ input-slice V{ } clone ] % - p1>> compiled-parser \ ?quot repeat1-pattern match-replace % - ] [ ] make ; + p1>> compiled-parser 1quotation '[ + input-slice V{ } clone , swap (repeat) repeat1-empty-check + ] ; TUPLE: optional-parser p1 ; +MATCH-VARS: ?quot ; : optional-pattern ( -- quot ) [ From 3123654a8462634914010b5135261cc4237f9661 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:05:09 +1300 Subject: [PATCH 10/15] Refactor optional peg parser --- extra/peg/peg.factor | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 8c427d5e27..332f7164f8 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -380,17 +380,15 @@ M: repeat1-parser (compile) ( parser -- quot ) ] ; TUPLE: optional-parser p1 ; -MATCH-VARS: ?quot ; -: optional-pattern ( -- quot ) - [ - ?quot [ input-slice f ] unless* - ] ; +: check-optional ( result -- result ) + [ input-slice f ] unless* ; M: optional-parser (compile) ( parser -- quot ) - p1>> compiled-parser \ ?quot optional-pattern match-replace ; + p1>> compiled-parser 1quotation '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; +MATCH-VARS: ?quot ; MATCH-VARS: ?parser ; From 796981e192e3a2f622be5c3bc455efd1e49bd6af Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:19:11 +1300 Subject: [PATCH 11/15] Refactor semantic peg parser --- extra/peg/peg.factor | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 332f7164f8..ab70745b11 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -392,18 +392,16 @@ MATCH-VARS: ?quot ; MATCH-VARS: ?parser ; -: semantic-pattern ( -- quot ) - [ - ?parser [ - dup parse-result-ast ?quot call [ drop f ] unless - ] [ - f - ] if* - ] ; +: check-semantic ( result quot -- result ) + over [ + over ast>> swap call [ drop f ] unless + ] [ + drop + ] if ; inline M: semantic-parser (compile) ( parser -- quot ) - [ p1>> compiled-parser ] [ quot>> ] bi - 2array { ?parser ?quot } semantic-pattern match-replace ; + [ p1>> compiled-parser 1quotation ] [ quot>> ] bi + '[ @ , check-semantic ] ; TUPLE: ensure-parser p1 ; From 247bf2137bbb785f644219f695388426bf05c389 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:30:11 +1300 Subject: [PATCH 12/15] Refactor ensure and ensure-not parsers --- extra/peg/peg.factor | 24 ++++++------------------ 1 file changed, 6 insertions(+), 18 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ab70745b11..7970d761de 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -405,31 +405,19 @@ M: semantic-parser (compile) ( parser -- quot ) TUPLE: ensure-parser p1 ; -: ensure-pattern ( -- quot ) - [ - input-slice ?quot [ - ignore - ] [ - drop f - ] if - ] ; +: check-ensure ( old-input result -- result ) + [ ignore ] [ drop f ] if ; M: ensure-parser (compile) ( parser -- quot ) - p1>> compiled-parser \ ?quot ensure-pattern match-replace ; + p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ; TUPLE: ensure-not-parser p1 ; -: ensure-not-pattern ( -- quot ) - [ - input-slice ?quot [ - drop f - ] [ - ignore - ] if - ] ; +: check-ensure-not ( old-input result -- result ) + [ drop f ] [ ignore ] if ; M: ensure-not-parser (compile) ( parser -- quot ) - p1>> compiled-parser \ ?quot ensure-not-pattern match-replace ; + p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ; TUPLE: action-parser p1 quot ; From d93c7958fdad169d99dc1ddeb1ef01cae6594b0f Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:33:50 +1300 Subject: [PATCH 13/15] Refactor action peg parser --- extra/peg/peg.factor | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7970d761de..fd41a67bfe 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -423,17 +423,16 @@ TUPLE: action-parser p1 quot ; MATCH-VARS: ?action ; -: action-pattern ( -- quot ) - [ - ?quot dup [ - dup ast>> ?action call - >>ast - ] when - ] ; +: check-action ( result quot -- result ) + over [ + over ast>> swap call >>ast + ] [ + drop + ] if ; inline M: action-parser (compile) ( parser -- quot ) - [ p1>> compiled-parser ] [ quot>> ] bi - 2array { ?quot ?action } action-pattern match-replace ; + [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ + @ , check-action ] ; : left-trim-slice ( string -- string ) #! Return a new string without any leading whitespace From 2744313ac14679397be74f345b63b9264b53db3b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:36:17 +1300 Subject: [PATCH 14/15] Refactor sp peg parser --- extra/peg/peg.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index fd41a67bfe..22405c9cbf 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -431,8 +431,7 @@ MATCH-VARS: ?action ; ] if ; inline M: action-parser (compile) ( parser -- quot ) - [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ - @ , check-action ] ; + [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; : left-trim-slice ( string -- string ) #! Return a new string without any leading whitespace @@ -444,9 +443,9 @@ M: action-parser (compile) ( parser -- quot ) TUPLE: sp-parser p1 ; M: sp-parser (compile) ( parser -- quot ) - [ - \ input-slice , \ left-trim-slice , \ input-from , \ pos , \ set , p1>> compiled-parser , - ] [ ] make ; + p1>> compiled-parser 1quotation '[ + input-slice left-trim-slice input-from pos set @ + ] ; TUPLE: delay-parser quot ; From e00a392736161a3438476a7adc6a37fdc6482f6c Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 5 Apr 2008 18:41:28 +1300 Subject: [PATCH 15/15] Refactor delay parser --- extra/peg/peg.factor | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 22405c9cbf..8d5d1c1560 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -453,11 +453,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 , - ] [ ] make - { } { "word" } memoize-quot - [ % \ execute , ] [ ] make ; + quot>> '[ @ compile ] { } { "word" } memoize-quot '[ @ execute ] ; TUPLE: box-parser quot ;