! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
+
USING: accessors arrays assocs classes combinators
combinators.short-circuit compiler.units effects.parser fry
-generalizations kernel locals make math math.order namespaces
-quotations sequences sets splitting unicode vectors words ;
+kernel make math math.order namespaces quotations sequences
+sets splitting unicode vectors vocabs.loader words ;
+
IN: peg
TUPLE: parse-result remaining ast ;
} cond ;
: merge-errors ( -- )
- error-stack get dup length 1 > [
+ error-stack get dup length 1 > [
[ pop ] [ pop swap (merge-errors) ] [ ] tri push
] [
drop
SYMBOL: ignore
+: ignore? ( obj -- ? )
+ ignore = ;
+
: packrat ( id -- cache )
! The packrat cache is a mapping of parser-id->cache.
! For each parser it maps to a cache holding a mapping
swap >>ans pos get >>pos drop ;
: stop-growth? ( ast m -- ? )
- [ failed? pos get ] dip
- pos>> <= or ;
+ [ failed? pos get ] dip pos>> <= or ;
: setup-growth ( h p -- )
pos namespaces:set dup involved-set>> clone >>eval-set drop ;
: execute-parser ( word -- result )
pos get apply-rule process-parser-result ;
-: preset-parser-word ( parser -- parser word )
- gensym [ >>compiled ] keep ;
+: preset-parser-word ( parser -- word parser )
+ gensym tuck >>compiled ;
-: define-parser-word ( parser word -- )
+: define-parser-word ( word parser -- )
! Return the body of the word that is the compiled version
! of the parser.
- 2dup swap peg>> (compile) ( -- result ) define-declared
- swap id>> "peg-id" set-word-prop ;
+ [ peg>> (compile) ( -- result ) define-declared ]
+ [ id>> "peg-id" set-word-prop ] 2bi ;
: compile-parser ( parser -- word )
! Look to see if the given parser has been compiled.
dup compiled>> [
nip
] [
- preset-parser-word [ define-parser-word ] keep
+ preset-parser-word dupd define-parser-word
] if* ;
: compile-parser-quot ( parser -- quot )
- compile-parser [ execute-parser ] curry ;
+ compile-parser '[ _ execute-parser ] ;
+
+: compile-parsers-quots ( parsers -- quots )
+ [ compile-parser-quot ] map dup rest-slice
+ [ '[ @ merge-errors ] ] map! drop ;
SYMBOL: delayed
: compile ( parser -- word )
[
H{ } clone delayed [
- compile-parser-quot ( -- result ) define-temp fixup-delayed
+ compile-parser fixup-delayed
] with-variable
] with-compilation-unit ;
: compiled-parse ( state word -- result )
swap [
- execute( -- result )
+ execute-parser
[ error-stack get ?first [ throw ]
[ pos get input get f <parse-error> throw ] if* ] unless*
] with-packrat ;
: (parse) ( input parser -- result )
- dup word? [ compile ] unless compiled-parse ;
+ compile compiled-parse ;
: parse ( input parser -- ast )
(parse) ast>> ;
! Wrap a parser tuple around the peg object.
! Look for an existing parser tuple for that
! peg object.
- peg-cache [
- f next-id parser boa
- ] cache ;
+ peg-cache [ f next-id parser boa ] cache ;
TUPLE: token-parser symbol ;
[ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
] if ;
-M: token-parser (compile) ( peg -- quot )
+M: token-parser (compile)
symbol>> '[ input-slice _ parse-token ] ;
TUPLE: satisfy-parser quot ;
-: parse-satisfy ( input quot -- result )
- swap [
- drop f
- ] [
- unclip-slice dup roll call [
+:: parse-satisfy ( input quot -- result/f )
+ input [ f ] [
+ unclip-slice dup quot call [
<parse-result>
] [
2drop f
TUPLE: range-parser min max ;
-: parse-range ( input min max -- result )
- pick empty? [
- 3drop f
- ] [
- [ dup first ] 2dip between? [
+:: parse-range ( input min max -- result/f )
+ input [ f ] [
+ dup first min max between? [
unclip-slice <parse-result>
] [
drop f
] if
- ] if ;
+ ] if-empty ;
M: range-parser (compile)
[ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
TUPLE: seq-parser parsers ;
-: ignore? ( ast -- bool )
- ignore = ;
-
: calc-seq-result ( prev-result current-result -- next-result )
[
- [ remaining>> swap remaining<< ] 2keep
- ast>> dup ignore? [
- drop
- ] [
- swap [ ast>> push ] keep
- ] if
+ [ remaining>> >>remaining ] [ ast>> ] bi
+ dup ignore? [ drop ] [ over ast>> push ] if
] [
drop f
] if* ;
: parse-seq-element ( result quot -- result )
- over [
- call calc-seq-result
- ] [
- 2drop f
- ] if ; inline
+ '[ @ calc-seq-result ] [ f ] if* ; inline
M: seq-parser (compile)
- [
- [ input-slice V{ } clone <parse-result> ] %
- [
- parsers>> unclip compile-parser-quot [ parse-seq-element ] curry ,
- [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each
- ] { } make , \ 1&& ,
- ] [ ] make ;
+ parsers>> compile-parsers-quots
+ [ '[ _ parse-seq-element ] ] map
+ '[ input-slice V{ } clone <parse-result> _ 1&& ] ;
TUPLE: choice-parser parsers ;
M: choice-parser (compile)
- [
- [
- parsers>> [ compile-parser-quot ] map
- unclip , [ [ merge-errors ] compose , ] each
- ] { } make , \ 0|| ,
- ] [ ] make ;
+ parsers>> compile-parsers-quots '[ _ 0|| ] ;
TUPLE: repeat0-parser parser ;
-: (repeat) ( quot: ( -- result ) result -- result )
+: (repeat) ( quot: ( -- result/f ) result -- result )
over call [
- [ remaining>> swap remaining<< ] 2keep
- ast>> swap [ ast>> push ] keep
- (repeat)
+ [ remaining>> >>remaining ] [ ast>> ] bi
+ over ast>> push (repeat)
] [
nip
] if* ; inline recursive
TUPLE: repeat1-parser parser ;
: repeat1-empty-check ( result -- result )
- [
- dup ast>> empty? [ drop f ] when
- ] [
- f
- ] if* ;
+ [ dup ast>> empty? [ drop f ] when ] [ f ] if* ;
M: repeat1-parser (compile)
parser>> compile-parser-quot '[
TUPLE: optional-parser parser ;
: check-optional ( result -- result )
-
[ input-slice f <parse-result> ] unless* ;
+ [ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile)
- parser>> compile-parser-quot '[ @ check-optional ] ;
+ parser>> compile-parser-quot '[ @ check-optional ] ;
TUPLE: semantic-parser parser quot ;
: check-semantic ( result quot -- result )
- over [
- over ast>> swap call [ drop f ] unless
- ] [
- drop
- ] if ; inline
+ dupd '[ dup ast>> @ [ drop f ] unless ] when ; inline
M: semantic-parser (compile)
[ parser>> compile-parser-quot ] [ quot>> ] bi
TUPLE: action-parser parser quot ;
: check-action ( result quot -- result )
- over [
- over ast>> swap call( ast -- ast ) >>ast
- ] [
- drop
- ] if ;
+ dupd '[ [ _ call( ast -- ast ) ] change-ast ] when ;
M: action-parser (compile)
- [ parser>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
+ [ parser>> compile-parser-quot ] [ quot>> ] bi
+ '[ @ _ check-action ] ;
TUPLE: sp-parser parser ;
: 4seq ( parser1 parser2 parser3 parser4 -- parser )
4array seq ;
-: seq* ( quot -- paser )
+: seq* ( quot -- parser )
{ } make seq ; inline
: choice ( seq -- parser )
: 4choice ( parser1 parser2 parser3 parser4 -- parser )
4array choice ;
-: choice* ( quot -- paser )
+: choice* ( quot -- parser )
{ } make choice ; inline
: repeat0 ( parser -- parser )
[
[
def call compile :> compiled-def
- [
+ word [
dup compiled-def compiled-parse
[ ast>> ] [ word parse-failed ] ?if
- ]
- word swap effect define-declared
+ ] effect define-declared
] with-compilation-unit
] append!
] ;
-USE: vocabs.loader
-
{ "debugger" "peg" } "peg.debugger" require-when
projects / factor.git / blobdiff