diff --git a/extra/peg/parsers/parsers.factor b/extra/peg/parsers/parsers.factor index 3ccb1e7d10..407729004f 100755 --- a/extra/peg/parsers/parsers.factor +++ b/extra/peg/parsers/parsers.factor @@ -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 ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index b3200ec5eb..9d6b18398e 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -8,16 +8,42 @@ IN: peg TUPLE: parse-result remaining ast ; -GENERIC: compile ( parser -- quot ) - -: parse ( state parser -- result ) - compile call ; - SYMBOL: ignore : ( remaining ast -- parse-result ) parse-result construct-boa ; +TUPLE: parser ; +C: parser +M: parser equal? eq? ; + +: init-parser ( parser -- parser ) + #! Set the delegate for the 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 ; + ] % - 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 ] % - 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 ] % - 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 or + dup ?quot swap f 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 ] [ 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 ] 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: (:) [