steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Language change: tuple slot setter words with stack effect ( value object -- ) are now named FOO<< instead of (>>FOO)

db4
Slava Pestov 2010-05-05 16:52:54 -04:00
parent 98db8b5e78
commit 627295f094
123 changed files with 441 additions and 450 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/fortran/fortran.factor
View File

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

12
basis/bitstreams/bitstreams.factor
View File

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

2
basis/boxes/boxes.factor
View File

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

2
basis/checksums/md5/md5.factor
View File

@ -29,7 +29,7 @@ M: md5 initialize-checksum-state drop <md5-state> ;
: update-md5 ( md5 -- )
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
[ (>>old-state) ] [ (>>state) ] bi ;
[ old-state<< ] [ state<< ] bi ;
CONSTANT: T
$[

2
basis/checksums/sha/sha.factor
View File

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

2
basis/circular/circular.factor
View File

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

4
basis/classes/struct/struct.factor
View File

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

2
basis/compiler/cfg/block-joining/block-joining.factor
View File

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

2
basis/compiler/cfg/dependence/dependence.factor
View File

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

10
basis/compiler/cfg/gc-checks/gc-checks.factor
View File

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

4
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
View File

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

4
basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
View File

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

2
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

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

2
basis/compiler/cfg/linear-scan/numbering/numbering.factor
View File

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

6
basis/compiler/cfg/utilities/utilities.factor
View File

@ -50,9 +50,9 @@ SYMBOL: visited
:: insert-basic-block ( from to insns -- )
! Insert basic block on the edge between 'from' and 'to'.
<basic-block> :> 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 ;

4
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

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

2
basis/compiler/tree/propagation/inlining/inlining.factor
View File

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

2
basis/compiler/tree/recursive/recursive.factor
View File

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

2
basis/compression/huffman/huffman.factor
View File

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

8
basis/core-graphics/types/types.factor
View File

@ -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
: <CGRect> ( x y w h -- rect )
[ CGPoint <struct-boa> ] [ CGSize <struct-boa> ] 2bi*

4
basis/cpu/ppc/linux/linux.factor
View File

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

2
basis/delegate/delegate.factor
View File

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

8
basis/dlists/dlists.factor
View File

@ -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 <dlist-node> dup dup set-next-prev ] keep
[ (>>front) ] keep
[ front<< ] keep
set-back-to-front ;
M: dlist push-back* ( obj dlist -- dlist-node )
[ back>> f <dlist-node> ] keep
[ back>> set-next-when ] 2keep
[ (>>back) ] 2keep
[ back<< ] 2keep
set-front-to-back ;
ERROR: empty-dlist ;

6
basis/ftp/server/server.factor
View File

@ -83,7 +83,7 @@ C: <ftp-disconnect> 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> 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 )
<promise> client get (>>extra-connection)
<promise> client get extra-connection<<
random-local-server
[ [ passive-loop ] curry in-thread ]
[ addr>> port>> ] bi ;

2
basis/furnace/chloe-tags/chloe-tags.factor
View File

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

16
basis/game/input/xinput/xinput.factor
View File

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

2
basis/help/definitions/definitions.factor
View File

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

2
basis/help/tips/tips.factor
View File

@ -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<< ;
: <tip> ( content -- tip ) f tip boa ;

2
basis/hints/hints-tests.factor
View File

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

8
basis/images/jpeg/jpeg.factor
View File

@ -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 <jpeg-color-info>
@ -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:<msb0-bit-reader> jpeg> (>>bitstream)
>byte-array bs:<msb0-bit-reader> jpeg> bitstream<<
jpeg>
[ bitstream>> ]
[ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi

2
basis/io/backend/windows/nt/nt.factor
View File

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

4
basis/io/encodings/iso2022/iso2022.factor
View File

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

6
basis/io/launcher/windows/nt/nt.factor
View File

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

2
basis/io/monitors/monitors.factor
View File

@ -24,7 +24,7 @@ TUPLE: monitor < disposable path queue timeout ;
M: monitor timeout timeout>> ;
M: monitor set-timeout (>>timeout) ;
M: monitor set-timeout timeout<< ;
<PRIVATE

2
basis/io/ports/ports.factor
View File

@ -15,7 +15,7 @@ TUPLE: port < disposable handle timeout ;
M: port timeout timeout>> ;
M: port set-timeout (>>timeout) ;
M: port set-timeout timeout<< ;
: <port> ( handle class -- port )
new-disposable swap >>handle ; inline

2
basis/io/sockets/windows/windows.factor
View File

@ -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 )
<win32-socket> |dispose dup add-completion ;

4
basis/io/streams/limited/limited.factor
View File

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

4
basis/math/rectangles/rectangles.factor
View File

@ -58,8 +58,8 @@ M: rect contains-point?
[ rect-bounds ] dip vmin <rect> ;
: set-rect-bounds ( rect1 rect -- )
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
[ [ loc>> ] dip loc<< ]
[ [ dim>> ] dip dim<< ]
2bi ; inline
USE: vocabs.loader

4
basis/math/vectors/simd/simd-docs.factor
View File

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

2
basis/models/models.factor
View File

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

16
basis/peg/peg.factor
View File

@ -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)
] [

6
basis/prettyprint/sections/sections.factor
View File

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

14
basis/random/sfmt/sfmt.factor
View File

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

2
basis/refs/refs.factor
View File

@ -30,7 +30,7 @@ M: ref delete-ref ref-off ;
TUPLE: obj-ref obj ;
C: <obj-ref> 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 ;

2
basis/regexp/dfa/dfa.factor
View File

@ -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 )
<transition-table>

4
basis/sequences/parser/parser.factor
View File

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

2
basis/tools/walker/walker.factor
View File

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

2
basis/ui/backend/cocoa/cocoa.factor
View File

@ -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 <window-handle> world (>>handle)
view window <window-handle> world handle<<
window f -> makeKeyAndOrderFront: ;
M: cocoa-ui-backend (close-window) ( handle -- )

6
basis/ui/backend/windows/windows.factor
View File

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

2
basis/ui/backend/x11/x11.factor
View File

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

2
basis/ui/clipboards/clipboards.factor
View File

@ -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 ) "" clipboard boa ;

4
basis/ui/gadgets/gadgets.factor
View File

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

4
basis/ui/gadgets/labels/labels.factor
View File

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

4
basis/ui/gadgets/packs/packs.factor
View File

@ -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 ;
: <pack> ( orientation -- pack )
pack new

6
basis/ui/gadgets/worlds/worlds.factor
View File

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

4
basis/ui/gestures/gestures.factor
View File

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

2
basis/ui/tools/browser/history/history-tests.factor
View File

@ -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> "history" set

4
basis/ui/tools/listener/listener-tests.factor
View File

@ -16,7 +16,7 @@ IN: ui.tools.listener.tests
[ ] [ <promise> "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> "promise" set ] unit-test
[
self "interactor" get (>>thread)
self "interactor" get thread<<
"interactor" get stream-readln "promise" get fulfill
] "Interactor test" spawn drop

2
basis/ui/ui.factor
View File

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

4
basis/unrolled-lists/unrolled-lists.factor
View File

@ -47,7 +47,7 @@ M: unrolled-list clear-deque
unroll-factor 0 <array>
[ 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 <array> [ set-first ] keep
] dip [ f node boa dup ] keep
dup [ (>>next) ] [ 2drop ] if ; inline
dup [ next<< ] [ 2drop ] if ; inline
: normalize-front ( list -- )
dup front>> [

2
basis/values/values.factor
View File

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

2
basis/xml/data/data.factor
View File

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

8
basis/xmode/catalog/catalog.factor
View File

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

14
basis/xmode/loader/loader.factor
View File

@ -45,7 +45,7 @@ RULE: MARK_PREVIOUS mark-previous-rule parse-rule-tag
TAG: KEYWORDS parse-rule-tag
rule-set get ignore-case?>> <keyword-map>
swap children-tags [ over parse-keyword-tag ] each
swap (>>keywords) ;
swap keywords<< ;
: ?<regexp> ( string/f -- regexp/f )
dup [ rule-set get ignore-case?>> <?insensitive-regexp> ] when ;
@ -53,13 +53,13 @@ TAG: KEYWORDS parse-rule-tag
: (parse-rules-tag) ( tag -- rule-set )
<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" ?<regexp> (>>digit-re) }
{ "SET" string>rule-set-name name<< }
{ "IGNORE_CASE" string>boolean ignore-case?<< }
{ "HIGHLIGHT_DIGITS" string>boolean highlight-digits?<< }
{ "DIGIT_RE" ?<regexp> 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 )

14
basis/xmode/loader/syntax/syntax.factor
View File

@ -52,24 +52,24 @@ SYNTAX: RULE:
swap position-attrs <matcher> ;
: 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 ] , ;

8
basis/xmode/marker/marker.factor
View File

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

4
basis/xmode/rules/rules.factor
View File

@ -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 [
[ <escape-rule> ] dip
2dup (>>escape-rule)
2dup escape-rule<<
add-rule
] [
2drop

6
core/classes/tuple/tuple-docs.factor
View File

@ -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> ( -- employee )"

2
core/classes/tuple/tuple-tests.factor
View File

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

8
core/growable/growable.factor
View File

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

2
core/hashtables/hashtables.factor
View File

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

4
core/io/io.factor
View File

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

2
core/lexer/lexer.factor
View File

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

12
core/slots/slots-docs.factor
View File

@ -28,9 +28,9 @@ $nl
"The following uses writers, and requires some stack shuffling:"
{ $code
"<email>"
" \"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
"<email>"
" [ (>>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:"

2
core/slots/slots-tests.factor
View File

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

2
core/slots/slots.factor
View File

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

4
core/source-files/source-files.factor
View File

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

2
core/strings/parser/parser.factor
View File

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

2
core/syntax/syntax.factor
View File

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

2
core/vocabs/parser/parser.factor
View File

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

16
extra/asn1/asn1.factor
View File

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

2
extra/benchmark/chameneos-redux/chameneos-redux.factor
View File

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

2
extra/c/lexer/lexer.factor
View File

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

4
extra/classes/struct/vectored/vectored.factor
View File

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

254
extra/cpu/8080/emulator/emulator.factor
View File

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

2
extra/cpu/8080/test/test.factor
View File

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

1
extra/enter/authors.txt
View File

@ -1 +0,0 @@
Sam Anklesaria

8
extra/enter/enter.factor
View File

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

4
extra/fullscreen/fullscreen.factor
View File

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

2
extra/game/loop/loop.factor
View File

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

32
extra/game/models/obj/obj.factor
View File

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

6
extra/game/models/util/util.factor
View File

@ -37,8 +37,8 @@ M:: indexed-seq set-nth ( elt n seq -- )
M: indexed-seq new-resizable
[ dseq>> ] [ iseq>> ] [ rassoc>> ] tri <indexed-seq>
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 ;

8
extra/io/serial/unix/unix.factor
View File

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

2
extra/irc/client/internals/internals.factor
View File

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

4
extra/irc/client/participants/participants.factor
View File

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

2
extra/irc/messages/base/base.factor
View File

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

2
extra/irc/messages/parser/parser.factor
View File

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

6
extra/joystick-demo/joystick-demo.factor
View File

@ -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 ] <border-button>
shelf over add-gadget drop
] map gadget (>>buttons) ;
] map gadget buttons<< ;
: add-button-gadgets ( gadget shelf -- gadget shelf )
[ (add-button-gadgets) ] 2keep ;

2
extra/key-caps/key-caps.factor
View File

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

8
extra/managed-server/chat/chat.factor
View File

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

Some files were not shown because too many files have changed in this diff Show More