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

modern: Allow [[ [=[ [0[ etc 

Fix slice-until to be a more general combinator
modern-harvey3
Doug Coleman 2019-12-07 18:26:15 -08:00
parent 3f9448bc18
commit a4a9500be1
4 changed files with 63 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/modern/modern-tests.factor
View File

@ -256,3 +256,7 @@ IN: modern.tests
{ t } [ "foo[[ ]]" [ rewrite-string-exact ] keep sequence= ] unit-test { t } [ "foo[[ ]]" [ rewrite-string-exact ] keep sequence= ] unit-test
{ t } [ "foo[11[ ]11]" [ rewrite-string-exact ] keep sequence= ] unit-test { t } [ "foo[11[ ]11]" [ rewrite-string-exact ] keep sequence= ] unit-test
{ t } [ "foo[123[ ]123]" [ rewrite-string-exact ] keep sequence= ] unit-test { t } [ "foo[123[ ]123]" [ rewrite-string-exact ] keep sequence= ] unit-test
{ } [ "[1,b)" string>literals drop ] unit-test
{ } [ "[1,b]" string>literals drop ] unit-test

45
extra/modern/modern.factor
View File

@ -13,11 +13,17 @@ ERROR: long-opening-mismatch tag open string n ch ;
ERROR: unexpected-terminator string n slice ; ! ] } ) ; ERROR: unexpected-terminator string n slice ; ! ] } ) ;
ERROR: compound-syntax-disallowed seq n obj ; ERROR: compound-syntax-disallowed seq n obj ;
ERROR: expected-digits-only str n got ; ERROR: expected-digits-only-or-equals-only str n got ;
! Allow [00[ ]00] etc ! Allow [00[ ]00] etc
: check-digits ( str n got -- str n digits ) : container-expander-char? ( ch -- ? )
dup but-last [ digit? ] all? { [ digit? ] [ char: = = ] } 1|| ; inline
[ >string but-last expected-digits-only ] unless ;
: check-container-expander ( str n got -- str n digits )
dup but-last {
[ [ digit? ] all? ]
[ [ char: = = ] all? ]
} 1||
[ >string but-last expected-digits-only-or-equals-only ] unless ;
! (( )) [[ ]] {{ }} ! (( )) [[ ]] {{ }}
MACRO:: read-double-matched ( $open-ch -- quot: ( string n tag ch -- string n' seq ) ) MACRO:: read-double-matched ( $open-ch -- quot: ( string n tag ch -- string n' seq ) )
@ -27,10 +33,10 @@ MACRO:: read-double-matched ( $open-ch -- quot: ( string n tag ch -- string n' s
:> ( $openstr2 $openstr1 $closestr2 ) ! "[[" "[" "]]" :> ( $openstr2 $openstr1 $closestr2 ) ! "[[" "[" "]]"
|[ $string $n $tag! $ch | |[ $string $n $tag! $ch |
$ch { $ch {
{ [ dup digit? ] [ { [ dup container-expander-char? ] [
drop $tag 1 cut-slice* drop $tag! ! XXX: $tag of (=( is ( here, fix it (??) drop $tag 1 cut-slice* drop $tag! ! XXX: $tag of (=( is ( here, fix it (??)
$string $n $openstr1 slice-until-include [ $string $n $openstr1 slice-until-token-include [
check-digits ! 000] ok, 00a] bad check-container-expander ! 000] ok, =] ok, 00=] bad
-1 modify-from -1 modify-from
] dip :> ( $string' $n' $opening $ch ) ] dip :> ( $string' $n' $opening $ch )
$ch $open-ch = [ $tag $openstr2 $string $n $ch long-opening-mismatch ] unless $ch $open-ch = [ $tag $openstr2 $string $n $ch long-opening-mismatch ] unless
@ -106,12 +112,27 @@ DEFER: lex-factor-nested
DEFER: lex-factor-fallthrough DEFER: lex-factor-fallthrough
MACRO:: read-matched ( $ch -- quot: ( string n tag -- string n' slice' ) ) MACRO:: read-matched ( $ch -- quot: ( string n tag -- string n' slice' ) )
{ 48 49 50 51 52 53 54 55 56 57 $ch } {
$ch matching-delimiter 1string :> ( $openstreq $closestr1 ) ! digits ] char: 0 char: 1 char: 2 char: 3 char: 4 char: 5
char: 6 char: 7 char: 8 char: 9 $ch char: =
} :> $openstr-chars
$ch matching-delimiter 1string :> $closestr1
|[ $string $n $tag | |[ $string $n $tag |
$string $n $tag $string $n $tag
2over nth-check-eof { 2over nth-check-eof {
{ [ dup $openstreq member? ] [ $ch read-double-matched ] } ! (=( or (( { [
dup {
[ $openstr-chars member? ]
[
! check that opening is good form
drop
$string $n [
{ [ $ch = ] [ blank? ] } 1||
] t slice-until 3nip $ch =
]
} 1&&
] [ $ch read-double-matched ] } ! (=( or ((
{ [ dup blank? ] [ { [ dup blank? ] [
drop dup '[ _ matching-delimiter-string $closestr1 2array members lex-until ] dip drop dup '[ _ matching-delimiter-string $closestr1 2array members lex-until ] dip
swap unclip-last 3array $ch <matched> swap unclip-last 3array $ch <matched>
@ -128,7 +149,7 @@ MACRO:: read-matched ( $ch -- quot: ( string n tag -- string n' slice' ) )
: read-paren ( string n slice -- string n' obj ) char: \( read-matched ; : read-paren ( string n slice -- string n' obj ) char: \( read-matched ;
: read-string-payload ( string n -- string n' ) : read-string-payload ( string n -- string n' )
dup [ dup [
{ char: \\ char: \" } slice-until-include { { char: \\ char: \" } slice-until-token-include {
{ f [ drop ] } { f [ drop ] }
{ char: \" [ drop ] } { char: \" [ drop ] }
{ char: \\ [ drop next-char-from drop read-string-payload ] } { char: \\ [ drop next-char-from drop read-string-payload ] }
@ -421,7 +442,7 @@ DEFER: lex-factor-top*
{ char: \" [ read-string ] } { char: \" [ read-string ] }
{ char: \! [ read-exclamation ] } { char: \! [ read-exclamation ] }
{ char: > [ { char: > [
[ [ char: > = not ] slice-until-exclude drop ] dip merge-slices [ [ char: > = not ] f slice-until drop ] dip merge-slices
dup section-close-form? [ dup section-close-form? [
[ slice-til-whitespace drop ] dip ?span-slices [ slice-til-whitespace drop ] dip ?span-slices
] unless ] unless

6
extra/modern/slices/slices-tests.factor
View File

@ -27,10 +27,10 @@ IN: modern.slices.tests
"foo:" 3 slice-til-whitespace "foo:" 3 slice-til-whitespace
] unit-test ] unit-test
{ "foo " f T{ slice f 0 4 "foo " } f } [ { "foo " 4 T{ slice f 0 4 "foo " } 32 } [
"foo " 0 [ blank? ] slice-until-include "foo " 0 [ blank? ] t slice-until
] unit-test ] unit-test
{ "foo " 3 T{ slice f 0 3 "foo " } 32 } [ { "foo " 3 T{ slice f 0 3 "foo " } 32 } [
"foo " 0 [ blank? ] slice-until-exclude "foo " 0 [ blank? ] f slice-until
] unit-test ] unit-test

38
extra/modern/slices/slices.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2016 Doug Coleman. ! Copyright (C) 2016 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel locals math sequences USING: accessors assocs fry kernel locals math sequences
sequences.deep sequences.extras strings unicode sequences.private ; sequences.deep sequences.extras strings unicode sequences.private
shuffle ;
IN: modern.slices IN: modern.slices
ERROR: unexpected-eof string n expected ; ERROR: unexpected-eof string n expected ;
@ -53,38 +54,39 @@ ERROR: unexpected-eof string n expected ;
: find-from*' ( ... seq n quot: ( ... elt -- ... ? ) -- ... i elt ? ) : find-from*' ( ... seq n quot: ( ... elt -- ... ? ) -- ... i elt ? )
swapd find-from* ; inline swapd find-from* ; inline
: slice-until-exclude ( string n quot -- string n' slice/f ch/f ) : slice-until ( string n quot include? -- string n' slice/f ch/f )
over [ pick [
'[
[ drop ] [ drop ]
[ find-from' ] 3bi ! ( string n n' ch ) [ find-from' _ [ [ ?1+ ] dip ] when ] 3bi ! ( string n n' ch )
[ drop nip ] [ drop nip ]
[ [ rot ?<slice> ] dip ] 4bi [ [ rot ?<slice> ] dip ] 4bi
] call
] [ ] [
drop f f 2drop f f
] if ; inline ] if ; inline
: slice-until-include ( string n tokens -- string n' slice/f ch/f ) : slice-until-token-exclude ( string n tokens -- string n' slice/f ch/f )
over [ '[ _ member? ] f slice-until ; inline
'[ _ member? ]
[ drop ] : slice-until-token-include ( string n tokens -- string n' slice/f ch/f )
[ find-from' [ ?1+ ] dip ] 3bi ! ( string n n' ch ) '[ _ member? ] t slice-until ; inline
[ drop nip ]
[ [ rot ?<slice> ] dip ] 4bi : peek-until ( string n quot include? -- string n slice/f ch/f )
] [ '[ _ slice-until 2nipd ] 2keepd 2swap ; inline
drop f f
] if ; inline
: slice-til-whitespace ( string n -- string n' slice/f ch/f ) : slice-til-whitespace ( string n -- string n' slice/f ch/f )
[ "\s\r\n" member? ] slice-until-exclude ; inline [ "\s\r\n" member? ] f slice-until ; inline
: slice-til-not-whitespace ( string n -- string n' slice/f ch/f ) : slice-til-not-whitespace ( string n -- string n' slice/f ch/f )
[ "\s\r\n" member? not ] slice-until-exclude ; inline [ "\s\r\n" member? not ] f slice-until ; inline
: skip-whitespace ( string n/f -- string n'/f ) : skip-whitespace ( string n/f -- string n'/f )
slice-til-not-whitespace 2drop ; slice-til-not-whitespace 2drop ;
: slice-til-eol ( string n -- string n' slice/f ch/f ) : slice-til-eol ( string n -- string n' slice/f ch/f )
[ "\r\n" member? ] slice-until-exclude ; inline [ "\r\n" member? ] f slice-until ; inline
: merge-slice-til-whitespace ( string n slice -- string n' slice' ) : merge-slice-til-whitespace ( string n slice -- string n' slice' )
over [ over [