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

modern: before major refactor.

locals-and-roots
Doug Coleman 2016-06-17 01:29:53 -07:00
parent 604f14f630
commit 672ecb7c88
1 changed files with 39 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
core/modern/modern.factor
View File

@ -129,8 +129,8 @@ M: array collapse-decorators
: scoped-upper? ( string -- ? ) : scoped-upper? ( string -- ? )
dup { [ ":" tail? ] [ "<" tail? ] } 1|| [ dup { [ ":" tail? ] [ "<" tail? ] } 1|| [
dup length 1 > [ dup length 1 > [
[ [ length 2 - ] keep [ char: \: = ] find-last-from ] keep [ [ ":<" member? ] trim-tail [ char: \: = ] find-last ] keep
swap [ swap tail strict-upper? ] [ nip strict-upper? ] if swap [ swap tail strict-upper? ] [ nip strict-upper? ] if
] [ ] [
"<" sequence= not "<" sequence= not
] if ] if
@ -177,10 +177,11 @@ ERROR: mismatched-closing opening closing ;
tag closing [ dup tag-literal? [ lexed-underlying ] when ] bi@ ?span-slices >>underlying tag closing [ dup tag-literal? [ lexed-underlying ] when ] bi@ ?span-slices >>underlying
opening-delimiter >string >>delimiter opening-delimiter >string >>delimiter
dup single-matched-literal? [ dup single-matched-literal? [
! closing tag>> length 1 > [ closing dup [ tag>> ] when length 1 > [
! tag opening-delimiter append tag opening-delimiter append
! matching-delimiter-string closing tag>> sequence= [ opening-delimiter closing tag>> mismatched-closing ] unless matching-delimiter-string closing dup [ tag>> ] when sequence=
! ] when [ opening-delimiter closing tag>> mismatched-closing ] unless
] when
closing dup [ tag>> ] when >>closing-tag closing dup [ tag>> ] when >>closing-tag
] when ] when
tag opening-delimiter payload closing 4array >>seq ; inline tag opening-delimiter payload closing 4array >>seq ; inline
@ -248,36 +249,40 @@ ERROR: lex-expected-but-got-eof n string quot ;
ERROR: unnestable-form n string obj ; ERROR: unnestable-form n string obj ;
! For implementing [ { ( ! For implementing [ { (
: lex-until ( top? n string tags -- top?' n' string payload closing ) : lex-until ( nested n string tags -- nested' n' string payload closing )
3 npick [ lex-expected-but-got-eof ] unless ! 3 npick [ lex-expected-but-got-eof ] unless
3dup '[ '[
[ [
lex-factor lex-factor [
[ _ _ _ lex-expected-but-got-eof ] unless* ! [ _ _ _ lex-expected-but-got-eof ] unless*
dup , dup tag-literal? [ dup tag-literal? [
underlying>> dup scoped-upper? [ unnestable-form ] when dup ,
_ [ sequence= ] with any? not underlying>> ! { [ dup scoped-upper? ] [ 4 npick 0 > ] } 0&& [ unnestable-form ] when
] [ drop t ] if _ [ sequence= ] with any? not
] [ , t ] if
] [
f , f
] if*
] loop ] loop
] { } make unclip-last ; inline ] { } make unclip-last ; inline
MACRO:: read-matched ( ch -- quot: ( top? n string tag -- top?' n' string slice' ) ) MACRO:: read-matched ( ch -- quot: ( nested n string tag -- nested' n' string slice' ) )
ch dup matching-delimiter { ch dup matching-delimiter {
[ drop "=" swap prefix ] [ drop "=" swap prefix ]
[ nip 1string ] [ nip 1string ]
} 2cleave :> ( openstreq closestr1 ) ! [= ] } 2cleave :> ( openstreq closestr1 ) ! [= ]
|[ n string tag | |[ nested n string tag |
n string tag nested 1 + n string tag
2over nth-check-eof { 2over nth-check-eof {
{ [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or (( { [ dup openstreq member? ] [ ch read-double-matched ] } ! (=( or ((
{ [ dup blank? ] [ drop dup '[ _ matching-delimiter-string closestr1 2array lex-until ] dip 1 cut-slice* single-matched-literal make-matched-literal ] } ! ( foo ) { [ dup blank? ] [ drop dup '[ _ matching-delimiter-string closestr1 2array lex-until ] dip 1 cut-slice* single-matched-literal make-matched-literal [ 1 - ] 3dip ] } ! ( foo )
[ drop [ slice-til-whitespace drop ] dip span-slices make-tag-literal ] ! (foo) [ drop [ slice-til-whitespace drop ] dip span-slices make-tag-literal ] ! (foo)
} cond } cond
] ; ] ;
: read-bracket ( top? n string slice -- top?' n' string slice' ) char: \[ read-matched ; : read-bracket ( nested n string slice -- nested' n' string slice' ) char: \[ read-matched ;
: read-brace ( top? n string slice -- top?' n' string slice' ) char: \{ read-matched ; : read-brace ( nested n string slice -- nested' n' string slice' ) char: \{ read-matched ;
: read-paren ( top? n string slice -- top?' n' string slice' ) char: \( read-matched ; : read-paren ( nested n string slice -- nested' n' string slice' ) char: \( read-matched ;
: read-string-payload ( n string -- n' string ) : read-string-payload ( n string -- n' string )
over [ over [
@ -300,18 +305,21 @@ MACRO:: read-matched ( ch -- quot: ( top? n string tag -- top?' n' string slice'
: read-upper-colon ( top? n string string' -- top?' n' string obj ) ERROR: cannot-nest-upper-colon nested n string string' ;
: read-upper-colon ( nested n string string' -- nested' n' string obj )
4 npick 0 > [ cannot-nest-upper-colon ] when
dup [ scoped-colon-name [ but-last ";" append ";" 2array ] [ ";" 1array ] if* lex-until ] dip dup [ scoped-colon-name [ but-last ";" append ";" 2array ] [ ";" 1array ] if* lex-until ] dip
1 cut-slice* uppercase-colon-literal make-matched-literal ; 1 cut-slice* uppercase-colon-literal make-matched-literal ;
: read-lower-colon ( top?' n string string' -- top?' n' string obj ) : read-lower-colon ( nested' n string string' -- nested' n' string obj )
[ lex-factor dup ] dip 1 cut-slice* [ lex-factor dup ] dip 1 cut-slice*
lowercase-colon-literal make-delimited-literal ; lowercase-colon-literal make-delimited-literal ;
! : foo: :foo foo:bar foo:BAR: foo:bar: :foo: ! : foo: :foo foo:bar foo:BAR: foo:bar: :foo:
: read-colon ( top? n string slice -- top?' n' string colon ) : read-colon ( nested n string slice -- nested' n' string colon )
merge-slice-til-whitespace { merge-slice-til-whitespace {
{ [ dup length 1 = ] [ read-upper-colon ] } { [ dup length 1 = ] [ read-upper-colon ] }
{ [ dup [ char: \: = ] all? ] [ read-upper-colon ] }
{ [ dup { [ ":" head? ] [ ":" tail? ] } 1&& ] [ make-tag-literal ] } { [ dup { [ ":" head? ] [ ":" tail? ] } 1&& ] [ make-tag-literal ] }
{ [ dup ":" tail? ] [ dup scoped-upper? [ read-upper-colon ] [ read-lower-colon ] if ] } { [ dup ":" tail? ] [ dup scoped-upper? [ read-upper-colon ] [ read-lower-colon ] if ] }
{ [ dup ":" head? ] [ make-tag-literal ] } ! :foo( ... ) { [ dup ":" head? ] [ make-tag-literal ] } ! :foo( ... )
@ -320,11 +328,11 @@ MACRO:: read-matched ( ch -- quot: ( top? n string tag -- top?' n' string slice'
: read-upper-less-than ( top? n string slice -- top?' n' string less-than ) : read-upper-less-than ( nested n string slice -- nested' n' string less-than )
dup [ scoped-less-than-name [ but-last ">" append 1array ] [ ">" 1array ] if* lex-until ] dip dup [ scoped-less-than-name [ but-last ">" append 1array ] [ ">" 1array ] if* lex-until ] dip
1 cut-slice* less-than-literal make-matched-literal ; 1 cut-slice* less-than-literal make-matched-literal ;
: read-less-than ( top? n string slice -- top?' n' string less-than ) : read-less-than ( nested n string slice -- nested' n' string less-than )
merge-slice-til-whitespace { merge-slice-til-whitespace {
{ [ dup length 1 = ] [ make-tag-literal ] } ! "<" { [ dup length 1 = ] [ make-tag-literal ] } ! "<"
{ [ dup "<" tail? ] [ dup scoped-upper? [ read-upper-less-than ] [ make-tag-literal ] if ] } ! FOO< or foo< { [ dup "<" tail? ] [ dup scoped-upper? [ read-upper-less-than ] [ make-tag-literal ] if ] } ! FOO< or foo<
@ -364,7 +372,7 @@ ERROR: backslash-expects-whitespace slice ;
! If the slice is 0 width, we stopped on whitespace. ! If the slice is 0 width, we stopped on whitespace.
! Advance the index and read again! ! Advance the index and read again!
: read-token-or-whitespace ( top? n string slice -- top?' n' string slice ) : read-token-or-whitespace ( nested n string slice -- nested' n' string slice )
[ [ 1 + ] dip lex-factor ] [ [ 1 + ] dip lex-factor ]
[ make-tag-literal ] if-empty ; [ make-tag-literal ] if-empty ;
@ -415,7 +423,7 @@ COMPILE<
COMPILE> COMPILE>
! 0 "HI: ;" slice-til-either -> 3 "HI: ;" "HI:" CHAR: \: ! 0 "HI: ;" slice-til-either -> 3 "HI: ;" "HI:" CHAR: \:
MACRO: rules>call-lexer ( seq -- quot: ( top? n/f string -- top?' n'/f string literal ) ) MACRO: rules>call-lexer ( seq -- quot: ( nested n/f string -- nested' n'/f string literal ) )
[ lexer-rules>delimiters ] [ lexer-rules>delimiters ]
[ [
lexer-rules>assoc lexer-rules>assoc
@ -446,11 +454,11 @@ CONSTANT: factor-lexing-rules {
T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter char: \n } } T{ whitespace-lexer { generator read-token-or-whitespace } { delimiter char: \n } }
} ; } ;
: lex-factor ( top? n/f string -- top?' n'/f string literal ) : lex-factor ( nested n/f string -- nested' n'/f string literal )
factor-lexing-rules rules>call-lexer ; factor-lexing-rules rules>call-lexer ;
: string>literals ( string -- sequence ) : string>literals ( string -- sequence )
[ t 0 ] dip [ lex-factor ] loop>array nip 2nip postprocess-lexed ; [ 0 0 ] dip [ lex-factor ] loop>array nip 2nip postprocess-lexed ;
: path>literals ( path -- sequence ) : path>literals ( path -- sequence )
utf8 file-contents string>literals ; utf8 file-contents string>literals ;