modern: add a partial slot to lexer to be able to deal with <{ } forms. lexer has to recursively call itself and merge the slices.

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> 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 )

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

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 ;
 
 

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