From 1fe15b322d4811d8323c9333d7c7dcdb12fc2c1a Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Fri, 21 Dec 2007 11:38:25 +1300
Subject: [PATCH 1/3] Fix number/sequence error in match-replace
---
extra/match/match.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/match/match.factor b/extra/match/match.factor
index 527d7f2465..a80001e724 100755
--- a/extra/match/match.factor
+++ b/extra/match/match.factor
@@ -54,6 +54,7 @@ MACRO: match-cond ( assoc -- )
: replace-patterns ( object -- result )
{
+ { [ dup number? ] [ ] }
{ [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
From e7cf83a57a16ae4bb34be7c04b0f26a8c1672561 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Fri, 21 Dec 2007 13:16:14 +1300
Subject: [PATCH 2/3] First attempt at compiling peg parsers to quotations
---
extra/peg/peg.factor | 266 +++++++++++++++++++++++++++----------------
1 file changed, 169 insertions(+), 97 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 411a47b9bd..3d9128fec9 100644
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,12 +1,16 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib memoize math.parser ;
+ vectors arrays combinators.lib memoize math.parser match ;
IN: peg
TUPLE: parse-result remaining ast ;
-GENERIC: (parse) ( state parser -- result )
+GENERIC: compile ( parser -- quot )
+
+: (parse) ( state parser -- result )
+ compile call ;
+
<PRIVATE
@@ -72,135 +76,199 @@ PRIVATE>
TUPLE: token-parser symbol ;
-M: token-parser (parse) ( input parser -- result )
- token-parser-symbol 2dup head? [
- dup >r length tail-slice r> <parse-result>
- ] [
- 2drop f
- ] if ;
-
-TUPLE: satisfy-parser quot ;
+MATCH-VARS: ?token ;
-M: satisfy-parser (parse) ( state parser -- result )
- over empty? [
- 2drop f
- ] [
- satisfy-parser-quot [ unclip-slice dup ] dip call [
- <parse-result>
+: token-pattern ( -- quot )
+ [
+ ?token 2dup head? [
+ dup >r length tail-slice r> <parse-result>
] [
2drop f
- ] if
- ] if ;
+ ] if
+ ] ;
+
+M: token-parser compile ( parser -- quot )
+ token-parser-symbol \ ?token token-pattern match-replace ;
+
+TUPLE: satisfy-parser quot ;
+
+MATCH-VARS: ?quot ;
+
+: satisfy-pattern ( -- quot )
+ [
+ dup empty? [
+ drop f
+ ] [
+ unclip-slice dup ?quot call [
+ <parse-result>
+ ] [
+ 2drop f
+ ] if
+ ] if
+ ] ;
+
+M: satisfy-parser compile ( parser -- quot )
+ satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
TUPLE: range-parser min max ;
-M: range-parser (parse) ( state parser -- result )
- over empty? [
- 2drop f
- ] [
- 0 pick nth dup rot
- { range-parser-min range-parser-max } get-slots between? [
- [ 1 tail-slice ] dip <parse-result>
+MATCH-VARS: ?min ?max ;
+
+: range-pattern ( -- quot )
+ [
+ dup empty? [
+ drop f
] [
- 2drop f
- ] if
- ] if ;
+ 0 over nth dup
+ ?min ?max between? [
+ [ 1 tail-slice ] dip <parse-result>
+ ] [
+ 2drop f
+ ] if
+ ] if
+ ] ;
+
+M: range-parser compile ( parser -- quot )
+ T{ range-parser _ ?min ?max } range-pattern match-replace ;
TUPLE: seq-parser parsers ;
-: do-seq-parser ( result parser -- result )
- [ dup parse-result-remaining ] dip parse [
- [ parse-result-remaining swap set-parse-result-remaining ] 2keep
- parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if
- ] [
- drop f
- ] if* ;
+: seq-pattern ( -- quot )
+ [
+ dup [
+ dup parse-result-remaining ?quot call [
+ [ parse-result-remaining swap set-parse-result-remaining ] 2keep
+ parse-result-ast dup ignore = [
+ drop
+ ] [
+ swap [ parse-result-ast push ] keep
+ ] if
+ ] [
+ drop f
+ ] if*
+ ] [
+ drop f
+ ] if
+ ] ;
-: (seq-parser) ( result parsers -- result )
- dup empty? not pick and [
- unclip swap [ do-seq-parser ] dip (seq-parser)
- ] [
- drop
- ] if ;
-
-M: seq-parser (parse) ( state parser -- result )
- seq-parser-parsers [ V{ } clone <parse-result> ] dip (seq-parser) ;
+M: seq-parser compile ( parser -- quot )
+ [
+ [ V{ } clone <parse-result> ] %
+ seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each
+ ] [ ] make ;
TUPLE: choice-parser parsers ;
-
-: (choice-parser) ( state parsers -- result )
- dup empty? [
- 2drop f
- ] [
- unclip pick swap parse [
- 2nip
- ] [
- (choice-parser)
- ] if*
- ] if ;
-M: choice-parser (parse) ( state parser -- result )
- choice-parser-parsers (choice-parser) ;
+: choice-pattern ( -- quot )
+ [
+ dup [
+
+ ] [
+ drop dup ?quot call
+ ] if
+ ] ;
+
+M: choice-parser compile ( parser -- quot )
+ [
+ f ,
+ choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
+ \ nip ,
+ ] [ ] make ;
TUPLE: repeat0-parser p1 ;
-: (repeat-parser) ( parser result -- result )
- 2dup parse-result-remaining swap parse [
+: (repeat0) ( quot result -- result )
+ 2dup parse-result-remaining swap call [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep
parse-result-ast swap [ parse-result-ast push ] keep
- (repeat-parser)
+ (repeat0)
] [
nip
- ] if* ;
+ ] if* ; inline
-: clone-result ( result -- result )
- { parse-result-remaining parse-result-ast }
- get-slots 1vector <parse-result> ;
+: repeat0-pattern ( -- quot )
+ [
+ ?quot swap (repeat0)
+ ] ;
-M: repeat0-parser (parse) ( state parser -- result )
- repeat0-parser-p1 2dup parse [
- nipd clone-result (repeat-parser)
- ] [
- drop V{ } clone <parse-result>
- ] if* ;
+M: repeat0-parser compile ( parser -- quot )
+ [
+ [ V{ } clone <parse-result> ] %
+ repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %
+ ] [ ] make ;
TUPLE: repeat1-parser p1 ;
-M: repeat1-parser (parse) ( state parser -- result )
- repeat1-parser-p1 tuck parse dup [ clone-result (repeat-parser) ] [ nip ] if ;
+: repeat1-pattern ( -- quot )
+ [
+ ?quot swap (repeat0) [
+ dup parse-result-ast empty? [
+ drop f
+ ] when
+ ] [
+ f
+ ] if*
+ ] ;
+
+M: repeat1-parser compile ( parser -- quot )
+ [
+ [ V{ } clone <parse-result> ] %
+ repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace %
+ ] [ ] make ;
TUPLE: optional-parser p1 ;
-M: optional-parser (parse) ( state parser -- result )
- dupd optional-parser-p1 parse swap f <parse-result> or ;
+: optional-pattern ( -- quot )
+ [
+ dup ?quot call swap f <parse-result> or
+ ] ;
+
+M: optional-parser compile ( parser -- quot )
+ optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
TUPLE: ensure-parser p1 ;
-M: ensure-parser (parse) ( state parser -- result )
- dupd ensure-parser-p1 parse [
- ignore <parse-result>
- ] [
- drop f
- ] if ;
+: ensure-pattern ( -- quot )
+ [
+ dup ?quot call [
+ ignore <parse-result>
+ ] [
+ drop f
+ ] if
+ ] ;
+
+M: ensure-parser compile ( parser -- quot )
+ ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
TUPLE: ensure-not-parser p1 ;
-M: ensure-not-parser (parse) ( state parser -- result )
- dupd ensure-not-parser-p1 parse [
- drop f
- ] [
- ignore <parse-result>
- ] if ;
+: ensure-not-pattern ( -- quot )
+ [
+ dup ?quot call [
+ drop f
+ ] [
+ ignore <parse-result>
+ ] if
+ ] ;
+
+M: ensure-not-parser compile ( parser -- quot )
+ ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
TUPLE: action-parser p1 quot ;
-M: action-parser (parse) ( state parser -- result )
- tuck action-parser-p1 parse dup [
- dup parse-result-ast rot action-parser-quot call
- swap [ set-parse-result-ast ] keep
- ] [
- nip
- ] if ;
+MATCH-VARS: ?action ;
+
+: action-pattern ( -- quot )
+ [
+ ?quot call dup [
+ dup parse-result-ast ?action call
+ swap [ set-parse-result-ast ] keep
+ ] when
+ ] ;
+
+M: action-parser compile ( parser -- quot )
+ { action-parser-p1 action-parser-quot } get-slots [ compile ] dip
+ 2array { ?quot ?action } action-pattern match-replace ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
@@ -211,13 +279,17 @@ M: action-parser (parse) ( state parser -- result )
TUPLE: sp-parser p1 ;
-M: sp-parser (parse) ( state parser -- result )
- [ left-trim-slice ] dip sp-parser-p1 parse ;
+M: sp-parser compile ( parser -- quot )
+ [
+ \ left-trim-slice , sp-parser-p1 compile %
+ ] [ ] make ;
TUPLE: delay-parser quot ;
-M: delay-parser (parse) ( state parser -- result )
- delay-parser-quot call parse ;
+M: delay-parser compile ( parser -- quot )
+ [
+ delay-parser-quot % \ compile , \ call ,
+ ] [ ] make ;
PRIVATE>
From ffd25ce5a81628c9a0f012188dc87c9c78aee261 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Fri, 21 Dec 2007 13:24:14 +1300
Subject: [PATCH 3/3] Fix missing vocab in match
---
extra/match/match.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/match/match.factor b/extra/match/match.factor
index a80001e724..421aa926f9 100755
--- a/extra/match/match.factor
+++ b/extra/match/match.factor
@@ -3,7 +3,7 @@
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
USING: parser kernel words namespaces sequences tuples
-combinators macros assocs ;
+combinators macros assocs math ;
IN: match
SYMBOL: _