: spin swap rot ;
parent
74fb0ed298
commit
e58cbb2cda
|
@ -20,7 +20,7 @@ IN: bit-arrays
|
||||||
|
|
||||||
: (set-bits) ( bit-array n -- )
|
: (set-bits) ( bit-array n -- )
|
||||||
over length bits>cells -rot [
|
over length bits>cells -rot [
|
||||||
swap rot 4 * set-alien-unsigned-4
|
spin 4 * set-alien-unsigned-4
|
||||||
] 2curry each ; inline
|
] 2curry each ; inline
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
|
@ -63,7 +63,7 @@ M: sequence hashcode*
|
||||||
next-power-of-2 swap [ nip clone ] curry map ;
|
next-power-of-2 swap [ nip clone ] curry map ;
|
||||||
|
|
||||||
: distribute-buckets ( assoc initial quot -- buckets )
|
: distribute-buckets ( assoc initial quot -- buckets )
|
||||||
swap rot [ length <buckets> ] keep
|
spin [ length <buckets> ] keep
|
||||||
[ >r 2dup r> dup first roll call (distribute-buckets) ] each
|
[ >r 2dup r> dup first roll call (distribute-buckets) ] each
|
||||||
nip ; inline
|
nip ; inline
|
||||||
|
|
||||||
|
|
|
@ -26,6 +26,7 @@ $nl
|
||||||
{ $subsection swapd }
|
{ $subsection swapd }
|
||||||
{ $subsection rot }
|
{ $subsection rot }
|
||||||
{ $subsection -rot }
|
{ $subsection -rot }
|
||||||
|
{ $subsection spin }
|
||||||
{ $subsection roll }
|
{ $subsection roll }
|
||||||
{ $subsection -roll }
|
{ $subsection -roll }
|
||||||
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
|
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
|
||||||
|
@ -37,7 +38,9 @@ $nl
|
||||||
{ $code
|
{ $code
|
||||||
": foo ( m ? n -- m+n/n )"
|
": foo ( m ? n -- m+n/n )"
|
||||||
" >r [ r> + ] [ drop r> ] if ; ! This is OK"
|
" >r [ r> + ] [ drop r> ] if ; ! This is OK"
|
||||||
} ;
|
}
|
||||||
|
"An alternative to using " { $link >r } " and " { $link r> } " is the following:"
|
||||||
|
{ $subsection dip } ;
|
||||||
|
|
||||||
ARTICLE: "basic-combinators" "Basic combinators"
|
ARTICLE: "basic-combinators" "Basic combinators"
|
||||||
"The following pair of words invoke words and quotations reflectively:"
|
"The following pair of words invoke words and quotations reflectively:"
|
||||||
|
@ -159,6 +162,7 @@ HELP: tuck ( x y -- y x y ) $shuffle ;
|
||||||
HELP: over ( x y -- x y x ) $shuffle ;
|
HELP: over ( x y -- x y x ) $shuffle ;
|
||||||
HELP: pick ( x y z -- x y z x ) $shuffle ;
|
HELP: pick ( x y z -- x y z x ) $shuffle ;
|
||||||
HELP: swap ( x y -- y x ) $shuffle ;
|
HELP: swap ( x y -- y x ) $shuffle ;
|
||||||
|
HELP: spin $shuffle ;
|
||||||
HELP: roll $shuffle ;
|
HELP: roll $shuffle ;
|
||||||
HELP: -roll $shuffle ;
|
HELP: -roll $shuffle ;
|
||||||
|
|
||||||
|
@ -541,6 +545,14 @@ HELP: 3compose
|
||||||
"However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
|
"However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
HELP: dip
|
||||||
|
{ $values { "obj" object } { "quot" quotation } }
|
||||||
|
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
|
||||||
|
{ $notes "The following are equivalent:"
|
||||||
|
{ $code ">r foo bar r>" }
|
||||||
|
{ $code "[ foo bar ] dip" }
|
||||||
|
} ;
|
||||||
|
|
||||||
HELP: while
|
HELP: while
|
||||||
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
|
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
|
||||||
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
|
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
|
||||||
|
|
|
@ -6,6 +6,8 @@ IN: kernel
|
||||||
: version ( -- str ) "0.92" ; foldable
|
: version ( -- str ) "0.92" ; foldable
|
||||||
|
|
||||||
! Stack stuff
|
! Stack stuff
|
||||||
|
: spin ( x y z -- z y x ) swap rot ; inline
|
||||||
|
|
||||||
: roll ( x y z t -- y z t x ) >r rot r> swap ; inline
|
: roll ( x y z t -- y z t x ) >r rot r> swap ; inline
|
||||||
|
|
||||||
: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
|
: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
|
||||||
|
@ -49,7 +51,7 @@ DEFER: if
|
||||||
|
|
||||||
: 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline
|
: 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline
|
||||||
|
|
||||||
: dip ( obj callable -- obj ) swap slip ; inline
|
: dip ( obj quot -- obj ) swap slip ; inline
|
||||||
|
|
||||||
: keep ( x quot -- x ) over slip ; inline
|
: keep ( x quot -- x ) over slip ; inline
|
||||||
|
|
||||||
|
|
|
@ -115,7 +115,7 @@ INSTANCE: integer immutable-sequence
|
||||||
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
|
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
|
||||||
>r >r set-nth-unsafe r> r> set-nth-unsafe ; inline
|
>r >r set-nth-unsafe r> r> set-nth-unsafe ; inline
|
||||||
|
|
||||||
: (head) ( seq n -- from to seq ) 0 swap rot ; inline
|
: (head) ( seq n -- from to seq ) 0 spin ; inline
|
||||||
|
|
||||||
: (tail) ( seq n -- from to seq ) over length rot ; inline
|
: (tail) ( seq n -- from to seq ) over length rot ; inline
|
||||||
|
|
||||||
|
@ -270,7 +270,7 @@ PRIVATE>
|
||||||
: tail* ( seq n -- tailseq ) from-end tail ;
|
: tail* ( seq n -- tailseq ) from-end tail ;
|
||||||
|
|
||||||
: copy ( src i dst -- )
|
: copy ( src i dst -- )
|
||||||
pick length >r 3dup check-copy swap rot 0 r>
|
pick length >r 3dup check-copy spin 0 r>
|
||||||
(copy) drop ; inline
|
(copy) drop ; inline
|
||||||
|
|
||||||
M: sequence clone-like
|
M: sequence clone-like
|
||||||
|
@ -579,7 +579,7 @@ M: sequence <=>
|
||||||
|
|
||||||
: join ( seq glue -- newseq )
|
: join ( seq glue -- newseq )
|
||||||
[
|
[
|
||||||
2dup joined-length over new-resizable -rot swap
|
2dup joined-length over new-resizable spin
|
||||||
[ dup pick push-all ] [ pick push-all ] interleave drop
|
[ dup pick push-all ] [ pick push-all ] interleave drop
|
||||||
] keep like ;
|
] keep like ;
|
||||||
|
|
||||||
|
|
|
@ -94,8 +94,6 @@ M: compound redefined* ( word -- )
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: changed-word ( word -- ) dup changed-words get set-at ;
|
|
||||||
|
|
||||||
: define ( word def -- )
|
: define ( word def -- )
|
||||||
over unxref
|
over unxref
|
||||||
over redefined
|
over redefined
|
||||||
|
|
|
@ -24,7 +24,7 @@ IN: cocoa.pasteboard
|
||||||
|
|
||||||
: pasteboard-error ( error -- f )
|
: pasteboard-error ( error -- f )
|
||||||
"Pasteboard does not hold a string" <NSString>
|
"Pasteboard does not hold a string" <NSString>
|
||||||
0 swap rot set-void*-nth f ;
|
0 spin set-void*-nth f ;
|
||||||
|
|
||||||
: ?pasteboard-string ( pboard error -- str/f )
|
: ?pasteboard-string ( pboard error -- str/f )
|
||||||
over pasteboard-string? [
|
over pasteboard-string? [
|
||||||
|
|
|
@ -120,7 +120,7 @@ MACRO: ifte ( quot quot quot -- )
|
||||||
|
|
||||||
: preserving ( predicate -- quot )
|
: preserving ( predicate -- quot )
|
||||||
dup infer effect-in
|
dup infer effect-in
|
||||||
dup 1+ swap rot
|
dup 1+ spin
|
||||||
[ , , nkeep , nrot ]
|
[ , , nkeep , nrot ]
|
||||||
bake ;
|
bake ;
|
||||||
|
|
||||||
|
|
|
@ -27,9 +27,6 @@ M: tuple-class group-words
|
||||||
dup [ slot-spec-reader ] map
|
dup [ slot-spec-reader ] map
|
||||||
swap [ slot-spec-writer ] map append ;
|
swap [ slot-spec-writer ] map append ;
|
||||||
|
|
||||||
: spin ( x y z -- z y x )
|
|
||||||
swap rot ;
|
|
||||||
|
|
||||||
: define-consult-method ( word class quot -- )
|
: define-consult-method ( word class quot -- )
|
||||||
pick add <method> spin define-method ;
|
pick add <method> spin define-method ;
|
||||||
|
|
||||||
|
|
|
@ -9,7 +9,7 @@ IN: hashtables.lib
|
||||||
|
|
||||||
! set-hash with alternative stack effects
|
! set-hash with alternative stack effects
|
||||||
|
|
||||||
: put-hash* ( table key value -- ) swap rot set-at ;
|
: put-hash* ( table key value -- ) spin set-at ;
|
||||||
|
|
||||||
: put-hash ( table key value -- table ) swap pick set-at ;
|
: put-hash ( table key value -- table ) swap pick set-at ;
|
||||||
|
|
||||||
|
|
|
@ -89,7 +89,7 @@ TUPLE: segment number color radius ;
|
||||||
rot dup length swap <slice> find-nearest-segment ;
|
rot dup length swap <slice> find-nearest-segment ;
|
||||||
|
|
||||||
: nearest-segment-backward ( segments oint start -- segment )
|
: nearest-segment-backward ( segments oint start -- segment )
|
||||||
swapd 1+ 0 swap rot <slice> <reversed> find-nearest-segment ;
|
swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
|
||||||
|
|
||||||
: nearest-segment ( segments oint start-segment -- segment )
|
: nearest-segment ( segments oint start-segment -- segment )
|
||||||
#! find the segment nearest to 'oint', and return it.
|
#! find the segment nearest to 'oint', and return it.
|
||||||
|
|
|
@ -199,7 +199,7 @@ DEFER: (d)
|
||||||
: bigraded-ker/im-d ( bigraded-basis -- seq )
|
: bigraded-ker/im-d ( bigraded-basis -- seq )
|
||||||
dup length [
|
dup length [
|
||||||
over first length [
|
over first length [
|
||||||
>r 2dup r> swap rot (bigraded-ker/im-d)
|
>r 2dup r> spin (bigraded-ker/im-d)
|
||||||
] map 2nip
|
] map 2nip
|
||||||
] curry* map ;
|
] curry* map ;
|
||||||
|
|
||||||
|
@ -277,7 +277,7 @@ DEFER: (d)
|
||||||
: bigraded-triples ( grid -- triples )
|
: bigraded-triples ( grid -- triples )
|
||||||
dup length [
|
dup length [
|
||||||
over first length [
|
over first length [
|
||||||
>r 2dup r> swap rot bigraded-triple
|
>r 2dup r> spin bigraded-triple
|
||||||
] map 2nip
|
] map 2nip
|
||||||
] curry* map ;
|
] curry* map ;
|
||||||
|
|
||||||
|
|
|
@ -84,7 +84,7 @@ SYMBOL: matrix
|
||||||
: basis-vector ( row col# -- )
|
: basis-vector ( row col# -- )
|
||||||
>r clone r>
|
>r clone r>
|
||||||
[ swap nth neg recip ] 2keep
|
[ swap nth neg recip ] 2keep
|
||||||
[ 0 swap rot set-nth ] 2keep
|
[ 0 spin set-nth ] 2keep
|
||||||
>r n*v r>
|
>r n*v r>
|
||||||
matrix get set-nth ;
|
matrix get set-nth ;
|
||||||
|
|
||||||
|
|
|
@ -79,6 +79,6 @@ SYMBOL: plchoice
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: binding-resolve ( binds name pat -- binds )
|
: binding-resolve ( binds name pat -- binds )
|
||||||
tuck lookup-rule dup backtrace? swap rot add-bindings ;
|
tuck lookup-rule dup backtrace? spin add-bindings ;
|
||||||
|
|
||||||
: is ( binds val var -- binds ) rot [ set-at ] keep ;
|
: is ( binds val var -- binds ) rot [ set-at ] keep ;
|
||||||
|
|
|
@ -293,7 +293,7 @@ M: invaders-gadget draw-gadget* ( gadget -- )
|
||||||
|
|
||||||
: plot-bitmap-pixel ( bitmap point color -- )
|
: plot-bitmap-pixel ( bitmap point color -- )
|
||||||
#! point is a {x y}. color is a {r g b}.
|
#! point is a {x y}. color is a {r g b}.
|
||||||
swap rot set-bitmap-pixel ;
|
spin set-bitmap-pixel ;
|
||||||
|
|
||||||
: within ( n a b -- bool )
|
: within ( n a b -- bool )
|
||||||
#! n >= a and n <= b
|
#! n >= a and n <= b
|
||||||
|
|
|
@ -14,8 +14,8 @@ SYMBOL: grid-dim
|
||||||
|
|
||||||
: grid-line-from/to ( orientation point -- from to )
|
: grid-line-from/to ( orientation point -- from to )
|
||||||
half-gap v-
|
half-gap v-
|
||||||
[ half-gap swap rot set-axis ] 2keep
|
[ half-gap spin set-axis ] 2keep
|
||||||
grid-dim get swap rot set-axis ;
|
grid-dim get spin set-axis ;
|
||||||
|
|
||||||
: draw-grid-lines ( gaps orientation -- )
|
: draw-grid-lines ( gaps orientation -- )
|
||||||
grid get rot grid-positions grid get rect-dim add [
|
grid get rot grid-positions grid get rect-dim add [
|
||||||
|
|
|
@ -100,7 +100,7 @@ IN: unicode
|
||||||
[ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
|
[ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
|
||||||
|
|
||||||
: replace ( seq old new -- newseq )
|
: replace ( seq old new -- newseq )
|
||||||
swap rot [ 2dup = [ drop over ] when ] map 2nip ;
|
spin [ 2dup = [ drop over ] when ] map 2nip ;
|
||||||
|
|
||||||
: process-names ( data -- names-hash )
|
: process-names ( data -- names-hash )
|
||||||
1 swap (process-data)
|
1 swap (process-data)
|
||||||
|
@ -382,7 +382,7 @@ SYMBOL: locale ! Just casing locale, or overall?
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: insert ( seq quot elt n -- )
|
: insert ( seq quot elt n -- )
|
||||||
swap rot >r -rot [ swap set-nth ] 2keep r> (insert) ; inline
|
spin >r -rot [ swap set-nth ] 2keep r> (insert) ; inline
|
||||||
|
|
||||||
: insertion-sort ( seq quot -- )
|
: insertion-sort ( seq quot -- )
|
||||||
! quot is a transformation on elements
|
! quot is a transformation on elements
|
||||||
|
|
|
@ -69,7 +69,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
|
||||||
: d-sq ( d -- d ) dup d* ;
|
: d-sq ( d -- d ) dup d* ;
|
||||||
|
|
||||||
: d-recip ( d -- d' )
|
: d-recip ( d -- d' )
|
||||||
>dimensioned< swap rot recip dimension-op> ;
|
>dimensioned< spin recip dimension-op> ;
|
||||||
|
|
||||||
: d/ ( d d -- d ) d-recip d* ;
|
: d/ ( d d -- d ) d-recip d* ;
|
||||||
|
|
||||||
|
|
|
@ -74,7 +74,7 @@ dup XKeyEvent-state swap event>keyname 2array ;
|
||||||
[ $keymap swap resolve-key-event call ]
|
[ $keymap swap resolve-key-event call ]
|
||||||
|
|
||||||
"grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [
|
"grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [
|
||||||
3dup name>keysym keysym-to-keycode swap rot
|
3dup name>keysym keysym-to-keycode spin
|
||||||
False GrabModeAsync GrabModeAsync grab-key ]
|
False GrabModeAsync GrabModeAsync grab-key ]
|
||||||
|
|
||||||
"set-key-action" !( wm-root modifiers keyname action -- wm-root ) [
|
"set-key-action" !( wm-root modifiers keyname action -- wm-root ) [
|
||||||
|
|
|
@ -1,140 +1,140 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel namespaces sequences words io assocs
|
USING: kernel namespaces sequences words io assocs
|
||||||
quotations strings parser arrays xml.data xml.writer debugger
|
quotations strings parser arrays xml.data xml.writer debugger
|
||||||
splitting ;
|
splitting ;
|
||||||
IN: xml.utilities
|
IN: xml.utilities
|
||||||
|
|
||||||
! * System for words specialized on tag names
|
! * System for words specialized on tag names
|
||||||
|
|
||||||
TUPLE: process-missing process tag ;
|
TUPLE: process-missing process tag ;
|
||||||
M: process-missing error.
|
M: process-missing error.
|
||||||
"Tag <" write
|
"Tag <" write
|
||||||
dup process-missing-tag print-name
|
dup process-missing-tag print-name
|
||||||
"> not implemented on process process " write
|
"> not implemented on process process " write
|
||||||
process-missing-process word-name print ;
|
process-missing-process word-name print ;
|
||||||
|
|
||||||
: run-process ( tag word -- )
|
: run-process ( tag word -- )
|
||||||
2dup "xtable" word-prop
|
2dup "xtable" word-prop
|
||||||
>r dup name-tag r> at* [ 2nip call ] [
|
>r dup name-tag r> at* [ 2nip call ] [
|
||||||
drop \ process-missing construct-boa throw
|
drop \ process-missing construct-boa throw
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: PROCESS:
|
: PROCESS:
|
||||||
CREATE
|
CREATE
|
||||||
dup H{ } clone "xtable" set-word-prop
|
dup H{ } clone "xtable" set-word-prop
|
||||||
dup [ run-process ] curry define-compound ; parsing
|
dup [ run-process ] curry define-compound ; parsing
|
||||||
|
|
||||||
: TAG:
|
: TAG:
|
||||||
scan scan-word
|
scan scan-word
|
||||||
parse-definition
|
parse-definition
|
||||||
swap "xtable" word-prop
|
swap "xtable" word-prop
|
||||||
rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;
|
rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;
|
||||||
parsing
|
parsing
|
||||||
|
|
||||||
|
|
||||||
! * Common utility functions
|
! * Common utility functions
|
||||||
|
|
||||||
: build-tag* ( items name -- tag )
|
: build-tag* ( items name -- tag )
|
||||||
"" swap "" <name>
|
"" swap "" <name>
|
||||||
swap >r { } r> <tag> ;
|
swap >r { } r> <tag> ;
|
||||||
|
|
||||||
: build-tag ( item name -- tag )
|
: build-tag ( item name -- tag )
|
||||||
>r 1array r> build-tag* ;
|
>r 1array r> build-tag* ;
|
||||||
|
|
||||||
: build-xml ( tag -- xml )
|
: build-xml ( tag -- xml )
|
||||||
T{ prolog f "1.0" "iso-8859-1" f } { } rot { } <xml> ;
|
T{ prolog f "1.0" "iso-8859-1" f } { } rot { } <xml> ;
|
||||||
|
|
||||||
: children>string ( tag -- string )
|
: children>string ( tag -- string )
|
||||||
tag-children
|
tag-children
|
||||||
dup [ string? ] all?
|
dup [ string? ] all?
|
||||||
[ "XML tag unexpectedly contains non-text children" throw ] unless
|
[ "XML tag unexpectedly contains non-text children" throw ] unless
|
||||||
concat ;
|
concat ;
|
||||||
|
|
||||||
: children-tags ( tag -- sequence )
|
: children-tags ( tag -- sequence )
|
||||||
tag-children [ tag? ] subset ;
|
tag-children [ tag? ] subset ;
|
||||||
|
|
||||||
: first-child-tag ( tag -- tag )
|
: first-child-tag ( tag -- tag )
|
||||||
tag-children [ tag? ] find nip ;
|
tag-children [ tag? ] find nip ;
|
||||||
|
|
||||||
! * Utilities for searching through XML documents
|
! * Utilities for searching through XML documents
|
||||||
! These all work from the outside in, top to bottom.
|
! These all work from the outside in, top to bottom.
|
||||||
|
|
||||||
: with-delegate ( object quot -- object )
|
: with-delegate ( object quot -- object )
|
||||||
over clone >r >r delegate r> call r>
|
over clone >r >r delegate r> call r>
|
||||||
[ set-delegate ] keep ; inline
|
[ set-delegate ] keep ; inline
|
||||||
|
|
||||||
GENERIC# xml-each 1 ( quot tag -- ) inline
|
GENERIC# xml-each 1 ( quot tag -- ) inline
|
||||||
M: tag xml-each
|
M: tag xml-each
|
||||||
[ call ] 2keep
|
[ call ] 2keep
|
||||||
swap tag-children [ swap xml-each ] curry* each ;
|
swap tag-children [ swap xml-each ] curry* each ;
|
||||||
M: object xml-each
|
M: object xml-each
|
||||||
call ;
|
call ;
|
||||||
M: xml xml-each
|
M: xml xml-each
|
||||||
>r delegate r> xml-each ;
|
>r delegate r> xml-each ;
|
||||||
|
|
||||||
GENERIC# xml-map 1 ( quot tag -- tag ) inline
|
GENERIC# xml-map 1 ( quot tag -- tag ) inline
|
||||||
M: tag xml-map
|
M: tag xml-map
|
||||||
swap clone over >r swap call r>
|
swap clone over >r swap call r>
|
||||||
swap [ tag-children [ swap xml-map ] curry* map ] keep
|
swap [ tag-children [ swap xml-map ] curry* map ] keep
|
||||||
[ set-tag-children ] keep ;
|
[ set-tag-children ] keep ;
|
||||||
M: object xml-map
|
M: object xml-map
|
||||||
call ;
|
call ;
|
||||||
M: xml xml-map
|
M: xml xml-map
|
||||||
swap [ swap xml-map ] with-delegate ;
|
swap [ swap xml-map ] with-delegate ;
|
||||||
|
|
||||||
: xml-subset ( quot tag -- seq ) ! quot: tag -- ?
|
: xml-subset ( quot tag -- seq ) ! quot: tag -- ?
|
||||||
V{ } clone rot [
|
V{ } clone rot [
|
||||||
swap >r [ swap call ] 2keep rot r>
|
swap >r [ swap call ] 2keep rot r>
|
||||||
swap [ [ push ] keep ] [ nip ] if
|
swap [ [ push ] keep ] [ nip ] if
|
||||||
] xml-each nip ;
|
] xml-each nip ;
|
||||||
|
|
||||||
GENERIC# xml-find 1 ( quot tag -- tag ) inline
|
GENERIC# xml-find 1 ( quot tag -- tag ) inline
|
||||||
M: tag xml-find
|
M: tag xml-find
|
||||||
[ call ] 2keep swap rot [
|
[ call ] 2keep spin [
|
||||||
f swap
|
f swap
|
||||||
[ nip over >r swap xml-find r> swap dup ] find
|
[ nip over >r swap xml-find r> swap dup ] find
|
||||||
2drop ! leaves result of quot
|
2drop ! leaves result of quot
|
||||||
] unless nip ;
|
] unless nip ;
|
||||||
M: object xml-find
|
M: object xml-find
|
||||||
keep f ? ;
|
keep f ? ;
|
||||||
M: xml xml-find
|
M: xml xml-find
|
||||||
>r delegate r> xml-find ;
|
>r delegate r> xml-find ;
|
||||||
|
|
||||||
GENERIC# xml-inject 1 ( quot tag -- ) inline
|
GENERIC# xml-inject 1 ( quot tag -- ) inline
|
||||||
M: tag xml-inject
|
M: tag xml-inject
|
||||||
swap [
|
swap [
|
||||||
swap [ call ] keep
|
swap [ call ] keep
|
||||||
[ xml-inject ] keep
|
[ xml-inject ] keep
|
||||||
] change-each ;
|
] change-each ;
|
||||||
M: object xml-inject 2drop ;
|
M: object xml-inject 2drop ;
|
||||||
M: xml xml-inject >r delegate >r xml-inject ;
|
M: xml xml-inject >r delegate >r xml-inject ;
|
||||||
|
|
||||||
! * Accessing part of an XML document
|
! * Accessing part of an XML document
|
||||||
|
|
||||||
: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
|
: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
|
||||||
swap [
|
swap [
|
||||||
dup tag?
|
dup tag?
|
||||||
[ "id" swap at over = ]
|
[ "id" swap at over = ]
|
||||||
[ drop f ] if
|
[ drop f ] if
|
||||||
] xml-find nip ;
|
] xml-find nip ;
|
||||||
|
|
||||||
: (get-tag) ( name elem -- ? )
|
: (get-tag) ( name elem -- ? )
|
||||||
dup tag? [ names-match? ] [ 2drop f ] if ;
|
dup tag? [ names-match? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: tag-named* ( tag name/string -- matching-tag )
|
: tag-named* ( tag name/string -- matching-tag )
|
||||||
assure-name swap [ dupd (get-tag) ] xml-find nip ;
|
assure-name swap [ dupd (get-tag) ] xml-find nip ;
|
||||||
|
|
||||||
: tags-named* ( tag name/string -- tags-seq )
|
: tags-named* ( tag name/string -- tags-seq )
|
||||||
assure-name swap [ dupd (get-tag) ] xml-subset nip ;
|
assure-name swap [ dupd (get-tag) ] xml-subset nip ;
|
||||||
|
|
||||||
: tag-named ( tag name/string -- matching-tag )
|
: tag-named ( tag name/string -- matching-tag )
|
||||||
! like get-name-tag but only looks at direct children,
|
! like get-name-tag but only looks at direct children,
|
||||||
! not all the children down the tree.
|
! not all the children down the tree.
|
||||||
assure-name swap [ (get-tag) ] curry* find nip ;
|
assure-name swap [ (get-tag) ] curry* find nip ;
|
||||||
|
|
||||||
: tags-named ( tag name/string -- tags-seq )
|
: tags-named ( tag name/string -- tags-seq )
|
||||||
assure-name swap [ (get-tag) ] curry* subset ;
|
assure-name swap [ (get-tag) ] curry* subset ;
|
||||||
|
|
||||||
: assert-tag ( name name -- )
|
: assert-tag ( name name -- )
|
||||||
names-match? [ "Unexpected XML tag found" throw ] unless ;
|
names-match? [ "Unexpected XML tag found" throw ] unless ;
|
||||||
|
|
Loading…
Reference in New Issue