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

modern: handle optional semicolons partially.

locals-and-roots
Doug Coleman 2016-06-20 10:32:13 -07:00
parent 692aecc323
commit d4cb6170eb
2 changed files with 45 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
core/modern/lexer/lexer.factor
View File

@ -14,6 +14,21 @@ CONSTRUCTOR: <modern-lexer> modern-lexer ( string -- obj )
: ?lexer-nth ( lexer -- obj )
>lexer< over [ ?nth ] [ 2drop f ] if ;
: lexer-eof? ( lexer -- obj )
n>> >boolean ;
: push-tag ( lexer tag -- )
swap stack>> push ;
: peek-tag ( lexer -- tag )
stack>> ?last ;
: pop-tag ( lexer -- tag )
stack>> [ f ] [ pop ] if-empty ;
: roll-back-lexer ( lexer slice -- )
from>> >>n drop ;
ERROR: unexpected-end n string ;
: nth-check-eof ( n string -- nth )
2dup ?nth [ 2nip ] [ unexpected-end ] if* ; inline

37
core/modern/modern.factor
View File

@ -126,7 +126,7 @@ M: array collapse-decorators
: scoped-less-than-name ( string -- string' )
dup [ length 2 - ] keep [ char: < = ] find-last-from [ 1 + tail ] [ drop ] if ;
: scoped-upper? ( string -- ? )
: top-level-name? ( string -- ? )
dup { [ ":" tail? ] [ "<" tail? ] } 1|| [
dup length 1 > [
[ [ ":<" member? ] trim-tail [ char: \: = ] find-last ] keep
@ -138,6 +138,18 @@ M: array collapse-decorators
drop f
] if ;
: top-level-colon? ( string -- ? )
dup ":" tail? [
dup length 1 > [
[ [ char: \: = ] trim-tail [ char: \: = ] find-last ] keep
swap [ swap tail strict-upper? ] [ nip strict-upper? ] if
] [
":" sequence=
] if
] [
drop f
] if ;
ERROR: whitespace-expected-after n string ch ;
ERROR: expected-more-tokens n string expected ;
ERROR: string-expected-got-eof n string ;
@ -249,17 +261,17 @@ ERROR: unnestable-form n string obj ;
! For implementing [ { (
: lex-until ( lexer tags -- payload closing )
! over lexer-found-eof? [ "more tokens expected" throw ] when
2dup '[
'[
[
_ B lex-factor [
_ lex-factor [
dup tag-literal? [
dup ,
underlying>> ! { [ dup scoped-upper? ] [ 4 npick 0 > ] } 0&& [ unnestable-form ] when
underlying>> ! { [ dup top-level-name? ] [ 4 npick 0 > ] } 0&& [ unnestable-form ] when
_ [ sequence= ] with any? not
] [ , t ] if
] [
_ _ lex-expected-but-got-eof
f , f
! _ _ over lexer-eof? [ lex-expected-but-got-eof ] [ 2drop f , f ] if
] if*
] loop
] { } make unclip-last ; inline
@ -311,11 +323,18 @@ MACRO:: read-matched ( ch -- quot: ( lexer tag -- slice' ) )
ERROR: cannot-nest-upper-colon n string string' ;
: read-upper-colon ( lexer string' -- obj )
: read-upper-colon ( lexer string' -- obj/f )
! 4 npick 0 > [ cannot-nest-upper-colon ] when
over peek-tag top-level-colon? [
! roll back, nested upper
roll-back-lexer f
] [
2dup push-tag [
dup [
[ but-last ";" append ";" 2array ] [ ";" 1array ] if* lex-until
] dip 1 cut-slice* uppercase-colon-literal make-matched-literal ;
] dip 1 cut-slice* uppercase-colon-literal make-matched-literal
] 2keep drop pop-tag drop
] if ;
: read-lower-colon ( lexer string' -- obj )
[ lex-factor dup ] dip 1 cut-slice*
@ -327,7 +346,7 @@ ERROR: cannot-nest-upper-colon n string string' ;
{ [ dup length 1 = ] [ read-upper-colon ] }
{ [ dup [ char: \: = ] all? ] [ read-upper-colon ] }
{ [ dup { [ ":" head? ] [ ":" tail? ] } 1&& ] [ nip make-tag-literal ] }
{ [ dup ":" tail? ] [ dup scoped-upper? [ read-upper-colon ] [ read-lower-colon ] if ] }
{ [ dup ":" tail? ] [ dup top-level-name? [ read-upper-colon ] [ read-lower-colon ] if ] }
{ [ dup ":" head? ] [ nip make-tag-literal ] } ! :foo( ... )
[ nip make-tag-literal ]
} cond ;
@ -341,7 +360,7 @@ ERROR: cannot-nest-upper-colon n string string' ;
: read-less-than ( lexer slice -- less-than )
dupd merge-lex-til-whitespace {
{ [ dup length 1 = ] [ nip make-tag-literal ] } ! "<"
{ [ dup "<" tail? ] [ dup scoped-upper? [ read-upper-less-than ] [ nip make-tag-literal ] if ] } ! FOO< or foo<
{ [ dup "<" tail? ] [ dup top-level-name? [ read-upper-less-than ] [ nip make-tag-literal ] if ] } ! FOO< or foo<
[ nip make-tag-literal ]
} cond ;