diff --git a/core/modern/lexer/lexer.factor b/core/modern/lexer/lexer.factor index 50ec68bd3c..55e8cfd77a 100644 --- a/core/modern/lexer/lexer.factor +++ b/core/modern/lexer/lexer.factor @@ -4,7 +4,7 @@ USING: accessors constructors kernel math sequences sequences.extras slots.syntax unicode ; in: modern.lexer -TUPLE: modern-lexer n string stack ; +TUPLE: modern-lexer n string partial stack ; CONSTRUCTOR: modern-lexer ( string -- obj ) 0 >>n V{ } clone >>stack ; inline @@ -58,10 +58,18 @@ ERROR: unexpected-end n string ; ] if ; inline :: lex-til-either ( lexer tokens -- n'/f string' slice/f ch/f ) - lexer >lexer< tokens slice-til-either :> ( n' string' slice ch ) + lexer >lexer< + lexer partial>> :> partial + partial [ + [ 1 - ] dip + f lexer partial<< + ] when + tokens slice-til-either :> ( n' string' slice ch ) lexer n' >>n drop - n' string' slice ch ; + n' string' + slice partial [ merge-slices ] when* + ch ; :: slice-til-separator-inclusive ( n string tokens -- n' string slice/f ch/f ) diff --git a/core/modern/modern-tests.factor b/core/modern/modern-tests.factor index c3b1ca61e2..ae459eaead 100644 --- a/core/modern/modern-tests.factor +++ b/core/modern/modern-tests.factor @@ -108,3 +108,15 @@ in: modern.tests { 1 } [ "HI< OMG: BYE< BYE> HI>" string>literals length ] unit-test { 1 } [ "HI< OMG: ; BYE< BYE> HI>" string>literals length ] unit-test + +{ 1 t "<" } +[ + "<{ ptx-2op-instruction ptx-float-ftz }" string>literals + [ length ] [ first single-matched-literal? ] [ first tag>> ] tri +] unit-test + +{ 1 t "foo<" } +[ + "foo<{ ptx-2op-instruction ptx-float-ftz }" string>literals + [ length ] [ first single-matched-literal? ] [ first tag>> ] tri +] unit-test \ No newline at end of file diff --git a/core/modern/modern.factor b/core/modern/modern.factor index ea24b53f07..ed86108b44 100644 --- a/core/modern/modern.factor +++ b/core/modern/modern.factor @@ -384,9 +384,8 @@ ERROR: closing-tag-required lexer tag ; : read-less-than ( lexer slice -- less-than ) dupd merge-lex-til-whitespace { - { [ dup length 1 = ] [ nip make-tag-literal ] } ! "<" { [ dup "<" tail? ] [ dup top-level-name? [ read-upper-less-than ] [ nip make-tag-literal ] if ] } ! FOO< or foo< - [ nip make-tag-literal ] + [ >>partial lex-factor ] } cond ; diff --git a/core/modern/out/out-tests.factor b/core/modern/out/out-tests.factor index 4f1080a392..550371841a 100644 --- a/core/modern/out/out-tests.factor +++ b/core/modern/out/out-tests.factor @@ -57,3 +57,6 @@ in: modern.out.tests { t } [ "( a: ( quot: ( b -- c ) -- d ) -- e )" [ [ ] rewrite-string ] keep sequence= ] unit-test + +{ t } [ "<{ ptx-2op-instruction ptx-float-ftz }" rewrite-same-string ] unit-test +{ t } [ "foo<{ ptx-2op-instruction ptx-float-ftz }" rewrite-same-string ] unit-test \ No newline at end of file