From: Slava Pestov Date: Wed, 5 May 2010 20:52:54 +0000 (-0400) Subject: Language change: tuple slot setter words with stack effect ( value object -- ) are... X-Git-Tag: 0.97~4241^2~1^2~58 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=627295f094d75eada75630abaa092ea574981f3e Language change: tuple slot setter words with stack effect ( value object -- ) are now named FOO<< instead of (>>FOO) --- diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 9f44dec80a..27bd183a2e 100755 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -114,7 +114,7 @@ MACRO: size-case-type ( cases -- ) [ append-dimensions ] bi ; : new-fortran-type ( out? dims size class -- type ) - new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ; + new [ [ size<< ] [ dims<< ] [ out?<< ] tri ] keep ; GENERIC: (fortran-type>c-type) ( type -- c-type ) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index c4e1ec42b2..5581e47056 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -64,7 +64,7 @@ GENERIC: poke ( value n bitstream -- ) [ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline : set-abp ( abp bitstream -- ) - [ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline + [ 8 /mod ] dip [ bit-pos<< ] [ byte-pos<< ] bi ; inline : seek ( n bitstream -- ) [ get-abp + ] [ set-abp ] bi ; inline @@ -117,11 +117,11 @@ M:: lsb0-bit-writer poke ( value n bs -- ) byte bs widthed>> |widthed :> new-byte new-byte #bits>> 8 = [ new-byte bits>> bs bytes>> push - zero-widthed bs (>>widthed) + zero-widthed bs widthed<< remainder widthed>bytes - [ bs bytes>> push-all ] [ bs (>>widthed) ] bi* + [ bs bytes>> push-all ] [ bs widthed<< ] bi* ] [ - byte bs (>>widthed) + byte bs widthed<< ] if ; : enough-bits? ( n bs -- ? ) @@ -146,10 +146,10 @@ ERROR: not-enough-bits n bit-reader ; n 8 /mod :> ( #bytes #bits ) bs [ #bytes + ] change-byte-pos bit-pos>> #bits + dup 8 >= [ - 8 - bs (>>bit-pos) + 8 - bs bit-pos<< bs [ 1 + ] change-byte-pos drop ] [ - bs (>>bit-pos) + bs bit-pos<< ] if ; :: (peek) ( n bs endian> subseq-endian -- bits ) diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index a159e1402b..15c22bea88 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -11,7 +11,7 @@ ERROR: box-full box ; : >box ( value box -- ) dup occupied>> - [ box-full ] [ t >>occupied (>>value) ] if ; inline + [ box-full ] [ t >>occupied value<< ] if ; inline ERROR: box-empty box ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index a2b6d4fd79..63fdb4dee0 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -29,7 +29,7 @@ M: md5 initialize-checksum-state drop ; : update-md5 ( md5 -- ) [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri - [ (>>old-state) ] [ (>>state) ] bi ; + [ old-state<< ] [ state<< ] bi ; CONSTANT: T $[ diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor index ba85add03c..af0f95fa76 100644 --- a/basis/checksums/sha/sha.factor +++ b/basis/checksums/sha/sha.factor @@ -395,7 +395,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) state [ H [ w+ ] 2map ] change-H drop ; inline M:: sha1-state checksum-block ( bytes state -- ) - bytes prepare-sha1-message-schedule state (>>W) + bytes prepare-sha1-message-schedule state W<< bytes state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ; diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 0e1fe47fbb..db60bb1207 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -25,7 +25,7 @@ M: circular virtual-exemplar seq>> ; inline : change-circular-start ( n circular -- ) #! change start to (start + n) mod length - circular-wrap (>>start) ; inline + circular-wrap start<< ; inline : rotate-circular ( circular -- ) [ 1 ] dip change-circular-start ; inline diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 48b2aa5f32..74b4882ffb 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -232,10 +232,10 @@ GENERIC: compute-slot-offset ( offset class -- offset' ) M: struct-slot-spec compute-slot-offset [ type>> over c-type-align-at 8 * align ] keep - [ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ; + [ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ; M: struct-bit-slot-spec compute-slot-offset - [ (>>offset) ] [ bits>> + ] 2bi ; + [ offset<< ] [ bits>> + ] 2bi ; : compute-struct-offsets ( slots -- size ) 0 [ compute-slot-offset ] reduce 8 align 8 /i ; diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor index 60528a61bb..3f98c3711f 100644 --- a/basis/compiler/cfg/block-joining/block-joining.factor +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -21,7 +21,7 @@ IN: compiler.cfg.block-joining [ instructions>> ] bi@ dup pop* push-all ; : update-successors ( bb pred -- ) - [ successors>> ] dip (>>successors) ; + [ successors>> ] dip successors<< ; : join-block ( bb pred -- ) [ join-instructions ] [ update-successors ] 2bi ; diff --git a/basis/compiler/cfg/dependence/dependence.factor b/basis/compiler/cfg/dependence/dependence.factor index 6e07336217..ff9b82208c 100644 --- a/basis/compiler/cfg/dependence/dependence.factor +++ b/basis/compiler/cfg/dependence/dependence.factor @@ -117,7 +117,7 @@ M: object add-control-edge 2drop ; bi v+ supremum ] if-empty node insn>> temp-vregs length + - dup node (>>registers) ; + dup node registers<< ; ! Constructing fan-in trees diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 4d71bbe556..0ebda513a2 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -62,13 +62,13 @@ IN: compiler.cfg.gc-checks >>instructions t >>unlikely? ; :: insert-guard ( body check bb -- ) - bb predecessors>> check (>>predecessors) - V{ bb body } check (>>successors) + bb predecessors>> check predecessors<< + V{ bb body } check successors<< - V{ check } body (>>predecessors) - V{ bb } body (>>successors) + V{ check } body predecessors<< + V{ bb } body successors<< - V{ check body } bb (>>predecessors) + V{ check body } bb predecessors<< check predecessors>> [ bb check update-successors ] each ; diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 19b0f6c5b9..3ab4005359 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -19,13 +19,13 @@ ERROR: bad-live-ranges interval ; : trim-before-ranges ( live-interval -- ) [ ranges>> ] [ last-use n>> 1 + ] bi [ '[ from>> _ <= ] filter! drop ] - [ swap last (>>to) ] + [ swap last to<< ] 2bi ; : trim-after-ranges ( live-interval -- ) [ ranges>> ] [ first-use n>> ] bi [ '[ to>> _ >= ] filter! drop ] - [ swap first (>>from) ] + [ swap first from<< ] 2bi ; : assign-spill ( live-interval -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index b3cba3d90d..d41a06806b 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -51,8 +51,8 @@ ERROR: splitting-atomic-interval ; live-interval n check-split live-interval clone :> before live-interval clone :> after - live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi* - live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi* + live-interval uses>> n split-uses before after [ uses<< ] bi-curry@ bi* + live-interval ranges>> n split-ranges before after [ ranges<< ] bi-curry@ bi* before split-before after split-after ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index cb697c2136..c4b255d12a 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -52,7 +52,7 @@ M: live-interval covers? ( insn# live-interval -- ? ) : shorten-range ( n live-interval -- ) dup ranges>> empty? - [ dupd add-new-range ] [ ranges>> last (>>from) ] if ; + [ dupd add-new-range ] [ ranges>> last from<< ] if ; : extend-range ( from to live-range -- ) ranges>> last diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor index 391edf21d6..e48670ed99 100644 --- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -8,7 +8,7 @@ ERROR: already-numbered insn ; : number-instruction ( n insn -- n' ) [ nip dup insn#>> [ already-numbered ] [ drop ] if ] - [ (>>insn#) ] + [ insn#<< ] [ drop 2 + ] 2tri ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index ae860c52ce..0158c0546c 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -50,9 +50,9 @@ SYMBOL: visited :: insert-basic-block ( from to insns -- ) ! Insert basic block on the edge between 'from' and 'to'. :> bb - insns V{ } like bb (>>instructions) - V{ from } bb (>>predecessors) - V{ to } bb (>>successors) + insns V{ } like bb instructions<< + V{ from } bb predecessors<< + V{ to } bb successors<< from to bb update-predecessors from to bb update-successors ; diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index 4b029fccf2..d55769c17b 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -33,7 +33,7 @@ TUPLE: inline-cache value counter ; : update-inline-cache ( word/quot ic -- ) [ effect-counter ] dip - [ (>>value) ] [ (>>counter) ] bi-curry bi* ; inline + [ value<< ] [ counter<< ] bi-curry bi* ; inline SINGLETON: +unknown+ @@ -74,7 +74,7 @@ M: compose cached-effect : save-effect ( effect quot -- ) [ effect-counter ] dip - [ (>>cached-effect) ] [ (>>cache-counter) ] bi-curry bi* ; + [ cached-effect<< ] [ cache-counter<< ] bi-curry bi* ; M: quotation cached-effect dup cached-effect-valid? diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 4a227cfa77..5375ff6881 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -90,7 +90,7 @@ SYMBOL: history word already-inlined? [ f ] [ #call word splicing-body [ word add-to-history - #call (>>body) + #call body<< #call propagate-body ] [ f ] if* ] if ; diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index 0473e3a3a4..70c4fb44d9 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -44,7 +44,7 @@ GENERIC: node-call-graph ( tail? node -- ) ] with-scope ; M: #return-recursive node-call-graph - nip dup label>> (>>return) ; + nip dup label>> return<< ; M: #call-recursive node-call-graph [ dup label>> call-site boa ] keep diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 0c3db04993..7b5582a0b6 100644 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -35,7 +35,7 @@ TUPLE: huffman-code tdesc [ code next-size - [ code (>>value) code clone quot call code next-code ] each + [ code value<< code clone quot call code next-code ] each ] each ; inline : update-reverse-table ( huffman-code n table -- ) diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor index a1e9b1dc9a..587154fb2f 100644 --- a/basis/core-graphics/types/types.factor +++ b/basis/core-graphics/types/types.factor @@ -53,13 +53,13 @@ STRUCT: CGRect size>> h>> ; inline : set-CGRect-x ( x CGRect -- ) - origin>> (>>x) ; inline + origin>> x<< ; inline : set-CGRect-y ( y CGRect -- ) - origin>> (>>y) ; inline + origin>> y<< ; inline : set-CGRect-w ( w CGRect -- ) - size>> (>>w) ; inline + size>> w<< ; inline : set-CGRect-h ( h CGRect -- ) - size>> (>>h) ; inline + size>> h<< ; inline : ( x y w h -- rect ) [ CGPoint ] [ CGSize ] 2bi* diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor index 0a1e8477e8..5912632513 100644 --- a/basis/cpu/ppc/linux/linux.factor +++ b/basis/cpu/ppc/linux/linux.factor @@ -5,8 +5,8 @@ alien.c-types cpu.architecture cpu.ppc ; IN: cpu.ppc.linux << -t "longlong" c-type (>>stack-align?) -t "ulonglong" c-type (>>stack-align?) +t "longlong" c-type stack-align?<< +t "ulonglong" c-type stack-align?<< >> M: linux reserved-area-size 2 cells ; diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 5c8703116d..5bbd62dfa8 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -112,7 +112,7 @@ SYNTAX: BROADCAST: M: consultation where loc>> ; -M: consultation set-where (>>loc) ; +M: consultation set-where loc<< ; M: consultation forget* [ unconsult-methods ] [ unregister-consult ] bi ; diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 53e134fad9..c4b191360b 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -34,10 +34,10 @@ M: dlist deque-empty? front>> not ; inline M: dlist-node node-value obj>> ; : set-prev-when ( dlist-node dlist-node/f -- ) - [ (>>prev) ] [ drop ] if* ; inline + [ prev<< ] [ drop ] if* ; inline : set-next-when ( dlist-node dlist-node/f -- ) - [ (>>next) ] [ drop ] if* ; inline + [ next<< ] [ drop ] if* ; inline : set-next-prev ( dlist-node -- ) dup next>> set-prev-when ; inline @@ -74,13 +74,13 @@ PRIVATE> M: dlist push-front* ( obj dlist -- dlist-node ) [ front>> f swap dup dup set-next-prev ] keep - [ (>>front) ] keep + [ front<< ] keep set-back-to-front ; M: dlist push-back* ( obj dlist -- dlist-node ) [ back>> f ] keep [ back>> set-next-when ] 2keep - [ (>>back) ] 2keep + [ back<< ] 2keep set-front-to-back ; ERROR: empty-dlist ; diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index f1bc8adef9..2a3e82265b 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -83,7 +83,7 @@ C: ftp-disconnect : handle-USER ( ftp-command -- ) [ - tokenized>> second client get (>>user) + tokenized>> second client get user<< "Please specify the password." 331 server-response ] [ 2drop "bad USER" ftp-error @@ -91,7 +91,7 @@ C: ftp-disconnect : handle-PASS ( ftp-command -- ) [ - tokenized>> second client get (>>password) + tokenized>> second client get password<< "Login successful" 230 server-response ] [ 2drop "PASS error" ftp-error @@ -241,7 +241,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- ) ] if ; : expect-connection ( -- port ) - client get (>>extra-connection) + client get extra-connection<< random-local-server [ [ passive-loop ] curry in-thread ] [ addr>> port>> ] bi ; diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 8a08063595..a187300960 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -143,6 +143,6 @@ CHLOE: button { [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ] - [ [ children>> ] dip "button" deep-tag-named (>>children) ] + [ [ children>> ] dip "button" deep-tag-named children<< ] [ nip ] } 2cleave compile-chloe-tag ; diff --git a/basis/game/input/xinput/xinput.factor b/basis/game/input/xinput/xinput.factor index 32c2cd47bf..800b2c4720 100644 --- a/basis/game/input/xinput/xinput.factor +++ b/basis/game/input/xinput/xinput.factor @@ -56,14 +56,14 @@ MACRO: map-index-compose ( seq quot -- seq ) : fill-controller-state ( XINPUT_STATE -- controller-state ) Gamepad>> controller-state new dup rot { - [ wButtons>> HEX: f bitand >pov swap (>>pov) ] - [ wButtons>> fill-buttons swap (>>buttons) ] - [ sThumbLX>> >axis swap (>>x) ] - [ sThumbLY>> >axis swap (>>y) ] - [ sThumbRX>> >axis swap (>>rx) ] - [ sThumbRY>> >axis swap (>>ry) ] - [ bLeftTrigger>> >trigger swap (>>z) ] - [ bRightTrigger>> >trigger swap (>>rz) ] + [ wButtons>> HEX: f bitand >pov swap pov<< ] + [ wButtons>> fill-buttons swap buttons<< ] + [ sThumbLX>> >axis swap x<< ] + [ sThumbLY>> >axis swap y<< ] + [ sThumbRX>> >axis swap rx<< ] + [ sThumbRY>> >axis swap ry<< ] + [ bLeftTrigger>> >trigger swap z<< ] + [ bRightTrigger>> >trigger swap rz<< ] } 2cleave ; PRIVATE> diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor index 91ee1c9c79..076fa59352 100644 --- a/basis/help/definitions/definitions.factor +++ b/basis/help/definitions/definitions.factor @@ -11,7 +11,7 @@ M: link definer drop \ ARTICLE: \ ; ; M: link where name>> article loc>> ; -M: link set-where name>> article (>>loc) ; +M: link set-where name>> article loc<< ; M: link forget* name>> remove-article ; diff --git a/basis/help/tips/tips.factor b/basis/help/tips/tips.factor index 06f2255dfa..241e54d967 100644 --- a/basis/help/tips/tips.factor +++ b/basis/help/tips/tips.factor @@ -14,7 +14,7 @@ M: tip forget* tips get remove-eq! drop ; M: tip where loc>> ; -M: tip set-where (>>loc) ; +M: tip set-where loc<< ; : ( content -- tip ) f tip boa ; diff --git a/basis/hints/hints-tests.factor b/basis/hints/hints-tests.factor index 894e1dbdc8..fcceab1878 100644 --- a/basis/hints/hints-tests.factor +++ b/basis/hints/hints-tests.factor @@ -9,4 +9,4 @@ M: hashtable blahblah 2nip [ 1 + ] change-count drop ; HINTS: M\ hashtable blahblah { object fixnum object } { object word object } ; -[ t ] [ M\ hashtable blahblah { count>> (>>count) } inlined? ] unit-test +[ t ] [ M\ hashtable blahblah { count>> count<< } inlined? ] unit-test diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index db30faee33..937c73ceb0 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -80,7 +80,7 @@ TUPLE: jpeg-color-info : jpeg> ( -- jpeg-image ) jpeg-image get ; : apply-diff ( dc color -- dc' ) - [ diff>> + dup ] [ (>>diff) ] bi ; + [ diff>> + dup ] [ diff<< ] bi ; : fetch-tables ( component -- ) [ [ jpeg> quant-tables>> nth ] change-quant-table drop ] @@ -98,7 +98,7 @@ TUPLE: jpeg-color-info read1 8 assert= 2 read be> 2 read be> - swap 2array jpeg> (>>dim) + swap 2array jpeg> dim<< read1 [ read1 read4/4 read1 @@ -141,7 +141,7 @@ TUPLE: jpeg-color-info [ drop read1 jpeg> color-info>> nth clone read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi* - ] map jpeg> (>>components) + ] map jpeg> components<< read1 0 assert= read1 63 assert= read1 16 /mod [ 0 assert= ] bi@ @@ -346,7 +346,7 @@ SINGLETONS: YUV420 YUV444 Y MAGIC! ; : baseline-decompress ( -- ) jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append - >byte-array bs: jpeg> (>>bitstream) + >byte-array bs: jpeg> bitstream<< jpeg> [ bitstream>> ] [ [ [ ] with map ] change-huff-tables drop ] bi diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 5cbe7b3ad9..bd59afc26d 100644 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -90,7 +90,7 @@ ERROR: invalid-file-size n ; ERROR: seek-before-start n ; : set-seek-ptr ( n handle -- ) - [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ; + [ dup 0 < [ seek-before-start ] when ] dip ptr<< ; M: winnt tell-handle ( handle -- n ) ptr>> ; diff --git a/basis/io/encodings/iso2022/iso2022.factor b/basis/io/encodings/iso2022/iso2022.factor index 7d4d7f1215..4f092d6282 100644 --- a/basis/io/encodings/iso2022/iso2022.factor +++ b/basis/io/encodings/iso2022/iso2022.factor @@ -56,7 +56,7 @@ M:: iso2022-state encode-char ( char stream encoding -- ) char encoding type>> value? [ char find-type [ stream stream-write ] - [ encoding (>>type) ] bi* + [ encoding type<< ] bi* ] unless char encoding type>> value-at stream stream-write-num ; @@ -92,7 +92,7 @@ M:: iso2022-state decode-char ( stream encoding -- char ) stream stream-read1 { { ESC [ stream read-escape [ - encoding (>>type) + encoding type<< stream encoding decode-char ] [ replacement-char ] if* ] } diff --git a/basis/io/launcher/windows/nt/nt.factor b/basis/io/launcher/windows/nt/nt.factor index 16d9cbf6c9..959bf93119 100644 --- a/basis/io/launcher/windows/nt/nt.factor +++ b/basis/io/launcher/windows/nt/nt.factor @@ -105,6 +105,6 @@ IN: io.launcher.windows.nt M: winnt fill-redirection ( process args -- ) dup lpStartupInfo>> - [ [ redirect-stdout ] dip (>>hStdOutput) ] - [ [ redirect-stderr ] dip (>>hStdError) ] - [ [ redirect-stdin ] dip (>>hStdInput) ] 3tri ; + [ [ redirect-stdout ] dip hStdOutput<< ] + [ [ redirect-stderr ] dip hStdError<< ] + [ [ redirect-stdin ] dip hStdInput<< ] 3tri ; diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor index 731798c424..f3e744a59a 100644 --- a/basis/io/monitors/monitors.factor +++ b/basis/io/monitors/monitors.factor @@ -24,7 +24,7 @@ TUPLE: monitor < disposable path queue timeout ; M: monitor timeout timeout>> ; -M: monitor set-timeout (>>timeout) ; +M: monitor set-timeout timeout<< ; > ; -M: port set-timeout (>>timeout) ; +M: port set-timeout timeout<< ; : ( handle class -- port ) new-disposable swap >>handle ; inline diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index 0f3ac39607..cf1edc0cb1 100644 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -34,7 +34,7 @@ M: win32-socket dispose ( stream -- ) handle>> closesocket drop ; : unspecific-sockaddr/size ( addrspec -- sockaddr len ) - [ empty-sockaddr/size ] [ protocol-family ] bi pick (>>family) ; + [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ; : opened-socket ( handle -- win32-socket ) |dispose dup add-completion ; diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index f5aab9c976..25f1d88363 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -128,9 +128,9 @@ M: limited-stream stream-read-partial :: limited-stream-seek ( n seek-type stream -- ) seek-type { - { seek-absolute [ n stream (>>current) ] } + { seek-absolute [ n stream current<< ] } { seek-relative [ stream [ n + ] change-current drop ] } - { seek-end [ stream stop>> n - stream (>>current) ] } + { seek-end [ stream stop>> n - stream current<< ] } [ bad-seek-type ] } case ; diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index 15f4d5376d..8714bdfb1a 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -58,8 +58,8 @@ M: rect contains-point? [ rect-bounds ] dip vmin ; : set-rect-bounds ( rect1 rect -- ) - [ [ loc>> ] dip (>>loc) ] - [ [ dim>> ] dip (>>dim) ] + [ [ loc>> ] dip loc<< ] + [ [ dim>> ] dip dim<< ] 2bi ; inline USE: vocabs.loader diff --git a/basis/math/vectors/simd/simd-docs.factor b/basis/math/vectors/simd/simd-docs.factor index bcc05564fc..accced4b79 100644 --- a/basis/math/vectors/simd/simd-docs.factor +++ b/basis/math/vectors/simd/simd-docs.factor @@ -138,11 +138,11 @@ GENERIC: advance ( dt object -- ) : update-velocity ( dt actor -- ) [ acceleration>> n*v ] [ velocity>> v+ ] [ ] tri - (>>velocity) ; inline + velocity<< ; inline : update-position ( dt actor -- ) [ velocity>> n*v ] [ position>> v+ ] [ ] tri - (>>position) ; inline + position<< ; inline M: actor advance ( dt actor -- ) [ >float ] dip diff --git a/basis/models/models.factor b/basis/models/models.factor index f9927cfd4c..1b6f0f30c2 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -94,7 +94,7 @@ M: model update-model drop ; ((change-model)) set-model ; inline : (change-model) ( model quot -- ) - ((change-model)) (>>value) ; inline + ((change-model)) value<< ; inline GENERIC: range-value ( model -- value ) GENERIC: range-page-value ( model -- value ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index e50c1d8d95..e0c5350ed1 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -160,7 +160,7 @@ TUPLE: peg-head rule-id involved-set eval-set ; s [ s left-recursion? [ s throw ] unless s head>> l head>> eq? [ - l head>> s (>>head) + l head>> s head<< l head>> [ s rule-id>> suffix ] change-involved-set drop l s next>> (setup-lr) ] unless @@ -168,14 +168,14 @@ TUPLE: peg-head rule-id involved-set eval-set ; :: setup-lr ( r l -- ) l head>> [ - r rule-id V{ } clone V{ } clone peg-head boa l (>>head) + r rule-id V{ } clone V{ } clone peg-head boa l head<< ] unless l lrstack get (setup-lr) ; :: lr-answer ( r p m -- ast ) m ans>> head>> :> h h rule-id>> r rule-id eq? [ - m ans>> seed>> m (>>ans) + m ans>> seed>> m ans<< m ans>> failed? [ fail ] [ @@ -210,14 +210,14 @@ TUPLE: peg-head rule-id involved-set eval-set ; lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m r eval-rule :> ans lrstack get next>> lrstack set - pos get m (>>pos) + pos get m pos<< lr head>> [ m ans>> left-recursion? [ - ans lr (>>seed) + ans lr seed<< r p m lr-answer ] [ ans ] if ] [ - ans m (>>ans) + ans m ans<< ans ] if ; inline @@ -387,7 +387,7 @@ TUPLE: seq-parser parsers ; : calc-seq-result ( prev-result current-result -- next-result ) [ - [ remaining>> swap (>>remaining) ] 2keep + [ remaining>> swap remaining<< ] 2keep ast>> dup ignore? [ drop ] [ @@ -427,7 +427,7 @@ TUPLE: repeat0-parser p1 ; : (repeat) ( quot: ( -- result ) result -- result ) over call [ - [ remaining>> swap (>>remaining) ] 2keep + [ remaining>> swap remaining<< ] 2keep ast>> swap [ ast>> push ] keep (repeat) ] [ diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index cd606667fd..9c23f6017d 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -41,7 +41,7 @@ TUPLE: pprinter last-newline line-count indent ; dup pprinter get last-newline>> = [ drop ] [ - pprinter get (>>last-newline) + pprinter get last-newline<< line-limit? [ "..." write pprinter get return ] when @@ -338,8 +338,8 @@ M: block long-section ( block -- ) : pprinter-manifest ( -- manifest ) - [ [ pprinter-use get keys >vector ] dip (>>search-vocabs) ] - [ [ pprinter-in get ] dip (>>current-vocab) ] + [ [ pprinter-use get keys >vector ] dip search-vocabs<< ] + [ [ pprinter-in get ] dip current-vocab<< ] [ ] tri ; diff --git a/basis/random/sfmt/sfmt.factor b/basis/random/sfmt/sfmt.factor index 04049b542d..7a80cda062 100644 --- a/basis/random/sfmt/sfmt.factor +++ b/basis/random/sfmt/sfmt.factor @@ -60,8 +60,8 @@ GENERIC: generate ( sfmt -- ) M:: sfmt generate ( sfmt -- ) sfmt state>> :> state sfmt uint-4-array>> :> array - state n>> 2 - array nth state (>>r1) - state n>> 1 - array nth state (>>r2) + state n>> 2 - array nth state r1<< + state n>> 1 - array nth state r2<< state m>> :> m state n>> :> n state mask>> :> mask @@ -72,8 +72,8 @@ M:: sfmt generate ( sfmt -- ) mask state r1>> state r2>> formula :> r r i array set-nth-unsafe - state r2>> state (>>r1) - r state (>>r2) + state r2>> state r1<< + r state r2<< ] each ! n m - 1 + n [a,b) [ @@ -84,11 +84,11 @@ M:: sfmt generate ( sfmt -- ) mask state r1>> state r2>> formula :> r r i array set-nth-unsafe - state r2>> state (>>r1) - r state (>>r2) + state r2>> state r1<< + r state r2<< ] each - 0 state (>>index) ; + 0 state index<< ; : period-certified? ( sfmt -- ? ) [ uint-4-array>> first ] diff --git a/basis/refs/refs.factor b/basis/refs/refs.factor index 668cdd65c3..18b749087c 100644 --- a/basis/refs/refs.factor +++ b/basis/refs/refs.factor @@ -30,7 +30,7 @@ M: ref delete-ref ref-off ; TUPLE: obj-ref obj ; C: obj-ref M: obj-ref get-ref obj>> ; -M: obj-ref set-ref (>>obj) ; +M: obj-ref set-ref obj<< ; INSTANCE: obj-ref ref TUPLE: var-ref var ; diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index 416781bdb3..235ff5148f 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -73,7 +73,7 @@ IN: regexp.dfa [ transitions>> keys ] bi* [ intersects? ] with filter fast-set - ] keep (>>final-states) ; + ] keep final-states<< ; : initialize-dfa ( nfa -- dfa ) diff --git a/basis/sequences/parser/parser.factor b/basis/sequences/parser/parser.factor index 322d4cf488..8e1b1f540c 100644 --- a/basis/sequences/parser/parser.factor +++ b/basis/sequences/parser/parser.factor @@ -15,7 +15,7 @@ TUPLE: sequence-parser sequence n ; :: with-sequence-parser ( sequence-parser quot -- seq/f ) sequence-parser n>> :> n sequence-parser quot call [ - n sequence-parser (>>n) f + n sequence-parser n<< f ] unless* ; inline : offset ( sequence-parser offset -- char/f ) @@ -92,7 +92,7 @@ TUPLE: sequence-parser sequence n ; sequence-parser [ growing length - 1 + ] change-n drop ! sequence-parser advance drop ] [ - saved sequence-parser (>>n) + saved sequence-parser n<< f ] if ; diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 35a9ce7787..3cc53cda9d 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -145,7 +145,7 @@ SYMBOL: +stopped+ : associate-thread ( walker -- ) walker-thread tset [ f walker-thread tget send-synchronous drop ] - self (>>exit-handler) ; + self exit-handler<< ; : start-walker-thread ( status continuation -- thread' ) self [ diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index d4f9b82cff..0ce6a8cb08 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -138,7 +138,7 @@ M:: cocoa-ui-backend (open-window) ( world -- ) window world window-loc>> auto-position world window save-position window install-window-delegate - view window world (>>handle) + view window world handle<< window f -> makeKeyAndOrderFront: ; M: cocoa-ui-backend (close-window) ( handle -- ) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index c8fcabf2c6..46bea3e256 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -285,12 +285,12 @@ CONSTANT: window-control>ex-style : handle-wm-size ( hWnd uMsg wParam lParam -- ) 2nip [ lo-word ] keep hi-word 2array - dup { 0 0 } = [ 2drop ] [ swap window [ (>>dim) ] [ drop ] if* ] if ; + dup { 0 0 } = [ 2drop ] [ swap window [ dim<< ] [ drop ] if* ] if ; : handle-wm-move ( hWnd uMsg wParam lParam -- ) 2nip [ lo-word ] keep hi-word 2array - swap window [ (>>window-loc) ] [ drop ] if* ; + swap window [ window-loc<< ] [ drop ] if* ; CONSTANT: wm-keydown-codes H{ @@ -415,7 +415,7 @@ CONSTANT: exclude-keys-wm-char ] unless ; :: set-window-active ( hwnd uMsg wParam lParam ? -- n ) - ? hwnd window (>>active?) + ? hwnd window active?<< hwnd uMsg wParam lParam DefWindowProc ; : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n ) diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 1cb1738007..2f979ee4f1 100644 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -233,7 +233,7 @@ M: x11-ui-backend do-events M: x-clipboard copy-clipboard [ x-clipboard@ own-selection ] keep - (>>contents) ; + contents<< ; M: x-clipboard paste-clipboard [ find-world handle>> window>> ] dip atom>> convert-selection ; diff --git a/basis/ui/clipboards/clipboards.factor b/basis/ui/clipboards/clipboards.factor index 42c3f6ddef..ec7bb59931 100644 --- a/basis/ui/clipboards/clipboards.factor +++ b/basis/ui/clipboards/clipboards.factor @@ -15,7 +15,7 @@ GENERIC: set-clipboard-contents ( string clipboard -- ) M: clipboard clipboard-contents contents>> ; -M: clipboard set-clipboard-contents (>>contents) ; +M: clipboard set-clipboard-contents contents<< ; : ( -- clipboard ) "" clipboard boa ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 3c1ece1f5e..267654304a 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -174,7 +174,7 @@ M: gadget dim-changed PRIVATE> -M: gadget (>>dim) ( dim gadget -- ) +M: gadget dim<< ( dim gadget -- ) 2dup dim>> = [ 2drop ] [ [ nip ] [ call-next-method ] 2bi dim-changed ] if ; @@ -184,7 +184,7 @@ GENERIC: pref-dim* ( gadget -- dim ) : pref-dim ( gadget -- dim ) dup pref-dim>> [ ] [ [ pref-dim* ] [ ] [ layout-state>> ] tri - [ drop ] [ dupd (>>pref-dim) ] if + [ drop ] [ dupd pref-dim<< ] if ] ?if ; : pref-dims ( gadgets -- seq ) [ pref-dim ] map ; diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index c655e289b0..5e91e5bfb7 100644 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -26,14 +26,14 @@ PRIVATE> ERROR: not-a-string object ; -M: label (>>string) ( string label -- ) +M: label string<< ( string label -- ) [ { { [ dup string-array? ] [ ] } { [ dup string? ] [ ?string-lines ] } [ not-a-string ] } cond - ] dip (>>text) ; inline + ] dip text<< ; inline : label-theme ( gadget -- gadget ) sans-serif-font >>font ; inline diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index 5f21d74180..09a0e222d8 100644 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -46,8 +46,8 @@ PRIVATE> : pack-layout ( pack sizes -- ) [ round-dims packed-dims ] [ drop ] 2bi - [ children>> [ (>>dim) ] 2each ] - [ [ packed-locs ] [ children>> ] bi [ (>>loc) ] 2each ] 2bi ; + [ children>> [ dim<< ] 2each ] + [ [ packed-locs ] [ children>> ] bi [ loc<< ] 2each ] 2bi ; : ( orientation -- pack ) pack new diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index bcdccb23cd..cdee1ab02d 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -76,14 +76,14 @@ TUPLE: world-attributes : show-status ( string/f gadget -- ) dup find-world dup [ dup status>> [ - [ (>>status-owner) ] [ status>> set-model ] bi + [ status-owner<< ] [ status>> set-model ] bi ] [ 3drop ] if ] [ 3drop ] if ; : hide-status ( gadget -- ) dup find-world dup [ [ status-owner>> eq? ] keep - '[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when + '[ f _ [ status-owner<< ] [ status>> set-model ] 2bi ] when ] [ 2drop ] if ; : window-resource ( resource -- resource ) @@ -174,7 +174,7 @@ M: world end-world M: world resize-world drop ; -M: world (>>dim) +M: world dim<< [ call-next-method ] [ dup active?>> [ diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index c3e51c39ed..a45c325cc6 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -227,11 +227,11 @@ SYMBOL: drag-timer dup send-lose-focus f swap t focus-child ] when* - dupd (>>focus) [ + dupd focus<< [ send-gain-focus ] when* ] [ - (>>focus) + focus<< ] if ; : modifier ( mod modifiers -- seq ) diff --git a/basis/ui/tools/browser/history/history-tests.factor b/basis/ui/tools/browser/history/history-tests.factor index 454e4700a0..3412d03949 100644 --- a/basis/ui/tools/browser/history/history-tests.factor +++ b/basis/ui/tools/browser/history/history-tests.factor @@ -5,7 +5,7 @@ IN: ui.tools.browser.history.tests TUPLE: dummy obj ; M: dummy history-value obj>> ; -M: dummy set-history-value (>>obj) ; +M: dummy set-history-value obj<< ; dummy new "history" set diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index fbbac8f3fa..94d0b4f263 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -16,7 +16,7 @@ IN: ui.tools.listener.tests [ ] [ "promise" set ] unit-test [ - self "interactor" get (>>thread) + self "interactor" get thread<< "interactor" get stream-read-quot "promise" get fulfill ] "Interactor test" spawn drop @@ -40,7 +40,7 @@ IN: ui.tools.listener.tests [ ] [ "promise" set ] unit-test [ - self "interactor" get (>>thread) + self "interactor" get thread<< "interactor" get stream-readln "promise" get fulfill ] "Interactor test" spawn drop diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index bf32b329ce..bf186ee9a8 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -251,7 +251,7 @@ HOOK: system-alert ui-backend ( caption text -- ) : define-main-window ( word attributes quot -- ) [ '[ [ f _ clone @ open-window ] with-ui ] (( -- )) define-declared - ] [ 2drop current-vocab (>>main) ] 3bi ; + ] [ 2drop current-vocab main<< ] 3bi ; SYNTAX: MAIN-WINDOW: CREATE diff --git a/basis/unrolled-lists/unrolled-lists.factor b/basis/unrolled-lists/unrolled-lists.factor index 9e2c9539c6..a1ec025e45 100644 --- a/basis/unrolled-lists/unrolled-lists.factor +++ b/basis/unrolled-lists/unrolled-lists.factor @@ -47,7 +47,7 @@ M: unrolled-list clear-deque unroll-factor 0 [ unroll-factor 1 - swap set-nth ] keep f ] dip [ node boa dup ] keep - dup [ (>>prev) ] [ 2drop ] if ; inline + dup [ prev<< ] [ 2drop ] if ; inline : normalize-back ( list -- ) dup back>> [ @@ -93,7 +93,7 @@ M: unrolled-list pop-front* [ unroll-factor 0 [ set-first ] keep ] dip [ f node boa dup ] keep - dup [ (>>next) ] [ 2drop ] if ; inline + dup [ next<< ] [ 2drop ] if ; inline : normalize-front ( list -- ) dup front>> [ diff --git a/basis/values/values.factor b/basis/values/values.factor index 4329affe82..61217b1037 100644 --- a/basis/values/values.factor +++ b/basis/values/values.factor @@ -41,7 +41,7 @@ M: value-word definer drop \ VALUE: f ; M: value-word definition drop f ; : set-value ( value word -- ) - def>> first (>>obj) ; + def>> first obj<< ; SYNTAX: to: scan-word literalize suffix! diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 419dfbba53..1ca0979ca3 100644 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -47,7 +47,7 @@ M: attrs set-at 2nip set-second ] [ [ assure-name swap 2array ] dip - [ alist>> ?push ] keep (>>alist) + [ alist>> ?push ] keep alist<< ] if* ; M: attrs assoc-size alist>> length ; diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index 5d0f7f0ea4..e576a672c2 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -11,9 +11,9 @@ TAGS: parse-mode-tag ( modes tag -- ) TAG: MODE parse-mode-tag dup "NAME" attr [ mode new { - { "FILE" f (>>file) } - { "FILE_NAME_GLOB" f (>>file-name-glob) } - { "FIRST_LINE_GLOB" f (>>first-line-glob) } + { "FILE" f file<< } + { "FILE_NAME_GLOB" f file-name-glob<< } + { "FIRST_LINE_GLOB" f first-line-glob<< } } init-from-tag ] dip rot set-at ; @@ -70,7 +70,7 @@ DEFER: finalize-rule-set over [ assoc-union! ] [ nip clone ] if ; : import-keywords ( parent child -- ) - over [ [ keywords>> ] bi@ ?update ] dip (>>keywords) ; + over [ [ keywords>> ] bi@ ?update ] dip keywords<< ; : import-rules ( parent child -- ) swap [ add-rule ] curry each-rule ; diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index e5d5112a27..43fe47a650 100644 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -45,7 +45,7 @@ RULE: MARK_PREVIOUS mark-previous-rule parse-rule-tag TAG: KEYWORDS parse-rule-tag rule-set get ignore-case?>> swap children-tags [ over parse-keyword-tag ] each - swap (>>keywords) ; + swap keywords<< ; : ? ( string/f -- regexp/f ) dup [ rule-set get ignore-case?>> ] when ; @@ -53,13 +53,13 @@ TAG: KEYWORDS parse-rule-tag : (parse-rules-tag) ( tag -- rule-set ) dup rule-set set { - { "SET" string>rule-set-name (>>name) } - { "IGNORE_CASE" string>boolean (>>ignore-case?) } - { "HIGHLIGHT_DIGITS" string>boolean (>>highlight-digits?) } - { "DIGIT_RE" ? (>>digit-re) } + { "SET" string>rule-set-name name<< } + { "IGNORE_CASE" string>boolean ignore-case?<< } + { "HIGHLIGHT_DIGITS" string>boolean highlight-digits?<< } + { "DIGIT_RE" ? digit-re<< } { "ESCAPE" f add-escape-rule } - { "DEFAULT" string>token (>>default) } - { "NO_WORD_SEP" f (>>no-word-sep) } + { "DEFAULT" string>token default<< } + { "NO_WORD_SEP" f no-word-sep<< } } init-from-tag ; : parse-rules-tag ( tag -- rule-set ) diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index d2e1d99721..5f093b0ccb 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -52,24 +52,24 @@ SYNTAX: RULE: swap position-attrs ; : shared-tag-attrs ( -- ) - { "TYPE" string>token (>>body-token) } , ; inline + { "TYPE" string>token body-token<< } , ; inline : parse-delegate ( string -- pair ) "::" split1 [ rule-set get swap ] unless* 2array ; : delegate-attr ( -- ) - { "DELEGATE" f (>>delegate) } , ; + { "DELEGATE" f delegate<< } , ; : regexp-attr ( -- ) - { "HASH_CHAR" f (>>chars) } , ; + { "HASH_CHAR" f chars<< } , ; : match-type-attr ( -- ) - { "MATCH_TYPE" string>match-type (>>match-token) } , ; + { "MATCH_TYPE" string>match-type match-token<< } , ; : span-attrs ( -- ) - { "NO_LINE_BREAK" string>boolean (>>no-line-break?) } , - { "NO_WORD_BREAK" string>boolean (>>no-word-break?) } , - { "NO_ESCAPE" string>boolean (>>no-escape?) } , ; + { "NO_LINE_BREAK" string>boolean no-line-break?<< } , + { "NO_WORD_BREAK" string>boolean no-word-break?<< } , + { "NO_ESCAPE" string>boolean no-escape?<< } , ; : literal-start ( -- ) [ parse-literal-matcher >>start drop ] , ; diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index 6b8db76ac9..73519e105c 100644 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -181,7 +181,7 @@ M: abstract-span-rule handle-rule-start add-remaining-token [ rule-match-token* next-token, ] keep ! ... end subst ... - dup context get (>>in-rule) + dup context get in-rule<< delegate>> push-context ; M: span-rule handle-rule-end @@ -191,12 +191,12 @@ M: mark-following-rule handle-rule-start ?end-rule mark-token add-remaining-token [ rule-match-token* next-token, ] keep - f context get (>>end) - context get (>>in-rule) ; + f context get end<< + context get in-rule<< ; M: mark-following-rule handle-rule-end nip rule-match-token* prev-token, - f context get (>>in-rule) ; + f context get in-rule<< ; M: mark-previous-rule handle-rule-start ?end-rule diff --git a/basis/xmode/rules/rules.factor b/basis/xmode/rules/rules.factor index ffe6db3b46..7a67dc9f9b 100644 --- a/basis/xmode/rules/rules.factor +++ b/basis/xmode/rules/rules.factor @@ -79,7 +79,7 @@ TUPLE: eol-span-rule < rule ; : init-span ( rule -- ) dup delegate>> [ drop ] [ dup body-token>> standard-rule-set - swap (>>delegate) + swap delegate<< ] if ; : init-eol-span ( rule -- ) @@ -114,7 +114,7 @@ M: regexp text-hash-char drop f ; : add-escape-rule ( string ruleset -- ) over [ [ ] dip - 2dup (>>escape-rule) + 2dup escape-rule<< add-rule ] [ 2drop diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index b3bdcb4673..037ecf8715 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -214,9 +214,9 @@ ARTICLE: "tuple-examples" "Tuple examples" "This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:" { $table { "Reader" "Writer" "Setter" "Changer" } - { { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } } - { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } } - { { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } } + { { $snippet "name>>" } { $snippet "name<<" } { $snippet ">>name" } { $snippet "change-name" } } + { { $snippet "salary>>" } { $snippet "salary<<" } { $snippet ">>salary" } { $snippet "change-salary" } } + { { $snippet "position>>" } { $snippet "position<<" } { $snippet ">>position" } { $snippet "change-position" } } } "We can define a constructor which makes an empty employee:" { $code ": ( -- employee )" diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 1609c1eeca..5aec400fbe 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -588,7 +588,7 @@ T{ reshape-test f "hi" } "tuple" set [ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test -[ f ] [ \ reshape-test \ (>>x) method ] unit-test +[ f ] [ \ reshape-test \ x<< method ] unit-test [ "tuple" get 5 >>x ] must-fail diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 3d5f16d7f1..8d52c98c71 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -35,7 +35,7 @@ M: growable set-length ( n seq -- ) ] [ 2dup capacity > [ 2dup expand ] when ] if - (>>length) ; + length<< ; : new-size ( old -- new ) 1 + 3 * ; inline @@ -44,7 +44,7 @@ M: growable set-length ( n seq -- ) 2dup length >= [ 2dup capacity >= [ over new-size over expand ] when [ >fixnum ] dip - over 1 fixnum+fast over (>>length) + over 1 fixnum+fast over length<< ] [ [ >fixnum ] dip ] if ; inline @@ -56,14 +56,14 @@ M: growable clone (clone) [ clone ] change-underlying ; inline M: growable lengthen ( n seq -- ) 2dup length > [ 2dup capacity > [ over new-size over expand ] when - 2dup (>>length) + 2dup length<< ] when 2drop ; inline M: growable shorten ( n seq -- ) growable-check 2dup length < [ 2dup contract - 2dup (>>length) + 2dup length<< ] when 2drop ; inline M: growable new-resizable new-sequence 0 over set-length ; inline diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index e31ed925d1..be5aa97634 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -131,7 +131,7 @@ M: hashtable set-at ( value key hash -- ) : push-unsafe ( elt seq -- ) [ length ] keep [ underlying>> set-array-nth ] - [ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ] + [ [ 1 fixnum+fast { array-capacity } declare ] dip length<< ] 2bi ; inline PRIVATE> diff --git a/core/io/io.factor b/core/io/io.factor index e3c6a8f26c..cb6786fe1c 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -32,9 +32,9 @@ SLOT: i : (stream-seek) ( n seek-type stream -- ) swap { - { seek-absolute [ (>>i) ] } + { seek-absolute [ i<< ] } { seek-relative [ [ + ] change-i drop ] } - { seek-end [ [ underlying>> length + ] [ (>>i) ] bi ] } + { seek-end [ [ underlying>> length + ] [ i<< ] bi ] } [ bad-seek-type ] } case ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 7939a49d7a..d5eecde1a2 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -49,7 +49,7 @@ ERROR: unexpected want got ; : change-lexer-column ( lexer quot -- ) [ [ column>> ] [ line-text>> ] bi ] prepose keep - (>>column) ; inline + column<< ; inline GENERIC: skip-blank ( lexer -- ) diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 92b34db6ec..1fcf40aa20 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -28,9 +28,9 @@ $nl "The following uses writers, and requires some stack shuffling:" { $code "" - " \"Happy birthday\" over (>>subject)" - " { \"bob@bigcorp.com\" } over (>>to)" - " \"alice@bigcorp.com\" over (>>from)" + " \"Happy birthday\" over subject<<" + " { \"bob@bigcorp.com\" } over to<<" + " \"alice@bigcorp.com\" over from<<" "send-email" } "Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:" @@ -44,9 +44,9 @@ $nl "The above has less shuffling than the writer version:" { $code "" - " [ (>>subject) ] keep" - " [ (>>to) ] keep" - " \"alice@bigcorp.com\" over (>>from)" + " [ subject<< ] keep" + " [ to<< ] keep" + " \"alice@bigcorp.com\" over from<<" "send-email" } "The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:" diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 3548e22c33..7ec0136467 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -24,7 +24,7 @@ SLOT: my-protocol-slot-test TUPLE: protocol-slot-test-tuple x ; M: protocol-slot-test-tuple my-protocol-slot-test>> x>> sq ; -M: protocol-slot-test-tuple (>>my-protocol-slot-test) [ sqrt ] dip (>>x) ; +M: protocol-slot-test-tuple my-protocol-slot-test<< [ sqrt ] dip x<< ; [ 9 ] [ T{ protocol-slot-test-tuple { x 3 } } my-protocol-slot-test>> ] unit-test diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 191205a9b4..6c7881b3ad 100644 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -59,7 +59,7 @@ M: object reader-quot ] 2bi ; : writer-word ( name -- word ) - "(>>" ")" surround "accessors" create + "<<" append "accessors" create dup t "writer" set-word-prop ; ERROR: bad-slot-value value class ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 840ed94b96..120d91bb22 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -16,11 +16,11 @@ checksum definitions ; : record-top-level-form ( quot file -- ) - (>>top-level-form) + top-level-form<< [ ] [ H{ } notify-definition-observers ] if-bootstrapping ; : record-checksum ( lines source-file -- ) - [ crc32 checksum-lines ] dip (>>checksum) ; + [ crc32 checksum-lines ] dip checksum<< ; : record-definitions ( file -- ) new-definitions get >>definitions drop ; diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 0a5572e530..d3dc72005a 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -81,7 +81,7 @@ name>char-hook [ [ column>> ] [ line-text>> ] bi ] dip swap subseq ] [ - lexer get (>>column) + lexer get column<< ] bi ; : rest-of-line ( lexer -- seq ) diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index de719c7272..92211a5b01 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -233,7 +233,7 @@ IN: bootstrap.syntax "))" parse-effect suffix! ] define-core-syntax - "MAIN:" [ scan-word current-vocab (>>main) ] define-core-syntax + "MAIN:" [ scan-word current-vocab main<< ] define-core-syntax "<<" [ [ diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor index d21b7d2043..8d1d2664da 100644 --- a/core/vocabs/parser/parser.factor +++ b/core/vocabs/parser/parser.factor @@ -86,7 +86,7 @@ PRIVATE> : set-current-vocab ( name -- ) create-vocab - [ manifest get (>>current-vocab) ] [ (add-qualified) ] bi ; + [ manifest get current-vocab<< ] [ (add-qualified) ] bi ; : with-current-vocab ( name quot -- ) manifest get clone manifest [ diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor index 2b96d2a4f4..1fb5757695 100644 --- a/extra/asn1/asn1.factor +++ b/extra/asn1/asn1.factor @@ -72,7 +72,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ; : (set-tag) ( -- ) elements get id>> 31 bitand - dup elements get (>>tag) + dup elements get tag<< 31 < [ [ "unsupported tag encoding: #{" % get-id # "}" % @@ -81,22 +81,22 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ; : set-tagclass ( -- ) get-id -6 shift tag-classes nth - elements get (>>tagclass) ; + elements get tagclass<< ; : set-encoding ( -- ) get-id HEX: 20 bitand zero? "primitive" "constructed" ? - elements get (>>encoding) ; + elements get encoding<< ; : set-content-length ( -- ) read1 dup 127 <= [ 127 bitand read be> - ] unless elements get (>>contentlength) ; + ] unless elements get contentlength<< ; : set-newobj ( -- ) elements get contentlength>> read - elements get (>>newobj) ; + elements get newobj<< ; : set-objtype ( syntax -- ) builtin-syntax 2array [ @@ -104,7 +104,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ; elements get encoding>> swap at elements get tag>> swap at [ - elements get (>>objtype) + elements get objtype<< ] when* ] each ; @@ -130,7 +130,7 @@ SYMBOL: end } case ; : set-id ( -- boolean ) - read1 dup elements get (>>id) ; + read1 dup elements get id<< ; : read-ber ( syntax -- object ) element new @@ -199,7 +199,7 @@ TUPLE: tag value ; ] with-scope ; inline : set-tag ( value -- ) - tagnum get (>>value) ; + tagnum get value<< ; M: string >ber ( str -- byte-array ) tagnum get value>> 1array "C" pack-native swap dup diff --git a/extra/benchmark/chameneos-redux/chameneos-redux.factor b/extra/benchmark/chameneos-redux/chameneos-redux.factor index afd2f8830a..f17db30c92 100644 --- a/extra/benchmark/chameneos-redux/chameneos-redux.factor +++ b/extra/benchmark/chameneos-redux/chameneos-redux.factor @@ -65,7 +65,7 @@ TUPLE: meeting-place count mailbox ; first2 { [ [ [ 1 + ] change-count ] bi@ 2drop ] [ 2dup = [ [ 1 + ] change-self-count ] when 2drop ] - [ [ [ color>> ] bi@ complement-color ] [ [ (>>color) ] bi-curry@ bi ] 2bi ] + [ [ [ color>> ] bi@ complement-color ] [ [ color<< ] bi-curry@ bi ] 2bi ] [ [ mailbox>> f swap mailbox-put ] bi@ ] } 2cleave ; diff --git a/extra/c/lexer/lexer.factor b/extra/c/lexer/lexer.factor index 57894217bd..9e613d54b4 100644 --- a/extra/c/lexer/lexer.factor +++ b/extra/c/lexer/lexer.factor @@ -54,7 +54,7 @@ IN: c.lexer sequence-parser current quote-char = [ sequence-parser advance* string ] [ - start-n sequence-parser (>>n) f + start-n sequence-parser n<< f ] if ; : (take-token) ( sequence-parser -- string ) diff --git a/extra/classes/struct/vectored/vectored.factor b/extra/classes/struct/vectored/vectored.factor index 16ff95b1c0..e6f45ab245 100644 --- a/extra/classes/struct/vectored/vectored.factor +++ b/extra/classes/struct/vectored/vectored.factor @@ -45,13 +45,13 @@ MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) ) SLOT: (n) SLOT: (vectored) -FUNCTOR: define-vectored-accessors ( S>> (>>S) T -- ) +FUNCTOR: define-vectored-accessors ( S>> S<< T -- ) WHERE M: T S>> [ (n)>> ] [ (vectored)>> S>> ] bi nth-unsafe ; inline -M: T (>>S) +M: T S<< [ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline ;FUNCTOR diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index ddea7e762a..015d98157f 100644 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -63,7 +63,7 @@ CONSTANT: sign-flag HEX: 80 #! Return the 16-bit pseudo register AF. [ a>> 8 shift ] keep f>> bitor ; -: (>>af) ( value cpu -- ) +: af<< ( value cpu -- ) #! Set the value of the 16-bit pseudo register AF [ >word< ] dip swap >>f swap >>a drop ; @@ -71,7 +71,7 @@ CONSTANT: sign-flag HEX: 80 #! Return the 16-bit pseudo register BC. [ b>> 8 shift ] keep c>> bitor ; -: (>>bc) ( value cpu -- ) +: bc<< ( value cpu -- ) #! Set the value of the 16-bit pseudo register BC [ >word< ] dip swap >>c swap >>b drop ; @@ -79,7 +79,7 @@ CONSTANT: sign-flag HEX: 80 #! Return the 16-bit pseudo register DE. [ d>> 8 shift ] keep e>> bitor ; -: (>>de) ( value cpu -- ) +: de<< ( value cpu -- ) #! Set the value of the 16-bit pseudo register DE [ >word< ] dip swap >>e swap >>d drop ; @@ -87,7 +87,7 @@ CONSTANT: sign-flag HEX: 80 #! Return the 16-bit pseudo register HL. [ h>> 8 shift ] keep l>> bitor ; -: (>>hl) ( value cpu -- ) +: hl<< ( value cpu -- ) #! Set the value of the 16-bit pseudo register HL [ >word< ] dip swap >>l swap >>h drop ; @@ -150,14 +150,14 @@ CONSTANT: sign-flag HEX: 80 [ pc>> ] keep [ read-byte ] keep [ pc>> 1 + ] keep - (>>pc) ; + pc<< ; : next-word ( cpu -- word ) #! Return the value of the word at PC, and increment PC. [ pc>> ] keep [ read-word ] keep [ pc>> 2 + ] keep - (>>pc) ; + pc<< ; : write-byte ( value addr cpu -- ) @@ -176,43 +176,43 @@ CONSTANT: sign-flag HEX: 80 : cpu-a-bitand ( quot cpu -- ) #! A &= quot call - [ a>> swap call bitand ] keep (>>a) ; inline + [ a>> swap call bitand ] keep a<< ; inline : cpu-a-bitor ( quot cpu -- ) #! A |= quot call - [ a>> swap call bitor ] keep (>>a) ; inline + [ a>> swap call bitor ] keep a<< ; inline : cpu-a-bitxor ( quot cpu -- ) #! A ^= quot call - [ a>> swap call bitxor ] keep (>>a) ; inline + [ a>> swap call bitxor ] keep a<< ; inline : cpu-a-bitxor= ( value cpu -- ) #! cpu-a ^= value - [ a>> bitxor ] keep (>>a) ; + [ a>> bitxor ] keep a<< ; : cpu-f-bitand ( quot cpu -- ) #! F &= quot call - [ f>> swap call bitand ] keep (>>f) ; inline + [ f>> swap call bitand ] keep f<< ; inline : cpu-f-bitor ( quot cpu -- ) #! F |= quot call - [ f>> swap call bitor ] keep (>>f) ; inline + [ f>> swap call bitor ] keep f<< ; inline : cpu-f-bitxor ( quot cpu -- ) #! F |= quot call - [ f>> swap call bitxor ] keep (>>f) ; inline + [ f>> swap call bitxor ] keep f<< ; inline : cpu-f-bitor= ( value cpu -- ) #! cpu-f |= value - [ f>> bitor ] keep (>>f) ; + [ f>> bitor ] keep f<< ; : cpu-f-bitand= ( value cpu -- ) #! cpu-f &= value - [ f>> bitand ] keep (>>f) ; + [ f>> bitand ] keep f<< ; : cpu-f-bitxor= ( value cpu -- ) #! cpu-f ^= value - [ f>> bitxor ] keep (>>f) ; + [ f>> bitxor ] keep f<< ; : set-flag ( cpu flag -- ) swap cpu-f-bitor= ; @@ -361,7 +361,7 @@ CONSTANT: sign-flag HEX: 80 : decrement-sp ( n cpu -- ) #! Decrement the stackpointer by n. [ sp>> ] keep - [ swap - ] dip (>>sp) ; + [ swap - ] dip sp<< ; : save-pc ( cpu -- ) #! Save the value of the PC on the stack. @@ -393,24 +393,24 @@ CONSTANT: sign-flag HEX: 80 : call-sub ( addr cpu -- ) #! Call the address as a subroutine. dup push-pc - [ HEX: FFFF bitand ] dip (>>pc) ; + [ HEX: FFFF bitand ] dip pc<< ; : ret-from-sub ( cpu -- ) - [ pop-pc ] keep (>>pc) ; + [ pop-pc ] keep pc<< ; : interrupt ( number cpu -- ) #! Perform a hardware interrupt ! "***Interrupt: " write over 16 >base print dup f>> interrupt-flag bitand 0 = not [ dup push-pc - (>>pc) + pc<< ] [ 2drop ] if ; : inc-cycles ( n cpu -- ) #! Increment the number of cpu cycles - [ cycles>> + ] keep (>>cycles) ; + [ cycles>> + ] keep cycles<< ; : instruction-cycles ( -- vector ) #! Return a 256 element vector containing the cycles for @@ -496,7 +496,7 @@ SYMBOL: rom-root #! Read the next instruction from the cpu's program #! counter, and increment the program counter. [ pc>> ] keep ! pc cpu - [ over 1 + swap (>>pc) ] keep + [ over 1 + swap pc<< ] keep read-byte ; : get-cycles ( n -- opcode ) @@ -514,11 +514,11 @@ SYMBOL: rom-root over 16667 < [ 2drop ] [ - [ [ 16667 - ] dip (>>cycles) ] keep + [ [ 16667 - ] dip cycles<< ] keep dup last-interrupt>> HEX: 10 = [ - HEX: 08 over (>>last-interrupt) HEX: 08 swap interrupt + HEX: 08 over last-interrupt<< HEX: 08 swap interrupt ] [ - HEX: 10 over (>>last-interrupt) HEX: 10 swap interrupt + HEX: 10 over last-interrupt<< HEX: 10 swap interrupt ] if ] if ; @@ -561,18 +561,18 @@ SYMBOL: rom-root #! where the 1st item is the getter and the 2nd is the setter #! for that register. H{ - { "A" { a>> (>>a) } } - { "B" { b>> (>>b) } } - { "C" { c>> (>>c) } } - { "D" { d>> (>>d) } } - { "E" { e>> (>>e) } } - { "H" { h>> (>>h) } } - { "L" { l>> (>>l) } } - { "AF" { af>> (>>af) } } - { "BC" { bc>> (>>bc) } } - { "DE" { de>> (>>de) } } - { "HL" { hl>> (>>hl) } } - { "SP" { sp>> (>>sp) } } + { "A" { a>> a<< } } + { "B" { b>> b<< } } + { "C" { c>> c<< } } + { "D" { d>> d<< } } + { "E" { e>> e<< } } + { "H" { h>> h<< } } + { "L" { l>> l<< } } + { "AF" { af>> af<< } } + { "BC" { bc>> bc<< } } + { "DE" { de>> de<< } } + { "HL" { hl>> hl<< } } + { "SP" { sp>> sp<< } } } at ; @@ -580,14 +580,14 @@ SYMBOL: rom-root #! Given a string containing a flag name, return a vector #! where the 1st item is a word that tests that flag. H{ - { "NZ" { flag-nz? } } - { "NC" { flag-nc? } } - { "PO" { flag-po? } } - { "PE" { flag-pe? } } + { "NZ" { flag-nz? } } + { "NC" { flag-nc? } } + { "PO" { flag-po? } } + { "PE" { flag-pe? } } { "Z" { flag-z? } } { "C" { flag-c? } } { "P" { flag-p? } } - { "M" { flag-m? } } + { "M" { flag-m? } } } at ; SYMBOLS: $1 $2 $3 $4 ; @@ -606,19 +606,19 @@ SYMBOLS: $1 $2 $3 $4 ; : (emulate-RST) ( n cpu -- ) #! RST nn [ sp>> 2 - dup ] keep ! sp sp cpu - [ (>>sp) ] keep ! sp cpu + [ sp<< ] keep ! sp cpu [ pc>> ] keep ! sp pc cpu swapd [ write-word ] keep ! cpu - [ 8 * ] dip (>>pc) ; + [ 8 * ] dip pc<< ; : (emulate-CALL) ( cpu -- ) #! 205 - CALL nn [ next-word HEX: FFFF bitand ] keep ! addr cpu [ sp>> 2 - dup ] keep ! addr sp sp cpu - [ (>>sp) ] keep ! addr sp cpu + [ sp<< ] keep ! addr sp cpu [ pc>> ] keep ! addr sp pc cpu swapd [ write-word ] keep ! addr cpu - (>>pc) ; + pc<< ; : (emulate-RLCA) ( cpu -- ) #! The content of the accumulator is rotated left @@ -628,7 +628,7 @@ SYMBOLS: $1 $2 $3 $4 ; [ a>> -7 shift ] keep over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if [ a>> 1 shift HEX: FF bitand ] keep - [ bitor ] dip (>>a) ; + [ bitor ] dip a<< ; : (emulate-RRCA) ( cpu -- ) #! The content of the accumulator is rotated right @@ -638,7 +638,7 @@ SYMBOLS: $1 $2 $3 $4 ; [ a>> 1 bitand 7 shift ] keep over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if [ a>> 254 bitand -1 shift ] keep - [ bitor ] dip (>>a) ; + [ bitor ] dip a<< ; : (emulate-RLA) ( cpu -- ) #! The content of the accumulator is rotated left @@ -650,7 +650,7 @@ SYMBOLS: $1 $2 $3 $4 ; [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep [ a>> 127 bitand 7 shift ] keep dup a>> 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if - [ bitor ] dip (>>a) ; + [ bitor ] dip a<< ; : (emulate-RRA) ( cpu -- ) #! The content of the accumulator is rotated right @@ -661,7 +661,7 @@ SYMBOLS: $1 $2 $3 $4 ; [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep [ a>> 254 bitand -1 shift ] keep dup a>> 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if - [ bitor ] dip (>>a) ; + [ bitor ] dip a<< ; : (emulate-CPL) ( cpu -- ) #! The contents of the accumulator are complemented @@ -679,93 +679,93 @@ SYMBOLS: $1 $2 $3 $4 ; ] keep [ a>> + ] keep [ update-flags ] 2keep - [ swap HEX: FF bitand swap (>>a) ] keep + [ swap HEX: FF bitand swap a<< ] keep [ dup carry-flag swap flag-set? swap a>> -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if ] keep [ a>> + ] keep [ update-flags ] 2keep - swap HEX: FF bitand swap (>>a) ; + swap HEX: FF bitand swap a<< ; : patterns ( -- hashtable ) #! table of code quotation patterns for each type of instruction. H{ - { "NOP" [ drop ] } - { "RET-NN" [ ret-from-sub ] } - { "RST-0" [ 0 swap (emulate-RST) ] } - { "RST-8" [ 8 swap (emulate-RST) ] } - { "RST-10H" [ HEX: 10 swap (emulate-RST) ] } - { "RST-18H" [ HEX: 18 swap (emulate-RST) ] } - { "RST-20H" [ HEX: 20 swap (emulate-RST) ] } - { "RST-28H" [ HEX: 28 swap (emulate-RST) ] } - { "RST-30H" [ HEX: 30 swap (emulate-RST) ] } - { "RST-38H" [ HEX: 38 swap (emulate-RST) ] } - { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] } - { "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] } - { "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] } - { "CP-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] } - { "OR-N" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep (>>a) ] } - { "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep (>>a) ] } - { "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep (>>a) ] } - { "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep (>>a) ] } - { "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep (>>a) ] } - { "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep (>>a) ] } - { "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep (>>a) ] } - { "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep (>>a) ] } - { "AND-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep (>>a) ] } - { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] } - { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] } - { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] } - { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] } - { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] } - { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] } - { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] } - { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] } - { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] } - { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] } - { "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep (>>a) ] } - { "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep (>>a) ] } - { "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep (>>a) ] } - { "CPL" [ (emulate-CPL) ] } - { "DAA" [ (emulate-DAA) ] } - { "RLA" [ (emulate-RLA) ] } - { "RRA" [ (emulate-RRA) ] } - { "CCF" [ carry-flag swap cpu-f-bitxor= ] } - { "SCF" [ carry-flag swap cpu-f-bitor= ] } - { "RLCA" [ (emulate-RLCA) ] } - { "RRCA" [ (emulate-RRCA) ] } - { "HALT" [ drop ] } - { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] } - { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] } - { "POP-RR" [ [ pop-sp ] keep $2 ] } - { "PUSH-RR" [ [ $1 ] keep push-sp ] } - { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] } - { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] } - { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] } - { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] } - { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] } - { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] } - { "JP-NN" [ [ pc>> ] keep [ read-word ] keep (>>pc) ] } - { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ (>>pc) ] keep [ cycles>> ] keep swap 5 + swap (>>cycles) ] [ [ pc>> 2 + ] keep (>>pc) ] if ] } - { "JP-(RR)" [ [ $1 ] keep (>>pc) ] } - { "CALL-NN" [ (emulate-CALL) ] } - { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ pc>> 2 + ] keep (>>pc) ] if ] } - { "LD-RR,NN" [ [ next-word ] keep $2 ] } - { "LD-RR,RR" [ [ $3 ] keep $2 ] } - { "LD-R,N" [ [ next-byte ] keep $2 ] } - { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] } - { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] } - { "LD-R,R" [ [ $3 ] keep $2 ] } - { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] } - { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] } - { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] } - { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] } - { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] } - { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] } - { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep (>>a) ] } - { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] } - { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] } + { "NOP" [ drop ] } + { "RET-NN" [ ret-from-sub ] } + { "RST-0" [ 0 swap (emulate-RST) ] } + { "RST-8" [ 8 swap (emulate-RST) ] } + { "RST-10H" [ HEX: 10 swap (emulate-RST) ] } + { "RST-18H" [ HEX: 18 swap (emulate-RST) ] } + { "RST-20H" [ HEX: 20 swap (emulate-RST) ] } + { "RST-28H" [ HEX: 28 swap (emulate-RST) ] } + { "RST-30H" [ HEX: 30 swap (emulate-RST) ] } + { "RST-38H" [ HEX: 38 swap (emulate-RST) ] } + { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] } + { "CP-N" [ [ a>> ] keep [ next-byte ] keep sub-byte drop ] } + { "CP-R" [ [ a>> ] keep [ $1 ] keep sub-byte drop ] } + { "CP-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] } + { "OR-N" [ [ a>> ] keep [ next-byte ] keep [ or-byte ] keep a<< ] } + { "OR-R" [ [ a>> ] keep [ $1 ] keep [ or-byte ] keep a<< ] } + { "OR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep a<< ] } + { "XOR-N" [ [ a>> ] keep [ next-byte ] keep [ xor-byte ] keep a<< ] } + { "XOR-R" [ [ a>> ] keep [ $1 ] keep [ xor-byte ] keep a<< ] } + { "XOR-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep a<< ] } + { "AND-N" [ [ a>> ] keep [ next-byte ] keep [ and-byte ] keep a<< ] } + { "AND-R" [ [ a>> ] keep [ $1 ] keep [ and-byte ] keep a<< ] } + { "AND-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep a<< ] } + { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] } + { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] } + { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] } + { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] } + { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] } + { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] } + { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] } + { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] } + { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] } + { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] } + { "SUB-R" [ [ a>> ] keep [ $1 ] keep [ sub-byte ] keep a<< ] } + { "SUB-(RR)" [ [ a>> ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep a<< ] } + { "SUB-N" [ [ a>> ] keep [ next-byte ] keep [ sub-byte ] keep a<< ] } + { "CPL" [ (emulate-CPL) ] } + { "DAA" [ (emulate-DAA) ] } + { "RLA" [ (emulate-RLA) ] } + { "RRA" [ (emulate-RRA) ] } + { "CCF" [ carry-flag swap cpu-f-bitxor= ] } + { "SCF" [ carry-flag swap cpu-f-bitor= ] } + { "RLCA" [ (emulate-RLCA) ] } + { "RRCA" [ (emulate-RRCA) ] } + { "HALT" [ drop ] } + { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] } + { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] } + { "POP-RR" [ [ pop-sp ] keep $2 ] } + { "PUSH-RR" [ [ $1 ] keep push-sp ] } + { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] } + { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] } + { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] } + { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] } + { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] } + { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] } + { "JP-NN" [ [ pc>> ] keep [ read-word ] keep pc<< ] } + { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ pc<< ] keep [ cycles>> ] keep swap 5 + swap cycles<< ] [ [ pc>> 2 + ] keep pc<< ] if ] } + { "JP-(RR)" [ [ $1 ] keep pc<< ] } + { "CALL-NN" [ (emulate-CALL) ] } + { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ pc>> 2 + ] keep pc<< ] if ] } + { "LD-RR,NN" [ [ next-word ] keep $2 ] } + { "LD-RR,RR" [ [ $3 ] keep $2 ] } + { "LD-R,N" [ [ next-byte ] keep $2 ] } + { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] } + { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] } + { "LD-R,R" [ [ $3 ] keep $2 ] } + { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] } + { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] } + { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] } + { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] } + { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] } + { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] } + { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep a<< ] } + { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] } + { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] } } ; : 8-bit-registers ( -- parser ) diff --git a/extra/cpu/8080/test/test.factor b/extra/cpu/8080/test/test.factor index 6be74156be..2fcb9434b7 100644 --- a/extra/cpu/8080/test/test.factor +++ b/extra/cpu/8080/test/test.factor @@ -20,7 +20,7 @@ IN: cpu.8080.test over get-cycles over inc-cycles [ swap instructions nth call( cpu -- ) ] keep [ pc>> HEX: FFFF bitand ] keep - [ (>>pc) ] keep + [ pc<< ] keep process-interrupts ; : test-step ( cpu -- cpu ) diff --git a/extra/enter/authors.txt b/extra/enter/authors.txt deleted file mode 100644 index ce0899f16e..0000000000 --- a/extra/enter/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sam Anklesaria \ No newline at end of file diff --git a/extra/enter/enter.factor b/extra/enter/enter.factor deleted file mode 100644 index 845182c726..0000000000 --- a/extra/enter/enter.factor +++ /dev/null @@ -1,8 +0,0 @@ -! Copyright (C) 2009 Sam Anklesaria. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel parser vocabs.parser words ; -IN: enter -! main words are usually only used for entry, doing initialization, etc -! it makes sense, then to define it all at once, rather than factoring it out into a seperate word -! and then declaring it main -SYNTAX: ENTER: gensym [ parse-definition (( -- )) define-declared ] keep current-vocab (>>main) ; \ No newline at end of file diff --git a/extra/fullscreen/fullscreen.factor b/extra/fullscreen/fullscreen.factor index 458ef3d51e..56c1426554 100755 --- a/extra/fullscreen/fullscreen.factor +++ b/extra/fullscreen/fullscreen.factor @@ -131,11 +131,11 @@ ERROR: unsupported-resolution triple ; triple world handle>> hWnd>> fullscreen? [ - enable-fullscreen world (>>saved-position) + enable-fullscreen world saved-position<< ] [ [ world saved-position>> ] 2dip disable-fullscreen ] if - fullscreen? world (>>fullscreen?) + fullscreen? world fullscreen?<< ] when ; : set-fullscreen ( gadget triple fullscreen? -- ) diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor index 312d7dbd1c..fa4d4adcb3 100644 --- a/extra/game/loop/loop.factor +++ b/extra/game/loop/loop.factor @@ -95,7 +95,7 @@ PRIVATE> t >>running? [ reset-loop-benchmark ] [ [ run-loop ] curry "game loop" spawn ] - [ (>>thread) ] tri ; + [ thread<< ] tri ; : stop-loop ( loop -- ) f >>running? diff --git a/extra/game/models/obj/obj.factor b/extra/game/models/obj/obj.factor index 9ac59444db..9b91b8fcf7 100644 --- a/extra/game/models/obj/obj.factor +++ b/extra/game/models/obj/obj.factor @@ -54,22 +54,22 @@ TUPLE: material [ material new swap >>name current-material set ] [ cm swap md set-at ] bi ] } - { "Ka" [ 3 head strings>numbers cm (>>ambient-reflectivity) ] } - { "Kd" [ 3 head strings>numbers cm (>>diffuse-reflectivity) ] } - { "Ks" [ 3 head strings>numbers cm (>>specular-reflectivity) ] } - { "Tf" [ 3 head strings>numbers cm (>>transmission-filter) ] } - { "d" [ first string>number cm (>>dissolve) ] } - { "Ns" [ first string>number cm (>>specular-exponent) ] } - { "Ni" [ first string>number cm (>>refraction-index) ] } - { "map_Ka" [ first cm (>>ambient-map) ] } - { "map_Kd" [ first cm (>>diffuse-map) ] } - { "map_Ks" [ first cm (>>specular-map) ] } - { "map_Ns" [ first cm (>>specular-exponent-map) ] } - { "map_d" [ first cm (>>dissolve-map) ] } - { "map_bump" [ first cm (>>bump-map) ] } - { "bump" [ first cm (>>bump-map) ] } - { "disp" [ first cm (>>displacement-map) ] } - { "refl" [ first cm (>>reflection-map) ] } + { "Ka" [ 3 head strings>numbers cm ambient-reflectivity<< ] } + { "Kd" [ 3 head strings>numbers cm diffuse-reflectivity<< ] } + { "Ks" [ 3 head strings>numbers cm specular-reflectivity<< ] } + { "Tf" [ 3 head strings>numbers cm transmission-filter<< ] } + { "d" [ first string>number cm dissolve<< ] } + { "Ns" [ first string>number cm specular-exponent<< ] } + { "Ni" [ first string>number cm refraction-index<< ] } + { "map_Ka" [ first cm ambient-map<< ] } + { "map_Kd" [ first cm diffuse-map<< ] } + { "map_Ks" [ first cm specular-map<< ] } + { "map_Ns" [ first cm specular-exponent-map<< ] } + { "map_d" [ first cm dissolve-map<< ] } + { "map_bump" [ first cm bump-map<< ] } + { "bump" [ first cm bump-map<< ] } + { "disp" [ first cm displacement-map<< ] } + { "refl" [ first cm reflection-map<< ] } [ 2drop ] } case ] unless-empty ; diff --git a/extra/game/models/util/util.factor b/extra/game/models/util/util.factor index 438ab82356..cf43e69451 100644 --- a/extra/game/models/util/util.factor +++ b/extra/game/models/util/util.factor @@ -37,8 +37,8 @@ M:: indexed-seq set-nth ( elt n seq -- ) M: indexed-seq new-resizable [ dseq>> ] [ iseq>> ] [ rassoc>> ] tri dup -rot - [ [ dseq>> new-resizable ] keep (>>dseq) ] - [ [ iseq>> new-resizable ] keep (>>iseq) ] - [ [ rassoc>> clone nip ] keep (>>rassoc) ] + [ [ dseq>> new-resizable ] keep dseq<< ] + [ [ iseq>> new-resizable ] keep iseq<< ] + [ [ rassoc>> clone nip ] keep rassoc<< ] 2tri ; diff --git a/extra/io/serial/unix/unix.factor b/extra/io/serial/unix/unix.factor index fc613da423..f2dec1972e 100644 --- a/extra/io/serial/unix/unix.factor +++ b/extra/io/serial/unix/unix.factor @@ -47,14 +47,14 @@ M: unix open-serial ( serial -- serial' ) : configure-termios ( serial -- ) dup termios>> { - [ [ iflag>> ] dip over [ (>>iflag) ] [ 2drop ] if ] - [ [ oflag>> ] dip over [ (>>oflag) ] [ 2drop ] if ] + [ [ iflag>> ] dip over [ iflag<< ] [ 2drop ] if ] + [ [ oflag>> ] dip over [ oflag<< ] [ 2drop ] if ] [ [ [ cflag>> 0 or ] [ baud>> lookup-baud ] bi bitor - ] dip (>>cflag) + ] dip cflag<< ] - [ [ lflag>> ] dip over [ (>>lflag) ] [ 2drop ] if ] + [ [ lflag>> ] dip over [ lflag<< ] [ 2drop ] if ] } 2cleave ; : tciflush ( serial -- ) diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index f2030e87b0..68ca6451a5 100644 --- a/extra/irc/client/internals/internals.factor +++ b/extra/irc/client/internals/internals.factor @@ -165,7 +165,7 @@ M: irc-chat (attach-chat) 2bi ; M: irc-server-chat (attach-chat) - irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ; + irc> [ client<< ] [ chats>> +server-chat+ set-at ] 2bi ; GENERIC: remove-chat ( irc-chat -- ) M: irc-nick-chat remove-chat name>> unregister-chat ; diff --git a/extra/irc/client/participants/participants.factor b/extra/irc/client/participants/participants.factor index 8d367dbb95..d2b2e15999 100644 --- a/extra/irc/client/participants/participants.factor +++ b/extra/irc/client/participants/participants.factor @@ -37,8 +37,8 @@ M: irc-channel-chat has-participant? participants>> key? ; : apply-mode ( ? participant mode -- ) { - { CHAR: o [ (>>operator) ] } - { CHAR: v [ (>>voice) ] } + { CHAR: o [ operator<< ] } + { CHAR: v [ voice<< ] } [ 3drop ] } case ; diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor index b785970520..f0f9ca02ce 100644 --- a/extra/irc/messages/base/base.factor +++ b/extra/irc/messages/base/base.factor @@ -74,7 +74,7 @@ M: irc-message set-irc-trailing GENERIC: set-irc-command ( irc-message -- ) M: irc-message set-irc-command - [ irc-command-string ] [ (>>command) ] bi ; + [ irc-command-string ] [ command<< ] bi ; : irc-message>string ( irc-message -- string ) { diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor index 06a41b0aaa..34606eb83a 100644 --- a/extra/irc/messages/parser/parser.factor +++ b/extra/irc/messages/parser/parser.factor @@ -31,5 +31,5 @@ PRIVATE> [ >>parameters ] [ >>trailing ] tri* - [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri + [ prefix<< ] [ fill-irc-message-slots ] [ swap >>line ] tri dup sender >>sender ; diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor index 63814dfbf8..8201137f2a 100644 --- a/extra/joystick-demo/joystick-demo.factor +++ b/extra/joystick-demo/joystick-demo.factor @@ -52,8 +52,8 @@ CONSTANT: pov-polygons :: move-axis ( gadget x y z -- ) x y z (xyz>loc) :> ( xy z ) - xy gadget indicator>> (>>loc) - z gadget z-indicator>> (>>loc) ; + xy gadget indicator>> loc<< + z gadget z-indicator>> loc<< ; : move-pov ( gadget pov -- ) swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ] @@ -91,7 +91,7 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; gadget controller>> read-controller buttons>> length iota [ number>string [ drop ] shelf over add-gadget drop - ] map gadget (>>buttons) ; + ] map gadget buttons<< ; : add-button-gadgets ( gadget shelf -- gadget shelf ) [ (add-button-gadgets) ] 2keep ; diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index 585ca2d16f..b236442e9d 100644 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -158,7 +158,7 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ; : update-key-caps-state ( gadget -- ) read-keyboard keys>> over keys>> - [ [ (>>selected?) ] [ drop ] if* ] 2each + [ [ selected?<< ] [ drop ] if* ] 2each relayout-1 ; M: key-caps-gadget graft* diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index ecf36bcfbb..91936c701f 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -27,7 +27,7 @@ CONSTANT: line-beginning "-!- " ] "" append-outputs-as send-everyone ; : handle-quit ( string -- ) - client [ (>>object) ] [ t >>quit? drop ] bi ; + client [ object<< ] [ t >>quit? drop ] bi ; : handle-help ( string -- ) [ @@ -60,7 +60,7 @@ CONSTANT: line-beginning "-!- " ] [ [ username swap warn-name-changed ] [ username clients rename-at ] - [ client (>>username) ] tri + [ client username<< ] tri ] if ] if-empty ; @@ -127,10 +127,10 @@ M: chat-server handle-client-disconnect M: chat-server handle-already-logged-in username username-taken-string send-line - t client (>>quit?) ; + t client quit?<< ; M: chat-server handle-managed-client* - readln dup f = [ t client (>>quit?) ] when + readln dup f = [ t client quit?<< ] when [ "/" ?head [ handle-command ] [ handle-chat ] if ] unless-empty ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index acb3c84825..d626044766 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -67,7 +67,7 @@ PRIVATE> username clients key? [ handle-already-logged-in ] [ - t client (>>logged-in?) + t client logged-in?<< client username clients set-at ] if ; diff --git a/extra/model-viewer/model-viewer.factor b/extra/model-viewer/model-viewer.factor index 606eada523..93bb0bd836 100644 --- a/extra/model-viewer/model-viewer.factor +++ b/extra/model-viewer/model-viewer.factor @@ -193,7 +193,7 @@ M: model-world wasd-far-plane drop 1024.0 ; M: model-world begin-game-world init-gpu { 0.0 0.0 2.0 } 0 0 set-wasd-view - [ [ fill-model-state ] keep ] [ (>>model-state) ] bi ; + [ [ fill-model-state ] keep ] [ model-state<< ] bi ; M: model-world apply-world-attributes { [ model-path>> >>model-path ] diff --git a/extra/models/conditional/conditional.factor b/extra/models/conditional/conditional.factor index 37cf3d115e..bc20fcd04d 100644 --- a/extra/models/conditional/conditional.factor +++ b/extra/models/conditional/conditional.factor @@ -13,7 +13,7 @@ M: conditional model-changed [ [ value>> ] dip set-model f ] [ 2drop t ] if 100 milliseconds sleep ] 2curry "models.conditional" spawn-server - ] keep (>>thread) ; + ] keep thread<< ; : ( condition -- model ) f conditional new-model swap >>condition ; diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index 85036c8d86..eeb7314196 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -44,7 +44,7 @@ PRIVATE> M: mdb-persistent id>> ( object -- id ) dup class id-slot reader-word execute( object -- id ) ; -M: mdb-persistent (>>id) ( object value -- ) +M: mdb-persistent id<< ( object value -- ) over class id-slot writer-word execute( object value -- ) ; diff --git a/extra/pairs/pairs.factor b/extra/pairs/pairs.factor index 2b19d95833..201b91e5e7 100644 --- a/extra/pairs/pairs.factor +++ b/extra/pairs/pairs.factor @@ -23,7 +23,7 @@ M: pair at* ] if-key ; inline M: pair set-at - [ (>>value) ] [ + [ value<< ] [ [ set-at ] [ [ associate ] dip swap >>hash drop ] if-hash ] if-key ; inline diff --git a/extra/path-finding/path-finding.factor b/extra/path-finding/path-finding.factor index 3188013940..cd63a5c8d5 100644 --- a/extra/path-finding/path-finding.factor +++ b/extra/path-finding/path-finding.factor @@ -57,8 +57,8 @@ TUPLE: (astar) astar goal origin in-open-set open-set ; : (init) ( from to astar -- ) swap >>goal - H{ } clone over astar>> (>>g) - { } over astar>> (>>in-closed-set) + H{ } clone over astar>> g<< + { } over astar>> in-closed-set<< H{ } clone >>origin H{ } clone >>in-open-set >>open-set @@ -77,7 +77,7 @@ M: bfs neighbours neighbours>> at ; PRIVATE> : find-path ( start target astar -- path/f ) - (astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ; + (astar) new [ astar<< ] keep [ (init) ] [ (find-path) ] bi ; : ( neighbours cost heuristic -- astar ) astar-simple new swap >>heuristic swap >>cost swap >>neighbours ; diff --git a/extra/pop3/pop3.factor b/extra/pop3/pop3.factor index 030d265f37..c99eb8678e 100644 --- a/extra/pop3/pop3.factor +++ b/extra/pop3/pop3.factor @@ -45,7 +45,7 @@ TUPLE: raw-source top headers content ; : get-ok-and-total ( -- total ) stream [ readln dup "+OK" head? [ - " " split second string>number dup account (>>count) + " " split second string>number dup account count<< ] [ throw ] if ] with-stream* ; @@ -78,13 +78,13 @@ TUPLE: raw-source top headers content ; : (list) ( -- ) stream [ "LIST" command - readlns account (>>list) + readlns account list<< ] with-stream* ; : (uidls) ( -- ) stream [ "UIDL" command - readlns account (>>uidls) + readlns account uidls<< ] with-stream* ; PRIVATE> @@ -115,7 +115,7 @@ PRIVATE> : capa ( -- array ) stream [ "CAPA" command - readlns dup account (>>capa) + readlns dup account capa<< ] with-stream* ; : count ( -- n ) @@ -140,7 +140,7 @@ PRIVATE> "TOP " _ number>string append " " append _ number>string append command - readlns dup raw (>>top) + readlns dup raw top<< ] with-stream* ; : headers ( -- assoc ) @@ -168,7 +168,7 @@ PRIVATE> : retrieve ( message# -- seq ) [ stream ] dip '[ "RETR " _ number>string append command - readlns dup raw (>>content) + readlns dup raw content<< ] with-stream* ; : delete ( message# -- ) diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 895eba4deb..7474850f8f 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -157,6 +157,6 @@ PRIVATE> SYNTAX: SOLUTION: scan-word [ name>> "-main" append create-in ] keep - [ drop current-vocab (>>main) ] + [ drop current-vocab main<< ] [ [ . ] swap prefix (( -- )) define-declared ] 2bi ; diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor index 7c2bdd0d28..ab0e9bda23 100644 --- a/extra/quadtrees/quadtrees.factor +++ b/extra/quadtrees/quadtrees.factor @@ -80,7 +80,7 @@ DEFER: in-rect* : leaf-insert ( value point leaf -- ) 2dup leaf-replaceable? - [ [ (>>point) ] [ (>>value) ] bi ] + [ [ point<< ] [ value<< ] bi ] [ split-leaf ] if ; : node-insert ( value point node -- ) diff --git a/extra/random/cmwc/cmwc.factor b/extra/random/cmwc/cmwc.factor index 3fda392d80..44bb016267 100644 --- a/extra/random/cmwc/cmwc.factor +++ b/extra/random/cmwc/cmwc.factor @@ -42,7 +42,7 @@ M:: cmwc random-32* ( cmwc -- n ) [ [ i>> ] [ Q>> ] bi nth-unsafe * ] [ c>> + ] tri - [ >fixnum -32 shift cmwc (>>c) ] + [ >fixnum -32 shift cmwc c<< ] [ cmwc [ b>> bitand ] [ c>> + ] bi 32 bits ] bi dup cmwc r>> > [ diff --git a/extra/sequences/repeating/repeating.factor b/extra/sequences/repeating/repeating.factor index 7157e3f025..4689633b61 100644 --- a/extra/sequences/repeating/repeating.factor +++ b/extra/sequences/repeating/repeating.factor @@ -12,7 +12,7 @@ TUPLE: repeating circular len ; dupd swap like ; M: repeating length len>> ; -M: repeating set-length (>>len) ; +M: repeating set-length len<< ; M: repeating virtual@ ( n seq -- n' seq' ) circular>> ; diff --git a/extra/smalltalk/compiler/lexenv/lexenv-tests.factor b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor index 8f171f3eed..e6b648c3e4 100644 --- a/extra/smalltalk/compiler/lexenv/lexenv-tests.factor +++ b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor @@ -19,6 +19,6 @@ lexenv set [ [ \ tuple ] ] [ "Object" lexenv get lookup-reader ] unit-test [ [ fake-local ] ] [ "jumble" lexenv get lookup-writer ] unit-test -[ [ fake-self (>>y) ] ] [ "y" lexenv get lookup-writer ] unit-test +[ [ fake-self y<< ] ] [ "y" lexenv get lookup-writer ] unit-test [ "blahblah" lexenv get lookup-writer ] must-fail \ No newline at end of file diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index 01bf621769..14277a1f28 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -72,7 +72,7 @@ CONSTANT: SOUND-UFO-HIT 8 : init-sounds ( cpu -- ) init-openal - [ 9 gen-sources swap (>>sounds) ] keep + [ 9 gen-sources swap sounds<< ] keep [ SOUND-SHOT "vocab:space-invaders/resources/Shot.wav" init-sound ] keep [ SOUND-UFO "vocab:space-invaders/resources/Ufo.wav" init-sound ] keep [ sounds>> SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep @@ -83,10 +83,10 @@ CONSTANT: SOUND-UFO-HIT 8 [ SOUND-WALK3 "vocab:space-invaders/resources/Walk3.wav" init-sound ] keep [ SOUND-WALK4 "vocab:space-invaders/resources/Walk4.wav" init-sound ] keep [ SOUND-UFO-HIT "vocab:space-invaders/resources/UfoHit.wav" init-sound ] keep - f swap (>>looping?) ; + f swap looping?<< ; : cpu-init ( cpu -- cpu ) - make-opengl-bitmap over (>>bitmap) + make-opengl-bitmap over bitmap<< [ init-sounds ] keep [ reset ] keep ; @@ -108,7 +108,7 @@ CONSTANT: SOUND-UFO-HIT 8 #! Bit 5 = player one left #! Bit 6 = player one right [ port1>> dup HEX: FE bitand ] keep - (>>port1) ; + port1<< ; : read-port2 ( cpu -- byte ) #! Port 2 maps player 2 controls and dip switches @@ -139,7 +139,7 @@ M: space-invaders read-port ( port cpu -- byte ) : write-port2 ( value cpu -- ) #! Setting this value affects the value read from port 3 - (>>port2o) ; + port2o<< ; :: bit-newly-set? ( old-value new-value bit -- bool ) new-value bit bit? [ old-value bit bit? not ] dip and ; @@ -159,23 +159,23 @@ M: space-invaders read-port ( port cpu -- byte ) #! Bit 4 = Extended play sound over 0 bit? over looping?>> not and [ dup SOUND-UFO play-invaders-sound - t over (>>looping?) + t over looping?<< ] when over 0 bit? not over looping?>> and [ dup SOUND-UFO stop-invaders-sound - f over (>>looping?) + f over looping?<< ] when 2dup 0 port3-newly-set? [ dup SOUND-UFO play-invaders-sound ] when 2dup 1 port3-newly-set? [ dup SOUND-SHOT play-invaders-sound ] when 2dup 2 port3-newly-set? [ dup SOUND-BASE-HIT play-invaders-sound ] when 2dup 3 port3-newly-set? [ dup SOUND-INVADER-HIT play-invaders-sound ] when - (>>port3o) ; + port3o<< ; : write-port4 ( value cpu -- ) #! Affects the value returned by reading port 3 [ port4hi>> ] keep - [ (>>port4lo) ] keep - (>>port4hi) ; + [ port4lo<< ] keep + port4hi<< ; : write-port5 ( value cpu -- ) #! Plays sounds @@ -190,7 +190,7 @@ M: space-invaders read-port ( port cpu -- byte ) 2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when 2dup 3 port5-newly-set? [ dup SOUND-WALK4 play-invaders-sound ] when 2dup 4 port5-newly-set? [ dup SOUND-UFO-HIT play-invaders-sound ] when - (>>port5o) ; + port5o<< ; M: space-invaders write-port ( value port cpu -- ) #! Write a byte to the hardware port, where 'port' is @@ -219,7 +219,7 @@ M: space-invaders reset ( cpu -- ) over get-cycles over inc-cycles [ swap instructions nth call( cpu -- ) ] keep [ pc>> HEX: FFFF bitand ] keep - (>>pc) ; + pc<< ; : gui-frame/2 ( cpu -- ) [ gui-step ] keep @@ -227,11 +227,11 @@ M: space-invaders reset ( cpu -- ) over 16667 < [ ! cycles cpu nip gui-frame/2 ] [ - [ [ 16667 - ] dip (>>cycles) ] keep + [ [ 16667 - ] dip cycles<< ] keep dup last-interrupt>> HEX: 10 = [ - HEX: 08 over (>>last-interrupt) HEX: 08 swap interrupt + HEX: 08 over last-interrupt<< HEX: 08 swap interrupt ] [ - HEX: 10 over (>>last-interrupt) HEX: 10 swap interrupt + HEX: 10 over last-interrupt<< HEX: 10 swap interrupt ] if ] if ; @@ -239,46 +239,46 @@ M: space-invaders reset ( cpu -- ) dup gui-frame/2 gui-frame/2 ; : coin-down ( cpu -- ) - [ port1>> 1 bitor ] keep (>>port1) ; + [ port1>> 1 bitor ] keep port1<< ; : coin-up ( cpu -- ) - [ port1>> 255 1 - bitand ] keep (>>port1) ; + [ port1>> 255 1 - bitand ] keep port1<< ; : player1-down ( cpu -- ) - [ port1>> 4 bitor ] keep (>>port1) ; + [ port1>> 4 bitor ] keep port1<< ; : player1-up ( cpu -- ) - [ port1>> 255 4 - bitand ] keep (>>port1) ; + [ port1>> 255 4 - bitand ] keep port1<< ; : player2-down ( cpu -- ) - [ port1>> 2 bitor ] keep (>>port1) ; + [ port1>> 2 bitor ] keep port1<< ; : player2-up ( cpu -- ) - [ port1>> 255 2 - bitand ] keep (>>port1) ; + [ port1>> 255 2 - bitand ] keep port1<< ; : fire-down ( cpu -- ) - [ port1>> HEX: 10 bitor ] keep (>>port1) ; + [ port1>> HEX: 10 bitor ] keep port1<< ; : fire-up ( cpu -- ) - [ port1>> 255 HEX: 10 - bitand ] keep (>>port1) ; + [ port1>> 255 HEX: 10 - bitand ] keep port1<< ; : left-down ( cpu -- ) - [ port1>> HEX: 20 bitor ] keep (>>port1) ; + [ port1>> HEX: 20 bitor ] keep port1<< ; : left-up ( cpu -- ) - [ port1>> 255 HEX: 20 - bitand ] keep (>>port1) ; + [ port1>> 255 HEX: 20 - bitand ] keep port1<< ; : right-down ( cpu -- ) - [ port1>> HEX: 40 bitor ] keep (>>port1) ; + [ port1>> HEX: 40 bitor ] keep port1<< ; : right-up ( cpu -- ) - [ port1>> 255 HEX: 40 - bitand ] keep (>>port1) ; + [ port1>> 255 HEX: 40 - bitand ] keep port1<< ; TUPLE: invaders-gadget < gadget cpu quit? windowed? ; invaders-gadget H{ - { T{ key-down f f "ESC" } [ t over (>>quit?) dup windowed?>> [ close-window ] [ drop ] if ] } + { T{ key-down f f "ESC" } [ t over quit?<< dup windowed?>> [ close-window ] [ drop ] if ] } { T{ key-down f f "BACKSPACE" } [ cpu>> coin-down ] } { T{ key-up f f "BACKSPACE" } [ cpu>> coin-up ] } { T{ key-down f f "1" } [ cpu>> player1-down ] } @@ -377,12 +377,12 @@ M: space-invaders update-video ( value addr cpu -- ) M: invaders-gadget graft* ( gadget -- ) dup cpu>> init-sounds - f over (>>quit?) + f over quit?<< [ system:system-micros swap invaders-process ] curry "Space invaders" threads:spawn drop ; M: invaders-gadget ungraft* ( gadget -- ) - t swap (>>quit?) ; + t swap quit?<< ; : (run) ( title cpu rom-info -- ) over load-rom* t >>windowed? swap open-window ; diff --git a/extra/synth/synth.factor b/extra/synth/synth.factor index 90645e3562..2b9fd8da0b 100755 --- a/extra/synth/synth.factor +++ b/extra/synth/synth.factor @@ -16,7 +16,7 @@ MEMO: single-sine-wave ( samples/wave -- seq ) [ sample-freq>> -rot sine-wave ] keep swap >>data ; : >silent-buffer ( seconds buffer -- buffer ) - [ sample-freq>> * >integer 0 ] [ (>>data) ] [ ] tri ; + [ sample-freq>> * >integer 0 ] [ data<< ] [ ] tri ; TUPLE: harmonic n amplitude ; C: harmonic @@ -32,5 +32,5 @@ C: note harmonic amplitude>> ; : >note ( harmonics note buffer -- buffer ) - [ [ note-harmonic-data ] 2curry map ] [ (>>data) ] [ ] tri ; + [ [ note-harmonic-data ] 2curry map ] [ data<< ] [ ] tri ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index e4838061f5..d8bc90bf73 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -120,7 +120,7 @@ terrain-world H{ read-keyboard keys>> :> keys key-left-shift keys nth - VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player (>>velocity-modifier) + VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player velocity-modifier<< { [ key-1 keys nth 1 f ? ] @@ -128,7 +128,7 @@ terrain-world H{ [ key-3 keys nth 3 f ? ] [ key-4 keys nth 4 f ? ] [ key-5 keys nth 10000 f ? ] - } 0|| player (>>reverse-time) + } 0|| player reverse-time<< key-w keys nth [ player walk-forward ] when key-s keys nth [ player walk-backward ] when @@ -203,7 +203,7 @@ TYPED:: collide ( world: terrain-world player: player -- ) world history>> :> history history length 0 > [ history length reverse-time 1 - - 1 max history set-length - history pop world (>>player) + history pop world player<< ] when ; : tick-player-forward ( world player -- ) diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index 66df0cdb2d..e5d4f408ff 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -52,7 +52,7 @@ tetris-gadget H{ [ tetris>> ?update ] [ relayout-1 ] bi ; M: tetris-gadget graft* ( gadget -- ) - [ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ; + [ [ tick ] curry 100 milliseconds every ] keep alarm<< ; M: tetris-gadget ungraft* ( gadget -- ) [ cancel-alarm f ] change-alarm drop ; diff --git a/extra/tokyo/abstractdb/abstractdb.factor b/extra/tokyo/abstractdb/abstractdb.factor index ea6d20fc2d..fc7f0d5e59 100644 --- a/extra/tokyo/abstractdb/abstractdb.factor +++ b/extra/tokyo/abstractdb/abstractdb.factor @@ -7,4 +7,4 @@ IN: tokyo.abstractdb : ( name -- tokyo-abstractdb ) tcadbnew [ swap tcadbopen drop ] keep - tokyo-abstractdb new [ (>>handle) ] keep ; + tokyo-abstractdb new [ handle<< ] keep ; diff --git a/extra/tokyo/remotedb/remotedb.factor b/extra/tokyo/remotedb/remotedb.factor index c8761e16f3..4ae1f4dced 100644 --- a/extra/tokyo/remotedb/remotedb.factor +++ b/extra/tokyo/remotedb/remotedb.factor @@ -7,4 +7,4 @@ IN: tokyo.remotedb : ( host port -- tokyo-remotedb ) [ tcrdbnew dup ] 2dip tcrdbopen drop - tokyo-remotedb new [ (>>handle) ] keep ; + tokyo-remotedb new [ handle<< ] keep ; diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 401ac205d6..9b4819d3aa 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -31,7 +31,7 @@ TUPLE: avl-node < node balance ; : single-rotate ( node -- node ) 0 >>balance 0 over node+link - (>>balance) rotate ; + balance<< rotate ; : pick-balances ( a node -- balance balance ) balance>> { @@ -44,8 +44,8 @@ TUPLE: avl-node < node balance ; [ node+link [ node-link current-side get neg - over pick-balances rot 0 swap (>>balance) - ] keep (>>balance) + over pick-balances rot 0 swap balance<< + ] keep balance<< ] keep swap >>balance dup node+link [ rotate ] with-other-side over set-node+link rotate ; @@ -74,7 +74,7 @@ DEFER: avl-set : (avl-set) ( value key node -- node taller? ) 2dup key>> = [ - -rot pick (>>key) over (>>value) f + -rot pick key<< over value<< f ] [ avl-insert ] if ; : avl-set ( value key node -- node taller? ) @@ -85,8 +85,8 @@ M: avl set-at ( value key node -- node ) : delete-select-rotate ( node -- node shorter? ) dup node+link balance>> zero? [ - current-side get neg over (>>balance) - current-side get over node+link (>>balance) rotate f + current-side get neg over balance<< + current-side get over node+link balance<< rotate f ] [ select-rotate t ] if ; @@ -100,7 +100,7 @@ M: avl set-at ( value key node -- node ) : balance-delete ( node -- node shorter? ) current-side get over balance>> { - { [ dup zero? ] [ drop neg over (>>balance) f ] } + { [ dup zero? ] [ drop neg over balance<< f ] } { [ dupd = ] [ drop 0 >>balance t ] } [ dupd neg increase-balance rebalance-delete ] } cond ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 79c19416a0..3b39bfe642 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -14,20 +14,20 @@ TUPLE: splay < tree ; : rotate-right ( node -- node ) dup left>> - [ right>> swap (>>left) ] 2keep - [ (>>right) ] keep ; + [ right>> swap left<< ] 2keep + [ right<< ] keep ; : rotate-left ( node -- node ) dup right>> - [ left>> swap (>>right) ] 2keep - [ (>>left) ] keep ; + [ left>> swap right<< ] 2keep + [ left<< ] keep ; : link-right ( left right key node -- left right key node ) - swap [ [ swap (>>left) ] 2keep + swap [ [ swap left<< ] 2keep nip dup left>> ] dip swap ; : link-left ( left right key node -- left right key node ) - swap [ rot [ (>>right) ] 2keep + swap [ rot [ right<< ] 2keep drop dup right>> swapd ] dip swap ; : cmp ( key node -- obj node <=> ) @@ -61,23 +61,23 @@ DEFER: (splay) } case ; : assemble ( head left right node -- root ) - [ right>> swap (>>left) ] keep - [ left>> swap (>>right) ] keep - [ swap left>> swap (>>right) ] 2keep - [ swap right>> swap (>>left) ] keep ; + [ right>> swap left<< ] keep + [ left>> swap right<< ] keep + [ swap left>> swap right<< ] 2keep + [ swap right>> swap left<< ] keep ; : splay-at ( key node -- node ) [ T{ node } clone dup dup ] 2dip (splay) nip assemble ; : do-splay ( key tree -- ) - [ root>> splay-at ] keep (>>root) ; + [ root>> splay-at ] keep root<< ; : splay-split ( key tree -- node node ) 2dup do-splay root>> cmp +lt+ = [ - nip dup left>> swap f over (>>left) + nip dup left>> swap f over left<< ] [ - nip dup right>> swap f over (>>right) swap + nip dup right>> swap f over right<< swap ] if ; : get-splay ( key tree -- node ? ) @@ -95,7 +95,7 @@ DEFER: (splay) : splay-join ( n2 n1 -- node ) splay-largest [ - [ (>>right) ] keep + [ right<< ] keep ] [ drop f ] if* ; @@ -104,19 +104,19 @@ DEFER: (splay) [ get-splay nip ] keep [ dup dec-count dup right>> swap left>> splay-join - swap (>>root) + swap root<< ] [ drop ] if* ; : set-splay ( value key tree -- ) - 2dup get-splay [ 2nip (>>value) ] [ + 2dup get-splay [ 2nip value<< ] [ drop dup inc-count 2dup splay-split rot - [ [ swapd ] dip node boa ] dip (>>root) + [ [ swapd ] dip node boa ] dip root<< ] if ; : new-root ( value key tree -- ) 1 >>count - [ swap ] dip (>>root) ; + [ swap ] dip root<< ; M: splay set-at ( value key tree -- ) dup root>> [ set-splay ] [ new-root ] if ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 821aceaab1..d56e338234 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -55,7 +55,7 @@ CONSTANT: right 1 go-left? xor [ left>> ] [ right>> ] if ; : set-node-link@ ( left parent ? -- ) - go-left? xor [ (>>left) ] [ (>>right) ] if ; + go-left? xor [ left<< ] [ right<< ] if ; : node-link ( node -- child ) f node-link@ ; diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 06f1de6bc8..249698e8dc 100644 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -78,7 +78,7 @@ M: list focusable-child* drop t ; dup list-empty? [ 2drop ] [ - [ control-value length rem ] [ (>>index) ] [ ] tri + [ control-value length rem ] [ index<< ] [ ] tri [ relayout-1 ] [ scroll>selected ] bi ] if ; diff --git a/extra/variables/variables.factor b/extra/variables/variables.factor index 705e1f1945..e4632d04ea 100644 --- a/extra/variables/variables.factor +++ b/extra/variables/variables.factor @@ -72,7 +72,7 @@ PREDICATE: global-variable < variable : [global-getter] ( box -- quot ) '[ _ value>> ] ; : [global-setter] ( box -- quot ) - '[ _ (>>value) ] ; + '[ _ value<< ] ; : define-global ( word -- ) global-box new [ [global-getter] ] [ [global-setter] ] bi (define-variable) ;