From f8092480a6b1488c397d2c69b616a4342f487c56 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Jan 2009 19:34:31 -0600
Subject: [PATCH] Fix a couple of bugs in xmode and add a unit test

---
 basis/xmode/catalog/catalog.factor           | 36 +++++++++++---------
 basis/xmode/code2html/code2html-tests.factor |  9 ++++-
 basis/xmode/code2html/code2html.factor       |  6 ++--
 basis/xmode/loader/loader.factor             | 16 ++++-----
 basis/xmode/loader/syntax/syntax.factor      | 13 +++----
 basis/xmode/marker/context/context.factor    |  4 +--
 basis/xmode/marker/marker.factor             |  4 +--
 7 files changed, 49 insertions(+), 39 deletions(-)

diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor
index 8a8e5fad4a..4e3af0af56 100644
--- a/basis/xmode/catalog/catalog.factor
+++ b/basis/xmode/catalog/catalog.factor
@@ -52,9 +52,15 @@ SYMBOL: rule-sets
     dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
     dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
 
+DEFER: finalize-rule-set
+
 : resolve-delegate ( rule -- )
-    dup delegate>> dup string?
-    [ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ;
+    dup delegate>> dup string? [
+        get-rule-set
+        dup rule-set? [ "not a rule set" throw ] unless
+        swap rule-sets [ dup finalize-rule-set ] with-variable
+        >>delegate drop
+    ] [ 2drop ] if ;
 
 : each-rule ( rule-set quot -- )
     [ rules>> values concat ] dip each ; inline
@@ -74,26 +80,22 @@ SYMBOL: rule-sets
 : resolve-imports ( ruleset -- )
     dup imports>> [
         get-rule-set swap rule-sets [
-            dup resolve-delegates
-            2dup import-keywords
-            import-rules
+            [ nip resolve-delegates ]
+            [ import-keywords ]
+            [ import-rules ]
+            2tri
         ] with-variable
     ] with each ;
 
 ERROR: mutually-recursive-rulesets ruleset ;
+
 : finalize-rule-set ( ruleset -- )
-    dup finalized?>> {
-        { f [
-            {
-                [ 1 >>finalized? drop ]
-                [ resolve-imports ]
-                [ resolve-delegates ]
-                [ t >>finalized? drop ]
-            } cleave
-        ] }
-        { t [ drop ] }
-        { 1 [ mutually-recursive-rulesets ] }
-    } case ;
+    dup finalized?>> [ drop ] [
+        t >>finalized?
+        [ resolve-imports ]
+        [ resolve-delegates ]
+        bi
+    ] if ;
 
 : finalize-mode ( rulesets -- )
     rule-sets [
diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor
index cd11ba50d0..c0b8a1b560 100644
--- a/basis/xmode/code2html/code2html-tests.factor
+++ b/basis/xmode/code2html/code2html-tests.factor
@@ -1,7 +1,7 @@
 IN: xmode.code2html.tests
 USING: xmode.code2html xmode.catalog
 tools.test multiline splitting memoize
-kernel ;
+kernel io.streams.string xml.writer ;
 
 [ ] [ \ (load-mode) reset-memoized ] unit-test
 
@@ -9,4 +9,11 @@ kernel ;
     <" <style type="text/css" media="screen" >
     *        {margin:0; padding:0; border:0;} ">
     string-lines "html" htmlize-lines drop
+] unit-test
+
+[ ] [
+    "test.c"
+    <" int x = "hi";
+/* a comment */ "> <string-reader> htmlize-stream
+    write-xml
 ] unit-test
\ No newline at end of file
diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor
index 665d334fd2..22ffc04824 100644
--- a/basis/xmode/code2html/code2html.factor
+++ b/basis/xmode/code2html/code2html.factor
@@ -8,14 +8,14 @@ IN: xmode.code2html
         [ str>> ] [ id>> ] bi [
             name>> swap
             [XML <span class=<->><-></span> XML]
-        ] [ ] if*
+        ] when*
     ] map ;
 
 : htmlize-line ( line-context line rules -- line-context' xml )
     tokenize-line htmlize-tokens ;
 
 : htmlize-lines ( lines mode -- xml )
-    [ f ] 2dip load-mode [ htmlize-line ] curry map nip ;
+    [ f ] 2dip load-mode [ htmlize-line "\n" suffix ] curry map nip ;
 
 : default-stylesheet ( -- xml )
     "resource:basis/xmode/code2html/stylesheet.css"
@@ -24,7 +24,7 @@ IN: xmode.code2html
 
 :: htmlize-stream ( path stream -- xml )
     stream lines
-    [ "" ] [ first find-mode path swap htmlize-lines ]
+    [ "" ] [ path over first find-mode htmlize-lines ]
     if-empty :> input
     default-stylesheet :> stylesheet
     <XML <html>
diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor
index 64c4234bd3..b661f4eb3f 100644
--- a/basis/xmode/loader/loader.factor
+++ b/basis/xmode/loader/loader.factor
@@ -43,17 +43,17 @@ RULE: MARK_PREVIOUS mark-previous-rule
     shared-tag-attrs match-type-attr literal-start ;
 
 TAG: KEYWORDS ( rule-set tag -- key value )
-    ignore-case? get <keyword-map>
+    rule-set get ignore-case?>> <keyword-map>
     swap child-tags [ over parse-keyword-tag ] each
     swap (>>keywords) ;
 
 TAGS>
 
 : ?<regexp> ( string/f -- regexp/f )
-    dup [ ignore-case? get <regexp> ] when ;
+    dup [ rule-set get ignore-case?>> <regexp> ] when ;
 
 : (parse-rules-tag) ( tag -- rule-set )
-    <rule-set>
+    <rule-set> dup rule-set set
     {
         { "SET" string>rule-set-name (>>name) }
         { "IGNORE_CASE" string>boolean (>>ignore-case?) }
@@ -65,11 +65,11 @@ TAGS>
     } init-from-tag ;
 
 : parse-rules-tag ( tag -- rule-set )
-    dup (parse-rules-tag) [
-        dup ignore-case?>> ignore-case? [
-            swap child-tags [ parse-rule-tag ] with each
-        ] with-variable
-    ] keep ;
+    [
+        [ (parse-rules-tag) ] [ child-tags ] bi
+        [ parse-rule-tag ] with each
+        rule-set get
+    ] with-scope ;
 
 : merge-rule-set-props ( props rule-set -- )
     [ assoc-union ] change-props drop ;
diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor
index f63191d5f6..b546969a37 100644
--- a/basis/xmode/loader/syntax/syntax.factor
+++ b/basis/xmode/loader/syntax/syntax.factor
@@ -1,13 +1,11 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors xmode.tokens xmode.rules xmode.keyword-map
 xml.data xml.utilities xml assocs kernel combinators sequences
 math.parser namespaces make parser lexer xmode.utilities
-parser-combinators.regexp io.files ;
+parser-combinators.regexp io.files splitting arrays ;
 IN: xmode.loader.syntax
 
-SYMBOL: ignore-case?
-
 ! Rule tag parsing utilities
 : (parse-rule-tag) ( rule-set tag specs class -- )
     new swap init-from-tag swap add-rule ; inline
@@ -44,16 +42,19 @@ SYMBOL: ignore-case?
 
 : parse-literal-matcher ( tag -- matcher )
     dup children>string
-    ignore-case? get <string-matcher>
+    rule-set get ignore-case?>> <string-matcher>
     swap position-attrs <matcher> ;
 
 : parse-regexp-matcher ( tag -- matcher )
-    dup children>string ignore-case? get <regexp>
+    dup children>string rule-set get ignore-case?>> <regexp>
     swap position-attrs <matcher> ;
 
 : shared-tag-attrs ( -- )
     { "TYPE" string>token (>>body-token) } , ; inline
 
+: parse-delegate ( string -- pair )
+    "::" split1 [ rule-set get swap ] unless* 2array ;
+
 : delegate-attr ( -- )
     { "DELEGATE" f (>>delegate) } , ;
 
diff --git a/basis/xmode/marker/context/context.factor b/basis/xmode/marker/context/context.factor
index da20503fcb..cc3b5096e8 100644
--- a/basis/xmode/marker/context/context.factor
+++ b/basis/xmode/marker/context/context.factor
@@ -1,4 +1,4 @@
-USING: accessors kernel ;
+USING: accessors kernel xmode.rules ;
 IN: xmode.marker.context
 
 ! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
@@ -10,7 +10,7 @@ end
 ;
 
 : <line-context> ( ruleset parent -- line-context )
-    over [ "no context" throw ] unless
+    over rule-set? [ "not a rule-set" throw ] unless
     line-context new
         swap >>parent
         swap >>in-rule-set ;
diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor
index cff0af2a98..4fdde60976 100755
--- a/basis/xmode/marker/marker.factor
+++ b/basis/xmode/marker/marker.factor
@@ -157,7 +157,7 @@ M: seq-rule handle-rule-start
     mark-token
     add-remaining-token
     tuck body-token>> next-token,
-    delegate>> [ push-context ] when* ;
+    get-delegate [ push-context ] when* ;
 
 UNION: abstract-span-rule span-rule eol-span-rule ;
 
@@ -168,7 +168,7 @@ M: abstract-span-rule handle-rule-start
     tuck rule-match-token* next-token,
     ! ... end subst ...
     dup context get (>>in-rule)
-    delegate>> push-context ;
+    get-delegate push-context ;
 
 M: span-rule handle-rule-end
     2drop ;