From c3bee3134235da78d422bd963128199557b8a59c Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Wed, 25 Sep 2019 20:26:12 -0700 Subject: [PATCH] peg: some cleanup. --- basis/peg/debugger/debugger.factor | 3 +- basis/peg/parsers/parsers.factor | 11 +++-- basis/peg/peg.factor | 75 ++++++++++-------------------- basis/peg/search/search.factor | 17 ++++--- 4 files changed, 44 insertions(+), 62 deletions(-) diff --git a/basis/peg/debugger/debugger.factor b/basis/peg/debugger/debugger.factor index e60217af53..5800d21a1c 100644 --- a/basis/peg/debugger/debugger.factor +++ b/basis/peg/debugger/debugger.factor @@ -13,5 +13,6 @@ M: parse-error error. ] tri ; M: parse-failed error. - "The " write dup word>> pprint " word could not parse the following input:" print nl + "The " write dup word>> pprint + " word could not parse the following input:" print nl input>> . ; diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index adcc78a1da..950db68062 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -1,7 +1,10 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel make math math.parser math.ranges peg -peg.private peg.search sequences strings unicode vectors ; + +USING: accessors kernel literals make math math.parser +math.ranges peg peg.private peg.search sequences strings unicode +vectors ; + IN: peg.parsers TUPLE: just-parser p1 ; @@ -31,9 +34,9 @@ M: just-parser (compile) ( parser -- quot ) : list-of-many ( items separator -- parser ) hide t (list-of) ; -: epsilon ( -- parser ) V{ } token ; +CONSTANT: epsilon $[ V{ } token ] -: any-char ( -- parser ) [ drop t ] satisfy ; +CONSTANT: any-char $[ [ drop t ] satisfy ] [ + error-stack get dup length 1 > [ [ pop ] [ pop swap (merge-errors) ] [ ] tri push ] [ drop @@ -134,8 +137,7 @@ TUPLE: peg-head rule-id involved-set eval-set ; 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 ; @@ -324,9 +326,7 @@ SYMBOL: delayed ! 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 ; @@ -343,11 +343,9 @@ M: token-parser (compile) ( peg -- quot ) 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 [ ] [ 2drop f @@ -359,29 +357,24 @@ M: satisfy-parser (compile) 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 ] [ 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? [ + ast>> dup ignore = [ drop ] [ swap [ ast>> push ] keep @@ -391,11 +384,7 @@ TUPLE: seq-parser parsers ; ] 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) [ @@ -435,11 +424,7 @@ M: repeat0-parser (compile) 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 '[ @@ -450,19 +435,15 @@ M: repeat1-parser (compile) TUPLE: optional-parser parser ; : check-optional ( result -- result ) - [ input-slice f ] unless* ; + [ input-slice f ] 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 @@ -487,14 +468,11 @@ M: ensure-not-parser (compile) 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 ; @@ -613,15 +591,12 @@ SYNTAX: PEG: [ [ 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 diff --git a/basis/peg/search/search.factor b/basis/peg/search/search.factor index 668b72cc71..2d4c23bee8 100644 --- a/basis/peg/search/search.factor +++ b/basis/peg/search/search.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: combinators continuations io io.streams.string kernel -math memoize namespaces peg sequences strings ; +literals math namespaces peg sequences strings ; IN: peg.search : stream-tree-write ( object stream -- ) @@ -15,15 +15,18 @@ IN: peg.search : tree-write ( object -- ) output-stream get stream-tree-write ; -MEMO: any-char-parser ( -- parser ) - [ drop t ] satisfy ; + : search ( string parser -- seq ) any-char-parser [ drop f ] action 2choice repeat0 [ parse sift ] [ 3drop { } ] recover ; -: (replace) ( string parser -- seq ) - any-char-parser 2choice repeat0 parse sift ; - : replace ( string parser -- result ) - [ (replace) tree-write ] with-string-writer ; + [ + any-char-parser 2choice repeat0 + parse sift tree-write + ] with-string-writer ;