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

modern: fix less than.

locals-and-roots
Doug Coleman 2016-06-20 11:08:35 -07:00
parent d4cb6170eb
commit 404ded9a42
2 changed files with 33 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -23,8 +23,11 @@ CONSTRUCTOR: <modern-lexer> modern-lexer ( string -- obj )
: peek-tag ( lexer -- tag ) : peek-tag ( lexer -- tag )
stack>> ?last ; stack>> ?last ;
: pop-tag ( lexer -- tag ) : pop-tag ( lexer -- )
stack>> [ f ] [ pop ] if-empty ; stack>> pop drop ;
: with-tag ( lexer tag quot -- )
[ [ push-tag ] dip call ] 3keep 2drop pop-tag ; inline
: roll-back-lexer ( lexer slice -- ) : roll-back-lexer ( lexer slice -- )
from>> >>n drop ; from>> >>n drop ;

39
core/modern/modern.factor
View File

@ -150,6 +150,19 @@ M: array collapse-decorators
drop f drop f
] if ; ] if ;
: top-level-less-than? ( string -- ? )
dup "<" tail? [
dup length 1 > [
[ [ 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: whitespace-expected-after n string ch ;
ERROR: expected-more-tokens n string expected ; ERROR: expected-more-tokens n string expected ;
ERROR: string-expected-got-eof n string ; ERROR: string-expected-got-eof n string ;
@ -260,18 +273,15 @@ ERROR: lex-expected-but-got-eof lexer tags ;
ERROR: unnestable-form n string obj ; ERROR: unnestable-form n string obj ;
! For implementing [ { ( ! For implementing [ { (
: lex-until ( lexer tags -- payload closing ) : lex-until ( lexer tags -- payload closing )
! over lexer-found-eof? [ "more tokens expected" throw ] when
'[ '[
[ [
_ lex-factor [ _ lex-factor [
dup tag-literal? [ dup tag-literal? [
dup , dup ,
underlying>> ! { [ dup top-level-name? ] [ 4 npick 0 > ] } 0&& [ unnestable-form ] when underlying>> _ [ sequence= ] with any? not
_ [ sequence= ] with any? not
] [ , t ] if ] [ , t ] if
] [ ] [
f , f f , f
! _ _ over lexer-eof? [ lex-expected-but-got-eof ] [ 2drop f , f ] if
] if* ] if*
] loop ] loop
] { } make unclip-last ; inline ] { } make unclip-last ; inline
@ -324,16 +334,14 @@ 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/f ) : read-upper-colon ( lexer string' -- obj/f )
! 4 npick 0 > [ cannot-nest-upper-colon ] when
over peek-tag top-level-colon? [ over peek-tag top-level-colon? [
! roll back, nested upper
roll-back-lexer f roll-back-lexer f
] [ ] [
2dup push-tag [ 2dup [
dup [ dup [
[ but-last ";" append ";" 2array ] [ ";" 1array ] if* lex-until [ 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 ] with-tag
] if ; ] if ;
: read-lower-colon ( lexer string' -- obj ) : read-lower-colon ( lexer string' -- obj )
@ -352,10 +360,19 @@ ERROR: cannot-nest-upper-colon n string string' ;
} cond ; } cond ;
ERROR: closing-tag-required lexer tag ;
: read-upper-less-than ( lexer slice -- less-than ) :: read-upper-less-than ( lexer slice -- less-than/f )
dup [ scoped-less-than-name [ but-last ">" append 1array ] [ ">" 1array ] if* lex-until ] dip lexer peek-tag top-level-less-than? [
1 cut-slice* less-than-literal make-matched-literal ; lexer slice roll-back-lexer f
] [
lexer slice [
lexer slice scoped-less-than-name
[ but-last ">" append 1array ] [ ">" 1array ] if* lex-until
dup [ lexer slice >string closing-tag-required ] unless
slice 1 cut-slice* less-than-literal make-matched-literal
] with-tag
] if ;
: read-less-than ( lexer slice -- less-than ) : read-less-than ( lexer slice -- less-than )
dupd merge-lex-til-whitespace { dupd merge-lex-til-whitespace {