diff --git a/extra/find/extras/extras.factor b/extra/find/extras/extras.factor index 31df0ef942..e4f4dd27e1 100644 --- a/extra/find/extras/extras.factor +++ b/extra/find/extras/extras.factor @@ -2,27 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators combinators.extras combinators.smart fry generalizations kernel literals locals -macros make math math.private multiline namespaces quotations -sequences sequences.deep sequences.extras +macros make math math.private modern.slices multiline namespaces +quotations sequences sequences.deep sequences.extras sequences.generalizations sequences.private shuffle stack-checker.transforms strings unicode words ; IN: find.extras -: >strings ( seq -- str ) - [ dup slice? [ >string ] when ] deep-map ; - -: matching-delimiter ( ch -- ch' ) - H{ - { char: \( char: \) } - { char: \[ char: \] } - { char: \{ char: \} } - { char: < char: > } - { char: \: char: \; } - } ?at drop ; - -: matching-delimiter-string ( string -- string' ) - [ matching-delimiter ] map ; - SYMBOL: delimiter-stack : with-delimiter-stack ( string quot -- seq ) diff --git a/extra/modern/modern-tests.factor b/extra/modern/modern-tests.factor index 10432d6949..12af1ca7d1 100644 --- a/extra/modern/modern-tests.factor +++ b/extra/modern/modern-tests.factor @@ -26,9 +26,13 @@ IN: modern.tests } [ ":asdf:" string>literals >strings ] unit-test { - { { "one:" "1" } } + { { "one:" { "1" } } } } [ "one: 1" string>literals >strings ] unit-test +{ + { { "two::" { "1" "2" } } } +} [ "two:: 1 2" string>literals >strings ] unit-test + { { "1" ":>" "one" } } [ "1 :> one" string>literals >strings ] unit-test @@ -96,16 +100,16 @@ IN: modern.tests { { "foo\\bar{" { "1" } "}" } } } [ "foo\\bar{ 1 }" string>literals >strings ] unit-test -{ { { "char:" "\\{" } } } [ "char: \\{" string>literals >strings ] unit-test +{ { { "char:" { "\\{" } } } } [ "char: \\{" string>literals >strings ] unit-test [ "char: {" string>literals >strings ] must-fail [ "char: [" string>literals >strings ] must-fail [ "char: {" string>literals >strings ] must-fail [ "char: \"" string>literals >strings ] must-fail -{ { { "char:" "\\\\" } } } [ "char: \\\\" string>literals >strings ] unit-test +{ { { "char:" { "\\\\" } } } } [ "char: \\\\" string>literals >strings ] unit-test [ "char: \\" string>literals >strings ] must-fail ! char: \ should be legal eventually -{ { { "\\" "(" } } } [ "\\ (" string>literals >strings ] unit-test +{ { { "\\" { "(" } } } } [ "\\ (" string>literals >strings ] unit-test { { "\\[[" } } [ "\\[[" string>literals >strings ] unit-test { { "\\[=[" } } [ "\\[=[" string>literals >strings ] unit-test @@ -177,3 +181,24 @@ IN: modern.tests { "" } } } [ "" string>literals >strings ] unit-test + + +{ + { + { + { + "foo::" + { + { + { "" } + { "[" { "0" } "]" } + { "[" { "1" } "]" } + { "[" { "2" } "]" } + { "[" { "3" } "]" } + } + { { "" } } + } + } + } + } +} [ "foo:: [ 0 ][ 1 ][ 2 ][ 3 ] " string>literals >strings ] unit-test \ No newline at end of file diff --git a/extra/modern/modern.factor b/extra/modern/modern.factor index 1f3dfc1280..b7dbcd1bd2 100644 --- a/extra/modern/modern.factor +++ b/extra/modern/modern.factor @@ -46,13 +46,14 @@ MACRO:: read-double-matched ( open-ch -- quot: ( n string tag ch -- n' string se : read-double-matched-bracket ( n string tag ch -- n' string seq ) char: \[ read-double-matched ; : read-double-matched-brace ( n string tag ch -- n' string seq ) char: \{ read-double-matched ; +DEFER: (lex-factor) DEFER: lex-factor ERROR: lex-expected-but-got-eof n string expected ; ! For implementing [ { ( : lex-until ( n string tag-sequence -- n' string payload ) 3dup '[ [ - lex-factor dup f like [ , ] when* [ + (lex-factor) dup f like [ , ] when* [ dup [ ! } gets a chance, but then also full seq { } after recursion... [ _ ] dip '[ _ sequence= ] any? not @@ -68,7 +69,7 @@ ERROR: lex-expected-but-got-eof n string expected ; : lex-colon-until ( n string tag-sequence -- n' string payload ) '[ [ - lex-factor dup f like [ , ] when* [ + (lex-factor) dup f like [ , ] when* [ dup [ ! } gets a chance, but then also full seq { } after recursion... [ _ ] dip '[ _ sequence= ] any? not @@ -226,7 +227,7 @@ ERROR: no-backslash-payload n string slice ; ! If the slice is 0 width, we stopped on whitespace. ! Advance the index and read again! : read-token-or-whitespace ( n string slice -- n' string slice/f ) - dup length 0 = [ [ 1 + ] 2dip drop lex-factor ] when ; + dup length 0 = [ [ 1 + ] 2dip drop (lex-factor) ] when ; ERROR: mismatched-terminator n string slice ; : read-terminator ( n string slice -- n' string slice ) ; @@ -236,7 +237,7 @@ ERROR: mismatched-terminator n string slice ; : ?length-and-string ( length/f string -- length string ) over [ nip [ length ] [ ] bi ] unless ; inline -: (lex-factor) ( n/f string slice/f ch/f -- n'/f string literal ) +: ((lex-factor)) ( n/f string slice/f ch/f -- n'/f string literal ) { { char: \" [ read-string ] } { char: \! [ read-exclamation ] } @@ -267,13 +268,15 @@ ERROR: mismatched-terminator n string slice ; ] when ] } { char: > [ - [ slice-til-whitespace drop ] dip span-slices + [ [ char: > = not ] slice-until ] dip merge-slices dup section-close? [ strict-upper get [ [ ?length-and-string ] dip length swap [ - ] dip f strict-upper off ] when - ] when + ] [ + [ slice-til-whitespace drop ] dip ?span-slices + ] if ] } { char: \[ [ read-bracket ] } { char: \{ [ read-brace ] } @@ -287,7 +290,7 @@ ERROR: mismatched-terminator n string slice ; { f [ ] } } case ; -: lex-factor ( n/f string -- n'/f string literal ) +: (lex-factor) ( n/f string -- n'/f string literal ) over [ ! skip-whitespace "\"\\!:[{(]})<>\s\r\n" slice-til-either @@ -302,10 +305,10 @@ ERROR: mismatched-terminator n string slice ; drop dup "\\" sequence= [ read-backslash ] [ merge-slice-til-whitespace ] if ] [ - over "\\" tail? [ drop read-backslash ] [ (lex-factor) ] if + over "\\" tail? [ drop read-backslash ] [ ((lex-factor)) ] if ] if ] [ - (lex-factor) + ((lex-factor)) ] if ] [ f @@ -314,23 +317,27 @@ ERROR: mismatched-terminator n string slice ; ERROR: compound-syntax-disallowed seq i obj ; : check-for-compound-syntax ( seq -- seq' ) dup [ length 1 > ] find - [ compound-syntax-disallowed ] [ drop ] if* - concat ; + [ compound-syntax-disallowed ] [ drop ] if* ; + +: lex-factor ( n/f string/f -- n'/f string literal/f ) + [ + ! Compound syntax loop + [ + (lex-factor) f like [ , ] when* + ! concatenated syntax ( a )[ a 1 + ]( b ) + [ ] + [ peek-from blank? ] + [ previous-from blank? or not ] 2tri pick and + ] loop + ] { } make + ! check-for-compound-syntax + ! concat + f like ; : string>literals ( string -- sequence ) [ 0 ] dip [ - [ - [ - [ - lex-factor f like [ , ] when* - ! concatenated syntax ( a )[ a 1 + ]( b ) - [ ] - [ peek-from blank? ] - [ previous-from blank? or not ] 2tri pick and - ] loop - ] { } make f like [ , ] when* over - ] loop - ] { } make 2nip check-for-compound-syntax ; + [ lex-factor [ , ] when* over ] loop + ] { } make 2nip ; : vocab>literals ( vocab -- sequence ) ".private" ?tail drop diff --git a/extra/modern/slices/slices.factor b/extra/modern/slices/slices.factor index d52e4ca14e..5d1c2f9b3e 100644 --- a/extra/modern/slices/slices.factor +++ b/extra/modern/slices/slices.factor @@ -59,9 +59,6 @@ ERROR: unexpected-end n string ; : char-after-slice ( slice -- ch/f ) [ to>> ] [ seq>> ] bi ?nth ; -: next-char-from* ( n/f string -- ch/f ) - next-char-from 2nip ; - : find-from* ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt ? ) [ find-from ] 2keep drop pick [ drop t ] [ length -rot nip f ] if ; inline @@ -180,6 +177,7 @@ ERROR: unexpected-end n string ; [ [ 1 - ] change-to ] dip ] when ; +! Takes at least one character if not whitespace :: slice-til-either ( n string tokens -- n'/f string slice/f ch/f ) n [ n string '[ tokens member? ] find-from