xml: update XML-NS: for define-memoized stack effect change and get all unit tests to pass
parent
4fc2182ac8
commit
5408191724
|
@ -17,8 +17,8 @@ M: no-tag summary
|
|||
>alist swap '[ _ no-tag boa throw ] suffix
|
||||
'[ dup main>> _ case ] ;
|
||||
|
||||
: define-tags ( word -- )
|
||||
dup dup "xtable" word-prop compile-tags define ;
|
||||
: define-tags ( word effect -- )
|
||||
[ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
|
||||
|
||||
:: define-tag ( string word quot -- )
|
||||
quot string word "xtable" word-prop set-at
|
||||
|
@ -27,16 +27,16 @@ M: no-tag summary
|
|||
PRIVATE>
|
||||
|
||||
SYNTAX: TAGS:
|
||||
CREATE
|
||||
[ H{ } clone "xtable" set-word-prop ]
|
||||
[ define-tags ] bi ;
|
||||
CREATE complete-effect
|
||||
[ drop H{ } clone "xtable" set-word-prop ]
|
||||
[ define-tags ]
|
||||
2bi ;
|
||||
|
||||
SYNTAX: TAG:
|
||||
scan scan-word parse-definition define-tag ;
|
||||
|
||||
SYNTAX: XML-NS:
|
||||
CREATE-WORD (( string -- name )) over set-stack-effect
|
||||
scan '[ f swap _ <name> ] define-memoized ;
|
||||
CREATE-WORD scan '[ f swap _ <name> ] (( string -- name )) define-memoized ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
@ -2,8 +2,8 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces fry
|
|||
accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ;
|
||||
IN: xml.tests
|
||||
|
||||
: sub-tag
|
||||
T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" } ;
|
||||
CONSTANT: sub-tag
|
||||
T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" }
|
||||
|
||||
SYMBOL: ref-table
|
||||
|
||||
|
|
|
@ -17,7 +17,7 @@ TUPLE: xml-test id uri sections description type ;
|
|||
: parse-tests ( xml -- tests )
|
||||
"TEST" tags-named [ >xml-test ] map ;
|
||||
|
||||
: base "vocab:xml/tests/xmltest/" ;
|
||||
CONSTANT: base "vocab:xml/tests/xmltest/"
|
||||
|
||||
MACRO: drop-output ( quot -- newquot )
|
||||
dup infer out>> '[ @ _ ndrop ] ;
|
||||
|
|
|
@ -61,7 +61,7 @@ IN: xml.writer.tests
|
|||
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
|
||||
[ "<foo'>" ] [ "<foo'>" <unescaped> xml>string ] unit-test
|
||||
|
||||
: test-file "resource:basis/xml/writer/test.xml" ;
|
||||
CONSTANT: test-file "resource:basis/xml/writer/test.xml"
|
||||
|
||||
[ ] [ "<?xml version='1.0' encoding='UTF-16BE'?><x/>" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test
|
||||
[ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test
|
||||
|
|
Loading…
Reference in New Issue