diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index d9028756f2..304f7400fa 100644 --- 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 572a75cd05..d3d24d736c 100644 --- 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 6f3179bc02..e76a759291 100644 --- 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 "13-8" calc-arith ] unit-test + +\ calc-arith must-infer diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor index 23cb43cc47..613836aae2 100644 --- 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 872ddbcee3..bd3915cb36 100755 --- 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 ) "," split [ string>number ] map ; -PROCESS: adsoda-read-model ( tag -- ) +TAGS: adsoda-read-model ( tag -- ) TAG: dimension adsoda-read-model children>> first string>number ;