steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

First attempt at compiling peg parsers to quotations

db4
Chris Double 2007-12-21 13:16:14 +13:00
parent 1fe15b322d
commit e7cf83a57a
1 changed files with 169 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

258
extra/peg/peg.factor
View File

@ -1,12 +1,16 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle 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 IN: peg
TUPLE: parse-result remaining ast ; TUPLE: parse-result remaining ast ;
GENERIC: (parse) ( state parser -- result ) GENERIC: compile ( parser -- quot )
: (parse) ( state parser -- result )
compile call ;
<PRIVATE <PRIVATE
@ -72,135 +76,199 @@ PRIVATE>
TUPLE: token-parser symbol ; TUPLE: token-parser symbol ;
M: token-parser (parse) ( input parser -- result ) MATCH-VARS: ?token ;
token-parser-symbol 2dup head? [
dup >r length tail-slice r> <parse-result> : token-pattern ( -- quot )
] [ [
2drop f ?token 2dup head? [
] if ; dup >r length tail-slice r> <parse-result>
] [
2drop f
] if
] ;
M: token-parser compile ( parser -- quot )
token-parser-symbol \ ?token token-pattern match-replace ;
TUPLE: satisfy-parser quot ; TUPLE: satisfy-parser quot ;
M: satisfy-parser (parse) ( state parser -- result ) MATCH-VARS: ?quot ;
over empty? [
2drop f : satisfy-pattern ( -- quot )
] [ [
satisfy-parser-quot [ unclip-slice dup ] dip call [ dup empty? [
<parse-result> drop f
] [ ] [
2drop f unclip-slice dup ?quot call [
<parse-result>
] [
2drop f
] if
] if ] if
] if ; ] ;
M: satisfy-parser compile ( parser -- quot )
satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
TUPLE: range-parser min max ; TUPLE: range-parser min max ;
M: range-parser (parse) ( state parser -- result ) MATCH-VARS: ?min ?max ;
over empty? [
2drop f : range-pattern ( -- quot )
] [ [
0 pick nth dup rot dup empty? [
{ range-parser-min range-parser-max } get-slots between? [ drop f
[ 1 tail-slice ] dip <parse-result>
] [ ] [
2drop f 0 over nth dup
?min ?max between? [
[ 1 tail-slice ] dip <parse-result>
] [
2drop f
] if
] if ] if
] if ; ] ;
M: range-parser compile ( parser -- quot )
T{ range-parser _ ?min ?max } range-pattern match-replace ;
TUPLE: seq-parser parsers ; TUPLE: seq-parser parsers ;
: do-seq-parser ( result parser -- result ) : seq-pattern ( -- quot )
[ dup parse-result-remaining ] dip parse [ [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep dup [
parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if dup parse-result-remaining ?quot call [
] [ [ parse-result-remaining swap set-parse-result-remaining ] 2keep
drop f parse-result-ast dup ignore = [
] if* ; drop
] [
swap [ parse-result-ast push ] keep
] if
] [
drop f
] if*
] [
drop f
] if
] ;
: (seq-parser) ( result parsers -- result ) M: seq-parser compile ( parser -- quot )
dup empty? not pick and [ [
unclip swap [ do-seq-parser ] dip (seq-parser) [ V{ } clone <parse-result> ] %
] [ seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each
drop ] [ ] make ;
] if ;
M: seq-parser (parse) ( state parser -- result )
seq-parser-parsers [ V{ } clone <parse-result> ] dip (seq-parser) ;
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
: (choice-parser) ( state parsers -- result ) : choice-pattern ( -- quot )
dup empty? [ [
2drop f dup [
] [
unclip pick swap parse [
2nip
] [
(choice-parser)
] if*
] if ;
M: choice-parser (parse) ( state parser -- result ) ] [
choice-parser-parsers (choice-parser) ; 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 ; TUPLE: repeat0-parser p1 ;
: (repeat-parser) ( parser result -- result ) : (repeat0) ( quot result -- result )
2dup parse-result-remaining swap parse [ 2dup parse-result-remaining swap call [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep [ parse-result-remaining swap set-parse-result-remaining ] 2keep
parse-result-ast swap [ parse-result-ast push ] keep parse-result-ast swap [ parse-result-ast push ] keep
(repeat-parser) (repeat0)
] [ ] [
nip nip
] if* ; ] if* ; inline
: clone-result ( result -- result ) : repeat0-pattern ( -- quot )
{ parse-result-remaining parse-result-ast } [
get-slots 1vector <parse-result> ; ?quot swap (repeat0)
] ;
M: repeat0-parser (parse) ( state parser -- result ) M: repeat0-parser compile ( parser -- quot )
repeat0-parser-p1 2dup parse [ [
nipd clone-result (repeat-parser) [ V{ } clone <parse-result> ] %
] [ repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %
drop V{ } clone <parse-result> ] [ ] make ;
] if* ;
TUPLE: repeat1-parser p1 ; TUPLE: repeat1-parser p1 ;
M: repeat1-parser (parse) ( state parser -- result ) : repeat1-pattern ( -- quot )
repeat1-parser-p1 tuck parse dup [ clone-result (repeat-parser) ] [ nip ] if ; [
?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 ; TUPLE: optional-parser p1 ;
M: optional-parser (parse) ( state parser -- result ) : optional-pattern ( -- quot )
dupd optional-parser-p1 parse swap f <parse-result> or ; [
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 ; TUPLE: ensure-parser p1 ;
M: ensure-parser (parse) ( state parser -- result ) : ensure-pattern ( -- quot )
dupd ensure-parser-p1 parse [ [
ignore <parse-result> dup ?quot call [
] [ ignore <parse-result>
drop f ] [
] if ; drop f
] if
] ;
M: ensure-parser compile ( parser -- quot )
ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
TUPLE: ensure-not-parser p1 ; TUPLE: ensure-not-parser p1 ;
M: ensure-not-parser (parse) ( state parser -- result ) : ensure-not-pattern ( -- quot )
dupd ensure-not-parser-p1 parse [ [
drop f dup ?quot call [
] [ drop f
ignore <parse-result> ] [
] if ; 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 ; TUPLE: action-parser p1 quot ;
M: action-parser (parse) ( state parser -- result ) MATCH-VARS: ?action ;
tuck action-parser-p1 parse dup [
dup parse-result-ast rot action-parser-quot call : action-pattern ( -- quot )
swap [ set-parse-result-ast ] keep [
] [ ?quot call dup [
nip dup parse-result-ast ?action call
] if ; 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 ) : left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
@ -211,13 +279,17 @@ M: action-parser (parse) ( state parser -- result )
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
M: sp-parser (parse) ( state parser -- result ) M: sp-parser compile ( parser -- quot )
[ left-trim-slice ] dip sp-parser-p1 parse ; [
\ left-trim-slice , sp-parser-p1 compile %
] [ ] make ;
TUPLE: delay-parser quot ; TUPLE: delay-parser quot ;
M: delay-parser (parse) ( state parser -- result ) M: delay-parser compile ( parser -- quot )
delay-parser-quot call parse ; [
delay-parser-quot % \ compile , \ call ,
] [ ] make ;
PRIVATE> PRIVATE>