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

Merge branch 'row-polymorphism' of git://factorcode.org/git/factor into row-polymorphism

db4
Slava Pestov 2010-03-11 17:23:18 +13:00
parent a926576993 f24a74f66c
commit 0de6d2005e
119 changed files with 2542 additions and 483 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/binary-search/binary-search.factor
View File

@ -21,7 +21,7 @@ DEFER: (search)
: keep-searching ( seq quot -- slice )
[ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline
: (search) ( quot: ( elt -- <=> ) seq -- i elt )
: (search) ( ... quot: ( ... elt -- ... <=> ) seq -- ... i elt )
dup length 1 <= [
finish
] [

4
basis/circular/circular.factor
View File

@ -64,7 +64,7 @@ TUPLE: circular-iterator
<PRIVATE
: (circular-while) ( iterator quot: ( obj -- ? ) -- )
: (circular-while) ( ... iterator quot: ( ... obj -- ... ? ) -- ... )
[ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
rot [ [ dup n>> >>last-start ] dip ] when
over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
@ -75,5 +75,5 @@ TUPLE: circular-iterator
PRIVATE>
: circular-while ( circular quot: ( obj -- ? ) -- )
: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
[ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline

6
basis/cocoa/enumeration/enumeration.factor
View File

@ -15,7 +15,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
@
] with-destructors ; inline
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
:: (NSFastEnumeration-each) ( ... object quot: ( ... elt -- ) state stackbuf count -- ... )
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
state itemsPtr>> [ items-count id <c-direct-array> ] [ stackbuf ] if* :> items
@ -23,10 +23,10 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
object quot state stackbuf count (NSFastEnumeration-each)
] unless ; inline recursive
: NSFastEnumeration-each ( object quot -- )
: NSFastEnumeration-each ( ... object quot: ( ... elt -- ... ) -- ... )
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
: NSFastEnumeration-map ( object quot -- vector )
: NSFastEnumeration-map ( ... object quot: ( ... elt -- ... newelt ) -- ... vector )
NS-EACH-BUFFER-SIZE <vector>
[ '[ @ _ push ] NSFastEnumeration-each ] keep ; inline

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

@ -39,7 +39,7 @@ predecessors-valid? dominance-valid? loops-valid? ;
: predecessors-changed ( cfg -- cfg )
f >>predecessors-valid? ;
: with-cfg ( cfg quot: ( cfg -- ) -- )
: with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
[ dup cfg ] dip with-variable ; inline
TUPLE: mr { instructions array } word label ;

8
basis/compiler/cfg/representations/preferred/preferred.factor
View File

@ -67,16 +67,16 @@ PRIVATE>
tri
] with-compilation-unit
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
[ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
'[
[ basic-block set ] [
[

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

@ -187,7 +187,7 @@ SYMBOLS: renaming-set needs-renaming? ;
: record-renaming ( from to -- )
2array renaming-set get push needs-renaming? on ;
:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
vreg rep-of :> preferred
preferred required eq?
[ vreg no-renaming ]

4
basis/compiler/cfg/rpo/rpo.factor
View File

@ -38,8 +38,8 @@ SYMBOL: visited
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
dupd '[ _ optimize-basic-block ] each-basic-block ; inline
: needs-post-order ( cfg -- cfg' )
dup post-order drop ;
dup post-order drop ;

4
basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor
View File

@ -47,7 +47,7 @@ SYMBOLS: visited merge-sets levels again? ;
tmp dom-parent to tmp walk
] [ lnode ] if ;
: each-incoming-j-edge ( bb quot: ( from to -- ) -- )
: each-incoming-j-edge ( ... bb quot: ( ... from to -- ... ) -- ... )
[ [ predecessors>> ] keep ] dip
'[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
@ -101,7 +101,7 @@ PRIVATE>
[ compute-merge-set-loop ]
tri ;
: merge-set-each ( bbs quot: ( bb -- ) -- )
: merge-set-each ( ... bbs quot: ( ... bb -- ... ) -- ... )
[ (merge-set) ] dip '[
swap _ [ drop ] if
] 2each ; inline

2
basis/compiler/cfg/stacks/finalize/finalize.factor
View File

@ -27,7 +27,7 @@ IN: compiler.cfg.stacks.finalize
to dead-in to live-in to anticip-in assoc-diff assoc-diff
assoc-diff ;
: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
: each-insertion ( ... assoc bb quot: ( ... vreg loc -- ... ) -- ... )
'[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
ERROR: bad-peek dst loc ;

4
basis/compiler/cfg/tco/tco.factor
View File

@ -29,7 +29,7 @@ IN: compiler.cfg.tco
: word-tail-call? ( bb -- ? )
instructions>> penultimate ##call? ;
: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
: convert-tail-call ( ..a bb quot: ( ..a insn -- ..a tail-insn ) -- ..b )
'[
instructions>>
[ pop* ] [ pop ] [ ] tri
@ -65,4 +65,4 @@ IN: compiler.cfg.tco
: optimize-tail-calls ( cfg -- cfg' )
dup [ optimize-tail-call ] each-basic-block
cfg-changed predecessors-changed ;
cfg-changed predecessors-changed ;

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

@ -65,14 +65,14 @@ SYMBOL: visited
: cfg-has-phis? ( cfg -- ? )
post-order [ has-phis? ] any? ;
: if-has-phis ( bb quot: ( bb -- ) -- )
: if-has-phis ( ..a bb quot: ( ..a bb -- ..b ) -- ..b )
[ dup has-phis? ] dip [ drop ] if ; inline
: each-phi ( bb quot: ( ##phi -- ) -- )
: each-phi ( ... bb quot: ( ... ##phi -- ... ) -- ... )
[ instructions>> ] dip
'[ dup ##phi? [ @ t ] [ drop f ] if ] all? drop ; inline
: each-non-phi ( bb quot: ( insn -- ) -- )
: each-non-phi ( ... bb quot: ( ... insn -- ... ) -- ... )
[ instructions>> ] dip
'[ dup ##phi? [ drop ] _ if ] each ; inline

2
basis/compiler/tests/curry.factor
View File

@ -32,7 +32,7 @@ IN: compiler.tests.curry
compile-call
] unit-test
: foobar ( quot: ( -- ) -- )
: foobar ( quot: ( ..a -- ..b ) -- )
[ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ f ] foobar ] compile-call ] unit-test

2
basis/compiler/tests/optimizer.factor
View File

@ -198,7 +198,7 @@ USE: sorting
USE: binary-search
USE: binary-search.private
: old-binsearch ( elt quot: ( -- ) seq -- elt quot i )
: old-binsearch ( elt quot: ( ..a -- ..b ) seq -- elt quot i )
dup length 1 <= [
from>>
] [

8
basis/compiler/tree/combinators/combinators.factor
View File

@ -5,7 +5,7 @@ arrays stack-checker.inlining namespaces compiler.tree
math.order ;
IN: compiler.tree.combinators
: each-node ( nodes quot: ( node -- ) -- )
: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
dup dup '[
_ [
dup #branch? [
@ -18,7 +18,7 @@ IN: compiler.tree.combinators
] bi
] each ; inline recursive
: map-nodes ( nodes quot: ( node -- node' ) -- nodes )
: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
dup dup '[
@
dup #branch? [
@ -30,7 +30,7 @@ IN: compiler.tree.combinators
] if
] map-flat ; inline recursive
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
dup dup '[
_ keep swap [ drop t ] [
dup #branch? [
@ -49,7 +49,7 @@ IN: compiler.tree.combinators
: sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ;
: until-fixed-point ( #recursive quot: ( node -- ) -- )
: until-fixed-point ( ... #recursive quot: ( ... node -- ... ) -- ... )
over label>> t >>fixed-point drop
[ with-scope ] 2keep
over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ;

2
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -168,7 +168,7 @@ IN: compiler.tree.dead-code.tests
[ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test
: call-recursive-dce-6 ( i quot: ( i -- ? ) -- i )
: call-recursive-dce-6 ( i quot: ( ..a -- ..b ) -- i )
dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
[ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test

2
basis/compiler/tree/escape-analysis/nodes/nodes.factor
View File

@ -10,7 +10,7 @@ GENERIC: escape-analysis* ( node -- )
SYMBOL: next-node
: each-with-next ( seq quot: ( elt -- ) -- )
: each-with-next ( ... seq quot: ( ... elt -- ... ) -- ... )
dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline
: (escape-analysis) ( node -- )

2
basis/compiler/tree/normalization/normalization-tests.factor
View File

@ -14,7 +14,7 @@ IN: compiler.tree.normalization.tests
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
: foo ( quot: ( -- ) -- ) call ; inline recursive
: foo ( ..a quot: ( ..a -- ..b ) -- ..b ) call ; inline recursive
: recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ;

38
basis/compiler/tree/propagation/info/info.factor
View File

@ -31,7 +31,6 @@ class
interval
literal
literal?
length
slots ;
CONSTANT: null-info T{ value-info f null empty-interval }
@ -48,9 +47,7 @@ CONSTANT: object-info T{ value-info f object full-interval }
{ [ over interval-length 0 > ] [ 3drop f f ] }
{ [ pick bignum class<= ] [ 2nip >bignum t ] }
{ [ pick integer class<= ] [ 2nip >fixnum t ] }
{ [ pick float class<= ] [
2nip dup zero? [ drop f f ] [ >float t ] if
] }
{ [ pick float class<= ] [ 2nip dup zero? [ drop f f ] [ >float t ] if ] }
[ 3drop f f ]
} cond
] if ;
@ -74,13 +71,19 @@ UNION: fixed-length array byte-array string ;
] unless
] unless ;
: (slots-with-length) ( length class -- slots )
"slots" word-prop length 1 - f <array> swap prefix ;
: slots-with-length ( seq -- slots )
[ length <literal-info> ] [ class ] bi (slots-with-length) ;
: init-literal-info ( info -- info )
empty-interval >>interval
dup literal>> literal-class >>class
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }
{ [ dup fixed-length? ] [ length <literal-info> >>length ] }
{ [ dup fixed-length? ] [ slots-with-length >>slots ] }
[ drop ]
} cond ; inline
@ -158,11 +161,11 @@ UNION: fixed-length array byte-array string ;
t >>literal?
init-value-info ; foldable
: <sequence-info> ( value -- info )
: <sequence-info> ( length class -- info )
<value-info>
object >>class
swap value-info >>length
init-value-info ; foldable
over >>class
[ (slots-with-length) ] dip swap >>slots
init-value-info ;
: <tuple-info> ( slots class -- info )
<value-info>
@ -185,13 +188,6 @@ DEFER: value-info-intersect
DEFER: (value-info-intersect)
: intersect-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ drop ] }
{ [ over not ] [ nip ] }
[ value-info-intersect ]
} cond ;
: intersect-slot ( info1 info2 -- info )
{
{ [ dup not ] [ nip ] }
@ -215,7 +211,6 @@ DEFER: (value-info-intersect)
[ [ class>> ] bi@ class-and >>class ]
[ [ interval>> ] bi@ interval-intersect >>interval ]
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
[ intersect-lengths >>length ]
[ intersect-slots >>slots ]
} 2cleave
init-value-info ;
@ -236,13 +231,6 @@ DEFER: value-info-union
DEFER: (value-info-union)
: union-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ value-info-union ]
} cond ;
: union-slot ( info1 info2 -- info )
{
{ [ dup not ] [ nip ] }
@ -261,7 +249,6 @@ DEFER: (value-info-union)
[ [ class>> ] bi@ class-or >>class ]
[ [ interval>> ] bi@ interval-union >>interval ]
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
[ union-lengths >>length ]
[ union-slots >>slots ]
} 2cleave
init-value-info ;
@ -293,7 +280,6 @@ DEFER: (value-info-union)
{ [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
{ [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
{ [ 2dup literals<= not ] [ f ] }
{ [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
{ [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
[ t ]
} cond 2nip

3
basis/compiler/tree/propagation/recursive/recursive.factor
View File

@ -45,8 +45,7 @@ IN: compiler.tree.propagation.recursive
[ clone ] dip
[ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ]
[ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ]
[ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ]
tri
bi
] if
] if ;

9
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -9,8 +9,6 @@ IN: compiler.tree.propagation.slots
! Propagation of immutable slots and array lengths
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( word -- ? )
{ <array> <byte-array> (byte-array) <string> } member-eq? ;
@ -23,9 +21,9 @@ UNION: fixed-length-sequence array byte-array string ;
} at ;
: propagate-sequence-constructor ( #call word -- infos )
[ in-d>> first <sequence-info> ]
[ constructor-output-class <class-info> ]
bi* value-info-intersect 1array ;
[ in-d>> first value-info ]
[ constructor-output-class ] bi*
<sequence-info> 1array ;
: fold-<tuple-boa> ( values class -- info )
[ [ literal>> ] map ] dip prefix >tuple
@ -72,7 +70,6 @@ UNION: fixed-length-sequence array byte-array string ;
: value-info-slot ( slot info -- info' )
{
{ [ over 0 = ] [ 2drop fixnum <class-info> ] }
{ [ 2dup length-accessor? ] [ nip length>> ] }
{ [ dup literal?>> ] [ literal>> literal-info-slot ] }
[ [ 1 - ] [ slots>> ] bi* ?nth ]
} cond [ object-info ] unless* ;

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

@ -102,7 +102,7 @@ SYMBOL: changed?
recursive-nesting get pop*
] each ;
: while-changing ( quot: ( -- ) -- )
: while-changing ( ... quot: ( ... -- ... ) -- ... )
changed? off
[ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
inline recursive

4
basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
View File

@ -38,10 +38,10 @@ TUPLE: empty-tuple ;
} [ [ ] swap [ test-unboxing ] curry unit-test ] each
! A more complicated example
: impeach-node ( quot: ( node -- ) -- )
: impeach-node ( quot: ( ..a -- ..b ) -- )
[ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
: bleach-node ( quot: ( ..a -- ..b ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test

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

@ -30,7 +30,7 @@ TUPLE: huffman-code
[ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
[ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
:: huffman-each ( tdesc quot: ( huffman-code -- ) -- )
:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )
<huffman-code> :> code
tdesc
[

2
basis/concurrency/mailboxes/mailboxes-docs.factor
View File

@ -21,7 +21,7 @@ HELP: block-unless-pred
{ $values
{ "mailbox" mailbox }
{ "timeout" "a " { $link duration } " or " { $link f } }
{ "pred" { $quotation "( obj -- ? )" } }
{ "pred" { $quotation "( ... message -- ... ? )" } }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;

2
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -23,7 +23,7 @@ TUPLE: mailbox threads data ;
: wait-for-mailbox ( mailbox timeout -- )
[ threads>> ] dip "mailbox" wait ;
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
mailbox data>> pred dlist-any? [
mailbox timeout wait-for-mailbox
mailbox timeout pred block-unless-pred

4
basis/debugger/debugger.factor
View File

@ -328,6 +328,10 @@ M: lexer-error error-help
M: bad-effect summary
drop "Bad stack effect declaration" ;
M: invalid-effect-variable summary
drop "Stack effect variables can only occur as the first input or output" ;
M: effect-variable-can't-have-type summary
drop "Stack effect variables cannot have a declared type" ;
M: bad-escape error.
"Bad escape code: \\" write

18
basis/dlists/dlists.factor
View File

@ -54,16 +54,16 @@ M: dlist-node node-value obj>> ;
: set-front-to-back ( dlist -- )
dup front>> [ dup back>> >>front ] unless drop ; inline
: (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
: (dlist-find-node) ( ... dlist-node quot: ( ... node -- ... ? ) -- ... node/f ? )
over [
[ call ] 2keep rot
[ drop t ] [ [ next>> ] dip (dlist-find-node) ] if
] [ 2drop f f ] if ; inline recursive
: dlist-find-node ( dlist quot -- node/f ? )
: dlist-find-node ( ... dlist quot: ( ... node -- ... ? ) -- ... node/f ? )
[ front>> ] dip (dlist-find-node) ; inline
: dlist-each-node ( dlist quot -- )
: dlist-each-node ( ... dlist quot: ( ... node -- ... ) -- ... )
'[ @ f ] dlist-find-node 2drop ; inline
: unlink-node ( dlist-node -- )
@ -114,10 +114,10 @@ M: dlist pop-back* ( dlist -- )
] keep
normalize-front ;
: dlist-find ( dlist quot -- obj/f ? )
: dlist-find ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-any? ( dlist quot -- ? )
: dlist-any? ( ... dlist quot: ( ... value -- ... ? ) -- ... ? )
dlist-find nip ; inline
M: dlist deque-member? ( value dlist -- ? )
@ -130,7 +130,7 @@ M: dlist delete-node ( dlist-node dlist -- )
[ drop unlink-node ]
} cond ;
: delete-node-if* ( dlist quot -- obj/f ? )
: delete-node-if* ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f ? )
dupd dlist-find-node [
dup [
[ swap delete-node ] keep obj>> t
@ -141,7 +141,7 @@ M: dlist delete-node ( dlist-node dlist -- )
2drop f f
] if ; inline
: delete-node-if ( dlist quot -- obj/f )
: delete-node-if ( ... dlist quot: ( ... value -- ... ? ) -- ... obj/f )
'[ obj>> @ ] delete-node-if* drop ; inline
M: dlist clear-deque ( dlist -- )
@ -149,7 +149,7 @@ M: dlist clear-deque ( dlist -- )
f >>back
drop ;
: dlist-each ( dlist quot -- )
: dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... )
'[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
@ -157,7 +157,7 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
: dlist-filter ( dlist quot -- dlist' )
: dlist-filter ( ... dlist quot: ( ... value -- ... ? ) -- ... dlist' )
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
M: dlist clone

2
basis/documents/documents-docs.factor
View File

@ -42,7 +42,7 @@ HELP: doc-lines
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;
HELP: each-line
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( string -- )" } } }
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( ... line -- ... )" } } }
{ $description "Applies the quotation to each line in the range." }
{ $notes "The range is created by calling " { $link <slice> } "." }
{ $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ;

6
basis/documents/documents.factor
View File

@ -55,12 +55,12 @@ TUPLE: document < model locs undos redos inside-undo? ;
to first line# =
[ to second ] [ line# document doc-line length ] if ;
: each-line ( from to quot -- )
: each-line ( ... from to quot: ( ... line -- ... ) -- ... )
2over = [ 3drop ] [
[ [ first ] bi@ [a,b] ] dip each
] if ; inline
: map-lines ( from to quot -- results )
: map-lines ( ... from to quot: ( ... line -- ... result ) -- ... results )
collector [ each-line ] dip ; inline
: start/end-on-line ( from to line# document -- n1 n2 )
@ -109,7 +109,7 @@ CONSTANT: doc-start { 0 0 }
: entire-doc ( document -- start end document )
[ [ doc-start ] dip doc-end ] keep ;
: with-undo ( document quot: ( document -- ) -- )
: with-undo ( ..a document quot: ( ..a document -- ..b ) -- ..b )
[ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline
PRIVATE>

2
basis/farkup/farkup.factor
View File

@ -70,7 +70,7 @@ DEFER: (parse-paragraph)
{ CHAR: % inline-code }
} at ;
: or-simple-title ( url title/f quot: ( title -- title' ) -- url title' )
: or-simple-title ( ... url title/f quot: ( ... title -- ... title' ) -- ... url title' )
[ "" like dup simple-link-title ] if* ; inline
: parse-link ( string -- paragraph-list )

1
basis/furnace/auth/auth.factor
View File

@ -14,6 +14,7 @@ furnace.redirection
furnace.boilerplate
furnace.auth.providers
furnace.auth.providers.db ;
FROM: assocs => change-at ;
IN: furnace.auth
SYMBOL: logged-in-user

1
basis/furnace/scopes/scopes.factor
View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors assocs destructors
db.tuples db.types furnace.cache ;
FROM: assocs => change-at ;
IN: furnace.scopes
TUPLE: scope < server-state namespace changed? ;

25
basis/help/lint/checks/checks.factor
View File

@ -36,11 +36,27 @@ SYMBOL: vocab-articles
first rest [ first ] map
] unless ;
: extract-value-effects ( element -- seq )
\ $values swap elements dup empty? [
first rest [
\ $quotation swap elements dup empty? [ drop f ] [
first second
] if
] map
] unless ;
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
[ dup pair? [ first ] when effect>string ] map prune ;
: effect-effects ( word -- seq )
stack-effect in>> [
dup pair?
[ second dup effect? [ effect>string ] [ drop f ] if ]
[ drop f ] if
] map ;
: contains-funky-elements? ( element -- ? )
{
$shuffle
@ -70,9 +86,16 @@ SYMBOL: vocab-articles
[ effect-values ]
[ extract-values ]
bi* sequence=
]
]
} 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
: check-value-effects ( word element -- )
[ effect-effects ]
[ extract-value-effects ]
bi* [ 2dup and [ = ] [ 2drop t ] if ] 2all?
[ "$quotation documentation in $values don't match stack effect" simple-lint-error ]
unless ;
: check-nulls ( element -- )
\ $values swap elements
null swap deep-member?

18
basis/help/lint/lint.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs continuations fry help help.lint.checks
help.topics io kernel namespaces parser sequences
source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors listener ;
USING: assocs combinators continuations fry help
help.lint.checks help.topics io kernel namespaces parser
sequences source-files.errors vocabs.hierarchy vocabs words
classes locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ;
FROM: vocabs => child-vocabs ;
IN: help.lint
@ -49,10 +49,12 @@ PRIVATE>
[ with-file-vocabs ] vocabs-quot set
dup word-help [
[ >link ] keep '[
_ dup word-help
[ check-values ]
[ check-class-description ]
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
_ dup word-help {
[ check-values ]
[ check-value-effects ]
[ check-class-description ]
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ]
} 2cleave
] check-something
] [ drop ] if ;

2
basis/io/directories/search/search.factor
View File

@ -41,7 +41,7 @@ TUPLE: directory-iterator path bfs queue ;
[ nip ] if
] if ;
:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
:: iterate-directory-entries ( ... iter quot: ( ... obj -- ... obj ) -- ... directory-entry/f )
iter next-directory-entry [
quot call
[ iter quot iterate-directory-entries ] unless*

8
basis/lists/lists-docs.factor
View File

@ -127,19 +127,19 @@ HELP: unswons
{ leach foldl lmap>array } related-words
HELP: leach
{ $values { "list" list } { "quot" { $quotation "( obj -- )" } } }
{ $values { "list" list } { "quot" { $quotation "( ... elt -- ... )" } } }
{ $description "Call the quotation for each item in the list." } ;
HELP: foldl
{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
HELP: foldr
{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
HELP: lmap
{ $values { "list" list } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } }
{ $values { "list" list } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "result" "the final result" } }
{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
HELP: lreverse

10
basis/lists/lists.factor
View File

@ -55,16 +55,16 @@ M: object nil? drop f ;
PRIVATE>
: leach ( list quot: ( elt -- ) -- )
: leach ( ... list quot: ( ... elt -- ... ) -- ... )
over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
: lmap ( list quot: ( elt -- ) -- result )
: lmap ( ... list quot: ( ... elt -- ... newelt ) -- ... result )
over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive
: foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
: foldl ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd leach ; inline
:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
:: foldr ( ... list identity quot: ( ... prev elt -- ... next ) -- ... result )
list nil? [ identity ] [
list cdr identity quot foldr
list car quot call
@ -87,7 +87,7 @@ PRIVATE>
: sequence>list ( sequence -- list )
<reversed> nil [ swons ] reduce ;
: lmap>array ( list quot -- array )
: lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array )
collector [ leach ] dip { } like ; inline
: list>array ( list -- array )

2
basis/math/matrices/elimination/elimination.factor
View File

@ -11,7 +11,7 @@ SYMBOL: matrix
: nth-row ( row# -- seq ) matrix get nth ;
: change-row ( row# quot: ( seq -- seq ) -- )
: change-row ( ..a row# quot: ( ..a seq -- ..b seq ) -- ..b )
matrix get swap change-nth ; inline
: exchange-rows ( row# row# -- ) matrix get exchange ;

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

@ -20,7 +20,7 @@ SYNTAX: RECT: scan-object scan-object <rect> suffix! ;
: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
: with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
: with-rect-extents ( ..a+b rect1 rect2 loc-quot: ( ..a loc1 loc2 -- ..c ) ext-quot: ( ..b ext1 ext2 -- ..d ) -- ..c+d )
[ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;

3
basis/regexp/minimize/minimize.factor
View File

@ -3,6 +3,7 @@
USING: kernel sequences regexp.transition-tables fry assocs
accessors locals math sorting arrays sets hashtables regexp.dfa
combinators.short-circuit regexp.classes ;
FROM: assocs => change-at ;
IN: regexp.minimize
: table>state-numbers ( table -- assoc )
@ -51,7 +52,7 @@ IN: regexp.minimize
<reversed>
>hashtable ;
:: (while-changes) ( obj quot: ( obj -- obj' ) comp: ( obj -- key ) old-key -- obj )
:: (while-changes) ( ..a obj quot: ( ..a obj -- ..b obj' ) comp: ( ..b obj' -- ..a key ) old-key -- ..a obj )
obj quot call :> new-obj
new-obj comp call :> new-key
new-key old-key =

6
basis/regexp/regexp.factor
View File

@ -69,7 +69,7 @@ PRIVATE>
dup next-match>>
execute( i string regexp -- i start end ? ) ; inline
:: (each-match) ( i string regexp quot: ( start end string -- ) -- )
:: (each-match) ( ... i string regexp quot: ( ... start end string -- ... ) -- ... )
i string regexp do-next-match [| i' start end |
start end string quot call
i' string regexp quot (each-match)
@ -80,10 +80,10 @@ PRIVATE>
PRIVATE>
: each-match ( string regexp quot: ( start end string -- ) -- )
: each-match ( ... string regexp quot: ( ... start end string -- ... ) -- ... )
[ prepare-match-iterator ] dip (each-match) ; inline
: map-matches ( string regexp quot: ( start end string -- obj ) -- seq )
: map-matches ( ... string regexp quot: ( ... start end string -- ... obj ) -- ... seq )
collector [ each-match ] dip >array ; inline
: all-matching-slices ( string regexp -- seq )

12
basis/sequences/deep/deep-docs.factor
View File

@ -2,27 +2,27 @@ USING: help.syntax help.markup kernel sequences ;
IN: sequences.deep
HELP: deep-each
{ $values { "obj" object } { "quot" { $quotation "( elt -- )" } } }
{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... )" } } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder." }
{ $see-also each } ;
HELP: deep-map
{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "newobj" "the mapped object" } }
{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... elt' )" } } { "newobj" "the mapped object" } }
{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." }
{ $see-also map } ;
HELP: deep-filter
{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a sequence" } }
{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "seq" "a sequence" } }
{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." }
{ $see-also filter } ;
HELP: deep-find
{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "elt" "an element" } }
{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "elt" "an element" } }
{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." }
{ $see-also find } ;
HELP: deep-any?
{ $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests whether the given object or any subnode satisfies the given quotation." }
{ $see-also any? } ;
@ -31,7 +31,7 @@ HELP: flatten
{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ;
HELP: deep-map!
{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } }
{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... elt' )" } } }
{ $description "Modifies each sub-node of an object in place, in preorder, and returns that object." }
{ $see-also map! } ;

16
basis/sequences/deep/deep.factor
View File

@ -12,30 +12,30 @@ M: integer branch? drop f ;
M: string branch? drop f ;
M: object branch? drop f ;
: deep-each ( obj quot: ( elt -- ) -- )
: deep-each ( ... obj quot: ( ... elt -- ... ) -- ... )
[ call ] 2keep over branch?
[ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive
: deep-map ( obj quot: ( elt -- elt' ) -- newobj )
: deep-map ( ... obj quot: ( ... elt -- ... elt' ) -- ... newobj )
[ call ] keep over branch?
[ '[ _ deep-map ] map ] [ drop ] if ; inline recursive
: deep-filter ( obj quot: ( elt -- ? ) -- seq )
: deep-filter ( ... obj quot: ( ... elt -- ... ? ) -- ... seq )
over [ selector [ deep-each ] dip ] dip
dup branch? [ like ] [ drop ] if ; inline recursive
: (deep-find) ( obj quot: ( elt -- ? ) -- elt ? )
: (deep-find) ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ? )
[ call ] 2keep rot [ drop t ] [
over branch? [
[ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean
] [ 2drop f f ] if
] if ; inline recursive
: deep-find ( obj quot -- elt ) (deep-find) drop ; inline
: deep-find ( ... obj quot: ( ... elt -- ... ? ) -- ... elt ) (deep-find) drop ; inline
: deep-any? ( obj quot -- ? ) (deep-find) nip ; inline
: deep-any? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? ) (deep-find) nip ; inline
: deep-all? ( obj quot -- ? )
: deep-all? ( ... obj quot: ( ... elt -- ... ? ) -- ... ? )
'[ @ not ] deep-any? not ; inline
: deep-member? ( obj seq -- ? )
@ -48,7 +48,7 @@ M: object branch? drop f ;
_ swap dup branch? [ subseq? ] [ 2drop f ] if
] deep-find >boolean ;
: deep-map! ( obj quot: ( elt -- elt' ) -- obj )
: deep-map! ( ... obj quot: ( ... elt -- ... elt' ) -- ... obj )
over branch? [
'[ _ [ call ] keep over [ deep-map! drop ] dip ] map!
] [ drop ] if ; inline recursive

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

@ -39,7 +39,7 @@ TUPLE: sequence-parser sequence n ;
: get+increment ( sequence-parser -- char/f )
[ current ] [ advance drop ] bi ; inline
:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
:: skip-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... )
sequence-parser current [
sequence-parser quot call
[ sequence-parser advance quot skip-until ] unless
@ -47,7 +47,7 @@ TUPLE: sequence-parser sequence n ;
: sequence-parse-end? ( sequence-parser -- ? ) current not ;
: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
: take-until ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
over sequence-parse-end? [
2drop f
] [
@ -56,7 +56,7 @@ TUPLE: sequence-parser sequence n ;
[ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
] if ; inline
: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
: take-while ( ... sequence-parser quot: ( ... obj -- ... ? ) -- ... sequence/f )
[ not ] compose take-until ; inline
: <safe-slice> ( from to seq -- slice/f )

2
basis/sorting/insertion/insertion.factor
View File

@ -2,7 +2,7 @@ USING: locals sequences kernel math ;
IN: sorting.insertion
<PRIVATE
:: insert ( seq quot: ( elt -- elt' ) n -- )
:: insert ( ... seq quot: ( ... elt -- ... elt' ) n -- ... )
n zero? [
n n 1 - [ seq nth quot call ] bi@ >= [
n n 1 - seq exchange

1
basis/stack-checker/backend/backend-tests.factor
View File

@ -8,6 +8,7 @@ IN: stack-checker.backend.tests
V{ } clone \ literals set
H{ } clone known-values set
0 input-count set
0 inner-d-index set
] unit-test
[ 0 ] [ 0 ensure-d length ] unit-test

44
basis/stack-checker/backend/backend.factor
View File

@ -3,9 +3,10 @@
USING: fry arrays generic io io.streams.string kernel math namespaces
parser sequences strings vectors words quotations effects classes
continuations assocs combinators compiler.errors accessors math.order
definitions sets hints macros stack-checker.state
definitions locals sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state stack-checker.dependencies summary ;
FROM: sequences.private => from-end ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
@ -16,8 +17,13 @@ IN: stack-checker.backend
[ #introduce, ]
tri ;
: update-inner-d ( new -- )
inner-d-index get min inner-d-index set ;
: pop-d ( -- obj )
meta-d [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
meta-d
[ <value> dup 1array introduce-values ]
[ pop meta-d length update-inner-d ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
@ -30,13 +36,17 @@ IN: stack-checker.backend
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
[ introduce-values ] [ meta-d push-all ] bi
meta-d push-all
] when swap tail* ;
] when
swap from-end [ tail ] [ update-inner-d ] bi ;
: shorten-by ( n seq -- )
[ length swap - ] keep shorten ; inline
: shorten-d ( n -- )
meta-d shorten-by meta-d length update-inner-d ;
: consume-d ( n -- seq )
[ ensure-d ] [ meta-d shorten-by ] bi ;
[ ensure-d ] [ shorten-d ] bi ;
: output-d ( values -- ) meta-d push-all ;
@ -126,7 +136,7 @@ M: bad-call summary
: infer-r> ( n -- )
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
: consume/produce ( effect quot: ( inputs outputs -- ) -- )
: consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b )
'[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
[ terminated?>> [ terminate ] when ]
bi ; inline
@ -160,3 +170,27 @@ M: bad-call summary
: (infer) ( quot -- effect )
[ infer-quot-here ] with-infer drop ;
: ?quotation-effect ( in -- effect/f )
dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
:: declare-effect-d ( word effect variables branches n -- )
meta-d length :> d-length
n d-length < [
d-length 1 - n - :> n'
n' meta-d nth :> value
value known :> known
known word effect variables branches <declared-effect> :> known'
known' value set-known
known' branches push
] [ word unknown-macro-input ] if ;
:: declare-input-effects ( word -- )
H{ } clone :> variables
V{ } clone :> branches
word stack-effect in>> <reversed> [| in n |
in ?quotation-effect [| effect |
word effect variables branches n declare-effect-d
] when*
] each-index ;

40
basis/stack-checker/branches/branches.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry vectors sequences assocs math math.order accessors kernel
combinators quotations namespaces grouping stack-checker.state
USING: arrays effects fry vectors sequences assocs math math.order accessors kernel
combinators quotations namespaces grouping locals stack-checker.state
stack-checker.backend stack-checker.errors stack-checker.visitor
stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.branches
@ -45,11 +45,17 @@ SYMBOLS: +bottom+ +top+ ;
SYMBOL: quotations
: simple-unbalanced-branches-error ( branches quots -- * )
[ \ if ] 2dip swap
[ length [ (( ..a -- ..b )) ] replicate ]
[ [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
unbalanced-branches-error ;
: unify-branches ( ins stacks -- in phi-in phi-out )
zip [ 0 { } { } ] [
[ keys supremum ] [ ] [ balanced? ] tri
[ dupd phi-inputs dup phi-outputs ]
[ quotations get unbalanced-branches-error ]
[ quotations get simple-unbalanced-branches-error ]
if
] if-empty ;
@ -61,7 +67,9 @@ SYMBOL: quotations
branch-variable ;
: datastack-phi ( seq -- phi-in phi-out )
[ input-count branch-variable ] [ \ meta-d active-variable ] bi
[ input-count branch-variable ]
[ inner-d-index branch-variable infimum inner-d-index set ]
[ \ meta-d active-variable ] tri
unify-branches
[ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ;
@ -80,7 +88,8 @@ SYMBOL: quotations
: copy-inference ( -- )
\ meta-d [ clone ] change
literals [ clone ] change
input-count [ ] change ;
input-count [ ] change
inner-d-index [ ] change ;
GENERIC: infer-branch ( literal -- namespace )
@ -91,6 +100,9 @@ M: literal infer-branch
[ value>> quotation set ] [ infer-literal-quot ] bi
] H{ } make-assoc ;
M: declared-effect infer-branch
known>> infer-branch ;
M: callable infer-branch
[
copy-inference
@ -107,12 +119,26 @@ M: callable infer-branch
infer-branches
[ first2 #if, ] dip compute-phi-function ;
GENERIC: curried/composed? ( known -- ? )
M: object curried/composed? drop f ;
M: curried curried/composed? drop t ;
M: composed curried/composed? drop t ;
M: declared-effect curried/composed? known>> curried/composed? ;
:: declare-if-effects ( -- )
H{ } clone :> variables
V{ } clone :> branches
\ if (( ..a -- ..b )) variables branches 0 declare-effect-d
\ if (( ..a -- ..b )) variables branches 1 declare-effect-d ;
: infer-if ( -- )
2 literals-available? [
(infer-if)
] [
drop 2 consume-d
dup [ known [ curried? ] [ composed? ] bi or ] any? [
drop 2 ensure-d
declare-if-effects
2 shorten-d
dup [ known curried/composed? ] any? [
output-d
[ rot [ drop call ] [ nip call ] if ]
infer-quot-here

11
basis/stack-checker/errors/errors-docs.factor
View File

@ -63,15 +63,16 @@ HELP: bad-macro-input
} ;
HELP: unbalanced-branches-error
{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } }
{ $description "Throws an " { $link unbalanced-branches-error } "." }
{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." }
{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." }
{ $error-description "Thrown when inference encounters an inline combinator whose input quotations do not match their declared effects, or when it encounters an " { $link if } " or " { $link dispatch } " whose branches do not all exit with the same stack height. See " { $link "inference-combinators" } " and " { $link "inference-branches" } " for details." }
{ $examples
{ $code
": unbalanced-branches-example ( a b c -- )"
": if-unbalanced-branches-example ( a b c -- )"
" [ + ] [ dup ] if ;"
}
{ $code
": each-unbalanced-branches-example ( x seq -- x' )"
" [ 3append ] each ;"
}
} ;
HELP: too-many->r

8
basis/stack-checker/errors/errors.factor
View File

@ -10,8 +10,6 @@ ERROR: bad-macro-input < inference-error macro ;
ERROR: unknown-macro-input < inference-error macro ;
ERROR: unbalanced-branches-error < inference-error branches quots ;
ERROR: too-many->r < inference-error ;
ERROR: too-many-r> < inference-error ;
@ -34,9 +32,5 @@ ERROR: transform-expansion-error < inference-error error continuation word ;
ERROR: bad-declaration-error < inference-error declaration ;
ERROR: invalid-quotation-input < inference-error word branches quots ;
ERROR: invalid-effect-variable < inference-error effect ;
ERROR: effect-variable-can't-have-type < inference-error effect ;
ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ;

23
basis/stack-checker/errors/prettyprint/prettyprint.factor
View File

@ -10,17 +10,6 @@ M: unknown-macro-input summary
M: bad-macro-input summary
macro>> name>> "Cannot apply “" "” to a run-time computed value" surround ;
M: unbalanced-branches-error summary
drop "Unbalanced branches" ;
: quots-and-branches. ( quots branches -- )
zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
M: unbalanced-branches-error error.
dup summary print
[ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
quots-and-branches. ;
M: too-many->r summary
drop "Quotation pushes elements on retain stack without popping them" ;
@ -65,16 +54,12 @@ M: transform-expansion-error error.
M: do-not-compile summary
word>> name>> "Cannot compile call to " prepend ;
M: invalid-quotation-input summary
M: unbalanced-branches-error summary
word>> name>>
"The input quotations to " " don't match their expected effects" surround ;
M: invalid-quotation-input error.
M: unbalanced-branches-error error.
dup summary print
[ quots>> ] [ branches>> ] bi quots-and-branches. ;
M: invalid-effect-variable summary
drop "Stack effect variables can only occur as the first input or output" ;
M: effect-variable-can't-have-type summary
drop "Stack effect variables cannot have a declared type" ;
[ quots>> ] [ declareds>> ] [ actuals>> ] tri 3array flip
{ "Input" "Expected" "Got" } prefix simple-table. ;

10
basis/stack-checker/inlining/inlining.factor
View File

@ -119,9 +119,15 @@ SYMBOL: enter-out
: trimmed-enter-out ( label -- stack )
dup enter-out>> trim-stack ;
GENERIC: (undeclared-known) ( value -- known )
M: object (undeclared-known) ;
M: declared-effect (undeclared-known) known>> (undeclared-known) ;
: undeclared-known ( value -- known ) known (undeclared-known) ;
: check-call-site-stack ( label -- )
[ ] [ call-site-stack ] [ trimmed-enter-out ] tri
[ dup known [ [ known ] bi@ = ] [ 2drop t ] if ] 2all?
[ dup undeclared-known [ [ undeclared-known ] bi@ = ] [ 2drop t ] if ] 2all?
[ drop ] [ word>> inconsistent-recursive-call-error inference-error ] if ;
: check-call ( label -- )
@ -142,7 +148,7 @@ SYMBOL: enter-out
: inline-word ( word -- )
commit-literals
[ depends-on-definition ]
[ infer-polymorphic? get [ check-polymorphic-effect ] [ drop ] if ]
[ declare-input-effects ]
[
dup inline-recursive-label [
call-recursive-inline-word

6
basis/stack-checker/known-words/known-words.factor
View File

@ -22,7 +22,8 @@ stack-checker.backend
stack-checker.branches
stack-checker.transforms
stack-checker.dependencies
stack-checker.recursive-state ;
stack-checker.recursive-state
stack-checker.row-polymorphism ;
IN: stack-checker.known-words
: infer-primitive ( word -- )
@ -98,6 +99,9 @@ M: composed infer-call*
1 infer->r infer-call
terminated? get [ 1 infer-r> infer-call ] unless ;
M: declared-effect infer-call*
[ [ known>> infer-call* ] keep ] with-effect-here check-declared-effect ;
M: input-parameter infer-call* \ call unknown-macro-input ;
M: object infer-call* \ call bad-macro-input ;

71
basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor
View File

@ -1,71 +0,0 @@
! (c)2010 Joe Groff bsd license
USING: effects fry io kernel math namespaces sequences
system tools.test
stack-checker.backend
stack-checker.errors
stack-checker.row-polymorphism
stack-checker.state
stack-checker.values ;
IN: stack-checker.row-polymorphism.tests
: infer-polymorphic-quot ( quot -- vars )
t infer-polymorphic? [
unclip-last [
dup current-word set
init-inference
init-known-values
[ [ <literal> <value> [ set-known ] [ push-d ] bi ] each ]
[ stack-effect ] bi*
infer-polymorphic-vars
] with-scope
] with-variable ;
: test-poly-infer ( effect quot -- )
[ '[ _ ] ] [ '[ _ infer-polymorphic-quot ] ] bi* unit-test ; inline
: poly-infer-must-fail ( quot -- )
'[ _ infer-polymorphic-quot ] [ invalid-quotation-input? ] must-fail-with ; inline
: poly-infer-must-fail-unknown ( quot -- )
'[ _ infer-polymorphic-quot ] [ unknown-macro-input? ] must-fail-with ; inline
H{ { "." 0 } } [ [ write ] each ] test-poly-infer
H{ { "." 1 } } [ [ append ] each ] test-poly-infer
H{ { "." 0 } } [ [ ] map ] test-poly-infer
H{ { "." 0 } } [ [ reverse ] map ] test-poly-infer
H{ { "." 1 } } [ [ append dup ] map ] test-poly-infer
H{ { "." 1 } } [ [ swap nth suffix dup ] map-index ] test-poly-infer
H{ { "a" 3 } { "b" 1 } } [ [ 2drop ] [ 2nip ] if ] test-poly-infer
H{ { "a" 2 } { "b" 3 } } [ [ dup ] [ over ] if ] test-poly-infer
H{ { "a" 0 } { "b" 1 } } [ [ os ] [ cpu ] if ] test-poly-infer
H{ { "a" 1 } { "b" 2 } } [ [ os ] [ 1 + cpu ] if ] test-poly-infer
H{ { "a" 0 } { "b" 0 } } [ [ write ] [ "(f)" write ] if* ] test-poly-infer
H{ { "a" 0 } { "b" 1 } } [ [ ] [ f ] if* ] test-poly-infer
H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ drop f ] if* ] test-poly-infer
H{ { "a" 1 } { "b" 1 } } [ [ nip ] [ ] if* ] test-poly-infer
H{ { "a" 2 } { "b" 2 } } [ [ 3append f ] [ ] if* ] test-poly-infer
H{ { "a" 0 } { "b" 0 } } [ [ drop ] [ ] if* ] test-poly-infer
[ [ write write ] each ] poly-infer-must-fail
[ [ ] each ] poly-infer-must-fail
[ [ dup ] map ] poly-infer-must-fail
[ [ drop ] map ] poly-infer-must-fail
[ [ 1 + ] map-index ] poly-infer-must-fail
[ [ dup ] [ ] if ] poly-infer-must-fail
[ [ 2dup ] [ over ] if ] poly-infer-must-fail
[ [ drop ] [ ] if ] poly-infer-must-fail
[ [ ] [ ] if* ] poly-infer-must-fail
[ [ dup ] [ ] if* ] poly-infer-must-fail
[ [ drop ] [ drop ] if* ] poly-infer-must-fail
[ [ ] [ drop ] if* ] poly-infer-must-fail
[ [ ] [ 2dup ] if* ] poly-infer-must-fail
[ "derp" each ] poly-infer-must-fail
[ each ] poly-infer-must-fail-unknown
[ "derp" [ "derp" ] if ] poly-infer-must-fail
[ [ "derp" ] "derp" if ] poly-infer-must-fail
[ [ "derp" ] if ] poly-infer-must-fail-unknown

132
basis/stack-checker/row-polymorphism/row-polymorphism.factor
View File

@ -1,6 +1,6 @@
! (c)2010 Joe Groff bsd license
USING: accessors arrays assocs combinators combinators.short-circuit
continuations effects fry kernel locals math namespaces
continuations effects fry kernel locals math math.order namespaces
quotations sequences splitting
stack-checker.backend
stack-checker.errors
@ -10,91 +10,63 @@ stack-checker.values
stack-checker.visitor ;
IN: stack-checker.row-polymorphism
<PRIVATE
SYMBOLS: current-effect-variables current-word-effect current-meta-d ;
:: with-inner-d ( quot -- inner-d )
inner-d-index get :> old-inner-d-index
meta-d length inner-d-index set
quot call
inner-d-index get :> new-inner-d-index
old-inner-d-index new-inner-d-index min inner-d-index set
new-inner-d-index ; inline
: quotation-effect? ( in -- ? )
dup pair? [ second effect? ] [ drop f ] if ;
:: with-effect-here ( quot -- effect )
input-count get :> old-input-count
meta-d length :> old-meta-d-length
SYMBOL: (unknown)
quot with-inner-d :> inner-d
input-count get :> new-input-count
old-meta-d-length inner-d -
new-input-count old-input-count - + :> in
meta-d length inner-d - :> out
in "x" <array> out "x" <array> terminated? get <terminated-effect> ; inline
GENERIC: >error-quot ( known -- quot )
M: object >error-quot drop (unknown) ;
M: literal >error-quot value>> ;
M: composed >error-quot
[ quot1>> known >error-quot ] [ quot2>> known >error-quot ] bi
\ compose [ ] 3sequence ;
M: curried >error-quot
[ obj>> known >error-quot ] [ quot>> known >error-quot ] bi
\ curry [ ] 3sequence ;
: >error-branches-and-quots ( branch/values -- branches quots )
[ [ second ] [ known >error-quot ] bi* ] assoc-map unzip ;
: abandon-check ( -- * )
current-word get
current-word-effect get in>> current-meta-d get zip
[ first quotation-effect? ] filter
>error-branches-and-quots
invalid-quotation-input ;
:: check-variable ( actual-count declared-count variable -- difference )
:: check-variable ( actual-count declared-count variable vars -- difference ? )
actual-count declared-count -
variable [
variable current-effect-variables get at* nip
[ variable current-effect-variables get at - ]
[ variable current-effect-variables get set-at 0 ] if
] [
dup [ abandon-check ] unless-zero
variable vars at* nip
[ variable vars at - ]
[ variable vars set-at 0 ] if
t
] [ dup 0 <= ] if ;
: adjust-variable ( diff var vars -- )
pick 0 >=
[ at+ ]
[ 3drop ] if ; inline
:: check-variables ( vars declared actual -- ? )
actual terminated?>> [ t ] [
actual declared [ in>> length ] bi@ declared in-var>>
[ vars check-variable ] keep :> ( in-diff in-ok? in-var )
actual declared [ out>> length ] bi@ declared out-var>>
[ vars check-variable ] keep :> ( out-diff out-ok? out-var )
{ [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&&
dup [
in-var [ in-diff swap vars adjust-variable ] when*
out-var [ out-diff swap vars adjust-variable ] when*
] when
] if ;
: adjust-variable ( diff var -- )
over 0 >=
[ current-effect-variables get at+ ]
[ 2drop ] if ; inline
: complex-unbalanced-branches-error ( known -- * )
[ word>> ] [
branches>> <reversed>
[ [ known>callable ] { } map-as ]
[ [ effect>> ] { } map-as ]
[ [ actual>> ] { } map-as ] tri
] bi unbalanced-branches-error ;
:: (check-input) ( declared actual -- )
actual declared [ in>> length ] bi@ declared in-var>>
[ check-variable ] keep :> ( in-diff in-var )
actual declared [ out>> length ] bi@ declared out-var>>
[ check-variable ] keep :> ( out-diff out-var )
{ [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
[
in-var [ in-diff swap adjust-variable ] when*
out-var [ out-diff swap adjust-variable ] when*
] [
abandon-check
] if ;
: check-declared-effect ( known effect -- )
[ >>actual ] keep
2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
[ 2drop ] [ drop complex-unbalanced-branches-error ] if ;
: infer-value ( value -- effect )
dup known [ nest-visitor init-inference infer-call* current-effect ] with-scope ; inline
: check-input ( in value -- )
over quotation-effect? [
[ second ] dip infer-value (check-input)
] [ 2drop ] if ;
: normalize-variables ( -- variables' )
current-effect-variables get dup values [
infimum dup 0 <
[ '[ _ - ] assoc-map ] [ drop ] if
] unless-empty ;
PRIVATE>
: infer-polymorphic-vars ( effect -- variables )
H{ } clone current-effect-variables set
dup current-word-effect set
in>> dup length ensure-d dup current-meta-d set
[ check-input ] 2each
normalize-variables ;
: check-polymorphic-effect ( word -- )
current-word get [
dup current-word set stack-effect
dup { [ in-var>> ] [ out-var>> ] } 1||
[ infer-polymorphic-vars ] when drop
] dip current-word set ;
SYMBOL: infer-polymorphic?

2
basis/stack-checker/stack-checker-docs.factor
View File

@ -27,6 +27,8 @@ ARTICLE: "inference-combinators" "Combinator stack effects"
{ "If the word is declared " { $link POSTPONE: inline } ", the combinator may additionally be called on one of the word's input parameters or with quotations built from the word's input parameters, literal quotations, " { $link curry } ", and " { $link compose } ". When inline, a word is itself considered to be a combinator, and its callers must in turn satisfy these conditions." }
}
"If neither condition holds, the stack checker throws a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error. To make the code compile, a runtime checking combinator such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by " { $link curry } "ing the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "."
{ $heading "Input stack effects" }
"Inline combinators will verify the stack effect of their input quotations if they are declared in the combinator's stack effect. See " { $link "effects-variables" } " for details."
{ $heading "Examples" }
{ $subheading "Calling a combinator" }
"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":"

68
basis/stack-checker/stack-checker-tests.factor
View File

@ -234,10 +234,12 @@ DEFER: blah4
! Test some curry stuff
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
{ 3 1 } [ [ ] curry [ [ ] curry ] dip if ] must-infer-as
{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ ] curry [ [ ] 2curry ] dip if ] infer ] [ unbalanced-branches-error? ] must-fail-with
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
@ -378,7 +380,10 @@ DEFER: eee'
[ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with
[ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
[ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with
[ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
[ [ [ "derp" ] if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
@ -402,3 +407,64 @@ DEFER: eee'
[ "special" word-prop not ] filter
[ "shuffle" word-prop not ] filter
] unit-test
{ 1 0 } [ [ drop ] each ] must-infer-as
{ 2 1 } [ [ append ] each ] must-infer-as
{ 1 1 } [ [ ] map ] must-infer-as
{ 1 1 } [ [ reverse ] map ] must-infer-as
{ 2 2 } [ [ append dup ] map ] must-infer-as
{ 2 2 } [ [ swap nth suffix dup ] map-index ] must-infer-as
{ 4 1 } [ [ 2drop ] [ 2nip ] if ] must-infer-as
{ 3 3 } [ [ dup ] [ over ] if ] must-infer-as
{ 1 1 } [ [ 1 ] [ 0 ] if ] must-infer-as
{ 2 2 } [ [ t ] [ 1 + f ] if ] must-infer-as
{ 1 0 } [ [ write ] [ "(f)" write ] if* ] must-infer-as
{ 1 1 } [ [ ] [ f ] if* ] must-infer-as
{ 2 1 } [ [ nip ] [ drop f ] if* ] must-infer-as
{ 2 1 } [ [ nip ] [ ] if* ] must-infer-as
{ 3 2 } [ [ 3append f ] [ ] if* ] must-infer-as
{ 1 0 } [ [ drop ] [ ] if* ] must-infer-as
{ 1 1 } [ [ 1 + ] [ "oops" throw ] if* ] must-infer-as
: strict-each ( seq quot: ( x -- ) -- )
each ; inline
: strict-map ( seq quot: ( x -- x' ) -- seq' )
map ; inline
: strict-2map ( xs ys quot: ( x y -- z ) -- zs )
2map ; inline
{ 1 0 } [ [ drop ] strict-each ] must-infer-as
{ 1 1 } [ [ 1 + ] strict-map ] must-infer-as
{ 1 1 } [ [ ] strict-map ] must-infer-as
{ 2 1 } [ [ + ] strict-2map ] must-infer-as
{ 2 1 } [ [ drop ] strict-2map ] must-infer-as
[ [ [ append ] strict-each ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ 1 + ] strict-2map ] infer ] [ unbalanced-branches-error? ] must-fail-with
! ensure that polymorphic checking works on recursive combinators
FROM: splitting.private => split, ;
{ 2 0 } [ [ member? ] curry split, ] must-infer-as
[ [ [ write write ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ ] each ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ dup ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ drop ] map ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ 1 + ] map-index ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ dup ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ 2dup ] [ over ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ drop ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ dup ] [ ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ drop ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ ] [ drop ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
[ [ [ ] [ 2dup ] if* ] infer ] [ unbalanced-branches-error? ] must-fail-with
! M\ declared-effect infer-call* didn't properly unify branches
{ 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as

4
basis/stack-checker/state/state.factor
View File

@ -11,6 +11,7 @@ SYMBOL: terminated?
! Number of inputs current word expects from the stack
SYMBOL: input-count
SYMBOL: inner-d-index
DEFER: commit-literals
@ -46,4 +47,5 @@ SYMBOL: literals
terminated? off
V{ } clone \ meta-d set
V{ } clone literals set
0 input-count set ;
0 input-count set
0 inner-d-index set ;

2
basis/stack-checker/transforms/transforms.factor
View File

@ -18,7 +18,7 @@ IN: stack-checker.transforms
:: ((apply-transform)) ( quot values stack rstate -- )
rstate recursive-state [ stack quot call-transformer ] with-variable
values [ length meta-d shorten-by ] [ #drop, ] bi
values [ length shorten-d ] [ #drop, ] bi
rstate infer-quot ;
: literal-values? ( values -- ? ) [ literal-value? ] all? ;

39
basis/stack-checker/values/values.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel assocs sequences
stack-checker.recursive-state stack-checker.errors ;
USING: accessors namespaces fry kernel assocs sequences
stack-checker.recursive-state stack-checker.errors
quotations ;
IN: stack-checker.values
! Values
@ -97,9 +98,41 @@ M: input-parameter (literal-value?) drop f ;
M: input-parameter (literal) current-word get unknown-macro-input ;
! Argument corresponding to polymorphic declared input of inline combinator
TUPLE: declared-effect known word effect variables branches actual ;
C: (declared-effect) declared-effect
: <declared-effect> ( known word effect variables branches -- declared-effect )
f (declared-effect) ; inline
M: declared-effect (input-value?) known>> (input-value?) ;
M: declared-effect (literal-value?) known>> (literal-value?) ;
M: declared-effect (literal) known>> (literal) ;
! Computed values
M: f (input-value?) drop f ;
M: f (literal-value?) drop f ;
M: f (literal) current-word get bad-macro-input ;
M: f (literal) current-word get bad-macro-input ;
GENERIC: known>callable ( known -- quot )
: ?@ ( x -- y )
dup callable? [ drop [ @ ] ] unless ;
M: object known>callable drop \ _ ;
M: literal known>callable value>> ;
M: composed known>callable
[ quot1>> known known>callable ?@ ] [ quot2>> known known>callable ?@ ] bi
append ;
M: curried known>callable
[ quot>> known known>callable ] [ obj>> known known>callable ] bi
prefix ;
M: declared-effect known>callable
known>> known>callable ;

2
basis/tools/disassembler/udis/udis.factor
View File

@ -103,7 +103,7 @@ FUNCTION: c-string ud_lookup_mnemonic ( int c ) ;
dup cell-bits ud_set_mode
dup UD_SYN_INTEL ud_set_syntax ;
: with-ud ( quot: ( ud -- ) -- )
: with-ud ( ..a quot: ( ..a ud -- ..b ) -- ..b )
[ [ [ <ud> ] dip call ] with-destructors ] with-code-blocks ; inline
SINGLETON: udis-disassembler

2
basis/windows/ddk/hid/tags.txt
View File

@ -1 +1 @@
unportable bindings
bindings

2
basis/windows/ddk/setupapi/tags.txt
View File

@ -1 +1 @@
unportable bindings
bindings

2
basis/windows/ddk/winusb/tags.txt
View File

@ -1 +1 @@
unportable bindings
bindings

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

@ -44,7 +44,7 @@ SYNTAX: XML-NS:
: each-attrs ( attrs quot -- )
[ values [ interpolated? ] filter ] dip each ; inline
: (each-interpolated) ( item quot: ( interpolated -- ) -- )
: (each-interpolated) ( ... item quot: ( ... interpolated -- ... ) -- ... )
{
{ [ over interpolated? ] [ call ] }
{ [ over tag? ] [ [ attrs>> ] dip each-attrs ] }

4
basis/xml/tokenize/tokenize.factor
View File

@ -59,14 +59,14 @@ HINTS: next* { spot } ;
! with-input-stream implicitly creates a new scope which we use
swap [ init-parser call ] with-input-stream ; inline
:: (skip-until) ( quot: ( -- ? ) spot -- )
:: (skip-until) ( ... quot: ( ... -- ... ? ) spot -- ... )
spot char>> [
quot call [
spot next* quot spot (skip-until)
] unless
] when ; inline recursive
: skip-until ( quot: ( -- ? ) -- )
: skip-until ( ... quot: ( ... -- ... ? ) -- ... )
spot get (skip-until) ; inline
: take-until ( quot -- string )

6
core/alien/alien-docs.factor
View File

@ -71,7 +71,7 @@ HELP: alien-invoke-error
} ;
HELP: alien-invoke
{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } { "return..." "the return value of the function, if not " { $link void } } }
{ $description "Calls a C library function with the given name. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected." }
{ $notes "C type names are documented in " { $link "c-types-specs" } "." }
{ $errors "Throws an " { $link alien-invoke-error } " if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler." } ;
@ -85,7 +85,7 @@ HELP: alien-indirect-error
} ;
HELP: alien-indirect
{ $values { "..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $values { "args..." "zero or more objects passed to the C function" } { "funcptr" "a C function pointer" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "return..." "the return value of the function, if not " { $link void } } }
{ $description
"Invokes a C function pointer passed on the data stack. Input parameters are taken from the data stack following the function pointer, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected."
}
@ -128,7 +128,7 @@ HELP: alien-assembly-error
} ;
HELP: alien-assembly
{ $values { "..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } }
{ $values { "args..." "zero or more objects passed to the C function" } { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" quotation } { "return..." "the return value of the function, if not " { $link void } } }
{ $description
"Invokes arbitrary machine code, generated at compile-time by the quotation. Input parameters are taken from the data stack, and the return value is pushed on the data stack after the function returns. A return type of " { $link void } " indicates that no value is to be expected."
}

6
core/alien/alien.factor
View File

@ -70,17 +70,17 @@ ERROR: alien-callback-error ;
ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- ... )
: alien-indirect ( args... funcptr return parameters abi -- return... )
alien-indirect-error ;
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
: alien-invoke ( args... return library function parameters -- return... )
2over alien-invoke-error ;
ERROR: alien-assembly-error code ;
: alien-assembly ( ... return parameters abi quot -- ... )
: alien-assembly ( args... return parameters abi quot -- return... )
dup alien-assembly-error ;
! Callbacks are registered in a global hashtable. Note that they

2
core/assocs/assocs.factor
View File

@ -44,7 +44,7 @@ M: assoc assoc-like drop ; inline
: substituter ( assoc -- quot )
[ ?at drop ] curry ; inline
: with-assoc ( assoc quot: ( value key assoc -- ) -- quot: ( key value -- ) )
: with-assoc ( assoc quot: ( ..a value key assoc -- ..b ) -- quot: ( ..a key value -- ..b ) )
curry [ swap ] prepose ; inline
PRIVATE>

2
core/bootstrap/primitives.factor
View File

@ -420,7 +420,7 @@ tuple
{ "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
{ "<byte-array>" "byte-arrays" "primitive_byte_array" (( n -- byte-array )) }
{ "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- newbyte-array )) }
{ "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( ... layout -- tuple )) }
{ "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( slots... layout -- tuple )) }
{ "<tuple>" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) }
{ "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist update-existing? reset-pics? -- )) }
{ "lookup-method" "generic.single.private" "primitive_lookup_method" (( object methods -- method )) }

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

@ -421,8 +421,8 @@ HELP: <tuple> ( layout -- tuple )
{ $values { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
HELP: <tuple-boa> ( ... layout -- tuple )
{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
HELP: <tuple-boa> ( slots... layout -- tuple )
{ $values { "slots..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
HELP: new
@ -439,7 +439,7 @@ HELP: new
} ;
HELP: boa
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $values { "slots..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." }
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;

2
core/combinators/combinators-docs.factor
View File

@ -295,7 +295,7 @@ HELP: spread
{ bi* tri* spread } related-words
HELP: to-fixed-point
{ $values { "object" object } { "quot" { $quotation "( object(n) -- object(n+1) )" } } { "object(n)" object } }
{ $values { "object" object } { "quot" { $quotation "( ... object(n) -- ... object(n+1) )" } } { "object(n)" object } }
{ $description "Applies the quotation repeatedly with " { $snippet "object" } " as the initial input until the output of the quotation equals the input." }
{ $examples
{ $example

2
core/combinators/combinators.factor
View File

@ -193,5 +193,5 @@ M: hashtable hashcode*
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
: to-fixed-point ( object quot: ( object(n) -- object(n+1) ) -- object(n) )
: to-fixed-point ( ... object quot: ( ... object(n) -- ... object(n+1) ) -- ... object(n) )
[ keep over = ] keep [ to-fixed-point ] curry unless ; inline recursive

2
core/continuations/continuations-docs.factor
View File

@ -182,7 +182,7 @@ HELP: cleanup
{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
HELP: recover
{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
{ $values { "try" { $quotation "( ..a -- ..b )" } } { "recovery" { $quotation "( ..a error -- ..b )" } } }
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
HELP: ignore-errors

4
core/continuations/continuations.factor
View File

@ -119,7 +119,7 @@ SYMBOL: thread-error-hook
] when
c> continue-with ;
: recover ( try recovery -- )
: recover ( ..a try: ( ..a -- ..b ) recovery: ( ..a error -- ..b ) -- ..b )
[ [ swap >c call c> drop ] curry ] dip ifcc ; inline
: ignore-errors ( quot -- )
@ -130,7 +130,7 @@ SYMBOL: thread-error-hook
ERROR: attempt-all-error ;
: attempt-all ( seq quot -- obj )
: attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
over empty? [
attempt-all-error
] [

81
core/effects/effects-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax math strings words kernel combinators ;
USING: arrays classes help.markup help.syntax math strings words kernel combinators sequences ;
IN: effects
ARTICLE: "effects" "Stack effect declarations"
@ -6,11 +6,9 @@ ARTICLE: "effects" "Stack effect declarations"
{ $code "( input1 input2 ... -- output1 ... )" }
"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:"
{ $synopsis + }
"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:"
"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration. If the number of inputs or outputs depends on the stack effects of quotation parameters, " { $link "effects-variables" } " can be used to declare this:"
{ $synopsis while }
"Only the number of inputs and outputs carries semantic meaning."
$nl
"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "."
"For words that are not " { $link POSTPONE: inline } ", only the number of inputs and outputs carries semantic meaning, and effect variables are ignored. However, nested quotation declarations are enforced for inline words. Nested quotation declarations are optional for non-recursive inline combinators and only provide better error messages. However, quotation inputs to " { $link POSTPONE: recursive } " combinators must have an effect declared. See " { $link "inference-recursive-combinators" } "."
$nl
"In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters."
$nl
@ -29,9 +27,82 @@ $nl
{ { $snippet "loc" } "a screen location specified as a two-element array holding x and y co-ordinates" }
{ { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" }
{ { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" }
{ { $snippet ".." } { "indicates " { $link "effects-variables" } ". only valid as the first input or first output" } }
}
"For reflection and metaprogramming, you can use " { $link "syntax-effects" } " to include literal stack effects in your code, or these constructor words to construct stack effect objects at runtime:"
{ $subsections
<effect>
<terminated-effect>
<variable-effect>
}
$nl
{ $see-also "inference" } ;
HELP: <effect>
{ $values
{ "in" "a sequence of strings or string–type pairs" }
{ "out" "a sequence of strings or string–type pairs" }
{ "effect" effect }
}
{ $description "Constructs an " { $link effect } " object. Each element of " { $snippet "in" } " and " { $snippet "out" } " must be either a string (which is equivalent to a " { $snippet "name" } " in literal stack effect syntax), or a " { $link pair } " where the first element is a string and the second is either a " { $link class } " or effect (which is equivalent to " { $snippet "name: class" } " or " { $snippet "name: ( nested -- effect )" } " in the literal syntax. If the " { $snippet "out" } " array consists of a single string element " { $snippet "\"*\"" } ", a terminating stack effect will be constructed." }
{ $notes "This word cannot construct effects with " { $link "effects-variables" } ". Use " { $link <variable-effect> } " to construct variable stack effects." }
{ $examples
{ $example """USING: effects prettyprint ;
{ "a" "b" } { "c" } <effect> .""" """(( a b -- c ))""" }
{ $example """USING: arrays effects prettyprint ;
{ "a" { "b" array } } { "c" } <effect> .""" """(( a b: array -- c ))""" }
{ $example """USING: effects prettyprint ;
{ "a" { "b" (( x y -- z )) } } { "c" } <effect> .""" """(( a b: ( x y -- z ) -- c ))""" }
{ $example """USING: effects prettyprint ;
{ "a" { "b" (( x y -- z )) } } { "*" } <effect> .""" """(( a b: ( x y -- z ) -- * ))""" }
} ;
HELP: <terminated-effect>
{ $values
{ "in" "a sequence of strings or string–type pairs" }
{ "out" "a sequence of strings or string–type pairs" }
{ "terminated?" boolean }
{ "effect" effect }
}
{ $description "Constructs an " { $link effect } " object like " { $link <effect> } ". If " { $snippet "terminated?" } " is true, the value of " { $snippet "out" } " is ignored, and a terminating stack effect is constructed." }
{ $notes "This word cannot construct effects with " { $link "effects-variables" } ". Use " { $link <variable-effect> } " to construct variable stack effects." }
{ $examples
{ $example """USING: effects prettyprint ;
{ "a" { "b" (( x y -- z )) } } { "c" } f <terminated-effect> .""" """(( a b: ( x y -- z ) -- c ))""" }
{ $example """USING: effects prettyprint ;
{ "a" { "b" (( x y -- z )) } } { } t <terminated-effect> .""" """(( a b: ( x y -- z ) -- * ))""" }
} ;
HELP: <variable-effect>
{ $values
{ "in-var" { $maybe string } }
{ "in" "a sequence of strings or string–type pairs" }
{ "out-var" { $maybe string } }
{ "out" "a sequence of strings or string–type pairs" }
{ "effect" effect }
}
{ $description "Constructs an " { $link effect } " object like " { $link <effect> } ". If " { $snippet "in-var" } " or " { $snippet "out-var" } " are not " { $link f } ", they are used as the names of the " { $link "effects-variables" } " for the inputs and outputs of the effect object." }
{ $examples
{ $example """USING: effects prettyprint ;
f { "a" "b" } f { "c" } <variable-effect> .""" """(( a b -- c ))""" }
{ $example """USING: effects prettyprint ;
"x" { "a" "b" } "y" { "c" } <variable-effect> .""" """(( ..x a b -- ..y c ))""" }
{ $example """USING: arrays effects prettyprint ;
"y" { "a" { "b" (( ..x -- ..y )) } } "x" { "c" } <variable-effect> .""" """(( ..y a b: ( ..x -- ..y ) -- ..x c ))""" }
{ $example """USING: effects prettyprint ;
"." { "a" "b" } f { "*" } <variable-effect> .""" """(( ... a b -- * ))""" }
} ;
{ <effect> <terminated-effect> <variable-effect> } related-words
ARTICLE: "effects-variables" "Stack effect variables"
{ $link POSTPONE: inline } " combinators can have variable stack effects, depending on the effect of the quotation they call. For example, while " { $link each } " inputs elements of its sequence to its quotation, the quotation can also manipulate values on the stack below the element, as long as it leaves the same number of elements on the stack. This ability is used to implement " { $link reduce } " in terms of " { $snippet "each" } ". This variable stack effect is indicated by starting the list of inputs and outputs with a name starting with " { $snippet ".." } ":"
{ $synopsis each }
"In combinators with multiple quotation inputs, the number of inputs or outputs represented by a particular " { $snippet ".." } " name must match. For example, the predicate for a " { $link while } " loop can take an arbitrary number of inputs and leave an arbitrary number of outputs on the stack in addition to the predicate result; however, for the loop to leave the stack balanced, the body of the while loop must consume all of the predicate's outputs and leave a number of its own outputs equal to the initial number of stack values before the predicate was called. This is expressed with the following stack effect:"
{ $synopsis while }
"Stack effect variables can only occur as the first input or first output of a stack effect; names starting in " { $snippet ".." } " cause a syntax error if they occur elsewhere in the effect. For words that are not " { $link POSTPONE: inline } ", effect variables are currently ignored by the stack checker." ;
ABOUT: "effects"
HELP: effect

4
core/generic/math/math.factor
View File

@ -74,7 +74,7 @@ PRIVATE>
SYMBOL: generic-word
: make-math-method-table ( classes quot: ( class -- quot ) -- alist )
: make-math-method-table ( classes quot: ( ... class -- ... quot ) -- alist )
[ bootstrap-words ] dip
[ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline
@ -93,7 +93,7 @@ SYMBOL: generic-word
: tuple-dispatch ( picker alist -- alist' )
swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
: math-dispatch-step ( picker quot: ( class -- quot ) -- quot )
: math-dispatch-step ( picker quot: ( ... class -- ... quot ) -- quot )
[ [ { bignum float fixnum } ] dip make-math-method-table ]
[ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi
tuple swap 2array prefix tag-dispatch ; inline

2
core/io/io.factor
View File

@ -87,7 +87,7 @@ SYMBOL: error-stream
: bl ( -- ) " " write ;
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
: each-morsel ( ..a handler: ( ..a data -- ..b ) reader: ( ..b -- ..a data ) -- ..a )
[ dup ] compose swap while drop ; inline
<PRIVATE

22
core/kernel/kernel-docs.factor
View File

@ -169,7 +169,7 @@ HELP: xor
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?
{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
{ $values { "x" object } { "y" object } { "quot" { $quotation "( ... obj -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" }
@ -177,7 +177,7 @@ HELP: both?
} ;
HELP: either?
{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
{ $values { "x" object } { "y" object } { "quot" { $quotation "( ... obj -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" }
@ -214,22 +214,22 @@ HELP: call-clear ( quot -- * )
{ $notes "Used to implement " { $link "threads" } "." } ;
HELP: keep
{ $values { "x" object } { "quot" { $quotation "( x -- ... )" } } }
{ $values { "x" object } { "quot" { $quotation "( ..a x -- ..b )" } } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
{ $examples
{ $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ <array> ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" }
} ;
HELP: 2keep
{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ... )" } } }
{ $values { "x" object } { "y" object } { "quot" { $quotation "( ..a x y -- ..b )" } } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( x y z -- ... )" } } }
{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( ..a x y z -- ..b )" } } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
{ $values { "x" object } { "p" { $quotation "( x -- ... )" } } { "q" { $quotation "( x -- ... )" } } }
{ $values { "x" object } { "p" { $quotation "( ..a x -- ..b )" } } { "q" { $quotation "( ..c x -- ..d )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } "." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
@ -595,7 +595,7 @@ $nl
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
HELP: if*
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" quotation } }
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( ..a ? -- ..b )" } } { "false" { $quotation "( ..a -- ..b )" } } }
{ $description "Alternative conditional form that preserves the " { $snippet "cond" } " value if it is true."
$nl
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
@ -618,7 +618,7 @@ HELP: unless*
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } { "false" { $quotation "( default -- ... )" } } }
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" { $quotation "( ..a cond -- ..b )" } } { "false" { $quotation "( ..a default -- ..b )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"
@ -771,15 +771,15 @@ HELP: 4dip
} ;
HELP: while
{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } }
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ;
HELP: until
{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } }
{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ;
HELP: do
{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } }
{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "body" { $quotation "( ..b -- ..a )" } } }
{ $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ;
HELP: loop

6
core/kernel/kernel.factor
View File

@ -177,10 +177,10 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
: do ( pred body -- pred body )
dup 2dip ; inline
: while ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- ... )
: while ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b )
swap do compose [ loop ] curry when ; inline
: until ( ... pred: ( ... -- ... ? ) body: ( ... -- ... ) -- )
: until ( ..a pred: ( ..a -- ..b ? ) body: ( ..b -- ..a ) -- ..b )
[ [ not ] compose ] dip while ; inline
! Object protocol
@ -226,7 +226,7 @@ M: callstack clone (clone) ; inline
! Tuple construction
GENERIC: new ( class -- tuple )
GENERIC: boa ( ... class -- tuple )
GENERIC: boa ( slots... class -- tuple )
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded

4
core/lexer/lexer-docs.factor
View File

@ -67,13 +67,13 @@ HELP: still-parsing?
{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
HELP: each-token
{ $values { "end" string } { "quot" { $quotation "( token -- )" } } }
{ $values { "end" string } { "quot" { $quotation "( ... token -- ... )" } } }
{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read." }
{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
$parsing-note ;
HELP: map-tokens
{ $values { "end" string } { "quot" { $quotation "( token -- object )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } }
{ $values { "end" string } { "quot" { $quotation "( ... token -- ... elt )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } }
{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read, and the results are collected into a new output sequence." }
$parsing-note ;

4
core/lexer/lexer.factor
View File

@ -100,10 +100,10 @@ PREDICATE: unexpected-eof < unexpected
: (each-token) ( end quot -- pred quot )
[ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline
: each-token ( end quot -- )
: each-token ( ... end quot: ( ... token -- ... ) -- ... )
(each-token) while drop ; inline
: map-tokens ( end quot -- seq )
: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
(each-token) produce nip ; inline
: parse-tokens ( end -- seq )

8
core/math/math-docs.factor
View File

@ -410,22 +410,22 @@ HELP: power-of-2?
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: each-integer
{ $values { "n" integer } { "quot" { $quotation "( i -- )" } } }
{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... )" } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }
{ $notes "This word is used to implement " { $link each } "." } ;
HELP: all-integers?
{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "?" "a boolean" } }
{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "?" "a boolean" } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iteration stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." }
{ $notes "This word is used to implement " { $link all? } "." } ;
HELP: find-integer
{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs a true value or the end is reached. If the quotation yields a true value for some integer, this word outputs that integer. Otherwise, this word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find } "." } ;
HELP: find-last-integer
{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $values { "n" integer } { "quot" { $quotation "( ... i -- ... ? )" } } { "i" "an integer or " { $link f } } }
{ $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
{ $notes "This word is used to implement " { $link find-last } "." } ;

90
core/sequences/sequences-docs.factor
View File

@ -253,15 +253,15 @@ HELP: set-array-nth
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory. User code must use " { $link set-nth } " instead." } ;
HELP: collect
{ $values { "n" "a non-negative integer" } { "quot" { $quotation "( n -- value )" } } { "into" "a sequence of length at least " { $snippet "n" } } }
{ $values { "n" "a non-negative integer" } { "quot" { $quotation "( ... n -- ... value )" } } { "into" "a sequence of length at least " { $snippet "n" } } }
{ $description "A primitive mapping operation that applies a quotation to all integers from 0 up to but not including " { $snippet "n" } ", and collects the results in a new array. User code should use " { $link map } " instead." } ;
HELP: each
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... x -- ... )" } } }
{ $description "Applies the quotation to each element of the sequence in order." } ;
HELP: reduce
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." }
{ $examples
{ $example "USING: math prettyprint sequences ;" "{ 1 5 3 } 0 [ + ] reduce ." "9" }
@ -269,7 +269,7 @@ HELP: reduce
HELP: reduce-index
{ $values
{ "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt index -- result )" } } }
{ "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt index -- ... next )" } } { "result" object } }
{ $description "Combines successive elements of the sequence and their indices binary operations, and outputs the final result. On the first iteration, the three inputs to the quotation are " { $snippet "identity" } ", the first element of the sequence, and its index, 0. On successive iterations, the first input is the result of the previous iteration, the second input is the corresponding element of the sequence, and the third is its index." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 50 90 } 0 [ + + ] reduce-index ."
@ -277,7 +277,7 @@ HELP: reduce-index
} } ;
HELP: accumulate-as
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of the same type as " { $snippet "exemplar" } " containing intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
@ -285,7 +285,7 @@ $nl
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } ;
HELP: accumulate
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } }
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "final" "the final result" } { "newseq" "a new array" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs an array of intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
@ -296,7 +296,7 @@ $nl
} ;
HELP: accumulate!
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } }
{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "final" "the final result" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs the original sequence of intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
@ -307,11 +307,11 @@ $nl
} ;
HELP: map
{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
HELP: map-as
{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
{ $examples
"The following example converts a string into an array of one-element strings:"
@ -321,7 +321,7 @@ HELP: map-as
HELP: each-index
{ $values
{ "seq" sequence } { "quot" { $quotation "( elt index -- )" } } }
{ "seq" sequence } { "quot" { $quotation "( ... elt index -- ... )" } } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack." }
{ $examples { $example "USING: arrays sequences prettyprint ;"
"{ 10 20 30 } [ 2array . ] each-index"
@ -330,7 +330,7 @@ HELP: each-index
HELP: map-index
{ $values
{ "seq" sequence } { "quot" { $quotation "( elt index -- result )" } } { "newseq" sequence } }
{ "seq" sequence } { "quot" { $quotation "( ... elt index -- ... newelt )" } } { "newseq" sequence } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." }
{ $examples { $example "USING: arrays sequences prettyprint ;"
"{ 10 20 30 } [ 2array ] map-index ."
@ -338,13 +338,13 @@ HELP: map-index
} } ;
HELP: change-nth
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( elt -- newelt )" } } }
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( ... elt -- ... newelt )" } } }
{ $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
{ $errors "Throws an error if the sequence is immutable, if the index is out of bounds, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
HELP: map!
{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } }
{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( ... elt -- ... newelt )" } } }
{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence. Returns the original sequence." }
{ $errors "Throws an error if the sequence is immutable, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
@ -358,44 +358,44 @@ HELP: max-length
{ $description "Outputs the maximum of the lengths of the two sequences." } ;
HELP: 2each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... )" } } }
{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: 3each
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- )" } } }
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... )" } } }
{ $description "Applies the quotation to triples of elements from " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } "." } ;
HELP: 2reduce
{ $values { "seq1" sequence }
{ "seq2" sequence }
{ "identity" object }
{ "quot" { $quotation "( prev elt1 elt2 -- next )" } }
{ "quot" { $quotation "( ... prev elt1 elt2 -- ... next )" } }
{ "result" "the final result" } }
{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
HELP: 2map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
HELP: 3map
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "newseq" "a new sequence" } }
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... newelt )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
HELP: 2map-as
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 3map-as
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( ... elt1 elt2 elt3 -- ... newelt )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 2all?
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: find
{ $values { "seq" sequence }
{ "quot" { $quotation "( elt -- ? )" } }
{ "quot" { $quotation "( ... elt -- ... ? )" } }
{ "i" "the index of the first match, or " { $link f } }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-from } " where the starting index is 0." } ;
@ -403,51 +403,51 @@ HELP: find
HELP: find-from
{ $values { "n" "a starting index" }
{ "seq" sequence }
{ "quot" { $quotation "( elt -- ? )" } }
{ "quot" { $quotation "( ... elt -- ... ? )" } }
{ "i" "the index of the first match, or " { $link f } }
{ "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in turn, until it outputs a true value or the end of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
HELP: find-last
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "A simpler variant of " { $link find-last-from } " where the starting index is one less than the length of the sequence." } ;
HELP: find-last-from
{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
HELP: map-find
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- result/f )" } } { "result" "the first non-false result of the quotation" } { "elt" "the first matching element, or " { $link f } } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... result/f )" } } { "result" "the first non-false result of the quotation" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence, until the quotation outputs a true value. If the quotation ever yields a result which is not " { $link f } ", then the value is output, along with the element of the sequence which yielded this." } ;
HELP: any?
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ;
HELP: all?
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } }
{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
HELP: push-if
{ $values { "elt" object } { "quot" { $quotation "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
{ $values { "elt" object } { "quot" { $quotation "( ..a elt -- ..b ? )" } } { "accum" "a resizable mutable sequence" } }
{ $description "Adds the element at the end of the sequence if the quotation yields a true value." }
{ $notes "This word is a factor of " { $link filter } "." } ;
HELP: filter
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter-as
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } }
{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter!
{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( ... elt -- ... ? )" } } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
{ $side-effects "seq" } ;
HELP: interleave
{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( elt -- )" } } }
{ $values { "seq" sequence } { "between" "a quotation" } { "quot" { $quotation "( ... elt -- ... )" } } }
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
@ -622,7 +622,7 @@ HELP: reverse!
{ $side-effects "seq" } ;
HELP: padding
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( ... seq1 seq2 -- ... newseq )" } } { "newseq" "a new sequence" } }
{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
HELP: pad-head
@ -961,7 +961,7 @@ HELP: supremum
{ $errors "Throws an error if the sequence is empty." } ;
HELP: produce
{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "seq" "a sequence" } }
{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "quot" { $quotation "( ..b -- ..a obj )" } } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
@ -971,7 +971,7 @@ HELP: produce
} ;
HELP: produce-as
{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "exemplar" sequence } { "seq" "a sequence" } }
{ $values { "pred" { $quotation "( ..a -- ..b ? )" } } { "quot" { $quotation "( ..b -- ..a obj )" } } { "exemplar" sequence } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." }
{ $examples "See " { $link produce } " for examples." } ;
@ -995,8 +995,8 @@ HELP: count
HELP: selector
{ $values
{ "quot" { $quotation "( elt -- ? )" } }
{ "selector" { $quotation "( elt -- )" } } { "accum" vector } }
{ "quot" { $quotation "( ... elt -- ... ? )" } }
{ "selector" { $quotation "( ... elt -- ... )" } } { "accum" vector } }
{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the collector if the test yields true. The collector is left on the stack for convenience." }
{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
"10 iota [ even? ] selector [ each ] dip ."
@ -1140,7 +1140,7 @@ HELP: set-fourth
HELP: replicate
{ $values
{ "len" integer } { "quot" { $quotation "( -- elt )" } }
{ "len" integer } { "quot" { $quotation "( ... -- ... newelt )" } }
{ "newseq" sequence } }
{ $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new array." }
{ $examples
@ -1152,7 +1152,7 @@ HELP: replicate
HELP: replicate-as
{ $values
{ "len" integer } { "quot" { $quotation "( -- elt )" } } { "exemplar" sequence }
{ "len" integer } { "quot" { $quotation "( ... -- ... newelt )" } } { "exemplar" sequence }
{ "newseq" sequence } }
{ $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
{ $examples
@ -1190,7 +1190,7 @@ HELP: virtual@
HELP: 2map-reduce
{ $values
{ "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation "( elt1 elt2 -- intermediate )" } } { "reduce-quot" { $quotation "( prev intermediate -- result )" } }
{ "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation "( ..a elt1 elt2 -- ..b intermediate )" } } { "reduce-quot" { $quotation "( ..b prev intermediate -- ..a next )" } }
{ "result" object } }
{ $description "Calls " { $snippet "map-quot" } " on each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } " and combines the results using " { $snippet "reduce-quot" } " in the same manner as " { $link reduce } ", except that there is no identity element, and the sequence must have a length of at least 1." }
{ $errors "Throws an error if the sequence is empty." }
@ -1236,7 +1236,7 @@ HELP: collector
HELP: binary-reduce
{ $values
{ "seq" sequence } { "start" integer } { "quot" { $quotation "( elt1 elt2 -- newelt )" } }
{ "seq" sequence } { "start" integer } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } }
{ "value" object } }
{ $description "Like " { $link reduce } ", but splits the sequence in half recursively until each sequence is small enough, and calls the quotation on these smaller sequences. If the quotation computes values that depend on the size of their input, such as bignum arithmetic, then this algorithm can be more efficient than using " { $link reduce } "." }
{ $examples "Computing factorial:"
@ -1247,7 +1247,7 @@ HELP: binary-reduce
HELP: follow
{ $values
{ "obj" object } { "quot" { $quotation "( prev -- result/f )" } }
{ "obj" object } { "quot" { $quotation "( ... prev -- ... result/f )" } }
{ "seq" sequence } }
{ $description "Outputs a sequence containing the input object and all of the objects generated by successively feeding the result of the quotation called on the input object to the quotation recursuively. Objects yielded by the quotation are added to the output sequence until the quotation yields " { $link f } ", at which point the recursion terminates." }
{ $examples "Get random numbers until zero is reached:"
@ -1365,11 +1365,11 @@ HELP: assert-sequence=
} ;
HELP: cartesian-each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... )" } } }
{ $description "Applies the quotation to every possible pairing of elements from the two sequences." } ;
HELP: cartesian-map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- result )" } } { "newseq" "a new sequence of sequences" } }
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( ... elt1 elt2 -- ... newelt )" } } { "newseq" "a new sequence of sequences" } }
{ $description "Applies the quotation to every possible pairing of elements from the two sequences, collecting results into a new sequence of sequences." } ;
HELP: cartesian-product

44
core/sequences/sequences.factor
View File

@ -417,19 +417,19 @@ PRIVATE>
: map-integers ( len quot exemplar -- newseq )
[ over ] dip [ [ collect ] keep ] new-like ; inline
: map-as ( ... seq quot: ( ... x -- ... newx ) exemplar -- ... newseq )
: map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
[ (each) ] dip map-integers ; inline
: map ( ... seq quot: ( ... x -- ... newx ) -- ... newseq )
: map ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
over map-as ; inline
: replicate-as ( ... len quot: ( ... -- ... newx ) exemplar -- ... newseq )
: replicate-as ( ... len quot: ( ... -- ... newelt ) exemplar -- ... newseq )
[ [ drop ] prepose ] dip map-integers ; inline
: replicate ( ... len quot: ( ... -- ... newx ) -- ... newseq )
: replicate ( ... len quot: ( ... -- ... newelt ) -- ... newseq )
{ } replicate-as ; inline
: map! ( ... seq quot: ( ... x -- ... x' ) -- ... seq )
: map! ( ... seq quot: ( ... elt -- ... newelt ) -- ... seq )
over [ map-into ] keep ; inline
: accumulate-as ( ... seq identity quot: ( ... prev elt -- ... next ) exemplar -- ... final newseq )
@ -441,31 +441,31 @@ PRIVATE>
: accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
(accumulate) map! ; inline
: 2each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
: 2each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
(2each) each-integer ; inline
: 2reverse-each ( ... seq1 seq2 quot: ( ... x1 x2 -- ... ) -- ... )
: 2reverse-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
[ [ <reversed> ] bi@ ] dip 2each ; inline
: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline
: 2map-as ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) exemplar -- ... newseq )
: 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq )
[ (2each) ] dip map-integers ; inline
: 2map ( ... seq1 seq2 quot: ( ... x1 x2 -- ... newx ) -- ... newseq )
: 2map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
pick 2map-as ; inline
: 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
(2each) all-integers? ; inline
: 3each ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... ) -- ... )
: 3each ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) -- ... )
(3each) each-integer ; inline
: 3map-as ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) exemplar -- ... newseq )
: 3map-as ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) exemplar -- ... newseq )
[ (3each) ] dip map-integers ; inline
: 3map ( ... seq1 seq2 seq3 quot: ( ... x1 x2 x3 -- ... newx ) -- ... newseq )
: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq )
[ pick ] dip swap 3map-as ; inline
: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
@ -483,7 +483,7 @@ PRIVATE>
: all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
(each) all-integers? ; inline
: push-if ( ... elt quot: ( ... elt -- ... ? ) accum -- ... )
: push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
: selector-for ( quot exemplar -- selector accum )
@ -498,7 +498,7 @@ PRIVATE>
: filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
over filter-as ; inline
: push-either ( ... elt quot: ( ... elt -- ... ? ) accum1 accum2 -- ... )
: push-either ( ..a elt quot: ( ..a elt -- ..b ? ) accum1 accum2 -- ..b )
[ keep swap ] 2dip ? push ; inline
: 2selector ( quot -- selector accum1 accum2 )
@ -513,16 +513,16 @@ PRIVATE>
: collector ( quot -- quot' vec )
V{ } collector-for ; inline
: produce-as ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) exemplar -- ... seq )
: produce-as ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) exemplar -- ..b seq )
dup [ collector-for [ while ] dip ] curry dip like ; inline
: produce ( ... pred: ( ... -- ... ? ) quot: ( ... -- ... obj ) -- ... seq )
: produce ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) -- ..b seq )
{ } produce-as ; inline
: follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq )
[ dup ] swap [ keep ] curry produce nip ; inline
: each-index ( ... seq quot: ( ... x i -- ... ) -- ... )
: each-index ( ... seq quot: ( ... elt index -- ... ) -- ... )
(each-index) each-integer ; inline
: interleave ( seq between quot -- )
@ -532,10 +532,10 @@ PRIVATE>
3bi
] if ; inline
: map-index ( ... seq quot: ( ... x i -- ... newx ) -- ... newseq )
: map-index ( ... seq quot: ( ... elt index -- ... newelt ) -- ... newseq )
[ dup length iota ] dip 2map ; inline
: reduce-index ( ... seq identity quot: ( ... prev x i -- ... next ) -- ... result )
: reduce-index ( ... seq identity quot: ( ... prev elt index -- ... next ) -- ... result )
swapd each-index ; inline
: index ( obj seq -- n )
@ -877,7 +877,7 @@ PRIVATE>
[ [ unclip-slice ] dip [ call ] keep ] dip
compose reduce ; inline
: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a x1 x2 -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
: 2map-reduce ( ..a seq1 seq2 map-quot: ( ..a elt1 elt2 -- ..b intermediate ) reduce-quot: ( ..b prev intermediate -- ..a next ) -- ..a result )
[ [ prepare-2map-reduce ] keep ] dip
compose compose each-integer ; inline
@ -889,10 +889,10 @@ PRIVATE>
PRIVATE>
: map-find ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
: map-find ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt )
[ find ] (map-find) ; inline
: map-find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... result elt )
: map-find-last ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt )
[ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last )

2
core/splitting/splitting.factor
View File

@ -61,7 +61,7 @@ PRIVATE>
[ drop [ swap [ tail ] unless-zero , ] 2curry ]
3tri if* ; inline recursive
: split, ( seq quot -- ) [ 0 ] 2dip (split) ; inline
: split, ( ... seq quot: ( ... elt -- ... ? ) -- ... ) [ 0 ] 2dip (split) ; inline
PRIVATE>

76
extra/astar/astar-docs.factor Normal file
View File

@ -0,0 +1,76 @@
! Copyright (C) 2010 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: astar
HELP: astar
{ $description "This tuple must be subclassed and its method " { $link cost } ", "
{ $link heuristic } ", and " { $link neighbours } " must be implemented. "
"Alternatively, the " { $link <astar> } " word can be used to build a non-specialized version." } ;
HELP: cost
{ $values
{ "from" "a node" }
{ "to" "a node" }
{ "astar" "an instance of a subclassed " { $link astar } " tuple" }
{ "n" "a number" }
}
{ $description "Return the cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
{ $snippet "to" } " is necessarily a neighbour of " { $snippet "from" } "."
} ;
HELP: heuristic
{ $values
{ "from" "a node" }
{ "to" "a node" }
{ "astar" "an instance of a subclassed " { $link astar } " tuple" }
{ "n" "a number" }
}
{ $description "Return the estimated (undervalued) cost to go from " { $snippet "from" } " to " { $snippet "to" } ". "
{ $snippet "from" } " and " { $snippet "to" } " are not necessarily neighbours."
} ;
HELP: neighbours
{ $values
{ "node" "a node" }
{ "astar" "an instance of a subclassed " { $link astar } " tuple" }
{ "seq" "a sequence of nodes" }
}
{ $description "Return the list of nodes reachable from " { $snippet "node" } "." } ;
HELP: <astar>
{ $values
{ "neighbours" "a quotation with stack effect ( node -- seq )" }
{ "cost" "a quotation with stack effect ( from to -- cost )" }
{ "heuristic" "a quotation with stack effect ( pos target -- cost )" }
{ "astar" "a astar tuple" }
}
{ $description "Build an astar object from the given quotations. The "
{ $snippet "neighbours" } " one builds the list of neighbours. The "
{ $snippet "cost" } " and " { $snippet "heuristic" } " ones represent "
"respectively the cost for transitioning from a node to one of its neighbour, "
"and the underestimated cost for going from a node to the target. This solution "
"may not be as efficient as subclassing the " { $link astar } " tuple."
} ;
HELP: find-path
{ $values
{ "start" "a node" }
{ "target" "a node" }
{ "astar" "a astar tuple" }
{ "path/f" "an optimal path from " { $snippet "start" } " to " { $snippet "target" }
", or f if no such path exists" }
}
{ $description "Find a path between " { $snippet "start" } " and " { $snippet "target" }
" using the A* algorithm. The " { $snippet "astar" } " tuple must have been previously "
" built using " { $link <astar> } "."
} ;
HELP: considered
{ $values
{ "astar" "a astar tuple" }
{ "considered" "a sequence" }
}
{ $description "When called after a call to " { $link find-path } ", return a list of nodes "
"which have been examined during the A* exploration."
} ;

109
extra/astar/astar-tests.factor Normal file
View File

@ -0,0 +1,109 @@
! Copyright (C) 2010 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs astar combinators hashtables kernel literals math math.functions
math.vectors sequences sorting splitting strings tools.test ;
IN: astar.tests
<<
! Use a 10x9 maze (see below) to try to go from s to e, f or g.
! X means that a position is unreachable.
! The costs model is:
! - going up costs 5 points
! - going down costs 1 point
! - going left or right costs 2 points
: reachable? ( pos -- ? )
first2 [ 2 * 5 + ] [ 2 + ] bi* $[
" 0 1 2 3 4 5 6 7 8 9
0 X X X X X X X X X X
1 X s f X X
2 X X X X X X X X X
3 X X X X X X X X X
4 X X X X X X
5 X X X X X
6 X X X X X X e X
7 X g X X
8 X X X X X X X X X X"
"\n" split ] nth nth CHAR: X = not ;
: neighbours ( pos -- neighbours )
first2
{ [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
4array
[ reachable? ] filter ;
: heuristic ( from to -- cost )
v- [ abs ] [ + ] map-reduce ;
: cost ( from to -- cost )
2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
: test1 ( to -- path considered )
{ 1 1 } swap [ neighbours ] [ cost ] [ heuristic ] <astar> [ find-path ] [ considered ] bi ;
>>
! Existing path from s to f
[
{
{ 1 1 }
{ 2 1 }
{ 3 1 }
{ 4 1 }
{ 4 2 }
{ 4 3 }
{ 4 4 }
{ 4 5 }
{ 4 6 }
{ 4 7 }
{ 5 7 }
{ 6 7 }
{ 7 7 }
{ 8 7 }
{ 8 6 }
}
] [
{ 8 6 } test1 drop
] unit-test
! Check that only the right positions have been considered in the s to f path
[ 7 ] [ { 7 1 } test1 nip length ] unit-test
! Non-existing path from s to g -- all positions must have been considered
[ f 26 ] [ { 1 7 } test1 length ] unit-test
<<
! Look for a path between A and C. The best path is A --> D --> C. C will be placed
! in the open set early because B will be examined first. This checks that the evaluation
! of C is correctly replaced in the open set.
!
! We use no heuristic here and always return 0.
!
! (5)
! B ---> C <--------
! \ (2)
! ^ ^ |
! | | |
! (1) | | (2) |
! | | |
!
! A ---> D ---------> E ---> F
! (2) (1) (1)
: n ( pos -- neighbours )
$[ { "ABD" "BC" "C" "DCE" "ECF" } [ unclip swap 2array ] map >hashtable ] at ;
: c ( from to -- cost )
"" 2sequence H{ { "AB" 1 } { "AD" 2 } { "BC" 5 } { "DC" 2 } { "DE" 1 } { "EC" 2 } { "EF" 1 } } at ;
: test2 ( fromto -- path considered )
first2 [ n ] [ c ] [ 2drop 0 ] <astar> [ find-path ] [ considered natural-sort >string ] bi ;
>>
! Check path from A to C -- all nodes but F must have been examined
[ "ADC" "ABCDE" ] [ "AC" test2 [ >string ] dip ] unit-test
! No path from D to B -- all nodes reachable from D must have been examined
[ f "CDEF" ] [ "DB" test2 ] unit-test

81
extra/astar/astar.factor Normal file
View File

@ -0,0 +1,81 @@
! Copyright (C) 2010 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel math sequences sets shuffle ;
IN: astar
! This implements the A* algorithm. See http://en.wikipedia.org/wiki/A*
TUPLE: astar g in-closed-set ;
GENERIC: cost ( from to astar -- n )
GENERIC: heuristic ( from to astar -- n )
GENERIC: neighbours ( node astar -- seq )
<PRIVATE
TUPLE: (astar) astar goal origin in-open-set open-set ;
: (add-to-open-set) ( h node astar -- )
2dup in-open-set>> at* [ over open-set>> heap-delete ] [ drop ] if
[ swapd open-set>> heap-push* ] [ in-open-set>> set-at ] 2bi ;
: add-to-open-set ( node astar -- )
[ astar>> g>> at ] 2keep
[ [ goal>> ] [ astar>> heuristic ] bi + ] 2keep
(add-to-open-set) ;
: ?add-to-open-set ( node astar -- )
2dup astar>> in-closed-set>> key? [ 2drop ] [ add-to-open-set ] if ;
: move-to-closed-set ( node astar -- )
[ astar>> in-closed-set>> conjoin ] [ in-open-set>> delete-at ] 2bi ;
: get-first ( astar -- node )
[ open-set>> heap-pop drop dup ] [ move-to-closed-set ] bi ;
: set-g ( origin g node astar -- )
[ [ origin>> set-at ] [ astar>> g>> set-at ] bi-curry bi-curry bi* ] [ ?add-to-open-set ] 2bi ;
: cost-through ( origin node astar -- cost )
[ astar>> cost ] [ nip astar>> g>> at ] 3bi + ;
: ?set-g ( origin node astar -- )
[ cost-through ] 3keep [ swap ] 2dip
3dup astar>> g>> at [ 1/0. ] unless* > [ 4drop ] [ set-g ] if ;
: build-path ( target astar -- path )
[ over ] [ over [ [ origin>> at ] keep ] dip ] produce 2nip reverse ;
: handle ( node astar -- )
dupd [ astar>> neighbours ] keep [ ?set-g ] curry with each ;
: (find-path) ( astar -- path/f )
dup open-set>> heap-empty? [
drop f
] [
[ get-first ] keep 2dup goal>> = [ build-path ] [ [ handle ] [ (find-path) ] bi ] if
] if ;
: (init) ( from to astar -- )
swap >>goal
H{ } clone over astar>> (>>g)
H{ } clone over astar>> (>>in-closed-set)
H{ } clone >>origin
H{ } clone >>in-open-set
<min-heap> >>open-set
[ 0 ] 2dip [ (add-to-open-set) ] [ astar>> g>> set-at ] 3bi ;
TUPLE: astar-simple < astar cost heuristic neighbours ;
M: astar-simple cost cost>> call( n1 n2 -- c ) ;
M: astar-simple heuristic heuristic>> call( n1 n2 -- c ) ;
M: astar-simple neighbours neighbours>> call( n -- neighbours ) ;
PRIVATE>
: find-path ( start target astar -- path/f )
(astar) new [ (>>astar) ] keep [ (init) ] [ (find-path) ] bi ;
: <astar> ( neighbours cost heuristic -- astar )
astar-simple new swap >>heuristic swap >>cost swap >>neighbours ;
: considered ( astar -- considered )
in-closed-set>> keys ;

1
extra/astar/authors.txt Normal file
View File

@ -0,0 +1 @@
Samuel Tardieu

1
extra/astar/summary.txt Normal file
View File

@ -0,0 +1 @@
A* path-finding algorithm

2
extra/bank/bank.factor
View File

@ -54,7 +54,7 @@ C: <transaction> transaction
: process-day ( account date -- )
2dup accumulate-interest ?pay-interest ;
: each-day ( quot: ( -- ) start end -- )
: each-day ( ... quot: ( ... day -- ... ) start end -- ... )
2dup before? [
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [

2
extra/benchmark/nbody-simd/nbody-simd.factor
View File

@ -58,7 +58,7 @@ SPECIALIZED-ARRAY: body
body-array{ } output>sequence
dup init-bodies ; inline
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- )
bodies [| body i |
body each-quot call
bodies i 1 + tail-slice [

2
extra/benchmark/nbody/nbody.factor
View File

@ -58,7 +58,7 @@ TUPLE: nbody-system { bodies array read-only } ;
[ <sun> <jupiter> <saturn> <uranus> <neptune> ] output>array nbody-system boa
dup bodies>> init-bodies ; inline
:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
:: each-pair ( ... bodies pair-quot: ( ... other-body body -- ... ) each-quot: ( ... body -- ... ) -- ... )
bodies [| body i |
body each-quot call
bodies i 1 + tail-slice [

12
extra/bson/writer/writer.factor
View File

@ -32,22 +32,22 @@ PRIVATE>
: ensure-buffer ( -- )
(buffer) drop ; inline
: with-buffer ( quot: ( -- ) -- byte-vector )
: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
[ (buffer) [ reset-buffer ] keep dup ] dip
with-output-stream* ; inline
: with-length ( quot: ( -- ) -- bytes-written start-index )
: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
[ (buffer) [ length ] keep ] dip
call length swap [ - ] keep ; inline
: (with-length-prefix) ( quot: ( -- ) length-quot: ( bytes-written -- length ) -- )
: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
[ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
[ call ] dip (buffer) copy ; inline
: with-length-prefix ( quot: ( -- ) -- )
: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
[ INT32-SIZE >le ] (with-length-prefix) ; inline
: with-length-prefix-excl ( quot: ( -- ) -- )
: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
[ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
<PRIVATE
@ -152,4 +152,4 @@ PRIVATE>
: mdb-special-value? ( value -- ? )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
[ oid? ] [ byte-array? ] } 1|| ; inline
[ oid? ] [ byte-array? ] } 1|| ; inline

4
extra/fuel/fuel.factor
View File

@ -55,14 +55,14 @@ SYMBOL: :uses-suggestions
PRIVATE>
: fuel-use-suggested-vocabs ( suggestions quot -- ... )
: fuel-use-suggested-vocabs ( ..a suggestions quot: ( ..a -- ..b ) -- ..b )
[ :uses-suggestions set ] dip
[ try-suggested-restarts rethrow ] recover ; inline
: fuel-run-file ( path -- )
[ fuel-set-use-hook run-file ] curry with-scope ; inline
: fuel-with-autouse ( ... quot: ( ... -- ... ) -- ... )
: fuel-with-autouse ( ..a quot: ( ..a -- ..b ) -- ..b )
[ auto-use? on fuel-set-use-hook call ] curry with-scope ; inline
: fuel-get-uses ( lines -- )

2
extra/gpu/buffers/buffers-docs.factor
View File

@ -203,7 +203,7 @@ HELP: vertex-buffer
HELP: with-mapped-buffer
{ $values
{ "buffer" buffer } { "access" buffer-access-mode } { "quot" { $quotation "( alien -- )" } }
{ "buffer" buffer } { "access" buffer-access-mode } { "quot" { $quotation "( ..a alien -- ..b )" } }
}
{ $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;

8
extra/gpu/buffers/buffers.factor
View File

@ -132,7 +132,7 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size
from-buffer-ptr offset>> to-buffer-ptr offset>>
size glCopyBufferSubData ;
:: with-mapped-buffer ( buffer access quot: ( alien -- ) -- )
:: with-mapped-buffer ( ..a buffer access quot: ( ..a alien -- ..b ) -- ..b )
buffer bind-buffer :> target
target access gl-access glMapBuffer
@ -140,15 +140,15 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size
target glUnmapBuffer drop ; inline
:: with-bound-buffer ( buffer target quot: ( -- ) -- )
:: with-bound-buffer ( ..a buffer target quot: ( ..a -- ..b ) -- ..b )
target gl-target buffer glBindBuffer
quot call ; inline
: with-buffer-ptr ( buffer-ptr target quot: ( c-ptr -- ) -- )
: with-buffer-ptr ( ..a buffer-ptr target quot: ( ..a c-ptr -- ..b ) -- ..b )
[ [ offset>> <alien> ] [ buffer>> handle>> ] bi ] 2dip
with-bound-buffer ; inline
: with-gpu-data-ptr ( gpu-data-ptr target quot: ( c-ptr -- ) -- )
: with-gpu-data-ptr ( ..a gpu-data-ptr target quot: ( ..a c-ptr -- ..b ) -- ..b )
pick buffer-ptr?
[ with-buffer-ptr ]
[ [ gl-target 0 glBindBuffer ] dip call ] if ; inline

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

@ -14,7 +14,7 @@ SYMBOL: current-irc-client
: chats> ( -- seq ) irc> chats>> values ;
: me? ( string -- ? ) irc> nick>> = ;
: with-irc ( irc-client quot: ( -- ) -- )
: with-irc ( ..a irc-client quot: ( ..a -- ..b ) -- ..b )
\ current-irc-client swap with-variable ; inline
UNION: to-target privmsg notice ;

4
extra/math/matrices/simd/simd.factor
View File

@ -28,7 +28,7 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
c1 c2 c3 c4 columns 4 set-firstn-unsafe
c ; inline
: make-matrix4 ( quot: ( -- c1 c2 c3 c4 ) -- c )
: make-matrix4 ( ..a quot: ( ..a -- ..b c1 c2 c3 c4 ) -- ..b c )
matrix4 (struct) swap dip set-columns ; inline
:: 2map-columns ( a b quot -- c )
@ -42,7 +42,7 @@ M: matrix4 new-sequence 2drop matrix4 (struct) ; inline
a4 b4 quot call
] make-matrix4 ; inline
: map-columns ( a quot -- c )
: map-columns ( ... a quot: ( ... col -- ... newcol ) -- ... c )
'[ columns _ 4 napply ] make-matrix4 ; inline
PRIVATE>

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