Compile pegs down to words
Chris Double
parent
1c6882b32c
commit
a14854520d
|
|
@ -16,11 +16,11 @@ TUPLE: just-parser p1 ;
|
|||
] ;
|
||||
|
||||
|
||||
M: just-parser compile ( parser -- quot )
|
||||
just-parser-p1 compile just-pattern append ;
|
||||
M: just-parser (compile) ( parser -- quot )
|
||||
just-parser-p1 compiled-parser just-pattern curry ;
|
||||
|
||||
: just ( parser -- parser )
|
||||
just-parser construct-boa ;
|
||||
just-parser construct-boa init-parser ;
|
||||
|
||||
: 1token ( ch -- parser ) 1string token ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,16 +8,42 @@ IN: peg
|
|||
|
||||
TUPLE: parse-result remaining ast ;
|
||||
|
||||
GENERIC: compile ( parser -- quot )
|
||||
|
||||
: parse ( state parser -- result )
|
||||
compile call ;
|
||||
|
||||
SYMBOL: ignore
|
||||
|
||||
: <parse-result> ( remaining ast -- parse-result )
|
||||
parse-result construct-boa ;
|
||||
|
||||
TUPLE: parser ;
|
||||
C: <parser> parser
|
||||
M: parser equal? eq? ;
|
||||
|
||||
: init-parser ( parser -- parser )
|
||||
#! Set the delegate for the parser
|
||||
<parser> over set-delegate ;
|
||||
|
||||
SYMBOL: compiled-parsers
|
||||
|
||||
GENERIC: (compile) ( parser -- quot )
|
||||
|
||||
: compiled-parser ( parser -- word )
|
||||
#! Look to see if the given parser has been compied.
|
||||
#! If not, compile it to a temporary word, cache it,
|
||||
#! and return it. Otherwise return the existing one.
|
||||
dup compiled-parsers get at [
|
||||
nip
|
||||
] [
|
||||
dup (compile) define-temp
|
||||
[ swap compiled-parsers get set-at ] keep
|
||||
] if* ;
|
||||
|
||||
: compile ( parser -- word )
|
||||
H{ } clone compiled-parsers [
|
||||
[ compiled-parser ] with-compilation-unit
|
||||
] with-variable ;
|
||||
|
||||
: parse ( state parser -- result )
|
||||
compile call ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: token-parser symbol ;
|
||||
|
|
@ -33,7 +59,7 @@ MATCH-VARS: ?token ;
|
|||
] if
|
||||
] ;
|
||||
|
||||
M: token-parser compile ( parser -- quot )
|
||||
M: token-parser (compile) ( parser -- quot )
|
||||
token-parser-symbol \ ?token token-pattern match-replace ;
|
||||
|
||||
TUPLE: satisfy-parser quot ;
|
||||
|
|
@ -53,7 +79,7 @@ MATCH-VARS: ?quot ;
|
|||
] if
|
||||
] ;
|
||||
|
||||
M: satisfy-parser compile ( parser -- quot )
|
||||
M: satisfy-parser (compile) ( parser -- quot )
|
||||
satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
|
||||
|
||||
TUPLE: range-parser min max ;
|
||||
|
|
@ -74,7 +100,7 @@ MATCH-VARS: ?min ?max ;
|
|||
] if
|
||||
] ;
|
||||
|
||||
M: range-parser compile ( parser -- quot )
|
||||
M: range-parser (compile) ( parser -- quot )
|
||||
T{ range-parser _ ?min ?max } range-pattern match-replace ;
|
||||
|
||||
TUPLE: seq-parser parsers ;
|
||||
|
|
@ -82,7 +108,7 @@ TUPLE: seq-parser parsers ;
|
|||
: seq-pattern ( -- quot )
|
||||
[
|
||||
dup [
|
||||
dup parse-result-remaining ?quot call [
|
||||
dup parse-result-remaining ?quot [
|
||||
[ parse-result-remaining swap set-parse-result-remaining ] 2keep
|
||||
parse-result-ast dup ignore = [
|
||||
drop
|
||||
|
|
@ -97,10 +123,10 @@ TUPLE: seq-parser parsers ;
|
|||
] if
|
||||
] ;
|
||||
|
||||
M: seq-parser compile ( parser -- quot )
|
||||
M: seq-parser (compile) ( parser -- quot )
|
||||
[
|
||||
[ V{ } clone <parse-result> ] %
|
||||
seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each
|
||||
seq-parser-parsers [ compiled-parser \ ?quot seq-pattern match-replace % ] each
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: choice-parser parsers ;
|
||||
|
|
@ -110,14 +136,14 @@ TUPLE: choice-parser parsers ;
|
|||
dup [
|
||||
|
||||
] [
|
||||
drop dup ?quot call
|
||||
drop dup ?quot
|
||||
] if
|
||||
] ;
|
||||
|
||||
M: choice-parser compile ( parser -- quot )
|
||||
M: choice-parser (compile) ( parser -- quot )
|
||||
[
|
||||
f ,
|
||||
choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
|
||||
choice-parser-parsers [ compiled-parser \ ?quot choice-pattern match-replace % ] each
|
||||
\ nip ,
|
||||
] [ ] make ;
|
||||
|
||||
|
|
@ -134,20 +160,20 @@ TUPLE: repeat0-parser p1 ;
|
|||
|
||||
: repeat0-pattern ( -- quot )
|
||||
[
|
||||
?quot swap (repeat0)
|
||||
[ ?quot ] swap (repeat0)
|
||||
] ;
|
||||
|
||||
M: repeat0-parser compile ( parser -- quot )
|
||||
M: repeat0-parser (compile) ( parser -- quot )
|
||||
[
|
||||
[ V{ } clone <parse-result> ] %
|
||||
repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %
|
||||
repeat0-parser-p1 compiled-parser \ ?quot repeat0-pattern match-replace %
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: repeat1-parser p1 ;
|
||||
|
||||
: repeat1-pattern ( -- quot )
|
||||
[
|
||||
?quot swap (repeat0) [
|
||||
[ ?quot ] swap (repeat0) [
|
||||
dup parse-result-ast empty? [
|
||||
drop f
|
||||
] when
|
||||
|
|
@ -156,49 +182,49 @@ TUPLE: repeat1-parser p1 ;
|
|||
] if*
|
||||
] ;
|
||||
|
||||
M: repeat1-parser compile ( parser -- quot )
|
||||
M: repeat1-parser (compile) ( parser -- quot )
|
||||
[
|
||||
[ V{ } clone <parse-result> ] %
|
||||
repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace %
|
||||
repeat1-parser-p1 compiled-parser \ ?quot repeat1-pattern match-replace %
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: optional-parser p1 ;
|
||||
|
||||
: optional-pattern ( -- quot )
|
||||
[
|
||||
dup ?quot call swap f <parse-result> or
|
||||
dup ?quot swap f <parse-result> or
|
||||
] ;
|
||||
|
||||
M: optional-parser compile ( parser -- quot )
|
||||
optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
|
||||
M: optional-parser (compile) ( parser -- quot )
|
||||
optional-parser-p1 compiled-parser \ ?quot optional-pattern match-replace ;
|
||||
|
||||
TUPLE: ensure-parser p1 ;
|
||||
|
||||
: ensure-pattern ( -- quot )
|
||||
[
|
||||
dup ?quot call [
|
||||
dup ?quot [
|
||||
ignore <parse-result>
|
||||
] [
|
||||
drop f
|
||||
] if
|
||||
] ;
|
||||
|
||||
M: ensure-parser compile ( parser -- quot )
|
||||
ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
|
||||
M: ensure-parser (compile) ( parser -- quot )
|
||||
ensure-parser-p1 compiled-parser \ ?quot ensure-pattern match-replace ;
|
||||
|
||||
TUPLE: ensure-not-parser p1 ;
|
||||
|
||||
: ensure-not-pattern ( -- quot )
|
||||
[
|
||||
dup ?quot call [
|
||||
dup ?quot [
|
||||
drop f
|
||||
] [
|
||||
ignore <parse-result>
|
||||
] if
|
||||
] ;
|
||||
|
||||
M: ensure-not-parser compile ( parser -- quot )
|
||||
ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
|
||||
M: ensure-not-parser (compile) ( parser -- quot )
|
||||
ensure-not-parser-p1 compiled-parser \ ?quot ensure-not-pattern match-replace ;
|
||||
|
||||
TUPLE: action-parser p1 quot ;
|
||||
|
||||
|
|
@ -206,14 +232,14 @@ MATCH-VARS: ?action ;
|
|||
|
||||
: action-pattern ( -- quot )
|
||||
[
|
||||
?quot call dup [
|
||||
?quot 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
|
||||
M: action-parser (compile) ( parser -- quot )
|
||||
{ action-parser-p1 action-parser-quot } get-slots [ compiled-parser ] dip
|
||||
2array { ?quot ?action } action-pattern match-replace ;
|
||||
|
||||
: left-trim-slice ( string -- string )
|
||||
|
|
@ -225,31 +251,31 @@ M: action-parser compile ( parser -- quot )
|
|||
|
||||
TUPLE: sp-parser p1 ;
|
||||
|
||||
M: sp-parser compile ( parser -- quot )
|
||||
M: sp-parser (compile) ( parser -- quot )
|
||||
[
|
||||
\ left-trim-slice , sp-parser-p1 compile %
|
||||
\ left-trim-slice , sp-parser-p1 compiled-parser ,
|
||||
] [ ] make ;
|
||||
|
||||
TUPLE: delay-parser quot ;
|
||||
|
||||
M: delay-parser compile ( parser -- quot )
|
||||
M: delay-parser (compile) ( parser -- quot )
|
||||
[
|
||||
delay-parser-quot % \ compile , \ call ,
|
||||
delay-parser-quot % \ (compile) , \ call ,
|
||||
] [ ] make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: token ( string -- parser )
|
||||
token-parser construct-boa ;
|
||||
token-parser construct-boa init-parser ;
|
||||
|
||||
: satisfy ( quot -- parser )
|
||||
satisfy-parser construct-boa ;
|
||||
satisfy-parser construct-boa init-parser ;
|
||||
|
||||
: range ( min max -- parser )
|
||||
range-parser construct-boa ;
|
||||
range-parser construct-boa init-parser ;
|
||||
|
||||
: seq ( seq -- parser )
|
||||
seq-parser construct-boa ;
|
||||
seq-parser construct-boa init-parser ;
|
||||
|
||||
: 2seq ( parser1 parser2 -- parser )
|
||||
2array seq ;
|
||||
|
|
@ -264,7 +290,7 @@ PRIVATE>
|
|||
{ } make seq ; inline
|
||||
|
||||
: choice ( seq -- parser )
|
||||
choice-parser construct-boa ;
|
||||
choice-parser construct-boa init-parser ;
|
||||
|
||||
: 2choice ( parser1 parser2 -- parser )
|
||||
2array choice ;
|
||||
|
|
@ -279,31 +305,31 @@ PRIVATE>
|
|||
{ } make choice ; inline
|
||||
|
||||
: repeat0 ( parser -- parser )
|
||||
repeat0-parser construct-boa ;
|
||||
repeat0-parser construct-boa init-parser ;
|
||||
|
||||
: repeat1 ( parser -- parser )
|
||||
repeat1-parser construct-boa ;
|
||||
repeat1-parser construct-boa init-parser ;
|
||||
|
||||
: optional ( parser -- parser )
|
||||
optional-parser construct-boa ;
|
||||
optional-parser construct-boa init-parser ;
|
||||
|
||||
: ensure ( parser -- parser )
|
||||
ensure-parser construct-boa ;
|
||||
ensure-parser construct-boa init-parser ;
|
||||
|
||||
: ensure-not ( parser -- parser )
|
||||
ensure-not-parser construct-boa ;
|
||||
ensure-not-parser construct-boa init-parser ;
|
||||
|
||||
: action ( parser quot -- parser )
|
||||
action-parser construct-boa ;
|
||||
action-parser construct-boa init-parser ;
|
||||
|
||||
: sp ( parser -- parser )
|
||||
sp-parser construct-boa ;
|
||||
sp-parser construct-boa init-parser ;
|
||||
|
||||
: hide ( parser -- parser )
|
||||
[ drop ignore ] action ;
|
||||
|
||||
: delay ( quot -- parser )
|
||||
delay-parser construct-boa ;
|
||||
delay-parser construct-boa init-parser ;
|
||||
|
||||
: PEG:
|
||||
(:) [
|
||||
|
|
|
|||
Loading…
Reference in New Issue