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

modern: working on CHAR: a

locals-and-roots
Doug Coleman 2016-06-13 10:34:51 -07:00
parent 890b1e3e34
commit de823c48ea
2 changed files with 20 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
core/modern/modern.factor
View File

@ -181,7 +181,7 @@ ERROR: mismatched-closing opening closing ;
! 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 tag>> sequence= [ opening-delimiter closing tag>> mismatched-closing ] unless
! ] when ! ] when
closing tag>> >>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
@ -261,15 +261,25 @@ ERROR: unnestable-form n string obj ;
] loop ] loop
] { } make unclip-last ; inline ] { } make unclip-last ; inline
: lex-until-top ( n string tags -- n' string payload closing ) : lex-until-top ( n string tags -- n' string payload closing )
3 npick [ lex-expected-but-got-eof ] unless '[
3dup '[
[ [
lex-factor lex-factor [
[ _ _ _ lex-expected-but-got-eof ] unless* dup tag-literal? [
dup , dup tag-literal? [ underlying>> _ [ sequence= ] with any? not ] [ drop t ] if dup underlying>> scoped-upper? [ ! end here, start anew
underlying>> length swap [ - ] dip f , f ! no loop
] [
dup , underlying>> _ [ sequence= ] with any? not
] if
] [
, t
] if
] [
f , f
] if*
] loop ] loop
] { } make unclip-last ; inline ] { } make unclip-last ;
@ -322,11 +332,10 @@ MACRO:: read-matched ( ch -- quot: ( n string tag -- n' string slice' ) )
! : foo: :foo foo:bar foo:BAR: foo:bar: :foo: ! : foo: :foo foo:bar foo:BAR: foo:bar: :foo:
: read-colon ( n string slice -- n string colon ) : read-colon ( n string slice -- n string colon )
B
merge-slice-til-whitespace { merge-slice-til-whitespace {
{ [ dup length 1 = ] [ read-upper-colon ] } { [ dup length 1 = ] [ read-upper-colon ] }
{ [ dup { [ ":" head? ] [ ":" tail? ] } 1&& ] [ make-tag-literal ] } { [ dup { [ ":" head? ] [ ":" tail? ] } 1&& ] [ make-tag-literal ] }
{ [ dup ":" tail? ] [ B 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( ... )
[ make-tag-literal ] [ make-tag-literal ]
} cond ; } cond ;
@ -420,18 +429,7 @@ PRIVATE>
[ make-tag-literal ] [ make-tag-literal ]
} cond ; } cond ;
symbol: lexing-delimiters
: add-lexing-delimiter ( rule -- )
[ ] [ delimiter>> ] bi lexing-delimiters get set-once-at ;
<< <<
: lexer-rules>hashtable ( seq -- obj )
H{ } clone lexing-delimiters [
[ add-lexing-delimiter ] each
lexing-delimiters get
] with-variable ;
: lexer-rules>delimiters ( seq -- string ) : lexer-rules>delimiters ( seq -- string )
[ delimiter>> ] "" map-as ; [ delimiter>> ] "" map-as ;

4
core/modern/out/out.factor
View File

@ -99,8 +99,8 @@ M: uppercase-colon-literal write-literal
[ seq>> 1 swap nth write-whitespace ] [ seq>> 1 swap nth write-whitespace ]
[ delimiter>> write ] [ delimiter>> write ]
[ payload>> [ write-literal ] each ] ! don't need write-whitespace here, the recursion does it [ payload>> [ write-literal ] each ] ! don't need write-whitespace here, the recursion does it
[ seq>> 3 swap nth lexed-underlying write-whitespace ] [ seq>> 3 swap nth lexed-underlying [ write-whitespace ] when* ]
[ closing-tag>> write ] [ closing-tag>> [ write ] when* ]
} cleave ; } cleave ;
M: lowercase-colon-literal write-literal M: lowercase-colon-literal write-literal