: 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 ;
: successors ( bb -- first second ) successors>> first2 ; inline
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label ... )
+:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
bb insn
conditional-quot
[ drop dup successors>> second useless-branch? ] 2bi
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' )
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
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 ;
M: effect curry-effect
[ in>> length ] [ out>> length ] [ terminated?>> ] tri
pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
- [ [ "x" <array> ] bi@ ] dip effect boa ;
+ [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
M: curry cached-effect
quot>> cached-effect curry-effect ;
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
nano-count - 1,000 /f system-micros + ;
: reset-timer ( timer -- )
- yield {
- { [ run-queue deque-empty? not ] [ yield system-micros (reset-timer) ] }
- { [ sleep-queue heap-empty? ] [ system-micros 1,000,000 + (reset-timer) ] }
- [ sleep-queue heap-peek nip nano-count>micros (reset-timer) ]
- } cond ;
+ {
+ { [ run-queue deque-empty? not ] [ system-micros ] }
+ { [ sleep-queue heap-empty? not ] [ sleep-queue heap-peek nip nano-count>micros ] }
+ [ system-micros 1,000,000 + ]
+ } cond (reset-timer) ;
PRIVATE>
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: slots arrays definitions generic hashtables summary io kernel
-math namespaces make prettyprint prettyprint.config sequences assocs
-sequences.private strings io.styles io.pathnames vectors words system
-splitting math.parser classes.mixin classes.tuple continuations
-continuations.private combinators generic.math classes.builtin classes
-compiler.units generic.standard generic.single vocabs init
-kernel.private io.encodings accessors math.order destructors
-source-files parser classes.tuple.parser effects.parser lexer
-generic.parser strings.parser vocabs.loader vocabs.parser
-source-files.errors ;
+USING: slots alien.c-types alien.parser arrays definitions generic
+hashtables summary io kernel math namespaces make prettyprint
+prettyprint.config sequences assocs sequences.private strings
+io.styles io.pathnames vectors words system splitting math.parser
+classes.mixin classes.tuple continuations continuations.private
+combinators generic.math classes.builtin classes compiler.units
+generic.standard generic.single vocabs init kernel.private
+io.encodings accessors math.order destructors source-files parser
+classes.tuple.parser effects.parser lexer generic.parser strings.parser
+vocabs.loader vocabs.parser source-files.errors ;
IN: debugger
GENERIC: error-help ( error -- topic )
M: bad-effect summary
drop "Bad stack effect declaration" ;
+M: invalid-row-variable summary
+ drop "Stack effect row variables can only occur as the first input or output" ;
+M: row-variable-can't-have-type summary
+ drop "Stack effect row variables cannot have a declared type" ;
M: bad-escape error.
"Bad escape code: \\" write
M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;
+M: no-c-type summary name>> unparse "“" "” is not a C type" surround ;
+
+M: *-in-c-type-name summary
+ name>> "Cannot define a C type “" "” that ends with an asterisk (*)" surround ;
+
{
{ [ os windows? ] [ "debugger.windows" require ] }
{ [ os unix? ] [ "debugger.unix" require ] }
: 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
FROM: namespaces => set ;\r
IN: furnace.auth\r
\r
TUPLE: recaptcha-app < dispatcher recaptcha ;
-: recaptcha-db ( -- obj ) "recaptcha-example" <sqlite-db> ;
+: recaptcha-db ( -- obj ) "resource:recaptcha-example" <sqlite-db> ;
: <recaptcha-challenge> ( -- obj )
<page-action>
- [
- begin-conversation
- validate-recaptcha
- recaptcha-valid? cget
- "?good" "?bad" ? >url <continue-conversation>
- ] >>submit
+ [ validate-recaptcha ] >>validate
+ [ "?good" >url <redirect> ] >>submit
{ recaptcha-app "example" } >>template ;
: <recaptcha-app> ( -- obj )
\ recaptcha-app new-dispatcher
<recaptcha-challenge> "" add-responder
<recaptcha>
- "concatenative.org" >>domain
- "6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
- "6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key
+ "concatenative.org" >>domain
+ "6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
+ "6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key
recaptcha-db <alloy> ;
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-<html><body><form submit="" method="post"><t:recaptcha/></form></body></html>
+<html><body><t:form t:action=""><t:recaptcha/></t:form></body></html>
</t:chloe>
HELP: <recaptcha>
{ $values
{ "responder" "a responder" }
- { "obj" object }
+ { "recaptcha" recaptcha }
}
-{ $description "A " { $link filter-responder } " wrapping another responder. Set the domain, public, and private keys using the key you get by registering with Recaptcha." } ;
+{ $description "A " { $link filter-responder } " wrapping another responder. Set the domain, public, and private keys using the key you get by registering with recaptcha." } ;
HELP: recaptcha-error
-{ $var-description "Set to the error string returned by the Recaptcha server." } ;
-
-HELP: recaptcha-valid?
-{ $var-description "Set to " { $link t } " if the user solved the last Recaptcha correctly." } ;
+{ $var-description "Set to the error string returned by the recaptcha server." } ;
HELP: validate-recaptcha
-{ $description "Validates a Recaptcha using the Recaptcha web service API." } ;
+{ $description "Validates a recaptcha using the recaptcha web service API." } ;
ARTICLE: "recaptcha-example" "Recaptcha example"
-"There are several steps to using the Recaptcha library."
+"There are several steps to using the recaptcha library."
{ $list
{ "Wrap the responder in a " { $link <recaptcha> } }
- { "Wrap the responder in a " { $link <conversations> } " if it is not already" }
- { "Ensure that there is a database connected, with the " { $link <alloy> } " word" }
- { "Start a conversation to move values between requests" }
- { "Add a handler calling " { $link validate-recaptcha } " in the " { $slot "submit" } " of the " { $link page-action } }
- { "Pass the conversation from your submit action using " { $link <continue-conversation> } }
- { "Put the chloe tag " { $snippet "<recaptcha/>" } " inside a form tag in the template for your " { $link page-action } }
+ { "Wrap the responder in an " { $link <alloy> } " if it is not already, to enable conversations and database access" }
+ { "Call " { $link validate-recaptcha } " from the " { $slot "validate" } " slot of the " { $link action } }
+ { "Put the chloe tag " { $snippet "<recaptcha/>" } " inside a form tag in the template served by your " { $link action } }
}
$nl
-"Run this example vocabulary:"
+"There is an example web app using recaptcha support:"
{ $code
- "USE: furnace.recaptcha.example"
+ "USING: furnace.recaptcha.example http.server ;"
"<recaptcha-app> main-responder set-global"
+ "8080 httpd"
} ;
-ARTICLE: "furnace.recaptcha" "Recaptcha"
-"The " { $vocab-link "furnace.recaptcha" } " vocabulary implements support for the Recaptcha. Recaptcha is a web service that provides the user with a captcha, a test that is easy to solve by visual inspection, but hard to solve by writing a computer program. Use a captcha to protect forms from abusive users." $nl
+ARTICLE: "furnace.recaptcha" "Recaptcha support for Furnace"
+"The " { $vocab-link "furnace.recaptcha" } " vocabulary implements support for the recaptcha. Recaptcha is a web service that provides the user with a captcha, a test that is easy to solve by visual inspection, but hard to solve by writing a computer program. Use a captcha to protect forms from abusive users." $nl
-"The recaptcha responder is a " { $link filter-responder } " that wraps another responder. Set the " { $slot "domain" } ", " { $slot "public-key" } ", and " { $slot "private-key" } " slots of this responder to your Recaptcha account information." $nl
+"The recaptcha responder is a " { $link filter-responder } " that wraps another responder. Set the " { $slot "domain" } ", " { $slot "public-key" } ", and " { $slot "private-key" } " slots of this responder to your recaptcha account information." $nl
-"Wrapping a responder with Recaptcha:"
+"Wrapping a responder with recaptcha support:"
{ $subsections <recaptcha> }
"Validating recaptcha:"
{ $subsections validate-recaptcha }
-"Symbols set after validation:"
-{ $subsections
- recaptcha-valid?
- recaptcha-error
- "recaptcha-example"
-} ;
+"Symbol set after validation:"
+{ $subsections recaptcha-error }
+"An example:"
+{ $subsections "recaptcha-example" } ;
ABOUT: "furnace.recaptcha"
TUPLE: recaptcha < filter-responder domain public-key private-key ;
-SYMBOLS: recaptcha-valid? recaptcha-error ;
+SYMBOL: recaptcha-error
-: <recaptcha> ( responder -- obj )
+: <recaptcha> ( responder -- recaptcha )
recaptcha new
swap >>responder ;
M: recaptcha call-responder*
- dup \ recaptcha set
+ dup recaptcha set
responder>> call-responder ;
<PRIVATE
: (render-recaptcha) ( private-key -- xml )
dup
-[XML <script type="text/javascript"
- src=<->>
-</script>
-
-<noscript>
- <iframe src=<->
- height="300" width="500" frameborder="0"></iframe><br/>
- <textarea name="recaptcha_challenge_field" rows="3" cols="40">
- </textarea>
- <input type="hidden" name="recaptcha_response_field"
- value="manual_challenge"/>
-</noscript>
-XML] ;
+ [XML
+ <script type="text/javascript"
+ src=<->>
+ </script>
+
+ <noscript>
+ <iframe src=<->
+ height="300" width="500" frameborder="0"></iframe><br/>
+ <textarea name="recaptcha_challenge_field" rows="3" cols="40">
+ </textarea>
+ <input type="hidden" name="recaptcha_response_field"
+ value="manual_challenge"/>
+ </noscript>
+ XML] ;
: recaptcha-url ( secure? -- ? )
- [ "https://api.recaptcha.net/challenge" ]
- [ "http://api.recaptcha.net/challenge" ] if
+ "https://api.recaptcha.net/challenge" "http://api.recaptcha.net/challenge" ?
recaptcha-error cget [ "?error=" glue ] when* >url ;
: render-recaptcha ( -- xml )
} URL" http://api-verify.recaptcha.net/verify"
<post-request> http-request nip parse-recaptcha-response ;
-CHLOE: recaptcha
- drop [ render-recaptcha ] [xml-code] ;
+: validate-recaptcha-params ( -- )
+ {
+ { "recaptcha_challenge_field" [ v-required ] }
+ { "recaptcha_response_field" [ v-required ] }
+ } validate-params ;
PRIVATE>
+CHLOE: recaptcha drop [ render-recaptcha ] [xml-code] ;
+
: validate-recaptcha ( -- )
- {
- { "recaptcha_challenge_field" [ v-required ] }
- { "recaptcha_response_field" [ v-required ] }
- } validate-params
+ begin-conversation
+ validate-recaptcha-params
+
"recaptcha_challenge_field" value
"recaptcha_response_field" value
- \ recaptcha get (validate-recaptcha)
- [ recaptcha-valid? cset ] [ recaptcha-error cset ] bi* ;
+ recaptcha get
+ (validate-recaptcha)
+ recaptcha-error cset
+ [ validation-failed ] unless ;
! 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? ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences fry combinators syndication
http.server.responses http.server.redirection furnace.actions
-furnace.utilities ;
+furnace.utilities io.encodings.utf8 ;
IN: furnace.syndication
GENERIC: feed-entry-title ( object -- string )
] map ;
: <feed-content> ( body -- response )
- feed>xml "application/atom+xml" <content> ;
+ feed>xml "application/atom+xml" <content>
+ "UTF-8" >>content-charset
+ utf8 >>content-encoding ;
TUPLE: feed-action < action title url entries ;
+dinput+ [ com-release f ] change-global ;
: device-for-guid ( guid -- device )
- +dinput+ get swap f <void*>
+ +dinput+ get-global swap f <void*>
[ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
: set-coop-level ( device -- )
- +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
- IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
+ +device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
+ IDirectInputDevice8W::SetCooperativeLevel ole32-error ; inline
: set-data-format ( device format-symbol -- )
- get IDirectInputDevice8W::SetDataFormat ole32-error ;
+ get-global IDirectInputDevice8W::SetDataFormat ole32-error ; inline
: <buffer-size-diprop> ( size -- DIPROPDWORD )
DIPROPDWORD <struct> [
+dinput+ get swap device-guid
IDirectInput8W::GetDeviceStatus S_OK = ;
+: (find-device-axes-callback) ( lpddoi pvRef -- BOOL )
+ +controller-devices+ get-global at
+ swap guidType>> {
+ { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
+ { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
+ { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
+ { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
+ { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
+ { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
+ { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
+ [ drop ]
+ } cond drop
+ DIENUM_CONTINUE ;
+
: find-device-axes-callback ( -- alien )
- [ ! ( lpddoi pvRef -- BOOL )
- +controller-devices+ get at
- swap guidType>> {
- { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
- { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
- { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
- { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
- { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
- { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
- { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
- [ drop ]
- } cond drop
- DIENUM_CONTINUE
- ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
+ [ (find-device-axes-callback) ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
: find-device-axes ( device controller-state -- controller-state )
- swap [ +controller-devices+ get set-at ] 2keep
+ swap [ +controller-devices+ get-global set-at ] 2keep
find-device-axes-callback over DIDFT_AXIS
IDirectInputDevice8W::EnumObjects ole32-error ;
find-device-axes ;
: device-known? ( guid -- ? )
- +controller-guids+ get key? ; inline
+ +controller-guids+ get-global key? ; inline
: (add-controller) ( guid -- )
device-for-guid {
[ configure-controller ]
[ controller-state-template ]
- [ dup device-guid clone +controller-guids+ get set-at ]
- [ +controller-devices+ get set-at ]
+ [ dup device-guid clone +controller-guids+ get-global set-at ]
+ [ +controller-devices+ get-global set-at ]
} cleave ;
: add-controller ( guid -- )
dup device-known? [ drop ] [ (add-controller) ] if ;
: remove-controller ( device -- )
- [ +controller-devices+ get delete-at ]
- [ device-guid +controller-guids+ get delete-at ]
+ [ +controller-devices+ get-global delete-at ]
+ [ device-guid +controller-guids+ get-global delete-at ]
[ com-release ] tri ;
+: (find-controller-callback) ( lpddi pvRef -- BOOL )
+ drop guidInstance>> add-controller
+ DIENUM_CONTINUE ;
+
: find-controller-callback ( -- alien )
- [ ! ( lpddi pvRef -- BOOL )
- drop guidInstance>> add-controller
- DIENUM_CONTINUE
- ] LPDIENUMDEVICESCALLBACKW ; inline
+ [ (find-controller-callback) ] LPDIENUMDEVICESCALLBACKW ;
: find-controllers ( -- )
- +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
+ +dinput+ get-global DI8DEVCLASS_GAMECTRL find-controller-callback
f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
: set-up-controllers ( -- )
find-controllers ;
: find-and-remove-detached-devices ( -- )
- +controller-devices+ get keys
+ +controller-devices+ get-global keys
[ device-attached? not ] filter
[ remove-controller ] each ;
] bind ;
M: dinput-game-input-backend get-controllers
- +controller-devices+ get
+ +controller-devices+ get-global
[ drop controller boa ] { } assoc>map ;
M: dinput-game-input-backend product-string
} case ;
: fill-mouse-state ( buffer count -- state )
- iota [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
+ iota [ +mouse-state+ get-global ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
: get-device-state ( device DIJOYSTATE2 -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
[ fill-controller-state ] [ drop f ] with-acquisition ;
M: dinput-game-input-backend read-controller
- handle>> dup +controller-devices+ get at
+ handle>> dup +controller-devices+ get-global at
[ (read-controller) ] [ drop f ] if* ;
M: dinput-game-input-backend calibrate-controller
handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
M: dinput-game-input-backend read-keyboard
- +keyboard-device+ get
- [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
+ +keyboard-device+ get-global
+ [ +keyboard-state+ get-global [ keys>> underlying>> get-device-state ] keep ]
[ ] [ f ] with-acquisition ;
M: dinput-game-input-backend read-mouse
- +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
+ +mouse-device+ get-global [ +mouse-buffer+ get-global MOUSE-BUFFER-SIZE read-device-buffer ]
[ fill-mouse-state ] [ f ] with-acquisition ;
M: dinput-game-input-backend reset-mouse
- +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
+ +mouse-device+ get-global [ f MOUSE-BUFFER-SIZE read-device-buffer ]
[ 2drop ] [ ] with-acquisition
- +mouse-state+ get
+ +mouse-state+ get-global
0 >>dx
0 >>dy
0 >>scroll-dx
HINTS: record-mouse { mouse-state alien } ;
M: iokit-game-input-backend read-mouse
- +mouse-state+ get ;
+ +mouse-state+ get-global ;
M: iokit-game-input-backend reset-mouse
- +mouse-state+ get
+ +mouse-state+ get-global
0 >>dx
0 >>dy
0 >>scroll-dx
} cleave controller-state boa ;
: ?add-mouse-buttons ( device -- )
- button-count +mouse-state+ get buttons>>
+ button-count +mouse-state+ get-global buttons>>
2dup length >
[ set-length ] [ 2drop ] if ;
+:: (device-matched-callback) ( context result sender device -- )
+ {
+ { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
+ { [ device controller-device? ] [
+ device <device-controller-state>
+ device +controller-states+ get-global set-at
+ ] }
+ [ ]
+ } cond ;
+
: device-matched-callback ( -- alien )
- [| context result sender device |
- {
- { [ device controller-device? ] [
- device <device-controller-state>
- device +controller-states+ get set-at
- ] }
- { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
- [ ]
- } cond
- ] IOHIDDeviceCallback ;
+ [ (device-matched-callback) ] IOHIDDeviceCallback ;
+
+:: (device-removed-callback) ( context result sender device -- )
+ device +controller-states+ get-global delete-at ;
: device-removed-callback ( -- alien )
- [| context result sender device |
- device +controller-states+ get delete-at
- ] IOHIDDeviceCallback ;
+ [ (device-removed-callback) ] IOHIDDeviceCallback ;
+
+:: (device-input-callback) ( context result sender value -- )
+ {
+ { [ sender mouse-device? ] [ +mouse-state+ get-global value record-mouse ] }
+ { [ sender controller-device? ] [
+ sender +controller-states+ get-global at value record-controller
+ ] }
+ [ +keyboard-state+ get-global value record-keyboard ]
+ } cond ;
: device-input-callback ( -- alien )
- [| context result sender value |
- {
- { [ sender controller-device? ] [
- sender +controller-states+ get at value record-controller
- ] }
- { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
- [ +keyboard-state+ get value record-keyboard ]
- } cond
- ] IOHIDValueCallback ;
+ [ (device-input-callback) ] IOHIDValueCallback ;
: initialize-variables ( manager -- )
+hid-manager+ set-global
] when ;
M: iokit-game-input-backend get-controllers ( -- sequence )
- +controller-states+ get keys [ controller boa ] map ;
+ +controller-states+ get-global keys [ controller boa ] map ;
: ?join ( pre post sep -- string )
2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
handle>> kIOHIDLocationIDKey device-property ;
M: iokit-game-input-backend read-controller ( controller -- controller-state )
- handle>> +controller-states+ get at clone ;
+ handle>> +controller-states+ get-global at clone ;
M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
- +keyboard-state+ get clone keyboard-state boa ;
+ +keyboard-state+ get-global clone keyboard-state boa ;
M: iokit-game-input-backend calibrate-controller ( controller -- )
drop ;
{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ;\r
\r
HELP: apply-curry\r
-{ $values { "...a" { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }\r
+{ $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }\r
{ $description "Curries each of the top " { $snippet "n" } " items of the datastack onto " { $snippet "quot" } ", leaving " { $snippet "n" } " quotations on the datastack. A generalization of " { $link bi-curry@ } " and " { $link tri-curry@ } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry@ bi" } ", " { $snippet "tri-curry@ tri" } ", " { $snippet "bi-curry@ bi*" } ", and " { $snippet "tri-curry@ tri*" } "." } ;\r
\r
HELP: cleave-curry\r
-{ $values { "a" object } { "...quot" { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
+{ $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
{ $description "Curries " { $snippet "a" } " onto the " { $snippet "n" } " quotations on the top of the datastack. A generalization of " { $link bi-curry } " and " { $link tri-curry } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry bi" } ", " { $snippet "tri-curry tri" } ", " { $snippet "bi-curry bi*" } ", and " { $snippet "tri-curry tri*" } "." } ;\r
\r
HELP: spread-curry\r
-{ $values { "...a" { $snippet "n" } " objects on the datastack" } { "...quot" { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
+{ $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;\r
\r
: mnapply ( quot m n -- )
[ nip dupn ] [ nspread* ] 2bi ; inline
-: apply-curry ( ...a quot n -- )
+: apply-curry ( a... quot n -- )
[ [curry] ] dip napply ; inline
-: cleave-curry ( a ...quot n -- )
+: cleave-curry ( a quot... n -- )
[ [curry] ] swap [ napply ] [ cleave* ] bi ; inline
-: spread-curry ( ...a ...quot n -- )
+: spread-curry ( a... quot... n -- )
[ [curry] ] swap [ napply ] [ spread* ] bi ; inline
MACRO: mnswap ( m n -- )
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 members ;
+: 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 ;
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.parser namespaces make
sequences strings splitting calendar continuations accessors vectors
math.order hashtables byte-arrays destructors
io io.sockets io.streams.string io.files io.timeouts
io.pathnames io.encodings io.encodings.string io.encodings.ascii
-io.encodings.utf8 io.encodings.binary io.crlf
+io.encodings.utf8 io.encodings.binary io.encodings.iana io.crlf
io.streams.duplex fry ascii urls urls.encoding present locals
-http http.parsers http.client.post-data ;
+http http.parsers http.client.post-data mime.types ;
IN: http.client
ERROR: too-many-redirects ;
read-crlf parse-response-line first3
[ >>version ] [ >>code ] [ >>message ] tri* ;
+: detect-encoding ( response -- encoding )
+ [ content-charset>> name>encoding ]
+ [ content-type>> mime-type-encoding ] bi
+ or ;
+
: read-response-header ( response -- response )
read-header >>header
dup "set-cookie" header parse-set-cookie >>cookies
dup "content-type" header [
parse-content-type
- [ >>content-type ]
- [ >>content-charset ] bi*
+ [ >>content-type ] [ >>content-charset ] bi*
+ dup detect-encoding >>content-encoding
] when* ;
: read-response ( -- response )
: http-request ( request -- response data )
[ [ % ] with-http-request ] B{ } make
- over content-charset>> decode check-response-with-body ;
+ over content-encoding>> decode check-response-with-body ;
: <get-request> ( url -- request )
"GET" <client-request> ;
{ { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
{ { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
{ { $slot "content-type" } { "an HTTP content type" } }
- { { $slot "content-charset" } { "an encoding descriptor. See " { $link "io.encodings" } } }
+ { { $slot "content-charset" } { "an encoding name" } }
+ { { $slot "content-encoding" } { "an encoding descriptor. See " { $link "io.encodings" } } }
{ { $slot "body" } { "an HTTP response body" } }
} } ;
io.encodings.8-bit.latin1 ;
IN: http.tests
-[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
+[ "text/plain" "UTF-8" ] [ "text/plain" parse-content-type ] unit-test
-[ "text/html" utf8 ] [ "text/html; charset=UTF-8" parse-content-type ] unit-test
+[ "text/html" "ASCII" ] [ "text/html; charset=ASCII" parse-content-type ] unit-test
-[ "text/html" utf8 ] [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test
+[ "text/html" "utf-8" ] [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test
-[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
+[ "application/octet-stream" f ] [ "application/octet-stream" parse-content-type ] unit-test
: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
{ header H{ { "content-type" "text/html; charset=UTF-8" } } }
{ cookies { } }
{ content-type "text/html" }
- { content-charset utf8 }
+ { content-charset "UTF-8" }
+ { content-encoding utf8 }
}
] [
read-response-test-1 lf>crlf
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators math namespaces make assocs
sequences splitting sorting sets strings vectors hashtables
quotations arrays byte-arrays math.parser calendar
-calendar.format present urls fry
-io io.encodings io.encodings.iana io.encodings.binary
-io.crlf ascii io.encodings.8-bit.latin1 http.parsers base64 ;
+calendar.format present urls fry io io.encodings
+io.encodings.iana io.encodings.binary io.encodings.utf8 io.crlf
+ascii io.encodings.8-bit.latin1 http.parsers base64 mime.types ;
IN: http
CONSTANT: max-redirects 10
cookies
content-type
content-charset
+content-encoding
body ;
: <response> ( -- response )
"close" "connection" set-header
now timestamp>http-string "date" set-header
"Factor http.server" "server" set-header
- latin1 >>content-charset
+ utf8 >>content-encoding
V{ } clone >>cookies ;
M: response clone
: parse-content-type ( content-type -- type encoding )
";" split1
- parse-content-type-attributes "charset" swap at name>encoding
- [ dup "text/" head? latin1 binary ? ] unless* ;
+ parse-content-type-attributes "charset" swap at
+ [ dup mime-type-encoding encoding>name ] unless* ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.parser http accessors kernel xml.syntax xml.writer
io io.streams.string io.encodings.utf8 ;
<response>
200 >>code
"Document follows" >>message
- utf8 >>content-charset
+ utf8 >>content-encoding
swap >>content-type
swap >>body ;
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
-[ "text/plain; charset=UTF-8" ] [
+[ "text/plain; charset=ASCII" ] [
<response>
"text/plain" >>content-type
- utf8 >>content-charset
+ "ASCII" >>content-charset
unparse-content-type
] unit-test
-[ "text/xml" ] [
+[ "text/xml; charset=UTF-8" ] [
<response>
"text/xml" >>content-type
- binary >>content-charset
+ unparse-content-type
+] unit-test
+
+[ "image/jpeg" ] [
+ <response>
+ "image/jpeg" >>content-type
+ unparse-content-type
+] unit-test
+
+[ "application/octet-stream" ] [
+ <response>
unparse-content-type
] unit-test
\ No newline at end of file
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
html.templates
html.streams
html
+mime.types
xml.writer ;
FROM: mime.multipart => parse-multipart ;
IN: http.server
tri ;
: unparse-content-type ( request -- content-type )
- [ content-type>> "application/octet-stream" or ] [ content-charset>> ] bi
- dup binary eq? [ drop ] [ encoding>name "; charset=" glue ] if ;
+ [ content-type>> ] [ content-charset>> ] bi
+ over mime-type-encoding encoding>name or
+ [ "application/octet-stream" or ] dip
+ [ "; charset=" glue ] when* ;
: ensure-domain ( cookie -- cookie )
[
M: response write-full-response ( request response -- )
dup write-response
swap method>> "HEAD" = [
- [ content-charset>> encode-output ]
+ [ content-encoding>> encode-output ]
[ write-response-body ]
bi
] unless drop ;
-! Copyright (C) 2004, 2009 Slava Pestov.\r
+! Copyright (C) 2004, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: calendar kernel math math.order math.parser namespaces\r
parser sequences strings assocs hashtables debugger mime.types\r
dup [ rfc822>timestamp ] when ;\r
\r
: modified-since? ( filename -- ? )\r
- request get modified-since dup [\r
- [ file-info modified>> ] dip after?\r
- ] [\r
- 2drop t\r
- ] if ;\r
+ request get modified-since dup\r
+ [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;\r
\r
: <file-responder> ( root hook -- responder )\r
file-responder new\r
\r
: (serve-static) ( path mime-type -- response )\r
[\r
- [ binary <file-reader> &dispose ] dip\r
- <content> binary >>content-charset\r
+ [ binary <file-reader> &dispose ] dip <content>\r
+ binary >>content-encoding\r
]\r
[ drop file-info [ size>> ] [ modified>> ] bi ] 2bi\r
[ "content-length" set-header ]\r
[ 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*
[ timeout>> timeouts ] [ handle-client* ] bi
] with-stream ;
-\ handle-client ERROR add-error-logging
+\ handle-client NOTICE add-error-logging
: thread-name ( server-name addrspec -- string )
unparse-short " connection from " glue ;
{ 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> ;
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.pathnames io.files io.encodings.ascii assocs sequences
+USING: io.pathnames io.files io.encodings.ascii
+io.encodings.binary io.encodings.utf8 assocs sequences
splitting kernel namespaces fry memoize ;
IN: mime.types
: mime-type ( filename -- mime-type )
file-extension mime-types at "application/octet-stream" or ;
+
+: mime-type-encoding ( mime-type -- encoding )
+ "text/" head? utf8 binary ? ;
+
2 nesting-limit set
string-limit? on
boa-tuples? on
- c-object-pointers? on
+ c-object-pointers? off
call
] with-scope ; inline
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 )
M: cord norm-sq [ norm-sq ] cord-both + ; inline
M: cord distance v- norm ; inline
-
-
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
IN: sequences.generalizations
HELP: neach
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- )" } } { "n" integer } }
{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
HELP: nmap
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
HELP: nmap-as
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
+{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( element... -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
HELP: mnmap
{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
HELP: nproduce-as
-{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "exemplar..." { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
dup 1 - [ min ] n*quot
'[ [ length ] _ napply @ ] ;
-: nnth-unsafe ( n ...seq n -- )
+: nnth-unsafe ( n seq... n -- )
[ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
MACRO: nset-nth-unsafe ( n -- )
[ [ drop ] ]
[ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
if-zero ;
-: (neach) ( ...seq quot n -- len quot' )
+: (neach) ( seq... quot n -- len quot' )
dup dup dup
'[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
-: neach ( ...seq quot n -- )
+: neach ( seq... quot n -- )
(neach) each-integer ; inline
-: nmap-as ( ...seq quot exemplar n -- result )
+: nmap-as ( seq... quot exemplar n -- result )
'[ _ (neach) ] dip map-integers ; inline
-: nmap ( ...seq quot n -- result )
+: nmap ( seq... quot n -- result )
dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
MACRO: nnew-sequence ( n -- )
[ [ drop ] ]
[ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
-: nnew-like ( len ...exemplar quot n -- result... )
+: nnew-like ( len exemplar... quot n -- result... )
5 dupn '[
_ nover
[ [ _ nnew-sequence ] dip call ]
3 dupn 1 +
'[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
-: ncollect ( len quot ...into n -- )
+: ncollect ( len quot into... n -- )
(ncollect) each-integer ; inline
-: nmap-integers ( len quot ...exemplar n -- result... )
+: nmap-integers ( len quot exemplar... n -- result... )
4 dupn
'[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
: mnmap ( m*seq quot m n -- result*n )
2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
-: ncollector-for ( quot ...exemplar n -- quot' vec... )
+: ncollector-for ( quot exemplar... n -- quot' vec... )
5 dupn '[
[ [ length ] keep new-resizable ] _ napply
[ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
: ncollector ( quot n -- quot' vec... )
[ V{ } swap dupn ] keep ncollector-for ; inline
-: nproduce-as ( pred quot ...exemplar n -- seq... )
+: nproduce-as ( pred quot exemplar... n -- seq... )
7 dupn '[
_ ndup
[ _ ncollector-for [ while ] _ ndip ]
: 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 ;
FROM: namespaces => set ;
IN: stack-checker.backend
[ #introduce, ]
tri ;
+: update-inner-d ( new -- )
+ inner-d-index get min inner-d-index set ;
+
: pop-d ( -- obj )
- meta-d [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
+ meta-d
+ [ <value> dup 1array introduce-values ]
+ [ pop meta-d length update-inner-d ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
[ 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
current-effect
stack-visitor get
] with-scope ; 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
[ \ depends-on-final add-conditional-dependency ] bi ;
M: depends-on-final satisfied?
- class>> final-class? ;
+ class>> { [ class? ] [ final-class? ] } 1&& ;
: init-dependencies ( -- )
H{ } clone dependencies set
} ;
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: transform-expansion-error < inference-error error continuation word ;
-ERROR: bad-declaration-error < inference-error declaration ;
\ No newline at end of file
+ERROR: bad-declaration-error < inference-error declaration ;
+
+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" ;
-
-M: unbalanced-branches-error error.
- dup summary print
- [ quots>> ] [ branches>> [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi zip
- [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
-
M: too-many->r summary
drop "Quotation pushes elements on retain stack without popping them" ;
tri ;
M: do-not-compile summary
- word>> name>> "Cannot compile call to " prepend ;
\ No newline at end of file
+ word>> name>> "Cannot compile call to " prepend ;
+
+M: unbalanced-branches-error summary
+ word>> name>>
+ "The input quotations to " " don't match their expected effects" surround ;
+
+M: unbalanced-branches-error error.
+ dup summary print
+ [ quots>> ] [ declareds>> ] [ actuals>> ] tri 3array flip
+ { "Input" "Expected" "Got" } prefix simple-table. ;
+
stack-checker.branches
stack-checker.known-words
stack-checker.dependencies
+stack-checker.row-polymorphism
stack-checker.recursive-state ;
IN: stack-checker.inlining
: 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 ]
+ [ declare-input-effects ]
[
dup inline-recursive-label [
call-recursive-inline-word
[ dup infer-inline-word-def ]
if
] if*
- ] bi ;
+ ] tri ;
M: word apply-object
dup inline? [ inline-word ] [ non-inline-word ] if ;
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: accessors arrays assocs combinators combinators.short-circuit
+continuations effects fry kernel locals math math.order namespaces
+quotations sequences splitting
+stack-checker.backend
+stack-checker.errors
+stack-checker.known-words
+stack-checker.state
+stack-checker.values
+stack-checker.visitor ;
+IN: stack-checker.row-polymorphism
+
+: with-inner-d ( quot -- inner-d )
+ inner-d-index get
+ [ meta-d length inner-d-index set call ] dip
+ inner-d-index get [ min inner-d-index set ] keep ; inline
+
+:: (effect-here) ( inner-d old-meta-d-length old-input-count -- effect )
+ old-meta-d-length inner-d - input-count get old-input-count - +
+ meta-d length inner-d -
+ [ "x" <array> ] bi@ terminated? get <terminated-effect> ; inline
+
+: with-effect-here ( quot -- effect )
+ meta-d length input-count get
+ [ with-inner-d ] 2dip (effect-here) ; inline
+
+: (diff-variable) ( diff variable vars -- diff' )
+ [ at* nip ] [ '[ _ _ at - ] ] [ '[ _ _ set-at 0 ] ] 2tri if ;
+
+: (check-variable) ( actual-count declared-count variable vars -- diff ? )
+ [ - ] 2dip dupd '[ _ _ (diff-variable) t ] [ dup 0 <= ] if ;
+
+: adjust-variable ( diff var vars -- )
+ pick 0 >= [ at+ ] [ 3drop ] if ; inline
+
+:: check-variable ( vars declared actual slot var-slot -- diff ok? var )
+ actual declared [ slot call length ] bi@ declared var-slot call
+ [ vars (check-variable) ] keep ; inline
+
+:: unify-variables ( in-diff in-ok? in-var out-diff out-ok? out-var vars -- ? )
+ { [ 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 ;
+
+: (check-variables) ( vars declared actual -- ? )
+ [ [ in>> ] [ in-var>> ] check-variable ]
+ [ [ out>> ] [ out-var>> ] check-variable ]
+ [ 2drop ] 3tri unify-variables ;
+
+: check-variables ( vars declared actual -- ? )
+ dup terminated?>> [ 3drop t ] [ (check-variables) ] if ;
+
+: combinator-branches-effects ( branches -- quots declareds actuals )
+ [ [ known>callable ] { } map-as ]
+ [ [ effect>> ] { } map-as ]
+ [ [ actual>> ] { } map-as ] tri ;
+
+: combinator-unbalanced-branches-error ( known -- * )
+ [ word>> ] [ branches>> <reversed> combinator-branches-effects ] bi
+ unbalanced-branches-error ;
+
+: check-declared-effect ( known effect -- )
+ [ >>actual ] keep
+ 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
+ [ 2drop ] [ drop combinator-unbalanced-branches-error ] if ;
+
{ "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
+
GENERIC: infer ( quot -- effect )
M: callable infer ( quot -- effect )
- [ infer-quot-here ] with-infer drop ;
+ (infer) ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
! Number of inputs current word expects from the stack
SYMBOL: input-count
+SYMBOL: inner-d-index
DEFER: commit-literals
: current-effect ( -- effect )
input-count get "x" <array>
meta-d length "x" <array>
- terminated? get effect boa ;
+ terminated? get <terminated-effect> ;
: init-inference ( -- )
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
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces prettyprint classes.struct
vm tools.dispatch.private ;
{ "Tuple check count" [ pic-tuple-count>> ] }
} object-table. ;
-: collect-dispatch-stats ( quot -- )
+: collect-dispatch-stats ( quot -- dispatch-statistics )
reset-dispatch-stats
call
- dispatch-stats dispatch-statistics memory>struct
- last-dispatch-stats set ; inline
+ dispatch-stats dispatch-statistics memory>struct ; inline
-USING: tools.test tools.memory memory ;
+USING: tools.test tools.memory memory arrays ;
IN: tools.memory.tests
[ ] [ room. ] unit-test
[ ] [ heap-stats. ] unit-test
-[ ] [ [ gc gc ] collect-gc-events ] unit-test
+[ t ] [ [ gc gc ] collect-gc-events array? ] unit-test
[ ] [ gc-events. ] unit-test
[ ] [ gc-stats. ] unit-test
[ ] [ gc-summary. ] unit-test
] each 2drop
] tabular-output nl ;
-SYMBOL: gc-events
-
-: collect-gc-events ( quot -- )
+: collect-gc-events ( quot -- gc-events )
enable-gc-events
[ ] [ disable-gc-events drop ] cleanup
- disable-gc-events [ gc-event memory>struct ] map gc-events set ; inline
+ disable-gc-events [ gc-event memory>struct ] map ; inline
<PRIVATE
PRIVATE>
+SYMBOL: gc-events
+
: gc-event. ( event -- )
{
{ "Event type:" [ op>> gc-op-string ] }
{ benchmark system-micros time } related-words
HELP: collect-gc-events
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation, storing an array of " { $link gc-event } " instances in the " { $link gc-events } " variable." }
+{ $values { "quot" quotation } { "gc-events" "a sequence of " { $link gc-event } " instances" } }
+{ $description "Calls the quotation and outputs a sequence of " { $link gc-event } " instances." }
{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;
HELP: collect-dispatch-stats
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation, collecting method dispatch statistics and storing them in the " { $link last-dispatch-stats } " variable. " }
+{ $values { "quot" quotation } { "dispatch-statistics" dispatch-statistics } }
+{ $description "Calls the quotation and outputs a " { $link dispatch-statistics } " instance." }
{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math io prettyprint tools.memory
+USING: system kernel math namespaces io prettyprint tools.memory
tools.dispatch ;
IN: tools.time
"gc-summary. - Print aggregate garbage collection statistics" print ;
: time ( quot -- )
- [ [ benchmark ] collect-dispatch-stats ] collect-gc-events
+ [
+ [ benchmark ] collect-dispatch-stats last-dispatch-stats set
+ ] collect-gc-events gc-events set
time. nl time-banner. ; inline
USING: accessors effects eval kernel layouts math namespaces
quotations tools.test typed words words.symbol
-compiler.tree.debugger prettyprint ;
+compiler.tree.debugger prettyprint definitions compiler.units ;
IN: typed.tests
TYPED: f+ ( a: float b: float -- c: float )
a-symbol get
] with-variable
] unit-test
+
+! Forgetting an unboxed final class should work
+TUPLE: forget-class { x read-only } ; final
+
+TYPED: forget-fail ( a: forget-class -- ) drop ;
+
+[ ] [ [ \ forget-class forget ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ forget-fail forget ] with-compilation-unit ] unit-test
! Rendering
{ "drawRect:" void { id SEL NSRect }
- [ 2drop window relayout-1 yield ]
+ [ 2drop window draw-world ]
}
! Events
-unportable bindings
\ No newline at end of file
+bindings\r
-unportable bindings\r
+bindings\r
-unportable bindings
+bindings
ubyte-components >>component-type
t >>upside-down? ;
-: with-memory-dc ( quot: ( hDC -- ) -- )
+: with-memory-dc ( ..a quot: ( ..a hDC -- ..b ) -- ..b )
[ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
:: make-bitmap-image ( dim dc quot -- image )
: 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, row variables can be declared:"
+{ $subsection "effects-variables" }
+"Some examples of row-polymorphic combinators:"
{ $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" } "."
+{ $synopsis if* }
+{ $synopsis each }
+"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 "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" }
}
+"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>
+}
{ $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 row variables"
+"The stack of effect of many " { $link POSTPONE: inline } " combinators can have variable stack effects, depending on the effect of the quotation they call. For example, the quotation parameter to " { $link each } " receives an element from the input sequence each time it is called, but it can also manipulate values on the stack below the element as long as it leaves the same number of elements on the stack. (This is how " { $link reduce } " is implemented in terms of " { $snippet "each" } ".) The stack effect of an " { $snippet "each" } " expression thus depends on the stack effect of its input quotation:"
+{ $example
+ """USING: io sequences stack-checker ;
+[ [ write ] each ] infer."""
+"""( x -- )""" }
+{ $example
+"""USING: sequences stack-checker ;
+[ [ append ] each ] infer."""
+"""( x x -- x )""" }
+"This feature is referred to as row polymorphism. Row-polymorphic combinators are declared by including row variables in their stack effect, which are indicated by names starting with " { $snippet ".." } ":"
+{ $synopsis each }
+"Using the same variable name in both the inputs and outputs (in the above case of " { $snippet "each" } ", " { $snippet "..." } ") indicates that the number of additional inputs and outputs must be the same. Using different variable names indicates that they can be independent. In combinators with multiple quotation inputs, the number of inputs or outputs represented by a particular " { $snippet ".." } " name must match among all of the quotations. For example, the branches of " { $link if* } " can take a different number of inputs from outputs, as long as they both have the same stack height. The true branch receives the test value as an added input. This is declared as follows:"
+{ $synopsis if* }
+"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
-USING: effects kernel tools.test prettyprint accessors
+USING: effects effects.parser eval kernel tools.test prettyprint accessors
quotations sequences ;
IN: effects.tests
[ 2 ] [ (( a b -- c )) in>> length ] unit-test
[ 1 ] [ (( a b -- c )) out>> length ] unit-test
+[ t ] [ (( a b -- c )) (( ... a b -- ... c )) effect<= ] unit-test
+[ t ] [ (( b -- )) (( ... a b -- ... c )) effect<= ] unit-test
+[ f ] [ (( ... a b -- ... c )) (( a b -- c )) effect<= ] unit-test
+[ f ] [ (( ... b -- ... )) (( a b -- c )) effect<= ] unit-test
+[ f ] [ (( a b -- c )) (( ... a b -- c )) effect<= ] unit-test
+[ f ] [ (( a b -- c )) (( ..x a b -- ..y c )) effect<= ] unit-test
+
[ "(( object -- object ))" ] [ { f } { f } <effect> unparse ] unit-test
[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
[ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
[ { object sequence } ] [ (( a b: sequence -- )) effect-in-types ] unit-test
+
+[ f ] [ (( a b c -- d )) in-var>> ] unit-test
+[ f ] [ (( -- d )) in-var>> ] unit-test
+[ "a" ] [ (( ..a b c -- d )) in-var>> ] unit-test
+[ { "b" "c" } ] [ (( ..a b c -- d )) in>> ] unit-test
+
+[ f ] [ (( ..a b c -- e )) out-var>> ] unit-test
+[ "d" ] [ (( ..a b c -- ..d e )) out-var>> ] unit-test
+[ { "e" } ] [ (( ..a b c -- ..d e )) out>> ] unit-test
+
+[ "(( a ..b c -- d ))" eval( -- effect ) ]
+[ error>> invalid-row-variable? ] must-fail-with
+
+[ "(( ..a: integer b c -- d ))" eval( -- effect ) ]
+[ error>> row-variable-can't-have-type? ] must-fail-with
TUPLE: effect
{ in array read-only }
{ out array read-only }
-{ terminated? read-only } ;
+{ terminated? read-only }
+{ in-var read-only }
+{ out-var read-only } ;
+
+: ?terminated ( out -- out terminated? )
+ dup { "*" } = [ drop { } t ] [ f ] if ;
: <effect> ( in out -- effect )
- dup { "*" } = [ drop { } t ] [ f ] if
- effect boa ;
+ ?terminated f f effect boa ;
+
+: <terminated-effect> ( in out terminated? -- effect )
+ f f effect boa ; inline
+
+: <variable-effect> ( in-var in out-var out -- effect )
+ swap [ rot ] dip [ ?terminated ] 2dip effect boa ;
: effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline
+: variable-effect? ( effect -- ? )
+ [ in-var>> ] [ out-var>> ] bi or ;
+: bivariable-effect? ( effect -- ? )
+ [ in-var>> ] [ out-var>> ] bi = not ;
+
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
+ { [ 2dup [ bivariable-effect? ] either? ] [ f ] }
+ { [ 2dup [ variable-effect? ] [ variable-effect? not ] bi* and ] [ f ] }
{ [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]
: stack-picture ( seq -- string )
[ [ effect>string % CHAR: \s , ] each ] "" make ;
+: var-picture ( var -- string )
+ [ ".." " " surround ]
+ [ "" ] if* ;
+
M: effect effect>string ( effect -- string )
[
"( " %
- [ in>> stack-picture % "-- " % ]
- [ out>> stack-picture % ]
- [ terminated?>> [ "* " % ] when ]
- tri
+ dup in-var>> var-picture %
+ dup in>> stack-picture % "-- " %
+ dup out-var>> var-picture %
+ dup out>> stack-picture %
+ dup terminated?>> [ "* " % ] when
+ drop
")" %
] "" make ;
shuffle-mapping swap nths ;
: add-effect-input ( effect -- effect' )
- [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
+ [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri <terminated-effect> ;
: compose-effects ( effect1 effect2 -- effect' )
over terminated?>> [
[ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
[ nip terminated?>> ] 2tri
[ [ "x" <array> ] bi@ ] dip
- effect boa
+ <terminated-effect>
] if ; inline
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects
-combinators arrays vocabs.parser classes parser ;
+combinators arrays make vocabs.parser classes parser ;
IN: effects.parser
DEFER: parse-effect
ERROR: bad-effect ;
+ERROR: invalid-row-variable ;
+ERROR: row-variable-can't-have-type ;
+ERROR: stack-effect-omits-dashes ;
-: parse-effect-token ( end -- token/f )
- scan [ nip ] [ = ] 2bi [ drop f ] [
- dup { f "(" "((" } member? [ bad-effect ] [
- ":" ?tail [
- scan {
- { [ dup "(" = ] [ drop ")" parse-effect ] }
- { [ dup f = ] [ ")" unexpected-eof ] }
- [ parse-word dup class? [ bad-effect ] unless ]
- } cond 2array
- ] when
- ] if
- ] if ;
+SYMBOL: effect-var
-: parse-effect-tokens ( end -- tokens )
- [ parse-effect-token dup ] curry [ ] produce nip ;
+<PRIVATE
+: end-token? ( end token -- token ? ) [ nip ] [ = ] 2bi ; inline
+: effect-opener? ( token -- token ? ) dup { f "(" "((" "--" } member? ; inline
+: effect-closer? ( token -- token ? ) dup { ")" "))" } member? ; inline
+: row-variable? ( token -- token' ? ) ".." ?head ; inline
-ERROR: stack-effect-omits-dashes tokens ;
+: parse-effect-var ( first? var name -- var )
+ nip
+ [ ":" ?tail [ row-variable-can't-have-type ] when ] curry
+ [ invalid-row-variable ] if ;
+
+: parse-effect-value ( token -- value )
+ ":" ?tail [
+ scan {
+ { [ dup "(" = ] [ drop ")" parse-effect ] }
+ { [ dup f = ] [ ")" unexpected-eof ] }
+ [ parse-word dup class? [ bad-effect ] unless ]
+ } cond 2array
+ ] when ;
+PRIVATE>
+
+: parse-effect-token ( first? var end -- var more? )
+ scan {
+ { [ end-token? ] [ drop nip f ] }
+ { [ effect-opener? ] [ bad-effect ] }
+ { [ effect-closer? ] [ stack-effect-omits-dashes ] }
+ { [ row-variable? ] [ parse-effect-var t ] }
+ [ [ drop ] 2dip parse-effect-value , t ]
+ } cond ;
+
+: parse-effect-tokens ( end -- var tokens )
+ [
+ [ t f ] dip [ parse-effect-token [ f ] 2dip ] curry [ ] while nip
+ ] { } make ;
: parse-effect ( end -- effect )
- parse-effect-tokens { "--" } split1 dup
- [ <effect> ] [ drop stack-effect-omits-dashes ] if ;
+ [ "--" parse-effect-tokens ] dip parse-effect-tokens
+ <variable-effect> ;
: complete-effect ( -- effect )
"(" expect ")" parse-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
#! two literal quotations.
rot [ drop ] [ nip ] if ; inline
-: if ( ? true false -- ) ? call ;
+: if ( ..a ? true: ( ..a -- ..b ) false: ( ..a -- ..b ) -- ..b ) ? call ;
! Single branch
: unless ( ? false -- )
swap [ call ] [ drop ] if ; inline
! Anaphoric
-: if* ( ? true false -- )
+: if* ( ..a ? true: ( ..a ? -- ..b ) false: ( ..a -- ..b ) -- ..b )
pick [ drop call ] [ 2nip call ] if ; inline
: when* ( ? true -- )
over [ drop ] [ nip call ] if ; inline
! Default
-: ?if ( default cond true false -- )
+: ?if ( ..a default cond true: ( ..a cond -- ..b ) false: ( ..a default -- ..b ) -- ..b )
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
! Dippers.
: most ( x y quot -- z ) 2keep ? ; inline
! Loops
-: loop ( pred: ( -- ? ) -- )
+: loop ( ... pred: ( ... -- ... ? ) -- ... )
[ call ] keep [ loop ] curry when ; inline recursive
: 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 ;
source-files.errors ;
IN: lexer
-TUPLE: lexer text line line-text line-length column ;
+TUPLE: lexer text line line-text line-length column parsing-words ;
+
+TUPLE: lexer-parsing-word word line line-text column ;
: next-line ( lexer -- )
dup [ line>> ] [ text>> ] bi ?nth >>line-text
0 >>column
drop ;
+: push-parsing-word ( word -- )
+ lexer-parsing-word new
+ swap >>word
+ lexer get [
+ [ line>> >>line ]
+ [ line-text>> >>line-text ]
+ [ column>> >>column ] tri
+ ] [ parsing-words>> push ] bi ;
+
+: pop-parsing-word ( -- )
+ lexer get parsing-words>> pop drop ;
+
: new-lexer ( text class -- lexer )
new
0 >>line
swap >>text
+ V{ } clone >>parsing-words
dup next-line ; inline
: <lexer> ( text -- lexer )
: (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 )
[ ] map-tokens ;
-TUPLE: lexer-error line column line-text error ;
+TUPLE: lexer-error line column line-text parsing-words error ;
M: lexer-error error-file error>> error-file ;
M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
: <lexer-error> ( msg -- error )
\ lexer-error new
- lexer get
- [ line>> >>line ]
- [ column>> >>column ]
- [ line-text>> >>line-text ]
- tri
+ lexer get [
+ [ line>> >>line ]
+ [ column>> >>column ] bi
+ ] [
+ [ line-text>> >>line-text ]
+ [ parsing-words>> clone >>parsing-words ] bi
+ ] bi
swap >>error ;
-: lexer-dump ( error -- )
+: simple-lexer-dump ( error -- )
[ line>> number>string ": " append ]
[ line-text>> dup string? [ drop "" ] unless ]
[ column>> 0 or ] tri
pick length + CHAR: \s <string>
[ write ] [ print ] [ write "^" print ] tri* ;
+: (parsing-word-lexer-dump) ( error parsing-word -- )
+ [
+ line>> number>string
+ over line>> number>string length
+ CHAR: \s pad-head
+ ": " append write
+ ] [ line-text>> dup string? [ drop "" ] unless print ] bi
+ simple-lexer-dump ;
+
+: parsing-word-lexer-dump ( error parsing-word -- )
+ 2dup [ line>> ] bi@ =
+ [ drop simple-lexer-dump ]
+ [ (parsing-word-lexer-dump) ] if ;
+
+: lexer-dump ( error -- )
+ dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ;
+
: with-lexer ( lexer quot -- newquot )
[ lexer set ] dip [ <lexer-error> rethrow ] recover ; inline
{ $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 } "." } ;
: even? ( n -- ? ) 1 bitand zero? ;
: odd? ( n -- ? ) 1 bitand 1 number= ;
-: if-zero ( n quot1 quot2 -- )
+: if-zero ( ..a n quot1: ( ..a -- ..b ) quot2: ( ..a n -- ..b ) -- ..b )
[ dup zero? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-zero ( n quot -- ) [ ] if-zero ; inline
PRIVATE>
-: (each-integer) ( i n quot: ( i -- ) -- )
+: (each-integer) ( ... i n quot: ( ... i -- ... ) -- ... )
[ iterate-step iterate-next (each-integer) ]
[ 3drop ] if-iterate? ; inline recursive
-: (find-integer) ( i n quot: ( i -- ? ) -- i )
+: (find-integer) ( ... i n quot: ( ... i -- ... ? ) -- ... i )
[
iterate-step
[ [ ] ] 2dip
[ iterate-next (find-integer) ] 2curry bi-curry if
] [ 3drop f ] if-iterate? ; inline recursive
-: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
+: (all-integers?) ( ... i n quot: ( ... i -- ... ? ) -- ... ? )
[
iterate-step
[ iterate-next (all-integers?) ] 3curry
: all-integers? ( n quot -- ? )
iterate-prep (all-integers?) ; inline
-: find-last-integer ( n quot: ( i -- ? ) -- i )
+: find-last-integer ( ... n quot: ( ... i -- ... ? ) -- ... i )
over 0 < [
2drop f
] [
ERROR: staging-violation word ;
+: (execute-parsing) ( accum word -- accum )
+ dup push-parsing-word
+ execute( accum -- accum )
+ pop-parsing-word ; inline
+
: execute-parsing ( accum word -- accum )
dup changed-definitions get key? [ staging-violation ] when
- execute( accum -- accum ) ;
+ (execute-parsing) ;
: scan-object ( -- object )
scan-word {
{ $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
: empty? ( seq -- ? ) length 0 = ; inline
-: if-empty ( seq quot1 quot2 -- )
+: if-empty ( ..a seq quot1: ( ..a -- ..b ) quot2: ( ..a seq -- ..b ) -- ..b )
[ dup empty? ] [ [ drop ] prepose ] [ ] tri* if ; inline
: when-empty ( seq quot -- ) [ ] if-empty ; inline
PRIVATE>
-: each ( seq quot -- )
+: each ( ... seq quot: ( ... x -- ... ) -- ... )
(each) each-integer ; inline
-: reduce ( seq identity quot -- result )
+: reduce ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... result )
swapd each ; inline
: map-integers ( len quot exemplar -- newseq )
[ over ] dip [ [ collect ] keep ] new-like ; inline
-: map-as ( seq quot exemplar -- newseq )
+: map-as ( ... seq quot: ( ... elt -- ... newelt ) exemplar -- ... newseq )
[ (each) ] dip map-integers ; inline
-: map ( seq quot -- newseq )
+: map ( ... seq quot: ( ... elt -- ... newelt ) -- ... newseq )
over map-as ; inline
-: replicate-as ( len quot exemplar -- newseq )
+: replicate-as ( ... len quot: ( ... -- ... newelt ) exemplar -- ... newseq )
[ [ drop ] prepose ] dip map-integers ; inline
-: replicate ( len quot -- newseq )
+: replicate ( ... len quot: ( ... -- ... newelt ) -- ... newseq )
{ } replicate-as ; inline
-: map! ( seq quot -- seq )
+: map! ( ... seq quot: ( ... elt -- ... newelt ) -- ... seq )
over [ map-into ] keep ; inline
-: accumulate-as ( seq identity quot exemplar -- final newseq )
+: accumulate-as ( ... seq identity quot: ( ... prev elt -- ... next ) exemplar -- ... final newseq )
[ (accumulate) ] dip map-as ; inline
-: accumulate ( seq identity quot -- final newseq )
+: accumulate ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final newseq )
{ } accumulate-as ; inline
-: accumulate! ( seq identity quot -- final seq )
+: accumulate! ( ... seq identity quot: ( ... prev elt -- ... next ) -- ... final seq )
(accumulate) map! ; inline
-: 2each ( seq1 seq2 quot -- )
+: 2each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
(2each) each-integer ; inline
-: 2reverse-each ( seq1 seq2 quot -- )
+: 2reverse-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
[ [ <reversed> ] bi@ ] dip 2each ; inline
-: 2reduce ( seq1 seq2 identity quot -- result )
+: 2reduce ( ... seq1 seq2 identity quot: ( ... prev elt1 elt2 -- ... next ) -- ... result )
[ -rot ] dip 2each ; inline
-: 2map-as ( seq1 seq2 quot exemplar -- newseq )
+: 2map-as ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) exemplar -- ... newseq )
[ (2each) ] dip map-integers ; inline
-: 2map ( seq1 seq2 quot -- newseq )
+: 2map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
pick 2map-as ; inline
-: 2all? ( seq1 seq2 quot -- ? )
+: 2all? ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ? ) -- ... ? )
(2each) all-integers? ; inline
-: 3each ( seq1 seq2 seq3 quot -- )
+: 3each ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... ) -- ... )
(3each) each-integer ; inline
-: 3map-as ( seq1 seq2 seq3 quot exemplar -- newseq )
+: 3map-as ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) exemplar -- ... newseq )
[ (3each) ] dip map-integers ; inline
-: 3map ( seq1 seq2 seq3 quot -- newseq )
+: 3map ( ... seq1 seq2 seq3 quot: ( ... elt1 elt2 elt3 -- ... newelt ) -- ... newseq )
[ pick ] dip swap 3map-as ; inline
-: find-from ( n seq quot -- i elt )
+: find-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ (find-integer) ] (find-from) ; inline
-: find ( seq quot -- i elt )
+: find ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ find-integer ] (find) ; inline
-: find-last-from ( n seq quot -- i elt )
+: find-last-from ( ... n seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ nip find-last-integer ] (find-from) ; inline
-: find-last ( seq quot -- i elt )
+: find-last ( ... seq quot: ( ... elt -- ... ? ) -- ... i elt )
[ [ 1 - ] dip find-last-integer ] (find) ; inline
-: all? ( seq quot -- ? )
+: all? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
(each) all-integers? ; inline
-: push-if ( elt quot accum -- )
+: push-if ( ..a elt quot: ( ..a elt -- ..b ? ) accum -- ..b )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
: selector-for ( quot exemplar -- selector accum )
: selector ( quot -- selector accum )
V{ } selector-for ; inline
-: filter-as ( seq quot exemplar -- subseq )
+: filter-as ( ... seq quot: ( ... elt -- ... ? ) exemplar -- ... subseq )
dup [ selector-for [ each ] dip ] curry dip like ; inline
-: filter ( seq quot -- subseq )
+: filter ( ... seq quot: ( ... elt -- ... ? ) -- ... subseq )
over filter-as ; inline
-: push-either ( elt quot accum1 accum2 -- )
+: push-either ( ..a elt quot: ( ..a elt -- ..b ? ) accum1 accum2 -- ..b )
[ keep swap ] 2dip ? push ; inline
: 2selector ( quot -- selector accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
-: partition ( seq quot -- trueseq falseseq )
+: partition ( ... seq quot: ( ... elt -- ... ? ) -- ... trueseq falseseq )
over [ 2selector [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: collector-for ( quot exemplar -- quot' vec )
: collector ( quot -- quot' vec )
V{ } collector-for ; inline
-: produce-as ( pred quot 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 -- seq )
+: produce ( ..a pred: ( ..a -- ..b ? ) quot: ( ..b -- ..a obj ) -- ..b seq )
{ } produce-as ; inline
-: follow ( obj quot -- seq )
+: follow ( ... obj quot: ( ... prev -- ... result/f ) -- ... seq )
[ dup ] swap [ keep ] curry produce nip ; inline
-: each-index ( seq quot -- )
+: each-index ( ... seq quot: ( ... elt index -- ... ) -- ... )
(each-index) each-integer ; inline
: interleave ( seq between quot -- )
3bi
] if ; inline
-: map-index ( seq quot -- newseq )
+: map-index ( ... seq quot: ( ... elt index -- ... newelt ) -- ... newseq )
[ dup length iota ] dip 2map ; inline
-: reduce-index ( seq identity quot -- )
+: reduce-index ( ... seq identity quot: ( ... prev elt index -- ... next ) -- ... result )
swapd each-index ; inline
: index ( obj seq -- n )
: nths ( indices seq -- seq' )
[ nth ] curry map ;
-: any? ( seq quot -- ? )
+: any? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? )
find drop >boolean ; inline
: member? ( elt seq -- ? )
<PRIVATE
-: (filter!) ( quot: ( elt -- ? ) store scan seq -- )
+: (filter!) ( ... quot: ( ... elt -- ... ? ) store scan seq -- ... )
2dup length < [
[ move ] 3keep
[ nth-unsafe pick call [ 1 + ] when ] 2keep
PRIVATE>
-: filter! ( seq quot -- seq )
+: filter! ( ... seq quot: ( ... elt -- ... ? ) -- ... seq )
swap [ [ 0 0 ] dip (filter!) ] keep ; inline
: remove! ( elt seq -- seq )
] keep like
] if ;
-: padding ( seq n elt quot -- newseq )
+: padding ( ... seq n elt quot: ( ... seq1 seq2 -- ... newseq ) -- ... newseq )
[
[ over length [-] dup 0 = [ drop ] ] dip
[ <repetition> ] curry
: halves ( seq -- first-slice second-slice )
dup midpoint@ cut-slice ;
-: binary-reduce ( seq start quot: ( elt1 elt2 -- newelt ) -- value )
+: binary-reduce ( ... seq start quot: ( ... elt1 elt2 -- ... newelt ) -- ... value )
#! We can't use case here since combinators depends on
#! sequences
pick length dup 0 3 between? [
: 2unclip-slice ( seq1 seq2 -- rest-slice1 rest-slice2 first1 first2 )
[ unclip-slice ] bi@ swapd ; inline
-: map-reduce ( seq map-quot reduce-quot -- result )
+: map-reduce ( ..a seq map-quot: ( ..a x -- ..b elt ) reduce-quot: ( ..b prev elt -- ..a next ) -- ..a result )
[ [ unclip-slice ] dip [ call ] keep ] dip
compose reduce ; inline
-: 2map-reduce ( seq1 seq2 map-quot reduce-quot -- 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 -- result elt )
+: map-find ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt )
[ find ] (map-find) ; inline
-: map-find-last ( seq quot -- result elt )
+: map-find-last ( ... seq quot: ( ... elt -- ... result/f ) -- ... result elt )
[ find-last ] (map-find) ; inline
: unclip-last-slice ( seq -- butlast-slice last )
PRIVATE>
-: trim-head-slice ( seq quot -- slice )
+: trim-head-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-head) tail-slice ; inline
-: trim-head ( seq quot -- newseq )
+: trim-head ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-head) tail ; inline
-: trim-tail-slice ( seq quot -- slice )
+: trim-tail-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
(trim-tail) head-slice ; inline
-: trim-tail ( seq quot -- newseq )
+: trim-tail ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
(trim-tail) head ; inline
-: trim-slice ( seq quot -- slice )
+: trim-slice ( ... seq quot: ( ... elt -- ... ? ) -- ... slice )
[ trim-head-slice ] [ trim-tail-slice ] bi ; inline
-: trim ( seq quot -- newseq )
+: trim ( ... seq quot: ( ... elt -- ... ? ) -- ... newseq )
[ trim-slice ] [ drop ] 2bi like ; inline
GENERIC: sum ( seq -- n )
: supremum ( seq -- n ) [ ] [ max ] map-reduce ;
-: map-sum ( seq quot -- n )
+: map-sum ( ... seq quot: ( ... elt -- ... n ) -- ... n )
[ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
-: count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline
+: count ( ... seq quot: ( ... elt -- ... ? ) -- ... n ) [ 1 0 ? ] compose map-sum ; inline
-: cartesian-each ( seq1 seq2 quot -- )
+: cartesian-each ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... ) -- ... )
[ with each ] 2curry each ; inline
-: cartesian-map ( seq1 seq2 quot -- newseq )
+: cartesian-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
[ with map ] 2curry map ; inline
: cartesian-product ( seq1 seq2 -- newseq )
[ 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."
+} ;
+
+ARTICLE: "astar" "A* algorithm"
+"The " { $vocab-link "astar" } " vocabulary implements a graph search algorithm for finding the least-cost path from one node to another." $nl
+"Make an A* object:"
+{ $subsections <astar> }
+"Find a path between nodes:"
+{ $subsections find-path } ;
+
+ABOUT: "astar"
--- /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
+
+<<
+
+TUPLE: maze < astar ;
+
+: 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 ;
+
+M: maze neighbours
+ drop
+ first2
+ { [ 1 + 2array ] [ 1 - 2array ] [ [ 1 + ] dip 2array ] [ [ 1 - ] dip 2array ] } 2cleave
+ 4array
+ [ reachable? ] filter ;
+
+M: maze heuristic
+ drop v- [ abs ] [ + ] map-reduce ;
+
+M: maze cost
+ drop 2dup [ first ] bi@ = [ [ second ] bi@ > 1 5 ? ] [ 2drop 2 ] if ;
+
+: test1 ( to -- path considered )
+ { 1 1 } swap maze new [ 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)
+
+<<
+
+! In this version, we will use the quotations-aware version through <astar>.
+
+: 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 ;
-! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs benchmark bootstrap.stage2 compiler.errors
-source-files.errors generic help.html help.lint io.directories
-io.encodings.utf8 io.files kernel mason.common math namespaces
-prettyprint sequences sets sorting tools.test tools.time
-words system io tools.errors vocabs.hierarchy vocabs.errors
-vocabs.refresh locals ;
+USING: accessors assocs benchmark bootstrap.stage2
+compiler.errors source-files.errors generic help.html help.lint
+io.directories io.encodings.utf8 io.files kernel mason.common
+math namespaces prettyprint sequences sets sorting tools.test
+tools.time words system io tools.errors vocabs vocabs.files
+vocabs.hierarchy vocabs.errors vocabs.refresh locals
+source-files compiler.units ;
IN: mason.test
: do-load ( -- )
test-all-errors-file
do-step ;
+: cleanup-tests ( -- )
+ ! Free up some code heap space
+ [
+ vocabs [ vocab-tests [ forget-source ] each ] each
+ ] with-compilation-unit ;
+
: do-help-lint ( -- )
help-lint-all lint-failures get values
help-lint-vocabs-file
[ do-load ] benchmark load-time-file to-file
[ generate-help ] benchmark html-help-time-file to-file
[ do-tests ] benchmark test-time-file to-file
+ cleanup-tests
[ do-help-lint ] benchmark help-lint-time-file to-file
[ do-benchmarks ] benchmark benchmark-time-file to-file
do-compile-errors
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
! Copyright (c) 2010 Aaron Schaefer. All rights reserved.
! The contents of this file are licensed under the Simplified BSD License
! A copy of the license is available at http://factorcode.org/license.txt
-USING: grouping kernel math math.ranges project-euler.common sequences ;
+USING: grouping kernel math math.ranges project-euler.common
+sequences sequences.cords ;
IN: project-euler.206
! http://projecteuler.net/index.php?section=problems&id=206
{ 1 2 3 4 5 6 7 8 9 0 } = ;
: candidates ( -- seq )
- lo lo 40 + [ hi 100 <range> ] bi@ append ;
+ lo lo 40 + [ hi 100 <range> ] bi@ cord-append ;
PRIVATE>
--- /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
<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
<tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
+ <tr><td colspan="2"><t:recaptcha /></td></tr>
</table>
<p> <button type="submit">Submit</button> </p>
<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
<tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
+ <tr><td colspan="2"><t:recaptcha /></td></tr>
</table>
<p> <button type="submit">Done</button> </p>
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
hashtables db.types db.tuples db combinators
furnace.auth
furnace.auth.login
furnace.boilerplate
-furnace.syndication ;
+furnace.recaptcha
+furnace.syndication
+furnace.conversations ;
IN: webapps.pastebin
TUPLE: pastebin < dispatcher ;
{ "author" [ v-one-line ] }
{ "mode" [ v-mode ] }
{ "contents" [ v-required ] }
- { "captcha" [ v-captcha ] }
- } validate-params ;
+ } validate-params
+ validate-recaptcha ;
: deposit-entity-slots ( tuple -- )
now >>date
furnace.auth.features.deactivate-user
furnace.boilerplate
furnace.redirection
+furnace.recaptcha
webapps.pastebin
webapps.planet
webapps.wiki
allow-edit-profile
allow-deactivation ;
+: <factor-recaptcha> ( responder -- responder' )
+ <recaptcha>
+ "concatenative.org" >>domain
+ "6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
+ "6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key ;
+
: <factor-website> ( -- responder )
factor-website new-dispatcher
URL" /wiki/view/Front Page" <redirect-responder> "" add-responder ;
<factor-website>
<wiki> <login-config> <factor-boilerplate> "wiki" add-responder
<user-admin> <login-config> <factor-boilerplate> "user-admin" add-responder
- <pastebin> <login-config> <factor-boilerplate> "pastebin" add-responder
+ <pastebin> <factor-recaptcha> <login-config> <factor-boilerplate> "pastebin" add-responder
<planet> <login-config> <factor-boilerplate> "planet" add-responder
<mason-app> <login-config> "mason" add-responder
"/tmp/docs/" <help-webapp> "docs" add-responder
<wiki> "wiki" add-responder
<user-admin> "user-admin" add-responder
<login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
- <pastebin> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
+ <pastebin> <
factor-recaptcha> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
<mason-app> <login-config> test-db <alloy> "builds.factorcode.org" add-responder
home "docs" append-path <help-webapp> "docs.factorcode.org" add-responder
"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