Making xml.dispatch compile

diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor
index d9028756f2c2af92d4ae3f9b815cf5bfa05ecb6b..304f7400fadcd46b9c81902e66e1291e5e8ec6f1 100644 (file)
--- a/basis/xml-rpc/xml-rpc.factor
+++ b/basis/xml-rpc/xml-rpc.factor
@@ -113,14 +113,18 @@ M: server-error error.
     "Description: " write dup message>> print
     "Tag: " write tag>> xml>string print ;
 
-PROCESS: xml>item ( tag -- object )
+TAGS: xml>item ( tag -- object )
 
 TAG: string xml>item
     children>string ;
 
-TAG: i4/int/double xml>item
+: children>number ( tag -- n )
     children>string string>number ;
 
+TAG: i4 xml>item children>number ;
+TAG: int xml>item children>number ;
+TAG: double xml>item children>number ;
+
 TAG: boolean xml>item
     dup children>string {
         { [ dup "1" = ] [ 2drop t ] }

diff --git a/basis/xml/dispatch/dispatch-docs.factor b/basis/xml/dispatch/dispatch-docs.factor
index 572a75cd05dba35634e821f50a57b1f687931a15..d3d24d736c2e86169b5e16ce76d10a1a47371da5 100644 (file)
--- a/basis/xml/dispatch/dispatch-docs.factor
+++ b/basis/xml/dispatch/dispatch-docs.factor
@@ -6,20 +6,20 @@ IN: xml.dispatch
 ABOUT: "xml.dispatch"
 
 ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
-"Two parsing words define a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
-{ $subsection POSTPONE: PROCESS: }
+"The " { $link "xml.dispatch" } " vocabulary defines a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
+{ $subsection POSTPONE: TAGS: }
 "and to define a new 'method' for this word, use"
 { $subsection POSTPONE: TAG: } ;
 
-HELP: PROCESS:
-{ $syntax "PROCESS: word" }
+HELP: TAGS:
+{ $syntax "TAGS: word" }
 { $values { "word" "a new word to define" } }
-{ $description "creates a new word to process XML tags" }
+{ $description "Creates a new word to which dispatches on XML tag names." }
 { $see-also POSTPONE: TAG: } ;
 
 HELP: TAG:
 { $syntax "TAG: tag word definition... ;" }
-{ $values { "tag" "an xml tag name" } { "word" "an XML process" } }
-{ $description "defines what a process should do when it encounters a specific tag" }
-{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
-{ $see-also POSTPONE: PROCESS: } ;
+{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
+{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." }
+{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
+{ $see-also POSTPONE: TAGS: } ;

diff --git a/basis/xml/dispatch/dispatch-tests.factor b/basis/xml/dispatch/dispatch-tests.factor
index 6f3179bc029e38ba28c8393a478eb2f279f3128e..e76a759291a5d8427fa632931c93c5e4bac1aacf 100644 (file)
--- a/basis/xml/dispatch/dispatch-tests.factor
+++ b/basis/xml/dispatch/dispatch-tests.factor
@@ -4,7 +4,7 @@ USING: xml io kernel math sequences strings xml.utilities
 tools.test math.parser xml.dispatch ;
 IN: xml.dispatch.tests
 
-PROCESS: calculate ( tag -- n )
+TAGS: calculate ( tag -- n )
 
 : calc-2children ( tag -- n n )
     children-tags first2 [ calculate ] dip calculate ;
@@ -29,3 +29,5 @@ TAG: neg calculate
     "<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
     calc-arith
 ] unit-test
+
+\ calc-arith must-infer

diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor
index 23cb43cc4716be9b9a07153172b4788538ba835d..613836aae24cc24a1c4a14fb03a53f1a70325c6b 100644 (file)
--- a/basis/xml/dispatch/dispatch.factor
+++ b/basis/xml/dispatch/dispatch.factor
@@ -1,27 +1,31 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words assocs kernel accessors parser sequences summary
-lexer splitting fry ;
+lexer splitting fry combinators ;
 IN: xml.dispatch
 
-TUPLE: process-missing process tag ;
-M: process-missing summary
-    drop "Tag not implemented on process" ;
+TUPLE: no-tag name word ;
+M: no-tag summary
+    drop "The tag-dispatching word has no method for the given tag name" ;
 
-: run-process ( tag word -- )
-    2dup "xtable" word-prop
-    [ dup main>> ] dip at* [ 2nip call ] [
-        drop \ process-missing boa throw
-    ] if ;
+: compile-tags ( word xtable -- quot )
+    >alist swap '[ _ no-tag boa throw ] [ ] like suffix
+    '[ dup main>> _ case ] ;
 
-: PROCESS:
+: define-tags ( word -- )
+    dup dup "xtable" word-prop compile-tags define ;
+
+: define-tag ( string word quot -- )
+    -rot [ "xtable" word-prop set-at ] [ define-tags ] bi ;
+
+:: define-tag ( string word quot -- )
+    quot string word "xtable" word-prop set-at
+    word define-tags ;
+
+: TAGS:
     CREATE
-    dup H{ } clone "xtable" set-word-prop
-    dup '[ _ run-process ] define ; parsing
+    [ H{ } clone "xtable" set-word-prop ]
+    [ define-tags ] bi ; parsing
 
 : TAG:
-    scan scan-word
-    parse-definition
-    swap "xtable" word-prop
-    rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
-    parsing
+    scan scan-word parse-definition define-tag ; parsing

diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor
index 872ddbcee3701f5c63aaa70684eb8b5035b329b5..bd3915cb365fd8307668c3d07acfef02eaf439d8 100755 (executable)
--- a/extra/4DNav/space-file-decoder/space-file-decoder.factor
+++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor
@@ -8,7 +8,7 @@ IN: 4DNav.space-file-decoder
 : decode-number-array ( x -- y )  \r
     "," split [ string>number ] map ;\r
 \r
-PROCESS: adsoda-read-model ( tag -- )\r
+TAGS: adsoda-read-model ( tag -- )\r
 \r
 TAG: dimension adsoda-read-model \r
     children>> first string>number ;\r