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

modern: before feature.

locals-and-roots
Doug Coleman 2016-06-19 23:14:55 -07:00
parent e9c388c649
commit 692aecc323
1 changed files with 8 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
core/modern/modern.factor
View File

@ -251,7 +251,7 @@ ERROR: unnestable-form n string obj ;
! over lexer-found-eof? [ "more tokens expected" throw ] when ! over lexer-found-eof? [ "more tokens expected" throw ] when
2dup '[ 2dup '[
[ [
_ lex-factor [ _ B lex-factor [
dup tag-literal? [ dup tag-literal? [
dup , dup ,
underlying>> ! { [ dup scoped-upper? ] [ 4 npick 0 > ] } 0&& [ unnestable-form ] when underlying>> ! { [ dup scoped-upper? ] [ 4 npick 0 > ] } 0&& [ unnestable-form ] when
@ -275,8 +275,10 @@ MACRO:: read-matched ( ch -- quot: ( lexer tag -- slice' ) )
over lexer-nth-check-eof { over lexer-nth-check-eof {
{ [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or (( { [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
{ [ dup blank? ] [ { [ dup blank? ] [
drop dup '[ _ matching-delimiter-string closestr1 2dup = [ drop 1array ] [ 2array ] if lex-until ] dip drop dup '[
1 cut-slice* single-matched-literal make-matched-literal _ matching-delimiter-string closestr1
2dup = [ drop 1array ] [ 2array ] if lex-until
] dip 1 cut-slice* single-matched-literal make-matched-literal
] } ! ( foo ) ] } ! ( foo )
[ drop [ lex-til-whitespace drop 2nip ] dip span-slices make-tag-literal ] ! (foo) [ drop [ lex-til-whitespace drop 2nip ] dip span-slices make-tag-literal ] ! (foo)
} cond } cond
@ -301,7 +303,6 @@ MACRO:: read-matched ( ch -- quot: ( lexer tag -- slice' ) )
:: read-string ( lexer tag -- seq ) :: read-string ( lexer tag -- seq )
lexer n>> :> n lexer n>> :> n
lexer read-string-payload :> ( n' string slice ) lexer read-string-payload :> ( n' string slice )
! n' string
n' [ n string string-expected-got-eof ] unless n' [ n string string-expected-got-eof ] unless
n n' 1 - string <slice> >string n n' 1 - string <slice> >string
n' 1 - n' string <slice> n' 1 - n' string <slice>
@ -312,8 +313,9 @@ MACRO:: read-matched ( ch -- quot: ( lexer tag -- slice' ) )
ERROR: cannot-nest-upper-colon n string string' ; ERROR: cannot-nest-upper-colon n string string' ;
: read-upper-colon ( lexer string' -- obj ) : read-upper-colon ( lexer string' -- obj )
! 4 npick 0 > [ cannot-nest-upper-colon ] when ! 4 npick 0 > [ cannot-nest-upper-colon ] when
dup [ scoped-colon-name [ but-last ";" append ";" 2array ] [ ";" 1array ] if* lex-until ] dip dup [
1 cut-slice* uppercase-colon-literal make-matched-literal ; [ but-last ";" append ";" 2array ] [ ";" 1array ] if* lex-until
] dip 1 cut-slice* uppercase-colon-literal make-matched-literal ;
: read-lower-colon ( lexer string' -- obj ) : read-lower-colon ( lexer string' -- obj )
[ lex-factor dup ] dip 1 cut-slice* [ lex-factor dup ] dip 1 cut-slice*