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

Remove delegate usage from pegs

db4
Chris Double 2008-07-08 16:10:06 +12:00
parent 7f4fe76698
commit d92c19f694
1 changed files with 54 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
extra/peg/peg.factor
View File

@ -10,14 +10,13 @@ USE: prettyprint
TUPLE: parse-result remaining ast ; TUPLE: parse-result remaining ast ;
TUPLE: parse-error position messages ; TUPLE: parse-error position messages ;
TUPLE: parser id compiled ; TUPLE: parser peg compiled id ;
M: parser equal? [ id>> ] bi@ = ;
M: parser equal? [ id>> ] bi@ = ;
M: parser hashcode* id>> hashcode* ; M: parser hashcode* id>> hashcode* ;
C: <parse-result> parse-result C: <parse-result> parse-result
C: <parse-error> parse-error C: <parse-error> parse-error
C: <parser> parser
M: parse-error error. M: parse-error error.
"Peg parsing error at character position " write dup position>> number>string write "Peg parsing error at character position " write dup position>> number>string write
@ -59,11 +58,16 @@ SYMBOL: heads
: failed? ( obj -- ? ) : failed? ( obj -- ? )
fail = ; fail = ;
: delegates ( -- cache ) : peg-cache ( -- cache )
\ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; #! Holds a hashtable mapping a peg tuple to
#! the parser tuple for that peg. The parser tuple
#! holds a unique id and the compiled form of that peg.
\ peg-cache get-global [
H{ } clone dup \ peg-cache set-global
] unless* ;
: reset-pegs ( -- ) : reset-pegs ( -- )
H{ } clone \ delegates set-global ; H{ } clone \ peg-cache set-global ;
reset-pegs reset-pegs
@ -239,7 +243,7 @@ C: <head> peg-head
] H{ } make-assoc swap bind ; inline ] H{ } make-assoc swap bind ; inline
GENERIC: (compile) ( parser -- quot ) GENERIC: (compile) ( peg -- quot )
: execute-parser ( word -- result ) : execute-parser ( word -- result )
pos get apply-rule dup failed? [ pos get apply-rule dup failed? [
@ -251,7 +255,7 @@ GENERIC: (compile) ( parser -- quot )
: parser-body ( parser -- quot ) : parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version #! Return the body of the word that is the compiled version
#! of the parser. #! of the parser.
gensym 2dup swap (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop
[ execute-parser ] curry ; [ execute-parser ] curry ;
: compiled-parser ( parser -- word ) : compiled-parser ( parser -- word )
@ -304,12 +308,13 @@ SYMBOL: id
1 id set-global 0 1 id set-global 0
] if* ; ] if* ;
: init-parser ( parser -- parser ) : wrap-peg ( peg -- parser )
#! Set the delegate for the parser. Equivalent parsers #! Wrap a parser tuple around the peg object.
#! get a delegate with the same id. #! Look for an existing parser tuple for that
dup clone delegates [ #! peg object.
drop next-id f <parser> peg-cache [
] cache over set-delegate ; f next-id parser boa
] cache ;
TUPLE: token-parser symbol ; TUPLE: token-parser symbol ;
@ -321,7 +326,7 @@ TUPLE: token-parser symbol ;
drop input-slice input-from "token '" r> append "'" append 1vector add-error f drop input-slice input-from "token '" r> append "'" append 1vector add-error f
] if ; ] if ;
M: token-parser (compile) ( parser -- quot ) M: token-parser (compile) ( peg -- quot )
symbol>> '[ input-slice , parse-token ] ; symbol>> '[ input-slice , parse-token ] ;
TUPLE: satisfy-parser quot ; TUPLE: satisfy-parser quot ;
@ -338,7 +343,7 @@ TUPLE: satisfy-parser quot ;
] if ; inline ] if ; inline
M: satisfy-parser (compile) ( parser -- quot ) M: satisfy-parser (compile) ( peg -- quot )
quot>> '[ input-slice , parse-satisfy ] ; quot>> '[ input-slice , parse-satisfy ] ;
TUPLE: range-parser min max ; TUPLE: range-parser min max ;
@ -354,7 +359,7 @@ TUPLE: range-parser min max ;
] if ] if
] if ; ] if ;
M: range-parser (compile) ( parser -- quot ) M: range-parser (compile) ( peg -- quot )
[ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ; [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
TUPLE: seq-parser parsers ; TUPLE: seq-parser parsers ;
@ -381,7 +386,7 @@ TUPLE: seq-parser parsers ;
2drop f 2drop f
] if ; inline ] if ; inline
M: seq-parser (compile) ( parser -- quot ) M: seq-parser (compile) ( peg -- quot )
[ [
[ input-slice V{ } clone <parse-result> ] % [ input-slice V{ } clone <parse-result> ] %
parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [ parsers>> unclip compiled-parser 1quotation , \ parse-seq-element , [
@ -390,7 +395,7 @@ M: seq-parser (compile) ( parser -- quot )
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
M: choice-parser (compile) ( parser -- quot ) M: choice-parser (compile) ( peg -- quot )
[ [
f , f ,
parsers>> [ compiled-parser ] map parsers>> [ compiled-parser ] map
@ -408,7 +413,7 @@ TUPLE: repeat0-parser p1 ;
nip nip
] if* ; inline ] if* ; inline
M: repeat0-parser (compile) ( parser -- quot ) M: repeat0-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compiled-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat) input-slice V{ } clone <parse-result> , swap (repeat)
] ; ] ;
@ -422,7 +427,7 @@ TUPLE: repeat1-parser p1 ;
f f
] if* ; ] if* ;
M: repeat1-parser (compile) ( parser -- quot ) M: repeat1-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compiled-parser 1quotation '[
input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
] ; ] ;
@ -432,7 +437,7 @@ TUPLE: optional-parser p1 ;
: check-optional ( result -- result ) : check-optional ( result -- result )
[ input-slice f <parse-result> ] unless* ; [ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( parser -- quot ) M: optional-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ @ check-optional ] ; p1>> compiled-parser 1quotation '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ; TUPLE: semantic-parser p1 quot ;
@ -444,7 +449,7 @@ TUPLE: semantic-parser p1 quot ;
drop drop
] if ; inline ] if ; inline
M: semantic-parser (compile) ( parser -- quot ) M: semantic-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi [ p1>> compiled-parser 1quotation ] [ quot>> ] bi
'[ @ , check-semantic ] ; '[ @ , check-semantic ] ;
@ -453,7 +458,7 @@ TUPLE: ensure-parser p1 ;
: check-ensure ( old-input result -- result ) : check-ensure ( old-input result -- result )
[ ignore <parse-result> ] [ drop f ] if ; [ ignore <parse-result> ] [ drop f ] if ;
M: ensure-parser (compile) ( parser -- quot ) M: ensure-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ; p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ; TUPLE: ensure-not-parser p1 ;
@ -461,7 +466,7 @@ TUPLE: ensure-not-parser p1 ;
: check-ensure-not ( old-input result -- result ) : check-ensure-not ( old-input result -- result )
[ drop f ] [ ignore <parse-result> ] if ; [ drop f ] [ ignore <parse-result> ] if ;
M: ensure-not-parser (compile) ( parser -- quot ) M: ensure-not-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ; p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ; TUPLE: action-parser p1 quot ;
@ -473,7 +478,7 @@ TUPLE: action-parser p1 quot ;
drop drop
] if ; inline ] if ; inline
M: action-parser (compile) ( parser -- quot ) M: action-parser (compile) ( peg -- quot )
[ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ; [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string ) : left-trim-slice ( string -- string )
@ -485,14 +490,14 @@ M: action-parser (compile) ( parser -- quot )
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( parser -- quot ) M: sp-parser (compile) ( peg -- quot )
p1>> compiled-parser 1quotation '[ p1>> compiled-parser 1quotation '[
input-slice left-trim-slice input-from pos set @ input-slice left-trim-slice input-from pos set @
] ; ] ;
TUPLE: delay-parser quot ; TUPLE: delay-parser quot ;
M: delay-parser (compile) ( parser -- quot ) M: delay-parser (compile) ( peg -- quot )
#! For efficiency we memoize the quotation. #! For efficiency we memoize the quotation.
#! This way it is run only once and the #! This way it is run only once and the
#! parser constructed once at run time. #! parser constructed once at run time.
@ -500,29 +505,26 @@ M: delay-parser (compile) ( parser -- quot )
TUPLE: box-parser quot ; TUPLE: box-parser quot ;
M: box-parser (compile) ( parser -- quot ) M: box-parser (compile) ( peg -- quot )
#! Calls the quotation at compile time #! Calls the quotation at compile time
#! to produce the parser to be compiled. #! to produce the parser to be compiled.
#! This differs from 'delay' which calls #! This differs from 'delay' which calls
#! it at run time. Due to using the runtime #! it at run time.
#! environment at compile time, this parser quot>> call compiled-parser 1quotation ;
#! must not be cached, so we clear out the
#! delgates cache.
f >>compiled quot>> call compiled-parser 1quotation ;
PRIVATE> PRIVATE>
: token ( string -- parser ) : token ( string -- parser )
token-parser boa init-parser ; token-parser boa wrap-peg ;
: satisfy ( quot -- parser ) : satisfy ( quot -- parser )
satisfy-parser boa init-parser ; satisfy-parser boa wrap-peg ;
: range ( min max -- parser ) : range ( min max -- parser )
range-parser boa init-parser ; range-parser boa wrap-peg ;
: seq ( seq -- parser ) : seq ( seq -- parser )
seq-parser boa init-parser ; seq-parser boa wrap-peg ;
: 2seq ( parser1 parser2 -- parser ) : 2seq ( parser1 parser2 -- parser )
2array seq ; 2array seq ;
@ -537,7 +539,7 @@ PRIVATE>
{ } make seq ; inline { } make seq ; inline
: choice ( seq -- parser ) : choice ( seq -- parser )
choice-parser boa init-parser ; choice-parser boa wrap-peg ;
: 2choice ( parser1 parser2 -- parser ) : 2choice ( parser1 parser2 -- parser )
2array choice ; 2array choice ;
@ -552,38 +554,38 @@ PRIVATE>
{ } make choice ; inline { } make choice ; inline
: repeat0 ( parser -- parser ) : repeat0 ( parser -- parser )
repeat0-parser boa init-parser ; repeat0-parser boa wrap-peg ;
: repeat1 ( parser -- parser ) : repeat1 ( parser -- parser )
repeat1-parser boa init-parser ; repeat1-parser boa wrap-peg ;
: optional ( parser -- parser ) : optional ( parser -- parser )
optional-parser boa init-parser ; optional-parser boa wrap-peg ;
: semantic ( parser quot -- parser ) : semantic ( parser quot -- parser )
semantic-parser boa init-parser ; semantic-parser boa wrap-peg ;
: ensure ( parser -- parser ) : ensure ( parser -- parser )
ensure-parser boa init-parser ; ensure-parser boa wrap-peg ;
: ensure-not ( parser -- parser ) : ensure-not ( parser -- parser )
ensure-not-parser boa init-parser ; ensure-not-parser boa wrap-peg ;
: action ( parser quot -- parser ) : action ( parser quot -- parser )
action-parser boa init-parser ; action-parser boa wrap-peg ;
: sp ( parser -- parser ) : sp ( parser -- parser )
sp-parser boa init-parser ; sp-parser boa wrap-peg ;
: hide ( parser -- parser ) : hide ( parser -- parser )
[ drop ignore ] action ; [ drop ignore ] action ;
: delay ( quot -- parser ) : delay ( quot -- parser )
delay-parser boa init-parser ; delay-parser boa wrap-peg ;
: box ( quot -- parser ) : box ( quot -- parser )
#! because a box has its quotation run at compile time #! because a box has its quotation run at compile time
#! it must always have a new parser delgate created, #! it must always have a new parser wrapper created,
#! not a cached one. This is because the same box, #! not a cached one. This is because the same box,
#! compiled twice can have a different compiled word #! compiled twice can have a different compiled word
#! due to running at compile time. #! due to running at compile time.
@ -593,7 +595,7 @@ PRIVATE>
#! parse. The action adds an indirection with a parser type #! parse. The action adds an indirection with a parser type
#! that gets memoized and fixes this. Need to rethink how #! that gets memoized and fixes this. Need to rethink how
#! to fix boxes so this isn't needed... #! to fix boxes so this isn't needed...
box-parser boa next-id f <parser> over set-delegate [ ] action ; box-parser boa f next-id parser boa [ ] action ;
ERROR: parse-failed input word ; ERROR: parse-failed input word ;