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

Merge branch 'master' of git://double.co.nz/git/factor

db4
Slava Pestov 2008-03-21 14:07:51 -05:00
parent 4e2c5f2d59 943b02ab2f
commit f24eb0f362
4 changed files with 67 additions and 43 deletions

2
extra/peg/ebnf/ebnf-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf ;
USING: kernel tools.test peg peg.ebnf words ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [

2
extra/peg/ebnf/ebnf.factor
View File

@ -278,7 +278,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: ebnf>quot ( string -- hashtable quot )
'ebnf' parse check-parse-result
parse-result-ast transform dup main swap at compile ;
parse-result-ast transform dup main swap at compile 1quotation ;
: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing

4
extra/peg/parsers/parsers.factor
View File

@ -16,8 +16,8 @@ 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 ;

102
extra/peg/peg.factor
View File

@ -3,24 +3,43 @@
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
words ;
words quotations effects memoize ;
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 ;
SYMBOL: compiled-parsers
GENERIC: (compile) ( parser -- quot )
: compiled-parser ( parser -- word )
#! 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.
dup compiled-parsers get at [
nip
] [
dup (compile) define-temp
[ swap compiled-parsers get set-at ] keep
] if* ;
MEMO: compile ( parser -- word )
H{ } clone compiled-parsers [
[ compiled-parser ] with-compilation-unit
] with-variable ;
: parse ( state parser -- result )
compile execute ;
<PRIVATE
TUPLE: token-parser symbol ;
! M: token-parser equal? eq? ;
MATCH-VARS: ?token ;
@ -33,7 +52,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 +72,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 +93,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 +101,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 +116,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 +129,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 +153,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 +175,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 +225,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,17 +244,22 @@ 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 )
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
[
delay-parser-quot % \ compile , \ call ,
] [ ] make ;
delay-parser-quot % \ compile ,
] [ ] make
{ } { "word" } <effect> memoize-quot
[ % \ execute , ] [ ] make ;
PRIVATE>
@ -308,7 +332,7 @@ PRIVATE>
: PEG:
(:) [
[
call compile
call compile 1quotation
[ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
append define
] with-compilation-unit