: 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
] [
<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 = [
PRIVATE>
-: circular-while ( circular quot: ( obj -- ? ) -- )
+: circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... )
[ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline
@
] 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
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
: 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 ;
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 ] [
[
: 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 ]
[ 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 ;
\ No newline at end of file
+ dup post-order drop ;
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
[ 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
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 ;
: 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
: optimize-tail-calls ( cfg -- cfg' )
dup [ optimize-tail-call ] each-basic-block
- cfg-changed predecessors-changed ;
\ No newline at end of file
+ cfg-changed predecessors-changed ;
: 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
compile-call
] unit-test
-: foobar ( quot: ( -- ) -- )
+: foobar ( quot: ( ..a -- ..b ) -- )
[ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
[ ] [ [ [ f ] foobar ] compile-call ] unit-test
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>>
] [
math.order ;
IN: compiler.tree.combinators
-: each-node ( nodes quot: ( node -- ) -- )
+: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
dup dup '[
_ [
dup #branch? [
] bi
] each ; inline recursive
-: map-nodes ( nodes quot: ( node -- node' ) -- nodes )
+: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
dup dup '[
@
dup #branch? [
] if
] map-flat ; inline recursive
-: contains-node? ( nodes quot: ( node -- ? ) -- ? )
+: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
dup dup '[
_ keep swap [ drop t ] [
dup #branch? [
: 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 ;
[ ] [ [ [ 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
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 ] [ [ 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 ;
interval
literal
literal?
-length
slots ;
CONSTANT: null-info T{ value-info f null empty-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 ;
] 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
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>
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 ] }
[ [ 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 ;
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 ] }
[ [ 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 ;
{ [ 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
[ 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 ;
! 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? ;
} 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
: 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* ;
recursive-nesting get pop*
] each ;
-: while-changing ( quot: ( -- ) -- )
+: while-changing ( ... quot: ( ... -- ... ) -- ... )
changed? off
[ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
inline recursive
} [ [ ] 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
[ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]\r
[ huffman-code code>> free-bits neg 2^ /i 1array ] if ;\r
\r
-:: huffman-each ( tdesc quot: ( huffman-code -- ) -- )\r
+:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )\r
<huffman-code> :> code\r
tdesc\r
[\r
{ $values\r
{ "mailbox" mailbox }\r
{ "timeout" "a " { $link duration } " or " { $link f } }\r
- { "pred" { $quotation "( obj -- ? )" } } \r
+ { "pred" { $quotation "( ... message -- ... ? )" } } \r
}\r
{ $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." } ;\r
\r
: 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
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
: 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 -- )
] 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 -- ? )
[ 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
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 -- )
f >>back
drop ;
-: dlist-each ( dlist quot -- )
+: dlist-each ( ... dlist quot: ( ... value -- ... ) -- ... )
'[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
: 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
{ $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." } ;
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 )
: 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>
{ 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 )
furnace.boilerplate\r
furnace.auth.providers\r
furnace.auth.providers.db ;\r
+FROM: assocs => change-at ;\r
IN: furnace.auth\r
\r
SYMBOL: logged-in-user\r
! 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? ;
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
[ 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?
! 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
[ 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 ;
[ 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*
{ 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
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
: 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 )
: 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 ;
: 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> ;
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 )
<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 =
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)
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 )
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? } ;
{ $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! } ;
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 -- ? )
_ 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
: 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
: 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
] [
[ 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 )
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
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
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 ;
[ #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 ;
[ 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 ;
: 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
: (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 ;
+
! 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
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 ;
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* ;
: copy-inference ( -- )
\ meta-d [ clone ] change
literals [ clone ] change
- input-count [ ] change ;
+ input-count [ ] change
+ inner-d-index [ ] change ;
GENERIC: infer-branch ( literal -- namespace )
[ value>> quotation set ] [ infer-literal-quot ] bi
] H{ } make-assoc ;
+M: declared-effect infer-branch
+ known>> infer-branch ;
+
M: callable infer-branch
[
copy-inference
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
} ;
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
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 ;
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 ;
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" ;
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. ;
: 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 -- )
: 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
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 -- )
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 ;
+++ /dev/null
-! (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
-
! (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
stack-checker.visitor ;
IN: stack-checker.row-polymorphism
-<PRIVATE
-SYMBOLS: current-effect-variables current-word-effect current-meta-d ;
-
-: quotation-effect? ( in -- ? )
- dup pair? [ second effect? ] [ drop f ] if ;
-
-SYMBOL: (unknown)
-
-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 )
+:: 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
+
+:: with-effect-here ( quot -- effect )
+ input-count get :> old-input-count
+ meta-d length :> old-meta-d-length
+
+ 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
+
+:: 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
-
-:: (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 ;
-
-: 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 ;
+: complex-unbalanced-branches-error ( known -- * )
+ [ word>> ] [
+ branches>> <reversed>
+ [ [ known>callable ] { } map-as ]
+ [ [ effect>> ] { } map-as ]
+ [ [ actual>> ] { } map-as ] tri
+ ] bi unbalanced-branches-error ;
-: 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 ;
+: check-declared-effect ( known effect -- )
+ [ >>actual ] keep
+ 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
+ [ 2drop ] [ drop complex-unbalanced-branches-error ] if ;
-SYMBOL: infer-polymorphic?
{ "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 } ":"
! 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
[ [ 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
[ "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
+
! Number of inputs current word expects from the stack
SYMBOL: input-count
+SYMBOL: inner-d-index
DEFER: commit-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 ;
:: ((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? ;
! 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
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 ;
\ No newline at end of file
+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 ;
+
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
-unportable bindings
\ No newline at end of file
+bindings\r
-unportable bindings\r
+bindings\r
-unportable bindings
+bindings
: 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 ] }
! 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 )
} ;
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." } ;
} ;
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."
}
} ;
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."
}
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
: 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>
{ "(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 )) }
{ $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
} ;
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" } ")." } ;
{ 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
[ 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
{ $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
] 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 -- )
ERROR: attempt-all-error ;
-: attempt-all ( seq quot -- obj )
+: attempt-all ( ... seq quot: ( ... elt -- ... obj ) -- ... obj )
over empty? [
attempt-all-error
] [
-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"
{ $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
{ { $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
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
: 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
: 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
{ $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" }
} ;
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" }
{ $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:"
"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."
{ $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:"
} ;
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
: 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
! 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
{ $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 ;
: (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 )
{ $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 } "." } ;
{ $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" }
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 ."
} } ;
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."
"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."
} ;
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."
} ;
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:"
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"
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 ."
} } ;
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" } ;
{ $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." } ;
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" } ;
{ $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
{ $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:"
} ;
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." } ;
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 ."
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
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
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." }
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:"
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:"
} ;
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
: 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 )
: 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 )
: 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 )
: 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 )
: 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 -- )
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 )
[ [ 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
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 )
[ 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>
--- /dev/null
+! 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."
+} ;
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
--- /dev/null
+Samuel Tardieu
--- /dev/null
+A* path-finding algorithm
: 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
] [
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 [
[ <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 [
: 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
: mdb-special-value? ( value -- ? )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
- [ oid? ] [ byte-array? ] } 1|| ; inline
\ No newline at end of file
+ [ oid? ] [ byte-array? ] } 1|| ; inline
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 -- )
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." } ;
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
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
: 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 ;
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 )
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>
--- /dev/null
+Erik Charlebois
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test opencl.ffi multiline locals kernel io.encodings.ascii
+io.encodings.string sequences libc alien.c-types destructors math specialized-arrays
+math.order alien ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAYS: float void* ;
+IN: opencl.ffi.tests
+
+STRING: kernel-source
+__kernel void square(
+ __global float* input,
+ __global float* output,
+ const unsigned int count)
+{
+ int i = get_global_id(0);
+ if (i < count)
+ output[i] = input[i] * input[i];
+}
+;
+
+ERROR: cl-error err ;
+: cl-success ( err -- )
+ dup CL_SUCCESS = [ drop ] [ cl-error ] if ;
+
+:: cl-string-array ( str -- alien )
+ str ascii encode 0 suffix :> str-buffer
+ str-buffer length malloc &free :> str-alien
+ str-alien str-buffer dup length memcpy str-alien ;
+
+:: opencl-square ( in -- out )
+ 0 f 0 <uint> [ clGetPlatformIDs cl-success ] keep *uint
+ dup <void*-array> [ f clGetPlatformIDs cl-success ] keep first
+ CL_DEVICE_TYPE_DEFAULT 1 f <void*> [ f clGetDeviceIDs cl-success ] keep *void* :> device-id
+ f 1 device-id <void*> f f 0 <int> [ clCreateContext ] keep *int cl-success :> context
+ context device-id 0 0 <int> [ clCreateCommandQueue ] keep *int cl-success :> queue
+
+ [
+ context 1 kernel-source cl-string-array <void*>
+ f 0 <int> [ clCreateProgramWithSource ] keep *int cl-success
+ [ 0 f f f f clBuildProgram cl-success ]
+ [ "square" cl-string-array 0 <int> [ clCreateKernel ] keep *int cl-success ]
+ [ ] tri
+ ] with-destructors :> ( kernel program )
+
+ context CL_MEM_READ_ONLY in byte-length f
+ 0 <int> [ clCreateBuffer ] keep *int cl-success :> input
+
+ context CL_MEM_WRITE_ONLY in byte-length f
+ 0 <int> [ clCreateBuffer ] keep *int cl-success :> output
+
+ queue input CL_TRUE 0 in byte-length in 0 f f clEnqueueWriteBuffer cl-success
+
+ kernel 0 cl_mem heap-size input <void*> clSetKernelArg cl-success
+ kernel 1 cl_mem heap-size output <void*> clSetKernelArg cl-success
+ kernel 2 uint heap-size in length <uint> clSetKernelArg cl-success
+
+ queue kernel 1 f in length <ulonglong> f
+ 0 f f clEnqueueNDRangeKernel cl-success
+
+ queue clFinish cl-success
+
+ queue output CL_TRUE 0 in byte-length in length <float-array>
+ [ 0 f f clEnqueueReadBuffer cl-success ] keep
+
+ input clReleaseMemObject cl-success
+ output clReleaseMemObject cl-success
+ program clReleaseProgram cl-success
+ kernel clReleaseKernel cl-success
+ queue clReleaseCommandQueue cl-success
+ context clReleaseContext cl-success ;
+
+[ float-array{ 1.0 4.0 9.0 16.0 100.0 } ]
+[ float-array{ 1.0 2.0 3.0 4.0 10.0 } opencl-square ] unit-test
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.libraries alien.syntax classes.struct
+combinators system alien.accessors byte-arrays kernel ;
+IN: opencl.ffi
+
+<< "opencl" {
+ { [ os windows? ] [ "OpenCL.dll" ] }
+ { [ os macosx? ] [ "/System/Library/Frameworks/OpenCL.framework/OpenCL" ] }
+ { [ os unix? ] [ "libOpenCL.so" ] }
+ } cond "stdcall" add-library >>
+LIBRARY: opencl
+
+! cl_platform.h
+TYPEDEF: char cl_char
+TYPEDEF: uchar cl_uchar
+TYPEDEF: short cl_short
+TYPEDEF: ushort cl_ushort
+TYPEDEF: int cl_int
+TYPEDEF: uint cl_uint
+TYPEDEF: longlong cl_long
+TYPEDEF: ulonglong cl_ulong
+TYPEDEF: ushort cl_half
+TYPEDEF: float cl_float
+TYPEDEF: double cl_double
+
+CONSTANT: CL_CHAR_BIT 8
+CONSTANT: CL_SCHAR_MAX 127
+CONSTANT: CL_SCHAR_MIN -128
+CONSTANT: CL_CHAR_MAX 127
+CONSTANT: CL_CHAR_MIN -128
+CONSTANT: CL_UCHAR_MAX 255
+CONSTANT: CL_SHRT_MAX 32767
+CONSTANT: CL_SHRT_MIN -32768
+CONSTANT: CL_USHRT_MAX 65535
+CONSTANT: CL_INT_MAX 2147483647
+CONSTANT: CL_INT_MIN -2147483648
+CONSTANT: CL_UINT_MAX HEX: ffffffff
+CONSTANT: CL_LONG_MAX HEX: 7FFFFFFFFFFFFFFF
+CONSTANT: CL_LONG_MIN HEX: 8000000000000000
+CONSTANT: CL_ULONG_MAX HEX: FFFFFFFFFFFFFFFF
+
+CONSTANT: CL_FLT_DIG 6
+CONSTANT: CL_FLT_MANT_DIG 24
+CONSTANT: CL_FLT_MAX_10_EXP 38
+CONSTANT: CL_FLT_MAX_EXP 128
+CONSTANT: CL_FLT_MIN_10_EXP -37
+CONSTANT: CL_FLT_MIN_EXP -125
+CONSTANT: CL_FLT_RADIX 2
+CONSTANT: CL_FLT_MAX 340282346638528859811704183484516925440.0
+CONSTANT: CL_FLT_MIN 1.175494350822287507969e-38
+CONSTANT: CL_FLT_EPSILON HEX: 1.0p-23
+
+CONSTANT: CL_DBL_DIG 15
+CONSTANT: CL_DBL_MANT_DIG 53
+CONSTANT: CL_DBL_MAX_10_EXP 308
+CONSTANT: CL_DBL_MAX_EXP 1024
+CONSTANT: CL_DBL_MIN_10_EXP -307
+CONSTANT: CL_DBL_MIN_EXP -1021
+CONSTANT: CL_DBL_RADIX 2
+CONSTANT: CL_DBL_MAX 179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.0
+CONSTANT: CL_DBL_MIN 2.225073858507201383090e-308
+CONSTANT: CL_DBL_EPSILON 2.220446049250313080847e-16
+
+CONSTANT: CL_NAN NAN: 0
+CONSTANT: CL_HUGE_VALF 1.0e50
+CONSTANT: CL_HUGE_VAL 1.0e500
+CONSTANT: CL_MAXFLOAT 340282346638528859811704183484516925440.0
+CONSTANT: CL_INFINITY 1.0e50
+
+TYPEDEF: uint cl_GLuint
+TYPEDEF: int cl_GLint
+TYPEDEF: uint cl_GLenum
+
+! cl.h
+C-TYPE: _cl_platform_id
+C-TYPE: _cl_device_id
+C-TYPE: _cl_context
+C-TYPE: _cl_command_queue
+C-TYPE: _cl_mem
+C-TYPE: _cl_program
+C-TYPE: _cl_kernel
+C-TYPE: _cl_event
+C-TYPE: _cl_sampler
+
+TYPEDEF: _cl_platform_id* cl_platform_id
+TYPEDEF: _cl_device_id* cl_device_id
+TYPEDEF: _cl_context* cl_context
+TYPEDEF: _cl_command_queue* cl_command_queue
+TYPEDEF: _cl_mem* cl_mem
+TYPEDEF: _cl_program* cl_program
+TYPEDEF: _cl_kernel* cl_kernel
+TYPEDEF: _cl_event* cl_event
+TYPEDEF: _cl_sampler* cl_sampler
+
+TYPEDEF: cl_uint cl_bool
+TYPEDEF: cl_ulong cl_bitfield
+TYPEDEF: cl_bitfield cl_device_type
+TYPEDEF: cl_uint cl_platform_info
+TYPEDEF: cl_uint cl_device_info
+TYPEDEF: cl_bitfield cl_device_address_info
+TYPEDEF: cl_bitfield cl_device_fp_config
+TYPEDEF: cl_uint cl_device_mem_cache_type
+TYPEDEF: cl_uint cl_device_local_mem_type
+TYPEDEF: cl_bitfield cl_device_exec_capabilities
+TYPEDEF: cl_bitfield cl_command_queue_properties
+
+TYPEDEF: intptr_t cl_context_properties
+TYPEDEF: cl_uint cl_context_info
+TYPEDEF: cl_uint cl_command_queue_info
+TYPEDEF: cl_uint cl_channel_order
+TYPEDEF: cl_uint cl_channel_type
+TYPEDEF: cl_bitfield cl_mem_flags
+TYPEDEF: cl_uint cl_mem_object_type
+TYPEDEF: cl_uint cl_mem_info
+TYPEDEF: cl_uint cl_image_info
+TYPEDEF: cl_uint cl_addressing_mode
+TYPEDEF: cl_uint cl_filter_mode
+TYPEDEF: cl_uint cl_sampler_info
+TYPEDEF: cl_bitfield cl_map_flags
+TYPEDEF: cl_uint cl_program_info
+TYPEDEF: cl_uint cl_program_build_info
+TYPEDEF: cl_int cl_build_status
+TYPEDEF: cl_uint cl_kernel_info
+TYPEDEF: cl_uint cl_kernel_work_group_info
+TYPEDEF: cl_uint cl_event_info
+TYPEDEF: cl_uint cl_command_type
+TYPEDEF: cl_uint cl_profiling_info
+
+STRUCT: cl_image_format
+ { image_channel_order cl_channel_order }
+ { image_channel_data_type cl_channel_type } ;
+
+CONSTANT: CL_SUCCESS 0
+CONSTANT: CL_DEVICE_NOT_FOUND -1
+CONSTANT: CL_DEVICE_NOT_AVAILABLE -2
+CONSTANT: CL_COMPILER_NOT_AVAILABLE -3
+CONSTANT: CL_MEM_OBJECT_ALLOCATION_FAILURE -4
+CONSTANT: CL_OUT_OF_RESOURCES -5
+CONSTANT: CL_OUT_OF_HOST_MEMORY -6
+CONSTANT: CL_PROFILING_INFO_NOT_AVAILABLE -7
+CONSTANT: CL_MEM_COPY_OVERLAP -8
+CONSTANT: CL_IMAGE_FORMAT_MISMATCH -9
+CONSTANT: CL_IMAGE_FORMAT_NOT_SUPPORTED -10
+CONSTANT: CL_BUILD_PROGRAM_FAILURE -11
+CONSTANT: CL_MAP_FAILURE -12
+
+CONSTANT: CL_INVALID_VALUE -30
+CONSTANT: CL_INVALID_DEVICE_TYPE -31
+CONSTANT: CL_INVALID_PLATFORM -32
+CONSTANT: CL_INVALID_DEVICE -33
+CONSTANT: CL_INVALID_CONTEXT -34
+CONSTANT: CL_INVALID_QUEUE_PROPERTIES -35
+CONSTANT: CL_INVALID_COMMAND_QUEUE -36
+CONSTANT: CL_INVALID_HOST_PTR -37
+CONSTANT: CL_INVALID_MEM_OBJECT -38
+CONSTANT: CL_INVALID_IMAGE_FORMAT_DESCRIPTOR -39
+CONSTANT: CL_INVALID_IMAGE_SIZE -40
+CONSTANT: CL_INVALID_SAMPLER -41
+CONSTANT: CL_INVALID_BINARY -42
+CONSTANT: CL_INVALID_BUILD_OPTIONS -43
+CONSTANT: CL_INVALID_PROGRAM -44
+CONSTANT: CL_INVALID_PROGRAM_EXECUTABLE -45
+CONSTANT: CL_INVALID_KERNEL_NAME -46
+CONSTANT: CL_INVALID_KERNEL_DEFINITION -47
+CONSTANT: CL_INVALID_KERNEL -48
+CONSTANT: CL_INVALID_ARG_INDEX -49
+CONSTANT: CL_INVALID_ARG_VALUE -50
+CONSTANT: CL_INVALID_ARG_SIZE -51
+CONSTANT: CL_INVALID_KERNEL_ARGS -52
+CONSTANT: CL_INVALID_WORK_DIMENSION -53
+CONSTANT: CL_INVALID_WORK_GROUP_SIZE -54
+CONSTANT: CL_INVALID_WORK_ITEM_SIZE -55
+CONSTANT: CL_INVALID_GLOBAL_OFFSET -56
+CONSTANT: CL_INVALID_EVENT_WAIT_LIST -57
+CONSTANT: CL_INVALID_EVENT -58
+CONSTANT: CL_INVALID_OPERATION -59
+CONSTANT: CL_INVALID_GL_OBJECT -60
+CONSTANT: CL_INVALID_BUFFER_SIZE -61
+CONSTANT: CL_INVALID_MIP_LEVEL -62
+CONSTANT: CL_INVALID_GLOBAL_WORK_SIZE -63
+
+CONSTANT: CL_VERSION_1_0 1
+
+CONSTANT: CL_FALSE 0
+CONSTANT: CL_TRUE 1
+
+CONSTANT: CL_PLATFORM_PROFILE HEX: 0900
+CONSTANT: CL_PLATFORM_VERSION HEX: 0901
+CONSTANT: CL_PLATFORM_NAME HEX: 0902
+CONSTANT: CL_PLATFORM_VENDOR HEX: 0903
+CONSTANT: CL_PLATFORM_EXTENSIONS HEX: 0904
+
+CONSTANT: CL_DEVICE_TYPE_DEFAULT 1
+CONSTANT: CL_DEVICE_TYPE_CPU 2
+CONSTANT: CL_DEVICE_TYPE_GPU 4
+CONSTANT: CL_DEVICE_TYPE_ACCELERATOR 8
+CONSTANT: CL_DEVICE_TYPE_ALL HEX: FFFFFFFF
+
+CONSTANT: CL_DEVICE_TYPE HEX: 1000
+CONSTANT: CL_DEVICE_VENDOR_ID HEX: 1001
+CONSTANT: CL_DEVICE_MAX_COMPUTE_UNITS HEX: 1002
+CONSTANT: CL_DEVICE_MAX_WORK_ITEM_DIMENSIONS HEX: 1003
+CONSTANT: CL_DEVICE_MAX_WORK_GROUP_SIZE HEX: 1004
+CONSTANT: CL_DEVICE_MAX_WORK_ITEM_SIZES HEX: 1005
+CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_CHAR HEX: 1006
+CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_SHORT HEX: 1007
+CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_INT HEX: 1008
+CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_LONG HEX: 1009
+CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_FLOAT HEX: 100A
+CONSTANT: CL_DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE HEX: 100B
+CONSTANT: CL_DEVICE_MAX_CLOCK_FREQUENCY HEX: 100C
+CONSTANT: CL_DEVICE_ADDRESS_BITS HEX: 100D
+CONSTANT: CL_DEVICE_MAX_READ_IMAGE_ARGS HEX: 100E
+CONSTANT: CL_DEVICE_MAX_WRITE_IMAGE_ARGS HEX: 100F
+CONSTANT: CL_DEVICE_MAX_MEM_ALLOC_SIZE HEX: 1010
+CONSTANT: CL_DEVICE_IMAGE2D_MAX_WIDTH HEX: 1011
+CONSTANT: CL_DEVICE_IMAGE2D_MAX_HEIGHT HEX: 1012
+CONSTANT: CL_DEVICE_IMAGE3D_MAX_WIDTH HEX: 1013
+CONSTANT: CL_DEVICE_IMAGE3D_MAX_HEIGHT HEX: 1014
+CONSTANT: CL_DEVICE_IMAGE3D_MAX_DEPTH HEX: 1015
+CONSTANT: CL_DEVICE_IMAGE_SUPPORT HEX: 1016
+CONSTANT: CL_DEVICE_MAX_PARAMETER_SIZE HEX: 1017
+CONSTANT: CL_DEVICE_MAX_SAMPLERS HEX: 1018
+CONSTANT: CL_DEVICE_MEM_BASE_ADDR_ALIGN HEX: 1019
+CONSTANT: CL_DEVICE_MIN_DATA_TYPE_ALIGN_SIZE HEX: 101A
+CONSTANT: CL_DEVICE_SINGLE_FP_CONFIG HEX: 101B
+CONSTANT: CL_DEVICE_GLOBAL_MEM_CACHE_TYPE HEX: 101C
+CONSTANT: CL_DEVICE_GLOBAL_MEM_CACHELINE_SIZE HEX: 101D
+CONSTANT: CL_DEVICE_GLOBAL_MEM_CACHE_SIZE HEX: 101E
+CONSTANT: CL_DEVICE_GLOBAL_MEM_SIZE HEX: 101F
+CONSTANT: CL_DEVICE_MAX_CONSTANT_BUFFER_SIZE HEX: 1020
+CONSTANT: CL_DEVICE_MAX_CONSTANT_ARGS HEX: 1021
+CONSTANT: CL_DEVICE_LOCAL_MEM_TYPE HEX: 1022
+CONSTANT: CL_DEVICE_LOCAL_MEM_SIZE HEX: 1023
+CONSTANT: CL_DEVICE_ERROR_CORRECTION_SUPPORT HEX: 1024
+CONSTANT: CL_DEVICE_PROFILING_TIMER_RESOLUTION HEX: 1025
+CONSTANT: CL_DEVICE_ENDIAN_LITTLE HEX: 1026
+CONSTANT: CL_DEVICE_AVAILABLE HEX: 1027
+CONSTANT: CL_DEVICE_COMPILER_AVAILABLE HEX: 1028
+CONSTANT: CL_DEVICE_EXECUTION_CAPABILITIES HEX: 1029
+CONSTANT: CL_DEVICE_QUEUE_PROPERTIES HEX: 102A
+CONSTANT: CL_DEVICE_NAME HEX: 102B
+CONSTANT: CL_DEVICE_VENDOR HEX: 102C
+CONSTANT: CL_DRIVER_VERSION HEX: 102D
+CONSTANT: CL_DEVICE_PROFILE HEX: 102E
+CONSTANT: CL_DEVICE_VERSION HEX: 102F
+CONSTANT: CL_DEVICE_EXTENSIONS HEX: 1030
+CONSTANT: CL_DEVICE_PLATFORM HEX: 1031
+
+CONSTANT: CL_FP_DENORM 1
+CONSTANT: CL_FP_INF_NAN 2
+CONSTANT: CL_FP_ROUND_TO_NEAREST 4
+CONSTANT: CL_FP_ROUND_TO_ZERO 8
+CONSTANT: CL_FP_ROUND_TO_INF 16
+CONSTANT: CL_FP_FMA 32
+
+CONSTANT: CL_NONE 0
+CONSTANT: CL_READ_ONLY_CACHE 1
+CONSTANT: CL_READ_WRITE_CACHE 2
+
+CONSTANT: CL_LOCAL 1
+CONSTANT: CL_GLOBAL 2
+
+CONSTANT: CL_EXEC_KERNEL 1
+CONSTANT: CL_EXEC_NATIVE_KERNEL 2
+
+CONSTANT: CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE 1
+CONSTANT: CL_QUEUE_PROFILING_ENABLE 2
+
+CONSTANT: CL_CONTEXT_REFERENCE_COUNT HEX: 1080
+CONSTANT: CL_CONTEXT_DEVICES HEX: 1081
+CONSTANT: CL_CONTEXT_PROPERTIES HEX: 1082
+
+CONSTANT: CL_CONTEXT_PLATFORM HEX: 1084
+
+CONSTANT: CL_QUEUE_CONTEXT HEX: 1090
+CONSTANT: CL_QUEUE_DEVICE HEX: 1091
+CONSTANT: CL_QUEUE_REFERENCE_COUNT HEX: 1092
+CONSTANT: CL_QUEUE_PROPERTIES HEX: 1093
+
+CONSTANT: CL_MEM_READ_WRITE 1
+CONSTANT: CL_MEM_WRITE_ONLY 2
+CONSTANT: CL_MEM_READ_ONLY 4
+CONSTANT: CL_MEM_USE_HOST_PTR 8
+CONSTANT: CL_MEM_ALLOC_HOST_PTR 16
+CONSTANT: CL_MEM_COPY_HOST_PTR 32
+
+CONSTANT: CL_R HEX: 10B0
+CONSTANT: CL_A HEX: 10B1
+CONSTANT: CL_RG HEX: 10B2
+CONSTANT: CL_RA HEX: 10B3
+CONSTANT: CL_RGB HEX: 10B4
+CONSTANT: CL_RGBA HEX: 10B5
+CONSTANT: CL_BGRA HEX: 10B6
+CONSTANT: CL_ARGB HEX: 10B7
+CONSTANT: CL_INTENSITY HEX: 10B8
+CONSTANT: CL_LUMINANCE HEX: 10B9
+
+CONSTANT: CL_SNORM_INT8 HEX: 10D0
+CONSTANT: CL_SNORM_INT16 HEX: 10D1
+CONSTANT: CL_UNORM_INT8 HEX: 10D2
+CONSTANT: CL_UNORM_INT16 HEX: 10D3
+CONSTANT: CL_UNORM_SHORT_565 HEX: 10D4
+CONSTANT: CL_UNORM_SHORT_555 HEX: 10D5
+CONSTANT: CL_UNORM_INT_101010 HEX: 10D6
+CONSTANT: CL_SIGNED_INT8 HEX: 10D7
+CONSTANT: CL_SIGNED_INT16 HEX: 10D8
+CONSTANT: CL_SIGNED_INT32 HEX: 10D9
+CONSTANT: CL_UNSIGNED_INT8 HEX: 10DA
+CONSTANT: CL_UNSIGNED_INT16 HEX: 10DB
+CONSTANT: CL_UNSIGNED_INT32 HEX: 10DC
+CONSTANT: CL_HALF_FLOAT HEX: 10DD
+CONSTANT: CL_FLOAT HEX: 10DE
+
+CONSTANT: CL_MEM_OBJECT_BUFFER HEX: 10F0
+CONSTANT: CL_MEM_OBJECT_IMAGE2D HEX: 10F1
+CONSTANT: CL_MEM_OBJECT_IMAGE3D HEX: 10F2
+
+CONSTANT: CL_MEM_TYPE HEX: 1100
+CONSTANT: CL_MEM_FLAGS HEX: 1101
+CONSTANT: CL_MEM_SIZE HEX: 1102
+CONSTANT: CL_MEM_HOST_PTR HEX: 1103
+CONSTANT: CL_MEM_MAP_COUNT HEX: 1104
+CONSTANT: CL_MEM_REFERENCE_COUNT HEX: 1105
+CONSTANT: CL_MEM_CONTEXT HEX: 1106
+
+CONSTANT: CL_IMAGE_FORMAT HEX: 1110
+CONSTANT: CL_IMAGE_ELEMENT_SIZE HEX: 1111
+CONSTANT: CL_IMAGE_ROW_PITCH HEX: 1112
+CONSTANT: CL_IMAGE_SLICE_PITCH HEX: 1113
+CONSTANT: CL_IMAGE_WIDTH HEX: 1114
+CONSTANT: CL_IMAGE_HEIGHT HEX: 1115
+CONSTANT: CL_IMAGE_DEPTH HEX: 1116
+
+CONSTANT: CL_ADDRESS_NONE HEX: 1130
+CONSTANT: CL_ADDRESS_CLAMP_TO_EDGE HEX: 1131
+CONSTANT: CL_ADDRESS_CLAMP HEX: 1132
+CONSTANT: CL_ADDRESS_REPEAT HEX: 1133
+
+CONSTANT: CL_FILTER_NEAREST HEX: 1140
+CONSTANT: CL_FILTER_LINEAR HEX: 1141
+
+CONSTANT: CL_SAMPLER_REFERENCE_COUNT HEX: 1150
+CONSTANT: CL_SAMPLER_CONTEXT HEX: 1151
+CONSTANT: CL_SAMPLER_NORMALIZED_COORDS HEX: 1152
+CONSTANT: CL_SAMPLER_ADDRESSING_MODE HEX: 1153
+CONSTANT: CL_SAMPLER_FILTER_MODE HEX: 1154
+
+CONSTANT: CL_MAP_READ 1
+CONSTANT: CL_MAP_WRITE 2
+
+CONSTANT: CL_PROGRAM_REFERENCE_COUNT HEX: 1160
+CONSTANT: CL_PROGRAM_CONTEXT HEX: 1161
+CONSTANT: CL_PROGRAM_NUM_DEVICES HEX: 1162
+CONSTANT: CL_PROGRAM_DEVICES HEX: 1163
+CONSTANT: CL_PROGRAM_SOURCE HEX: 1164
+CONSTANT: CL_PROGRAM_BINARY_SIZES HEX: 1165
+CONSTANT: CL_PROGRAM_BINARIES HEX: 1166
+
+CONSTANT: CL_PROGRAM_BUILD_STATUS HEX: 1181
+CONSTANT: CL_PROGRAM_BUILD_OPTIONS HEX: 1182
+CONSTANT: CL_PROGRAM_BUILD_LOG HEX: 1183
+
+CONSTANT: CL_BUILD_SUCCESS 0
+CONSTANT: CL_BUILD_NONE -1
+CONSTANT: CL_BUILD_ERROR -2
+CONSTANT: CL_BUILD_IN_PROGRESS -3
+
+CONSTANT: CL_KERNEL_FUNCTION_NAME HEX: 1190
+CONSTANT: CL_KERNEL_NUM_ARGS HEX: 1191
+CONSTANT: CL_KERNEL_REFERENCE_COUNT HEX: 1192
+CONSTANT: CL_KERNEL_CONTEXT HEX: 1193
+CONSTANT: CL_KERNEL_PROGRAM HEX: 1194
+
+CONSTANT: CL_KERNEL_WORK_GROUP_SIZE HEX: 11B0
+CONSTANT: CL_KERNEL_COMPILE_WORK_GROUP_SIZE HEX: 11B1
+CONSTANT: CL_KERNEL_LOCAL_MEM_SIZE HEX: 11B2
+
+CONSTANT: CL_EVENT_COMMAND_QUEUE HEX: 11D0
+CONSTANT: CL_EVENT_COMMAND_TYPE HEX: 11D1
+CONSTANT: CL_EVENT_REFERENCE_COUNT HEX: 11D2
+CONSTANT: CL_EVENT_COMMAND_EXECUTION_STATUS HEX: 11D3
+
+CONSTANT: CL_COMMAND_NDRANGE_KERNEL HEX: 11F0
+CONSTANT: CL_COMMAND_TASK HEX: 11F1
+CONSTANT: CL_COMMAND_NATIVE_KERNEL HEX: 11F2
+CONSTANT: CL_COMMAND_READ_BUFFER HEX: 11F3
+CONSTANT: CL_COMMAND_WRITE_BUFFER HEX: 11F4
+CONSTANT: CL_COMMAND_COPY_BUFFER HEX: 11F5
+CONSTANT: CL_COMMAND_READ_IMAGE HEX: 11F6
+CONSTANT: CL_COMMAND_WRITE_IMAGE HEX: 11F7
+CONSTANT: CL_COMMAND_COPY_IMAGE HEX: 11F8
+CONSTANT: CL_COMMAND_COPY_IMAGE_TO_BUFFER HEX: 11F9
+CONSTANT: CL_COMMAND_COPY_BUFFER_TO_IMAGE HEX: 11FA
+CONSTANT: CL_COMMAND_MAP_BUFFER HEX: 11FB
+CONSTANT: CL_COMMAND_MAP_IMAGE HEX: 11FC
+CONSTANT: CL_COMMAND_UNMAP_MEM_OBJECT HEX: 11FD
+CONSTANT: CL_COMMAND_MARKER HEX: 11FE
+CONSTANT: CL_COMMAND_ACQUIRE_GL_OBJECTS HEX: 11FF
+CONSTANT: CL_COMMAND_RELEASE_GL_OBJECTS HEX: 1200
+
+CONSTANT: CL_COMPLETE HEX: 0
+CONSTANT: CL_RUNNING HEX: 1
+CONSTANT: CL_SUBMITTED HEX: 2
+CONSTANT: CL_QUEUED HEX: 3
+
+CONSTANT: CL_PROFILING_COMMAND_QUEUED HEX: 1280
+CONSTANT: CL_PROFILING_COMMAND_SUBMIT HEX: 1281
+CONSTANT: CL_PROFILING_COMMAND_START HEX: 1282
+CONSTANT: CL_PROFILING_COMMAND_END HEX: 1283
+
+FUNCTION: cl_int clGetPlatformIDs ( cl_uint num_entries, cl_platform_id* platforms, cl_uint* num_platforms ) ;
+FUNCTION: cl_int clGetPlatformInfo ( cl_platform_id platform, cl_platform_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clGetDeviceIDs ( cl_platform_id platform, cl_device_type device_type, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ;
+FUNCTION: cl_int clGetDeviceInfo ( cl_device_id device, cl_device_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+CALLBACK: void cl_create_context_cb ( char* a, void* b, size_t s, void* c ) ;
+FUNCTION: cl_context clCreateContext ( cl_context_properties* properties, cl_uint num_devices, cl_device_id* devices, cl_create_context_cb pfn_notify, void* user_data, cl_int* errcode_ret ) ;
+FUNCTION: cl_context clCreateContextFromType ( cl_context_properties* properties, cl_device_type device_type, cl_create_context_cb pfn_notify, void* user_data, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clRetainContext ( cl_context context ) ;
+FUNCTION: cl_int clReleaseContext ( cl_context context ) ;
+FUNCTION: cl_int clGetContextInfo ( cl_context context, cl_context_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_command_queue clCreateCommandQueue ( cl_context context, cl_device_id device, cl_command_queue_properties properties, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clRetainCommandQueue ( cl_command_queue command_queue ) ;
+FUNCTION: cl_int clReleaseCommandQueue ( cl_command_queue command_queue ) ;
+FUNCTION: cl_int clGetCommandQueueInfo ( cl_command_queue command_queue, cl_command_queue_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clSetCommandQueueProperty ( cl_command_queue command_queue, cl_command_queue_properties properties, cl_bool enable, cl_command_queue_properties* old_properties ) ;
+FUNCTION: cl_mem clCreateBuffer ( cl_context context, cl_mem_flags flags, size_t size, void* host_ptr, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateImage2D ( cl_context context, cl_mem_flags flags, cl_image_format* image_format, size_t image_width, size_t image_height, size_t image_row_pitch, void* host_ptr, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateImage3D ( cl_context context, cl_mem_flags flags, cl_image_format* image_format, size_t image_width, size_t image_height, size_t image_depth, size_t image_row_pitch, size_t image_slice_pitch, void* host_ptr, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clRetainMemObject ( cl_mem memobj ) ;
+FUNCTION: cl_int clReleaseMemObject ( cl_mem memobj ) ;
+FUNCTION: cl_int clGetSupportedImageFormats ( cl_context context, cl_mem_flags flags, cl_mem_object_type image_type, cl_uint num_entries, cl_image_format* image_formats, cl_uint* num_image_formats ) ;
+FUNCTION: cl_int clGetMemObjectInfo ( cl_mem memobj, cl_mem_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clGetImageInfo ( cl_mem image, cl_image_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_sampler clCreateSampler ( cl_context context, cl_bool normalized_coords, cl_addressing_mode addressing_mode, cl_filter_mode filter_mode, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clRetainSampler ( cl_sampler sampler ) ;
+FUNCTION: cl_int clReleaseSampler ( cl_sampler sampler ) ;
+FUNCTION: cl_int clGetSamplerInfo ( cl_sampler sampler, cl_sampler_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_program clCreateProgramWithSource ( cl_context context, cl_uint count, char** strings, size_t* lengths, cl_int* errcode_ret ) ;
+FUNCTION: cl_program clCreateProgramWithBinary ( cl_context context, cl_uint num_devices, cl_device_id* device_list, size_t* lengths, char** binaries, cl_int* binary_status, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clRetainProgram ( cl_program program ) ;
+FUNCTION: cl_int clReleaseProgram ( cl_program program ) ;
+CALLBACK: void cl_build_program_cb ( cl_program program, void* user_data ) ;
+FUNCTION: cl_int clBuildProgram ( cl_program program, cl_uint num_devices, cl_device_id* device_list, char* options, cl_build_program_cb pfn_notify, void* user_data ) ;
+FUNCTION: cl_int clUnloadCompiler ( ) ;
+FUNCTION: cl_int clGetProgramInfo ( cl_program program, cl_program_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clGetProgramBuildInfo ( cl_program program, cl_device_id device, cl_program_build_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_kernel clCreateKernel ( cl_program program, char* kernel_name, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clCreateKernelsInProgram ( cl_program program, cl_uint num_kernels, cl_kernel* kernels, cl_uint* num_kernels_ret ) ;
+FUNCTION: cl_int clRetainKernel ( cl_kernel kernel ) ;
+FUNCTION: cl_int clReleaseKernel ( cl_kernel kernel ) ;
+FUNCTION: cl_int clSetKernelArg ( cl_kernel kernel, cl_uint arg_index, size_t arg_size, void* arg_value ) ;
+FUNCTION: cl_int clGetKernelInfo ( cl_kernel kernel, cl_kernel_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clGetKernelWorkGroupInfo ( cl_kernel kernel, cl_device_id device, cl_kernel_work_group_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clWaitForEvents ( cl_uint num_events, cl_event* event_list ) ;
+FUNCTION: cl_int clGetEventInfo ( cl_event event, cl_event_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clRetainEvent ( cl_event event ) ;
+FUNCTION: cl_int clReleaseEvent ( cl_event event ) ;
+FUNCTION: cl_int clGetEventProfilingInfo ( cl_event event, cl_profiling_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clFlush ( cl_command_queue command_queue ) ;
+FUNCTION: cl_int clFinish ( cl_command_queue command_queue ) ;
+FUNCTION: cl_int clEnqueueReadBuffer ( cl_command_queue command_queue, cl_mem buffer, cl_bool blocking_read, size_t offset, size_t cb, void* ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueWriteBuffer ( cl_command_queue command_queue, cl_mem buffer, cl_bool blocking_write, size_t offset, size_t cb, void* ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueCopyBuffer ( cl_command_queue command_queue, cl_mem src_buffer, cl_mem dst_buffer, size_t src_offset, size_t dst_offset, size_t cb, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueReadImage ( cl_command_queue command_queue, cl_mem image, cl_bool blocking_read, size_t** origin, size_t** region, size_t row_pitch, size_t slice_pitch, void* ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueWriteImage ( cl_command_queue command_queue, cl_mem image, cl_bool blocking_write, size_t** origin, size_t** region, size_t input_row_pitch, size_t input_slice_pitch, void* ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueCopyImage ( cl_command_queue command_queue, cl_mem src_image, cl_mem dst_image, size_t** src_origin, size_t** dst_origin, size_t** region, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueCopyImageToBuffer ( cl_command_queue command_queue, cl_mem src_image, cl_mem dst_buffer, size_t** src_origin, size_t** region, size_t dst_offset, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueCopyBufferToImage ( cl_command_queue command_queue, cl_mem src_buffer, cl_mem dst_image, size_t src_offset, size_t** dst_origin, size_t** region, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: void* clEnqueueMapBuffer ( cl_command_queue command_queue, cl_mem buffer, cl_bool blocking_map, cl_map_flags map_flags, size_t offset, size_t cb, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event, cl_int* errcode_ret ) ;
+FUNCTION: void* clEnqueueMapImage ( cl_command_queue command_queue, cl_mem image, cl_bool blocking_map, cl_map_flags map_flags, size_t** origin, size_t** region, size_t* image_row_pitch, size_t* image_slice_pitch, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clEnqueueUnmapMemObject ( cl_command_queue command_queue, cl_mem memobj, void* mapped_ptr, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueNDRangeKernel ( cl_command_queue command_queue, cl_kernel kernel, cl_uint work_dim, size_t* global_work_offset, size_t* global_work_size, size_t* local_work_size, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+CALLBACK: void cl_enqueue_task_cb ( void* args ) ;
+FUNCTION: cl_int clEnqueueTask ( cl_command_queue command_queue, cl_kernel kernel, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueNativeKernel ( cl_command_queue command_queue, cl_enqueue_task_cb user_func, void* args, size_t cb_args, cl_uint num_mem_objects, cl_mem* mem_list, void** args_mem_loc, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueMarker ( cl_command_queue command_queue, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueWaitForEvents ( cl_command_queue command_queue, cl_uint num_events, cl_event* event_list ) ;
+FUNCTION: cl_int clEnqueueBarrier ( cl_command_queue command_queue ) ;
+FUNCTION: void* clGetExtensionFunctionAddress ( char* func_name ) ;
+
+! cl_ext.h
+CONSTANT: CL_DEVICE_DOUBLE_FP_CONFIG HEX: 1032
+CONSTANT: CL_DEVICE_HALF_FP_CONFIG HEX: 1033
+
+! cl_khr_icd.txt
+CONSTANT: CL_PLATFORM_ICD_SUFFIX_KHR HEX: 0920
+CONSTANT: CL_PLATFORM_NOT_FOUND_KHR -1001
+
+FUNCTION: cl_int clIcdGetPlatformIDsKHR ( cl_uint num_entries, cl_platform_id* platforms, cl_uint* num_platforms ) ;
+
+! cl_gl.h
+TYPEDEF: cl_uint cl_gl_object_type
+TYPEDEF: cl_uint cl_gl_texture_info
+TYPEDEF: cl_uint cl_gl_platform_info
+
+CONSTANT: CL_GL_OBJECT_BUFFER HEX: 2000
+CONSTANT: CL_GL_OBJECT_TEXTURE2D HEX: 2001
+CONSTANT: CL_GL_OBJECT_TEXTURE3D HEX: 2002
+CONSTANT: CL_GL_OBJECT_RENDERBUFFER HEX: 2003
+CONSTANT: CL_GL_TEXTURE_TARGET HEX: 2004
+CONSTANT: CL_GL_MIPMAP_LEVEL HEX: 2005
+
+FUNCTION: cl_mem clCreateFromGLBuffer ( cl_context context, cl_mem_flags flags, cl_GLuint bufobj, int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromGLTexture2D ( cl_context context, cl_mem_flags flags, cl_GLenum target, cl_GLint miplevel, cl_GLuint texture, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromGLTexture3D ( cl_context context, cl_mem_flags flags, cl_GLenum target, cl_GLint miplevel, cl_GLuint texture, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromGLRenderbuffer ( cl_context context, cl_mem_flags flags, cl_GLuint renderbuffer, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clGetGLObjectInfo ( cl_mem memobj, cl_gl_object_type* gl_object_type, cl_GLuint* gl_object_name ) ;
+FUNCTION: cl_int clGetGLTextureInfo ( cl_mem memobj, cl_gl_texture_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+FUNCTION: cl_int clEnqueueAcquireGLObjects ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueReleaseGLObjects ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+
+! cl_khr_gl_sharing.txt
+TYPEDEF: cl_uint cl_gl_context_info
+
+CONSTANT: CL_INVALID_GL_SHAREGROUP_REFERENCE_KHR -1000
+CONSTANT: CL_CURRENT_DEVICE_FOR_GL_CONTEXT_KHR HEX: 2006
+CONSTANT: CL_DEVICES_FOR_GL_CONTEXT_KHR HEX: 2007
+CONSTANT: CL_GL_CONTEXT_KHR HEX: 2008
+CONSTANT: CL_EGL_DISPLAY_KHR HEX: 2009
+CONSTANT: CL_GLX_DISPLAY_KHR HEX: 200A
+CONSTANT: CL_WGL_HDC_KHR HEX: 200B
+CONSTANT: CL_CGL_SHAREGROUP_KHR HEX: 200C
+
+FUNCTION: cl_int clGetGLContextInfoKHR ( cl_context_properties* properties, cl_gl_context_info param_name, size_t param_value_size, void* param_value, size_t* param_value_size_ret ) ;
+
+! cl_nv_d3d9_sharing.txt
+CONSTANT: CL_D3D9_DEVICE_NV HEX: 4022
+CONSTANT: CL_D3D9_ADAPTER_NAME_NV HEX: 4023
+CONSTANT: CL_PREFERRED_DEVICES_FOR_D3D9_NV HEX: 4024
+CONSTANT: CL_ALL_DEVICES_FOR_D3D9_NV HEX: 4025
+CONSTANT: CL_CONTEXT_D3D9_DEVICE_NV HEX: 4026
+CONSTANT: CL_MEM_D3D9_RESOURCE_NV HEX: 4027
+CONSTANT: CL_IMAGE_D3D9_FACE_NV HEX: 4028
+CONSTANT: CL_IMAGE_D3D9_LEVEL_NV HEX: 4029
+CONSTANT: CL_COMMAND_ACQUIRE_D3D9_OBJECTS_NV HEX: 402A
+CONSTANT: CL_COMMAND_RELEASE_D3D9_OBJECTS_NV HEX: 402B
+CONSTANT: CL_INVALID_D3D9_DEVICE_NV -1010
+CONSTANT: CL_INVALID_D3D9_RESOURCE_NV -1011
+CONSTANT: CL_D3D9_RESOURCE_ALREADY_ACQUIRED_NV -1012
+CONSTANT: CL_D3D9_RESOURCE_NOT_ACQUIRED_NV -1013
+
+TYPEDEF: void* cl_d3d9_device_source_nv
+TYPEDEF: void* cl_d3d9_device_set_nv
+
+FUNCTION: cl_int clGetDeviceIDsFromD3D9NV ( cl_platform_id platform, cl_d3d9_device_source_nv d3d_device_source, void* d3d_object, cl_d3d9_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ;
+FUNCTION: cl_mem clCreateFromD3D9VertexBufferNV ( cl_context context, cl_mem_flags flags, void* id3dvb9_resource, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D9IndexBufferNV ( cl_context context, cl_mem_flags flags, void* id3dib9_resource, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D9SurfaceNV ( cl_context context, cl_mem_flags flags, void* id3dsurface9_resource, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D9TextureNV ( cl_context context, cl_mem_flags flags, void* id3dtexture9_resource, uint miplevel, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D9CubeTextureNV ( cl_context context, cl_mem_flags flags, void* id3dct9_resource, int facetype, uint miplevel, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D9VolumeTextureNV ( cl_context context, cl_mem_flags flags, void* id3dvt9-resource, uint miplevel, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clEnqueueAcquireD3D9ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueReleaseD3D9ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+
+! cl_nv_d3d10_sharing.txt
+CONSTANT: CL_D3D10_DEVICE_NV HEX: 4010
+CONSTANT: CL_D3D10_DXGI_ADAPTER_NV HEX: 4011
+CONSTANT: CL_PREFERRED_DEVICES_FOR_D3D10_NV HEX: 4012
+CONSTANT: CL_ALL_DEVICES_FOR_D3D10_NV HEX: 4013
+CONSTANT: CL_CONTEXT_D3D10_DEVICE_NV HEX: 4014
+CONSTANT: CL_MEM_D3D10_RESOURCE_NV HEX: 4015
+CONSTANT: CL_IMAGE_D3D10_SUBRESOURCE_NV HEX: 4016
+CONSTANT: CL_COMMAND_ACQUIRE_D3D10_OBJECTS_NV HEX: 4017
+CONSTANT: CL_COMMAND_RELEASE_D3D10_OBJECTS_NV HEX: 4018
+CONSTANT: CL_INVALID_D3D10_DEVICE_NV -1002
+CONSTANT: CL_INVALID_D3D10_RESOURCE_NV -1003
+CONSTANT: CL_D3D10_RESOURCE_ALREADY_ACQUIRED_NV -1004
+CONSTANT: CL_D3D10_RESOURCE_NOT_ACQUIRED_NV -1005
+
+TYPEDEF: void* cl_d3d10_device_source_nv
+TYPEDEF: void* cl_d3d10_device_set_nv
+
+FUNCTION: cl_int clGetDeviceIDsFromD3D10NV ( cl_platform_id platform, cl_d3d10_device_source_nv d3d_device_source, void* d3d_object, cl_d3d10_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ;
+FUNCTION: cl_mem clCreateFromD3D10BufferNV ( cl_context context, cl_mem_flags flags, void* id3d10buffer_resource, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D10Texture2DNV ( cl_context context, cl_mem_flags flags, void* id3d10texture2d_resource, uint subresource, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D10Texture3DNV ( cl_context context, cl_mem_flags flags, void* id3d10texture3d_resource, uint subresource, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clEnqueueAcquireD3D10ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueReleaseD3D10ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+
+! cl_nv_d3d11_sharing.txt
+CONSTANT: CL_D3D11_DEVICE_NV HEX: 4019
+CONSTANT: CL_D3D11_DXGI_ADAPTER_NV HEX: 401A
+CONSTANT: CL_PREFERRED_DEVICES_FOR_D3D11_NV HEX: 401B
+CONSTANT: CL_ALL_DEVICES_FOR_D3D11_NV HEX: 401C
+CONSTANT: CL_CONTEXT_D3D11_DEVICE_NV HEX: 401D
+CONSTANT: CL_MEM_D3D11_RESOURCE_NV HEX: 401E
+CONSTANT: CL_IMAGE_D3D11_SUBRESOURCE_NV HEX: 401F
+CONSTANT: CL_COMMAND_ACQUIRE_D3D11_OBJECTS_NV HEX: 4020
+CONSTANT: CL_COMMAND_RELEASE_D3D11_OBJECTS_NV HEX: 4021
+CONSTANT: CL_INVALID_D3D11_DEVICE_NV -1006
+CONSTANT: CL_INVALID_D3D11_RESOURCE_NV -1007
+CONSTANT: CL_D3D11_RESOURCE_ALREADY_ACQUIRED_NV -1008
+CONSTANT: CL_D3D11_RESOURCE_NOT_ACQUIRED_NV -1009
+
+TYPEDEF: void* cl_d3d11_device_source_nv
+TYPEDEF: void* cl_d3d11_device_set_nv
+
+FUNCTION: cl_int clGetDeviceIDsFromD3D11NV ( cl_platform_id platform, cl_d3d11_device_source_nv d3d_device_source, void* d3d_object, cl_d3d11_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ;
+FUNCTION: cl_mem clCreateFromD3D11BufferNV ( cl_context context, cl_mem_flags flags, void* id3d11buffer_resource, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D11Texture2DNV ( cl_context context, cl_mem_flags flags, void* id3d11texture2d_resource, uint subresource, cl_int* errcode_ret ) ;
+FUNCTION: cl_mem clCreateFromD3D11Texture3DNV ( cl_context context, cl_mem_flags flags, void* id3dtexture3d_resource, uint subresource, cl_int* errcode_ret ) ;
+FUNCTION: cl_int clEnqueueAcquireD3D11ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+FUNCTION: cl_int clEnqueueReleaseD3D11ObjectsNV ( cl_command_queue command_queue, cl_uint num_objects, cl_mem* mem_objects, cl_uint num_events_in_wait_list, cl_event* event_wait_list, cl_event* event ) ;
+
+! Utility words needed for working with the API
+: *size_t ( c-ptr -- value )
+ size_t heap-size {
+ { 4 [ 0 alien-unsigned-4 ] }
+ { 8 [ 0 alien-unsigned-8 ] }
+ } case ; inline
+
+: <size_t> ( value -- c-ptr )
+ size_t heap-size [ (byte-array) ] keep {
+ { 4 [ [ 0 set-alien-unsigned-4 ] keep ] }
+ { 8 [ [ 0 set-alien-unsigned-8 ] keep ] }
+ } case ; inline
--- /dev/null
+Bindings to OpenCL
--- /dev/null
+bindings
+untested
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations strings opencl.private
+math byte-arrays alien ;
+IN: opencl
+
+HELP: cl-addressing-mode
+{ $values
+ { "sampler" cl-sampler }
+ { "addressing-mode" cl-addressing-mode }
+}
+{ $description "Returns the addressing mode of the given sampler." } ;
+
+HELP: cl-barrier
+{ $description "Insert a synchronization barrier into the current command queue." } ;
+
+HELP: cl-barrier-events
+{ $values
+ { "event/events" "a single event or sequence of events" }
+}
+{ $description "Insert a synchronization barrier for the specified events into the current command queue." } ;
+
+HELP: cl-buffer
+{ $var-description "Tuple wrapper which will release the memory object handle when disposed." } ;
+
+HELP: cl-buffer-ptr
+{ $var-description "A buffer and offset pair for specifying a starting point for a copy." } ;
+
+HELP: cl-buffer-range
+{ $var-description "A buffer, offset and size triplet for specifying copy ranges." } ;
+
+HELP: cl-context
+{ $var-description "Tuple wrapper which will release the context handle when disposed." } ;
+
+HELP: cl-current-context
+{ $var-description "Symbol for the current cl-context tuple." } ;
+
+HELP: cl-current-device
+{ $var-description "Symbol for the current cl-device tuple." } ;
+
+HELP: cl-current-queue
+{ $var-description "Symbol for the current cl-queue tuple." } ;
+
+HELP: cl-device
+{ $var-description "Tuple wrapper which will release the device handle when disposed." } ;
+
+HELP: cl-event
+{ $var-description "Tuple wrapper which will release the event handle when disposed." } ;
+
+HELP: cl-event-status
+{ $values
+ { "event" cl-event }
+ { "execution-status" cl-execution-status }
+}
+{ $description "Returns the current execution status of the operation represented by the event." } ;
+
+HELP: cl-event-type
+{ $values
+ { "event" cl-event }
+ { "command-type" cl-execution-status }
+}
+{ $description "Returns the type of operation that created the event." } ;
+
+HELP: cl-filter-mode
+{ $values
+ { "sampler" cl-sampler }
+ { "filter-mode" cl-filter-mode }
+}
+{ $description "Returns the filter mode of the sampler object." } ;
+
+HELP: cl-finish
+{ $description "Flush the current command queue and wait till all operations are completed." } ;
+
+HELP: cl-flush
+{ $description "Flush the current command queue to kick off pending operations." } ;
+
+HELP: cl-kernel
+{ $var-description "Tuple wrapper which will release the kernel handle when disposed." } ;
+
+HELP: cl-kernel-arity
+{ $values
+ { "kernel" cl-kernel }
+ { "arity" integer }
+}
+{ $description "Returns the number of inputs that this kernel function accepts." } ;
+
+HELP: cl-kernel-local-size
+{ $values
+ { "kernel" cl-kernel }
+ { "size" integer }
+}
+{ $description "Returns the maximum size of a local work group for this kernel." } ;
+
+HELP: cl-kernel-name
+{ $values
+ { "kernel" cl-kernel }
+ { "string" string }
+}
+{ $description "Returns the name of the kernel function." } ;
+
+HELP: cl-marker
+{ $values
+
+ { "event" cl-event }
+}
+{ $description "Inserts a marker into the current command queue." } ;
+
+HELP: cl-normalized-coords?
+{ $values
+ { "sampler" cl-sampler }
+ { "?" boolean }
+}
+{ $description "Returns whether the sampler uses normalized coords or not." } ;
+
+HELP: cl-out-of-order-execution?
+{ $values
+ { "command-queue" cl-queue }
+ { "?" boolean }
+}
+{ $description "Returns whether the given command queue allows out of order execution or not." } ;
+
+HELP: cl-platform
+{ $var-description "Tuple summarizing the capabilities and devices of an OpenCL platform." } ;
+
+HELP: cl-platforms
+{ $values
+
+ { "platforms" "sequence of cl-platform"}
+}
+{ $description "Returns the platforms available for OpenCL computation on this hardware." } ;
+
+HELP: cl-profile-counters
+{ $values
+ { "event" cl-event }
+ { "queued" integer } { "submitted" integer } { "started" integer } { "finished" integer }
+}
+{ $description "Returns the profiling counters for the operation represented by event." } ;
+
+HELP: cl-profiling?
+{ $values
+ { "command-queue" cl-queue }
+ { "?" boolean }
+}
+{ $description "Returns true if the command queue allows profiling." } ;
+
+HELP: cl-program
+{ $var-description "Tuple wrapper which will release the program handle when disposed." } ;
+
+HELP: cl-queue
+{ $var-description "Tuple wrapper which will release the command queue handle when disposed." } ;
+
+HELP: cl-read-buffer
+{ $values
+ { "buffer-range" cl-buffer-range }
+ { "byte-array" byte-array }
+}
+{ $description "Synchronously read a byte-array from the specified buffer location." } ;
+
+HELP: cl-sampler
+{ $var-description "Tuple wrapper which will release the sampler handle when disposed." } ;
+
+HELP: cl-queue-copy-buffer
+{ $values
+ { "src-buffer-ptr" cl-buffer-ptr } { "dst-buffer-ptr" cl-buffer-ptr } { "size" integer } { "dependent-events" "sequence of events" }
+ { "event" cl-event }
+}
+{ $description "Queue a copy operation from " { $snippet "src-buffer-ptr" } " to " { $snippet "dst-buffer-ptr" } ". Dependent events can be passed to order the operation relative to other operations." } ;
+
+HELP: cl-queue-kernel
+{ $values
+ { "kernel" cl-kernel } { "args" "sequence of cl-buffer or byte-array" } { "sizes" "sequence of integers" } { "dependent-events" "sequence of events" }
+ { "event" cl-event }
+}
+{ $description "Queue a kernel for execution with the given arguments. The " { $snippet "sizes" } " argument specifies input array sizes for each dimension. Dependent events can be passed to order the operation relative to other operations." } ;
+
+HELP: cl-queue-read-buffer
+{ $values
+ { "buffer-range" cl-buffer-range } { "alien" alien } { "dependent-events" "a sequence of events" }
+ { "event" cl-event }
+}
+{ $description "Queue a read operation from " { $snippet "buffer-range" } " to " { $snippet "alien" } ". Dependent events can be passed to order the operation relative to other operations." } ;
+
+HELP: cl-queue-write-buffer
+{ $values
+ { "buffer-range" cl-buffer-range } { "alien" alien } { "dependent-events" "a sequence of events" }
+ { "event" cl-event }
+}
+{ $description "Queue a write operation from " { $snippet "alien" } " to " { $snippet "buffer-range" } ". Dependent events can be passed to order the operation relative to other operations." } ;
+
+HELP: cl-wait
+{ $values
+ { "event/events" "a single event or sequence of events" }
+}
+{ $description "Synchronously wait for the events to complete." } ;
+
+HELP: cl-write-buffer
+{ $values
+ { "buffer-range" cl-buffer-range } { "byte-array" byte-array }
+}
+{ $description "Synchronously write a byte-array to the specified buffer location." } ;
+
+HELP: <cl-program>
+{ $values
+ { "options" string } { "strings" "sequence of source code strings" }
+ { "program" "compiled cl-program" }
+}
+{ $description "Compile the given source code and return a program object. A " { $link cl-error } " is thrown in the event of a compile error." } ;
+
+HELP: with-cl-state
+{ $values
+ { "context/f" { $maybe cl-context } } { "device/f" { $maybe cl-device } } { "queue/f" { $maybe cl-queue } } { "quot" quotation }
+}
+{ $description "Run the specified quotation with the given context, device and command queue. False arguments are not bound." } ;
+
+ARTICLE: "opencl" "OpenCL"
+"The " { $vocab-link "opencl" } " vocabulary provides high-level words for using OpenCL."
+{ $subsections
+ cl-platforms
+ <cl-queue>
+ with-cl-state
+}
+"Memory Objects:"
+{ $subsections
+ <cl-buffer>
+ cl-queue-copy-buffer
+ cl-read-buffer
+ cl-queue-read-buffer
+ cl-write-buffer
+ cl-queue-write-buffer
+}
+"Programs and Kernels:"
+{ $subsections
+ <cl-program>
+ <cl-kernel>
+}
+
+"Running and Waiting for Completion:"
+{ $subsections
+ cl-queue-kernel
+ cl-wait
+ cl-flush
+ cl-finish
+}
+;
+
+ABOUT: "opencl"
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: multiline locals io.encodings.ascii io.encodings.string sequences
+math specialized-arrays alien.c-types math.order alien opencl tools.test
+accessors arrays destructors kernel namespaces ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+IN: opencl.tests
+
+STRING: kernel-source
+__kernel void square(
+ __global float* input,
+ __global float* output,
+ const unsigned int count)
+{
+ int i = get_global_id(0);
+ if (i < count)
+ output[i] = input[i] * input[i];
+}
+;
+
+:: opencl-square ( in -- out )
+ [
+ in byte-length :> num-bytes
+ in length :> num-floats
+ cl-platforms first devices>> first :> device
+ device 1array <cl-context> &dispose :> context
+ context device f f <cl-queue> &dispose :> queue
+
+ context device queue [
+ "" kernel-source 1array <cl-program> &dispose "square" <cl-kernel> &dispose :> kernel
+ cl-read-access num-bytes in <cl-buffer> &dispose :> in-buffer
+ cl-write-access num-bytes f <cl-buffer> &dispose :> out-buffer
+
+ kernel in-buffer out-buffer num-floats <uint> 3array
+ { num-floats } [ ] cl-queue-kernel &dispose drop
+
+ cl-finish
+ out-buffer 0 num-bytes <cl-buffer-range> cl-read-buffer num-floats <direct-float-array>
+ ] with-cl-state
+ ] with-destructors ;
+
+[ float-array{ 1.0 4.0 9.0 16.0 100.0 } ]
+[ float-array{ 1.0 2.0 3.0 4.0 10.0 } opencl-square ] unit-test
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors alien.c-types arrays
+byte-arrays combinators combinators.smart continuations destructors
+fry io.encodings.ascii io.encodings.string kernel libc locals macros
+math math.order multiline opencl.ffi prettyprint sequences
+specialized-arrays typed variants namespaces ;
+IN: opencl
+SPECIALIZED-ARRAYS: void* char size_t ;
+
+<PRIVATE
+ERROR: cl-error err ;
+
+: cl-success ( err -- )
+ dup CL_SUCCESS = [ drop ] [ cl-error ] if ; inline
+
+: cl-not-null ( err -- )
+ dup f = [ cl-error ] [ drop ] if ; inline
+
+MACRO: info ( info-quot lift-quot -- quot )
+ [ dup ] dip '[ 2dup 0 f 0 <size_t> _ '[ _ call cl-success ] keep
+ *size_t dup <byte-array> _ '[ f _ call cl-success ] keep
+ _ call ] ;
+
+MACRO: 2info ( info-quot lift-quot -- quot )
+ [ dup ] dip '[ 3dup 0 f 0 <size_t> _ '[ _ call cl-success ] keep
+ *size_t dup <byte-array> _ '[ f _ call cl-success ] keep
+ _ call ] ;
+
+: info-bool ( handle name quot -- ? )
+ [ *uint CL_TRUE = ] info ; inline
+
+: info-ulong ( handle name quot -- ulong )
+ [ *ulonglong ] info ; inline
+
+: info-int ( handle name quot -- int )
+ [ *int ] info ; inline
+
+: info-uint ( handle name quot -- uint )
+ [ *uint ] info ; inline
+
+: info-size_t ( handle name quot -- size_t )
+ [ *size_t ] info ; inline
+
+: 2info-size_t ( handle1 handle2 name quot -- size_t )
+ [ *size_t ] 2info ; inline
+
+: info-string ( handle name quot -- string )
+ [ ascii decode 1 head* ] info ; inline
+
+: 2info-string ( handle name quot -- string )
+ [ ascii decode 1 head* ] 2info ; inline
+
+: info-size_t-array ( handle name quot -- size_t-array )
+ [ [ length size_t heap-size / ] keep swap <direct-size_t-array> ] info ; inline
+
+TUPLE: cl-handle < disposable handle ;
+PRIVATE>
+
+VARIANT: cl-device-type
+ cl-device-default cl-device-cpu cl-device-gpu cl-device-accelerator ;
+
+: size_t>cl-device-type ( size_t -- cl-device-type )
+ {
+ { CL_DEVICE_TYPE_DEFAULT [ cl-device-default ] }
+ { CL_DEVICE_TYPE_CPU [ cl-device-cpu ] }
+ { CL_DEVICE_TYPE_GPU [ cl-device-gpu ] }
+ { CL_DEVICE_TYPE_ACCELERATOR [ cl-device-accelerator ] }
+ } case ; inline
+
+VARIANT: cl-fp-feature
+ cl-denorm cl-inf-and-nan cl-round-to-nearest cl-round-to-zero cl-round-to-inf cl-fma ;
+
+VARIANT: cl-cache-type
+ cl-no-cache cl-read-only-cache cl-read-write-cache ;
+
+VARIANT: cl-buffer-access-mode
+ cl-read-access cl-write-access cl-read-write-access ;
+
+VARIANT: cl-image-channel-order
+ cl-channel-order-r cl-channel-order-a cl-channel-order-rg cl-channel-order-ra
+ cl-channel-order-rga cl-channel-order-rgba cl-channel-order-bgra cl-channel-order-argb
+ cl-channel-order-intensity cl-channel-order-luminance ;
+
+VARIANT: cl-image-channel-type
+ cl-channel-type-snorm-int8 cl-channel-type-snorm-int16 cl-channel-type-unorm-int8
+ cl-channel-type-unorm-int16 cl-channel-type-unorm-short-565
+ cl-channel-type-unorm-short-555 cl-channel-type-unorm-int-101010
+ cl-channel-type-signed-int8 cl-channel-type-signed-int16 cl-channel-type-signed-int32
+ cl-channel-type-unsigned-int8 cl-channel-type-unsigned-int16
+ cl-channel-type-unsigned-int32 cl-channel-type-half-float cl-channel-type-float ;
+
+VARIANT: cl-addressing-mode
+ cl-repeat-addressing cl-clamp-to-edge-addressing cl-clamp-addressing cl-no-addressing ;
+
+VARIANT: cl-filter-mode
+ cl-filter-nearest cl-filter-linear ;
+
+VARIANT: cl-command-type
+ cl-ndrange-kernel-command cl-task-command cl-native-kernel-command cl-read-buffer-command
+ cl-write-buffer-command cl-copy-buffer-command cl-read-image-command cl-write-image-command
+ cl-copy-image-command cl-copy-buffer-to-image-command cl-copy-image-to-buffer-command
+ cl-map-buffer-command cl-map-image-command cl-unmap-mem-object-command
+ cl-marker-command cl-acquire-gl-objects-command cl-release-gl-objects-command ;
+
+VARIANT: cl-execution-status
+ cl-queued cl-submitted cl-running cl-complete cl-failure ;
+
+TUPLE: cl-platform
+ id profile version name vendor extensions devices ;
+
+TUPLE: cl-device
+ id type vendor-id max-compute-units max-work-item-dimensions
+ max-work-item-sizes max-work-group-size preferred-vector-width-char
+ preferred-vector-width-short preferred-vector-width-int
+ preferred-vector-width-long preferred-vector-width-float
+ preferred-vector-width-double max-clock-frequency address-bits
+ max-mem-alloc-size image-support max-read-image-args max-write-image-args
+ image2d-max-width image2d-max-height image3d-max-width image3d-max-height
+ image3d-max-depth max-samplers max-parameter-size mem-base-addr-align
+ min-data-type-align-size single-fp-config global-mem-cache-type
+ global-mem-cacheline-size global-mem-cache-size global-mem-size
+ max-constant-buffer-size max-constant-args local-mem? local-mem-size
+ error-correction-support profiling-timer-resolution endian-little
+ available compiler-available execute-kernels? execute-native-kernels?
+ out-of-order-exec-available? profiling-available?
+ name vendor driver-version profile version extensions ;
+
+TUPLE: cl-context < cl-handle ;
+TUPLE: cl-queue < cl-handle ;
+TUPLE: cl-buffer < cl-handle ;
+TUPLE: cl-sampler < cl-handle ;
+TUPLE: cl-program < cl-handle ;
+TUPLE: cl-kernel < cl-handle ;
+TUPLE: cl-event < cl-handle ;
+
+M: cl-context dispose* handle>> clReleaseContext cl-success ;
+M: cl-queue dispose* handle>> clReleaseCommandQueue cl-success ;
+M: cl-buffer dispose* handle>> clReleaseMemObject cl-success ;
+M: cl-sampler dispose* handle>> clReleaseSampler cl-success ;
+M: cl-program dispose* handle>> clReleaseProgram cl-success ;
+M: cl-kernel dispose* handle>> clReleaseKernel cl-success ;
+M: cl-event dispose* handle>> clReleaseEvent cl-success ;
+
+TUPLE: cl-buffer-ptr
+ { buffer cl-buffer read-only }
+ { offset integer read-only } ;
+C: <cl-buffer-ptr> cl-buffer-ptr
+
+TUPLE: cl-buffer-range
+ { buffer cl-buffer read-only }
+ { offset integer read-only }
+ { size integer read-only } ;
+C: <cl-buffer-range> cl-buffer-range
+
+SYMBOLS: cl-current-context cl-current-queue cl-current-device ;
+
+<PRIVATE
+: (current-cl-context) ( -- cl-context )
+ cl-current-context get ; inline
+
+: (current-cl-queue) ( -- cl-queue )
+ cl-current-queue get ; inline
+
+: (current-cl-device) ( -- cl-device )
+ cl-current-device get ; inline
+
+GENERIC: buffer-access-constant ( buffer-access-mode -- n )
+M: cl-read-write-access buffer-access-constant drop CL_MEM_READ_WRITE ;
+M: cl-read-access buffer-access-constant drop CL_MEM_READ_ONLY ;
+M: cl-write-access buffer-access-constant drop CL_MEM_WRITE_ONLY ;
+
+GENERIC: buffer-map-flags ( buffer-access-mode -- n )
+M: cl-read-write-access buffer-map-flags drop CL_MAP_READ CL_MAP_WRITE bitor ;
+M: cl-read-access buffer-map-flags drop CL_MAP_READ ;
+M: cl-write-access buffer-map-flags drop CL_MAP_WRITE ;
+
+GENERIC: addressing-mode-constant ( addressing-mode -- n )
+M: cl-repeat-addressing addressing-mode-constant drop CL_ADDRESS_REPEAT ;
+M: cl-clamp-to-edge-addressing addressing-mode-constant drop CL_ADDRESS_CLAMP_TO_EDGE ;
+M: cl-clamp-addressing addressing-mode-constant drop CL_ADDRESS_CLAMP ;
+M: cl-no-addressing addressing-mode-constant drop CL_ADDRESS_NONE ;
+
+GENERIC: filter-mode-constant ( filter-mode -- n )
+M: cl-filter-nearest filter-mode-constant drop CL_FILTER_NEAREST ;
+M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
+
+: cl_addressing_mode>addressing-mode ( cl_addressing_mode -- addressing-mode )
+ {
+ { CL_ADDRESS_REPEAT [ cl-repeat-addressing ] }
+ { CL_ADDRESS_CLAMP_TO_EDGE [ cl-clamp-to-edge-addressing ] }
+ { CL_ADDRESS_CLAMP [ cl-clamp-addressing ] }
+ { CL_ADDRESS_NONE [ cl-no-addressing ] }
+ } case ; inline
+
+: cl_filter_mode>filter-mode ( cl_filter_mode -- filter-mode )
+ {
+ { CL_FILTER_LINEAR [ cl-filter-linear ] }
+ { CL_FILTER_NEAREST [ cl-filter-nearest ] }
+ } case ; inline
+
+: platform-info-string ( handle name -- string )
+ [ clGetPlatformInfo ] info-string ; inline
+
+: platform-info ( id -- profile version name vendor extensions )
+ {
+ [ CL_PLATFORM_PROFILE platform-info-string ]
+ [ CL_PLATFORM_VERSION platform-info-string ]
+ [ CL_PLATFORM_NAME platform-info-string ]
+ [ CL_PLATFORM_VENDOR platform-info-string ]
+ [ CL_PLATFORM_EXTENSIONS platform-info-string ]
+ } cleave ;
+
+: cl_device_fp_config>flags ( ulong -- sequence )
+ [ {
+ [ CL_FP_DENORM bitand 0 = [ f ] [ cl-denorm ] if ]
+ [ CL_FP_INF_NAN bitand 0 = [ f ] [ cl-inf-and-nan ] if ]
+ [ CL_FP_ROUND_TO_NEAREST bitand 0 = [ f ] [ cl-round-to-nearest ] if ]
+ [ CL_FP_ROUND_TO_ZERO bitand 0 = [ f ] [ cl-round-to-zero ] if ]
+ [ CL_FP_ROUND_TO_INF bitand 0 = [ f ] [ cl-round-to-inf ] if ]
+ [ CL_FP_FMA bitand 0 = [ f ] [ cl-fma ] if ]
+ } cleave ] { } output>sequence sift ;
+
+: cl_device_mem_cache_type>cache-type ( uint -- cache-type )
+ {
+ { CL_NONE [ cl-no-cache ] }
+ { CL_READ_ONLY_CACHE [ cl-read-only-cache ] }
+ { CL_READ_WRITE_CACHE [ cl-read-write-cache ] }
+ } case ; inline
+
+: device-info-bool ( handle name -- ? )
+ [ clGetDeviceInfo ] info-bool ; inline
+
+: device-info-ulong ( handle name -- ulong )
+ [ clGetDeviceInfo ] info-ulong ; inline
+
+: device-info-uint ( handle name -- uint )
+ [ clGetDeviceInfo ] info-uint ; inline
+
+: device-info-string ( handle name -- string )
+ [ clGetDeviceInfo ] info-string ; inline
+
+: device-info-size_t ( handle name -- size_t )
+ [ clGetDeviceInfo ] info-size_t ; inline
+
+: device-info-size_t-array ( handle name -- size_t-array )
+ [ clGetDeviceInfo ] info-size_t-array ; inline
+
+: device-info ( device-id -- device )
+ dup {
+ [ CL_DEVICE_TYPE device-info-size_t size_t>cl-device-type ]
+ [ CL_DEVICE_VENDOR_ID device-info-uint ]
+ [ CL_DEVICE_MAX_COMPUTE_UNITS device-info-uint ]
+ [ CL_DEVICE_MAX_WORK_ITEM_DIMENSIONS device-info-uint ]
+ [ CL_DEVICE_MAX_WORK_ITEM_SIZES device-info-size_t-array ]
+ [ CL_DEVICE_MAX_WORK_GROUP_SIZE device-info-size_t ]
+ [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_CHAR device-info-uint ]
+ [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_SHORT device-info-uint ]
+ [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_INT device-info-uint ]
+ [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_LONG device-info-uint ]
+ [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_FLOAT device-info-uint ]
+ [ CL_DEVICE_PREFERRED_VECTOR_WIDTH_DOUBLE device-info-uint ]
+ [ CL_DEVICE_MAX_CLOCK_FREQUENCY device-info-uint ]
+ [ CL_DEVICE_ADDRESS_BITS device-info-uint ]
+ [ CL_DEVICE_MAX_MEM_ALLOC_SIZE device-info-ulong ]
+ [ CL_DEVICE_IMAGE_SUPPORT device-info-bool ]
+ [ CL_DEVICE_MAX_READ_IMAGE_ARGS device-info-uint ]
+ [ CL_DEVICE_MAX_WRITE_IMAGE_ARGS device-info-uint ]
+ [ CL_DEVICE_IMAGE2D_MAX_WIDTH device-info-size_t ]
+ [ CL_DEVICE_IMAGE2D_MAX_HEIGHT device-info-size_t ]
+ [ CL_DEVICE_IMAGE3D_MAX_WIDTH device-info-size_t ]
+ [ CL_DEVICE_IMAGE3D_MAX_HEIGHT device-info-size_t ]
+ [ CL_DEVICE_IMAGE3D_MAX_DEPTH device-info-size_t ]
+ [ CL_DEVICE_MAX_SAMPLERS device-info-uint ]
+ [ CL_DEVICE_MAX_PARAMETER_SIZE device-info-size_t ]
+ [ CL_DEVICE_MEM_BASE_ADDR_ALIGN device-info-uint ]
+ [ CL_DEVICE_MIN_DATA_TYPE_ALIGN_SIZE device-info-uint ]
+ [ CL_DEVICE_SINGLE_FP_CONFIG device-info-ulong cl_device_fp_config>flags ]
+ [ CL_DEVICE_GLOBAL_MEM_CACHE_TYPE device-info-uint cl_device_mem_cache_type>cache-type ]
+ [ CL_DEVICE_GLOBAL_MEM_CACHELINE_SIZE device-info-uint ]
+ [ CL_DEVICE_GLOBAL_MEM_CACHE_SIZE device-info-ulong ]
+ [ CL_DEVICE_GLOBAL_MEM_SIZE device-info-ulong ]
+ [ CL_DEVICE_MAX_CONSTANT_BUFFER_SIZE device-info-ulong ]
+ [ CL_DEVICE_MAX_CONSTANT_ARGS device-info-uint ]
+ [ CL_DEVICE_LOCAL_MEM_TYPE device-info-uint CL_LOCAL = ]
+ [ CL_DEVICE_LOCAL_MEM_SIZE device-info-ulong ]
+ [ CL_DEVICE_ERROR_CORRECTION_SUPPORT device-info-bool ]
+ [ CL_DEVICE_PROFILING_TIMER_RESOLUTION device-info-size_t ]
+ [ CL_DEVICE_ENDIAN_LITTLE device-info-bool ]
+ [ CL_DEVICE_AVAILABLE device-info-bool ]
+ [ CL_DEVICE_COMPILER_AVAILABLE device-info-bool ]
+ [ CL_DEVICE_EXECUTION_CAPABILITIES device-info-ulong CL_EXEC_KERNEL bitand 0 = not ]
+ [ CL_DEVICE_EXECUTION_CAPABILITIES device-info-ulong CL_EXEC_NATIVE_KERNEL bitand 0 = not ]
+ [ CL_DEVICE_QUEUE_PROPERTIES device-info-ulong CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE bitand 0 = not ]
+ [ CL_DEVICE_QUEUE_PROPERTIES device-info-ulong CL_QUEUE_PROFILING_ENABLE bitand 0 = not ]
+ [ CL_DEVICE_NAME device-info-string ]
+ [ CL_DEVICE_VENDOR device-info-string ]
+ [ CL_DRIVER_VERSION device-info-string ]
+ [ CL_DEVICE_PROFILE device-info-string ]
+ [ CL_DEVICE_VERSION device-info-string ]
+ [ CL_DEVICE_EXTENSIONS device-info-string ]
+ } cleave cl-device boa ;
+
+: platform-devices ( platform-id -- devices )
+ CL_DEVICE_TYPE_ALL [
+ 0 f 0 <uint> [ clGetDeviceIDs cl-success ] keep *uint
+ ] [
+ rot dup <void*-array> [ f clGetDeviceIDs cl-success ] keep
+ ] 2bi ; inline
+
+: command-queue-info-ulong ( handle name -- ulong )
+ [ clGetCommandQueueInfo ] info-ulong ; inline
+
+: sampler-info-bool ( handle name -- ? )
+ [ clGetSamplerInfo ] info-bool ; inline
+
+: sampler-info-uint ( handle name -- uint )
+ [ clGetSamplerInfo ] info-uint ; inline
+
+: program-build-info-string ( program-handle device-handle name -- string )
+ [ clGetProgramBuildInfo ] 2info-string ; inline
+
+: program-build-log ( program-handle device-handle -- string )
+ CL_PROGRAM_BUILD_LOG program-build-info-string ; inline
+
+: strings>char*-array ( strings -- char*-array )
+ [ ascii encode dup length dup malloc [ cl-not-null ]
+ keep &free [ -rot memcpy ] keep ] void*-array{ } map-as ; inline
+
+: (program) ( cl-context sources -- program-handle )
+ [ handle>> ] dip [
+ [ length ]
+ [ strings>char*-array ]
+ [ [ length ] size_t-array{ } map-as ] tri
+ 0 <int> [ clCreateProgramWithSource ] keep *int cl-success
+ ] with-destructors ;
+
+:: (build-program) ( program-handle device options -- program )
+ program-handle 1 device 1array [ id>> ] void*-array{ } map-as
+ options ascii encode 0 suffix f f clBuildProgram
+ {
+ { CL_BUILD_PROGRAM_FAILURE [
+ program-handle device id>> program-build-log program-handle
+ clReleaseProgram cl-success cl-error f ] }
+ { CL_SUCCESS [ cl-program new-disposable program-handle >>handle ] }
+ [ program-handle clReleaseProgram cl-success cl-success f ]
+ } case ;
+
+: kernel-info-string ( handle name -- string )
+ [ clGetKernelInfo ] info-string ; inline
+
+: kernel-info-uint ( handle name -- uint )
+ [ clGetKernelInfo ] info-uint ; inline
+
+: kernel-work-group-info-size_t ( handle1 handle2 name -- size_t )
+ [ clGetKernelWorkGroupInfo ] 2info-size_t ; inline
+
+: event-info-uint ( handle name -- uint )
+ [ clGetEventInfo ] info-uint ; inline
+
+: event-info-int ( handle name -- int )
+ [ clGetEventInfo ] info-int ; inline
+
+: cl_command_type>command-type ( cl_command-type -- command-type )
+ {
+ { CL_COMMAND_NDRANGE_KERNEL [ cl-ndrange-kernel-command ] }
+ { CL_COMMAND_TASK [ cl-task-command ] }
+ { CL_COMMAND_NATIVE_KERNEL [ cl-native-kernel-command ] }
+ { CL_COMMAND_READ_BUFFER [ cl-read-buffer-command ] }
+ { CL_COMMAND_WRITE_BUFFER [ cl-write-buffer-command ] }
+ { CL_COMMAND_COPY_BUFFER [ cl-copy-buffer-command ] }
+ { CL_COMMAND_READ_IMAGE [ cl-read-image-command ] }
+ { CL_COMMAND_WRITE_IMAGE [ cl-write-image-command ] }
+ { CL_COMMAND_COPY_IMAGE [ cl-copy-image-command ] }
+ { CL_COMMAND_COPY_BUFFER_TO_IMAGE [ cl-copy-buffer-to-image-command ] }
+ { CL_COMMAND_COPY_IMAGE_TO_BUFFER [ cl-copy-image-to-buffer-command ] }
+ { CL_COMMAND_MAP_BUFFER [ cl-map-buffer-command ] }
+ { CL_COMMAND_MAP_IMAGE [ cl-map-image-command ] }
+ { CL_COMMAND_UNMAP_MEM_OBJECT [ cl-unmap-mem-object-command ] }
+ { CL_COMMAND_MARKER [ cl-marker-command ] }
+ { CL_COMMAND_ACQUIRE_GL_OBJECTS [ cl-acquire-gl-objects-command ] }
+ { CL_COMMAND_RELEASE_GL_OBJECTS [ cl-release-gl-objects-command ] }
+ } case ;
+
+: cl_int>execution-status ( clint -- execution-status )
+ {
+ { CL_QUEUED [ cl-queued ] }
+ { CL_SUBMITTED [ cl-submitted ] }
+ { CL_RUNNING [ cl-running ] }
+ { CL_COMPLETE [ cl-complete ] }
+ [ drop cl-failure ]
+ } case ; inline
+
+: profiling-info-ulong ( handle name -- ulong )
+ [ clGetEventProfilingInfo ] info-ulong ; inline
+
+
+: bind-kernel-arg-buffer ( kernel index buffer -- )
+ [ handle>> ] [ cl_mem heap-size ] [ handle>> <void*> ] tri*
+ clSetKernelArg cl-success ; inline
+
+: bind-kernel-arg-data ( kernel index byte-array -- )
+ [ handle>> ] 2dip
+ [ byte-length ] keep clSetKernelArg cl-success ; inline
+
+GENERIC: bind-kernel-arg ( kernel index data -- )
+M: cl-buffer bind-kernel-arg bind-kernel-arg-buffer ;
+M: byte-array bind-kernel-arg bind-kernel-arg-data ;
+PRIVATE>
+
+: with-cl-state ( context/f device/f queue/f quot -- )
+ [
+ [
+ [ cl-current-queue set ] when*
+ [ cl-current-device set ] when*
+ [ cl-current-context set ] when*
+ ] 3curry H{ } make-assoc
+ ] dip bind ; inline
+
+: cl-platforms ( -- platforms )
+ 0 f 0 <uint> [ clGetPlatformIDs cl-success ] keep *uint
+ dup <void*-array> [ f clGetPlatformIDs cl-success ] keep
+ [
+ dup
+ [ platform-info ]
+ [ platform-devices [ device-info ] { } map-as ] bi
+ cl-platform boa
+ ] { } map-as ;
+
+: <cl-context> ( devices -- cl-context )
+ [ f ] dip
+ [ length ] [ [ id>> ] void*-array{ } map-as ] bi
+ f f 0 <int> [ clCreateContext ] keep *int cl-success
+ cl-context new-disposable swap >>handle ;
+
+: <cl-queue> ( context device out-of-order? profiling? -- command-queue )
+ [ [ handle>> ] [ id>> ] bi* ] 2dip
+ [ [ CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE ] [ 0 ] if ]
+ [ [ CL_QUEUE_PROFILING_ENABLE ] [ 0 ] if ] bi* bitor
+ 0 <int> [ clCreateCommandQueue ] keep *int cl-success
+ cl-queue new-disposable swap >>handle ;
+
+: cl-out-of-order-execution? ( command-queue -- ? )
+ CL_QUEUE_PROPERTIES command-queue-info-ulong
+ CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE bitand 0 = not ; inline
+
+: cl-profiling? ( command-queue -- ? )
+ CL_QUEUE_PROPERTIES command-queue-info-ulong
+ CL_QUEUE_PROFILING_ENABLE bitand 0 = not ; inline
+
+: <cl-buffer> ( buffer-access-mode size initial-data -- buffer )
+ [ (current-cl-context) ] 3dip
+ swap over [
+ [ handle>> ]
+ [ buffer-access-constant ]
+ [ [ CL_MEM_COPY_HOST_PTR ] [ CL_MEM_ALLOC_HOST_PTR ] if ] tri* bitor
+ ] 2dip
+ 0 <int> [ clCreateBuffer ] keep *int cl-success
+ cl-buffer new-disposable swap >>handle ;
+
+: cl-read-buffer ( buffer-range -- byte-array )
+ [ (current-cl-queue) handle>> ] dip
+ [ buffer>> handle>> CL_TRUE ]
+ [ offset>> ]
+ [ size>> dup <byte-array> ] tri
+ [ 0 f f clEnqueueReadBuffer cl-success ] keep ; inline
+
+: cl-write-buffer ( buffer-range byte-array -- )
+ [
+ [ (current-cl-queue) handle>> ] dip
+ [ buffer>> handle>> CL_TRUE ]
+ [ offset>> ]
+ [ size>> ] tri
+ ] dip 0 f f clEnqueueWriteBuffer cl-success ; inline
+
+: cl-queue-copy-buffer ( src-buffer-ptr dst-buffer-ptr size dependent-events -- event )
+ [
+ (current-cl-queue)
+ [ handle>> ]
+ [ [ buffer>> handle>> ] [ offset>> ] bi ]
+ [ [ buffer>> handle>> ] [ offset>> ] bi ]
+ tri* swapd
+ ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
+ f <void*> [ clEnqueueCopyBuffer cl-success ] keep *void* cl-event
+ new-disposable swap >>handle ;
+
+: cl-queue-read-buffer ( buffer-range alien dependent-events -- event )
+ [
+ [ (current-cl-queue) handle>> ] dip
+ [ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
+ ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
+ f <void*> [ clEnqueueReadBuffer cl-success ] keep *void* cl-event
+ new-disposable swap >>handle ;
+
+: cl-queue-write-buffer ( buffer-range alien dependent-events -- event )
+ [
+ [ (current-cl-queue) handle>> ] dip
+ [ buffer>> handle>> CL_FALSE ] [ offset>> ] [ size>> ] tri
+ ] 2dip [ length ] keep [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty
+ f <void*> [ clEnqueueWriteBuffer cl-success ] keep *void* cl-event
+ new-disposable swap >>handle ;
+
+: <cl-sampler> ( normalized-coords? addressing-mode filter-mode -- sampler )
+ [ (current-cl-context) ] 3dip
+ [ [ CL_TRUE ] [ CL_FALSE ] if ]
+ [ addressing-mode-constant ]
+ [ filter-mode-constant ]
+ tri* 0 <int> [ clCreateSampler ] keep *int cl-success
+ cl-sampler new-disposable swap >>handle ;
+
+: cl-normalized-coords? ( sampler -- ? )
+ handle>> CL_SAMPLER_NORMALIZED_COORDS sampler-info-bool ; inline
+
+: cl-addressing-mode ( sampler -- addressing-mode )
+ handle>> CL_SAMPLER_ADDRESSING_MODE sampler-info-uint cl_addressing_mode>addressing-mode ; inline
+
+: cl-filter-mode ( sampler -- filter-mode )
+ handle>> CL_SAMPLER_FILTER_MODE sampler-info-uint cl_filter_mode>filter-mode ; inline
+
+: <cl-program> ( options strings -- program )
+ [ (current-cl-device) ] 2dip
+ [ (current-cl-context) ] dip
+ (program) -rot (build-program) ;
+
+: <cl-kernel> ( program kernel-name -- kernel )
+ [ handle>> ] [ ascii encode 0 suffix ] bi*
+ 0 <int> [ clCreateKernel ] keep *int cl-success
+ cl-kernel new-disposable swap >>handle ; inline
+
+: cl-kernel-name ( kernel -- string )
+ handle>> CL_KERNEL_FUNCTION_NAME kernel-info-string ; inline
+
+: cl-kernel-arity ( kernel -- arity )
+ handle>> CL_KERNEL_NUM_ARGS kernel-info-uint ; inline
+
+: cl-kernel-local-size ( kernel -- size )
+ (current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; inline
+
+:: cl-queue-kernel ( kernel args sizes dependent-events -- event )
+ args [| arg idx | kernel idx arg bind-kernel-arg ] each-index
+ (current-cl-queue) handle>>
+ kernel handle>>
+ sizes [ length f ] [ [ ] size_t-array{ } map-as f ] bi
+ dependent-events [ length ] [ [ f ] [ [ handle>> ] void*-array{ } map-as ] if-empty ] bi
+ f <void*> [ clEnqueueNDRangeKernel cl-success ] keep *void*
+ cl-event new-disposable swap >>handle ;
+
+: cl-event-type ( event -- command-type )
+ handle>> CL_EVENT_COMMAND_TYPE event-info-uint cl_command_type>command-type ; inline
+
+: cl-event-status ( event -- execution-status )
+ handle>> CL_EVENT_COMMAND_EXECUTION_STATUS event-info-int cl_int>execution-status ; inline
+
+: cl-profile-counters ( event -- queued submitted started finished )
+ handle>> {
+ [ CL_PROFILING_COMMAND_QUEUED profiling-info-ulong ]
+ [ CL_PROFILING_COMMAND_SUBMIT profiling-info-ulong ]
+ [ CL_PROFILING_COMMAND_START profiling-info-ulong ]
+ [ CL_PROFILING_COMMAND_END profiling-info-ulong ]
+ } cleave ; inline
+
+: cl-barrier-events ( event/events -- )
+ [ (current-cl-queue) handle>> ] dip
+ dup sequence? [ 1array ] unless
+ [ handle>> ] void*-array{ } map-as [ length ] keep clEnqueueWaitForEvents cl-success ; inline
+
+: cl-marker ( -- event )
+ (current-cl-queue)
+ f <void*> [ clEnqueueMarker cl-success ] keep *void* cl-event new-disposable
+ swap >>handle ; inline
+
+: cl-barrier ( -- )
+ (current-cl-queue) clEnqueueBarrier cl-success ; inline
+
+: cl-flush ( -- )
+ (current-cl-queue) handle>> clFlush cl-success ; inline
+
+: cl-wait ( event/events -- )
+ dup sequence? [ 1array ] unless
+ [ handle>> ] void*-array{ } map-as [ length ] keep clWaitForEvents cl-success ; inline
+
+: cl-finish ( -- )
+ (current-cl-queue) handle>> clFinish cl-success ; inline
--- /dev/null
+High-level vocabulary for using OpenCL
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.parser classes.singleton classes.union kernel lexer
+sequences ;
+IN: opencl.syntax
+
+SYNTAX: SINGLETONS-UNION:
+ CREATE-CLASS ";" parse-tokens [ create-class-in [ define-singleton-class ] keep ] map define-union-class ;
--- /dev/null
+bindings
+untested
: rectangles-count ( a b -- n )
2dup [ 1 + ] bi@ * * * 4 /i ; inline
-:: each-unique-product ( a b quot: ( i j -- ) -- )
+:: each-unique-product ( ... a b quot: ( ... i j -- ... ) -- ... )
a b [a,b] [| i |
i b [a,b] [| j |
i j quot call
--- /dev/null
+! Copyright (c) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: project-euler.265 tools.test ;
+
+[ 209110240768 ] [ euler265 ] unit-test
--- /dev/null
+! Copyright (c) 2010 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions project-euler.common sequences sets ;
+IN: project-euler.265
+
+! http://projecteuler.net/index.php?section=problems&id=265
+
+! 2^(N) binary digits can be placed in a circle so that all the N-digit
+! clockwise subsequences are distinct.
+
+! For N=3, two such circular arrangements are possible, ignoring rotations.
+
+! For the first arrangement, the 3-digit subsequences, in clockwise order, are:
+! 000, 001, 010, 101, 011, 111, 110 and 100.
+
+! Each circular arrangement can be encoded as a number by concatenating
+! the binary digits starting with the subsequence of all zeros as the most
+! significant bits and proceeding clockwise. The two arrangements for N=3 are
+! thus represented as 23 and 29:
+! 00010111 _(2) = 23
+! 00011101 _(2) = 29
+
+! Calling S(N) the sum of the unique numeric representations, we can see that S(3) = 23 + 29 = 52.
+
+! Find S(5).
+
+CONSTANT: N 5
+
+: decompose ( n -- seq )
+ N iota [ drop [ 2/ ] [ 1 bitand ] bi ] map nip reverse ;
+
+: bits ( seq -- n )
+ 0 [ [ 2 * ] [ + ] bi* ] reduce ;
+
+: complete ( seq -- seq' )
+ unclip decompose append [ 1 bitand ] map ;
+
+: rotate-bits ( seq -- seq' )
+ dup length iota [ cut prepend bits ] with map ;
+
+: ?register ( acc seq -- )
+ complete rotate-bits
+ dup [ 2 N ^ mod ] map all-unique? [ infimum swap push ] [ 2drop ] if ;
+
+: add-bit ( seen bit -- seen' t/f )
+ over last 2 * + 2 N ^ mod
+ 2dup swap member? [ drop f ] [ suffix t ] if ;
+
+: iterate ( acc left seen -- )
+ over 0 = [
+ nip ?register
+ ] [
+ [ 1 - ] dip
+ { 0 1 } [ add-bit [ iterate ] [ 3drop ] if ] with with with each
+ ] if ;
+
+: euler265 ( -- answer )
+ V{ } clone [ 2 N ^ N - { 0 } iterate ] [ sum ] bi ;
+
+! [ euler265 ] time
+! Running time: 0.376389019 seconds
+
+SOLUTION: euler265
project-euler.134 project-euler.148 project-euler.150 project-euler.151
project-euler.164 project-euler.169 project-euler.173 project-euler.175
project-euler.186 project-euler.188 project-euler.190 project-euler.203
- project-euler.206 project-euler.215 project-euler.255 ;
+ project-euler.206 project-euler.215 project-euler.255 project-euler.265 ;
IN: project-euler
<PRIVATE
"LIBRARY:"\r
"M:" "M::" "MACRO:" "MACRO::" "MAIN:" "MATH:"\r
"MEMO:" "MEMO:" "METHOD:" "MIXIN:"\r
+ "NAN:"\r
"OCT:"\r
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"\r
"QUALIFIED-WITH:" "QUALIFIED:"\r
"SINGLETON:" "SINGLETONS:" "SLOT:" "SPECIALIZED-ARRAY:" "SPECIALIZED-ARRAYS:" "STRING:" "STRUCT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"\r
"TUPLE:" "t" "t?" "TYPEDEF:" "TYPED:" "TYPED::"\r
"UNIFORM-TUPLE:" "UNION:" "UNION-STRUCT:" "USE:" "USING:"\r
- "VARS:" "VERTEX-FORMAT:"))\r
+ "VARIANT:" "VERTEX-FORMAT:"))\r
\r
(defconst fuel-syntax--parsing-words-regex\r
(regexp-opt fuel-syntax--parsing-words 'words))\r
"\\_<-?[0-9]+\\_>")\r
\r
(defconst fuel-syntax--raw-float-regex\r
- "[0-9]*\\.[0-9]*\\([eE][+-]?[0-9]+\\)?")\r
+ "[0-9]*\\.[0-9]*\\([eEpP][+-]?[0-9]+\\)?")\r
\r
(defconst fuel-syntax--float-regex\r
(format "\\_<-?%s\\_>" fuel-syntax--raw-float-regex))\r
'("IN:" "USE:" "FROM:" "EXCLUDE:" "QUALIFIED:" "QUALIFIED-WITH:")))\r
\r
(defconst fuel-syntax--int-constant-def-regex\r
- (fuel-syntax--second-word-regex '("ALIEN:" "CHAR:" "BIN:" "HEX:" "OCT:")))\r
+ (fuel-syntax--second-word-regex '("ALIEN:" "CHAR:" "BIN:" "HEX:" "NAN:" "OCT:")))\r
\r
(defconst fuel-syntax--type-definition-regex\r
(fuel-syntax--second-word-regex\r
"MEMO" "MEMO:" "METHOD"\r
"SYNTAX"\r
"PREDICATE" "PRIMITIVE"\r
- "STRUCT" "TAG" "TUPLE"\r
+ "SINGLETONS"\r
+ "STRUCT" "SYMBOLS" "TAG" "TUPLE"\r
"TYPED" "TYPED:"\r
"UNIFORM-TUPLE"\r
"UNION-STRUCT" "UNION"\r
- "VERTEX-FORMAT"))\r
+ "VARIANT" "VERTEX-FORMAT"))\r
\r
(defconst fuel-syntax--no-indent-def-starts '("ARTICLE"\r
"HELP"\r
- "SINGLETONS"\r
- "SPECIALIZED-ARRAYS"\r
- "SYMBOLS"\r
- "VARS"))\r
+ "SPECIALIZED-ARRAYS"))\r
\r
(defconst fuel-syntax--indent-def-start-regex\r
(format "^\\(%s:\\)\\( \\|\n\\)" (regexp-opt fuel-syntax--indent-def-starts)))\r
"IN:" "INSTANCE:"\r
"LIBRARY:"\r
"MAIN:" "MATH:" "MIXIN:"\r
+ "NAN:"\r
"OCT:"\r
"POSTPONE:" "PRIVATE>" "<PRIVATE"\r
"QUALIFIED-WITH:" "QUALIFIED:"\r
("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))\r
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))\r
("\\_<TUPLE: +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)" (1 "<b"))\r
- ("\\_<\\(SYMBOLS\\|VARS\\|SPECIALIZED-ARRAYS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"\r
+ ("\\_<\\(SYMBOLS\\|SPECIALIZED-ARRAYS\\|SINGLETONS\\|VARIANT\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"\r
(2 "<b"))\r
("\\(\n\\| \\);\\_>" (1 ">b"))\r
;; Let and lambda:\r
projects / factor.git / commitdiff