From de823c48eacd3e1aac7509c8a74faf81d1213d5a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 13 Jun 2016 10:34:51 -0700
Subject: [PATCH] modern: working on CHAR: a

---
 core/modern/modern.factor  | 38 ++++++++++++++++++--------------------
 core/modern/out/out.factor |  4 ++--
 2 files changed, 20 insertions(+), 22 deletions(-)

diff --git a/core/modern/modern.factor b/core/modern/modern.factor
index d1ae749b02..9f2e69e4ff 100644
--- a/core/modern/modern.factor
+++ b/core/modern/modern.factor
@@ -181,7 +181,7 @@ ERROR: mismatched-closing opening closing ;
             !    tag opening-delimiter append
             !    matching-delimiter-string closing tag>> sequence= [ opening-delimiter closing tag>> mismatched-closing ] unless
             ! ] when
-            closing tag>> >>closing-tag
+            closing dup [ tag>> ] when >>closing-tag
         ] when
         tag opening-delimiter payload closing 4array >>seq ; inline
 
@@ -261,15 +261,25 @@ ERROR: unnestable-form n string obj ;
         ] loop
     ] { } make unclip-last ; inline
 
+
 : lex-until-top ( n string tags -- n' string payload closing )
-    3 npick [ lex-expected-but-got-eof ] unless
-    3dup '[
+    '[
         [
-            lex-factor
-            [ _ _ _ lex-expected-but-got-eof ] unless*
-            dup , dup tag-literal? [ underlying>> _ [ sequence= ] with any? not ] [ drop t ] if
+            lex-factor [
+                dup tag-literal? [
+                    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
-    ] { } 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:
 : read-colon ( n string slice -- n string colon )
-B
     merge-slice-til-whitespace {
         { [ dup length 1 = ] [ read-upper-colon ] }
         { [ 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( ... )
         [ make-tag-literal ]
     } cond ;
@@ -420,18 +429,7 @@ PRIVATE>
         [ make-tag-literal ]
     } 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 )
     [ delimiter>> ] "" map-as ;
 
diff --git a/core/modern/out/out.factor b/core/modern/out/out.factor
index 3b3ea6b710..558fb5a44c 100644
--- a/core/modern/out/out.factor
+++ b/core/modern/out/out.factor
@@ -99,8 +99,8 @@ M: uppercase-colon-literal write-literal
         [ seq>> 1 swap nth write-whitespace ]
         [ delimiter>> write ]
         [ payload>> [ write-literal ] each ] ! don't need write-whitespace here, the recursion does it
-        [ seq>> 3 swap nth lexed-underlying write-whitespace ]
-        [ closing-tag>> write ]
+        [ seq>> 3 swap nth lexed-underlying [ write-whitespace ] when* ]
+        [ closing-tag>> [ write ] when* ]
     } cleave ;
 
 M: lowercase-colon-literal write-literal