111 lines
2.8 KiB
Factor
111 lines
2.8 KiB
Factor
! Copyright (C) 2007 Chris Double.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: kernel sequences strings namespaces math assocs combinators.lib ;
|
|
IN: peg
|
|
|
|
TUPLE: parse-state input cache ;
|
|
|
|
: <parse-state> ( input index -- state )
|
|
tail-slice { set-parse-state-input } parse-state construct ;
|
|
|
|
: get-cached ( pid state -- result )
|
|
tuck parse-state-cache at [
|
|
swap parse-state-input slice-from swap nth
|
|
] [
|
|
drop f
|
|
] if* ;
|
|
|
|
: state-tail ( state n -- state )
|
|
dupd [ parse-state-cache ] dipd
|
|
[ parse-state-input ] dip tail-slice
|
|
{ set-parse-state-cache set-parse-state-input } parse-state construct ;
|
|
|
|
TUPLE: parse-result remaining matched ast ;
|
|
|
|
: <parse-result> ( remaining matched ast -- parse-result )
|
|
parse-result construct-boa ;
|
|
|
|
SYMBOL: next-id
|
|
|
|
: get-next-id ( -- number )
|
|
next-id get-global 0 or dup 1+ next-id set-global ;
|
|
|
|
TUPLE: parser id ;
|
|
|
|
: init-parser ( parser -- parser )
|
|
get-next-id parser construct-boa over set-delegate ;
|
|
|
|
GENERIC: parse ( state parser -- result )
|
|
|
|
TUPLE: token-parser symbol ;
|
|
|
|
M: token-parser parse ( state parser -- result )
|
|
token-parser-symbol 2dup >r parse-state-input r> head? [
|
|
dup >r length state-tail r> dup <parse-result>
|
|
] [
|
|
2drop f
|
|
] if ;
|
|
|
|
: token ( string -- parser )
|
|
token-parser construct-boa init-parser ;
|
|
|
|
TUPLE: range-parser min max ;
|
|
|
|
M: range-parser parse ( state parser -- result )
|
|
over parse-state-input empty? [
|
|
2drop f
|
|
] [
|
|
0 pick parse-state-input nth dup rot
|
|
{ range-parser-min range-parser-max } get-slots between? [
|
|
[ 1 state-tail ] dip dup <parse-result>
|
|
] [
|
|
2drop f
|
|
] if
|
|
] if ;
|
|
|
|
: range ( min max -- parser )
|
|
range-parser construct-boa init-parser ;
|
|
|
|
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 swap parse-result-ast push ] 2keep
|
|
parse-result-matched swap [ parse-result-matched swap append ] keep [ set-parse-result-matched ] keep
|
|
] [
|
|
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) ;
|
|
|
|
: seq ( seq -- parser )
|
|
seq-parser construct-boa init-parser ;
|
|
|
|
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 ( seq -- parser )
|
|
choice-parser construct-boa init-parser ;
|