Making xml.dispatch compile

db4
Daniel Ehrenberg 2009-02-04 01:25:48 -06:00
parent 038d86564f
commit babe9bb2fd
5 changed files with 40 additions and 30 deletions

View File

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

View File

@ -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: } ;

View File

@ -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

View File

@ -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

View File

@ -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 ;