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

modern: fix for words like S<<

locals-and-roots
Doug Coleman 2016-06-20 13:58:23 -07:00
parent 42d6d59993
commit 956719fc88
1 changed files with 13 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
core/modern/modern.factor
View File

@ -113,9 +113,9 @@ M: array collapse-decorators
: postprocess-lexed ( seq -- seq' ) : postprocess-lexed ( seq -- seq' )
collapse-decorators make-compound-literals ; collapse-decorators make-compound-literals ;
! foo:bar-baz09:
: strict-upper? ( string -- ? ) : strict-upper? ( string -- ? )
[ { [ char: A char: Z between? ] [ char: 0 char: 9 between? ] [ "#:-<" member? ] } 1|| ] all? ; [ { [ char: A char: Z between? ] [ char: 0 char: 9 between? ] [ ":-#" member? ] } 1|| ] all? ;
: whitespace/f? ( ch -- ? ) : whitespace/f? ( ch -- ? )
{ char: \s char: \r char: \n f } member? ; inline { char: \s char: \r char: \n f } member? ; inline
@ -126,22 +126,17 @@ M: array collapse-decorators
: scoped-less-than-name ( string -- string' ) : scoped-less-than-name ( string -- string' )
dup [ length 2 - ] keep [ char: < = ] find-last-from [ 1 + tail ] [ drop ] if ; dup [ length 2 - ] keep [ char: < = ] find-last-from [ 1 + tail ] [ drop ] if ;
: top-level-name? ( string -- ? ) : trim-top-level ( string -- string' )
dup { [ ":" tail? ] [ "<" tail? ] } 1|| [ {
dup length 1 > [ { [ dup "<" tail? ] [ but-last ] }
[ [ ":<" member? ] trim-tail [ char: \: = ] find-last ] keep { [ dup ":" tail? ] [ [ char: \: = ] trim-tail ] }
swap [ swap tail strict-upper? ] [ nip strict-upper? ] if [ ]
] [ } cond ;
"<" sequence= not
] if
] [
drop f
] if ;
: top-level-colon? ( string -- ? ) : top-level-colon? ( string -- ? )
dup ":" tail? [ dup ":" tail? [
dup length 1 > [ dup length 1 > [
[ [ char: \: = ] trim-tail [ char: \: = ] find-last ] keep [ trim-top-level [ char: \: = ] find-last ] keep
swap [ swap tail strict-upper? ] [ nip strict-upper? ] if swap [ swap tail strict-upper? ] [ nip strict-upper? ] if
] [ ] [
":" sequence= ":" sequence=
@ -152,6 +147,7 @@ M: array collapse-decorators
: top-level-less-than? ( string -- ? ) : top-level-less-than? ( string -- ? )
dup "<" tail? [ dup "<" tail? [
but-last
dup length 1 > [ dup length 1 > [
[ [ char: \: = ] find-last ] keep [ [ char: \: = ] find-last ] keep
swap [ swap tail strict-upper? ] [ nip strict-upper? ] if swap [ swap tail strict-upper? ] [ nip strict-upper? ] if
@ -162,6 +158,9 @@ M: array collapse-decorators
drop f drop f
] if ; ] if ;
: top-level-name? ( string -- ? )
{ [ top-level-colon? ] [ top-level-less-than? ] } 1|| ;
ERROR: no-start-delimiter lexer opening ; ERROR: no-start-delimiter lexer opening ;
:: delimiters-match? ( lexer opening closing -- ? ) :: delimiters-match? ( lexer opening closing -- ? )
opening empty? [ lexer opening closing no-start-delimiter ] when opening empty? [ lexer opening closing no-start-delimiter ] when