CREATE xs.txt \ Leo Wong 28 March 02003 fyj + \ #>c &entity 2flip >bl ?tag attribute cds comment content dent dents \ dtd eetag etag next pi rtp? set-xbuff snip tag xbuff xpad xs.txt \ xtext \ See jenx.txt \ String words and other tools for reading XML from tools.txt from string.txt from $string.txt \ Markup types 0 CONSTANT tag 1 CONSTANT etag 2 CONSTANT eetag 3 CONSTANT attribute 4 CONSTANT comment 5 CONSTANT cds 6 CONSTANT dtd 7 CONSTANT pi 8 CONSTANT content \ $-words have cell-sized counts 0 VALUE Xbuff \ Address of buffer, including scratch area Xpad : set-Xbuff ( n -- ) ALIGN HERE TO Xbuff 0 , CHARS ALLOT ; : neXt ( -- a ) Xbuff $> ; : Xpad ( -- a ) neXt ALIGNED ; \ Convert control characters to spaces : >bl ( a u -- a u ) 2DUP 0 ?DO DUP C@ BL MAX OVER C! CHAR+ LOOP DROP ; \ Convert hex or decimal digits to char : #>c ( a u -- c ) \ Assume &#ddd; or &#xhhh; BASE @ >R 2 /STRING 1- OVER C@ [CHAR] x = IF 1 /STRING HEX ELSE DECIMAL THEN EVALUATE R> BASE ! ; : 2FLIP ( d1 d2 d3 -- d3 d2 d1 ) 2SWAP 2ROT ; \ this will be changed to < type> | a u 0 : rtp? ( -- ? ) DUP >R 2>R TUCK 2>R - 2R> R@ - 2R> 2FLIP R> 0< 0= ; : snip ( a u c1 c2 -- ) >R >R 2DUP R> SCAN 2DUP R> SCAN 1 /STRING rtp? ; \ Words to decode standard XML entities: <>'"& \ Return: remaining ca1 u1, entity ca2 u2, preceding ca u3, flag : &entity ( ca u -- ca1 u1 ca2 u2 ca u3 ? ) [CHAR] & [CHAR] ; snip ; \ Decode an entity : dent ( a u $ -- ) >R 2DUP S" <" S= IF 2DROP [CHAR] < R> c$+! EXIT THEN 2DUP S" >" S= IF 2DROP [CHAR] > R> c$+! EXIT THEN 2DUP S" '" S= IF 2DROP [CHAR] ' R> c$+! EXIT THEN 2DUP S" "" S= IF 2DROP [CHAR] " R> c$+! EXIT THEN 2DUP S" &" S= IF 2DROP [CHAR] & R> c$+! EXIT THEN OVER 2 S" &#" S= IF #>c R> c$+! EXIT THEN \ Put "other entities" handler here? CR .S TYPE ." is an unknown entity. " R> DROP ABORT ; \ Return decoded version of ca u : dents ( ca u -- ca1 u1 ) Xpad 0 OVER ! >R BEGIN &entity WHILE R@ $+! R@ dent REPEAT R@ $+! 2DROP 2DROP R> @+ ; : Xtext ( -- ca u ) Xbuff @+ dents ; : ?tag ( a u --

id t | a u f ) 2DUP [CHAR] < scan DUP IF OVER S" R 2DUP [CHAR] [ scan DUP IF [CHAR] ] scan ELSE 2DROP 2DUP THEN s" >" ELSE OVER S" " ELSE OVER s" R 2DUP S" ?>" ELSE OVER s" r 2DUP S" ]]>" ELSE tag >R 2DUP S" >" THEN THEN THEN THEN DUP >R SEARCH IF R> /STRING RTP? R> SWAP ELSE 2R> 2DROP 2DROP 2DROP FALSE THEN ELSE 2DROP FALSE THEN ;