--- /dev/null
+! Copyright (C) 2010 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.parser summary sequences accessors
+prettyprint ;
+IN: alien.debugger
+
+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 ;
--- /dev/null
+Slava Pestov
+Doug Coleman
+Joe Groff
-! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.parser
-alien.libraries arrays assocs classes combinators
-combinators.short-circuit compiler.units effects grouping
-kernel parser sequences splitting words fry locals lexer
-namespaces summary math vocabs.parser ;
+USING: accessors alien alien.c-types alien.libraries arrays
+assocs classes combinators combinators.short-circuit
+compiler.units effects grouping kernel parser sequences
+splitting words fry locals lexer namespaces summary math
+vocabs.parser ;
IN: alien.parser
: parse-c-type-name ( name -- word )
[ ]
} cleave ;
-: normalize-c-arg ( type name -- type' name' )
- [ length ]
- [
- [ CHAR: * = ] trim-head
- [ length - CHAR: * <array> append ] keep
- ] bi
- [ parse-c-type ] dip ;
-
<PRIVATE
GENERIC: return-type-name ( type -- name )
M: object return-type-name drop "void" ;
M: word return-type-name name>> ;
M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
+
+: parse-pointers ( type name -- type' name' )
+ "*" ?head
+ [ [ <pointer> ] dip parse-pointers ] when ;
+
PRIVATE>
-: parse-arglist ( parameters return -- types effect )
- [
- 2 group [ first2 normalize-c-arg 2array ] map
- unzip [ "," ?tail drop ] map
- ]
- [ [ { } ] [ return-type-name 1array ] if-void ]
- bi* <effect> ;
+: scan-function-name ( -- return function )
+ scan-c-type scan parse-pointers ;
+
+:: (scan-c-args) ( end-marker types names -- )
+ scan :> type-str
+ type-str end-marker = [
+ type-str { "(" ")" } member? [
+ type-str parse-c-type :> type
+ scan "," ?tail drop :> name
+ type name parse-pointers :> ( type' name' )
+ type' types push name' names push
+ ] unless
+ end-marker types names (scan-c-args)
+ ] unless ;
+
+: scan-c-args ( end-marker -- types names )
+ V{ } clone V{ } clone [ (scan-c-args) ] 2keep [ >array ] bi@ ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
-:: make-function ( return library function parameters -- word quot effect )
- return function normalize-c-arg :> ( return function )
- function create-in dup reset-generic
- return library function
- parameters return parse-arglist [ function-quot ] dip ;
+: function-effect ( names return -- effect )
+ [ { } ] [ return-type-name 1array ] if-void <effect> ;
-: parse-arg-tokens ( -- tokens )
- ";" parse-tokens [ "()" subseq? not ] filter ;
+:: make-function ( return function library types names -- word quot effect )
+ function create-in dup reset-generic
+ return library function types function-quot
+ names return function-effect ;
: (FUNCTION:) ( -- word quot effect )
- scan "c-library" get scan parse-arg-tokens make-function ;
-
-: define-function ( return library function parameters -- )
- make-function define-declared ;
+ scan-function-name "c-library" get ";" scan-c-args make-function ;
: callback-quot ( return types abi -- quot )
'[ [ _ _ _ ] dip alien-callback ] ;
-:: make-callback-type ( lib return type-name parameters -- word quot effect )
- return type-name normalize-c-arg :> ( return type-name )
+:: make-callback-type ( lib return type-name types names -- word quot effect )
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
- parameters return parse-arglist :> ( types callback-effect )
- type-word callback-effect "callback-effect" set-word-prop
+ type-word names return function-effect "callback-effect" set-word-prop
type-word lib "callback-library" set-word-prop
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
: (CALLBACK:) ( -- word quot effect )
"c-library" get
- scan scan parse-arg-tokens make-callback-type ;
+ scan-function-name ";" scan-c-args make-callback-type ;
PREDICATE: alien-function-word < word
def>> {
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
-HELP: define-function
-{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
-{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
-{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
-
HELP: C-GLOBAL:
{ $syntax "C-GLOBAL: type name" }
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
: 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
] [
--- /dev/null
+USING: help.markup help.syntax sequences math ;
+IN: bit-sets
+
+ARTICLE: "bit-sets" "Bit sets"
+"The " { $vocab-link "bit-sets" } " vocabulary implements bit-array-backed sets. Bitsets are efficient for implementing relatively dense sets whose members are in a contiguous range of integers starting from 0. One bit is required for each integer in this range in the underlying representation." $nl
+"Bit sets are of the class"
+{ $subsection bit-set }
+"They can be instantiated with the word"
+{ $subsection <bit-set> } ;
+
+ABOUT: "bit-sets"
+
+HELP: bit-set
+{ $class-description "The class of bit-array-based " { $link "sets" } "." } ;
+
+HELP: <bit-set>
+{ $values { "capacity" integer } { "bit-set" bit-set } }
+{ $description "Creates a new bit set with the given capacity. This set is initially empty and can contain as members integers between 0 and " { $snippet "capacity" } "-1." } ;
-USING: bit-sets tools.test bit-arrays ;
+USING: bit-sets tools.test sets kernel bit-arrays ;
IN: bit-sets.tests
-[ ?{ t f t f t f } ] [
- ?{ t f f f t f }
- ?{ f f t f t f } bit-set-union
+[ T{ bit-set f ?{ t f t f t f } } ] [
+ T{ bit-set f ?{ t f f f t f } }
+ T{ bit-set f ?{ f f t f t f } } union
] unit-test
-[ ?{ f f f f t f } ] [
- ?{ t f f f t f }
- ?{ f f t f t f } bit-set-intersect
+[ T{ bit-set f ?{ f f f f t f } } ] [
+ T{ bit-set f ?{ t f f f t f } }
+ T{ bit-set f ?{ f f t f t f } } intersect
] unit-test
-[ ?{ t f t f f f } ] [
- ?{ t t t f f f }
- ?{ f t f f t t } bit-set-diff
+[ T{ bit-set f ?{ t f t f f f } } ] [
+ T{ bit-set f ?{ t t t f f f } }
+ T{ bit-set f ?{ f t f f t t } } diff
] unit-test
+
+[ f ] [
+ T{ bit-set f ?{ t t t f f f } }
+ T{ bit-set f ?{ f t f f t t } } subset?
+] unit-test
+
+[ t ] [
+ T{ bit-set f ?{ t t t f f f } }
+ T{ bit-set f ?{ f t f f f f } } subset?
+] unit-test
+
+[ t ] [
+ { 0 1 2 }
+ T{ bit-set f ?{ f t f f f f } } subset?
+] unit-test
+
+[ f ] [
+ T{ bit-set f ?{ f t f f f f } }
+ T{ bit-set f ?{ t t t f f f } } subset?
+] unit-test
+
+[ f ] [
+ { 1 }
+ T{ bit-set f ?{ t t t f f f } } subset?
+] unit-test
+
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } members ] unit-test
+
+[ t V{ 1 2 3 } ] [
+ { 1 2 } 5 <bit-set> set-like
+ [ bit-set? ] keep
+ 3 over adjoin
+ members
+] unit-test
+
+[ V{ 0 1 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap adjoin ] keep members ] unit-test
+[ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap adjoin ] keep members ] must-fail
+[ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap adjoin ] keep members ] must-fail
+
+[ V{ 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 0 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 1 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ 9 swap delete ] keep members ] unit-test
+[ V{ 0 2 5 } ] [ T{ bit-set f ?{ t f t f f t } } clone [ "foo" swap delete ] keep members ] unit-test
+
+[ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ]
+[ 1 <bit-set> dup clone 0 over adjoin ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
+USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ;
IN: bit-sets
+TUPLE: bit-set { table bit-array read-only } ;
+
+: <bit-set> ( capacity -- bit-set )
+ <bit-array> bit-set boa ;
+
+INSTANCE: bit-set set
+
+M: bit-set in?
+ over integer? [ table>> ?nth ] [ 2drop f ] if ; inline
+
+M: bit-set adjoin
+ ! This is allowed to crash when the elt couldn't go in the set
+ [ t ] 2dip table>> set-nth ;
+
+M: bit-set delete
+ ! This isn't allowed to crash if the elt wasn't in the set
+ over integer? [
+ table>> 2dup bounds-check? [
+ [ f ] 2dip set-nth
+ ] [ 2drop ] if
+ ] [ 2drop ] if ;
+
+! If you do binary set operations with a bitset, it's expected
+! that the other thing can also be represented as a bitset
+! of the same length.
<PRIVATE
+ERROR: check-bit-set-failed ;
+
+: check-bit-set ( bit-set -- bit-set )
+ dup bit-set? [ check-bit-set-failed ] unless ; inline
+
: bit-set-map ( seq1 seq2 quot -- seq )
[ 2drop length>> ]
[
] dip 2map
] 3bi bit-array boa ; inline
+: (bit-set-op) ( set1 set2 -- table1 table2 )
+ [ set-like ] keep [ table>> ] bi@ ; inline
+
+: bit-set-op ( set1 set2 quot: ( a b -- c ) -- bit-set )
+ [ (bit-set-op) ] dip bit-set-map bit-set boa ; inline
+
PRIVATE>
-: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
+M: bit-set union
+ [ bitor ] bit-set-op ;
-HINTS: bit-set-union bit-array bit-array ;
+M: bit-set intersect
+ [ bitand ] bit-set-op ;
-: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
+M: bit-set diff
+ [ bitnot bitand ] bit-set-op ;
-HINTS: bit-set-intersect bit-array bit-array ;
+M: bit-set subset?
+ [ intersect ] keep = ;
-: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
+M: bit-set members
+ [ table>> length iota ] keep [ in? ] curry filter ;
+
+<PRIVATE
+
+: bit-set-like ( set bit-set -- bit-set' )
+ ! This crashes if there are keys that can't be put in the bit set
+ over bit-set? [ 2dup [ table>> length ] bi@ = ] [ f ] if
+ [ drop ] [
+ [ members ] dip table>> length <bit-set>
+ [ [ adjoin ] curry each ] keep
+ ] if ;
+
+PRIVATE>
-HINTS: bit-set-diff bit-array bit-array ;
+M: bit-set set-like
+ bit-set-like check-bit-set ; inline
-: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;
\ No newline at end of file
+M: bit-set clone
+ table>> clone bit-set boa ;
"prettyprint" vocab [
"stack-checker.errors.prettyprint" require
"alien.prettyprint" require
+ "alien.debugger" require
] when
"cpu." cpu name>> append require
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
-GENERIC: year ( obj -- n )
-M: integer year ;
-M: timestamp year year>> ;
-
-GENERIC: month ( obj -- n )
-M: integer month ;
-M: timestamp month month>> ;
-
-GENERIC: day ( obj -- n )
-M: integer day ;
-M: timestamp day day>> ;
-
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: math math.order math.parser math.functions kernel\r
-sequences io accessors arrays io.streams.string splitting\r
-combinators calendar calendar.format.macros present ;\r
+USING: accessors arrays calendar calendar.format.macros\r
+combinators io io.streams.string kernel math math.functions\r
+math.order math.parser present sequences typed ;\r
IN: calendar.format\r
\r
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;\r
: (timestamp>ymd) ( timestamp -- )\r
{ YYYY "-" MM "-" DD } formatted ;\r
\r
-: timestamp>ymd ( timestamp -- str )\r
+TYPED: timestamp>ymd ( timestamp: timestamp -- str )\r
[ (timestamp>ymd) ] with-string-writer ;\r
\r
: (timestamp>hms) ( timestamp -- )\r
{ hh ":" mm ":" ss } formatted ;\r
\r
-: timestamp>hms ( timestamp -- str )\r
+TYPED: timestamp>hms ( timestamp: timestamp -- str )\r
[ (timestamp>hms) ] with-string-writer ;\r
\r
-: timestamp>ymdhms ( timestamp -- str )\r
+TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )\r
[\r
>gmt\r
{ (timestamp>ymd) " " (timestamp>hms) } formatted\r
<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
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data alien.syntax ascii
-assocs byte-arrays classes.struct classes.tuple.private classes.tuple
-combinators compiler.tree.debugger compiler.units destructors
-io.encodings.utf8 io.pathnames io.streams.string kernel libc
-literals math mirrors namespaces prettyprint
-prettyprint.config see sequences specialized-arrays system
+assocs byte-arrays classes.struct classes.tuple.parser
+classes.tuple.private classes.tuple combinators compiler.tree.debugger
+compiler.units destructors io.encodings.utf8 io.pathnames
+io.streams.string kernel libc literals math mirrors namespaces
+prettyprint prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts generic.single classes ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
"struct-class-test-1" parse-stream
] [ error>> error>> unexpected-eof? ] must-fail-with
+[
+ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x uint } ;" eval( -- )
+] [ error>> duplicate-slot-names? ] must-fail-with
+
+[
+ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: struct-test-duplicate-slots { x uint } { x float } ;" eval( -- )
+] [ error>> duplicate-slot-names? ] must-fail-with
+
! S{ with non-struct type
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
} case ;
: parse-struct-definition ( -- class slots )
- CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+ CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array
+ dup [ name>> ] map check-duplicate-slots ;
PRIVATE>
SYNTAX: STRUCT:
@
] 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
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.representations.preferred ;
+FROM: namespaces => set ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
histories get
values [
values [ [ store? ] filter [ insn#>> ] map ] map concat
- ] map concat unique
+ ] map concat fast-set
live-stores set ;
GENERIC: eliminate-dead-stores* ( insn -- insn' )
: (eliminate-dead-stores) ( insn -- insn' )
dup insn-slot# [
- insn# get live-stores get key? [
+ insn# get live-stores get in? [
drop f
] unless
] when ;
: 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 ;
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sets kernel namespaces sequences
+USING: accessors assocs kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
-compiler.cfg.rpo compiler.cfg.predecessors ;
+compiler.cfg.rpo compiler.cfg.predecessors hash-sets sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
SYMBOL: live-vregs
: live-vreg? ( vreg -- ? )
- live-vregs get key? ;
+ live-vregs get in? ;
! vregs which are the result of an allocation
SYMBOL: allocations
: allocation? ( vreg -- ? )
- allocations get key? ;
+ allocations get in? ;
: init-dead-code ( -- )
H{ } clone liveness-graph set
- H{ } clone live-vregs set
- H{ } clone allocations set ;
+ HS{ } clone live-vregs set
+ HS{ } clone allocations set ;
GENERIC: build-liveness-graph ( insn -- )
dup src>> setter-liveness-graph ;
M: ##allot build-liveness-graph
- [ dst>> allocations get conjoin ] [ call-next-method ] bi ;
+ [ dst>> allocations get adjoin ] [ call-next-method ] bi ;
M: insn build-liveness-graph
dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
: (record-live) ( vregs -- )
[
- dup live-vregs get key? [ drop ] [
- [ live-vregs get conjoin ]
+ dup live-vreg? [ drop ] [
+ [ live-vregs get adjoin ]
[ liveness-graph get at (record-live) ]
bi
] if
namespaces quotations sequences sets slots words
compiler.cfg.instructions compiler.cfg.instructions.syntax
compiler.cfg.rpo ;
+FROM: namespaces => set ;
+FROM: sets => members ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
cfg [| block |
block instructions>> [
dup ##phi?
- [ inputs>> [ use conjoin-at ] assoc-each ]
- [ uses-vregs [ block swap use conjoin-at ] each ]
+ [ inputs>> [ use adjoin-at ] assoc-each ]
+ [ uses-vregs [ block swap use adjoin-at ] each ]
if
] each
] each-basic-block
- use [ keys ] assoc-map uses set ;
+ use [ members ] assoc-map uses set ;
USING: accessors assocs combinators sets math fry kernel math.order
dlists deques vectors namespaces sequences sorting locals
compiler.cfg.rpo compiler.cfg.predecessors ;
+FROM: namespaces => set ;
IN: compiler.cfg.dominance
! Reference:
[ accum push ]
[ dom-children work-list push-all-front ] bi
] slurp-deque
- accum ;
\ No newline at end of file
+ accum ;
combinators.short-circuit compiler.cfg.builder.blocks
compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.stacks.local compiler.tree.propagation.info
+compiler.cfg.instructions
cpu.architecture effects fry generalizations
-kernel locals macros math namespaces quotations sequences
+kernel locals macros make math namespaces quotations sequences
splitting stack-checker words ;
IN: compiler.cfg.intrinsics.simd.backend
! Selection of implementation based on available CPU instructions
-: can-has? ( quot -- ? )
- [ t \ can-has? ] dip '[ @ drop \ can-has? get ] with-variable ; inline
-
-: can-has-rep? ( rep reps -- )
- member? \ can-has? [ and ] change ; inline
-
-GENERIC: create-can-has ( word -- word' )
-
-PREDICATE: hat-word < word
- {
- [ name>> { [ "^" head? ] [ "##" head? ] } 1|| ]
- [ vocabulary>> { "compiler.cfg.intrinsics.simd" "compiler.cfg.hats" } member? ]
- } 1&& ;
-
-PREDICATE: vector-op-word < hat-word
- name>> "-vector" swap subseq? ;
-
-: reps-word ( word -- word' )
- name>> "^^" ?head drop "##" ?head drop
- "%" "-reps" surround "cpu.architecture" lookup ;
-
-SYMBOL: blub
-
-:: can-has-^^-quot ( word def effect -- quot )
- effect in>> { "rep" } split1 [ length ] bi@ 1 +
- word reps-word 1quotation
- effect out>> length blub <array> >quotation
- '[ [ _ ndrop ] _ ndip @ can-has-rep? @ ] ;
-
-:: can-has-^-quot ( word def effect -- quot )
- def create-can-has first ;
-
-: map-concat-like ( seq quot -- seq' )
- '[ _ map ] [ concat-as ] bi ; inline
-
-M: object create-can-has 1quotation ;
-
-M: array create-can-has
- [ create-can-has ] map-concat-like 1quotation ;
-M: callable create-can-has
- [ create-can-has ] map-concat-like 1quotation ;
-
-: (can-has-word) ( word -- word' )
- name>> "can-has-" prepend "compiler.cfg.intrinsics.simd.backend" lookup ;
-
-: (can-has-quot) ( word -- quot )
- [ ] [ def>> ] [ stack-effect ] tri {
- { [ pick name>> "^^" head? ] [ can-has-^^-quot ] }
- { [ pick name>> "##" head? ] [ can-has-^^-quot ] }
- { [ pick name>> "^" head? ] [ can-has-^-quot ] }
- } cond ;
-
-: (can-has-nop-quot) ( word -- quot )
- stack-effect in>> length '[ _ ndrop blub ] ;
-
-DEFER: can-has-words
-
-M: word create-can-has
- can-has-words ?at drop 1quotation ;
-
-M: hat-word create-can-has
- (can-has-nop-quot) ;
-
-M: vector-op-word create-can-has
- dup (can-has-word) [ 1quotation ] [ (can-has-quot) ] ?if ;
-
-GENERIC# >can-has-cond 2 ( quot #pick #dup -- quotpair )
-M:: callable >can-has-cond ( quot #pick #dup -- quotpair )
- #dup quot create-can-has '[ _ ndup @ can-has? ] quot 2array ;
-
-M:: pair >can-has-cond ( pair #pick #dup -- quotpair )
+GENERIC: insn-available? ( ## -- reps )
+
+M: object insn-available? drop t ;
+
+M: ##zero-vector insn-available? rep>> %zero-vector-reps member? ;
+M: ##fill-vector insn-available? rep>> %fill-vector-reps member? ;
+M: ##gather-vector-2 insn-available? rep>> %gather-vector-2-reps member? ;
+M: ##gather-vector-4 insn-available? rep>> %gather-vector-4-reps member? ;
+M: ##alien-vector insn-available? rep>> %alien-vector-reps member? ;
+M: ##shuffle-vector insn-available? rep>> %shuffle-vector-reps member? ;
+M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
+M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
+M: ##merge-vector-tail insn-available? rep>> %merge-vector-reps member? ;
+M: ##signed-pack-vector insn-available? rep>> %signed-pack-vector-reps member? ;
+M: ##unsigned-pack-vector insn-available? rep>> %unsigned-pack-vector-reps member? ;
+M: ##unpack-vector-head insn-available? rep>> %unpack-vector-head-reps member? ;
+M: ##unpack-vector-tail insn-available? rep>> %unpack-vector-tail-reps member? ;
+M: ##tail>head-vector insn-available? rep>> %unpack-vector-head-reps member? ;
+M: ##integer>float-vector insn-available? rep>> %integer>float-vector-reps member? ;
+M: ##float>integer-vector insn-available? rep>> %float>integer-vector-reps member? ;
+M: ##compare-vector insn-available? [ rep>> ] [ cc>> ] bi %compare-vector-reps member? ;
+M: ##test-vector insn-available? rep>> %test-vector-reps member? ;
+M: ##add-vector insn-available? rep>> %add-vector-reps member? ;
+M: ##saturated-add-vector insn-available? rep>> %saturated-add-vector-reps member? ;
+M: ##add-sub-vector insn-available? rep>> %add-sub-vector-reps member? ;
+M: ##sub-vector insn-available? rep>> %sub-vector-reps member? ;
+M: ##saturated-sub-vector insn-available? rep>> %saturated-sub-vector-reps member? ;
+M: ##mul-vector insn-available? rep>> %mul-vector-reps member? ;
+M: ##mul-high-vector insn-available? rep>> %mul-high-vector-reps member? ;
+M: ##mul-horizontal-add-vector insn-available? rep>> %mul-horizontal-add-vector-reps member? ;
+M: ##saturated-mul-vector insn-available? rep>> %saturated-mul-vector-reps member? ;
+M: ##div-vector insn-available? rep>> %div-vector-reps member? ;
+M: ##min-vector insn-available? rep>> %min-vector-reps member? ;
+M: ##max-vector insn-available? rep>> %max-vector-reps member? ;
+M: ##avg-vector insn-available? rep>> %avg-vector-reps member? ;
+M: ##dot-vector insn-available? rep>> %dot-vector-reps member? ;
+M: ##sad-vector insn-available? rep>> %sad-vector-reps member? ;
+M: ##sqrt-vector insn-available? rep>> %sqrt-vector-reps member? ;
+M: ##horizontal-add-vector insn-available? rep>> %horizontal-add-vector-reps member? ;
+M: ##horizontal-sub-vector insn-available? rep>> %horizontal-sub-vector-reps member? ;
+M: ##abs-vector insn-available? rep>> %abs-vector-reps member? ;
+M: ##and-vector insn-available? rep>> %and-vector-reps member? ;
+M: ##andn-vector insn-available? rep>> %andn-vector-reps member? ;
+M: ##or-vector insn-available? rep>> %or-vector-reps member? ;
+M: ##xor-vector insn-available? rep>> %xor-vector-reps member? ;
+M: ##not-vector insn-available? rep>> %not-vector-reps member? ;
+M: ##shl-vector insn-available? rep>> %shl-vector-reps member? ;
+M: ##shr-vector insn-available? rep>> %shr-vector-reps member? ;
+M: ##shl-vector-imm insn-available? rep>> %shl-vector-imm-reps member? ;
+M: ##shr-vector-imm insn-available? rep>> %shr-vector-imm-reps member? ;
+M: ##horizontal-shl-vector-imm insn-available? rep>> %horizontal-shl-vector-imm-reps member? ;
+M: ##horizontal-shr-vector-imm insn-available? rep>> %horizontal-shr-vector-imm-reps member? ;
+
+: [vector-op-checked] ( #dup quot -- quot )
+ '[ _ ndup [ @ ] { } make dup [ insn-available? ] all? ] ;
+
+GENERIC# >vector-op-cond 2 ( quot #pick #dup -- quotpair )
+M:: callable >vector-op-cond ( quot #pick #dup -- quotpair )
+ #dup quot [vector-op-checked] '[ 2drop @ ]
+ #dup '[ % _ nnip ]
+ 2array ;
+
+M:: pair >vector-op-cond ( pair #pick #dup -- quotpair )
pair first2 :> ( class quot )
- #pick class #dup quot create-can-has
- '[ _ npick _ instance? [ _ ndup @ can-has? ] dip and ]
- quot 2array ;
+ #pick class #dup quot [vector-op-checked]
+ '[ 2drop _ npick _ instance? _ [ f f f ] if ]
+ #dup '[ % _ nnip ]
+ 2array ;
MACRO: v-vector-op ( trials -- )
- [ 1 2 >can-has-cond ] map '[ _ cond ] ;
+ [ 1 2 >vector-op-cond ] map '[ f f _ cond ] ;
MACRO: vl-vector-op ( trials -- )
- [ 1 3 >can-has-cond ] map '[ _ cond ] ;
+ [ 1 3 >vector-op-cond ] map '[ f f _ cond ] ;
MACRO: vv-vector-op ( trials -- )
- [ 1 3 >can-has-cond ] map '[ _ cond ] ;
+ [ 1 3 >vector-op-cond ] map '[ f f _ cond ] ;
MACRO: vv-cc-vector-op ( trials -- )
- [ 2 4 >can-has-cond ] map '[ _ cond ] ;
+ [ 2 4 >vector-op-cond ] map '[ f f _ cond ] ;
MACRO: vvvv-vector-op ( trials -- )
- [ 1 5 >can-has-cond ] map '[ _ cond ] ;
-
-! Special-case conditional instructions
-
-: can-has-^(compare-vector) ( src1 src2 rep cc -- dst )
- [ 2drop ] 2dip %compare-vector-reps member?
- \ can-has? [ and ] change
- blub ;
-
-: can-has-^^test-vector ( src rep vcc -- dst )
- [ drop ] 2dip drop %test-vector-reps member?
- \ can-has? [ and ] change
- blub ;
-
-MACRO: can-has-case ( cases -- )
- dup first second inputs 1 +
- '[ _ ndrop f ] suffix '[ _ case ] ;
-
-GENERIC# >can-has-trial 1 ( obj #pick -- quot )
-
-M: callable >can-has-trial
- drop '[ _ can-has? ] ;
-M: pair >can-has-trial
- swap first2 dup inputs
- '[ _ npick _ instance? [ _ can-has? ] [ _ ndrop blub ] if ] ;
-
-MACRO: can-has-vector-op ( trials #pick #dup -- )
- [ '[ _ >can-has-trial ] map ] dip '[ _ _ n|| \ can-has? [ and ] change blub ] ;
-
-: can-has-v-vector-op ( trials -- ? )
- 1 2 can-has-vector-op ; inline
-: can-has-vv-vector-op ( trials -- ? )
- 1 3 can-has-vector-op ; inline
-: can-has-vv-cc-vector-op ( trials -- ? )
- 2 4 can-has-vector-op ; inline
-: can-has-vvvv-vector-op ( trials -- ? )
- 1 5 can-has-vector-op ; inline
-
-CONSTANT: can-has-words
- H{
- { case can-has-case }
- { v-vector-op can-has-v-vector-op }
- { vl-vector-op can-has-vv-vector-op }
- { vv-vector-op can-has-vv-vector-op }
- { vv-cc-vector-op can-has-vv-cc-vector-op }
- { vvvv-vector-op can-has-vvvv-vector-op }
- }
+ [ 1 5 >vector-op-cond ] map '[ f f _ cond ] ;
! Intrinsic code emission
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
+FROM: namespaces => set ;
IN: compiler.cfg.linear-scan.assignment
! This contains both active and inactive intervals; any interval
USING: accessors kernel sequences sets arrays math strings fry
namespaces prettyprint compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
+FROM: namespaces => set ;
IN: compiler.cfg.linear-scan.debugger
: check-linear-scan ( live-intervals machine-registers -- )
-IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals
math.order grouping strings strings.private classes layouts
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.debugger ;
+FROM: namespaces => set ;
+IN: compiler.cfg.linear-scan.tests
check-allocation? on
check-numbering? on
: 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
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs deques dlists kernel make sorting
namespaces sequences combinators combinators.short-circuit
-fry math sets compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection compiler.cfg.predecessors ;
+fry math compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg.loop-detection compiler.cfg.predecessors
+sets hash-sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.linearization.order
! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
SYMBOLS: work-list loop-heads visited ;
-: visited? ( bb -- ? ) visited get key? ;
+: visited? ( bb -- ? ) visited get in? ;
: add-to-work-list ( bb -- )
- dup visited get key? [ drop ] [
+ dup visited? [ drop ] [
work-list get push-back
] if ;
: init-linearization-order ( cfg -- )
<dlist> work-list set
- H{ } clone visited set
+ HS{ } clone visited set
entry>> add-to-work-list ;
: (find-alternate-loop-head) ( bb -- bb' )
: process-block ( bb -- )
dup visited? [ drop ] [
[ , ]
- [ visited get conjoin ]
+ [ visited get adjoin ]
[ sorted-successors [ process-successor ] each ]
tri
] if ;
dup linear-order>> [ ] [
dup (linearization-order)
>>linear-order linear-order>>
- ] ?if ;
\ No newline at end of file
+ ] ?if ;
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities
compiler.cfg.predecessors ;
+FROM: namespaces => set ;
IN: compiler.cfg.liveness.ssa
! TODO: merge with compiler.cfg.liveness
: live-in? ( vreg bb -- ? ) live-in key? ;
-: live-out? ( vreg bb -- ? ) live-out key? ;
\ No newline at end of file
+: live-out? ( vreg bb -- ? ) live-out key? ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators deques dlists fry kernel
namespaces sequences sets compiler.cfg compiler.cfg.predecessors ;
+FROM: namespaces => set ;
IN: compiler.cfg.loop-detection
TUPLE: natural-loop header index ends blocks ;
compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
compiler.cfg.instructions compiler.cfg.def-use ;
FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
+FROM: namespaces => set ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )
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 ] [
[
compiler.cfg.loop-detection
compiler.cfg.renaming.functor
compiler.cfg.representations.preferred ;
+FROM: namespaces => set ;
IN: compiler.cfg.representations
! Virtual register representation selection.
: 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 ]
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences sets
assocs fry compiler.cfg compiler.cfg.instructions ;
+FROM: namespaces => set ;
IN: compiler.cfg.rpo
SYMBOL: visited
[ drop basic-block set ]
[ change-instructions drop ] 2bi ; inline
-: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
+: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
dupd '[ _ optimize-basic-block ] each-basic-block ; inline
: needs-post-order ( cfg -- cfg' )
- dup post-order drop ;
\ No newline at end of file
+ dup post-order drop ;
compiler.cfg.renaming
compiler.cfg.renaming.functor
compiler.cfg.ssa.construction.tdmsc ;
+FROM: namespaces => set ;
IN: compiler.cfg.ssa.construction
! The phi placement algorithm is implemented in
] [ 2drop ] if ;
: compute-phi-nodes-for ( vreg bbs -- )
- keys [ insert-phi-node-later ] with merge-set-each ;
+ keys merge-set [ insert-phi-node-later ] with each ;
: compute-phi-nodes ( -- )
H{ } clone inserting-phi-nodes set
[ compute-defs compute-phi-nodes insert-phi-nodes ]
[ rename ]
[ ]
- } cleave ;
\ No newline at end of file
+ } cleave ;
compiler.cfg.dominance compiler.cfg.predecessors
compiler.cfg.ssa.construction.tdmsc kernel namespaces sequences
tools.test vectors sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.ssa.construction.tdmsc.tests
: test-tdmsc ( -- )
[ ] [ test-tdmsc ] unit-test
[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test
-[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test
\ No newline at end of file
+[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test
USING: accessors arrays assocs bit-arrays bit-sets fry
hashtables hints kernel locals math namespaces sequences sets
compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
+FROM: namespaces => set ;
IN: compiler.cfg.ssa.construction.tdmsc
! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
SYMBOLS: visited merge-sets levels again? ;
: init-merge-sets ( cfg -- )
- post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
+ post-order dup length '[ _ <bit-set> ] H{ } map>assoc merge-sets set ;
: compute-levels ( cfg -- )
0 over entry>> associate [
: level ( bb -- n ) levels get at ; inline
-: set-bit ( bit-array n -- )
- [ t ] 2dip swap set-nth ;
-
: update-merge-set ( tmp to -- )
[ merge-sets get ] dip
'[
_
- [ merge-sets get at bit-set-union ]
- [ dupd number>> set-bit ]
+ [ merge-sets get at union ]
+ [ number>> over adjoin ]
bi
] change-at ;
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
-: visited? ( pair -- ? ) visited get key? ;
+: visited? ( pair -- ? ) visited get in? ;
: consistent? ( snode lnode -- ? )
- [ merge-sets get at ] bi@ swap bit-set-subset? ;
+ [ merge-sets get at ] bi@ subset? ;
: (process-edge) ( from to -- )
f walk [
: process-edge ( from to -- )
2dup 2array dup visited? [ 3drop ] [
- visited get conjoin
+ visited get adjoin
(process-edge)
] if ;
[ process-edge ] each-incoming-j-edge ;
: compute-merge-set-step ( bfo -- )
- visited get clear-assoc
+ HS{ } clone visited set
[ process-block ] each ;
: compute-merge-set-loop ( cfg -- )
loop ;
: (merge-set) ( bbs -- flags rpo )
- merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
+ merge-sets get '[ _ at ] [ union ] map-reduce
cfg get reverse-post-order ; inline
-: filter-by ( flags seq -- seq' )
- [ drop ] selector [ 2each ] dip ;
-
-HINTS: filter-by { bit-array object } ;
-
PRIVATE>
: compute-merge-sets ( cfg -- )
needs-dominance
- H{ } clone visited set
[ compute-levels ]
[ init-merge-sets ]
[ compute-merge-set-loop ]
tri ;
-: merge-set-each ( bbs quot: ( bb -- ) -- )
- [ (merge-set) ] dip '[
- swap _ [ drop ] if
- ] 2each ; inline
-
: merge-set ( bbs -- bbs' )
- (merge-set) filter-by ;
+ (merge-set) [ members ] dip nths ;
compiler.cfg.ssa.interference.live-ranges
compiler.cfg.utilities
compiler.utilities ;
+FROM: namespaces => set ;
IN: compiler.cfg.ssa.destruction
! Maps vregs to leaders.
compiler.cfg.dominance
compiler.cfg.def-use
compiler.cfg.instructions ;
+FROM: namespaces => set ;
IN: compiler.cfg.ssa.liveness
! Liveness checking on SSA IR, as described in
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 ;
compiler.cfg.registers
compiler.cfg.stacks.height
compiler.cfg.parallel-copy ;
+FROM: namespaces => set ;
IN: compiler.cfg.stacks.local
! Local stack analysis. We build three sets for every basic block
: peek-set ( bb -- assoc ) peek-sets get at ;
: replace-set ( bb -- assoc ) replace-sets get at ;
-: kill-set ( bb -- assoc ) kill-sets get at ;
\ No newline at end of file
+: kill-set ( bb -- assoc ) kill-sets get at ;
: 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
USING: accessors assocs combinators.short-circuit
compiler.cfg.instructions compiler.cfg.rpo kernel namespaces
sequences sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.write-barrier
SYMBOL: fresh-allocations
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make math math.order math.parser sequences accessors
-kernel kernel.private layouts assocs words summary arrays
-combinators classes.algebra alien alien.c-types
-alien.strings alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes classes.struct locals
-source-files.errors slots parser generic.parser strings
+USING: namespaces make math math.order math.parser sequences
+accessors kernel layouts assocs words summary arrays combinators
+classes.algebra alien alien.private alien.c-types alien.strings
+alien.arrays alien.complex alien.libraries sets libc
+continuations.private fry cpu.architecture classes
+classes.struct locals source-files.errors slots parser
+generic.parser strings quotations
compiler.errors
compiler.alien
compiler.constants
compiler.cfg.builder
compiler.codegen.fixup
compiler.utilities ;
+FROM: namespaces => set ;
IN: compiler.codegen
SYMBOL: insn-counts
box-parameters
] with-param-regs ;
-TUPLE: callback-context ;
-
-: current-callback ( -- id ) 2 special-object ;
-
-: wait-to-return ( token -- )
- dup current-callback eq? [
- drop
- ] [
- yield-hook get call( -- ) wait-to-return
- ] if ;
-
-: do-callback ( quot token -- )
- init-catchstack
- [ 2 set-special-object call ] keep
- wait-to-return ; inline
-
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup void? ] [ drop [ ] ] }
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
- [
- [ callback-prep-quot ]
- [ quot>> ]
- [ callback-return-quot ] tri 3append ,
- [ callback-context new do-callback ] %
- ] [ ] make ;
+ [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
+ yield-hook get
+ '[ _ _ do-callback ]
+ >quotation ;
M: ##alien-callback generate-insn
params>>
: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
-[ t ] [
- namestack*
- 3 "x" set callback-3 callback_test_1
- namestack* eq?
-] unit-test
-
-[ 5 ] [
+[ t 3 5 ] [
[
- 3 "x" set callback-3 callback_test_1 "x" get
+ namestack*
+ 3 "x" set callback-3 callback_test_1
+ namestack* eq?
+ "x" get "x" get-global
] with-scope
] unit-test
-: callback-4 ( -- callback )
- void { } "cdecl" [ "Hello world" write ] alien-callback
- gc ;
-
-[ "Hello world" ] [
- [ callback-4 callback_test_1 ] with-string-writer
-] unit-test
-
: callback-5 ( -- callback )
void { } "cdecl" [ gc ] alien-callback ;
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>>
] [
compiler.tree.def-use
compiler.tree.recursive
compiler.tree.combinators ;
+FROM: namespaces => set ;
IN: compiler.tree.checker
! Check some invariants; this can help catch compiler bugs.
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 ;
arrays combinators columns stack-checker.backend
stack-checker.branches compiler.tree compiler.tree.combinators
compiler.tree.dead-code.liveness compiler.tree.dead-code.simple ;
+FROM: namespaces => set ;
IN: compiler.tree.dead-code.branches
M: #if mark-live-values* look-at-inputs ;
[ ] [ [ [ 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
dlists kernel sequences compiler.utilities words sets
stack-checker.branches compiler.tree compiler.tree.def-use
compiler.tree.combinators ;
+FROM: namespaces => set ;
IN: compiler.tree.dead-code.liveness
SYMBOL: work-list
stack-checker.branches
compiler.tree
compiler.tree.combinators ;
+FROM: namespaces => set ;
+FROM: sets => members ;
IN: compiler.tree.def-use
SYMBOL: def-use
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
-M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
+M: #phi node-uses-values phi-in-d>> concat remove-bottom members ;
M: #declare node-uses-values drop f ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel fry vectors accessors namespaces assocs sets
stack-checker.branches compiler.tree compiler.tree.def-use ;
+FROM: namespaces => set ;
IN: compiler.tree.def-use.simplified
! Simplified def-use follows chains of copies.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.values ;
+FROM: namespaces => set ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to classes. Only for #introduce outputs
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 -- )
compiler.tree.def-use
compiler.tree.def-use.simplified
compiler.tree.late-optimizations ;
+FROM: namespaces => set ;
IN: compiler.tree.modular-arithmetic
! This is a late-stage optimization.
[ 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* ;
sets combinators.short-circuit sequences.private locals growable
stack-checker namespaces compiler.tree.propagation.info ;
FROM: math => float ;
+FROM: sets => set ;
IN: compiler.tree.propagation.transforms
\ equal? [
in-d>> first value-info literal>> {
{ V{ } [ [ drop { } 0 vector boa ] ] }
{ H{ } [ [ drop 0 <hashtable> ] ] }
+ { HS{ } [ [ drop f fast-set ] ] }
[ drop f ]
} case
] "custom-inlining" set-word-prop
[ drop f ] swap
[ literalize [ t ] ] { } map>assoc linear-case-quot
] [
- unique [ key? ] curry
+ tester
] if ;
\ member? [
\ at* [ at-quot ] 1 define-partial-eval
: diff-quot ( seq -- quot: ( seq' -- seq'' ) )
- tester '[ [ @ not ] filter ] ;
+ tester '[ [ [ @ not ] filter ] keep set-like ] ;
-\ diff [ diff-quot ] 1 define-partial-eval
+M\ set diff [ diff-quot ] 1 define-partial-eval
: intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
- tester '[ _ filter ] ;
+ tester '[ [ _ filter ] keep set-like ] ;
-\ intersect [ intersect-quot ] 1 define-partial-eval
+M\ set intersect [ intersect-quot ] 1 define-partial-eval
: fixnum-bits ( -- n )
cell-bits tag-bits get - ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs arrays namespaces accessors sequences deques fry
search-deques dlists combinators.short-circuit make sets compiler.tree ;
+FROM: namespaces => set ;
IN: compiler.tree.recursive
TUPLE: call-site tail? node label ;
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
<PRIVATE
-: ((reset-timer)) ( timer counter timestamp -- )
- nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
+: (reset-timer) ( timer timestamp -- )
+ >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
-: nano-count>timestamp ( x -- timestamp )
- nano-count - nanoseconds now time+ ;
-
-: (reset-timer) ( timer counter -- )
- yield {
- { [ dup 0 = ] [ now ((reset-timer)) ] }
- { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] }
- { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
- [ sleep-queue heap-peek nip nano-count>timestamp ((reset-timer)) ]
- } cond ;
+: nano-count>micros ( x -- n )
+ nano-count - 1,000 /f system-micros + ;
: reset-timer ( timer -- )
- 10 (reset-timer) ;
+ {
+ { [ 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) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar alien.c-types alien.syntax ;
+USING: calendar math alien.c-types alien.syntax memoize system ;
IN: core-foundation.time
TYPEDEF: double CFTimeInterval
: >CFTimeInterval ( duration -- interval )
duration>seconds ; inline
-: >CFAbsoluteTime ( timestamp -- time )
- T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
- duration>seconds ; inline
+MEMO: epoch ( -- micros )
+ T{ timestamp { year 2001 } { month 1 } { day 1 } } timestamp>micros ;
+
+: >CFAbsoluteTime ( micros -- time )
+ epoch - 1,000,000 /f ; inline
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax system math kernel calendar
core-foundation core-foundation.time ;
) ;
: <CFTimer> ( callback -- timer )
- [ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
+ [ f system-micros >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
FUNCTION: void CFRunLoopTimerInvalidate (
CFRunLoopTimerRef timer
USING: help.syntax help.markup kernel prettyprint sequences
-io.pathnames ;
+io.pathnames strings ;
IN: csv
HELP: csv
}
{ $description "Writes a comma-separated-value structure to a file." } ;
+HELP: string>csv
+{ $values
+ { "string" string }
+ { "csv" "csv" }
+}
+{ $description "Parses a string into a sequence of comma-separated-value fields." } ;
+
+HELP: csv>string
+{ $values
+ { "csv" "csv" }
+ { "string" string }
+}
+{ $description "Writes a comma-separated-value structure to a string." } ;
+
HELP: csv-row
{ $values { "stream" "an input stream" }
{ "row" "an array of fields" } }
{ $subsections file>csv }
"Writing a csv file:"
{ $subsections csv>file }
+"Reading a string to csv:"
+{ $subsections string>csv }
+"Writing csv to a string:"
+{ $subsections csv>string }
"Changing the delimiter from a comma:"
{ $subsections with-delimiter }
"Reading from a stream:"
! Copyright (C) 2007, 2008 Phil Dawes
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences io namespaces make combinators
-unicode.categories io.files combinators.short-circuit ;
+unicode.categories io.files combinators.short-circuit
+io.streams.string ;
IN: csv
SYMBOL: delimiter
[ [ (csv) ] { } make ] with-input-stream
dup last { "" } = [ but-last ] when ;
+: string>csv ( string -- csv )
+ <string-reader> csv ;
+
: file>csv ( path encoding -- csv )
<file-reader> csv ;
: write-row ( row -- )
[ delimiter get write1 ]
[ escape-if-required write ] interleave nl ; inline
+
+<PRIVATE
+
+: (write-csv) ( rows -- )
+ [ write-row ] each ;
+PRIVATE>
+
: write-csv ( rows stream -- )
- [ [ write-row ] each ] with-output-stream ;
+ [ (write-csv) ] with-output-stream ;
+: csv>string ( csv -- string )
+ [ (write-csv) ] with-string-writer ;
+
: csv>file ( rows path encoding -- ) <file-writer> write-csv ;
! 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 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
char>> 1string print ;
! Protocols
<PRIVATE
-: cross-2each ( seq1 seq2 quot -- )
- [ with each ] 2curry each ; inline
-
: forget-all-methods ( classes words -- )
- [ first method forget ] cross-2each ;
+ [ first method forget ] cartesian-each ;
: protocol-users ( protocol -- users )
protocol-consult keys ;
: add-new-definitions ( protocol wordlist -- )
[ drop protocol-consult values ] [ added-words ] 2bi
- [ swap consult-method ] cross-2each ;
+ [ swap consult-method ] cartesian-each ;
: initialize-protocol-props ( protocol wordlist -- )
[
M: protocol group-words protocol-words ;
SYNTAX: SLOT-PROTOCOL:
- CREATE-WORD ";" parse-tokens
- [ [ reader-word ] [ writer-word ] bi 2array ] map concat
- define-protocol ;
\ No newline at end of file
+ CREATE-WORD ";"
+ [ [ reader-word ] [ writer-word ] bi 2array ]
+ map-tokens concat define-protocol ;
: 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>
math combinators namespaces urls.encoding xml.syntax xmode.code2html
xml.data arrays strings vectors xml.writer io.streams.string locals
unicode.categories ;
+FROM: namespaces => set ;
IN: farkup
SYMBOL: relative-link-prefix
{ 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
SYMBOL: logged-in-user\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
{
{ [ os windows? ] [ "game.input.xinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] }
- { [ os linux? ] [ "game.input.linux" require ] }
+ { [ os linux? ] [ "game.input.x11" require ] }
[ ]
} cond
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 ;
+++ /dev/null
-Erik Charlebois
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel game.input namespaces classes bit-arrays vectors ;
-IN: game.input.linux
-
-SINGLETON: linux-game-input-backend
-
-linux-game-input-backend game-input-backend set-global
-
-M: linux-game-input-backend (open-game-input)
- ;
-
-M: linux-game-input-backend (close-game-input)
- ;
-
-M: linux-game-input-backend (reset-game-input)
- ;
-
-M: linux-game-input-backend get-controllers
- { } ;
-
-M: linux-game-input-backend product-string
- drop "" ;
-
-M: linux-game-input-backend product-id
- drop f ;
-
-M: linux-game-input-backend instance-id
- drop f ;
-
-M: linux-game-input-backend read-controller
- drop controller-state new ;
-
-M: linux-game-input-backend calibrate-controller
- drop ;
-
-M: linux-game-input-backend vibrate-controller
- 3drop ;
-
-M: linux-game-input-backend read-keyboard
- 256 <bit-array> keyboard-state boa ;
-
-M: linux-game-input-backend read-mouse
- 0 0 0 0 2 <vector> mouse-state boa ;
-
-M: linux-game-input-backend reset-mouse
- ;
+++ /dev/null
-Linux backend for game input.
--- /dev/null
+Erik Charlebois
+William Schlieper
--- /dev/null
+Linux backend for game input.
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois, William Schlieper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel game.input namespaces
+classes bit-arrays system sequences vectors x11 x11.xlib ;
+IN: game.input.x11
+
+SINGLETON: x11-game-input-backend
+
+x11-game-input-backend game-input-backend set-global
+
+M: x11-game-input-backend (open-game-input)
+ ;
+
+M: x11-game-input-backend (close-game-input)
+ ;
+
+M: x11-game-input-backend (reset-game-input)
+ ;
+
+M: x11-game-input-backend get-controllers
+ { } ;
+
+M: x11-game-input-backend product-string
+ drop "" ;
+
+M: x11-game-input-backend product-id
+ drop f ;
+
+M: x11-game-input-backend instance-id
+ drop f ;
+
+M: x11-game-input-backend read-controller
+ drop controller-state new ;
+
+M: x11-game-input-backend calibrate-controller
+ drop ;
+
+M: x11-game-input-backend vibrate-controller
+ 3drop ;
+
+HOOK: x>hid-bit-order os ( -- x )
+
+M: linux x>hid-bit-order
+ {
+ 0 0 0 0 0 0 0 0
+ 0 41 30 31 32 33 34 35
+ 36 37 38 39 45 46 42 43
+ 20 26 8 21 23 28 24 12
+ 18 19 47 48 40 224 4 22
+ 7 9 10 11 13 14 15 51
+ 52 53 225 49 29 27 6 25
+ 5 17 16 54 55 56 229 85
+ 226 44 57 58 59 60 61 62
+ 63 64 65 66 67 83 71 95
+ 96 97 86 92 93 94 87 91
+ 90 89 98 99 0 0 0 68
+ 69 0 0 0 0 0 0 0
+ 88 228 84 70 0 0 74 82
+ 75 80 79 77 81 78 73 76
+ 127 129 128 102 103 0 72 0
+ 0 0 0 227 231 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ } ; inline
+
+: x-bits>hid-bits ( bit-array -- bit-array )
+ 256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map
+ x>hid-bit-order [ nth ] curry map
+ 256 <bit-array> swap [ t swap pick set-nth ] each ;
+
+M: x11-game-input-backend read-keyboard
+ dpy get 256 <bit-array> [ XQueryKeymap drop ] keep
+ x-bits>hid-bits keyboard-state boa ;
+
+M: x11-game-input-backend read-mouse
+ 0 0 0 0 2 <vector> mouse-state boa ;
+
+M: x11-game-input-backend reset-mouse
+ ;
{ $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 -- )
{ $subsections groups <groups> <sliced-groups> }
"Splitting a sequence into overlapping, fixed-length subsequences:"
{ $subsections clump }
+"Splitting a sequence into overlapping, fixed-length subsequences, wrapping around the end of the sequence:"
+{ $subsections circular-clump }
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
{ $subsections clumps <clumps> <sliced-clumps> }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsections circular-clumps <circular-clumps> <sliced-circular-clumps> }
"The difference can be summarized as the following:"
{ $list
{ "With groups, the subsequences form the original sequence when concatenated:"
+ { $unchecked-example
+ "USING: grouping ;"
+ "{ 1 2 3 4 } 2 group ." "{ { 1 2 } { 3 4 } }"
+ }
{ $unchecked-example
"USING: grouping ;"
"{ 1 2 3 4 } dup" "2 <groups> concat sequence= ." "t"
}
}
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+ { $unchecked-example
+ "USING: grouping ;"
+ "{ 1 2 3 4 } 2 clump ." "{ { 1 2 } { 2 3 } { 3 4 } }"
+ }
{ $unchecked-example
"USING: grouping ;"
"{ 1 2 3 4 } dup" "2 <clumps> unclip-last [ [ first ] map ] dip append sequence= ." "t"
}
}
+ { "With circular clumps, collecting the first element of each subsequence yields the original sequence. Collecting the " { $snippet "n" } "th element of each subsequence would rotate the original sequence " { $snippet "n" } " elements rightward:"
+ { $unchecked-example
+ "USING: grouping ;"
+ "{ 1 2 3 4 } 2 circular-clump ." "{ { 1 2 } { 2 3 } { 3 4 } { 4 1 } }"
+ }
+ { $unchecked-example
+ "USING: grouping ;"
+ "{ 1 2 3 4 } dup" "2 <circular-clumps> [ first ] map sequence= ." "t"
+ }
+ { $unchecked-example
+ "USING: grouping ;"
+ "{ 1 2 3 4 } dup" "2 <circular-clumps> [ second ] { } map-as ." "{ 2 3 4 1 }"
+ }
+ }
}
$nl
"A combinator built using clumps:"
} ;
HELP: clumps
-{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences of an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
+HELP: circular-clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences of an underlying sequence, beginning with every element in the original sequence and wrapping around its end. Circular clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <circular-clumps> } " and " { $link <sliced-circular-clumps> } "." } ;
+
HELP: clump
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
-{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $errors "Throws an error if " { $snippet "n" } " is larger than the length of the sequence." }
{ $examples
{ $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
} ;
+HELP: circular-clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements, wrapping around the end of the sequence, and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is larger than the length of the sequence." }
+{ $examples
+ { $example "USING: grouping prettyprint ;" "{ 3 1 3 3 7 } 2 circular-clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } { 7 3 } }" }
+} ;
+
HELP: <clumps>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
}
} ;
-HELP: <sliced-clumps>
+HELP: <circular-clumps>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence, starting with each of its elements and wrapping around the end of the sequence." }
{ $examples
{ $example
"USING: kernel sequences grouping prettyprint ;"
- "{ 1 2 3 4 5 6 } 3 <sliced-clumps> second ."
- "T{ slice { from 1 } { to 4 } { seq { 1 2 3 4 5 6 } } }"
+ "{ 1 2 3 4 } 3 <circular-clumps> third ."
+ "{ 3 4 1 }"
+ }
+} ;
+
+HELP: <sliced-circular-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence, starting with each of its elements and wrapping around the end of the sequence." }
+{ $examples
+ { $example
+ "USING: arrays kernel sequences grouping prettyprint ;"
+ "{ 1 2 3 4 } 3 <sliced-circular-clumps> third >array ."
+ "{ 3 4 1 }"
}
} ;
-{ clumps groups } related-words
+{ clumps circular-clumps groups } related-words
-{ clump group } related-words
+{ clump circular-clump group } related-words
-{ <clumps> <groups> } related-words
+{ <clumps> <circular-clumps> <groups> } related-words
-{ <sliced-clumps> <sliced-groups> } related-words
+{ <sliced-clumps> <sliced-circular-clumps> <sliced-groups> } related-words
HELP: monotonic?
{ $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }
[ 1 ] [ { 1 2 } 2 <clumps> length ] unit-test
[ 2 ] [ { 1 2 3 } 2 <clumps> length ] unit-test
+[ { } 2 <circular-clumps> length ] must-fail
+[ { 1 } 2 <circular-clumps> length ] must-fail
+
+[ 2 ] [ { 1 2 } 2 <circular-clumps> length ] unit-test
+[ 3 ] [ { 1 2 3 } 2 <circular-clumps> length ] unit-test
+
+[ { { 1 2 } { 2 1 } } ] [ { 1 2 } 2 circular-clump ] unit-test
+[ { { 1 2 } { 2 3 } { 3 1 } } ] [ { 1 2 3 } 2 circular-clump ] unit-test
+
[ 1 ] [ V{ } 2 <clumps> 0 over set-length seq>> length ] unit-test
[ 2 ] [ V{ } 2 <clumps> 1 over set-length seq>> length ] unit-test
[ 3 ] [ V{ } 2 <clumps> 2 over set-length seq>> length ] unit-test
-! Copyright (C) 2005, 2010 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
-sequences.private accessors fry ;
+sequences.private accessors fry combinators ;
IN: grouping
<PRIVATE
: new-groups ( seq n class -- groups )
[ check-groups ] dip boa ; inline
+: slice-mod ( n length -- n' )
+ 2dup >= [ - ] [ drop ] if ; inline
+
+: check-circular-clumps ( seq n -- seq n )
+ 2dup 1 - swap bounds-check 2drop ; inline
+
PRIVATE>
TUPLE: groups < chunking-seq ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
+
+TUPLE: circular-slice { from read-only } { to read-only } { seq read-only } ;
+
+INSTANCE: circular-slice virtual-sequence
+
+M: circular-slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+
+M: circular-slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: circular-slice length [ to>> ] [ from>> ] bi - ; inline
+
+M: circular-slice virtual-exemplar seq>> ; inline
+
+M: circular-slice virtual@
+ [ from>> + ] [ seq>> ] bi [ length slice-mod ] keep ; inline
+
+C: <circular-slice> circular-slice
+
+TUPLE: sliced-circular-clumps < chunking-seq ;
+INSTANCE: sliced-circular-clumps sequence
+
+M: sliced-circular-clumps length
+ seq>> length ; inline
+
+M: sliced-circular-clumps nth
+ [ n>> over + ] [ seq>> ] bi <circular-slice> ; inline
+
+: <sliced-circular-clumps> ( seq n -- clumps )
+ check-circular-clumps sliced-circular-clumps boa ; inline
+
+TUPLE: circular-clumps < chunking-seq ;
+INSTANCE: circular-clumps sequence
+
+M: circular-clumps length
+ seq>> length ; inline
+
+M: circular-clumps nth
+ [ n>> over + ] [ seq>> ] bi [ <circular-slice> ] [ like ] bi ; inline
+
+: <circular-clumps> ( seq n -- clumps )
+ check-circular-clumps circular-clumps boa ; inline
+
+: circular-clump ( seq n -- array )
+ <circular-clumps> { } like ; inline
ARTICLE: "crossref-test-2" "Crossref test 2"
{ $markup-example { $subsection "crossref-test-1" } } ;
-[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test
+[ { } ] [ "crossref-test-2" >link article-children ] unit-test
}
{ $heading "Other collections" }
{ $subsections
+ "sets"
"lists"
"disjoint-sets"
"interval-maps"
namespaces sequences sequences.deep sets sorting splitting
strings unicode.categories values vocabs vocabs.loader words
words.symbol summary debugger io ;
+FROM: sets => members ;
IN: help.lint.checks
ERROR: simple-lint-error message ;
first rest [ first ] map
] unless ;
+: extract-value-effects ( element -- seq )
+ \ $values swap elements dup empty? [
+ first rest [
+ \ $quotation swap elements dup empty? [ drop f ] [
+ first second
+ ] if
+ ] map
+ ] unless ;
+
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
- [ dup pair? [ first ] when effect>string ] map prune ;
+ [ 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 -- ? )
{
[ 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?
: check-see-also ( element -- )
\ $see-also swap elements [
- rest dup prune [ length ] bi@ assert=
+ rest all-unique? t assert=
] each ;
: vocab-exists? ( name -- ? )
! 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 ;
sorting splitting strings vectors vocabs vocabs.loader words
words.symbol ;
FROM: prettyprint.sections => with-pprint ;
+FROM: namespaces => set ;
IN: help.markup
PREDICATE: simple-element < array
: elements ( elt-type element -- seq ) [ elements* ] { } make ;
: collect-elements ( element seq -- elements )
- swap '[ _ elements [ rest ] map concat ] map concat prune ;
+ swap '[ _ elements [ rest ] map concat ] gather ;
: <$link> ( topic -- element )
1array \ $link prefix ;
-! 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
IN: images.processing\r
\r
: coord-matrix ( dim -- m )\r
- [ iota ] map first2 [ [ 2array ] with map ] curry map ;\r
+ [ iota ] map first2 cartesian-product ;\r
\r
: map^2 ( m quot -- m' ) '[ _ map ] map ; inline\r
: each^2 ( m quot -- m' ) '[ _ each ] each ; inline\r
sequences strings io.styles vectors words quotations mirrors
splitting math.parser classes vocabs sets sorting summary
debugger continuations fry combinators ;
+FROM: namespaces => set ;
IN: inspector
SYMBOL: +number-rows+
[ 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*
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
system hashtables destructors unix classes.struct ;
+FROM: namespaces => set ;
IN: io.monitors.linux
SYMBOL: watches
IN_MOVED_FROM +rename-file-old+ ?flag
IN_MOVED_TO +rename-file-new+ ?flag
drop
- ] { } make prune ;
+ ] { } make members ;
: parse-event-name ( event -- name )
dup len>> zero?
[ 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 )
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
+: parse-local-defs ( -- words assoc )
+ [ "|" [ make-local ] map-tokens ] H{ } make-assoc ;
+
: make-local-word ( name def -- word )
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
[ \ ] parse-until >quotation ] ((parse-lambda)) ;
: parse-lambda ( -- lambda )
- "|" parse-tokens make-locals
+ parse-local-defs
(parse-lambda) <lambda>
?rewrite-closures ;
: parse-multi-def ( locals -- multi-def )
- ")" parse-tokens swap [ [ make-local ] map ] bind <multi-def> ;
+ [ ")" [ make-local ] map-tokens ] bind <multi-def> ;
: parse-def ( name/paren locals -- def )
over "(" = [ nip parse-multi-def ] [ [ make-local ] bind <def> ] if ;
GENERIC: defs-vars* ( seq form -- seq' )
-: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce prune ;
+: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce members ;
M: def defs-vars* local>> unquote suffix ;
GENERIC: uses-vars* ( seq form -- seq' )
-: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce prune ;
+: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce members ;
M: local-writer uses-vars* "local-reader" word-prop suffix ;
[ define-match-var ] each ;
SYNTAX: MATCH-VARS: ! vars ...
- ";" parse-tokens define-match-vars ;
+ ";" [ define-match-var ] each-token ;
: match-var? ( symbol -- bool )
dup word? [ "match-var" word-prop ] [ drop f ] if ;
: 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 ;
m.
] unit-test
-[ { 0 0 -1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test
+[ { 0 0 1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test
[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test
[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
+[ { 0.0 -0.707 0.707 } ] [ { 1.0 0.0 0.0 } { 0.0 0.707 0.707 } cross ] unit-test
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
-[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
-
[ { { 4181 6765 } { 6765 10946 } } ]
[ { { 0 1 } { 1 1 } } 20 m^n ] unit-test
: identity-matrix ( n -- matrix )
#! Make a nxn identity matrix.
- iota dup [ [ = 1 0 ? ] with map ] curry map ;
+ iota dup [ = 1 0 ? ] cartesian-map ;
:: rotation-matrix3 ( axis theta -- matrix )
theta cos :> c
: mnorm ( m -- n ) dup mmax abs m/n ;
: cross ( vec1 vec2 -- vec3 )
- [ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ]
- [ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline
+ [ [ { 1 2 0 } vshuffle ] [ { 2 0 1 } vshuffle ] bi* v* ]
+ [ [ { 2 0 1 } vshuffle ] [ { 1 2 0 } vshuffle ] bi* v* ] 2bi v- ; inline
: proj ( v u -- w )
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
+: perp ( v u -- w )
+ dupd proj v- ;
+
+: angle-between ( v u -- a )
+ [ normalize ] bi@ v. acos ;
+
: (gram-schmidt) ( v seq -- newseq )
[ dupd proj v- ] each ;
: norm-gram-schmidt ( seq -- orthonormal )
gram-schmidt [ normalize ] map ;
-: cross-zip ( seq1 seq2 -- seq1xseq2 )
- [ [ 2array ] with map ] curry map ;
-
: m^n ( m n -- n )
make-bits over first length identity-matrix
[ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
[ { 0 1/3 2/3 1 } ] [ 1 0 -1/3 <range> >array reverse ] unit-test
[ 100 ] [
- 1 100 [a,b] [ 2^ [1,b] ] map prune length
+ 1 100 [a,b] [ 2^ [1,b] ] map members length
] unit-test
: 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 ? ;
+
[ unknown-gl-platform ]
} cond use-vocab >>
-SYMBOL: +gl-function-number-counter+
+SYMBOL: +gl-function-counter+
SYMBOL: +gl-function-pointers+
: reset-gl-function-number-counter ( -- )
- 0 +gl-function-number-counter+ set-global ;
+ 0 +gl-function-counter+ set-global ;
: reset-gl-function-pointers ( -- )
100 <hashtable> +gl-function-pointers+ set-global ;
reset-gl-function-pointers
reset-gl-function-number-counter
-: gl-function-number ( -- n )
- +gl-function-number-counter+ get-global
- dup 1 + +gl-function-number-counter+ set-global ;
+: gl-function-counter ( -- n )
+ +gl-function-counter+ get-global
+ dup 1 + +gl-function-counter+ set-global ;
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
: indirect-quot ( function-ptr-quot return types abi -- quot )
'[ @ _ _ _ alien-indirect ] ;
-:: define-indirect ( abi return function-ptr-quot function-name parameters -- )
+:: define-indirect ( abi return function-name function-ptr-quot types names -- )
function-name create-in dup reset-generic
- function-ptr-quot return
- parameters return parse-arglist [ abi indirect-quot ] dip
+ function-ptr-quot return types abi indirect-quot
+ names return function-effect
define-declared ;
SYNTAX: GL-FUNCTION:
gl-function-calling-convention
- scan-c-type
- scan dup
- scan drop "}" parse-tokens swap prefix
- gl-function-number
- [ gl-function-pointer ] 2curry swap
- ";" parse-tokens [ "()" subseq? not ] filter
- define-indirect ;
+ scan-function-name
+ "{" expect "}" parse-tokens over prefix
+ gl-function-counter '[ _ _ gl-function-pointer ]
+ ";" scan-c-args define-indirect ;
TYPEDEF: float GLclampf
TYPEDEF: double GLdouble
TYPEDEF: double GLclampd
+TYPEDEF: longlong GLint64
+TYPEDEF: ulonglong GLuint64
+TYPEDEF: void* GLsync
C-TYPE: GLvoid
TYPEDEF: c-string[ascii] GLstring
! [09:39] (slava) NULL <void*>
! [09:39] (slava) then keep that object
-! [09:39] (slava) when you want to get the value stored there, *void*
+! [09:39] (slava) when you want to get the value stored there,* void*
! [09:39] (slava) which returns an alien
FUNCTION: void glGetPointerv ( GLenum pname, GLvoid** params ) ;
GL-FUNCTION: void glCopyBufferSubData { glCopyBufferSubDataEXT } ( GLenum readtarget, GLenum writetarget, GLintptr readoffset, GLintptr writeoffset, GLsizeiptr size ) ;
-! GL_EXT_geometry_shader4
-
-
-GL-FUNCTION: void glProgramParameteriEXT { } ( GLuint program, GLenum pname, GLint value ) ;
-GL-FUNCTION: void glFramebufferTextureEXT { } ( GLenum target, GLenum attachment,
- GLuint texture, GLint level ) ;
-
-CONSTANT: GL_GEOMETRY_SHADER_EXT HEX: 8DD9
-CONSTANT: GL_GEOMETRY_VERTICES_OUT_EXT HEX: 8DDA
-CONSTANT: GL_GEOMETRY_INPUT_TYPE_EXT HEX: 8DDB
-CONSTANT: GL_GEOMETRY_OUTPUT_TYPE_EXT HEX: 8DDC
-CONSTANT: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS_EXT HEX: 8C29
-CONSTANT: GL_MAX_GEOMETRY_VARYING_COMPONENTS_EXT HEX: 8DDD
-CONSTANT: GL_MAX_VERTEX_VARYING_COMPONENTS_EXT HEX: 8DDE
-CONSTANT: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS_EXT HEX: 8DDF
-CONSTANT: GL_MAX_GEOMETRY_OUTPUT_VERTICES_EXT HEX: 8DE0
-CONSTANT: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS_EXT HEX: 8DE1
-CONSTANT: GL_LINES_ADJACENCY_EXT HEX: A
-CONSTANT: GL_LINE_STRIP_ADJACENCY_EXT HEX: B
-CONSTANT: GL_TRIANGLES_ADJACENCY_EXT HEX: C
-CONSTANT: GL_TRIANGLE_STRIP_ADJACENCY_EXT HEX: D
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS_EXT HEX: 8DA8
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_EXT HEX: 8DA9
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_LAYERED_EXT HEX: 8DA7
-CONSTANT: GL_PROGRAM_POINT_SIZE_EXT HEX: 8642
+! OpenGL 3.2
+
+CONSTANT: GL_CONTEXT_CORE_PROFILE_BIT HEX: 00000001
+CONSTANT: GL_CONTEXT_COMPATIBILITY_PROFILE_BIT HEX: 00000002
+CONSTANT: GL_LINES_ADJACENCY HEX: 000A
+CONSTANT: GL_LINE_STRIP_ADJACENCY HEX: 000B
+CONSTANT: GL_TRIANGLES_ADJACENCY HEX: 000C
+CONSTANT: GL_TRIANGLE_STRIP_ADJACENCY HEX: 000D
+CONSTANT: GL_PROGRAM_POINT_SIZE HEX: 8642
+CONSTANT: GL_GEOMETRY_VERTICES_OUT HEX: 8916
+CONSTANT: GL_GEOMETRY_INPUT_TYPE HEX: 8917
+CONSTANT: GL_GEOMETRY_OUTPUT_TYPE HEX: 8918
+CONSTANT: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS HEX: 8C29
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_LAYERED HEX: 8DA7
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS HEX: 8DA8
+CONSTANT: GL_GEOMETRY_SHADER HEX: 8DD9
+CONSTANT: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS HEX: 8DDF
+CONSTANT: GL_MAX_GEOMETRY_OUTPUT_VERTICES HEX: 8DE0
+CONSTANT: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS HEX: 8DE1
+CONSTANT: GL_MAX_VERTEX_OUTPUT_COMPONENTS HEX: 9122
+CONSTANT: GL_MAX_GEOMETRY_INPUT_COMPONENTS HEX: 9123
+CONSTANT: GL_MAX_GEOMETRY_OUTPUT_COMPONENTS HEX: 9124
+CONSTANT: GL_MAX_FRAGMENT_INPUT_COMPONENTS HEX: 9125
+CONSTANT: GL_CONTEXT_PROFILE_MASK HEX: 9126
+CONSTANT: GL_MAX_SERVER_WAIT_TIMEOUT HEX: 9111
+CONSTANT: GL_OBJECT_TYPE HEX: 9112
+CONSTANT: GL_SYNC_CONDITION HEX: 9113
+CONSTANT: GL_SYNC_STATUS HEX: 9114
+CONSTANT: GL_SYNC_FLAGS HEX: 9115
+CONSTANT: GL_SYNC_FENCE HEX: 9116
+CONSTANT: GL_SYNC_GPU_COMMANDS_COMPLETE HEX: 9117
+CONSTANT: GL_UNSIGNALED HEX: 9118
+CONSTANT: GL_SIGNALED HEX: 9119
+CONSTANT: GL_ALREADY_SIGNALED HEX: 911A
+CONSTANT: GL_TIMEOUT_EXPIRED HEX: 911B
+CONSTANT: GL_CONDITION_SATISFIED HEX: 911C
+CONSTANT: GL_WAIT_FAILED HEX: 911D
+CONSTANT: GL_SYNC_FLUSH_COMMANDS_BIT HEX: 00000001
+CONSTANT: GL_TIMEOUT_IGNORED HEX: FFFF,FFFF,FFFF,FFFF
+CONSTANT: GL_SAMPLE_POSITION HEX: 8E50
+CONSTANT: GL_SAMPLE_MASK HEX: 8E51
+CONSTANT: GL_SAMPLE_MASK_VALUE HEX: 8E52
+CONSTANT: GL_MAX_SAMPLE_MASK_WORDS HEX: 8E59
+CONSTANT: GL_TEXTURE_2D_MULTISAMPLE HEX: 9100
+CONSTANT: GL_PROXY_TEXTURE_2D_MULTISAMPLE HEX: 9101
+CONSTANT: GL_TEXTURE_2D_MULTISAMPLE_ARRAY HEX: 9102
+CONSTANT: GL_PROXY_TEXTURE_2D_MULTISAMPLE_ARRAY HEX: 9103
+CONSTANT: GL_TEXTURE_BINDING_2D_MULTISAMPLE HEX: 9104
+CONSTANT: GL_TEXTURE_BINDING_2D_MULTISAMPLE_ARRAY HEX: 9105
+CONSTANT: GL_TEXTURE_SAMPLES HEX: 9106
+CONSTANT: GL_TEXTURE_FIXED_SAMPLE_LOCATIONS HEX: 9107
+CONSTANT: GL_SAMPLER_2D_MULTISAMPLE HEX: 9108
+CONSTANT: GL_INT_SAMPLER_2D_MULTISAMPLE HEX: 9109
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE HEX: 910A
+CONSTANT: GL_SAMPLER_2D_MULTISAMPLE_ARRAY HEX: 910B
+CONSTANT: GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY HEX: 910C
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY HEX: 910D
+CONSTANT: GL_MAX_COLOR_TEXTURE_SAMPLES HEX: 910E
+CONSTANT: GL_MAX_DEPTH_TEXTURE_SAMPLES HEX: 910F
+CONSTANT: GL_MAX_INTEGER_SAMPLES HEX: 9110
+CONSTANT: GL_DEPTH_CLAMP HEX: 864F
+CONSTANT: GL_QUADS_FOLLOW_PROVOKING_VERTEX_CONVENTION HEX: 8E4C
+CONSTANT: GL_FIRST_VERTEX_CONVENTION HEX: 8E4D
+CONSTANT: GL_LAST_VERTEX_CONVENTION HEX: 8E4E
+CONSTANT: GL_PROVOKING_VERTEX HEX: 8E4F
+CONSTANT: GL_TEXTURE_CUBE_MAP_SEAMLESS HEX: 884F
+
+GL-FUNCTION: void glFramebufferTexture { glFramebufferTextureARB glFramebufferTextureEXT }
+ ( GLenum target, GLenum attachment, GLuint texture, GLint level ) ;
+GL-FUNCTION: void glGetBufferParameteri64v { }
+ ( GLenum target, GLenum pname, GLint64* params ) ;
+GL-FUNCTION: void glGetInteger64i_v { }
+ ( GLenum target, GLuint index, GLint64* data ) ;
+GL-FUNCTION: void glProvokingVertex { } ( GLenum mode ) ;
+
+GL-FUNCTION: GLsync glFenceSync { } ( GLenum condition, GLbitfield flags ) ;
+GL-FUNCTION: GLboolean glIsSync { } ( GLsync sync ) ;
+GL-FUNCTION: void glDeleteSync { } ( GLsync sync ) ;
+GL-FUNCTION: GLenum glClientWaitSync { } ( GLsync sync, GLbitfield flags, GLuint64 timeout ) ;
+GL-FUNCTION: void glWaitSync { } ( GLsync sync, GLbitfield flags, GLuint64 timeout ) ;
+GL-FUNCTION: void glGetInteger64v { } ( GLenum pname, GLint64* params ) ;
+GL-FUNCTION: void glGetSynciv { } ( GLsync sync, GLenum pname, GLsizei bufSize, GLsizei* length, GLint* values ) ;
+GL-FUNCTION: void glTexImage2DMultisample { } ( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLboolean fixedsamplelocations ) ;
+GL-FUNCTION: void glTexImage3DMultisample { } ( GLenum target, GLsizei samples, GLint internalformat, GLsizei width, GLsizei height, GLsizei depth, GLboolean fixedsamplelocations ) ;
+GL-FUNCTION: void glGetMultisamplefv { } ( GLenum pname, GLuint index, GLfloat* val ) ;
+GL-FUNCTION: void glSampleMaski { } ( GLuint index, GLbitfield mask ) ;
+
+
+! OpenGL 3.3
+
+CONSTANT: GL_SRC1_COLOR HEX: 88F9
+CONSTANT: GL_ONE_MINUS_SRC1_COLOR HEX: 88FA
+CONSTANT: GL_ONE_MINUS_SRC1_ALPHA HEX: 88FB
+CONSTANT: GL_MAX_DUAL_SOURCE_DRAW_BUFFERS HEX: 88FC
+
+CONSTANT: GL_ANY_SAMPLES_PASSED HEX: 8C2F
+
+CONSTANT: GL_SAMPLER_BINDING HEX: 8919
+
+CONSTANT: GL_RGB10_A2UI HEX: 906F
+
+CONSTANT: GL_TEXTURE_SWIZZLE_R HEX: 8E42
+CONSTANT: GL_TEXTURE_SWIZZLE_G HEX: 8E43
+CONSTANT: GL_TEXTURE_SWIZZLE_B HEX: 8E44
+CONSTANT: GL_TEXTURE_SWIZZLE_A HEX: 8E45
+CONSTANT: GL_TEXTURE_SWIZZLE_RGBA HEX: 8E46
+
+CONSTANT: GL_TIME_ELAPSED HEX: 88BF
+CONSTANT: GL_TIMESTAMP HEX: 8E28
+
+CONSTANT: GL_INT_2_10_10_10_REV HEX: 8D9F
+
+GL-FUNCTION: void glBindFragDataLocationIndexed { } ( GLuint program, GLuint colorNumber, GLuint index, GLstring name ) ;
+GL-FUNCTION: GLint glGetFragDataIndex { } ( GLuint program, GLstring name ) ;
+
+GL-FUNCTION: void glGenSamplers { } ( GLsizei count, GLuint* samplers ) ;
+GL-FUNCTION: void glDeleteSamplers { } ( GLsizei count, GLuint* samplers ) ;
+GL-FUNCTION: GLboolean glIsSampler { } ( GLuint sampler ) ;
+GL-FUNCTION: void glBindSampler { } ( GLenum unit, GLuint sampler ) ;
+GL-FUNCTION: void glSamplerParameteri { } ( GLuint sampler, GLenum pname, GLint param ) ;
+GL-FUNCTION: void glSamplerParameteriv { } ( GLuint sampler, GLenum pname, GLint* param ) ;
+GL-FUNCTION: void glSamplerParameterf { } ( GLuint sampler, GLenum pname, GLfloat param ) ;
+GL-FUNCTION: void glSamplerParameterfv { } ( GLuint sampler, GLenum pname, GLfloat* param ) ;
+GL-FUNCTION: void glSamplerParameterIiv { } ( GLuint sampler, GLenum pname, GLint* param ) ;
+GL-FUNCTION: void glSamplerParameterIuiv { } ( GLuint sampler, GLenum pname, GLuint* param ) ;
+GL-FUNCTION: void glGetSamplerParameteriv { } ( GLuint sampler, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetSamplerParameterIiv { } ( GLuint sampler, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetSamplerParameterfv { } ( GLuint sampler, GLenum pname, GLfloat* params ) ;
+GL-FUNCTION: void glGetSamplerParameterIfv { } ( GLuint sampler, GLenum pname, GLfloat* params ) ;
+
+GL-FUNCTION: void glQueryCounter { } ( GLuint id, GLenum target ) ;
+GL-FUNCTION: void glGetQueryObjecti64v { } ( GLuint id, GLenum pname, GLint64* params ) ;
+GL-FUNCTION: void glGetQueryObjectui64v { } ( GLuint id, GLenum pname, GLuint64* params ) ;
+
+GL-FUNCTION: void glVertexP2ui { } ( GLenum type, GLuint value ) ;
+GL-FUNCTION: void glVertexP2uiv { } ( GLenum type, GLuint* value ) ;
+GL-FUNCTION: void glVertexP3ui { } ( GLenum type, GLuint value ) ;
+GL-FUNCTION: void glVertexP3uiv { } ( GLenum type, GLuint* value ) ;
+GL-FUNCTION: void glVertexP4ui { } ( GLenum type, GLuint value ) ;
+GL-FUNCTION: void glVertexP4uiv { } ( GLenum type, GLuint* value ) ;
+GL-FUNCTION: void glTexCoordP1ui { } ( GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glTexCoordP1uiv { } ( GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glTexCoordP2ui { } ( GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glTexCoordP2uiv { } ( GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glTexCoordP3ui { } ( GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glTexCoordP3uiv { } ( GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glTexCoordP4ui { } ( GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glTexCoordP4uiv { } ( GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glMultiTexCoordP1ui { } ( GLenum texture, GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glMultiTexCoordP1uiv { } ( GLenum texture, GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glMultiTexCoordP2ui { } ( GLenum texture, GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glMultiTexCoordP2uiv { } ( GLenum texture, GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glMultiTexCoordP3ui { } ( GLenum texture, GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glMultiTexCoordP3uiv { } ( GLenum texture, GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glMultiTexCoordP4ui { } ( GLenum texture, GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glMultiTexCoordP4uiv { } ( GLenum texture, GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glNormalP3ui { } ( GLenum type, GLuint coords ) ;
+GL-FUNCTION: void glNormalP3uiv { } ( GLenum type, GLuint* coords ) ;
+GL-FUNCTION: void glColorP3ui { } ( GLenum type, GLuint color ) ;
+GL-FUNCTION: void glColorP3uiv { } ( GLenum type, GLuint* color ) ;
+GL-FUNCTION: void glColorP4ui { } ( GLenum type, GLuint color ) ;
+GL-FUNCTION: void glColorP4uiv { } ( GLenum type, GLuint* color ) ;
+GL-FUNCTION: void glSecondaryColorP3ui { } ( GLenum type, GLuint color ) ;
+GL-FUNCTION: void glSecondaryColorP3uiv { } ( GLenum type, GLuint* color ) ;
+GL-FUNCTION: void glVertexAttribP1ui { } ( GLuint index, GLenum type, GLboolean normalized, GLuint value ) ;
+GL-FUNCTION: void glVertexAttribP1uiv { } ( GLuint index, GLenum type, GLboolean normalized, GLuint* value ) ;
+GL-FUNCTION: void glVertexAttribP2ui { } ( GLuint index, GLenum type, GLboolean normalized, GLuint value ) ;
+GL-FUNCTION: void glVertexAttribP2uiv { } ( GLuint index, GLenum type, GLboolean normalized, GLuint* value ) ;
+GL-FUNCTION: void glVertexAttribP3ui { } ( GLuint index, GLenum type, GLboolean normalized, GLuint value ) ;
+GL-FUNCTION: void glVertexAttribP3uiv { } ( GLuint index, GLenum type, GLboolean normalized, GLuint* value ) ;
+GL-FUNCTION: void glVertexAttribP4ui { } ( GLuint index, GLenum type, GLboolean normalized, GLuint value ) ;
+GL-FUNCTION: void glVertexAttribP4uiv { } ( GLuint index, GLenum type, GLboolean normalized, GLuint* value ) ;
+
+
+! OpenGL 4.0
+
+CONSTANT: GL_DRAW_INDIRECT_BUFFER HEX: 8F3F
+CONSTANT: GL_DRAW_INDIRECT_BUFFER_BINDING HEX: 8F43
+
+CONSTANT: GL_GEOMETRY_SHADER_INVOCATIONS HEX: 887F
+CONSTANT: GL_MAX_GEOMETRY_SHADER_INVOCATIONS HEX: 8E5A
+CONSTANT: GL_MIN_FRAGMENT_INTERPOLATION_OFFSET HEX: 8E5B
+CONSTANT: GL_MAX_FRAGMENT_INTERPOLATION_OFFSET HEX: 8E5C
+CONSTANT: GL_FRAGMENT_INTERPOLATION_OFFSET_BITS HEX: 8E5D
+CONSTANT: GL_MAX_VERTEX_STREAMS HEX: 8E71
+
+CONSTANT: GL_DOUBLE_VEC2 HEX: 8FFC
+CONSTANT: GL_DOUBLE_VEC3 HEX: 8FFD
+CONSTANT: GL_DOUBLE_VEC4 HEX: 8FFE
+CONSTANT: GL_DOUBLE_MAT2 HEX: 8F46
+CONSTANT: GL_DOUBLE_MAT3 HEX: 8F47
+CONSTANT: GL_DOUBLE_MAT4 HEX: 8F48
+CONSTANT: GL_DOUBLE_MAT2x3 HEX: 8F49
+CONSTANT: GL_DOUBLE_MAT2x4 HEX: 8F4A
+CONSTANT: GL_DOUBLE_MAT3x2 HEX: 8F4B
+CONSTANT: GL_DOUBLE_MAT3x4 HEX: 8F4C
+CONSTANT: GL_DOUBLE_MAT4x2 HEX: 8F4D
+CONSTANT: GL_DOUBLE_MAT4x3 HEX: 8F4E
+
+CONSTANT: GL_ACTIVE_SUBROUTINES HEX: 8DE5
+CONSTANT: GL_ACTIVE_SUBROUTINE_UNIFORMS HEX: 8DE6
+CONSTANT: GL_ACTIVE_SUBROUTINE_UNIFORM_LOCATIONS HEX: 8E47
+CONSTANT: GL_ACTIVE_SUBROUTINE_MAX_LENGTH HEX: 8E48
+CONSTANT: GL_ACTIVE_SUBROUTINE_UNIFORM_MAX_LENGTH HEX: 8E49
+CONSTANT: GL_MAX_SUBROUTINES HEX: 8DE7
+CONSTANT: GL_MAX_SUBROUTINE_UNIFORM_LOCATIONS HEX: 8DE8
+CONSTANT: GL_NUM_COMPATIBLE_SUBROUTINES HEX: 8E4A
+CONSTANT: GL_COMPATIBLE_SUBROUTINES HEX: 8E4B
+
+CONSTANT: GL_PATCHES HEX: 000E
+CONSTANT: GL_PATCH_VERTICES HEX: 8E72
+CONSTANT: GL_PATCH_DEFAULT_INNER_LEVEL HEX: 8E73
+CONSTANT: GL_PATCH_DEFAULT_OUTER_LEVEL HEX: 8E74
+CONSTANT: GL_TESS_CONTROL_OUTPUT_VERTICES HEX: 8E75
+CONSTANT: GL_TESS_GEN_MODE HEX: 8E76
+CONSTANT: GL_TESS_GEN_SPACING HEX: 8E77
+CONSTANT: GL_TESS_GEN_VERTEX_ORDER HEX: 8E78
+CONSTANT: GL_TESS_GEN_POINT_MODE HEX: 8E79
+CONSTANT: GL_ISOLINES HEX: 8E7A
+CONSTANT: GL_FRACTIONAL_ODD HEX: 8E7B
+CONSTANT: GL_FRACTIONAL_EVEN HEX: 8E7C
+CONSTANT: GL_MAX_PATCH_VERTICES HEX: 8E7D
+CONSTANT: GL_MAX_TESS_GEN_LEVEL HEX: 8E7E
+CONSTANT: GL_MAX_TESS_CONTROL_UNIFORM_COMPONENTS HEX: 8E7F
+CONSTANT: GL_MAX_TESS_EVALUATION_UNIFORM_COMPONENTS HEX: 8E80
+CONSTANT: GL_MAX_TESS_CONTROL_TEXTURE_IMAGE_UNITS HEX: 8E81
+CONSTANT: GL_MAX_TESS_EVALUATION_TEXTURE_IMAGE_UNITS HEX: 8E82
+CONSTANT: GL_MAX_TESS_CONTROL_OUTPUT_COMPONENTS HEX: 8E83
+CONSTANT: GL_MAX_TESS_PATCH_COMPONENTS HEX: 8E84
+CONSTANT: GL_MAX_TESS_CONTROL_TOTAL_OUTPUT_COMPONENTS HEX: 8E85
+CONSTANT: GL_MAX_TESS_EVALUATION_OUTPUT_COMPONENTS HEX: 8E86
+CONSTANT: GL_MAX_TESS_CONTROL_UNIFORM_BLOCKS HEX: 8E89
+CONSTANT: GL_MAX_TESS_EVALUATION_UNIFORM_BLOCKS HEX: 8E8A
+CONSTANT: GL_MAX_TESS_CONTROL_INPUT_COMPONENTS HEX: 886C
+CONSTANT: GL_MAX_TESS_EVALUATION_INPUT_COMPONENTS HEX: 886D
+CONSTANT: GL_MAX_COMBINED_TESS_CONTROL_UNIFORM_COMPONENTS HEX: 8E1E
+CONSTANT: GL_MAX_COMBINED_TESS_EVALUATION_UNIFORM_COMPONENTS HEX: 8E1F
+CONSTANT: GL_UNIFORM_BLOCK_REFERENCED_BY_TESS_CONTROL_SHADER HEX: 84F0
+CONSTANT: GL_UNIFORM_BLOCK_REFERENCED_BY_TESS_EVALUATION_SHADER HEX: 84F1
+CONSTANT: GL_TESS_EVALUATION_SHADER HEX: 8E87
+CONSTANT: GL_TESS_CONTROL_SHADER HEX: 8E88
+CONSTANT: GL_TRANSFORM_FEEDBACK HEX: 8E22
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_PAUSED HEX: 8E23
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_ACTIVE HEX: 8E24
+CONSTANT: GL_TRANSFORM_FEEDBACK_BINDING HEX: 8E25
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_BUFFERS HEX: 8E70
+
+GL-FUNCTION: void glUniform1d { } ( GLint location, GLdouble x ) ;
+GL-FUNCTION: void glUniform2d { } ( GLint location, GLdouble x, GLdouble y ) ;
+GL-FUNCTION: void glUniform3d { } ( GLint location, GLdouble x, GLdouble y, GLdouble z ) ;
+GL-FUNCTION: void glUniform4d { } ( GLint location, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ;
+GL-FUNCTION: void glUniform1dv { } ( GLint location, GLsizei count, GLdouble* value ) ;
+GL-FUNCTION: void glUniform2dv { } ( GLint location, GLsizei count, GLdouble* value ) ;
+GL-FUNCTION: void glUniform3dv { } ( GLint location, GLsizei count, GLdouble* value ) ;
+GL-FUNCTION: void glUniform4dv { } ( GLint location, GLsizei count, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix2dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix3dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix4dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix2x3dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix2x4dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix3x2dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix3x4dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix4x2dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glUniformMatrix4x3dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glGetUniformdv { } ( GLuint program, GLint location, GLdouble* params ) ;
+GL-FUNCTION: void glProgramUniform1dEXT { } ( GLuint program, GLint location, GLdouble x ) ;
+GL-FUNCTION: void glProgramUniform2dEXT { } ( GLuint program, GLint location, GLdouble x, GLdouble y ) ;
+GL-FUNCTION: void glProgramUniform3dEXT { } ( GLuint program, GLint location, GLdouble x, GLdouble y, GLdouble z ) ;
+GL-FUNCTION: void glProgramUniform4dEXT { } ( GLuint program, GLint location, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ;
+GL-FUNCTION: void glProgramUniform1dvEXT { } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniform2dvEXT { } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniform3dvEXT { } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniform4dvEXT { } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix2dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix3dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix4dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix2x3dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix2x4dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix3x2dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix3x4dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix4x2dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+GL-FUNCTION: void glProgramUniformMatrix4x3dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ;
+
+GL-FUNCTION: GLint glGetSubroutineUniformLocation { } ( GLuint program, GLenum shadertype, GLstring name ) ;
+GL-FUNCTION: GLuint glGetSubroutineIndex { } ( GLuint program, GLenum shadertype, GLstring name ) ;
+GL-FUNCTION: void glGetActiveSubroutineUniformiv { } ( GLuint program, GLenum shadertype, GLuint index, GLenum pname, GLint* values ) ;
+GL-FUNCTION: void glGetActiveSubroutineUniformName { } ( GLuint program, GLenum shadertype, GLuint index, GLsizei bufsize, GLsizei* length, GLstring name ) ;
+GL-FUNCTION: void glGetActiveSubroutineName { } ( GLuint program, GLenum shadertype, GLuint index, GLsizei bufsize, GLsizei* length, GLstring name ) ;
+GL-FUNCTION: void glUniformSubroutinesuiv { } ( GLenum shadertype, GLsizei count, GLuint* indices ) ;
+GL-FUNCTION: void glGetUniformSubroutineuiv { } ( GLenum shadertype, GLint location, GLuint* params ) ;
+GL-FUNCTION: void glGetProgramStageiv { } ( GLuint program, GLenum shadertype, GLenum pname, GLint* values ) ;
+
+GL-FUNCTION: void glPatchParameteri { } ( GLenum pname, GLint value ) ;
+GL-FUNCTION: void glPatchParameterfv { } ( GLenum pname, GLfloat* values ) ;
+
+GL-FUNCTION: void glBindTransformFeedback { } ( GLenum target, GLuint id ) ;
+GL-FUNCTION: void glDeleteTransformFeedbacks { } ( GLsizei n, GLuint* ids ) ;
+GL-FUNCTION: void glGenTransformFeedbacks { } ( GLsizei n, GLuint* ids ) ;
+GL-FUNCTION: GLboolean glIsTransformFeedback { } ( GLuint id ) ;
+GL-FUNCTION: void glPauseTransformFeedback { } ( ) ;
+GL-FUNCTION: void glResumeTransformFeedback { } ( ) ;
+GL-FUNCTION: void glDrawTransformFeedback { } ( GLenum mode, GLuint id ) ;
+
+GL-FUNCTION: void glDrawTransformFeedbackStream { } ( GLenum mode, GLuint id, GLuint stream ) ;
+GL-FUNCTION: void glBeginQueryIndexed { } ( GLenum target, GLuint index, GLuint id ) ;
+GL-FUNCTION: void glEndQueryIndexed { } ( GLenum target, GLuint index ) ;
+GL-FUNCTION: void glGetQueryIndexediv { } ( GLenum target, GLuint index, GLenum pname, GLint* params ) ;
+
+
+! GL_ARB_geometry_shader4
+
+GL-FUNCTION: void glProgramParameteriARB { glProgramParameteriEXT }
+ ( GLuint program, GLenum pname, GLint value ) ;
+GL-FUNCTION: void glFramebufferTextureLayerARB { glFramebufferTextureLayerEXT }
+ ( GLenum target, GLenum attachment, GLuint texture, GLint level, GLint layer ) ;
+GL-FUNCTION: void glFramebufferTextureFaceARB { glFramebufferTextureFaceEXT }
+ ( GLenum target, GLenum attachment, GLuint texture, GLint level, GLenum face ) ;
+
+CONSTANT: GL_MAX_GEOMETRY_VARYING_COMPONENTS_ARB HEX: 8DDD
+CONSTANT: GL_MAX_VERTEX_VARYING_COMPONENTS_ARB HEX: 8DDE
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_ARB HEX: 8DA9
! GL_EXT_framebuffer_object
CONSTANT: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14
CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15
+
! GL_EXT_texture_integer
CONSTANT: GL_ALPHA32UI_EXT HEX: 8D72
GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
+
! GL_EXT_texture_compression_s3tc, GL_EXT_texture_compression_dxt1
CONSTANT: GL_COMPRESSED_RGB_S3TC_DXT1_EXT HEX: 83F0
CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT3_EXT HEX: 83F2
CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT5_EXT HEX: 83F3
+
! GL_EXT_texture_compression_latc
CONSTANT: GL_COMPRESSED_LUMINANCE_LATC1_EXT HEX: 8C70
ALIAS: GL_TRIANGLES gl:GL_TRIANGLES
ALIAS: GL_TRIANGLE_STRIP gl:GL_TRIANGLE_STRIP
ALIAS: GL_TRIANGLE_FAN gl:GL_TRIANGLE_FAN
+ALIAS: GL_QUADS gl:GL_QUADS
ALIAS: GL_NEVER gl:GL_NEVER
ALIAS: GL_LESS gl:GL_LESS
ALIAS: GL_EQUAL gl:GL_EQUAL
ALIAS: GL_DYNAMIC_READ gl:GL_DYNAMIC_READ
ALIAS: GL_DYNAMIC_COPY gl:GL_DYNAMIC_COPY
ALIAS: GL_SAMPLES_PASSED gl:GL_SAMPLES_PASSED
+ALIAS: GL_SRC1_ALPHA gl:GL_SRC1_ALPHA
ALIAS: GL_BLEND_EQUATION_RGB gl:GL_BLEND_EQUATION_RGB
ALIAS: GL_VERTEX_ATTRIB_ARRAY_ENABLED gl:GL_VERTEX_ATTRIB_ARRAY_ENABLED
ALIAS: GL_VERTEX_ATTRIB_ARRAY_SIZE gl:GL_VERTEX_ATTRIB_ARRAY_SIZE
ALIAS: GL_UNIFORM_BLOCK_REFERENCED_BY_VERTEX_SHADER gl:GL_UNIFORM_BLOCK_REFERENCED_BY_VERTEX_SHADER
ALIAS: GL_UNIFORM_BLOCK_REFERENCED_BY_FRAGMENT_SHADER gl:GL_UNIFORM_BLOCK_REFERENCED_BY_FRAGMENT_SHADER
ALIAS: GL_INVALID_INDEX gl:GL_INVALID_INDEX
+ALIAS: GL_CONTEXT_CORE_PROFILE_BIT gl:GL_CONTEXT_CORE_PROFILE_BIT
+ALIAS: GL_CONTEXT_COMPATIBILITY_PROFILE_BIT gl:GL_CONTEXT_COMPATIBILITY_PROFILE_BIT
+ALIAS: GL_LINES_ADJACENCY gl:GL_LINES_ADJACENCY
+ALIAS: GL_LINE_STRIP_ADJACENCY gl:GL_LINE_STRIP_ADJACENCY
+ALIAS: GL_TRIANGLES_ADJACENCY gl:GL_TRIANGLES_ADJACENCY
+ALIAS: GL_TRIANGLE_STRIP_ADJACENCY gl:GL_TRIANGLE_STRIP_ADJACENCY
+ALIAS: GL_PROGRAM_POINT_SIZE gl:GL_PROGRAM_POINT_SIZE
+ALIAS: GL_GEOMETRY_VERTICES_OUT gl:GL_GEOMETRY_VERTICES_OUT
+ALIAS: GL_GEOMETRY_INPUT_TYPE gl:GL_GEOMETRY_INPUT_TYPE
+ALIAS: GL_GEOMETRY_OUTPUT_TYPE gl:GL_GEOMETRY_OUTPUT_TYPE
+ALIAS: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS gl:GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_LAYERED gl:GL_FRAMEBUFFER_ATTACHMENT_LAYERED
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS gl:GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS
+ALIAS: GL_GEOMETRY_SHADER gl:GL_GEOMETRY_SHADER
+ALIAS: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS gl:GL_MAX_GEOMETRY_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_GEOMETRY_OUTPUT_VERTICES gl:GL_MAX_GEOMETRY_OUTPUT_VERTICES
+ALIAS: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS gl:GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS
+ALIAS: GL_MAX_VERTEX_OUTPUT_COMPONENTS gl:GL_MAX_VERTEX_OUTPUT_COMPONENTS
+ALIAS: GL_MAX_GEOMETRY_INPUT_COMPONENTS gl:GL_MAX_GEOMETRY_INPUT_COMPONENTS
+ALIAS: GL_MAX_GEOMETRY_OUTPUT_COMPONENTS gl:GL_MAX_GEOMETRY_OUTPUT_COMPONENTS
+ALIAS: GL_MAX_FRAGMENT_INPUT_COMPONENTS gl:GL_MAX_FRAGMENT_INPUT_COMPONENTS
+ALIAS: GL_CONTEXT_PROFILE_MASK gl:GL_CONTEXT_PROFILE_MASK
+ALIAS: GL_MAX_SERVER_WAIT_TIMEOUT gl:GL_MAX_SERVER_WAIT_TIMEOUT
+ALIAS: GL_OBJECT_TYPE gl:GL_OBJECT_TYPE
+ALIAS: GL_SYNC_CONDITION gl:GL_SYNC_CONDITION
+ALIAS: GL_SYNC_STATUS gl:GL_SYNC_STATUS
+ALIAS: GL_SYNC_FLAGS gl:GL_SYNC_FLAGS
+ALIAS: GL_SYNC_FENCE gl:GL_SYNC_FENCE
+ALIAS: GL_SYNC_GPU_COMMANDS_COMPLETE gl:GL_SYNC_GPU_COMMANDS_COMPLETE
+ALIAS: GL_UNSIGNALED gl:GL_UNSIGNALED
+ALIAS: GL_SIGNALED gl:GL_SIGNALED
+ALIAS: GL_ALREADY_SIGNALED gl:GL_ALREADY_SIGNALED
+ALIAS: GL_TIMEOUT_EXPIRED gl:GL_TIMEOUT_EXPIRED
+ALIAS: GL_CONDITION_SATISFIED gl:GL_CONDITION_SATISFIED
+ALIAS: GL_WAIT_FAILED gl:GL_WAIT_FAILED
+ALIAS: GL_SYNC_FLUSH_COMMANDS_BIT gl:GL_SYNC_FLUSH_COMMANDS_BIT
+ALIAS: GL_TIMEOUT_IGNORED gl:GL_TIMEOUT_IGNORED
+ALIAS: GL_SAMPLE_POSITION gl:GL_SAMPLE_POSITION
+ALIAS: GL_SAMPLE_MASK gl:GL_SAMPLE_MASK
+ALIAS: GL_SAMPLE_MASK_VALUE gl:GL_SAMPLE_MASK_VALUE
+ALIAS: GL_MAX_SAMPLE_MASK_WORDS gl:GL_MAX_SAMPLE_MASK_WORDS
+ALIAS: GL_TEXTURE_2D_MULTISAMPLE gl:GL_TEXTURE_2D_MULTISAMPLE
+ALIAS: GL_PROXY_TEXTURE_2D_MULTISAMPLE gl:GL_PROXY_TEXTURE_2D_MULTISAMPLE
+ALIAS: GL_TEXTURE_2D_MULTISAMPLE_ARRAY gl:GL_TEXTURE_2D_MULTISAMPLE_ARRAY
+ALIAS: GL_PROXY_TEXTURE_2D_MULTISAMPLE_ARRAY gl:GL_PROXY_TEXTURE_2D_MULTISAMPLE_ARRAY
+ALIAS: GL_TEXTURE_BINDING_2D_MULTISAMPLE gl:GL_TEXTURE_BINDING_2D_MULTISAMPLE
+ALIAS: GL_TEXTURE_BINDING_2D_MULTISAMPLE_ARRAY gl:GL_TEXTURE_BINDING_2D_MULTISAMPLE_ARRAY
+ALIAS: GL_TEXTURE_SAMPLES gl:GL_TEXTURE_SAMPLES
+ALIAS: GL_TEXTURE_FIXED_SAMPLE_LOCATIONS gl:GL_TEXTURE_FIXED_SAMPLE_LOCATIONS
+ALIAS: GL_SAMPLER_2D_MULTISAMPLE gl:GL_SAMPLER_2D_MULTISAMPLE
+ALIAS: GL_INT_SAMPLER_2D_MULTISAMPLE gl:GL_INT_SAMPLER_2D_MULTISAMPLE
+ALIAS: GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE gl:GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE
+ALIAS: GL_SAMPLER_2D_MULTISAMPLE_ARRAY gl:GL_SAMPLER_2D_MULTISAMPLE_ARRAY
+ALIAS: GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY gl:GL_INT_SAMPLER_2D_MULTISAMPLE_ARRAY
+ALIAS: GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY gl:GL_UNSIGNED_INT_SAMPLER_2D_MULTISAMPLE_ARRAY
+ALIAS: GL_MAX_COLOR_TEXTURE_SAMPLES gl:GL_MAX_COLOR_TEXTURE_SAMPLES
+ALIAS: GL_MAX_DEPTH_TEXTURE_SAMPLES gl:GL_MAX_DEPTH_TEXTURE_SAMPLES
+ALIAS: GL_MAX_INTEGER_SAMPLES gl:GL_MAX_INTEGER_SAMPLES
+ALIAS: GL_DEPTH_CLAMP gl:GL_DEPTH_CLAMP
+ALIAS: GL_QUADS_FOLLOW_PROVOKING_VERTEX_CONVENTION gl:GL_QUADS_FOLLOW_PROVOKING_VERTEX_CONVENTION
+ALIAS: GL_FIRST_VERTEX_CONVENTION gl:GL_FIRST_VERTEX_CONVENTION
+ALIAS: GL_LAST_VERTEX_CONVENTION gl:GL_LAST_VERTEX_CONVENTION
+ALIAS: GL_PROVOKING_VERTEX gl:GL_PROVOKING_VERTEX
+ALIAS: GL_TEXTURE_CUBE_MAP_SEAMLESS gl:GL_TEXTURE_CUBE_MAP_SEAMLESS
+ALIAS: GL_SRC1_COLOR gl:GL_SRC1_COLOR
+ALIAS: GL_ONE_MINUS_SRC1_COLOR gl:GL_ONE_MINUS_SRC1_COLOR
+ALIAS: GL_ONE_MINUS_SRC1_ALPHA gl:GL_ONE_MINUS_SRC1_ALPHA
+ALIAS: GL_MAX_DUAL_SOURCE_DRAW_BUFFERS gl:GL_MAX_DUAL_SOURCE_DRAW_BUFFERS
+ALIAS: GL_ANY_SAMPLES_PASSED gl:GL_ANY_SAMPLES_PASSED
+ALIAS: GL_SAMPLER_BINDING gl:GL_SAMPLER_BINDING
+ALIAS: GL_RGB10_A2UI gl:GL_RGB10_A2UI
+ALIAS: GL_TEXTURE_SWIZZLE_R gl:GL_TEXTURE_SWIZZLE_R
+ALIAS: GL_TEXTURE_SWIZZLE_G gl:GL_TEXTURE_SWIZZLE_G
+ALIAS: GL_TEXTURE_SWIZZLE_B gl:GL_TEXTURE_SWIZZLE_B
+ALIAS: GL_TEXTURE_SWIZZLE_A gl:GL_TEXTURE_SWIZZLE_A
+ALIAS: GL_TEXTURE_SWIZZLE_RGBA gl:GL_TEXTURE_SWIZZLE_RGBA
+ALIAS: GL_TIME_ELAPSED gl:GL_TIME_ELAPSED
+ALIAS: GL_TIMESTAMP gl:GL_TIMESTAMP
+ALIAS: GL_INT_2_10_10_10_REV gl:GL_INT_2_10_10_10_REV
+ALIAS: GL_DRAW_INDIRECT_BUFFER gl:GL_DRAW_INDIRECT_BUFFER
+ALIAS: GL_DRAW_INDIRECT_BUFFER_BINDING gl:GL_DRAW_INDIRECT_BUFFER_BINDING
+ALIAS: GL_GEOMETRY_SHADER_INVOCATIONS gl:GL_GEOMETRY_SHADER_INVOCATIONS
+ALIAS: GL_MAX_GEOMETRY_SHADER_INVOCATIONS gl:GL_MAX_GEOMETRY_SHADER_INVOCATIONS
+ALIAS: GL_MIN_FRAGMENT_INTERPOLATION_OFFSET gl:GL_MIN_FRAGMENT_INTERPOLATION_OFFSET
+ALIAS: GL_MAX_FRAGMENT_INTERPOLATION_OFFSET gl:GL_MAX_FRAGMENT_INTERPOLATION_OFFSET
+ALIAS: GL_FRAGMENT_INTERPOLATION_OFFSET_BITS gl:GL_FRAGMENT_INTERPOLATION_OFFSET_BITS
+ALIAS: GL_MAX_VERTEX_STREAMS gl:GL_MAX_VERTEX_STREAMS
+ALIAS: GL_DOUBLE_VEC2 gl:GL_DOUBLE_VEC2
+ALIAS: GL_DOUBLE_VEC3 gl:GL_DOUBLE_VEC3
+ALIAS: GL_DOUBLE_VEC4 gl:GL_DOUBLE_VEC4
+ALIAS: GL_DOUBLE_MAT2 gl:GL_DOUBLE_MAT2
+ALIAS: GL_DOUBLE_MAT3 gl:GL_DOUBLE_MAT3
+ALIAS: GL_DOUBLE_MAT4 gl:GL_DOUBLE_MAT4
+ALIAS: GL_DOUBLE_MAT2x3 gl:GL_DOUBLE_MAT2x3
+ALIAS: GL_DOUBLE_MAT2x4 gl:GL_DOUBLE_MAT2x4
+ALIAS: GL_DOUBLE_MAT3x2 gl:GL_DOUBLE_MAT3x2
+ALIAS: GL_DOUBLE_MAT3x4 gl:GL_DOUBLE_MAT3x4
+ALIAS: GL_DOUBLE_MAT4x2 gl:GL_DOUBLE_MAT4x2
+ALIAS: GL_DOUBLE_MAT4x3 gl:GL_DOUBLE_MAT4x3
+ALIAS: GL_ACTIVE_SUBROUTINES gl:GL_ACTIVE_SUBROUTINES
+ALIAS: GL_ACTIVE_SUBROUTINE_UNIFORMS gl:GL_ACTIVE_SUBROUTINE_UNIFORMS
+ALIAS: GL_ACTIVE_SUBROUTINE_UNIFORM_LOCATIONS gl:GL_ACTIVE_SUBROUTINE_UNIFORM_LOCATIONS
+ALIAS: GL_ACTIVE_SUBROUTINE_MAX_LENGTH gl:GL_ACTIVE_SUBROUTINE_MAX_LENGTH
+ALIAS: GL_ACTIVE_SUBROUTINE_UNIFORM_MAX_LENGTH gl:GL_ACTIVE_SUBROUTINE_UNIFORM_MAX_LENGTH
+ALIAS: GL_MAX_SUBROUTINES gl:GL_MAX_SUBROUTINES
+ALIAS: GL_MAX_SUBROUTINE_UNIFORM_LOCATIONS gl:GL_MAX_SUBROUTINE_UNIFORM_LOCATIONS
+ALIAS: GL_NUM_COMPATIBLE_SUBROUTINES gl:GL_NUM_COMPATIBLE_SUBROUTINES
+ALIAS: GL_COMPATIBLE_SUBROUTINES gl:GL_COMPATIBLE_SUBROUTINES
+ALIAS: GL_PATCHES gl:GL_PATCHES
+ALIAS: GL_PATCH_VERTICES gl:GL_PATCH_VERTICES
+ALIAS: GL_PATCH_DEFAULT_INNER_LEVEL gl:GL_PATCH_DEFAULT_INNER_LEVEL
+ALIAS: GL_PATCH_DEFAULT_OUTER_LEVEL gl:GL_PATCH_DEFAULT_OUTER_LEVEL
+ALIAS: GL_TESS_CONTROL_OUTPUT_VERTICES gl:GL_TESS_CONTROL_OUTPUT_VERTICES
+ALIAS: GL_TESS_GEN_MODE gl:GL_TESS_GEN_MODE
+ALIAS: GL_TESS_GEN_SPACING gl:GL_TESS_GEN_SPACING
+ALIAS: GL_TESS_GEN_VERTEX_ORDER gl:GL_TESS_GEN_VERTEX_ORDER
+ALIAS: GL_TESS_GEN_POINT_MODE gl:GL_TESS_GEN_POINT_MODE
+ALIAS: GL_ISOLINES gl:GL_ISOLINES
+ALIAS: GL_FRACTIONAL_ODD gl:GL_FRACTIONAL_ODD
+ALIAS: GL_FRACTIONAL_EVEN gl:GL_FRACTIONAL_EVEN
+ALIAS: GL_MAX_PATCH_VERTICES gl:GL_MAX_PATCH_VERTICES
+ALIAS: GL_MAX_TESS_GEN_LEVEL gl:GL_MAX_TESS_GEN_LEVEL
+ALIAS: GL_MAX_TESS_CONTROL_UNIFORM_COMPONENTS gl:GL_MAX_TESS_CONTROL_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_TESS_EVALUATION_UNIFORM_COMPONENTS gl:GL_MAX_TESS_EVALUATION_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_TESS_CONTROL_TEXTURE_IMAGE_UNITS gl:GL_MAX_TESS_CONTROL_TEXTURE_IMAGE_UNITS
+ALIAS: GL_MAX_TESS_EVALUATION_TEXTURE_IMAGE_UNITS gl:GL_MAX_TESS_EVALUATION_TEXTURE_IMAGE_UNITS
+ALIAS: GL_MAX_TESS_CONTROL_OUTPUT_COMPONENTS gl:GL_MAX_TESS_CONTROL_OUTPUT_COMPONENTS
+ALIAS: GL_MAX_TESS_PATCH_COMPONENTS gl:GL_MAX_TESS_PATCH_COMPONENTS
+ALIAS: GL_MAX_TESS_CONTROL_TOTAL_OUTPUT_COMPONENTS gl:GL_MAX_TESS_CONTROL_TOTAL_OUTPUT_COMPONENTS
+ALIAS: GL_MAX_TESS_EVALUATION_OUTPUT_COMPONENTS gl:GL_MAX_TESS_EVALUATION_OUTPUT_COMPONENTS
+ALIAS: GL_MAX_TESS_CONTROL_UNIFORM_BLOCKS gl:GL_MAX_TESS_CONTROL_UNIFORM_BLOCKS
+ALIAS: GL_MAX_TESS_EVALUATION_UNIFORM_BLOCKS gl:GL_MAX_TESS_EVALUATION_UNIFORM_BLOCKS
+ALIAS: GL_MAX_TESS_CONTROL_INPUT_COMPONENTS gl:GL_MAX_TESS_CONTROL_INPUT_COMPONENTS
+ALIAS: GL_MAX_TESS_EVALUATION_INPUT_COMPONENTS gl:GL_MAX_TESS_EVALUATION_INPUT_COMPONENTS
+ALIAS: GL_MAX_COMBINED_TESS_CONTROL_UNIFORM_COMPONENTS gl:GL_MAX_COMBINED_TESS_CONTROL_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_COMBINED_TESS_EVALUATION_UNIFORM_COMPONENTS gl:GL_MAX_COMBINED_TESS_EVALUATION_UNIFORM_COMPONENTS
+ALIAS: GL_UNIFORM_BLOCK_REFERENCED_BY_TESS_CONTROL_SHADER gl:GL_UNIFORM_BLOCK_REFERENCED_BY_TESS_CONTROL_SHADER
+ALIAS: GL_UNIFORM_BLOCK_REFERENCED_BY_TESS_EVALUATION_SHADER gl:GL_UNIFORM_BLOCK_REFERENCED_BY_TESS_EVALUATION_SHADER
+ALIAS: GL_TESS_EVALUATION_SHADER gl:GL_TESS_EVALUATION_SHADER
+ALIAS: GL_TESS_CONTROL_SHADER gl:GL_TESS_CONTROL_SHADER
+ALIAS: GL_TRANSFORM_FEEDBACK gl:GL_TRANSFORM_FEEDBACK
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_PAUSED gl:GL_TRANSFORM_FEEDBACK_BUFFER_PAUSED
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_ACTIVE gl:GL_TRANSFORM_FEEDBACK_BUFFER_ACTIVE
+ALIAS: GL_TRANSFORM_FEEDBACK_BINDING gl:GL_TRANSFORM_FEEDBACK_BINDING
+ALIAS: GL_MAX_TRANSFORM_FEEDBACK_BUFFERS gl:GL_MAX_TRANSFORM_FEEDBACK_BUFFERS
ALIAS: glCullFace gl:glCullFace
ALIAS: glFrontFace gl:glFrontFace
ALIAS: glGetActiveUniformBlockName gl:glGetActiveUniformBlockName
ALIAS: glUniformBlockBinding gl:glUniformBlockBinding
ALIAS: glCopyBufferSubData gl:glCopyBufferSubData
+ALIAS: glFramebufferTexture gl:glFramebufferTexture
+ALIAS: glGetBufferParameteri64v gl:glGetBufferParameteri64v
+ALIAS: glGetInteger64i_v gl:glGetInteger64i_v
+ALIAS: glProvokingVertex gl:glProvokingVertex
+ALIAS: glFenceSync gl:glFenceSync
+ALIAS: glIsSync gl:glIsSync
+ALIAS: glDeleteSync gl:glDeleteSync
+ALIAS: glClientWaitSync gl:glClientWaitSync
+ALIAS: glWaitSync gl:glWaitSync
+ALIAS: glGetInteger64v gl:glGetInteger64v
+ALIAS: glGetSynciv gl:glGetSynciv
+ALIAS: glTexImage2DMultisample gl:glTexImage2DMultisample
+ALIAS: glTexImage3DMultisample gl:glTexImage3DMultisample
+ALIAS: glGetMultisamplefv gl:glGetMultisamplefv
+ALIAS: glSampleMaski gl:glSampleMaski
+ALIAS: glBindFragDataLocationIndexed gl:glBindFragDataLocationIndexed
+ALIAS: glGetFragDataIndex gl:glGetFragDataIndex
+ALIAS: glGenSamplers gl:glGenSamplers
+ALIAS: glDeleteSamplers gl:glDeleteSamplers
+ALIAS: glIsSampler gl:glIsSampler
+ALIAS: glBindSampler gl:glBindSampler
+ALIAS: glSamplerParameteri gl:glSamplerParameteri
+ALIAS: glSamplerParameteriv gl:glSamplerParameteriv
+ALIAS: glSamplerParameterf gl:glSamplerParameterf
+ALIAS: glSamplerParameterfv gl:glSamplerParameterfv
+ALIAS: glSamplerParameterIiv gl:glSamplerParameterIiv
+ALIAS: glSamplerParameterIuiv gl:glSamplerParameterIuiv
+ALIAS: glGetSamplerParameteriv gl:glGetSamplerParameteriv
+ALIAS: glGetSamplerParameterIiv gl:glGetSamplerParameterIiv
+ALIAS: glGetSamplerParameterfv gl:glGetSamplerParameterfv
+ALIAS: glGetSamplerParameterIfv gl:glGetSamplerParameterIfv
+ALIAS: glQueryCounter gl:glQueryCounter
+ALIAS: glGetQueryObjecti64v gl:glGetQueryObjecti64v
+ALIAS: glGetQueryObjectui64v gl:glGetQueryObjectui64v
+ALIAS: glVertexAttribP1ui gl:glVertexAttribP1ui
+ALIAS: glVertexAttribP1uiv gl:glVertexAttribP1uiv
+ALIAS: glVertexAttribP2ui gl:glVertexAttribP2ui
+ALIAS: glVertexAttribP2uiv gl:glVertexAttribP2uiv
+ALIAS: glVertexAttribP3ui gl:glVertexAttribP3ui
+ALIAS: glVertexAttribP3uiv gl:glVertexAttribP3uiv
+ALIAS: glVertexAttribP4ui gl:glVertexAttribP4ui
+ALIAS: glVertexAttribP4uiv gl:glVertexAttribP4uiv
+ALIAS: glUniform1d gl:glUniform1d
+ALIAS: glUniform2d gl:glUniform2d
+ALIAS: glUniform3d gl:glUniform3d
+ALIAS: glUniform4d gl:glUniform4d
+ALIAS: glUniform1dv gl:glUniform1dv
+ALIAS: glUniform2dv gl:glUniform2dv
+ALIAS: glUniform3dv gl:glUniform3dv
+ALIAS: glUniform4dv gl:glUniform4dv
+ALIAS: glUniformMatrix2dv gl:glUniformMatrix2dv
+ALIAS: glUniformMatrix3dv gl:glUniformMatrix3dv
+ALIAS: glUniformMatrix4dv gl:glUniformMatrix4dv
+ALIAS: glUniformMatrix2x3dv gl:glUniformMatrix2x3dv
+ALIAS: glUniformMatrix2x4dv gl:glUniformMatrix2x4dv
+ALIAS: glUniformMatrix3x2dv gl:glUniformMatrix3x2dv
+ALIAS: glUniformMatrix3x4dv gl:glUniformMatrix3x4dv
+ALIAS: glUniformMatrix4x2dv gl:glUniformMatrix4x2dv
+ALIAS: glUniformMatrix4x3dv gl:glUniformMatrix4x3dv
+ALIAS: glGetUniformdv gl:glGetUniformdv
+ALIAS: glProgramUniform1dEXT gl:glProgramUniform1dEXT
+ALIAS: glProgramUniform2dEXT gl:glProgramUniform2dEXT
+ALIAS: glProgramUniform3dEXT gl:glProgramUniform3dEXT
+ALIAS: glProgramUniform4dEXT gl:glProgramUniform4dEXT
+ALIAS: glProgramUniform1dvEXT gl:glProgramUniform1dvEXT
+ALIAS: glProgramUniform2dvEXT gl:glProgramUniform2dvEXT
+ALIAS: glProgramUniform3dvEXT gl:glProgramUniform3dvEXT
+ALIAS: glProgramUniform4dvEXT gl:glProgramUniform4dvEXT
+ALIAS: glProgramUniformMatrix2dvEXT gl:glProgramUniformMatrix2dvEXT
+ALIAS: glProgramUniformMatrix3dvEXT gl:glProgramUniformMatrix3dvEXT
+ALIAS: glProgramUniformMatrix4dvEXT gl:glProgramUniformMatrix4dvEXT
+ALIAS: glProgramUniformMatrix2x3dvEXT gl:glProgramUniformMatrix2x3dvEXT
+ALIAS: glProgramUniformMatrix2x4dvEXT gl:glProgramUniformMatrix2x4dvEXT
+ALIAS: glProgramUniformMatrix3x2dvEXT gl:glProgramUniformMatrix3x2dvEXT
+ALIAS: glProgramUniformMatrix3x4dvEXT gl:glProgramUniformMatrix3x4dvEXT
+ALIAS: glProgramUniformMatrix4x2dvEXT gl:glProgramUniformMatrix4x2dvEXT
+ALIAS: glProgramUniformMatrix4x3dvEXT gl:glProgramUniformMatrix4x3dvEXT
+ALIAS: glGetSubroutineUniformLocation gl:glGetSubroutineUniformLocation
+ALIAS: glGetSubroutineIndex gl:glGetSubroutineIndex
+ALIAS: glGetActiveSubroutineUniformiv gl:glGetActiveSubroutineUniformiv
+ALIAS: glGetActiveSubroutineUniformName gl:glGetActiveSubroutineUniformName
+ALIAS: glGetActiveSubroutineName gl:glGetActiveSubroutineName
+ALIAS: glUniformSubroutinesuiv gl:glUniformSubroutinesuiv
+ALIAS: glGetUniformSubroutineuiv gl:glGetUniformSubroutineuiv
+ALIAS: glGetProgramStageiv gl:glGetProgramStageiv
+ALIAS: glPatchParameteri gl:glPatchParameteri
+ALIAS: glPatchParameterfv gl:glPatchParameterfv
+ALIAS: glBindTransformFeedback gl:glBindTransformFeedback
+ALIAS: glDeleteTransformFeedbacks gl:glDeleteTransformFeedbacks
+ALIAS: glGenTransformFeedbacks gl:glGenTransformFeedbacks
+ALIAS: glIsTransformFeedback gl:glIsTransformFeedback
+ALIAS: glPauseTransformFeedback gl:glPauseTransformFeedback
+ALIAS: glResumeTransformFeedback gl:glResumeTransformFeedback
+ALIAS: glDrawTransformFeedback gl:glDrawTransformFeedback
+ALIAS: glDrawTransformFeedbackStream gl:glDrawTransformFeedbackStream
+ALIAS: glBeginQueryIndexed gl:glBeginQueryIndexed
+ALIAS: glEndQueryIndexed gl:glEndQueryIndexed
+ALIAS: glGetQueryIndexediv gl:glGetQueryIndexediv
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache colors.constants destructors
kernel opengl opengl.gl opengl.capabilities combinators images
images.tesselation grouping sequences math math.vectors
-math.matrices generalizations fry arrays namespaces system
+generalizations fry arrays namespaces system
locals literals specialized-arrays ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
: image-locs ( image-grid -- loc-grid )
[ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
[ 0 [ + ] accumulate nip ] bi@
- cross-zip flip ;
+ cartesian-product flip ;
: <texture-grid> ( image-grid loc -- grid )
[ dup image-locs ] dip
sets unicode.categories compiler.units parser effects.parser
words quotations memoize accessors locals splitting
combinators.short-circuit generalizations ;
+FROM: namespaces => set ;
IN: peg
TUPLE: parse-result remaining ast ;
io.pathnames io.styles kernel make math math.order math.parser
namespaces prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.stylesheet quotations sbufs
-sequences strings vectors words words.symbol ;
+sequences strings vectors words words.symbol hash-sets ;
+FROM: sets => members ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
M: tuple pprint-delims drop \ T{ \ } ;
M: wrapper pprint-delims drop \ W{ \ } ;
M: callstack pprint-delims drop \ CS{ \ } ;
+M: hash-set pprint-delims drop \ HS{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
M: wrapper >pprint-sequence wrapped>> 1array ;
M: callstack >pprint-sequence callstack>array ;
+M: hash-set >pprint-sequence members ;
: class-slot-sequence ( class slots -- sequence )
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
M: hashtable pprint* pprint-object ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
+M: hash-set pprint* pprint-object ;
M: wrapper pprint*
{
2 nesting-limit set
string-limit? on
boa-tuples? on
- c-object-pointers? on
+ c-object-pointers? off
call
] with-scope ; inline
parser prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections quotations sequences sorting strings vocabs
vocabs.prettyprint words sets generic ;
+FROM: namespaces => set ;
IN: prettyprint
: with-use ( obj quot -- )
namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
accessors sets vocabs.parser combinators vocabs ;
+FROM: namespaces => set ;
IN: prettyprint.sections
! State
[ t ] [ 10000 [ iota 0 [ drop 187 random + ] reduce ] keep / 2 * 187 10 ~ ] unit-test
[ t ] [ 10000 [ iota 0 [ drop 400 random + ] reduce ] keep / 2 * 400 10 ~ ] unit-test
-[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
+[ t ] [ 1000 [ 400 random ] replicate members length 256 > ] unit-test
[ f ] [ 0 random ] unit-test
[ { 1 2 } 3 sample ] [ too-many-samples? ] must-fail-with
-[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
-[ 99 ] [ 100 iota 99 sample prune length ] unit-test
+[ 3 ] [ { 1 2 3 4 } 3 sample members length ] unit-test
+[ 99 ] [ 100 iota 99 sample members length ] unit-test
[ ]
[ [ 100 random-bytes ] with-system-random drop ] unit-test
! Making classes into nested conditionals
-[ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
+[ { 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
[ { 3 } ] [ { { 3 t } } table>condition ] unit-test
[ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test
[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test
fry macros arrays assocs sets classes mirrors unicode.script
unicode.data ;
FROM: ascii => ascii? ;
+FROM: sets => members ;
IN: regexp.classes
SINGLETONS: dot letter-class LETTER-class Letter-class digit-class
TUPLE: class-partition integers not-integers simples not-simples and or other ;
: partition-classes ( seq -- class-partition )
- prune
+ members
[ integer? ] partition
[ not-integer? ] partition
[ simple-class? ] partition
[ t swap remove ] change-other
dup contradiction?
[ drop f ]
- [ filter-not-integers class-partition>seq prune t and-class seq>instance ] if ;
+ [ filter-not-integers class-partition>seq members t and-class seq>instance ] if ;
: <and-class> ( seq -- class )
dup and-class flatten partition-classes
[ f swap remove ] change-other
dup tautology?
[ drop t ]
- [ filter-integers class-partition>seq prune f or-class seq>instance ] if ;
+ [ filter-integers class-partition>seq members f or-class seq>instance ] if ;
: <or-class> ( seq -- class )
dup or-class flatten partition-classes
: condition-states ( condition -- states )
dup condition? [
[ yes>> ] [ no>> ] bi
- [ condition-states ] bi@ append prune
+ [ condition-states ] bi@ union
] [ 1array ] if ;
: condition-at ( condition assoc -- new-condition )
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: regexp.classes kernel sequences regexp.negation
-quotations assocs fry math locals combinators
+quotations assocs fry math locals combinators sets
accessors words compiler.units kernel.private strings
sequences.private arrays namespaces unicode.breaks
regexp.transition-tables combinators.short-circuit ;
: word>quot ( word dfa -- quot )
[ transitions>> at ]
- [ final-states>> key? ] 2bi
+ [ final-states>> in? ] 2bi
transitions>quot ;
: states>code ( words dfa -- )
: set-final-states ( nfa dfa -- )
[
- [ final-states>> keys ]
+ [ final-states>> members ]
[ transitions>> keys ] bi*
[ intersects? ] with filter
- unique
+ fast-set
] keep (>>final-states) ;
: initialize-dfa ( nfa -- dfa )
{ 3 H{ } }
} }
{ start-state 0 }
- { final-states H{ { 3 3 } } }
+ { final-states HS{ 3 } }
}
] [
T{ transition-table
{ 6 H{ } }
} }
{ start-state 0 }
- { final-states H{ { 3 3 } { 6 6 } } }
+ { final-states HS{ 3 6 } }
} combine-states
] unit-test
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 )
{
[ drop <= ]
[ transitions>> '[ _ at keys ] bi@ set= ]
- [ final-states>> '[ _ key? ] bi@ = ]
+ [ final-states>> '[ _ in? ] bi@ = ]
} 3&& ;
:: initialize-partitions ( transition-table -- partitions )
<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 =
{ -1 H{ { t -1 } } }
} }
{ start-state 0 }
- { final-states H{ { 0 0 } { -1 -1 } } }
+ { final-states HS{ 0 -1 } }
}
] [
! R/ a/
{ 1 H{ } }
} }
{ start-state 0 }
- { final-states H{ { 1 1 } } }
+ { final-states HS{ 1 } }
} negate-table
] unit-test
USING: regexp.nfa regexp.disambiguate kernel sequences
assocs regexp.classes hashtables accessors fry vectors
regexp.ast regexp.transition-tables regexp.minimize
-regexp.dfa namespaces ;
+regexp.dfa namespaces sets ;
IN: regexp.negation
CONSTANT: fail-state -1
fail-state-recurses ;
: inverse-final-states ( transition-table -- final-states )
- [ transitions>> assoc>set ] [ final-states>> ] bi assoc-diff ;
+ [ transitions>> keys ] [ final-states>> ] bi diff fast-set ;
: negate-table ( transition-table -- transition-table )
clone
[ [ [ 1vector ] assoc-map ] assoc-map ] change-transitions ;
: unify-final-state ( transition-table -- transition-table )
- dup [ final-states>> keys ] keep
+ dup [ final-states>> members ] keep
'[ -2 epsilon _ set-transition ] each
- H{ { -2 -2 } } >>final-states ;
+ HS{ -2 } clone >>final-states ;
: adjoin-dfa ( transition-table -- start end )
unify-final-state renumber-states box-transitions
[ start-state>> ]
- [ final-states>> keys first ]
+ [ final-states>> members first ]
[ nfa-table get [ transitions>> ] bi@ swap assoc-union! drop ] tri ;
: ast>dfa ( parse-tree -- minimal-dfa )
unicode.categories regexp.transition-tables words sets hashtables
combinators.short-circuit unicode.data regexp.ast
regexp.classes memoize ;
+FROM: namespaces => set ;
IN: regexp.nfa
! This uses unicode.data for ch>upper and ch>lower
<transition-table> nfa-table set
nfa-node
nfa-table get
- swap dup associate >>final-states
+ swap 1array fast-set >>final-states
swap >>start-state
] with-scope ;
[ [ simple ] keep ] H{ } map>assoc ;
MEMO: simple-script-table ( -- table )
- script-table interval-values prune simple-table ;
+ script-table interval-values members simple-table ;
MEMO: simple-category-table ( -- table )
categories simple-table ;
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 )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry hashtables kernel sequences
-vectors locals regexp.classes ;
+vectors locals regexp.classes sets ;
IN: regexp.transition-tables
TUPLE: transition-table transitions start-state final-states ;
: <transition-table> ( -- transition-table )
transition-table new
H{ } clone >>transitions
- H{ } clone >>final-states ;
+ HS{ } clone >>final-states ;
:: (set-transition) ( from to obj hash -- )
from hash at
: add-transition ( from to obj transition-table -- )
transitions>> (add-transition) ;
-: map-set ( assoc quot -- new-assoc )
- '[ drop @ dup ] assoc-map ; inline
+: map-set ( set quot -- new-set )
+ over [ [ members ] dip map ] dip set-like ; inline
: number-transitions ( transitions numbering -- new-transitions )
dup '[
prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections sequences sets sorting strings summary words
words.symbol words.constant words.alias vocabs slots ;
+FROM: namespaces => set ;
+FROM: classes => members ;
+RENAME: members sets => set-members
IN: see
GENERIC: synopsis* ( defspec -- )
dup class? [ dup seeing-implementors % ] when
dup generic? [ dup seeing-methods % ] when
drop
- ] { } make prune ;
+ ] { } make set-members ;
: see-methods ( word -- )
methods see-all nl ;
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 )
] { } make <interval-map> ;
: process-interval-file ( ranges -- table )
- dup values prune interned
+ dup values members interned
[ expand-ranges ] with-variable ;
: load-interval-file ( filename -- table )
kernel logging sequences combinators splitting assocs strings
math.order math.parser random system calendar summary calendar.format
accessors sets hashtables base64 debugger classes prettyprint words ;
+FROM: namespaces => set ;
IN: smtp
SYMBOL: smtp-domain
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
M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ;
SYNTAX: SPECIALIZED-ARRAYS:
- ";" parse-tokens [ parse-c-type define-array-vocab use-vocab ] each ;
+ ";" [ parse-c-type define-array-vocab use-vocab ] each-token ;
SYNTAX: SPECIALIZED-ARRAY:
scan-c-type define-array-vocab use-vocab ;
generate-vocab ;
SYNTAX: SPECIALIZED-VECTORS:
- ";" parse-tokens [
+ ";" [
parse-c-type
[ define-array-vocab use-vocab ]
[ define-vector-vocab use-vocab ] bi
- ] each ;
+ ] each-token ;
SYNTAX: SPECIALIZED-VECTOR:
scan-c-type
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators math namespaces
-init sets words assocs alien.libraries alien alien.c-types
-cpu.architecture fry stack-checker.backend stack-checker.errors
-stack-checker.visitor stack-checker.dependencies ;
+init sets words assocs alien.libraries alien alien.private
+alien.c-types cpu.architecture fry stack-checker.backend
+stack-checker.errors stack-checker.visitor
+stack-checker.dependencies ;
IN: stack-checker.alien
TUPLE: alien-node-params return parameters abi in-d out-d ;
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
: push-d ( obj -- ) meta-d push ;
[ #introduce, ]
tri ;
+: update-inner-d ( new -- )
+ inner-d-index get min inner-d-index set ;
+
: pop-d ( -- obj )
- meta-d [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
+ meta-d
+ [ <value> dup 1array introduce-values ]
+ [ pop meta-d length update-inner-d ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
[ introduce-values ] [ meta-d push-all ] bi
meta-d push-all
- ] when swap tail* ;
+ ] when
+ swap from-end [ tail ] [ update-inner-d ] bi ;
: shorten-by ( n seq -- )
[ length swap - ] keep shorten ; inline
+: shorten-d ( n -- )
+ meta-d shorten-by meta-d length update-inner-d ;
+
: consume-d ( n -- seq )
- [ ensure-d ] [ meta-d shorten-by ] bi ;
+ [ ensure-d ] [ shorten-d ] bi ;
: output-d ( values -- ) meta-d push-all ;
: infer-r> ( n -- )
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
-: consume/produce ( effect quot: ( inputs outputs -- ) -- )
+: consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b )
'[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
[ terminated?>> [ terminate ] when ]
bi ; inline
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
combinators.short-circuit classes.tuple alien.c-types ;
FROM: classes.tuple.private => tuple-layout ;
FROM: assocs => change-at ;
+FROM: namespaces => set ;
IN: stack-checker.dependencies
! Words that the current quotation depends on
[ \ 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" ;
M: undeclared-recursion-error summary
word>> name>>
- "The inline recursive word " " must be declared recursive" surround ;
+ "The inline recursive word “" "” must be declared recursive" surround ;
M: diverging-recursion-error summary
word>> name>>
- "The recursive word " " digs arbitrarily deep into the stack" surround ;
+ "The recursive word “" "” digs arbitrarily deep into the stack" surround ;
M: unbalanced-recursion-error summary
word>> name>>
- "The recursive word " " leaves with the stack having the wrong height" surround ;
+ "The recursive word “" "” leaves with the stack having the wrong height" surround ;
M: inconsistent-recursive-call-error summary
word>> name>>
- "The recursive word "
- " calls itself with a different set of quotation parameters than were input" surround ;
+ "The recursive word “"
+ "” calls itself with a different set of quotation parameters than were input" surround ;
M: transform-expansion-error summary
- word>> name>> "Macro expansion of " " threw an error" surround ;
+ word>> name>> "Macro expansion of “" "” threw an error" surround ;
M: transform-expansion-error error.
[ summary print ]
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 “" "”" surround ;
+
+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 ;
\ set-special-object { object fixnum } { } define-primitive
+\ context-object { fixnum } { object } define-primitive
+\ context-object make-flushable
+
+\ set-context-object { object fixnum } { } define-primitive
+
\ (exists?) { string } { object } define-primitive
\ minor-gc { } { } define-primitive
--- /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.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 ;
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.values stack-checker.recursive-state
stack-checker.dependencies ;
+FROM: namespaces => set ;
IN: stack-checker.transforms
: call-transformer ( stack quot -- newquot )
:: ((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 ;
+
[ { } ]
[ SA{ } "something" swap query ] unit-test
-[ V{ "unit-test" "(unit-test)" } ]
+[ { "unit-test" "(unit-test)" } ]
[ "suffix-array" get "unit-test" swap query ] unit-test
[ t ]
[ "suffix-array" get "something else" swap query empty? ] unit-test
-[ V{ "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test
-[ V{ "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test
-[ V{ "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test
-[ V{ "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test
-[ V{ } ] [ SA{ "rofl" } "t" swap query ] unit-test
+[ { "rofl" } ] [ SA{ "rofl" } "r" swap query ] unit-test
+[ { "rofl" } ] [ SA{ "rofl" } "o" swap query ] unit-test
+[ { "rofl" } ] [ SA{ "rofl" } "f" swap query ] unit-test
+[ { "rofl" } ] [ SA{ "rofl" } "l" swap query ] unit-test
+[ { } ] [ SA{ "rofl" } "t" swap query ] unit-test
: query ( begin suffix-array -- matches )
2dup find-index dup
- [ -rot [ from-to ] keep <funky-slice> [ seq>> ] map prune ]
+ [ -rot [ from-to ] keep <funky-slice> [ seq>> ] map members ]
[ 3drop { } ] if ;
tri ;
: atom-entry-link ( tag -- url/f )
- "link" tags-named [ "rel" attr "alternate" = ] find nip
+ "link" tags-named
+ [ "rel" attr { f "alternate" } member? ] find nip
dup [ "href" attr >url ] when ;
: atom1.0-entry ( tag -- entry )
SYMBOL: deploy-name
SYMBOL: deploy-ui?
+SYMBOL: deploy-console?
SYMBOL: deploy-math?
SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
: default-config ( vocab -- assoc )
vocab-name deploy-name associate H{
{ deploy-ui? f }
+ { deploy-console? t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-threads? t }
QUALIFIED: source-files.errors
QUALIFIED: vocabs
FROM: alien.libraries.private => >deployed-library-path ;
+FROM: namespaces => set ;
+FROM: sets => members ;
IN: tools.deploy.shaker
! This file is some hairy shit.
: write-vocab-manifest ( vocab-manifest-out -- )
"Writing vocabulary manifest to " write dup print flush
vocabs "VOCABS:" prefix
- deploy-libraries get [ libraries get at path>> ] map prune "LIBRARIES:" prefix append
+ deploy-libraries get [ libraries get at path>> ] map members "LIBRARIES:" prefix append
swap utf8 set-file-lines ;
: prepare-deploy-libraries ( -- )
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dll
- deploy-ui? get ".exe" ".com" ? copy-vm ;
+ deploy-console? get ".exe" ".com" ? copy-vm ;
: open-in-explorer ( dir -- )
[ f "open" ] dip absolute-path normalize-separators
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 ] }
combinators sorting math.parser vocabs definitions
tools.profiler.private tools.crossref continuations generic
compiler.units compiler.crossref sets classes fry ;
+FROM: sets => members ;
IN: tools.profiler
: profile ( quot -- )
[ smart-usage [ word? ] filter ]
[ generic-call-sites-of keys ]
[ effect-dependencies-of keys ]
- tri 3append prune ;
+ tri 3append members ;
: usage-counters ( word -- alist )
profiler-usage counters ;
{ 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
windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes colors
specialized-arrays classes.struct alien.data ;
+FROM: namespaces => set ;
SPECIALIZED-ARRAY: POINT
IN: ui.backend.windows
tools.test namespaces models kernel dlists deques math
math.parser ui sequences hashtables assocs io arrays prettyprint
io.streams.string math.rectangles ui.gadgets.private sets generic ;
+FROM: namespaces => set ;
IN: ui.gadgets.tests
[ { 300 300 } ]
] each-integer ;
: status-flags ( -- seq )
- { "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
+ { "g" "1" "2" "3" } [ get graft-state>> ] map members ;
: notify-combo ( ? ? -- )
nl "===== Combo: " write 2dup 2array . nl
<dlist> \ graft-queue [
<mock-gadget> "g" set
[ ] [ add-some-children ] unit-test
- [ V{ { f f } } ] [ status-flags ] unit-test
+ [ { { f f } } ] [ status-flags ] unit-test
[ ] [ "g" get graft ] unit-test
- [ V{ { f t } } ] [ status-flags ] unit-test
+ [ { { f t } } ] [ status-flags ] unit-test
dup [ [ ] [ notify-queued ] unit-test ] when
[ ] [ "g" get clear-gadget ] unit-test
[ [ t ] [ graft-queue [ front>> ] [ back>> ] bi eq? ] unit-test ] unless
[ { f t } ] [ "3" get graft-state>> ] unit-test
[ ] [ graft-queue [ "x" print notify ] slurp-deque ] unit-test
[ ] [ notify-queued ] unit-test
- [ V{ { t t } } ] [ status-flags ] unit-test
+ [ { { t t } } ] [ status-flags ] unit-test
] with-variable ;
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.matrices namespaces
-make sequences words io math.vectors ui.gadgets
-ui.baseline-alignment columns accessors strings.tables
-math.rectangles fry ;
+USING: arrays kernel math math.order namespaces make sequences
+words io math.vectors ui.gadgets ui.baseline-alignment columns
+accessors strings.tables math.rectangles fry ;
IN: ui.gadgets.grids
TUPLE: grid < gadget
: (compute-cell-locs) ( grid-layout -- locs )
[ accumulate-cell-xs nip ]
[ accumulate-cell-ys nip ]
- bi cross-zip flip ;
+ bi cartesian-product flip ;
: adjust-for-baseline ( row-locs row-cells -- row-locs' )
align-baselines [ 0 swap 2array v+ ] 2map ;
: cell-dims ( grid-layout -- dims )
dup fill?>>
- [ [ column-widths>> ] [ row-heights>> ] bi cross-zip flip ]
+ [ [ column-widths>> ] [ row-heights>> ] bi cartesian-product flip ]
[ grid>> [ [ pref-dim>> ] map ] map ]
if ;
}
TUPLE: world < track
- active? focused? grab-input?
+ active? focused? grab-input? fullscreen?
+ saved-position
layers
title status status-owner
text-handle handle images
math.vectors classes.tuple classes boxes calendar alarms combinators
sets columns fry deques ui.gadgets ui.gadgets.private ascii
combinators.short-circuit ;
+FROM: namespaces => set ;
+FROM: sets => members ;
IN: ui.gestures
: get-gesture-handler ( gesture gadget -- quot )
: modifier ( mod modifiers -- seq )
[ second swap bitand 0 > ] with filter
- 0 <column> prune [ f ] [ >array ] if-empty ;
+ 0 <column> members [ f ] [ >array ] if-empty ;
: drag-loc ( -- loc )
hand-loc get-global hand-click-loc get-global v- ;
deploy-name get <model-field>
"Executable name:" label-on-left add-gadget ;
+: deploy-console ( parent -- parent )
+ deploy-console? get
+ "Deploy as Windows console application" <checkbox> add-gadget ;
+
: deploy-ui ( parent -- parent )
deploy-ui? get
"Include user interface framework" <checkbox> add-gadget ;
<pile>
bundle-name
deploy-ui
+ deploy-console
io-settings
reflection-settings
advanced-settings
ui.tools.listener.history ui.images ui.tools.error-list
tools.errors.model ;
FROM: source-files.errors => all-errors ;
+FROM: namespaces => set ;
IN: ui.tools.listener
! If waiting is t, we're waiting for user input, and invoking
layout-queue [
dup layout find-world [ , ] when*
] slurp-deque
- ] { } make prune ;
+ ] { } make members ;
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;
compiler.units parser io.encodings.ascii values interval-maps
ascii sets combinators locals math.ranges sorting make
strings.parser io.encodings.utf8 memoize simple-flat-file ;
+FROM: namespaces => set ;
IN: unicode.data
<PRIVATE
] assoc-map ;
: properties>intervals ( properties -- assoc[str,interval] )
- dup values prune [ f ] H{ } map>assoc
+ dup values members [ f ] H{ } map>assoc
[ [ push-at ] curry assoc-each ] keep
[ <interval-set> ] assoc-map ;
TYPEDEF: __uint32_t fflags_t
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
-TYPEDEF: int time_t
+TYPEDEF: long time_t
-ALIAS: <time_t> <int>
+ALIAS: <time_t> <long>
sum 10 mod 0 = ;
: v-credit-card ( str -- n )
- "- " diff
+ "- " without
dup CHAR: 0 CHAR: 9 [a,b] diff empty? [
13 v-min-length
16 v-max-length
#! Hack.\r
[ vocab-prefix? ] partition\r
[\r
- [ vocab-name ] map unique\r
- '[ name>> _ key? not ] filter\r
+ [ vocab-name ] map fast-set\r
+ '[ name>> _ in? not ] filter\r
convert-prefixes\r
] keep\r
append ;\r
dup vocab-tags-path set-vocab-file-contents ;
: add-vocab-tags ( tags vocab -- )
- [ vocab-tags append prune ] keep set-vocab-tags ;
+ [ vocab-tags append members ] keep set-vocab-tags ;
: remove-vocab-tags ( tags vocab -- )
[ vocab-tags swap diff ] keep set-vocab-tags ;
: monitor-thread ( -- )\r
[\r
[\r
- vocab-roots get prune [ add-monitor-for-path ] each\r
+ vocab-roots get [ add-monitor-for-path ] each\r
\r
H{ } clone changed-vocabs set-global\r
vocabs [ changed-vocab ] each\r
USING: accessors assocs checksums checksums.crc32
io.encodings.utf8 io.files kernel namespaces sequences sets
source-files vocabs vocabs.errors vocabs.loader ;
+FROM: namespaces => set ;
IN: vocabs.refresh
: source-modified? ( path -- ? )
[ [ vocab f >>docs-loaded? drop ] each ] bi*
]
[
- append prune
+ union
[ unchanged-vocabs ]
[ require-all load-failures. ] bi
] 2bi ;
: refresh ( prefix -- ) to-refresh do-refresh ;
-: refresh-all ( -- ) "" refresh ;
\ No newline at end of file
+: refresh-all ( -- ) "" refresh ;
int xPlus ( int y )
int xMulAdd ( int mul, int add ) ;
+COM-INTERFACE: ISelfReferential IUnknown {d4f45bf8-f720-4701-a09d-e8e341981121}
+ ISelfReferential* selfReference ( ) ;
+
{ GUID: {216fb341-0eb2-44b1-8edb-60b76e353abc} } [ ISimple-iid ] unit-test
{ GUID: {9620ecec-8438-423b-bb14-86f835aa40dd} } [ IInherited-iid ] unit-test
{ GUID: {00000000-0000-0000-C000-000000000046} } [ IUnknown-iid ] unit-test
effects kernel windows.ole32 parser lexer splitting grouping
sequences namespaces assocs quotations generalizations
accessors words macros alien.syntax fry arrays layouts math
-classes.struct windows.kernel32 ;
+classes.struct windows.kernel32 locals ;
+FROM: alien.parser.private => parse-pointers return-type-name ;
IN: windows.com.syntax
<PRIVATE
TUPLE: com-interface-definition word parent iid functions ;
C: <com-interface-definition> com-interface-definition
-TUPLE: com-function-definition name return parameters ;
+TUPLE: com-function-definition return name parameter-types parameter-names ;
C: <com-function-definition> com-function-definition
SYMBOL: +com-interface-definitions+
: save-com-interface-definition ( definition -- )
dup word>> +com-interface-definitions+ get-global set-at ;
-: (parse-com-function) ( tokens -- definition )
- [ second ]
- [ first parse-c-type ]
- [
- 3 tail [ CHAR: , swap remove ] map
- 2 group [ first2 normalize-c-arg 2array ] map
- { void* "this" } prefix
- ] tri
+: (parse-com-function) ( return name -- definition )
+ ")" scan-c-args
+ [ pointer: void prefix ] [ "this" prefix ] bi*
<com-function-definition> ;
+:: (parse-com-functions) ( functions -- )
+ scan dup ";" = [ drop ] [
+ parse-c-type scan parse-pointers
+ (parse-com-function) functions push
+ functions (parse-com-functions)
+ ] if ;
+
: parse-com-functions ( -- functions )
- ";" parse-tokens { ")" } split harvest
- [ (parse-com-function) ] map ;
+ V{ } clone [ (parse-com-functions) ] keep >array ;
: (iid-word) ( definition -- word )
word>> name>> "-iid" append create-in ;
dup parent>> [ family-tree-functions ] [ { } ] if*
swap functions>> append ;
-: (invocation-quot) ( function return parameters -- quot )
- [ first ] map [ com-invoke ] 3curry ;
-
-: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
- swap
- [ [ second ] map ]
- [ dup void? [ drop { } ] [ name>> 1array ] if ] bi*
- <effect> ;
-
-: (define-word-for-function) ( function interface n -- )
- -rot [ (function-word) swap ] 2keep drop
- [ return>> ] [ parameters>> ] bi
- [ (invocation-quot) ] 2keep
- (stack-effect-from-return-and-parameters)
+:: (define-word-for-function) ( function interface n -- )
+ function interface (function-word)
+ n function [ return>> ] [ parameter-types>> ] bi '[ _ _ _ com-invoke ]
+ function [ parameter-names>> ] [ return>> ] bi function-effect
define-declared ;
: define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ]
- [ word>> void* swap typedef ]
[
dup family-tree-functions
[ (define-word-for-function) ] with each-index
- ]
- tri ;
+ ] bi ;
PRIVATE>
SYNTAX: COM-INTERFACE:
CREATE-C-TYPE
+ void* over typedef
scan-object find-com-interface-definition
scan string>guid
parse-com-functions
keep (next-vtbl-counter) '[
swap [
[ name>> _ _ (callback-word) ]
- [ return>> ] [
- parameters>>
- [ [ first ] map ]
- [ length ] bi
- ] tri
+ [ return>> ] [ parameter-types>> dup length ] tri
] [
first2 (finish-thunk)
] bi*
-unportable bindings
\ No newline at end of file
+bindings\r
-unportable bindings\r
+bindings\r
-unportable bindings
+bindings
STRUCT: D2D1_FACTORY_OPTIONS
{ debugLevel D2D1_DEBUG_LEVEL } ;
+C-TYPE: ID2D1Factory
+C-TYPE: ID2D1BitmapRenderTarget
+
COM-INTERFACE: ID2D1Resource IUnknown {2cd90691-12e2-11dc-9fed-001143a055f9}
void GetFactory ( ID2D1Factory** factory ) ;
{ bottom UINT }
{ back UINT } ;
+C-TYPE: ID3D10Device
COM-INTERFACE: ID3D10DeviceChild IUnknown {9B7E4C00-342C-4106-A19F-4F2704F689F0}
void GetDevice ( ID3D10Device** ppDevice )
HRESULT GetPrivateData ( LPGUID guid, UINT* pDataSize, void* pData )
USING: alien.c-types alien.syntax classes.struct windows.com
-windows.com.syntax windows.directx.d3d10
+windows.com.syntax windows.directx.d3d10 windows.directx.d3d10misc
windows.directx.d3d10shader windows.types ;
IN: windows.directx.d3d10effect
USING: alien.c-types alien.syntax windows.com windows.com.syntax
-windows.directx.dxgi windows.types alien.libraries ;
+windows.directx.d3d10 windows.directx.dxgi windows.types ;
IN: windows.directx.d3d10misc
LIBRARY: d3d10
-USING: alien.syntax alien.c-types classes.struct windows.types windows.com
-windows.com.syntax windows.directx.d3d10 ;
+USING: alien.c-types alien.syntax classes.struct windows.com
+windows.com.syntax windows.directx.d3d10 windows.directx.d3d10misc
+windows.types ;
IN: windows.directx.d3d10shader
LIBRARY: d3d10
{ bottom UINT }
{ back UINT } ;
+C-TYPE: ID3D11Device
+C-TYPE: ID3D11ClassLinkage
+
COM-INTERFACE: ID3D11DeviceChild IUnknown {1841e5c8-16b0-489b-bcc8-44cfb0d5deae}
void GetDevice ( ID3D11Device** ppDevice )
HRESULT GetPrivateData ( REFGUID guid, UINT* pDataSize, void* pData )
FUNCTION: void D3DPERF_SetOptions ( DWORD dwOptions ) ;
FUNCTION: DWORD D3DPERF_GetStatus ( ) ;
+C-TYPE: IDirect3DDevice9
+
COM-INTERFACE: IDirect3D9 IUnknown {81BDCBCA-64D4-426d-AE8D-AD0147F4275C}
HRESULT RegisterSoftwareDevice ( void* pInitializeFunction )
UINT GetAdapterCount ( )
C-TYPE: IDirect3DVertexShader9
C-TYPE: IDirect3DIndexBuffer9
C-TYPE: IDirect3DPixelShader9
+C-TYPE: IDirect3DSwapChain9
+C-TYPE: IDirect3DTexture9
+C-TYPE: IDirect3DVolumeTexture9
+C-TYPE: IDirect3DCubeTexture9
+C-TYPE: IDirect3DStateBlock9
+C-TYPE: IDirect3DQuery9
+C-TYPE: IDirect3DVolume9
+C-TYPE: IDirect3D9Ex
+C-TYPE: IDirect3DDevice9Ex
+C-TYPE: IDirect3DAuthenticatedChannel9
+C-TYPE: IDirect3DCryptoSession9
COM-INTERFACE: IDirect3DDevice9 IUnknown {D0223B96-BF7A-43fd-92BD-A43B0D82B9EB}
HRESULT TestCooperativeLevel ( )
HRESULT Clear ( DWORD Count, D3DRECT* pRects, DWORD Flags, D3DCOLOR Color, float Z, DWORD Stencil )
HRESULT SetTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
HRESULT GetTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
- HRESULT MultiplyTransform ( D3DTRANSFORMSTATETYPE, D3DMATRIX* )
+ HRESULT MultiplyTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
HRESULT SetViewport ( D3DVIEWPORT9* pViewport )
HRESULT GetViewport ( D3DVIEWPORT9* pViewport )
HRESULT SetMaterial ( D3DMATERIAL9* pMaterial )
-USING: alien.syntax windows.directx.d3d10 windows.directx.d3d10shader
-windows.types ;
+USING: alien.syntax windows.directx.d3d10 windows.directx.d3d10misc
+windows.directx.d3d10shader windows.directx.d3dx10core windows.types ;
IN: windows.directx.d3dx10async
LIBRARY: d3dx10
C-TYPE: ID3D10EffectPool
C-TYPE: D3DX10_IMAGE_LOAD_INFO
C-TYPE: D3DX10_IMAGE_INFO
+C-TYPE: ID3D10Effect
FUNCTION: HRESULT D3DX10CompileFromFileA ( LPCSTR pSrcFile, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-USING: alien.syntax alien.c-types classes.struct windows.types
-windows.directx.d3d10shader windows.directx.d3dx11core
-windows.directx.d3d11 windows.directx.d3dx11tex ;
+USING: alien.syntax windows.directx.d3d10misc
+windows.directx.d3d10shader windows.directx.d3d11
+windows.directx.d3dx11core windows.directx.d3dx11tex windows.types ;
IN: windows.directx.d3dx11async
LIBRARY: d3dx11
-USING: alien.syntax alien.c-types classes.struct windows.types
-windows.directx.dxgiformat windows.directx.d3d11
-windows.directx.d3dx11core ;
+USING: alien.c-types alien.syntax classes.struct
+windows.directx.d3d10misc windows.directx.d3d11
+windows.directx.d3dx11core windows.directx.dxgiformat windows.types ;
IN: windows.directx.d3dx11tex
LIBRARY: d3dx11
HRESULT GetDC ( BOOL Discard, HDC* phdc )
HRESULT ReleaseDC ( RECT* pDirtyRect ) ;
+C-TYPE: IDXGIOutput
COM-INTERFACE: IDXGIAdapter IDXGIObject {2411e7e1-12ac-4ccf-bd14-9798e8534dc0}
HRESULT EnumOutputs ( UINT Output, IDXGIOutput** ppOutput )
HRESULT GetDesc ( DXGI_ADAPTER_DESC* pDesc )
{ PrimaryCoordinates FLOAT[8][2] }
{ WhitePoints FLOAT[16][2] } ;
+COM-INTERFACE: IDXGIAdapter1 IDXGIAdapter {29038f61-3839-4626-91fd-086879011a05}
+HRESULT GetDesc1 ( DXGI_ADAPTER_DESC1* pDesc ) ;
+
COM-INTERFACE: IDXGIFactory1 IDXGIFactory {770aae78-f26f-4dba-a829-253c83d1b387}
HRESULT EnumAdapters1 ( UINT Adapter, IDXGIAdapter1** ppAdapter )
BOOL IsCurrent ( ) ;
-COM-INTERFACE: IDXGIAdapter1 IDXGIAdapter {29038f61-3839-4626-91fd-086879011a05}
-HRESULT GetDesc1 ( DXGI_ADAPTER_DESC1* pDesc ) ;
-
COM-INTERFACE: IDXGIDevice1 IDXGIDevice {77db970f-6276-48ba-ba28-070143b4392c}
HRESULT SetMaximumFrameLatency ( UINT MaxLatency )
HRESULT GetMaximumFrameLatency ( UINT* pMaxLatency ) ;
-USING: alien.c-types alien.syntax classes.struct windows.ole32
-windows.types ;
+USING: alien.c-types alien.syntax classes.struct windows.com
+windows.ole32 windows.types ;
IN: windows.directx.xapofx
LIBRARY: xapofx
C-TYPE: IXAudio2EngineCallback
C-TYPE: IXAudio2VoiceCallback
+C-TYPE: IXAudio2SourceVoice
+C-TYPE: IXAudio2SubmixVoice
+C-TYPE: IXAudio2MasteringVoice
COM-INTERFACE: IXAudio2 IUnknown {8bcf1f58-9fe7-4583-8ac6-e2adc465c8bb}
HRESULT GetDeviceCount ( UINT32* pCount )
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 )
CONSTANT: SWP_NOCOPYBITS 256
CONSTANT: SWP_NOOWNERZORDER 512
CONSTANT: SWP_NOSENDCHANGING 1024
-CONSTANT: SWP_DRAWFRAME SWP_FRAMECHANGED
-CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER
+ALIAS: SWP_DRAWFRAME SWP_FRAMECHANGED
+ALIAS: SWP_NOREPOSITION SWP_NOOWNERZORDER
CONSTANT: SWP_DEFERERASE 8192
CONSTANT: SWP_ASYNCWINDOWPOS 16384
{ dwType DWORD } ;
TYPEDEF: RAWINPUTDEVICELIST* PRAWINPUTDEVICELIST
+CONSTANT: CCHFORMNAME 32
+
+CONSTANT: CDS_UPDATEREGISTRY HEX: 00000001
+CONSTANT: CDS_TEST HEX: 00000002
+CONSTANT: CDS_FULLSCREEN HEX: 00000004
+CONSTANT: CDS_GLOBAL HEX: 00000008
+CONSTANT: CDS_SET_PRIMARY HEX: 00000010
+CONSTANT: CDS_RESET HEX: 40000000
+CONSTANT: CDS_SETRECT HEX: 20000000
+CONSTANT: CDS_NORESET HEX: 10000000
+
+CONSTANT: DISP_CHANGE_SUCCESSFUL 0
+CONSTANT: DISP_CHANGE_RESTART 1
+CONSTANT: DISP_CHANGE_FAILED -1
+CONSTANT: DISP_CHANGE_BADMODE -2
+CONSTANT: DISP_CHANGE_NOTUPDATED -3
+CONSTANT: DISP_CHANGE_BADFLAGS -4
+CONSTANT: DISP_CHANGE_BADPARAM -5
+
+
+
+STRUCT: DEVMODE
+ { dmDeviceName TCHAR[CCHDEVICENAME] }
+ { dmSpecVersion WORD }
+ { dmDriverVersion WORD }
+ { dmSize WORD }
+ { dmDriverExtra WORD }
+ { dmFields DWORD }
+
+ { dmOrientation short }
+ { dmPaperSize short }
+ { dmPaperLength short }
+ { dmPaperWidth short }
+ { dmScale short }
+ { dmCopies short }
+ { dmDefaultSource short }
+ { dmPrintQuality short }
+
+ { dmColor short }
+ { dmDuplex short }
+ { dmYResolution short }
+ { dmTTOption short }
+ { dmCollate short }
+ { dmFormName TCHAR[CCHFORMNAME] }
+ { dmLogPixels WORD }
+ { dmBitsPerPel DWORD }
+ { dmPelsWidth DWORD }
+ { dmPelsHeight DWORD }
+ { dmDisplayFlags DWORD }
+ { dmDisplayFrequency DWORD }
+ { dmiCMMethod DWORD }
+ { dmICMIntent DWORD }
+
+ { dmMediaType DWORD }
+ { dmDitherType DWORD }
+ { dmReserved1 DWORD }
+ { dmReserved2 DWORD }
+ { dmPanningWidth DWORD } ;
+
+! union { DWORD dmDisplayFlags; DWORD dmNup; } ;
+ ! union {
+ ! struct {
+ ! short dmOrientation;
+ ! short dmPaperSize;
+ ! short dmPaperLength;
+ ! short dmPaperWidth;
+ ! short dmScale;
+ ! short dmCopies;
+ ! short dmDefaultSource;
+ ! short dmPrintQuality;
+ ! } ;
+ ! struct {
+ ! POINTL dmPosition;
+ ! DWORD dmDisplayOrientation;
+ ! DWORD dmDisplayFixedOutput;
+ ! } ;
+ ! } ;
+
+TYPEDEF: DEVMODE* PDEVMODE
+TYPEDEF: DEVMODE* LPDEVMODE
+
LIBRARY: user32
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
! FUNCTION: CascadeChildWindows
! FUNCTION: CascadeWindows
! FUNCTION: ChangeClipboardChain
-! FUNCTION: ChangeDisplaySettingsA
-! FUNCTION: ChangeDisplaySettingsExA
-! FUNCTION: ChangeDisplaySettingsExW
-! FUNCTION: ChangeDisplaySettingsW
+FUNCTION: LONG ChangeDisplaySettingsExW ( LPCTSTR lpszDeviceName, DEVMODE *lpDevMode, HWND hwnd, DWORD dwFlags, LPVOID lParam ) ;
+FUNCTION: LONG ChangeDisplaySettingsW ( DEVMODE *lpDevMode, DWORD dwFlags ) ;
+ALIAS: ChangeDisplaySettingsEx ChangeDisplaySettingsExW
+ALIAS: ChangeDisplaySettings ChangeDisplaySettingsW
! FUNCTION: ChangeMenuA
! FUNCTION: ChangeMenuW
! FUNCTION: CharLowerA
! FUNCTION: EnumDesktopWindows
! FUNCTION: EnumDisplayDevicesA
! FUNCTION: EnumDisplayDevicesW
-! FUNCTION: EnumDisplayMonitors
+! FUNCTION: BOOL EnumDisplayMonitors ( HDC hdc, LPCRECT lprcClip, MONITORENUMPROC lpfnEnum, LPARAM dwData ) ;
! FUNCTION: EnumDisplaySettingsA
! FUNCTION: EnumDisplaySettingsExA
! FUNCTION: EnumDisplaySettingsExW
-! FUNCTION: EnumDisplaySettingsW
+FUNCTION: BOOL EnumDisplaySettingsW ( LPCTSTR lpszDeviceName, DWORD iModeNum, DEVMODE *lpDevMode ) ;
+ALIAS: EnumDisplaySettings EnumDisplaySettingsW
! FUNCTION: EnumPropsA
! FUNCTION: EnumPropsExA
! FUNCTION: EnumPropsExW
! FUNCTION: GetCursorPos
FUNCTION: HDC GetDC ( HWND hWnd ) ;
FUNCTION: HDC GetDCEx ( HWND hWnd, HRGN hrgnClip, DWORD flags ) ;
-! FUNCTION: GetDesktopWindow
+FUNCTION: HWND GetDesktopWindow ( ) ;
! FUNCTION: GetDialogBaseUnits
! FUNCTION: GetDlgCtrlID
! FUNCTION: GetDlgItem
! FUNCTION: GetDlgItemTextW
FUNCTION: uint GetDoubleClickTime ( ) ;
FUNCTION: HWND GetFocus ( ) ;
-! FUNCTION: GetForegroundWindow
+FUNCTION: HWND GetForegroundWindow ( ) ;
! FUNCTION: GetGuiResources
! FUNCTION: GetGUIThreadInfo
! FUNCTION: GetIconInfo
! FUNCTION: GetWindowLongW
FUNCTION: LONG_PTR GetWindowLongW ( HANDLE hWnd, int index ) ;
ALIAS: GetWindowLong GetWindowLongW
+
+FUNCTION: LONG_PTR GetWindowLongPtrW ( HWND hWnd, int nIndex ) ;
+ALIAS: GetWindowLongPtr GetWindowLongPtrW
! FUNCTION: GetWindowModuleFileName
! FUNCTION: GetWindowModuleFileNameA
! FUNCTION: GetWindowModuleFileNameW
! FUNCTION: SetWindowPlacement
FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
+FUNCTION: LONG_PTR SetWindowLongPtrW ( HWND hWnd, int nIndex, LONG_PTR dwNewLong ) ;
+ALIAS: SetWindowLongPtr SetWindowLongPtrW
+
: HWND_BOTTOM ( -- alien ) 1 <alien> ;
: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;
CONSTANT: HWND_TOP f
{ send_event Bool }
{ display Display* }
{ window Window }
-{ pad int }
-{ pad int }
-{ pad int }
-{ pad int }
-{ pad int }
-{ pad int }
-{ pad int }
-{ pad int } ;
+{ pad int[8] } ;
UNION-STRUCT: XEvent
{ int int }
X-FUNCTION: Bool XSupportsLocale ( ) ;
X-FUNCTION: c-string XSetLocaleModifiers ( c-string modifier_list ) ;
+
+! uncategorized xlib bindings
+
+X-FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ;
+
xml.data accessors arrays make xml.char-classes fry assocs sequences
math xml.errors sets combinators io.encodings io.encodings.iana
unicode.case xml.dtd strings xml.entities unicode.categories ;
+FROM: namespaces => set ;
IN: xml.elements
: take-interpolated ( quot -- interpolated )
: 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 )
assoc>> >alist ;
: (keyword-map-no-word-sep) ( assoc -- str )
- keys concat [ alpha? not ] filter prune natural-sort ;
+ keys combine [ alpha? not ] filter natural-sort ;
: keyword-map-no-word-sep* ( keyword-map -- str )
dup no-word-sep>> [ ] [
} ;
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."
}
USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
system prettyprint layouts alien.libraries sets ;
+FROM: namespaces => set ;
IN: alien.tests
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
[ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test
-[ V{ BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test
\ No newline at end of file
+[ { BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } members ] unit-test
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
-kernel.private byte-arrays byte-vectors arrays init ;
+kernel.private byte-arrays byte-vectors arrays init
+continuations.private ;
IN: alien
PREDICATE: pinned-alien < alien underlying>> not ;
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 ;
+<PRIVATE
+
! Callbacks are registered in a global hashtable. Note that they
! are also pinned in a special callback area, so clearing this
! hashtable will not reclaim callbacks. It should only be
[ H{ } clone callbacks set-global ] "alien" add-startup-hook
-<PRIVATE
+! Every context object in the VM is identified from the Factor
+! side by a unique identifier
+TUPLE: context-id < identity-tuple ;
+
+C: <context-id> context-id
+
+: context-id ( -- id ) 2 context-object ;
+
+: set-context-id ( id -- ) 2 set-context-object ;
+
+: wait-to-return ( yield-quot id -- )
+ dup context-id eq?
+ [ 2drop ] [ over call( -- ) wait-to-return ] if ;
+
+! Used by compiler.codegen to wrap callback bodies
+: do-callback ( callback-quot yield-quot -- )
+ init-namespaces
+ init-catchstack
+ <context-id>
+ [ set-context-id drop call ] [ wait-to-return drop ] 3bi ; inline
+! A utility for defining global variables that are recompiled in
+! every session
TUPLE: expiry-check object alien ;
: recompute-value? ( check -- ? )
M: sequence string>symbol [ string>symbol* ] map ;
[
- 8 special-object utf8 alien>string string>cpu \ cpu set-global
- 9 special-object utf8 alien>string string>os \ os set-global
+ 8 special-object utf8 alien>string string>cpu \ cpu set-global
+ 9 special-object utf8 alien>string string>os \ os set-global
+ 67 special-object utf8 alien>string \ vm-compiler set-global
] "alien.strings" add-startup-hook
: 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 )) }
{ "call-clear" "kernel.private" "primitive_call_clear" (( quot -- * )) }
{ "check-datastack" "kernel.private" "primitive_check_datastack" (( array in# out# -- ? )) }
{ "compute-identity-hashcode" "kernel.private" "primitive_compute_identity_hashcode" (( obj -- )) }
+ { "context-object" "kernel.private" "primitive_context_object" (( n -- obj )) }
{ "innermost-frame-executing" "kernel.private" "primitive_innermost_stack_frame_executing" (( callstack -- obj )) }
{ "innermost-frame-scan" "kernel.private" "primitive_innermost_stack_frame_scan" (( callstack -- n )) }
+ { "set-context-object" "kernel.private" "primitive_set_context_object" (( obj n -- )) }
{ "set-datastack" "kernel.private" "primitive_set_datastack" (( ds -- )) }
{ "set-innermost-frame-quot" "kernel.private" "primitive_set_innermost_stack_frame_quot" (( n callstack -- )) }
{ "set-retainstack" "kernel.private" "primitive_set_retainstack" (( rs -- )) }
run-file
] [
"Cannot find " write write "." print
- "Please move " write image write " to the same directory as the Factor sources," print
+ "Please move " write image write " into the same directory as the Factor sources," print
"and try again." print
1 (exit)
] if
"HEX:"
"HOOK:"
"H{"
+ "HS{"
"IN:"
"INSTANCE:"
"M:"
USING: kernel classes classes.private combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private sets math.order ;
+FROM: classes => members ;
+RENAME: members sets => set-members
IN: classes.algebra
<PRIVATE
TUPLE: anonymous-union { members read-only } ;
: <anonymous-union> ( members -- class )
- [ null eq? not ] filter prune
+ [ null eq? not ] filter set-members
dup length 1 = [ first ] [ anonymous-union boa ] if ;
TUPLE: anonymous-intersection { participants read-only } ;
: <anonymous-intersection> ( participants -- class )
- prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
+ set-members dup length 1 =
+ [ first ] [ anonymous-intersection boa ] if ;
TUPLE: anonymous-complement { class read-only } ;
slots.private namespaces make sequences strings words words.symbol
vectors math quotations combinators sorting effects graphs
vocabs sets ;
+FROM: namespaces => set ;
IN: classes
ERROR: bad-inheritance class superclass ;
ERROR: bad-literal-tuple ;
-: parse-slot-value ( -- )
- scan scan-object 2array , scan {
+ERROR: bad-slot-name class slot ;
+
+: check-slot-name ( class slots name -- name )
+ 2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ;
+
+: parse-slot-value ( class slots -- )
+ scan check-slot-name scan-object 2array , scan {
{ f [ \ } unexpected-eof ] }
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
-: (parse-slot-values) ( -- )
- parse-slot-value
+: (parse-slot-values) ( class slots -- )
+ 2dup parse-slot-value
scan {
- { f [ \ } unexpected-eof ] }
+ { f [ 2drop \ } unexpected-eof ] }
{ "{" [ (parse-slot-values) ] }
- { "}" [ ] }
- [ bad-literal-tuple ]
+ { "}" [ 2drop ] }
+ [ 2nip bad-literal-tuple ]
} case ;
-: parse-slot-values ( -- values )
+: parse-slot-values ( class slots -- values )
[ (parse-slot-values) ] { } make ;
GENERIC# boa>object 1 ( class slots -- tuple )
M: tuple-class boa>object
swap prefix >tuple ;
-ERROR: bad-slot-name class slot ;
-
: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
over [ drop ] [ nip nip nip bad-slot-name ] if ;
scan {
{ f [ unexpected-eof ] }
{ "f" [ drop \ } parse-until boa>object ] }
- { "{" [ parse-slot-values assoc>object ] }
+ { "{" [ 2dup parse-slot-values assoc>object ] }
{ "}" [ drop new ] }
[ bad-literal-tuple ]
} case ;
{ $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
: contiguous-range? ( keys -- ? )
dup [ fixnum? ] all? [
dup all-unique? [
- [ prune length ]
+ [ length ]
[ [ supremum ] [ infimum ] bi - ]
bi - 1 =
] [ drop f ] if
[ 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
sequences words vocabs definitions hashtables init sets math
math.order classes classes.private classes.algebra classes.tuple
classes.tuple.private generic source-files.errors kernel.private ;
+FROM: namespaces => set ;
IN: compiler.units
SYMBOL: old-definitions
{ $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
<PRIVATE
: catchstack* ( -- catchstack )
- 1 special-object { vector } declare ; inline
+ 1 context-object { vector } declare ; inline
: >c ( continuation -- ) catchstack* push ;
: dummy-1 ( -- obj ) f ;
: dummy-2 ( obj -- obj ) dup drop ;
-: init-catchstack ( -- ) V{ } clone 1 set-special-object ;
+: catchstack ( -- catchstack ) catchstack* clone ; inline
-PRIVATE>
+: set-catchstack ( catchstack -- )
+ >vector 1 set-context-object ; inline
-: catchstack ( -- catchstack ) catchstack* clone ; inline
+: init-catchstack ( -- ) f set-catchstack ;
-: set-catchstack ( catchstack -- ) >vector 1 set-special-object ; inline
+PRIVATE>
TUPLE: continuation data call retain name catch ;
datastack callstack retainstack namestack catchstack
<continuation> ;
+<PRIVATE
+
: >continuation< ( continuation -- data call retain name catch )
- {
- [ data>> ]
- [ call>> ]
- [ retain>> ]
- [ name>> ]
- [ catch>> ]
- } cleave ;
+ { [ data>> ] [ call>> ] [ retain>> ] [ name>> ] [ catch>> ] } cleave ;
+
+PRIVATE>
: ifcc ( capture restore -- )
[ dummy-1 continuation ] 2dip [ dummy-2 ] prepose ?if ; inline
] 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
] [
<PRIVATE
: init-error-handler ( -- )
- V{ } clone set-catchstack
+ init-catchstack
! VM calls on error
[
! 63 = self
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel namespaces make
sequences vectors sets assocs init math ;
+FROM: namespaces => set ;
IN: destructors
SYMBOL: disposables
-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 ;
hashtables definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators
sets ;
+FROM: namespaces => set ;
IN: generic
! Method combination protocol
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
prettyprint byte-vectors bit-vectors specialized-vectors
definitions generic sets graphs assocs grouping see eval ;
QUALIFIED-WITH: alien.c-types c
+FROM: namespaces => set ;
SPECIALIZED-VECTOR: c:double
IN: generic.single.tests
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: hash-sets
+
+ARTICLE: "hash-sets" "Hash sets"
+"The " { $vocab-link "hash-sets" } " vocabulary implements hashtable-backed sets. These are of the class:"
+{ $subsection hash-set }
+"They can be instantiated with the word"
+{ $subsection <hash-set> }
+"The syntax for hash sets is described in " { $link "syntax-hash-sets" } "." ;
+
+ABOUT: "hash-sets"
+
+HELP: hash-set
+{ $class-description "The class of hashtable-based sets. These implement the " { $link "sets" } "." } ;
+
+HELP: <hash-set>
+{ $values { "members" sequence } { "hash-set" hash-set } }
+{ $description "Creates a new hash set with the given members." } ;
--- /dev/null
+! Copyright (C) 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sets tools.test kernel sorting prettyprint hash-sets ;
+IN: hash-sets.tests
+
+[ { 1 2 3 } ] [ HS{ 1 2 3 } members natural-sort ] unit-test
+
+[ "HS{ 1 2 3 4 }" ] [ HS{ 1 2 3 4 } unparse ] unit-test
+
+[ t ] [ 1 HS{ 0 1 2 } in? ] unit-test
+[ f ] [ 3 HS{ 0 1 2 } in? ] unit-test
+[ HS{ 1 2 3 } ] [ 3 HS{ 1 2 } clone [ adjoin ] keep ] unit-test
+[ HS{ 1 2 } ] [ 2 HS{ 1 2 } clone [ adjoin ] keep ] unit-test
+[ HS{ 1 2 3 } ] [ 4 HS{ 1 2 3 } clone [ delete ] keep ] unit-test
+[ HS{ 1 2 } ] [ 3 HS{ 1 2 3 } clone [ delete ] keep ] unit-test
+[ HS{ 1 2 } ] [ HS{ 1 2 } fast-set ] unit-test
+[ { 1 2 } ] [ HS{ 1 2 } members natural-sort ] unit-test
+
+[ HS{ 1 2 3 4 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } union ] unit-test
+[ HS{ 2 3 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } intersect ] unit-test
+[ t ] [ HS{ 1 2 3 } HS{ 2 3 4 } intersects? ] unit-test
+[ f ] [ HS{ 1 } HS{ 2 3 4 } intersects? ] unit-test
+[ f ] [ HS{ 1 } HS{ 2 3 4 } subset? ] unit-test
+[ f ] [ HS{ 1 2 3 } HS{ 2 3 4 } subset? ] unit-test
+[ t ] [ HS{ 2 3 } HS{ 2 3 4 } subset? ] unit-test
+[ t ] [ HS{ } HS{ 2 3 4 } subset? ] unit-test
+[ HS{ 1 } ] [ HS{ 1 2 3 } HS{ 2 3 4 } diff ] unit-test
+[ t ] [ HS{ 1 2 3 } HS{ 2 1 3 } set= ] unit-test
+[ t ] [ HS{ 1 2 3 } HS{ 2 1 3 } = ] unit-test
+[ f ] [ HS{ 2 3 } HS{ 2 1 3 } set= ] unit-test
+[ f ] [ HS{ 1 2 3 } HS{ 2 3 } set= ] unit-test
+
+[ HS{ 1 2 } HS{ 1 2 3 } ] [ HS{ 1 2 } clone dup clone [ 3 swap adjoin ] keep ] unit-test
--- /dev/null
+! Copyright (C) 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hashtables kernel sets
+sequences parser ;
+QUALIFIED: sets
+IN: hash-sets
+
+! In a better implementation, less memory would be used
+TUPLE: hash-set { table hashtable read-only } ;
+
+: <hash-set> ( members -- hash-set )
+ H{ } clone [ [ dupd set-at ] curry each ] keep hash-set boa ;
+
+INSTANCE: hash-set set
+M: hash-set in? table>> key? ; inline
+M: hash-set adjoin table>> dupd set-at ; inline
+M: hash-set delete table>> delete-at ; inline
+M: hash-set members table>> keys ; inline
+M: hash-set set-like
+ drop dup hash-set? [ members <hash-set> ] unless ;
+M: hash-set clone
+ table>> clone hash-set boa ;
+
+M: sequence fast-set <hash-set> ;
+M: f fast-set drop H{ } clone hash-set boa ;
+
+M: sequence duplicates
+ f fast-set [ [ in? ] [ adjoin ] 2bi ] curry filter ;
: 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
{ $values { "lexer" lexer } { "?" "a boolean" } }
{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
+HELP: each-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 -- ... 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 ;
+
HELP: parse-tokens
{ $values { "end" string } { "seq" "a new sequence of strings" } }
-{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." }
-{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way. This word is equivalent to " { $link map-tokens } " with an empty quotation." }
$parsing-note ;
HELP: unexpected
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 )
[ unexpected-eof ]
if* ;
-: (parse-tokens) ( accum end -- accum )
- scan 2dup = [
- 2drop
- ] [
- [ pick push (parse-tokens) ] [ unexpected-eof ] if*
- ] if ;
+: (each-token) ( end quot -- pred quot )
+ [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline
+
+: each-token ( ... end quot: ( ... token -- ... ) -- ... )
+ (each-token) while drop ; inline
+
+: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
+ (each-token) produce nip ; inline
: parse-tokens ( end -- seq )
- 100 <vector> swap (parse-tokens) >array ;
+ [ ] 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
] [
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vectors sequences hashtables
arrays kernel.private math strings assocs ;
<PRIVATE
-: namestack* ( -- namestack ) 0 special-object { vector } declare ; inline
+: namestack* ( -- namestack ) 0 context-object { vector } declare ; inline
: >n ( namespace -- ) namestack* push ;
: ndrop ( -- ) namestack* pop* ;
: namespace ( -- namespace ) namestack* last ; inline
: namestack ( -- namestack ) namestack* clone ;
-: set-namestack ( namestack -- ) >vector 0 set-special-object ;
+: set-namestack ( namestack -- ) >vector 0 set-context-object ;
: global ( -- g ) 21 special-object { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
: get ( variable -- value ) namestack* assoc-stack ; inline
$nl
"One example is the " { $link POSTPONE: USING: } " parsing word."
{ $see POSTPONE: USING: }
-"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a lower-level word is called:"
-{ $subsections parse-tokens } ;
+"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a set of lower-level combinators can be used:"
+{ $subsections
+ each-token
+ map-tokens
+ parse-tokens
+} ;
ARTICLE: "parsing-words" "Parsing words"
"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
{ $examples "This word is used to implement " { $link POSTPONE: ARTICLE: } "." }
$parsing-note ;
-{ parse-tokens (parse-until) parse-until } related-words
+{ parse-tokens each-token map-tokens (parse-until) parse-until } related-words
HELP: (parse-lines)
{ $values { "lexer" lexer } { "quot" "a new " { $link quotation } } }
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 -- ... )" } } }
+{ $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 -- ... 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
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" "a new sequence of sequences of pairs" } }
+{ $description "Outputs a sequence of all possible pairings of elements from the two sequences." }
+{ $examples
+ { $example
+ "USING: prettyprint sequences ;"
+ "{ 1 2 } { 3 4 } cartesian-product ."
+ "{ { { 1 3 } { 1 4 } } { { 2 3 } { 2 4 } } }"
+ }
+} ;
+
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
2selector
} ;
+ARTICLE: "sequences-cartesian" "Cartesian product operations"
+"The cartesian product of two sequences is a sequence of all pairs where the first element of each pair is from the first sequence, and the second element of each pair is from the second sequence. The number of elements in the cartesian product is the product of the lengths of the two sequences."
+$nl
+"Combinators which pair every element of the first sequence with every element of the second:"
+{ $subsections
+ cartesian-each
+ cartesian-map
+}
+"Computing the cartesian product of two sequences:"
+{ $subsections
+ cartesian-product
+} ;
+
ARTICLE: "sequences" "Sequence operations"
"A " { $emphasis "sequence" } " is a finite, linearly-ordered collection of elements. Words for working with sequences are in the " { $vocab-link "sequences" } " vocabulary."
$nl
"binary-search"
"sets"
"sequences-trimming"
+ "sequences-cartesian"
"sequences.deep"
}
"Using sequences for looping:"
[ +gt+ ] [ { 0 0 0 0 } { 0 0 0 } <=> ] unit-test
[ +eq+ ] [ { } { } <=> ] unit-test
[ +eq+ ] [ { 1 2 3 } { 1 2 3 } <=> ] unit-test
+
+[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
+[ { 1 2 } { "a" "b" } cartesian-product ] unit-test
: 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: ( ... elt1 elt2 -- ... ) -- ... )
+ [ with each ] 2curry each ; inline
+
+: cartesian-map ( ... seq1 seq2 quot: ( ... elt1 elt2 -- ... newelt ) -- ... newseq )
+ [ with map ] 2curry map ; inline
+
+: cartesian-product ( seq1 seq2 -- newseq )
+ [ { } 2sequence ] cartesian-map ;
! We hand-optimize flip to such a degree because type hints
! cannot express that an array is an array of arrays yet, and
USING: assocs hashtables help.markup help.syntax kernel
-quotations sequences ;
+quotations sequences vectors ;
IN: sets
-ARTICLE: "sets" "Set-theoretic operations on sequences"
-"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. All of these operations use hashtables internally to achieve linear running time."
-$nl
-"Remove duplicates:"
-{ $subsections prune }
-"Test for duplicates:"
+ARTICLE: "sets" "Sets"
+"A set is an unordered list of elements. Words for working with sets are in the " { $vocab-link "sets" } " vocabulary." $nl
+"All sets are instances of a mixin class:"
{ $subsections
- all-unique?
- duplicates
+ set
+ set?
+}
+{ $subsections "set-operations" "set-implementations" } ;
+
+ABOUT: "sets"
+
+ARTICLE: "set-operations" "Operations on sets"
+"To test if an object is a member of a set:"
+{ $subsections member? }
+"All sets can be represented as a sequence, without duplicates, of their members:"
+{ $subsections members }
+"Sets can have members added or removed destructively:"
+{ $subsections
+ adjoin
+ delete
}
-"Set operations on sequences:"
+"Basic mathematical operations, which any type of set may override for efficiency:"
{ $subsections
diff
intersect
union
}
-"Set-theoretic predicates:"
+"Mathematical predicates on sets, which may be overridden for efficiency:"
{ $subsections
intersects?
subset?
set=
}
-"A word used to implement the above:"
-{ $subsections unique }
-"Adding elements to sets:"
+"An optional generic word for creating sets of the same class as a given set:"
+{ $subsections set-like }
+"An optional generic word for creating a set with a fast lookup operation, if the set itself has a slow lookup operation:"
+{ $subsections fast-set }
+"For set types that allow duplicates, like sequence sets, some additional words test for duplication:"
{ $subsections
- adjoin
+ all-unique?
+ duplicates
}
-{ $see-also member? member-eq? any? all? "assocs-sets" } ;
+"Utilities for sets and sequences:"
+{ $subsections
+ within
+ without
+} ;
-ABOUT: "sets"
+ARTICLE: "set-implementations" "Set implementations"
+"There are several implementations of sets in the Factor library. More can be added if they implement the words of the set protocol, the basic set operations."
+{ $subsections
+ "sequence-sets"
+ "hash-sets"
+ "bit-sets"
+} ;
+
+ARTICLE: "sequence-sets" "Sequences as sets"
+"Any sequence can be used as a set. The members of this set are the elements of the sequence. Calling the word " { $link members } " on a sequence returns a copy of the sequence with only one listing of each member. Destructive operations " { $link adjoin } " and " { $link delete } " only work properly on growable sequences like " { $link vector } "s."
+$nl
+"Care must be taken in writing efficient code using sequence sets. Testing for membership with " { $link in? } ", as well as the destructive set operations, take time proportional to the size of the sequence. Another representation, like " { $link "hash-sets" } ", would take constant time for membership tests. But binary operations like " { $link union } "are asymptotically optimal, taking time proportional to the sum of the size of the inputs."
+$nl
+"As one particlar example, " { $link POSTPONE: f } " is a representation of the empty set, as it represents the empty sequence." ;
+
+HELP: set
+{ $class-description "The class of all sets. Custom implementations of the set protocol should be declared as instances of this mixin for all set implementation to work correctly." } ;
HELP: adjoin
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
-{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
+{ $values { "elt" object } { "set" set } }
+{ $description "Destructively adds " { $snippet "elt" } " to " { $snippet "set" } ". For sequences, this guarantees that this element is not duplicated, and that it is at the end of the sequence." $nl "Each mutable set type is expected to implement a method on this generic word." }
{ $examples
{ $example
- "USING: namespaces prettyprint sets ;"
- "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
- "\"nachos\" \"v\" get adjoin"
- "\"salsa\" \"v\" get adjoin"
- "\"v\" get ."
+ "USING: prettyprint sets kernel ;"
+ "V{ \"beans\" \"salsa\" \"cheese\" } clone"
+ "\"nachos\" over adjoin"
+ "\"salsa\" over adjoin"
+ "."
"V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
}
}
-{ $side-effects "seq" } ;
+{ $side-effects "set" } ;
-HELP: conjoin
-{ $values { "elt" object } { "assoc" assoc } }
-{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
-{ $examples
- { $example
- "USING: kernel prettyprint sets ;"
- "H{ } clone 1 over conjoin ."
- "H{ { 1 1 } }"
- }
-}
-{ $side-effects "assoc" } ;
+HELP: delete
+{ $values { "elt" object } { "set" set } }
+{ $description "Destructively removes " { $snippet "elt" } " from " { $snippet "set" } ". If the element is not present, this does nothing." $nl "Each mutable set type is expected to implement a method on this generic word." }
+{ $side-effects "set" } ;
-HELP: conjoin-at
-{ $values { "value" object } { "key" object } { "assoc" assoc } }
-{ $description "Adds " { $snippet "value" } " to the set stored at " { $snippet "key" } " of " { $snippet "assoc" } "." } ;
+HELP: members
+{ $values { "set" set } { "seq" sequence } }
+{ $description "Creates a sequence with a single copy of each member of the set." $nl "Each set type is expected to implement a method on this generic word." } ;
-HELP: unique
-{ $values { "seq" "a sequence" } { "assoc" assoc } }
-{ $description "Outputs a new assoc where the keys and values are equal." }
-{ $examples
- { $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
-} ;
+HELP: in?
+{ $values { "elt" object } { "set" set } { "?" "a boolean" } }
+{ $description "Tests whether the element is a member of the set." $nl "Each set type is expected to implement a method on this generic word as part of the set protocol." } ;
-HELP: prune
-{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
-{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
-} ;
+HELP: adjoin-at
+{ $values { "value" object } { "key" object } { "assoc" assoc } }
+{ $description "Adds " { $snippet "value" } " to the set stored at " { $snippet "key" } " of " { $snippet "assoc" } "." }
+{ $side-effects "assoc" } ;
HELP: duplicates
-{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
-{ $description "Outputs a new sequence consisting of elements which occur more than once in " { $snippet "seq" } "." }
+{ $values { "set" set } { "seq" sequence } }
+{ $description "Outputs a sequence consisting of elements which occur more than once in " { $snippet "set" } "." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 1 2 1 }" }
} ;
HELP: all-unique?
-{ $values { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests whether a sequence contains any repeated elements." }
+{ $values { "set" set } { "?" "a boolean" } }
+{ $description "Tests whether a set contains any repeated elements." }
{ $example
"USING: sets prettyprint ;"
"{ 0 1 1 2 3 5 } all-unique? ."
} ;
HELP: diff
-{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
-{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " but not " { $snippet "seq2" } ", comparing elements for equality."
+{ $values { "set1" set } { "set2" set } { "set" set } }
+{ $description "Outputs a set consisting of elements present in " { $snippet "set1" } " but not " { $snippet "set2" } ", comparing elements for equality."
+"This word has a default definition which works for all sets, but set implementations may override the default for efficiency."
} { $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 1 }" }
} ;
HELP: intersect
-{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
-{ $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
+{ $values { "set1" set } { "set2" set } { "set" set } }
+{ $description "Outputs a set consisting of elements present in both " { $snippet "set1" } " and " { $snippet "set2" } "."
+"This word has a default definition which works for all sets, but set implementations may override the default for efficiency." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
} ;
HELP: union
-{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
-{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." }
+{ $values { "set1" set } { "set2" set } { "set" set } }
+{ $description "Outputs a set consisting of elements present in either " { $snippet "set1" } " or " { $snippet "set2" } " which does not contain duplicate values."
+"This word has a default definition which works for all sets, but set implementations may override the default for efficiency." }
{ $examples
- { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "V{ 1 2 3 4 }" }
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "{ 1 2 3 4 }" }
} ;
{ diff intersect union } related-words
HELP: intersects?
-{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." }
-{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ;
+{ $values { "set1" set } { "set2" set } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "set1" } " and " { $snippet "set2" } " have any elements in common." }
+{ $notes "If one of the sets is empty, the result is always " { $link f } "." } ;
HELP: subset?
-{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
-{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." }
-{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ;
+{ $values { "set1" set } { "set2" set } { "?" "a boolean" } }
+{ $description "Tests if every element of " { $snippet "set1" } " is contained in " { $snippet "set2" } "." }
+{ $notes "If " { $snippet "set1" } " is empty, the result is always " { $link t } "." } ;
HELP: set=
-{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
-{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;
+{ $values { "set1" set } { "set2" set } { "?" "a boolean" } }
+{ $description "Tests if both sets contain the same elements, disregrading order and duplicates." } ;
HELP: gather
{ $values
{ "newseq" sequence } }
{ $description "Maps a quotation onto a sequence, concatenates the results of the mapping, and removes duplicates." } ;
+HELP: set-like
+{ $values { "set" set } { "exemplar" set } { "set'" set } }
+{ $description "If the conversion is defined for the exemplar, converts the set into a set of the exemplar's class. This is not guaranteed to create a new set, for example if the input set and exemplar are of the same class." $nl
+"Set implementations may optionally implement a method on this generic word. The default implementation returns its input set." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } HS{ } set-like ." "HS{ 1 2 3 }" }
+} ;
+
+HELP: within
+{ $values { "seq" sequence } { "set" set } { "subseq" sequence } }
+{ $description "Returns the subsequence of the given sequence consisting of members of the set. This may contain duplicates, if the sequence has duplicates." } ;
+
+HELP: without
+{ $values { "seq" sequence } { "set" set } { "subseq" sequence } }
+{ $description "Returns the subsequence of the given sequence consisting of things that are not members of the set. This may contain duplicates, if the sequence has duplicates." } ;
-USING: kernel sets tools.test ;
+! Copyright (C) 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sets tools.test kernel prettyprint hash-sets sorting ;
IN: sets.tests
-[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
-[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
-
-[ V{ 1 2 3 } ] [ { 1 2 2 3 3 } prune ] unit-test
-[ V{ 3 2 1 } ] [ { 3 3 2 2 1 } prune ] unit-test
-
[ { } ] [ { } { } intersect ] unit-test
[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } intersect ] unit-test
[ { } ] [ { } { } diff ] unit-test
[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+[ { 1 } ] [ { 1 1 2 3 } { 2 3 4 4 } diff ] unit-test
-[ V{ } ] [ { } { } union ] unit-test
-[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
+[ { } ] [ { } { } within ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } within ] unit-test
+[ { 2 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } within ] unit-test
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+[ { } ] [ { } { } without ] unit-test
+[ { 1 } ] [ { 1 2 3 } { 2 3 4 } without ] unit-test
+[ { 1 1 } ] [ { 1 1 2 3 3 } { 2 3 4 4 } without ] unit-test
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
+[ { } ] [ { } { } union ] unit-test
+[ { 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
[ f ] [ { 1 } { } intersects? ] unit-test
+[ t ] [ 4 { 2 4 5 } in? ] unit-test
+[ f ] [ 1 { 2 4 5 } in? ] unit-test
+
+[ V{ 1 2 3 } ] [ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+[ V{ 1 2 } ] [ 2 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+[ V{ 1 2 } ] [ 3 V{ 1 2 } clone [ delete ] keep ] unit-test
+[ V{ 2 } ] [ 1 V{ 1 2 } clone [ delete ] keep ] unit-test
+
+[ t ] [ { 1 2 3 } { 2 1 3 } set= ] unit-test
+[ f ] [ { 2 3 } { 1 2 3 } set= ] unit-test
+[ f ] [ { 1 2 3 } { 2 3 } set= ] unit-test
+
+[ { 1 } ] [ { 1 } members ] unit-test
+
+[ { 1 2 3 } ] [ { 1 1 1 2 2 3 3 3 3 3 } dup set-like natural-sort ] unit-test
+[ { 1 2 3 } ] [ HS{ 1 2 3 } { } set-like natural-sort ] unit-test
+
+[ HS{ 1 2 3 } ] [ { 1 2 3 } fast-set ] unit-test
+
+[ { 1 2 3 } ] [ { { 1 } { 2 } { 1 3 } } combine ] unit-test
+
+[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
+[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
+
+[ { 1 2 3 } ] [ { 1 2 2 3 3 } { } set-like ] unit-test
+[ { 3 2 1 } ] [ { 3 3 2 2 1 } { } set-like ] unit-test
+
+[ { 2 1 2 1 } ] [ { 1 2 3 2 1 2 1 } duplicates ] unit-test
+[ f ] [ HS{ 1 2 3 1 2 1 } duplicates ] unit-test
+
+[ H{ { 3 HS{ 1 2 } } } ] [ H{ } clone 1 3 pick adjoin-at 2 3 pick adjoin-at ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2010 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs hashtables kernel sequences vectors ;
+USING: accessors assocs hashtables kernel vectors
+math sequences ;
+FROM: assocs => change-at ;
IN: sets
-: adjoin ( elt seq -- ) [ remove! drop ] [ push ] 2bi ;
+! Set protocol
+MIXIN: set
+GENERIC: adjoin ( elt set -- )
+GENERIC: in? ( elt set -- ? )
+GENERIC: delete ( elt set -- )
+GENERIC: set-like ( set exemplar -- set' )
+GENERIC: fast-set ( set -- set' )
+GENERIC: members ( set -- seq )
+GENERIC: union ( set1 set2 -- set )
+GENERIC: intersect ( set1 set2 -- set )
+GENERIC: intersects? ( set1 set2 -- ? )
+GENERIC: diff ( set1 set2 -- set )
+GENERIC: subset? ( set1 set2 -- ? )
+GENERIC: set= ( set1 set2 -- ? )
+GENERIC: duplicates ( set -- seq )
+GENERIC: all-unique? ( set -- ? )
+
+! Defaults for some methods.
+! Override them for efficiency
+
+M: set set-like drop ; inline
+
+M: set union
+ [ [ members ] bi@ append ] keep set-like ;
-: conjoin ( elt assoc -- ) dupd set-at ;
+<PRIVATE
-: conjoin-at ( value key assoc -- )
- [ dupd ?set-at ] change-at ;
+: tester ( set -- quot )
+ fast-set [ in? ] curry ; inline
-: (prune) ( elt hash vec -- )
- 3dup drop key? [ 3drop ] [
- [ drop conjoin ] [ nip push ] 3bi
- ] if ; inline
+: sequence/tester ( set1 set2 -- set1' quot )
+ [ members ] [ tester ] bi* ; inline
-: prune ( seq -- newseq )
- [ ] [ length <hashtable> ] [ length <vector> ] tri
- [ [ (prune) ] 2curry each ] keep ;
+PRIVATE>
-: duplicates ( seq -- newseq )
- H{ } clone [ [ key? ] [ conjoin ] 2bi ] curry filter ;
+M: set intersect
+ [ sequence/tester filter ] keep set-like ;
-: gather ( seq quot -- newseq )
- map concat prune ; inline
+M: set diff
+ [ sequence/tester [ not ] compose filter ] keep set-like ;
-: unique ( seq -- assoc )
- [ dup ] H{ } map>assoc ;
+M: set intersects?
+ sequence/tester any? ;
+
+M: set subset?
+ sequence/tester all? ;
+
+M: set set=
+ 2dup subset? [ swap subset? ] [ 2drop f ] if ;
+
+M: set fast-set ;
-: (all-unique?) ( elt hash -- ? )
- 2dup key? [ 2drop f ] [ conjoin t ] if ;
+M: set duplicates drop f ;
-: all-unique? ( seq -- ? )
- dup length <hashtable> [ (all-unique?) ] curry all? ;
+M: set all-unique? drop t ;
<PRIVATE
-: tester ( seq -- quot ) unique [ key? ] curry ; inline
+: (pruned) ( elt hash vec -- )
+ 3dup drop in? [ 3drop ] [
+ [ drop adjoin ] [ nip push ] 3bi
+ ] if ; inline
+
+: pruned ( seq -- newseq )
+ [ f fast-set ] [ length <vector> ] bi
+ [ [ (pruned) ] 2curry each ] keep ;
PRIVATE>
-: intersect ( seq1 seq2 -- newseq )
- tester filter ;
+! Sequences are sets
+INSTANCE: sequence set
+
+M: sequence in?
+ member? ; inline
-: intersects? ( seq1 seq2 -- ? )
- tester any? ;
+M: sequence adjoin
+ [ delete ] [ push ] 2bi ;
-: diff ( seq1 seq2 -- newseq )
- tester [ not ] compose filter ;
+M: sequence delete
+ remove! drop ; inline
-: union ( seq1 seq2 -- newseq )
- append prune ;
+M: sequence set-like
+ [ members ] dip like ;
-: subset? ( seq1 seq2 -- ? )
- tester all? ;
+M: sequence members
+ [ pruned ] keep like ;
-: set= ( seq1 seq2 -- ? )
- [ unique ] bi@ = ;
+M: sequence all-unique?
+ dup pruned sequence= ;
+
+: combine ( sets -- set )
+ [ f ]
+ [ [ [ members ] map concat ] [ first ] bi set-like ]
+ if-empty ;
+
+: gather ( seq quot -- newseq )
+ map concat members ; inline
+
+: adjoin-at ( value key assoc -- )
+ [ [ f fast-set ] unless* [ adjoin ] keep ] change-at ;
+
+: within ( seq set -- subseq )
+ fast-set [ in? ] curry filter ;
+
+: without ( seq set -- subseq )
+ fast-set [ in? not ] curry filter ;
+
+! Temporarily for compatibility
+
+: unique ( seq -- assoc )
+ [ dup ] H{ } map>assoc ;
+: conjoin ( elt assoc -- )
+ dupd set-at ;
+: conjoin-at ( value key assoc -- )
+ [ dupd ?set-at ] change-at ;
[ 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>
{ $subsections POSTPONE: H{ }
"Hashtables are documented in " { $link "hashtables" } "." ;
+ARTICLE: "syntax-hash-sets" "Hash set syntax"
+{ $subsections POSTPONE: HS{ }
+"Hashtables are documented in " { $link "hash-sets" } "." ;
+
ARTICLE: "syntax-tuples" "Tuple syntax"
{ $subsections POSTPONE: T{ }
"Tuples are documented in " { $link "tuples" } "." ;
"syntax-vectors"
"syntax-sbufs"
"syntax-hashtables"
+ "syntax-hash-sets"
"syntax-tuples"
"syntax-pathnames"
"syntax-effects"
$nl
"Parsing words can use this word as a generic end delimiter." } ;
-{ POSTPONE: { POSTPONE: V{ POSTPONE: H{ POSTPONE: C{ POSTPONE: T{ POSTPONE: W{ POSTPONE: } } related-words
+{ POSTPONE: { POSTPONE: V{ POSTPONE: H{ POSTPONE: HS{ POSTPONE: C{ POSTPONE: T{ POSTPONE: W{ POSTPONE: } } related-words
HELP: {
{ $syntax "{ elements... }" }
{ $description "Marks the beginning of a literal hashtable, given as a list of two-element arrays holding key/value pairs. Literal hashtables are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "H{ { \"tuna\" \"fish\" } { \"jalapeno\" \"vegetable\" } }" } } ;
+HELP: HS{
+{ $syntax "HS{ members ... }" }
+{ $values { "members" "a list of objects" } }
+{ $description "Marks the beginning of a literal hash set, given as a list of its members. Literal hashtables are terminated by " { $link POSTPONE: } } "." }
+{ $examples { $code "HS{ 3 \"foo\" }" } } ;
+
HELP: C{
{ $syntax "C{ real-part imaginary-part }" }
{ $values { "real-part" "a real number" } { "imaginary-part" "a real number" } }
io.pathnames vocabs vocabs.parser classes.parser classes.union
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple.parser compiler.units
-combinators effects.parser slots ;
+combinators effects.parser slots hash-sets ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
"UNUSE:" [ scan unuse-vocab ] define-core-syntax
- "USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax
+ "USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
"QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax
"T{" [ parse-tuple-literal suffix! ] define-core-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-core-syntax
+ "HS{" [ \ } [ <hash-set> ] parse-literal ] define-core-syntax
"POSTPONE:" [ scan-word suffix! ] define-core-syntax
"\\" [ scan-word <wrapper> suffix! ] define-core-syntax
] define-core-syntax
"SYMBOLS:" [
- ";" parse-tokens
- [ create-in dup reset-generic define-symbol ] each
+ ";" [ create-in dup reset-generic define-symbol ] each-token
] define-core-syntax
"SINGLETONS:" [
- ";" parse-tokens
- [ create-class-in define-singleton-class ] each
+ ";" [ create-class-in define-singleton-class ] each-token
] define-core-syntax
"DEFER:" [
: os ( -- class ) \ os get-global ; foldable
+: vm-compiler ( -- string ) \ vm-compiler get-global ; foldable
+
<PRIVATE
: string>cpu ( str -- class )
--- /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
HOLIDAY: martin-luther-king-day january 3 monday-of-month ;
HOLIDAY-NAME: martin-luther-king-day us-federal "Martin Luther King Day"
-HOLIDAY: inauguration-day year dup 4 neg rem + january 20 >>day ;
+HOLIDAY: inauguration-day january 20 >>day [ dup 4 neg rem + ] change-year ;
HOLIDAY-NAME: inauguration-day us "Inauguration Day"
HOLIDAY: washingtons-birthday february 3 monday-of-month ;
! See http:// factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax classes.struct combinators
combinators.short-circuit kernel math math.order sequences
-specialized-arrays.instances.alien.c-types.void* typed
-specialized-arrays locals system alien.libraries ;
+typed specialized-arrays locals system alien.libraries ;
+SPECIALIZED-ARRAY: void*
IN: chipmunk.ffi
-<< "chipmunk" {
- { [ os windows? ] [ "chipmunk.dll" ] }
- { [ os macosx? ] [ "libchipmunk.dylib" ] }
- { [ os unix? ] [ "libchipmunk.so" ] }
- } cond "cdecl" add-library >>
+<<
+"chipmunk" {
+ { [ os windows? ] [ "chipmunk.dll" ] }
+ { [ os macosx? ] [ "libchipmunk.dylib" ] }
+ { [ os unix? ] [ "libchipmunk.so" ] }
+} cond "cdecl" add-library
+
+"chipmunk" deploy-library
+>>
LIBRARY: chipmunk
! chipmunk_types.h
] with-directory ;
: patch-counts ( authors -- assoc )
- dup prune
+ dup members
[ dup rot [ = ] with count ] with
{ } map>assoc ;
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 -- )
[ word? ] filter [ word>xref ] map ;
: filter-prefix ( seq prefix -- seq )
- [ drop-prefix nip length 0 = ] curry filter prune ;
+ [ drop-prefix nip length 0 = ] curry filter members ;
MEMO: (vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
append H{ } [ assoc-union ] reduce keys ;
: vocabs-words ( names -- seq )
- prune [ (vocab-words) ] map concat ;
+ members [ (vocab-words) ] map concat ;
PRIVATE>
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays classes.struct fry kernel
+literals locals make math math.bitwise multiline sequences
+slots.syntax ui.backend.windows vocabs.loader windows.errors
+windows.gdi32 windows.kernel32 windows.types windows.user32
+ui.gadgets.worlds ;
+IN: fullscreen
+
+: hwnd>hmonitor ( HWND -- HMONITOR )
+ MONITOR_DEFAULTTOPRIMARY MonitorFromWindow ;
+
+: desktop-hmonitor ( -- HMONITOR )
+ GetDesktopWindow hwnd>hmonitor ;
+
+:: (monitor-info>devmodes) ( monitor-info n -- )
+ DEVMODE <struct>
+ DEVMODE heap-size >>dmSize
+ { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields
+ :> devmode
+
+ monitor-info szDevice>>
+ n
+ devmode
+ EnumDisplaySettings 0 = [
+ devmode ,
+ monitor-info n 1 + (monitor-info>devmodes)
+ ] unless ;
+
+: monitor-info>devmodes ( monito-info -- devmodes )
+ [ 0 (monitor-info>devmodes) ] { } make ;
+
+: hmonitor>monitor-info ( HMONITOR -- monitor-info )
+ MONITORINFOEX <struct>
+ MONITORINFOEX heap-size >>cbSize
+ [ GetMonitorInfo win32-error=0/f ] keep ;
+
+: hwnd>monitor-info ( HWND -- monitor-info )
+ hwnd>hmonitor hmonitor>monitor-info ;
+
+: hmonitor>devmodes ( HMONITOR -- devmodes )
+ hmonitor>monitor-info monitor-info>devmodes ;
+
+: desktop-devmodes ( -- DEVMODEs )
+ desktop-hmonitor hmonitor>devmodes ;
+
+: desktop-monitor-info ( -- monitor-info )
+ desktop-hmonitor hmonitor>monitor-info ;
+
+: desktop-RECT ( -- RECT )
+ GetDesktopWindow RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
+
+ERROR: display-change-error n ;
+
+: fullscreen-mode ( monitor-info devmode -- )
+ [ szDevice>> ] dip f CDS_FULLSCREEN f
+ ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
+ [ drop ] [ display-change-error ] if ;
+
+: non-fullscreen-mode ( monitor-info devmode -- )
+ [ szDevice>> ] dip f 0 f
+ ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
+ [ drop ] [ display-change-error ] if ;
+
+: get-style ( hwnd n -- style )
+ GetWindowLongPtr [ win32-error=0/f ] keep ;
+
+: set-style ( hwnd n style -- )
+ SetWindowLongPtr win32-error=0/f ;
+
+: change-style ( hwnd n quot -- )
+ [ 2dup get-style ] dip call set-style ; inline
+
+: set-fullscreen-styles ( hwnd -- )
+ [ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
+ [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ;
+
+: set-non-fullscreen-styles ( hwnd -- )
+ [ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
+ [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ;
+
+ERROR: unsupported-resolution triple ;
+
+:: find-devmode ( triple hwnd -- devmode )
+ hwnd hwnd>hmonitor hmonitor>devmodes
+ [
+ slots{ dmPelsWidth dmPelsHeight dmBitsPerPel }
+ triple =
+ ] find nip [ triple unsupported-resolution ] unless* ;
+
+:: set-fullscreen-window-position ( hwnd triple -- )
+ hwnd f
+ desktop-monitor-info rcMonitor>> slots{ left top } first2
+ triple first2
+ {
+ SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
+ SWP_NOREPOSITION SWP_NOZORDER
+ } flags
+ SetWindowPos win32-error=0/f ;
+
+:: enable-fullscreen ( triple hwnd -- rect )
+ hwnd hwnd>RECT :> rect
+
+ desktop-monitor-info
+ triple GetDesktopWindow find-devmode
+ hwnd set-fullscreen-styles
+ fullscreen-mode
+
+ hwnd triple set-fullscreen-window-position
+ rect ;
+
+:: set-window-position ( hwnd rect -- )
+ hwnd f rect get-RECT-dimensions SWP_FRAMECHANGED
+ SetWindowPos win32-error=0/f ;
+
+:: disable-fullscreen ( rect triple hwnd -- )
+ desktop-monitor-info
+ triple
+ GetDesktopWindow find-devmode non-fullscreen-mode
+ hwnd set-non-fullscreen-styles
+ hwnd rect set-window-position ;
+
+: enable-factor-fullscreen ( triple -- rect )
+ GetForegroundWindow enable-fullscreen ;
+
+: disable-factor-fullscreen ( rect triple -- )
+ GetForegroundWindow disable-fullscreen ;
+
+:: (set-fullscreen) ( world triple fullscreen? -- )
+ world fullscreen?>> fullscreen? xor [
+ triple
+ world handle>> hWnd>>
+ fullscreen? [
+ enable-fullscreen world (>>saved-position)
+ ] [
+ [ world saved-position>> ] 2dip disable-fullscreen
+ ] if
+ fullscreen? world (>>fullscreen?)
+ ] when ;
+
+: set-fullscreen ( gadget triple fullscreen? -- )
+ [ find-world ] 2dip (set-fullscreen) ;
: (run-loop) ( loop -- )
dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
+ [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
[ drop ] if ;
: run-loop ( loop -- )
M: game-world begin-world
dup use-game-input?>> [ open-game-input ] when
dup use-audio-engine?>> [ dup open-game-audio-engine >>audio-engine ] when
- dup begin-game-world
- dup [ tick-interval-micros>> ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
- drop ;
+ dup [ tick-interval-micros>> ] [ ] bi <game-loop>
+ [ >>game-loop begin-game-world ] keep start-loop ;
M: game-world end-world
[ [ stop-loop ] when* f ] change-game-loop
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
[ >url ] map ;
: find-all-links ( vector -- vector' )
- [ find-hrefs ] [ find-frame-links ] bi append prune ;
+ [ find-hrefs ] [ find-frame-links ] bi union ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
: 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 ;
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
splitting sorting shuffle sets math.order ;
+FROM: namespaces => set ;
IN: koszul
! Utilities
[ nth ] 2keep swap 1 + tail-slice (inversions) +
] curry each ;
-: duplicates? ( seq -- ? )
- dup prune [ length ] bi@ > ;
-
: (wedge) ( n basis1 basis2 -- n basis )
- append dup duplicates? [
+ append dup all-unique? not [
2drop 0 { }
] [
dup permutation inversions -1^ rot *
namespaces parser sequences sorting splitting strings.parser
unicode.case unicode.categories calendar calendar.format
locals io.encodings.binary io.encodings.string prettyprint ;
+FROM: namespaces => set ;
IN: managed-server.chat
TUPLE: chat-server < managed-server ;
io.streams.duplex fry kernel locals math math.ranges multiline
namespaces prettyprint random sequences sets splitting threads
tools.continuations ;
+FROM: namespaces => set ;
IN: managed-server
TUPLE: managed-server < threaded-server clients ;
-! 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 ( -- )
:: do-step ( errors summary-file details-file -- )
errors
[ error-type +linkage-error+ eq? not ] filter
- [ file>> ] map prune natural-sort summary-file to-file
+ [ file>> ] map members natural-sort summary-file to-file
errors details-file utf8 [ errors. ] with-file-writer ;
: do-tests ( -- )
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
compiler-error-messages-file
do-step ;
-: check-boot-image ( -- )
- "" to-refresh drop 2dup [ empty? not ] either?
- [
- "Boot image is out of date. Changed vocabs:" print
- append prune [ print ] each
- flush
- 1 exit
- ] [ 2drop ] if ;
+: outdated-core-vocabs ( -- modified-sources modified-docs any? )
+ "" to-refresh drop 2dup [ empty? not ] either? ;
+
+: outdated-boot-image. ( modified-sources modified-docs -- )
+ "Boot image is out of date. Changed vocabs:" print
+ union [ print ] each
+ flush ;
+
+: check-boot-image ( -- ? )
+ outdated-core-vocabs [ outdated-boot-image. t ] [ 2drop f ] if ;
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
- check-boot-image
+ check-boot-image [ 1 exit ] when
[ 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>
quotations generalizations debugger io compiler.units
kernel.private effects accessors hashtables sorting shuffle
math.order sets see effects.parser ;
+FROM: namespaces => set ;
IN: multi-methods
! PART I: Converting hook specializers
--- /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
string>value value>hand-name ;
SYNTAX: HAND{
- "}" parse-tokens [ card> ] { } map-as suffix! ;
+ "}" [ card> ] map-tokens suffix! ;
PRIVATE>
: euler004 ( -- answer )
- source-004 dup cartesian-product [ product ] map prune max-palindrome ;
+ source-004 dup [ * ] cartesian-map combine max-palindrome ;
! [ euler004 ] 100 ave-time
! 1164 ms ave run time - 39.35 SD (100 trials)
: source-027 ( -- seq )
1000 iota [ prime? ] filter [ dup [ neg ] map append ] keep
- cartesian-product [ first2 < ] filter ;
+ cartesian-product concat [ first2 < ] filter ;
: quadratic ( b a n -- m )
dup sq -rot * + + ;
! --------
: euler029 ( -- answer )
- 2 100 [a,b] dup cartesian-product [ first2 ^ ] map prune length ;
+ 2 100 [a,b] dup [ ^ ] cartesian-map concat members length ;
! [ euler029 ] 100 ave-time
! 704 ms ave run time - 28.07 SD (100 trials)
PRIVATE>
: euler032 ( -- answer )
- source-032 [ valid? ] filter products prune sum ;
+ source-032 [ valid? ] filter products members sum ;
! [ euler032 ] 10 ave-time
! 16361 ms ave run time - 417.8 SD (10 trials)
<PRIVATE
-: source-032a ( -- seq )
- 50 [1,b] 2000 [1,b] cartesian-product ;
-
! multiplicand/multiplier/product
-: mmp ( pair -- n )
- first2 2dup * [ number>string ] tri@ 3append string>number ;
+: mmp ( x y -- n )
+ 2dup * [ number>string ] tri@ 3append string>number ;
PRIVATE>
: euler032a ( -- answer )
- source-032a [ mmp ] map [ pandigital? ] filter products prune sum ;
+ 50 [1,b] 2000 [1,b]
+ [ mmp ] cartesian-map concat
+ [ pandigital? ] filter
+ products members sum ;
! [ euler032a ] 10 ave-time
! 2624 ms ave run time - 131.91 SD (10 trials)
<PRIVATE
: source-033 ( -- seq )
- 10 99 [a,b] dup cartesian-product [ first2 < ] filter ;
+ 10 99 [a,b] dup cartesian-product concat [ first2 < ] filter ;
: safe? ( ax xb -- ? )
[ 10 /mod ] bi@ [ = ] dip zero? not and nip ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.combinatorics math.parser math.primes
- project-euler.common sequences sets ;
+ project-euler.common sequences ;
IN: project-euler.035
! http://projecteuler.net/index.php?section=problems&id=35
: possible? ( seq -- ? )
dup length 1 > [
- dup { 0 2 4 5 6 8 } diff =
+ [ even? ] any? not
] [
drop t
] if ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
- candidates swap cartesian-product [ overlap? ] filter clean
+ candidates swap cartesian-product concat
+ [ overlap? ] filter clean
] each [ add-missing-digit ] map ;
PRIVATE>
USING: assocs kernel math math.combinatorics math.functions
math.parser math.primes namespaces project-euler.common
sequences sets strings grouping math.ranges arrays fry math.order ;
+FROM: namespaces => set ;
IN: project-euler.051
<PRIVATE
SYMBOL: family-count
! Through analysis, you only need to check when a and b > 90
: euler056 ( -- answer )
- 90 100 [a,b) dup cartesian-product
+ 90 100 [a,b) dup cartesian-product concat
[ first2 ^ number>digits sum ] [ max ] map-reduce ;
! [ euler056 ] 100 ave-time
over length <rollover> swap [ bitxor ] 2map ;
: frequency-analysis ( seq -- seq )
- dup prune [
+ dup members [
[ 2dup [ = ] curry count 2array , ] each
] { } make nip ; inline
] { } make ;
: find-source ( seq -- elt )
- unzip diff prune
+ unzip diff
[ "Topological sort failed" throw ] [ first ] if-empty ;
: remove-source ( seq elt -- seq )
: topological-sort ( seq -- seq )
[ [ (topological-sort) ] { } make ] keep
- concat prune over diff append ;
+ combine over diff append ;
: euler079 ( -- answer )
source-079 >edges topological-sort 10 digits>integer ;
! [ euler079 ] 100 ave-time
! 1 ms ave run time - 0.46 SD (100 trials)
-! TODO: prune and diff are relatively slow; topological sort could be
+! TODO: set words on sequences are relatively slow; topological sort could be
! cleaned up and generalized much better, but it works for this problem
SOLUTION: euler079
3dup minimal-path-sum-to '[ _ + ] change-matrix ;
: (euler081) ( matrix -- n )
- dup first length iota dup cartesian-product
- [ first2 pick update-minimal-path-sum ] each
+ dup first length iota dup
+ [ pick update-minimal-path-sum ] cartesian-each
last last ;
PRIVATE>
: 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
[ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
: generate ( n -- seq )
- 1 - { 1 } [ (generate) ] iterate concat prune ;
+ 1 - { 1 } [ (generate) ] iterate combine ;
: squarefree ( n -- ? )
factors all-unique? ;
! 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
: alpha-value ( str -- n )
>lower [ CHAR: a - 1 + ] map-sum ;
-: cartesian-product ( seq1 seq2 -- seq1xseq2 )
- [ [ 2array ] with map ] curry map concat ;
-
: mediant ( a/c b/d -- (a+b)/(c+d) )
2>fraction [ + ] 2bi@ / ;
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
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: slots.syntax
+
+HELP: slots[
+{ $description "Outputs several slot values to the stack." }
+{ $example "USING: kernel prettyprint slots.syntax ;"
+ "IN: slots.syntax.example"
+ "TUPLE: rectangle width height ;"
+ "T{ rectangle { width 3 } { height 5 } } slots[ width height ] [ . ] bi@"
+ """3
+5"""
+} ;
+
+HELP: slots{
+{ $description "Outputs an array of slot values from a tuple." }
+{ $example "USING: prettyprint slots.syntax ;"
+ "IN: slots.syntax.example"
+ "TUPLE: rectangle width height ;"
+ "T{ rectangle { width 3 } { height 5 } } slots{ width height } ."
+ "{ 3 5 }"
+} ;
+
+ARTICLE: "slots.syntax" "Slots syntax sugar"
+"The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for taking a sequence of slots from a tuple." $nl
+"Syntax sugar for cleaving slots to the stack:"
+{ $subsections POSTPONE: slots[ }
+"Syntax sugar for cleaving slots to an array:"
+{ $subsections POSTPONE: slots{ } ;
+
+ABOUT: "slots.syntax"
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test slots.syntax ;
+IN: slots.syntax.tests
+
+TUPLE: slot-test a b c ;
+
+[ 1 2 3 ] [ T{ slot-test f 1 2 3 } slots[ a b c ] ] unit-test
+[ 3 ] [ T{ slot-test f 1 2 3 } slots[ c ] ] unit-test
+[ ] [ T{ slot-test f 1 2 3 } slots[ ] ] unit-test
+
+[ { 1 2 3 } ] [ T{ slot-test f 1 2 3 } slots{ a b c } ] unit-test
+[ { 3 } ] [ T{ slot-test f 1 2 3 } slots{ c } ] unit-test
+[ { } ] [ T{ slot-test f 1 2 3 } slots{ } ] unit-test
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators combinators.smart fry lexer quotations
+sequences slots ;
+IN: slots.syntax
+
+SYNTAX: slots[
+ "]" [ reader-word 1quotation ] map-tokens
+ '[ _ cleave ] append! ;
+
+SYNTAX: slots{
+ "}" [ reader-word 1quotation ] map-tokens
+ '[ [ _ cleave ] output>array ] append! ;
nonmatching>> push-links ;
: filter-base-links ( spider spider-result -- base-links nonmatching-links )
- [ base>> host>> ] [ links>> prune ] bi*
+ [ base>> host>> ] [ links>> members ] bi*
[ host>> = ] with partition ;
: add-spidered ( spider spider-result -- )
[ define-var ] each ;
SYNTAX: VARS: ! vars ...
- ";" parse-tokens define-vars ;
+ ";" [ define-var ] each-token ;
<p>This is the <a href="http://factorcode.org" target="_top">Factor</a>
documentation, generated offline from a
- <code>load-everything</code> image. If you want, you can also browse the
+ <code>load-all</code> image. If you want, you can also browse the
documentation from within the <a href="http://factorcode.org" target="_top">Factor</a> UI.</p>
<p>You may search article titles below; for example, try searching for "HTTP".</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">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
*ptr = value; \
}
-DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,from_signed_cell,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,from_unsigned_cell,to_cell)
-DEFINE_ALIEN_ACCESSOR(signed_8,s64,from_signed_8,to_signed_8)
-DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,from_unsigned_8,to_unsigned_8)
-DEFINE_ALIEN_ACCESSOR(signed_4,s32,from_signed_4,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,from_unsigned_4,to_cell)
-DEFINE_ALIEN_ACCESSOR(signed_2,s16,from_signed_2,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,from_unsigned_2,to_cell)
-DEFINE_ALIEN_ACCESSOR(signed_1,s8,from_signed_1,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,from_unsigned_1,to_cell)
-DEFINE_ALIEN_ACCESSOR(float,float,from_float,to_float)
-DEFINE_ALIEN_ACCESSOR(double,double,from_double,to_double)
-DEFINE_ALIEN_ACCESSOR(cell,void *,allot_alien,pinned_alien_offset)
+EACH_ALIEN_PRIMITIVE(DEFINE_ALIEN_ACCESSOR)
/* open a native library and push a handle */
void factor_vm::primitive_dlopen()
retainstack(0),
datastack_region(new segment(ds_size,false)),
retainstack_region(new segment(rs_size,false)),
- catchstack_save(0),
- current_callback_save(0),
next(NULL)
{
reset_datastack();
reset_retainstack();
+ reset_context_objects();
+}
+
+void context::reset_datastack()
+{
+ datastack = datastack_region->start - sizeof(cell);
+}
+
+void context::reset_retainstack()
+{
+ retainstack = retainstack_region->start - sizeof(cell);
+}
+
+void context::reset_context_objects()
+{
+ memset_cell(context_objects,false_object,context_object_count * sizeof(cell));
}
context *factor_vm::alloc_context()
new_ctx->callstack_bottom = (stack_frame *)-1;
new_ctx->callstack_top = (stack_frame *)-1;
- /* save per-callback special_objects */
- new_ctx->current_callback_save = special_objects[OBJ_CURRENT_CALLBACK];
- new_ctx->catchstack_save = special_objects[OBJ_CATCHSTACK];
-
new_ctx->reset_datastack();
new_ctx->reset_retainstack();
+ new_ctx->reset_context_objects();
new_ctx->next = ctx;
ctx = new_ctx;
/* called when leaving a compiled callback */
void factor_vm::unnest_stacks()
{
- /* restore per-callback special_objects */
- special_objects[OBJ_CURRENT_CALLBACK] = ctx->current_callback_save;
- special_objects[OBJ_CATCHSTACK] = ctx->catchstack_save;
-
context *old_ctx = ctx;
ctx = old_ctx->next;
dealloc_context(old_ctx);
unused_contexts = NULL;
}
+void factor_vm::primitive_context_object()
+{
+ fixnum n = untag_fixnum(ctx->peek());
+ ctx->replace(ctx->context_objects[n]);
+}
+
+void factor_vm::primitive_set_context_object()
+{
+ fixnum n = untag_fixnum(ctx->pop());
+ cell value = ctx->pop();
+ ctx->context_objects[n] = value;
+}
+
bool factor_vm::stack_to_array(cell bottom, cell top)
{
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
namespace factor
{
+static const cell context_object_count = 10;
+
+enum context_object {
+ OBJ_NAMESTACK,
+ OBJ_CATCHSTACK,
+ OBJ_CONTEXT_ID,
+};
+
/* Assembly code makes assumptions about the layout of this struct */
struct context {
/* C stack pointer on entry */
/* memory region holding current retain stack */
segment *retainstack_region;
- /* saved special_objects slots on entry to callback */
- cell catchstack_save;
- cell current_callback_save;
+ /* context-specific special objects, accessed by context-object and
+ set-context-object primitives */
+ cell context_objects[context_object_count];
context *next;
context(cell ds_size, cell rs_size);
+ void reset_datastack();
+ void reset_retainstack();
+ void reset_context_objects();
cell peek()
{
replace(tagged);
}
- void reset_datastack()
- {
- datastack = datastack_region->start - sizeof(cell);
- }
-
- void reset_retainstack()
- {
- retainstack = retainstack_region->start - sizeof(cell);
- }
-
static const cell stack_reserved = (64 * sizeof(cell));
void fix_stacks()
special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path);
special_objects[OBJ_ARGS] = false_object;
special_objects[OBJ_EMBEDDED] = false_object;
+ special_objects[OBJ_VM_COMPILER] = allot_alien(false_object,(cell)FACTOR_COMPILER_VERSION);
/* We can GC now */
gc_off = false;
#include <vector>
#include <iostream>
+#define FACTOR_STRINGIZE(x) #x
+
+/* Record compiler version */
+#if defined(__clang__)
+ #define FACTOR_COMPILER_VERSION "Clang (GCC " __VERSION__ ")"
+#elif defined(__INTEL_COMPILER)
+ #define FACTOR_COMPILER_VERSION "Intel C Compiler " FACTOR_STRINGIZE(__INTEL_COMPILER)
+#elif defined(__GNUC__)
+ #define FACTOR_COMPILER_VERSION "GCC " __VERSION__
+#elif defined(_MSC_FULL_VER)
+ #define FACTOR_COMPILER_VERSION "Microsoft Visual C++ " FACTOR_STRINGIZE(_MSC_FULL_VER)
+#else
+ #define FACTOR_COMPILER_VERSION "unknown"
+#endif
+
/* Detect target CPU type */
#if defined(__arm__)
#define FACTOR_ARM
void factor_vm::primitive_special_object()
{
- fixnum e = untag_fixnum(ctx->peek());
- ctx->replace(special_objects[e]);
+ fixnum n = untag_fixnum(ctx->peek());
+ ctx->replace(special_objects[n]);
}
void factor_vm::primitive_set_special_object()
{
- fixnum e = untag_fixnum(ctx->pop());
+ fixnum n = untag_fixnum(ctx->pop());
cell value = ctx->pop();
- special_objects[e] = value;
+ special_objects[n] = value;
}
void factor_vm::primitive_identity_hashcode()
static const cell special_object_count = 70;
enum special_object {
- OBJ_NAMESTACK, /* used by library only */
- OBJ_CATCHSTACK, /* used by library only, per-callback */
-
- OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */
- OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */
+ OBJ_WALKER_HOOK = 3, /* non-local exit hook, used by library only */
OBJ_CALLCC_1, /* used to pass the value in callcc1 */
ERROR_HANDLER_QUOT = 5, /* quotation called when VM throws an error */
OBJ_THREADS = 64,
OBJ_RUN_QUEUE = 65,
OBJ_SLEEP_QUEUE = 66,
+
+ OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */
};
/* save-image-and-exit discards special objects that are filled in on startup
parent->primitive_##name(); \
}
-PRIMITIVE(alien_address)
-PRIMITIVE(all_instances)
-PRIMITIVE(array)
-PRIMITIVE(array_to_quotation)
-PRIMITIVE(become)
-PRIMITIVE(bignum_add)
-PRIMITIVE(bignum_and)
-PRIMITIVE(bignum_bitp)
-PRIMITIVE(bignum_divint)
-PRIMITIVE(bignum_divmod)
-PRIMITIVE(bignum_eq)
-PRIMITIVE(bignum_greater)
-PRIMITIVE(bignum_greatereq)
-PRIMITIVE(bignum_less)
-PRIMITIVE(bignum_lesseq)
-PRIMITIVE(bignum_log2)
-PRIMITIVE(bignum_mod)
-PRIMITIVE(bignum_multiply)
-PRIMITIVE(bignum_not)
-PRIMITIVE(bignum_or)
-PRIMITIVE(bignum_shift)
-PRIMITIVE(bignum_subtract)
-PRIMITIVE(bignum_to_fixnum)
-PRIMITIVE(bignum_to_float)
-PRIMITIVE(bignum_xor)
-PRIMITIVE(bits_double)
-PRIMITIVE(bits_float)
-PRIMITIVE(byte_array)
-PRIMITIVE(byte_array_to_bignum)
-PRIMITIVE(call_clear)
-PRIMITIVE(callback)
-PRIMITIVE(callstack)
-PRIMITIVE(callstack_to_array)
-PRIMITIVE(check_datastack)
-PRIMITIVE(clone)
-PRIMITIVE(code_blocks)
-PRIMITIVE(code_room)
-PRIMITIVE(compact_gc)
-PRIMITIVE(compute_identity_hashcode)
-PRIMITIVE(data_room)
-PRIMITIVE(datastack)
-PRIMITIVE(die)
-PRIMITIVE(disable_gc_events)
-PRIMITIVE(dispatch_stats)
-PRIMITIVE(displaced_alien)
-PRIMITIVE(dlclose)
-PRIMITIVE(dll_validp)
-PRIMITIVE(dlopen)
-PRIMITIVE(dlsym)
-PRIMITIVE(double_bits)
-PRIMITIVE(enable_gc_events)
-PRIMITIVE(existsp)
-PRIMITIVE(exit)
-PRIMITIVE(fclose)
-PRIMITIVE(fflush)
-PRIMITIVE(fgetc)
-PRIMITIVE(fixnum_divint)
-PRIMITIVE(fixnum_divmod)
-PRIMITIVE(fixnum_shift)
-PRIMITIVE(fixnum_to_bignum)
-PRIMITIVE(fixnum_to_float)
-PRIMITIVE(float_add)
-PRIMITIVE(float_bits)
-PRIMITIVE(float_divfloat)
-PRIMITIVE(float_eq)
-PRIMITIVE(float_greater)
-PRIMITIVE(float_greatereq)
-PRIMITIVE(float_less)
-PRIMITIVE(float_lesseq)
-PRIMITIVE(float_mod)
-PRIMITIVE(float_multiply)
-PRIMITIVE(float_subtract)
-PRIMITIVE(float_to_bignum)
-PRIMITIVE(float_to_fixnum)
-PRIMITIVE(float_to_str)
-PRIMITIVE(fopen)
-PRIMITIVE(fputc)
-PRIMITIVE(fread)
-PRIMITIVE(fseek)
-PRIMITIVE(ftell)
-PRIMITIVE(full_gc)
-PRIMITIVE(fwrite)
-PRIMITIVE(identity_hashcode)
-PRIMITIVE(innermost_stack_frame_executing)
-PRIMITIVE(innermost_stack_frame_scan)
-PRIMITIVE(jit_compile)
-PRIMITIVE(load_locals)
-PRIMITIVE(lookup_method)
-PRIMITIVE(mega_cache_miss)
-PRIMITIVE(minor_gc)
-PRIMITIVE(modify_code_heap)
-PRIMITIVE(nano_count)
-PRIMITIVE(optimized_p)
-PRIMITIVE(profiling)
-PRIMITIVE(quot_compiled_p)
-PRIMITIVE(quotation_code)
-PRIMITIVE(reset_dispatch_stats)
-PRIMITIVE(resize_array)
-PRIMITIVE(resize_byte_array)
-PRIMITIVE(resize_string)
-PRIMITIVE(retainstack)
-PRIMITIVE(save_image)
-PRIMITIVE(save_image_and_exit)
-PRIMITIVE(set_datastack)
-PRIMITIVE(set_innermost_stack_frame_quot)
-PRIMITIVE(set_retainstack)
-PRIMITIVE(set_slot)
-PRIMITIVE(set_special_object)
-PRIMITIVE(set_string_nth_fast)
-PRIMITIVE(set_string_nth_slow)
-PRIMITIVE(size)
-PRIMITIVE(sleep)
-PRIMITIVE(special_object)
-PRIMITIVE(string)
-PRIMITIVE(string_nth)
-PRIMITIVE(strip_stack_traces)
-PRIMITIVE(system_micros)
-PRIMITIVE(tuple)
-PRIMITIVE(tuple_boa)
-PRIMITIVE(unimplemented)
-PRIMITIVE(uninitialized_byte_array)
-PRIMITIVE(word)
-PRIMITIVE(word_code)
-PRIMITIVE(wrapper)
+EACH_PRIMITIVE(PRIMITIVE)
}
namespace factor
{
-#define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);
-
/* Generated with PRIMITIVE in primitives.cpp */
-DECLARE_PRIMITIVE(alien_address)
-DECLARE_PRIMITIVE(all_instances)
-DECLARE_PRIMITIVE(array)
-DECLARE_PRIMITIVE(array_to_quotation)
-DECLARE_PRIMITIVE(become)
-DECLARE_PRIMITIVE(bignum_add)
-DECLARE_PRIMITIVE(bignum_and)
-DECLARE_PRIMITIVE(bignum_bitp)
-DECLARE_PRIMITIVE(bignum_divint)
-DECLARE_PRIMITIVE(bignum_divmod)
-DECLARE_PRIMITIVE(bignum_eq)
-DECLARE_PRIMITIVE(bignum_greater)
-DECLARE_PRIMITIVE(bignum_greatereq)
-DECLARE_PRIMITIVE(bignum_less)
-DECLARE_PRIMITIVE(bignum_lesseq)
-DECLARE_PRIMITIVE(bignum_log2)
-DECLARE_PRIMITIVE(bignum_mod)
-DECLARE_PRIMITIVE(bignum_multiply)
-DECLARE_PRIMITIVE(bignum_not)
-DECLARE_PRIMITIVE(bignum_or)
-DECLARE_PRIMITIVE(bignum_shift)
-DECLARE_PRIMITIVE(bignum_subtract)
-DECLARE_PRIMITIVE(bignum_to_fixnum)
-DECLARE_PRIMITIVE(bignum_to_float)
-DECLARE_PRIMITIVE(bignum_xor)
-DECLARE_PRIMITIVE(bits_double)
-DECLARE_PRIMITIVE(bits_float)
-DECLARE_PRIMITIVE(byte_array)
-DECLARE_PRIMITIVE(byte_array_to_bignum)
-DECLARE_PRIMITIVE(call_clear)
-DECLARE_PRIMITIVE(callback)
-DECLARE_PRIMITIVE(callstack)
-DECLARE_PRIMITIVE(callstack_to_array)
-DECLARE_PRIMITIVE(check_datastack)
-DECLARE_PRIMITIVE(clone)
-DECLARE_PRIMITIVE(code_blocks)
-DECLARE_PRIMITIVE(code_room)
-DECLARE_PRIMITIVE(compact_gc)
-DECLARE_PRIMITIVE(compute_identity_hashcode)
-DECLARE_PRIMITIVE(data_room)
-DECLARE_PRIMITIVE(datastack)
-DECLARE_PRIMITIVE(die)
-DECLARE_PRIMITIVE(disable_gc_events)
-DECLARE_PRIMITIVE(dispatch_stats)
-DECLARE_PRIMITIVE(displaced_alien)
-DECLARE_PRIMITIVE(dlclose)
-DECLARE_PRIMITIVE(dll_validp)
-DECLARE_PRIMITIVE(dlopen)
-DECLARE_PRIMITIVE(dlsym)
-DECLARE_PRIMITIVE(double_bits)
-DECLARE_PRIMITIVE(enable_gc_events)
-DECLARE_PRIMITIVE(existsp)
-DECLARE_PRIMITIVE(exit)
-DECLARE_PRIMITIVE(fclose)
-DECLARE_PRIMITIVE(fflush)
-DECLARE_PRIMITIVE(fgetc)
-DECLARE_PRIMITIVE(fixnum_divint)
-DECLARE_PRIMITIVE(fixnum_divmod)
-DECLARE_PRIMITIVE(fixnum_shift)
-DECLARE_PRIMITIVE(fixnum_to_bignum)
-DECLARE_PRIMITIVE(fixnum_to_float)
-DECLARE_PRIMITIVE(float_add)
-DECLARE_PRIMITIVE(float_bits)
-DECLARE_PRIMITIVE(float_divfloat)
-DECLARE_PRIMITIVE(float_eq)
-DECLARE_PRIMITIVE(float_greater)
-DECLARE_PRIMITIVE(float_greatereq)
-DECLARE_PRIMITIVE(float_less)
-DECLARE_PRIMITIVE(float_lesseq)
-DECLARE_PRIMITIVE(float_mod)
-DECLARE_PRIMITIVE(float_multiply)
-DECLARE_PRIMITIVE(float_subtract)
-DECLARE_PRIMITIVE(float_to_bignum)
-DECLARE_PRIMITIVE(float_to_fixnum)
-DECLARE_PRIMITIVE(float_to_str)
-DECLARE_PRIMITIVE(fopen)
-DECLARE_PRIMITIVE(fputc)
-DECLARE_PRIMITIVE(fread)
-DECLARE_PRIMITIVE(fseek)
-DECLARE_PRIMITIVE(ftell)
-DECLARE_PRIMITIVE(full_gc)
-DECLARE_PRIMITIVE(fwrite)
-DECLARE_PRIMITIVE(identity_hashcode)
-DECLARE_PRIMITIVE(innermost_stack_frame_executing)
-DECLARE_PRIMITIVE(innermost_stack_frame_scan)
-DECLARE_PRIMITIVE(jit_compile)
-DECLARE_PRIMITIVE(load_locals)
-DECLARE_PRIMITIVE(lookup_method)
-DECLARE_PRIMITIVE(mega_cache_miss)
-DECLARE_PRIMITIVE(minor_gc)
-DECLARE_PRIMITIVE(modify_code_heap)
-DECLARE_PRIMITIVE(nano_count)
-DECLARE_PRIMITIVE(optimized_p)
-DECLARE_PRIMITIVE(profiling)
-DECLARE_PRIMITIVE(quot_compiled_p)
-DECLARE_PRIMITIVE(quotation_code)
-DECLARE_PRIMITIVE(reset_dispatch_stats)
-DECLARE_PRIMITIVE(resize_array)
-DECLARE_PRIMITIVE(resize_byte_array)
-DECLARE_PRIMITIVE(resize_string)
-DECLARE_PRIMITIVE(retainstack)
-DECLARE_PRIMITIVE(save_image)
-DECLARE_PRIMITIVE(save_image_and_exit)
-DECLARE_PRIMITIVE(set_datastack)
-DECLARE_PRIMITIVE(set_innermost_stack_frame_quot)
-DECLARE_PRIMITIVE(set_retainstack)
-DECLARE_PRIMITIVE(set_slot)
-DECLARE_PRIMITIVE(set_special_object)
-DECLARE_PRIMITIVE(set_string_nth_fast)
-DECLARE_PRIMITIVE(set_string_nth_slow)
-DECLARE_PRIMITIVE(size)
-DECLARE_PRIMITIVE(sleep)
-DECLARE_PRIMITIVE(special_object)
-DECLARE_PRIMITIVE(string)
-DECLARE_PRIMITIVE(string_nth)
-DECLARE_PRIMITIVE(strip_stack_traces)
-DECLARE_PRIMITIVE(system_micros)
-DECLARE_PRIMITIVE(tuple)
-DECLARE_PRIMITIVE(tuple_boa)
-DECLARE_PRIMITIVE(unimplemented)
-DECLARE_PRIMITIVE(uninitialized_byte_array)
-DECLARE_PRIMITIVE(word)
-DECLARE_PRIMITIVE(word_code)
-DECLARE_PRIMITIVE(wrapper)
+#define EACH_PRIMITIVE(_) \
+ _(alien_address) \
+ _(all_instances) \
+ _(array) \
+ _(array_to_quotation) \
+ _(become) \
+ _(bignum_add) \
+ _(bignum_and) \
+ _(bignum_bitp) \
+ _(bignum_divint) \
+ _(bignum_divmod) \
+ _(bignum_eq) \
+ _(bignum_greater) \
+ _(bignum_greatereq) \
+ _(bignum_less) \
+ _(bignum_lesseq) \
+ _(bignum_log2) \
+ _(bignum_mod) \
+ _(bignum_multiply) \
+ _(bignum_not) \
+ _(bignum_or) \
+ _(bignum_shift) \
+ _(bignum_subtract) \
+ _(bignum_to_fixnum) \
+ _(bignum_to_float) \
+ _(bignum_xor) \
+ _(bits_double) \
+ _(bits_float) \
+ _(byte_array) \
+ _(byte_array_to_bignum) \
+ _(call_clear) \
+ _(callback) \
+ _(callstack) \
+ _(callstack_to_array) \
+ _(check_datastack) \
+ _(clone) \
+ _(code_blocks) \
+ _(code_room) \
+ _(compact_gc) \
+ _(compute_identity_hashcode) \
+ _(context_object) \
+ _(data_room) \
+ _(datastack) \
+ _(die) \
+ _(disable_gc_events) \
+ _(dispatch_stats) \
+ _(displaced_alien) \
+ _(dlclose) \
+ _(dll_validp) \
+ _(dlopen) \
+ _(dlsym) \
+ _(double_bits) \
+ _(enable_gc_events) \
+ _(existsp) \
+ _(exit) \
+ _(fclose) \
+ _(fflush) \
+ _(fgetc) \
+ _(fixnum_divint) \
+ _(fixnum_divmod) \
+ _(fixnum_shift) \
+ _(fixnum_to_bignum) \
+ _(fixnum_to_float) \
+ _(float_add) \
+ _(float_bits) \
+ _(float_divfloat) \
+ _(float_eq) \
+ _(float_greater) \
+ _(float_greatereq) \
+ _(float_less) \
+ _(float_lesseq) \
+ _(float_mod) \
+ _(float_multiply) \
+ _(float_subtract) \
+ _(float_to_bignum) \
+ _(float_to_fixnum) \
+ _(float_to_str) \
+ _(fopen) \
+ _(fputc) \
+ _(fread) \
+ _(fseek) \
+ _(ftell) \
+ _(full_gc) \
+ _(fwrite) \
+ _(identity_hashcode) \
+ _(innermost_stack_frame_executing) \
+ _(innermost_stack_frame_scan) \
+ _(jit_compile) \
+ _(load_locals) \
+ _(lookup_method) \
+ _(mega_cache_miss) \
+ _(minor_gc) \
+ _(modify_code_heap) \
+ _(nano_count) \
+ _(optimized_p) \
+ _(profiling) \
+ _(quot_compiled_p) \
+ _(quotation_code) \
+ _(reset_dispatch_stats) \
+ _(resize_array) \
+ _(resize_byte_array) \
+ _(resize_string) \
+ _(retainstack) \
+ _(save_image) \
+ _(save_image_and_exit) \
+ _(set_context_object) \
+ _(set_datastack) \
+ _(set_innermost_stack_frame_quot) \
+ _(set_retainstack) \
+ _(set_slot) \
+ _(set_special_object) \
+ _(set_string_nth_fast) \
+ _(set_string_nth_slow) \
+ _(size) \
+ _(sleep) \
+ _(special_object) \
+ _(string) \
+ _(string_nth) \
+ _(strip_stack_traces) \
+ _(system_micros) \
+ _(tuple) \
+ _(tuple_boa) \
+ _(unimplemented) \
+ _(uninitialized_byte_array) \
+ _(word) \
+ _(word_code) \
+ _(wrapper)
/* These are generated with macros in alien.cpp, and not with PRIMIIVE in
primitives.cpp */
-DECLARE_PRIMITIVE(alien_signed_cell)
-DECLARE_PRIMITIVE(set_alien_signed_cell)
-DECLARE_PRIMITIVE(alien_unsigned_cell)
-DECLARE_PRIMITIVE(set_alien_unsigned_cell)
-DECLARE_PRIMITIVE(alien_signed_8)
-DECLARE_PRIMITIVE(set_alien_signed_8)
-DECLARE_PRIMITIVE(alien_unsigned_8)
-DECLARE_PRIMITIVE(set_alien_unsigned_8)
-DECLARE_PRIMITIVE(alien_signed_4)
-DECLARE_PRIMITIVE(set_alien_signed_4)
-DECLARE_PRIMITIVE(alien_unsigned_4)
-DECLARE_PRIMITIVE(set_alien_unsigned_4)
-DECLARE_PRIMITIVE(alien_signed_2)
-DECLARE_PRIMITIVE(set_alien_signed_2)
-DECLARE_PRIMITIVE(alien_unsigned_2)
-DECLARE_PRIMITIVE(set_alien_unsigned_2)
-DECLARE_PRIMITIVE(alien_signed_1)
-DECLARE_PRIMITIVE(set_alien_signed_1)
-DECLARE_PRIMITIVE(alien_unsigned_1)
-DECLARE_PRIMITIVE(set_alien_unsigned_1)
-DECLARE_PRIMITIVE(alien_float)
-DECLARE_PRIMITIVE(set_alien_float)
-DECLARE_PRIMITIVE(alien_double)
-DECLARE_PRIMITIVE(set_alien_double)
-DECLARE_PRIMITIVE(alien_cell)
-DECLARE_PRIMITIVE(set_alien_cell)
+#define EACH_ALIEN_PRIMITIVE(_) \
+ _(signed_cell,fixnum,from_signed_cell,to_fixnum) \
+ _(unsigned_cell,cell,from_unsigned_cell,to_cell) \
+ _(signed_8,s64,from_signed_8,to_signed_8) \
+ _(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
+ _(signed_4,s32,from_signed_4,to_fixnum) \
+ _(unsigned_4,u32,from_unsigned_4,to_cell) \
+ _(signed_2,s16,from_signed_2,to_fixnum) \
+ _(unsigned_2,u16,from_unsigned_2,to_cell) \
+ _(signed_1,s8,from_signed_1,to_fixnum) \
+ _(unsigned_1,u8,from_unsigned_1,to_cell) \
+ _(float,float,from_float,to_float) \
+ _(double,double,from_double,to_double) \
+ _(cell,void *,allot_alien,pinned_alien_offset)
+
+#define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);
+
+#define DECLARE_ALIEN_PRIMITIVE(name, type, from, to) \
+ DECLARE_PRIMITIVE(alien_##name) \
+ DECLARE_PRIMITIVE(set_alien_##name)
+
+EACH_PRIMITIVE(DECLARE_PRIMITIVE)
+EACH_ALIEN_PRIMITIVE(DECLARE_ALIEN_PRIMITIVE)
}
cell visit_pointer(cell pointer);
void visit_handle(cell *handle);
+ void visit_object_array(cell *start, cell *end);
void visit_slots(object *ptr, cell payload_start);
void visit_slots(object *ptr);
void visit_stack_elements(segment *region, cell *top);
*handle = visit_pointer(*handle);
}
+template<typename Visitor>
+void slot_visitor<Visitor>::visit_object_array(cell *start, cell *end)
+{
+ while(start < end) visit_handle(start++);
+}
+
template<typename Visitor>
void slot_visitor<Visitor>::visit_slots(object *ptr, cell payload_start)
{
if(slot != end)
{
slot++;
- for(; slot < end; slot++) visit_handle(slot);
+ visit_object_array(slot,end);
}
}
template<typename Visitor>
void slot_visitor<Visitor>::visit_stack_elements(segment *region, cell *top)
{
- for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
- visit_handle(ptr);
+ visit_object_array((cell *)region->start,top + 1);
}
template<typename Visitor>
std::vector<data_root_range>::const_iterator end = parent->data_roots.end();
for(; iter < end; iter++)
- {
- data_root_range r = *iter;
- for(cell index = 0; index < r.len; index++)
- visit_handle(r.start + index);
- }
+ visit_object_array(iter->start,iter->start + iter->len);
}
template<typename Visitor>
visit_callback_roots();
visit_literal_table_roots();
- for(cell i = 0; i < special_object_count; i++)
- visit_handle(&parent->special_objects[i]);
+ visit_object_array(parent->special_objects,parent->special_objects + special_object_count);
}
template<typename Visitor>
{
visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
-
- visit_handle(&ctx->catchstack_save);
- visit_handle(&ctx->current_callback_save);
+ visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count);
ctx = ctx->next;
}
cell cards_offset;
cell decks_offset;
- /* TAGGED user environment data; see getenv/setenv prims */
+ /* Various special objects, accessed by special-object and
+ set-special-object primitives */
cell special_objects[special_object_count];
/* Data stack and retain stack sizes */
void nest_stacks();
void unnest_stacks();
void init_stacks(cell ds_size_, cell rs_size_);
+ void primitive_context_object();
+ void primitive_set_context_object();
bool stack_to_array(cell bottom, cell top);
cell array_to_stack(array *array, cell bottom);
void primitive_datastack();
projects / factor.git / commitdiff