Making xml.dispatch compile

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 ] }

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"
+"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: PROCESS: }
+{ $subsection POSTPONE: TAGS: }
 "and to define a new 'method' for this word, use"
 { $subsection POSTPONE: TAG: } ;
 
-HELP: PROCESS:
+HELP: TAGS:
-{ $syntax "PROCESS: word" }
+{ $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" } }
+{ $values { "tag" "an XML tag name" } { "word" "an XML process" } }
-{ $description "defines what a process should do when it encounters a specific tag" }
+{ $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 "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
+{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
-{ $see-also POSTPONE: PROCESS: } ;
+{ $see-also POSTPONE: TAGS: } ;

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

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 ;
+TUPLE: no-tag name word ;
-M: process-missing summary
+M: no-tag summary
-    drop "Tag not implemented on process" ;
+    drop "The tag-dispatching word has no method for the given tag name" ;
 
-: run-process ( tag word -- )
+: compile-tags ( word xtable -- quot )
-    2dup "xtable" word-prop
+    >alist swap '[ _ no-tag boa throw ] [ ] like suffix
-    [ dup main>> ] dip at* [ 2nip call ] [
+    '[ dup main>> _ case ] ;
-        drop \ process-missing boa throw
-    ] if ;
 
-: 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
+    [ H{ } clone "xtable" set-word-prop ]
-    dup '[ _ run-process ] define ; parsing
+    [ define-tags ] bi ; parsing
 
 : TAG:
-    scan scan-word
+    scan scan-word parse-definition define-tag ; parsing
-    parse-definition
-    swap "xtable" word-prop
-    rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
-    parsing

extra/4DNav/space-file-decoder/space-file-decoder.factor

@@ -8,7 +8,7 @@ IN: 4DNav.space-file-decoder
 : decode-number-array ( x -- y )  
     "," split [ string>number ] map ;
 
-PROCESS: adsoda-read-model ( tag -- )
+TAGS: adsoda-read-model ( tag -- )
 
 TAG: dimension adsoda-read-model 
     children>> first string>number ;