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

modern: Fix sections.

modern-harvey2
Doug Coleman 2017-08-21 23:39:38 -05:00
parent e7a5101366
commit 530ebd49ee
1 changed files with 31 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
extra/modern/modern.factor
View File

@ -148,11 +148,23 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
[ lex-factor ] dip swap 2array ; [ lex-factor ] dip swap 2array ;
: strict-upper? ( string -- ? ) : strict-upper? ( string -- ? )
[ { [ CHAR: A CHAR: Z between? ] [ "#:-" member? ] } 1|| ] all? ; [ { [ CHAR: A CHAR: Z between? ] [ ":-" member? ] } 1|| ] all? ;
! <a <a: but not <a> ! <a <a: but not <a>
: section? ( string -- ? ) : section-open? ( string -- ? )
{ [ "<" head? ] [ ">" tail? not ] } 1&& ; {
[ "<" head? ]
[ length 2 >= ]
[ rest strict-upper? ]
[ ">" tail? not ]
} 1&& ;
: section-close? ( string -- ? )
{
[ length 2 >= ]
[ but-last strict-upper? ]
[ ">" tail? ]
} 1&& ;
ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ; ERROR: colon-word-must-be-all-uppercase-or-lowercase n string word ;
: read-colon ( n string slice -- n' string colon ) : read-colon ( n string slice -- n' string colon )
@ -198,7 +210,7 @@ ERROR: mismatched-terminator n string slice ;
: lex-factor ( n/f string -- n'/f string literal ) : lex-factor ( n/f string -- n'/f string literal )
over [ over [
skip-whitespace "\"\\!:[{(<\s\r\n" slice-til-either { skip-whitespace "\"\\!:[{(<>\s\r\n" slice-til-either {
! { CHAR: ` [ read-backtick ] } ! { CHAR: ` [ read-backtick ] }
{ CHAR: " [ read-string ] } { CHAR: " [ read-string ] }
{ CHAR: \ [ read-backslash ] } { CHAR: \ [ read-backslash ] }
@ -217,14 +229,25 @@ ERROR: mismatched-terminator n string slice ;
! FOO: a b <asdf> ! FOO: a b <asdf>
! FOO: a b <asdf asdf> ! FOO: a b <asdf asdf>
[ slice-til-whitespace drop ] dip span-slices [ slice-til-whitespace drop ] dip span-slices
! if we are in a FOO: and we hit a <BAR or <BAR: ! if we are in a FOO: and we hit a <BAR or <BAR:
! then end the FOO: ! then end the FOO:
dup section? strict-upper get and [ dup section-open? [
length swap [ - ] dip f strict-upper get [
strict-upper off length swap [ - ] dip f strict-upper off
] [ ] [
read-acute read-acute
] if ] if
] when
] }
{ CHAR: > [
dup section-close? [
strict-upper get [
length swap [ - ] dip f strict-upper off
] when
] [
[ slice-til-whitespace drop ] dip span-slices ! >= >> etc
] if
] } ] }
{ CHAR: [ [ read-bracket ] } { CHAR: [ [ read-bracket ] }
{ CHAR: { [ read-brace ] } { CHAR: { [ read-brace ] }