2008-03-29 00:37:52 -04:00
|
|
|
! Copyright (C) 2007, 2008 Chris Double.
|
2007-11-19 22:36:38 -05:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2019-09-25 23:26:12 -04:00
|
|
|
|
2014-12-12 17:19:39 -05:00
|
|
|
USING: accessors arrays assocs classes combinators
|
|
|
|
combinators.short-circuit compiler.units effects.parser fry
|
|
|
|
generalizations kernel locals make math math.order namespaces
|
2019-09-25 23:26:12 -04:00
|
|
|
quotations sequences sets splitting unicode vectors
|
|
|
|
vocabs.loader words ;
|
|
|
|
|
2007-11-19 22:36:38 -05:00
|
|
|
IN: peg
|
|
|
|
|
2007-11-20 21:31:23 -05:00
|
|
|
TUPLE: parse-result remaining ast ;
|
2014-10-21 10:27:33 -04:00
|
|
|
TUPLE: parse-error position got messages ;
|
2008-07-08 00:10:06 -04:00
|
|
|
TUPLE: parser peg compiled id ;
|
2008-03-30 00:48:01 -04:00
|
|
|
|
2013-07-24 17:52:09 -04:00
|
|
|
M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ;
|
2008-03-30 00:48:01 -04:00
|
|
|
M: parser hashcode* id>> hashcode* ;
|
|
|
|
|
2008-07-08 00:10:06 -04:00
|
|
|
C: <parse-result> parse-result
|
|
|
|
C: <parse-error> parse-error
|
2008-03-29 21:00:45 -04:00
|
|
|
|
2008-06-25 03:37:58 -04:00
|
|
|
SYMBOL: error-stack
|
|
|
|
|
2014-10-21 10:27:33 -04:00
|
|
|
: merge-overlapping-errors ( a b -- c )
|
|
|
|
dupd [ messages>> ] bi@ union [ [ position>> ] [ got>> ] bi ] dip
|
|
|
|
<parse-error> ;
|
|
|
|
|
2008-06-25 03:37:58 -04:00
|
|
|
: (merge-errors) ( a b -- c )
|
2013-07-24 17:52:09 -04:00
|
|
|
{
|
|
|
|
{ [ over position>> not ] [ nip ] }
|
|
|
|
{ [ dup position>> not ] [ drop ] }
|
|
|
|
[
|
|
|
|
2dup [ position>> ] compare {
|
|
|
|
{ +lt+ [ nip ] }
|
|
|
|
{ +gt+ [ drop ] }
|
2014-10-21 10:27:33 -04:00
|
|
|
{ +eq+ [ merge-overlapping-errors ] }
|
2013-07-24 17:52:09 -04:00
|
|
|
} case
|
|
|
|
]
|
|
|
|
} cond ;
|
2008-06-25 03:37:58 -04:00
|
|
|
|
|
|
|
: merge-errors ( -- )
|
2019-09-25 23:26:12 -04:00
|
|
|
error-stack get dup length 1 > [
|
2018-06-19 20:15:05 -04:00
|
|
|
[ pop ] [ pop swap (merge-errors) ] [ ] tri push
|
2013-07-24 17:52:09 -04:00
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] if ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2014-10-21 10:27:33 -04:00
|
|
|
: add-error ( position got message -- )
|
2013-07-24 17:52:09 -04:00
|
|
|
<parse-error> error-stack get push ;
|
|
|
|
|
|
|
|
SYMBOL: ignore
|
2007-11-19 22:36:38 -05:00
|
|
|
|
2019-09-26 11:56:42 -04:00
|
|
|
: ignore? ( obj -- ? )
|
|
|
|
ignore = ;
|
|
|
|
|
2008-07-08 20:07:17 -04:00
|
|
|
: packrat ( id -- cache )
|
2015-09-08 19:15:10 -04:00
|
|
|
! The packrat cache is a mapping of parser-id->cache.
|
|
|
|
! For each parser it maps to a cache holding a mapping
|
|
|
|
! of position->result. The packrat cache therefore keeps
|
|
|
|
! track of all parses that have occurred at each position
|
|
|
|
! of the input string and the results obtained from that
|
|
|
|
! parser.
|
2013-07-24 17:52:09 -04:00
|
|
|
\ packrat get [ drop H{ } clone ] cache ;
|
2008-07-08 20:07:17 -04:00
|
|
|
|
2008-03-28 06:20:43 -04:00
|
|
|
SYMBOL: pos
|
|
|
|
SYMBOL: input
|
|
|
|
SYMBOL: fail
|
2008-03-28 09:45:21 -04:00
|
|
|
SYMBOL: lrstack
|
2008-07-08 20:07:17 -04:00
|
|
|
|
|
|
|
: heads ( -- cache )
|
2015-09-08 19:15:10 -04:00
|
|
|
! A mapping from position->peg-head. It maps a
|
|
|
|
! position in the input string being parsed to
|
|
|
|
! the head of the left recursion which is currently
|
|
|
|
! being grown. It is 'f' at any position where
|
|
|
|
! left recursion growth is not underway.
|
2013-07-24 17:52:09 -04:00
|
|
|
\ heads get ;
|
2008-03-28 06:20:43 -04:00
|
|
|
|
2008-04-08 20:52:49 -04:00
|
|
|
: failed? ( obj -- ? )
|
2013-07-24 17:52:09 -04:00
|
|
|
fail = ;
|
2008-04-08 20:52:49 -04:00
|
|
|
|
2008-07-08 00:10:06 -04:00
|
|
|
: peg-cache ( -- cache )
|
2015-09-08 19:15:10 -04:00
|
|
|
! 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.
|
2013-07-24 17:52:09 -04:00
|
|
|
\ peg-cache get-global [
|
|
|
|
H{ } clone dup \ peg-cache set-global
|
|
|
|
] unless* ;
|
2008-04-01 19:59:12 -04:00
|
|
|
|
|
|
|
: reset-pegs ( -- )
|
2013-07-24 17:52:09 -04:00
|
|
|
H{ } clone \ peg-cache set-global ;
|
2008-04-01 19:59:12 -04:00
|
|
|
|
2014-10-21 10:27:33 -04:00
|
|
|
reset-pegs
|
2008-04-01 19:59:12 -04:00
|
|
|
|
2015-09-09 21:28:08 -04:00
|
|
|
! An entry in the table of memoized parse results
|
|
|
|
! ast = an AST produced from the parse
|
|
|
|
! or the symbol 'fail'
|
|
|
|
! or a left-recursion object
|
|
|
|
! pos = the position in the input string of this entry
|
2008-03-28 06:20:43 -04:00
|
|
|
TUPLE: memo-entry ans pos ;
|
2008-03-27 22:51:18 -04:00
|
|
|
|
2014-10-21 10:27:33 -04:00
|
|
|
TUPLE: left-recursion seed rule-id head next ;
|
2008-07-08 22:26:11 -04:00
|
|
|
TUPLE: peg-head rule-id involved-set eval-set ;
|
2008-03-28 09:45:21 -04:00
|
|
|
|
2014-10-21 10:27:33 -04:00
|
|
|
: rule-id ( word -- id )
|
2015-09-08 19:15:10 -04:00
|
|
|
! A rule is the parser compiled down to a word. It has
|
|
|
|
! a "peg-id" property containing the id of the original parser.
|
2013-07-24 17:52:09 -04:00
|
|
|
"peg-id" word-prop ;
|
2008-03-28 06:20:43 -04:00
|
|
|
|
|
|
|
: input-slice ( -- slice )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Return a slice of the input from the current parse position
|
2013-07-24 17:52:09 -04:00
|
|
|
input get pos get tail-slice ;
|
2008-03-27 22:51:18 -04:00
|
|
|
|
|
|
|
: input-from ( input -- n )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Return the index from the original string that the
|
|
|
|
! input slice is based on.
|
2013-07-24 17:52:09 -04:00
|
|
|
dup slice? [ from>> ] [ drop 0 ] if ;
|
2008-03-27 22:51:18 -04:00
|
|
|
|
2008-04-08 20:52:49 -04:00
|
|
|
: process-rule-result ( p result -- result )
|
2013-07-24 17:52:09 -04:00
|
|
|
[
|
2016-03-29 20:14:42 -04:00
|
|
|
nip [ ast>> ] [ remaining>> ] bi input-from pos namespaces:set
|
2013-07-24 17:52:09 -04:00
|
|
|
] [
|
2016-03-29 20:14:42 -04:00
|
|
|
pos namespaces:set fail
|
2014-10-21 10:27:33 -04:00
|
|
|
] if* ;
|
2008-04-08 20:52:49 -04:00
|
|
|
|
2008-03-28 06:20:43 -04:00
|
|
|
: eval-rule ( rule -- ast )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Evaluate a rule, return an ast resulting from it.
|
|
|
|
! Return fail if the rule failed. The rule has
|
|
|
|
! stack effect ( -- parse-result )
|
2013-07-24 17:52:09 -04:00
|
|
|
pos get swap execute( -- parse-result ) process-rule-result ; inline
|
2008-03-20 10:05:21 -04:00
|
|
|
|
2008-07-08 22:26:11 -04:00
|
|
|
: memo ( pos id -- memo-entry )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Return the result from the memo cache.
|
2013-07-24 17:52:09 -04:00
|
|
|
packrat at ;
|
2008-03-27 00:45:59 -04:00
|
|
|
|
2008-07-08 22:26:11 -04:00
|
|
|
: set-memo ( memo-entry pos id -- )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Store an entry in the cache
|
2013-07-24 17:52:09 -04:00
|
|
|
packrat set-at ;
|
2008-03-27 07:50:46 -04:00
|
|
|
|
2008-04-08 20:52:49 -04:00
|
|
|
: update-m ( ast m -- )
|
2013-07-24 17:52:09 -04:00
|
|
|
swap >>ans pos get >>pos drop ;
|
2008-04-08 20:52:49 -04:00
|
|
|
|
|
|
|
: stop-growth? ( ast m -- ? )
|
2019-09-25 23:26:12 -04:00
|
|
|
[ failed? pos get ] dip pos>> <= or ;
|
2008-04-08 20:52:49 -04:00
|
|
|
|
|
|
|
: setup-growth ( h p -- )
|
2016-03-29 20:14:42 -04:00
|
|
|
pos namespaces:set dup involved-set>> clone >>eval-set drop ;
|
2008-04-08 20:52:49 -04:00
|
|
|
|
2008-08-22 19:09:38 -04:00
|
|
|
: (grow-lr) ( h p r: ( -- result ) m -- )
|
2013-07-24 17:52:09 -04:00
|
|
|
[ [ setup-growth ] 2keep ] 2dip
|
|
|
|
[ dup eval-rule ] dip swap
|
|
|
|
dup pick stop-growth? [
|
2018-06-19 20:15:05 -04:00
|
|
|
5drop
|
2013-07-24 17:52:09 -04:00
|
|
|
] [
|
|
|
|
over update-m
|
|
|
|
(grow-lr)
|
|
|
|
] if ; inline recursive
|
|
|
|
|
2008-04-10 22:46:11 -04:00
|
|
|
: grow-lr ( h p r m -- ast )
|
2013-07-24 17:52:09 -04:00
|
|
|
[ [ heads set-at ] 2keep ] 2dip
|
|
|
|
pick over [ (grow-lr) ] 2dip
|
|
|
|
swap heads delete-at
|
2016-03-29 20:14:42 -04:00
|
|
|
dup pos>> pos namespaces:set ans>>
|
2013-07-24 17:52:09 -04:00
|
|
|
; inline
|
2008-03-28 08:17:54 -04:00
|
|
|
|
2009-04-01 00:55:15 -04:00
|
|
|
:: (setup-lr) ( l s -- )
|
2013-07-24 17:52:09 -04:00
|
|
|
s [
|
|
|
|
s left-recursion? [ s throw ] unless
|
|
|
|
s head>> l head>> eq? [
|
|
|
|
l head>> s head<<
|
|
|
|
l head>> [ s rule-id>> suffix ] change-involved-set drop
|
|
|
|
l s next>> (setup-lr)
|
|
|
|
] unless
|
|
|
|
] when ;
|
2008-03-28 09:45:21 -04:00
|
|
|
|
|
|
|
:: setup-lr ( r l -- )
|
2013-07-24 17:52:09 -04:00
|
|
|
l head>> [
|
|
|
|
r rule-id V{ } clone V{ } clone peg-head boa l head<<
|
|
|
|
] unless
|
|
|
|
l lrstack get (setup-lr) ;
|
2008-03-28 09:45:21 -04:00
|
|
|
|
|
|
|
:: lr-answer ( r p m -- ast )
|
2009-10-27 23:29:20 -04:00
|
|
|
m ans>> head>> :> h
|
2008-07-08 22:26:11 -04:00
|
|
|
h rule-id>> r rule-id eq? [
|
2013-07-24 17:52:09 -04:00
|
|
|
m ans>> seed>> m ans<<
|
|
|
|
m ans>> failed? [
|
|
|
|
fail
|
|
|
|
] [
|
|
|
|
h p r m grow-lr
|
|
|
|
] if
|
2008-03-28 09:45:21 -04:00
|
|
|
] [
|
2013-07-24 17:52:09 -04:00
|
|
|
m ans>> seed>>
|
2009-10-27 23:29:20 -04:00
|
|
|
] if ; inline
|
2008-03-28 09:45:21 -04:00
|
|
|
|
|
|
|
:: recall ( r p -- memo-entry )
|
2009-10-27 23:29:20 -04:00
|
|
|
p r rule-id memo :> m
|
|
|
|
p heads at :> h
|
2008-03-28 09:45:21 -04:00
|
|
|
h [
|
2013-07-24 17:52:09 -04:00
|
|
|
m r rule-id h involved-set>> h rule-id>> suffix member? not and [
|
|
|
|
fail p memo-entry boa
|
|
|
|
] [
|
|
|
|
r rule-id h eval-set>> member? [
|
|
|
|
h [ r rule-id swap remove ] change-eval-set drop
|
|
|
|
r eval-rule
|
|
|
|
m update-m
|
|
|
|
m
|
|
|
|
] [
|
|
|
|
m
|
|
|
|
] if
|
2008-03-28 09:45:21 -04:00
|
|
|
] if
|
|
|
|
] [
|
2013-07-24 17:52:09 -04:00
|
|
|
m
|
2009-10-27 23:29:20 -04:00
|
|
|
] if ; inline
|
2008-03-28 09:45:21 -04:00
|
|
|
|
2008-03-28 06:20:43 -04:00
|
|
|
:: apply-non-memo-rule ( r p -- ast )
|
2009-10-27 23:29:20 -04:00
|
|
|
fail r rule-id f lrstack get left-recursion boa :> lr
|
2016-03-29 20:14:42 -04:00
|
|
|
lr lrstack namespaces:set lr p memo-entry boa dup p r rule-id set-memo :> m
|
2009-10-27 23:29:20 -04:00
|
|
|
r eval-rule :> ans
|
2016-03-29 20:14:42 -04:00
|
|
|
lrstack get next>> lrstack namespaces:set
|
2010-05-05 16:52:54 -04:00
|
|
|
pos get m pos<<
|
2008-03-28 09:45:21 -04:00
|
|
|
lr head>> [
|
2013-07-24 17:52:09 -04:00
|
|
|
m ans>> left-recursion? [
|
|
|
|
ans lr seed<<
|
|
|
|
r p m lr-answer
|
|
|
|
] [ ans ] if
|
2008-03-28 08:17:54 -04:00
|
|
|
] [
|
2013-07-24 17:52:09 -04:00
|
|
|
ans m ans<<
|
|
|
|
ans
|
2009-10-27 23:29:20 -04:00
|
|
|
] if ; inline
|
2008-03-27 22:51:18 -04:00
|
|
|
|
2008-04-04 09:07:17 -04:00
|
|
|
: apply-memo-rule ( r m -- ast )
|
2016-03-29 20:14:42 -04:00
|
|
|
[ ans>> ] [ pos>> ] bi pos namespaces:set
|
2013-07-24 17:52:09 -04:00
|
|
|
dup left-recursion? [
|
|
|
|
[ setup-lr ] keep seed>>
|
|
|
|
] [
|
|
|
|
nip
|
|
|
|
] if ;
|
2008-03-27 22:51:18 -04:00
|
|
|
|
2008-04-04 08:56:37 -04:00
|
|
|
: apply-rule ( r p -- ast )
|
2013-07-24 17:52:09 -04:00
|
|
|
2dup recall [
|
|
|
|
nip apply-memo-rule
|
|
|
|
] [
|
|
|
|
apply-non-memo-rule
|
|
|
|
] if* ; inline
|
2008-03-27 22:51:18 -04:00
|
|
|
|
2008-03-28 06:20:43 -04:00
|
|
|
: with-packrat ( input quot -- result )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Run the quotation with a packrat cache active.
|
2012-07-19 18:11:33 -04:00
|
|
|
[
|
|
|
|
swap input ,,
|
|
|
|
0 pos ,,
|
|
|
|
f lrstack ,,
|
|
|
|
V{ } clone error-stack ,,
|
|
|
|
H{ } clone \ heads ,,
|
|
|
|
H{ } clone \ packrat ,,
|
|
|
|
] H{ } make swap with-variables ; inline
|
2008-03-27 22:51:18 -04:00
|
|
|
|
2008-07-08 00:10:06 -04:00
|
|
|
GENERIC: (compile) ( peg -- quot )
|
2008-03-27 00:45:59 -04:00
|
|
|
|
2008-07-08 00:56:12 -04:00
|
|
|
: process-parser-result ( result -- result )
|
2013-07-24 17:52:09 -04:00
|
|
|
dup failed? [
|
|
|
|
drop f
|
|
|
|
] [
|
|
|
|
input-slice swap <parse-result>
|
|
|
|
] if ;
|
|
|
|
|
2008-07-08 00:56:12 -04:00
|
|
|
: execute-parser ( word -- result )
|
2013-07-24 17:52:09 -04:00
|
|
|
pos get apply-rule process-parser-result ;
|
2008-03-30 06:24:02 -04:00
|
|
|
|
2019-09-27 11:24:53 -04:00
|
|
|
: preset-parser-word ( parser -- word parser )
|
|
|
|
gensym swap over >>compiled ;
|
2008-07-10 10:27:28 -04:00
|
|
|
|
2019-09-27 11:24:53 -04:00
|
|
|
: define-parser-word ( word parser -- )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Return the body of the word that is the compiled version
|
|
|
|
! of the parser.
|
2019-09-27 11:24:53 -04:00
|
|
|
[ peg>> (compile) ( -- result ) define-declared ]
|
|
|
|
[ id>> "peg-id" set-word-prop ] 2bi ;
|
2008-07-10 10:27:28 -04:00
|
|
|
|
|
|
|
: compile-parser ( parser -- word )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Look to see if the given parser has been compiled.
|
|
|
|
! If not, compile it to a temporary word, cache it,
|
|
|
|
! and return it. Otherwise return the existing one.
|
|
|
|
! Circular parsers are supported by getting the word
|
|
|
|
! name and storing it in the cache, before compiling,
|
|
|
|
! so it is picked up when re-entered.
|
2013-07-24 17:52:09 -04:00
|
|
|
dup compiled>> [
|
|
|
|
nip
|
|
|
|
] [
|
2019-09-27 11:24:53 -04:00
|
|
|
preset-parser-word dupd define-parser-word
|
2013-07-24 17:52:09 -04:00
|
|
|
] if* ;
|
2008-03-20 10:05:21 -04:00
|
|
|
|
2009-03-23 20:23:18 -04:00
|
|
|
: compile-parser-quot ( parser -- quot )
|
2019-09-26 11:56:42 -04:00
|
|
|
compile-parser '[ _ execute-parser ] ;
|
|
|
|
|
|
|
|
: compile-parsers-quots ( parsers -- quots )
|
|
|
|
[ compile-parser-quot ] map dup rest-slice
|
|
|
|
[ '[ @ merge-errors ] ] map! drop ;
|
2009-03-23 20:23:18 -04:00
|
|
|
|
2008-04-14 06:42:45 -04:00
|
|
|
SYMBOL: delayed
|
|
|
|
|
|
|
|
: fixup-delayed ( -- )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Work through all delayed parsers and recompile their
|
|
|
|
! words to have the correct bodies.
|
2013-07-24 17:52:09 -04:00
|
|
|
delayed get [
|
|
|
|
call( -- parser ) compile-parser-quot ( -- result ) define-declared
|
|
|
|
] assoc-each ;
|
2008-04-14 06:42:45 -04:00
|
|
|
|
2008-03-25 23:43:03 -04:00
|
|
|
: compile ( parser -- word )
|
2013-07-24 17:52:09 -04:00
|
|
|
[
|
|
|
|
H{ } clone delayed [
|
|
|
|
compile-parser-quot ( -- result ) define-temp fixup-delayed
|
|
|
|
] with-variable
|
|
|
|
] with-compilation-unit ;
|
2008-03-20 10:05:21 -04:00
|
|
|
|
2008-03-28 23:24:13 -04:00
|
|
|
: compiled-parse ( state word -- result )
|
2016-03-30 12:16:02 -04:00
|
|
|
swap [
|
|
|
|
execute( -- result )
|
|
|
|
[ error-stack get ?first [ throw ]
|
|
|
|
[ pos get input get f <parse-error> throw ] if* ] unless*
|
|
|
|
] with-packrat ;
|
2008-03-28 23:24:13 -04:00
|
|
|
|
2008-07-03 22:20:19 -04:00
|
|
|
: (parse) ( input parser -- result )
|
2013-07-24 17:52:09 -04:00
|
|
|
dup word? [ compile ] unless compiled-parse ;
|
2008-03-26 22:50:27 -04:00
|
|
|
|
2008-07-03 22:20:19 -04:00
|
|
|
: parse ( input parser -- ast )
|
2013-07-24 17:52:09 -04:00
|
|
|
(parse) ast>> ;
|
2008-07-03 22:20:19 -04:00
|
|
|
|
2007-11-28 18:35:45 -05:00
|
|
|
<PRIVATE
|
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: next-id ( -- n )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Return the next unique id for a parser
|
2015-09-02 16:12:14 -04:00
|
|
|
\ next-id counter ;
|
2008-03-27 19:00:36 -04:00
|
|
|
|
2008-07-08 00:10:06 -04:00
|
|
|
: wrap-peg ( peg -- parser )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Wrap a parser tuple around the peg object.
|
|
|
|
! Look for an existing parser tuple for that
|
|
|
|
! peg object.
|
2019-09-25 23:26:12 -04:00
|
|
|
peg-cache [ f next-id parser boa ] cache ;
|
2008-03-27 19:00:36 -04:00
|
|
|
|
2007-11-19 22:36:38 -05:00
|
|
|
TUPLE: token-parser symbol ;
|
|
|
|
|
2008-03-25 22:40:17 -04:00
|
|
|
: parse-token ( input string -- result )
|
2015-09-08 19:15:10 -04:00
|
|
|
! Parse the string, returning a parse result
|
2013-07-24 17:52:09 -04:00
|
|
|
[ ?head-slice ] keep swap [
|
2016-03-30 11:25:36 -04:00
|
|
|
<parse-result>
|
2013-07-24 17:52:09 -04:00
|
|
|
] [
|
2014-10-21 10:27:33 -04:00
|
|
|
[ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
|
2013-07-24 17:52:09 -04:00
|
|
|
] if ;
|
2008-03-25 22:40:17 -04:00
|
|
|
|
2020-09-09 17:41:17 -04:00
|
|
|
M: token-parser (compile)
|
2013-07-24 17:52:09 -04:00
|
|
|
symbol>> '[ input-slice _ parse-token ] ;
|
|
|
|
|
2007-12-20 19:16:14 -05:00
|
|
|
TUPLE: satisfy-parser quot ;
|
|
|
|
|
2019-09-25 23:26:12 -04:00
|
|
|
:: parse-satisfy ( input quot -- result/f )
|
|
|
|
input [ f ] [
|
|
|
|
unclip-slice dup quot call [
|
2013-07-24 17:52:09 -04:00
|
|
|
<parse-result>
|
|
|
|
] [
|
|
|
|
2drop f
|
|
|
|
] if
|
2016-03-30 13:29:43 -04:00
|
|
|
] if-empty ; inline
|
2008-04-05 00:15:43 -04:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: satisfy-parser (compile)
|
2013-07-24 17:52:09 -04:00
|
|
|
quot>> '[ input-slice _ parse-satisfy ] ;
|
2007-11-26 21:08:16 -05:00
|
|
|
|
2007-11-19 22:36:38 -05:00
|
|
|
TUPLE: range-parser min max ;
|
|
|
|
|
2019-09-25 23:26:12 -04:00
|
|
|
:: parse-range ( input min max -- result/f )
|
|
|
|
input [ f ] [
|
|
|
|
dup first min max between? [
|
2013-07-24 17:52:09 -04:00
|
|
|
unclip-slice <parse-result>
|
|
|
|
] [
|
|
|
|
drop f
|
|
|
|
] if
|
2019-09-25 23:26:12 -04:00
|
|
|
] if-empty ;
|
2007-12-20 19:16:14 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: range-parser (compile)
|
2013-07-24 17:52:09 -04:00
|
|
|
[ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ;
|
2007-11-19 22:36:38 -05:00
|
|
|
|
|
|
|
TUPLE: seq-parser parsers ;
|
|
|
|
|
2008-04-05 00:51:42 -04:00
|
|
|
: calc-seq-result ( prev-result current-result -- next-result )
|
2013-07-24 17:52:09 -04:00
|
|
|
[
|
2019-09-26 11:56:42 -04:00
|
|
|
[ remaining>> >>remaining ] [ ast>> ] bi
|
|
|
|
dup ignore? [ drop ] [ over ast>> push ] if
|
2007-12-20 19:16:14 -05:00
|
|
|
] [
|
2013-07-24 17:52:09 -04:00
|
|
|
drop f
|
|
|
|
] if* ;
|
2008-04-05 00:51:42 -04:00
|
|
|
|
|
|
|
: parse-seq-element ( result quot -- result )
|
2019-09-25 23:26:12 -04:00
|
|
|
'[ @ calc-seq-result ] [ f ] if* ; inline
|
2007-11-19 22:36:38 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: seq-parser (compile)
|
2019-09-26 11:56:42 -04:00
|
|
|
parsers>> compile-parsers-quots
|
|
|
|
[ '[ _ parse-seq-element ] ] map
|
|
|
|
'[ input-slice V{ } clone <parse-result> _ 1&& ] ;
|
2007-11-19 22:36:38 -05:00
|
|
|
|
2007-11-19 23:58:11 -05:00
|
|
|
TUPLE: choice-parser parsers ;
|
2007-12-20 19:16:14 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: choice-parser (compile)
|
2019-09-26 11:56:42 -04:00
|
|
|
parsers>> compile-parsers-quots '[ _ 0|| ] ;
|
2007-11-19 23:58:11 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
TUPLE: repeat0-parser parser ;
|
2007-11-20 21:01:44 -05:00
|
|
|
|
2008-08-23 00:00:35 -04:00
|
|
|
: (repeat) ( quot: ( -- result ) result -- result )
|
2013-07-24 17:52:09 -04:00
|
|
|
over call [
|
2019-09-26 11:56:42 -04:00
|
|
|
[ remaining>> >>remaining ] [ ast>> ] bi
|
|
|
|
over ast>> push (repeat)
|
2013-07-24 17:52:09 -04:00
|
|
|
] [
|
|
|
|
nip
|
|
|
|
] if* ; inline recursive
|
2007-11-20 21:01:44 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: repeat0-parser (compile)
|
|
|
|
parser>> compile-parser-quot '[
|
2014-10-21 10:27:33 -04:00
|
|
|
input-slice V{ } clone <parse-result> _ swap (repeat)
|
2013-07-24 17:52:09 -04:00
|
|
|
] ;
|
2007-11-20 21:01:44 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
TUPLE: repeat1-parser parser ;
|
2007-11-20 21:01:44 -05:00
|
|
|
|
2008-04-05 01:01:18 -04:00
|
|
|
: repeat1-empty-check ( result -- result )
|
2019-09-25 23:26:12 -04:00
|
|
|
[ dup ast>> empty? [ drop f ] when ] [ f ] if* ;
|
2007-12-20 19:16:14 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: repeat1-parser (compile)
|
|
|
|
parser>> compile-parser-quot '[
|
|
|
|
input-slice V{ } clone <parse-result> _ swap (repeat)
|
|
|
|
repeat1-empty-check
|
2013-07-24 17:52:09 -04:00
|
|
|
] ;
|
2007-11-20 21:01:44 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
TUPLE: optional-parser parser ;
|
2007-11-20 21:50:47 -05:00
|
|
|
|
2008-04-05 01:05:09 -04:00
|
|
|
: check-optional ( result -- result )
|
2019-09-25 23:26:12 -04:00
|
|
|
[ input-slice f <parse-result> ] unless* ;
|
2007-12-20 19:16:14 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: optional-parser (compile)
|
2019-09-25 23:26:12 -04:00
|
|
|
parser>> compile-parser-quot '[ @ check-optional ] ;
|
2007-11-20 21:50:47 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
TUPLE: semantic-parser parser quot ;
|
2008-03-30 23:34:59 -04:00
|
|
|
|
2008-04-05 01:19:11 -04:00
|
|
|
: check-semantic ( result quot -- result )
|
2019-09-25 23:26:12 -04:00
|
|
|
dupd '[ dup ast>> @ [ drop f ] unless ] when ; inline
|
2008-03-30 23:34:59 -04:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: semantic-parser (compile)
|
|
|
|
[ parser>> compile-parser-quot ] [ quot>> ] bi
|
2013-07-24 17:52:09 -04:00
|
|
|
'[ @ _ check-semantic ] ;
|
2008-03-30 23:34:59 -04:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
TUPLE: ensure-parser parser ;
|
2007-11-20 22:06:02 -05:00
|
|
|
|
2008-04-05 01:30:11 -04:00
|
|
|
: check-ensure ( old-input result -- result )
|
2013-07-24 17:52:09 -04:00
|
|
|
[ ignore <parse-result> ] [ drop f ] if ;
|
2007-12-20 19:16:14 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: ensure-parser (compile)
|
|
|
|
parser>> compile-parser-quot '[ input-slice @ check-ensure ] ;
|
2007-11-20 22:06:02 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
TUPLE: ensure-not-parser parser ;
|
2007-11-20 22:11:49 -05:00
|
|
|
|
2008-04-05 01:30:11 -04:00
|
|
|
: check-ensure-not ( old-input result -- result )
|
2013-07-24 17:52:09 -04:00
|
|
|
[ drop f ] [ ignore <parse-result> ] if ;
|
2007-12-20 19:16:14 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: ensure-not-parser (compile)
|
|
|
|
parser>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
|
2007-11-20 22:11:49 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
TUPLE: action-parser parser quot ;
|
2007-11-20 22:21:23 -05:00
|
|
|
|
2008-04-05 01:33:50 -04:00
|
|
|
: check-action ( result quot -- result )
|
2019-09-25 23:26:12 -04:00
|
|
|
dupd '[ [ _ call( ast -- ast ) ] change-ast ] when ;
|
2007-12-20 19:16:14 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: action-parser (compile)
|
2019-09-25 23:26:12 -04:00
|
|
|
[ parser>> compile-parser-quot ] [ quot>> ] bi
|
|
|
|
'[ @ _ check-action ] ;
|
2007-11-20 22:21:23 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
TUPLE: sp-parser parser ;
|
2007-11-26 21:36:26 -05:00
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: sp-parser (compile)
|
|
|
|
parser>> compile-parser-quot '[
|
2016-03-29 20:14:42 -04:00
|
|
|
input-slice [ blank? ] trim-head-slice input-from pos namespaces:set @
|
2013-07-24 17:52:09 -04:00
|
|
|
] ;
|
2007-11-26 21:36:26 -05:00
|
|
|
|
2007-11-26 22:16:21 -05:00
|
|
|
TUPLE: delay-parser quot ;
|
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: delay-parser (compile)
|
2015-09-08 19:15:10 -04:00
|
|
|
! For efficiency we memoize the quotation.
|
|
|
|
! This way it is run only once and the
|
|
|
|
! parser constructed once at run time.
|
2014-10-21 10:27:33 -04:00
|
|
|
quot>> gensym [ delayed get set-at ] keep 1quotation ;
|
2007-11-26 22:16:21 -05:00
|
|
|
|
2008-03-29 00:42:21 -04:00
|
|
|
TUPLE: box-parser quot ;
|
|
|
|
|
2015-09-02 16:12:14 -04:00
|
|
|
M: box-parser (compile)
|
2015-09-08 19:15:10 -04:00
|
|
|
! Calls the quotation at compile time
|
|
|
|
! to produce the parser to be compiled.
|
|
|
|
! This differs from 'delay' which calls
|
|
|
|
! it at run time.
|
2013-07-24 17:52:09 -04:00
|
|
|
quot>> call( -- parser ) compile-parser-quot ;
|
2008-03-29 00:42:21 -04:00
|
|
|
|
2007-11-26 18:22:33 -05:00
|
|
|
PRIVATE>
|
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: token ( string -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
token-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: satisfy ( quot -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
satisfy-parser boa wrap-peg ;
|
2007-11-26 21:08:16 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: range ( min max -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
range-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: seq ( seq -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
seq-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: 2seq ( parser1 parser2 -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
2array seq ;
|
2008-02-26 16:17:17 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: 3seq ( parser1 parser2 parser3 -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
3array seq ;
|
2008-02-26 16:17:17 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: 4seq ( parser1 parser2 parser3 parser4 -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
4array seq ;
|
2008-03-03 14:28:53 -05:00
|
|
|
|
2020-03-15 10:39:47 -04:00
|
|
|
: seq* ( quot -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
{ } make seq ; inline
|
2008-02-13 16:39:37 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: choice ( seq -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
choice-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: 2choice ( parser1 parser2 -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
2array choice ;
|
2008-02-26 18:13:15 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: 3choice ( parser1 parser2 parser3 -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
3array choice ;
|
2008-02-26 18:13:15 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: 4choice ( parser1 parser2 parser3 parser4 -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
4array choice ;
|
2008-03-03 14:28:53 -05:00
|
|
|
|
2020-03-15 10:39:47 -04:00
|
|
|
: choice* ( quot -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
{ } make choice ; inline
|
2008-02-13 16:39:37 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: repeat0 ( parser -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
repeat0-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: repeat1 ( parser -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
repeat1-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: optional ( parser -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
optional-parser boa wrap-peg ;
|
2008-03-30 23:34:59 -04:00
|
|
|
|
|
|
|
: semantic ( parser quot -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
semantic-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: ensure ( parser -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
ensure-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: ensure-not ( parser -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
ensure-not-parser boa wrap-peg ;
|
2007-11-26 18:22:33 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: action ( parser quot -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
action-parser boa wrap-peg ;
|
2007-11-26 21:36:26 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: sp ( parser -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
sp-parser boa wrap-peg ;
|
2007-11-26 21:45:00 -05:00
|
|
|
|
2008-03-20 08:25:45 -04:00
|
|
|
: hide ( parser -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
[ drop ignore ] action ;
|
2007-11-26 22:16:21 -05:00
|
|
|
|
2008-03-27 19:00:36 -04:00
|
|
|
: delay ( quot -- parser )
|
2013-07-24 17:52:09 -04:00
|
|
|
delay-parser boa wrap-peg ;
|
2008-03-03 17:57:30 -05:00
|
|
|
|
2008-03-29 00:42:21 -04:00
|
|
|
: box ( quot -- parser )
|
2015-09-08 19:15:10 -04:00
|
|
|
! because a box has its quotation run at compile time
|
|
|
|
! it must always have a new parser wrapper created,
|
|
|
|
! not a cached one. This is because the same box,
|
|
|
|
! compiled twice can have a different compiled word
|
|
|
|
! due to running at compile time.
|
|
|
|
! Why the [ ] action at the end? Box parsers don't get
|
|
|
|
! memoized during parsing due to all box parsers being
|
|
|
|
! unique. This breaks left recursion detection during the
|
|
|
|
! parse. The action adds an indirection with a parser type
|
|
|
|
! that gets memoized and fixes this. Need to rethink how
|
|
|
|
! to fix boxes so this isn't needed...
|
2013-07-24 17:52:09 -04:00
|
|
|
box-parser boa f next-id parser boa [ ] action ;
|
2008-03-29 00:42:21 -04:00
|
|
|
|
2008-06-18 01:35:19 -04:00
|
|
|
ERROR: parse-failed input word ;
|
|
|
|
|
2009-03-21 02:27:50 -04:00
|
|
|
SYNTAX: PEG:
|
2009-10-28 13:51:03 -04:00
|
|
|
[let
|
2009-10-28 17:11:33 -04:00
|
|
|
(:) :> ( word def effect )
|
2009-10-27 23:29:20 -04:00
|
|
|
[
|
2009-10-28 13:51:03 -04:00
|
|
|
[
|
2015-09-02 16:12:14 -04:00
|
|
|
def call compile :> compiled-def
|
2019-09-25 23:26:12 -04:00
|
|
|
word [
|
2015-09-02 16:12:14 -04:00
|
|
|
dup compiled-def compiled-parse
|
|
|
|
[ ast>> ] [ word parse-failed ] ?if
|
2019-09-25 23:26:12 -04:00
|
|
|
] effect define-declared
|
2015-09-02 16:12:14 -04:00
|
|
|
] with-compilation-unit
|
2009-10-28 17:17:24 -04:00
|
|
|
] append!
|
2009-10-28 13:51:03 -04:00
|
|
|
] ;
|
2008-12-08 21:04:13 -05:00
|
|
|
|
2010-04-18 15:29:24 -04:00
|
|
|
{ "debugger" "peg" } "peg.debugger" require-when
|