<string>Factor</string>
<key>CFBundlePackageType</key>
<string>APPL</string>
+ <key>CFBundleVersion</key>
+ <string>0.93</string>
<key>NSHumanReadableCopyright</key>
- <string>Copyright © 2003-2009, Slava Pestov and friends</string>
+ <string>Copyright © 2003-2010 Factor developers</string>
<key>NSServices</key>
<array>
<dict>
AR = ar
LD = ld
- VERSION = 0.92
+ VERSION = 0.93
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
{ $description "Throws a " { $link no-c-type } " error." }
{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
-HELP: c-types
-{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
-
HELP: c-type
{ $values { "name" "a C type" } { "c-type" c-type } }
{ $description "Looks up a C type by name." }
-{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
HELP: c-getter
{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
: <c-type> ( -- c-type )
\ c-type new ; inline
-SYMBOL: c-types
-
-global [
- c-types [ H{ } assoc-like ] change
-] bind
-
ERROR: no-c-type name ;
PREDICATE: c-type-word < word
dup "pointer-c-type" word-prop
[ ] [ drop void* ] ?if ;
-M: string resolve-pointer-type
- dup "*" append dup c-types get at
- [ nip ] [
- drop
- c-types get at dup c-type-name?
- [ resolve-pointer-type ] [ drop void* ] if
- ] if ;
-
M: array resolve-pointer-type
first resolve-pointer-type ;
PRIVATE>
-M: string c-type ( name -- c-type )
- CHAR: ] over member? [
- parse-array-type prefix
- ] [
- dup c-types get at [ ] [
- "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
- ] ?if resolve-typedef
- ] if ;
-
M: word c-type
dup "c-type" word-prop resolve-typedef
[ ] [ no-c-type ] ?if ;
PREDICATE: typedef-word < c-type-word
"c-type" word-prop c-type-name? ;
-M: string typedef ( old new -- ) c-types get set-at ;
-
M: word typedef ( old new -- )
{
[ nip define-symbol ]
- [ name>> typedef ]
[ swap "c-type" set-word-prop ]
[
swap dup c-type-name? [
[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
-[ complex ] [ "complex-float" c-type-boxed-class ] unit-test
+[ complex ] [ complex-float c-type-boxed-class ] unit-test
-[ complex ] [ "complex-double" c-type-boxed-class ] unit-test
+[ complex ] [ complex-double c-type-boxed-class ] unit-test
<<
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
+>>
+<<
! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
-"complex-float" c-type t >>return-in-registers? drop
+\ complex-float c-type t >>return-in-registers? drop
>>
FUNCTOR: define-complex-type ( N T -- )
+N-type IS ${N}
+
T-class DEFINES-CLASS ${T}
<T> DEFINES <${T}>
WHERE
-STRUCT: T-class { real N } { imaginary N } ;
+STRUCT: T-class { real N-type } { imaginary N-type } ;
: <T> ( z -- alien )
>rect T-class <struct-boa> >c-ptr ;
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
+HELP: deploy-library
+{ $values { "name" string } }
+{ $description "Specifies that the logical library named " { $snippet "name" } " should be included during " { $link "tools.deploy" } ". " { $snippet "name" } " must be the name of a library previously loaded with " { $link add-library } "." } ;
+
HELP: remove-library
{ $values { "name" string } }
{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
}
"Once a library has been defined, you can try loading it to see if the path name is correct:"
{ $subsections load-library }
-"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
+"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again."
+$nl
+"Libraries that do not come standard with the operating system need to be included with deployed applications that use them. A word is provided to instruct " { $link "tools.deploy" } " that a library must be so deployed:"
+{ $subsections
+ deploy-library
+} ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.strings assocs io.backend
-kernel namespaces destructors ;
+kernel namespaces destructors sequences system io.pathnames ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
SYMBOL: libraries
+SYMBOL: deploy-libraries
libraries [ H{ } clone ] initialize
+deploy-libraries [ V{ } clone ] initialize
TUPLE: library path abi dll ;
+ERROR: no-library name ;
+
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
: add-library ( name path abi -- )
[ 2drop remove-library ]
- [ <library> swap libraries get set-at ] 3bi ;
\ No newline at end of file
+ [ <library> swap libraries get set-at ] 3bi ;
+
+: deploy-library ( name -- )
+ dup libraries get key?
+ [ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ]
+ [ no-library ] if ;
+
+<PRIVATE
+HOOK: >deployed-library-path os ( path -- path' )
+
+M: windows >deployed-library-path
+ file-name ;
+M: unix >deployed-library-path
+ file-name "$ORIGIN" prepend-path ;
+M: macosx >deployed-library-path
+ file-name "@executable_path/../Frameworks" prepend-path ;
+PRIVATE>
} ;
HELP: convert-timezone
-{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
{ $examples
{ $example "USING: accessors calendar prettyprint ;"
} ;
HELP: >local-time
-{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"
} ;
HELP: >gmt
-{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"
GENERIC: time- ( time1 time2 -- time3 )
-: convert-timezone ( timestamp duration -- timestamp )
+: convert-timezone ( timestamp duration -- timestamp' )
over gmt-offset>> over = [ drop ] [
[ over gmt-offset>> time- time+ ] keep >>gmt-offset
] if ;
-: >local-time ( timestamp -- timestamp )
+: >local-time ( timestamp -- timestamp' )
gmt-offset-duration convert-timezone ;
-: >gmt ( timestamp -- timestamp )
+: >gmt ( timestamp -- timestamp' )
instant convert-timezone ;
M: timestamp <=> ( ts1 ts2 -- n )
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data ascii
-assocs byte-arrays classes.struct classes.tuple.private
+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
-tools.test parser lexer eval layouts ;
+tools.test parser lexer eval layouts generic.single classes ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
{ type bool }
{ class object }
}
-} ] [ "struct-test-foo" c-type fields>> ] unit-test
+} ] [ struct-test-foo c-type fields>> ] unit-test
[ {
T{ struct-slot-spec
{ class integer }
{ initial 0 }
}
-} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test
+} ] [ struct-test-float-and-bits c-type fields>> ] unit-test
STRUCT: struct-test-equality-1
{ x int } ;
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
eval( -- value )
-] must-fail
+] [ error>> no-method? ] must-fail-with
! Subclassing a struct class should not be allowed
[
- "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
+ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
eval( -- )
-] must-fail
+] [ error>> bad-superclass? ] must-fail-with
-! Remove c-type when struct class is forgotten
-[ ] [
- "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
-] unit-test
+! Changing a superclass into a struct should reset the subclass
+TUPLE: will-become-struct ;
+
+TUPLE: a-subclass < will-become-struct ;
+
+[ f ] [ will-become-struct struct-class? ] unit-test
+
+[ will-become-struct ] [ a-subclass superclass ] unit-test
+
+[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
+
+[ t ] [ will-become-struct struct-class? ] unit-test
-[ f ] [ "a-struct" c-types get key? ] unit-test
+[ tuple ] [ a-subclass superclass ] unit-test
STRUCT: bit-field-test
{ a uint bits: 12 }
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
-M: struct-class valid-superclass? drop f ;
-
SLOT: fields
: struct-slots ( struct-class -- slots )
[ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
- [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
+ [ struct f define-tuple-class ] [ make-final ] bi ;
:: (define-struct-class) ( class slots offsets-quot -- )
slots empty? [ struct-must-have-slots ] when
: define-union-struct-class ( class slots -- )
[ compute-union-offsets ] (define-struct-class) ;
-M: struct-class reset-class
- [ call-next-method ] [ name>> c-types get delete-at ] bi ;
-
ERROR: invalid-struct-slot token ;
: struct-slot-class ( c-type -- class' )
+++ /dev/null
-unportable
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel namespaces cocoa cocoa.classes
-cocoa.subclassing debugger ;
+USING: alien.c-types assocs kernel namespaces cocoa
+cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
IN: cocoa.callbacks
SYMBOL: callbacks
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
: super-send ( receiver args... selector -- return... ) t (send) ; inline
! Runtime introspection
-SYMBOL: class-startup-hooks
+SYMBOL: class-init-hooks
-class-startup-hooks [ H{ } clone ] initialize
+class-init-hooks [ H{ } clone ] initialize
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
- drop over class-startup-hooks get at [ call( -- ) ] when*
+ drop over class-init-hooks get at [ call( -- ) ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
: class-exists? ( string -- class ) objc_getClass >boolean ;
: define-objc-class-word ( quot name -- )
- [ class-startup-hooks get set-at ]
+ [ class-init-hooks get set-at ]
[
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
(( -- class )) define-declared
] bi ;
: import-objc-class ( name quot -- )
- over define-objc-class-word
- [ objc-class register-objc-methods ]
- [ objc-meta-class register-objc-methods ] bi ;
+ 2dup swap define-objc-class-word
+ over objc_getClass [ drop ] [ call( -- ) ] if
+ dup objc_getClass [
+ [ objc_getClass register-objc-methods ]
+ [ objc_getMetaClass register-objc-methods ] bi
+ ] [ drop ] if ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
-unportable
bindings
+ffi
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
--- /dev/null
+USING: compiler.crossref fry kernel sequences tools.test vocabs words ;
+IN: compiler.crossref.tests
+
+! Dependencies of all words should always be satisfied unless we're
+! in the middle of recompiling something
+[ { } ] [
+ all-words dup [ subwords ] map concat append
+ H{ } clone '[ _ dependencies-satisfied? not ] filter
+] unit-test
--- /dev/null
+IN: compiler.tests.redefine22
+USING: kernel sequences compiler.units vocabs tools.test definitions ;
+
+TUPLE: ttt ;
+INSTANCE: ttt sequence
+M: ttt new-sequence 2drop ttt new ;
+
+: www-1 ( a -- b ) T{ ttt } new-sequence ;
+
+! This used to break with a compiler error in the above word
+[ ] [ [ \ ttt forget ] with-compilation-unit ] unit-test
--- /dev/null
+IN: compiler.tests.redefine23
+USING: classes.struct specialized-arrays alien.c-types sequences
+compiler.units vocabs tools.test ;
+
+STRUCT: my-struct { x int } ;
+SPECIALIZED-ARRAY: my-struct
+: my-word ( a -- b ) iota [ my-struct <struct-boa> ] my-struct-array{ } map-as ;
+
+[ ] [
+ [
+ "specialized-arrays.instances.compiler.tests.redefine23" forget-vocab
+ ] with-compilation-unit
+] unit-test
[ in-d>> #drop ]
bi prefix ;
-: record-predicate-folding ( #call -- )
- [ node-input-infos first class>> ]
+: >predicate-folding< ( #call -- value-info class result )
+ [ node-input-infos first ]
[ word>> "predicating" word-prop ]
- [ node-output-infos first literal>> ] tri
- [ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
+ [ node-output-infos first literal>> ] tri ;
+
+: record-predicate-folding ( #call -- )
+ >predicate-folding< pick literal?>>
+ [ [ literal>> ] 2dip depends-on-instance-predicate ]
+ [ [ class>> ] 2dip depends-on-class-predicate ]
+ if ;
: record-folding ( #call -- )
dup word>> predicate?
[ { vector } declare length>> ]
count-unboxed-allocations
] unit-test
+
+! Bug found while tweaking benchmark.raytracer-simd
+
+TUPLE: point-2d { x read-only } { y read-only } ;
+TUPLE: point-3d < point-2d { z read-only } ;
+
+[ 0 ] [
+ [ { point-2d } declare dup point-3d? [ z>> ] [ x>> ] if ]
+ count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [ point-2d boa dup point-3d? [ z>> ] [ x>> ] if ]
+ count-unboxed-allocations
+] unit-test
: record-tuple-allocation ( #call -- )
dup immutable-tuple-boa?
- [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ]
+ [ [ in-d>> but-last { } like ] [ out-d>> first ] bi record-allocation ]
[ record-unknown-allocation ]
if ;
: slot-offset ( #call -- n/f )
- dup in-d>>
- [ second node-value-info literal>> ]
- [ first node-value-info class>> ] 2bi
- 2dup [ fixnum? ] [ tuple class<= ] bi* and [
- over 2 >= [ drop 2 - ] [ 2drop f ] if
+ dup in-d>> second node-value-info literal>> dup [ 2 - ] when ;
+
+: valid-slot-offset? ( slot# in -- ? )
+ over [
+ allocation dup [
+ dup array? [ bounds-check? ] [ 2drop f ] if
+ ] [ 2drop t ] if
] [ 2drop f ] if ;
+: unknown-slot-call ( out slot# in -- )
+ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ;
+
: record-slot-call ( #call -- )
- [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
+ [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
+ 2dup valid-slot-offset?
[ [ record-slot-access ] [ copy-slot-value ] 3bi ]
- [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
+ [ unknown-slot-call ]
if ;
M: #call escape-analysis*
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
-classes.tuple.private kernel accessors math math.intervals namespaces
-sequences sequences.private words combinators memoize
-combinators.short-circuit byte-arrays strings arrays layouts
-cpu.architecture compiler.tree.propagation.copy ;
+classes.tuple.private classes.singleton kernel accessors math
+math.intervals namespaces sequences sequences.private words
+combinators memoize combinators.short-circuit byte-arrays
+strings arrays layouts cpu.architecture
+compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
UNION: fixed-length array byte-array string ;
+: literal-class ( obj -- class )
+ #! Handle forgotten tuples and singleton classes properly
+ dup singleton-class? [
+ class dup class? [
+ drop tuple
+ ] unless
+ ] unless ;
+
: init-literal-info ( info -- info )
empty-interval >>interval
- dup literal>> class >>class
+ dup literal>> literal-class >>class
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }
] final-info drop
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { hashtable } declare hashtable instance? ] final-classes
] unit-test
[ { assoc } declare hashtable instance? ] final-classes
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { string } declare string? ] final-classes
] unit-test
[ { fixnum } declare log2 ] final-classes
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { fixnum } declare log2 0 >= ] final-classes
] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators
recover ;
: predicate-output-infos/class ( info class -- info )
- [ class>> ] dip {
- { [ 2dup class<= ] [ t <literal-info> ] }
- { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
- [ object-info ]
- } cond 2nip ;
+ [ class>> ] dip compare-classes
+ dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
: predicate-output-infos ( info class -- info )
over literal?>>
! Speeds up 2^
: 2^? ( #call -- ? )
- in-d>> first2 [ value-info ] bi@
- [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
- [ class>> fixnum class<= ]
- bi* and ;
+ in-d>> first value-info literal>> 1 eq? ;
\ shift [
- 2^? [
+ 2^? [
cell-bits tag-bits get - 1 -
'[
>fixnum dup 0 < [ 2drop 0 ] [
HELP: lzw-read
{ $values
- { "lzw" lzw }
{ "lzw" lzw } { "n" integer }
}
{ $description "Read the next LZW code." } ;
HELP: reset-lzw-uncompress
{ $values
{ "lzw" lzw }
- { "lzw" lzw }
}
{ $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ;
mailbox-get\r
] unit-test\r
\r
-<mailbox> "m" set\r
-\r
-1 <count-down> "c" set\r
-1 <count-down> "d" set\r
-\r
-[\r
- "c" get await\r
- [ "m" get mailbox-get drop ]\r
- [ drop "d" get count-down ] recover\r
-] "Mailbox close test" spawn drop\r
-\r
-[ ] [ "c" get count-down ] unit-test\r
-[ ] [ "m" get dispose ] unit-test\r
-[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
-\r
-[ ] [ "m" get dispose ] unit-test\r
-\r
-<mailbox> "m" set\r
-\r
-1 <count-down> "c" set\r
-1 <count-down> "d" set\r
-\r
-[\r
- "c" get await\r
- "m" get wait-for-close\r
- "d" get count-down\r
-] "Mailbox close test" spawn drop\r
-\r
-[ ] [ "c" get count-down ] unit-test\r
-[ ] [ "m" get dispose ] unit-test\r
-[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
-\r
-[ ] [ "m" get dispose ] unit-test\r
-\r
[ { "foo" "bar" } ] [\r
<mailbox>\r
"foo" over mailbox-put\r
[\r
<mailbox> 1 seconds mailbox-get-timeout\r
] [ wait-timeout? ] must-fail-with\r
- \r
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: dlists deques threads sequences continuations\r
-destructors namespaces math quotations words kernel\r
-arrays assocs init system concurrency.conditions accessors\r
-debugger debugger.threads locals fry ;\r
+USING: dlists deques threads sequences continuations namespaces\r
+math quotations words kernel arrays assocs init system\r
+concurrency.conditions accessors debugger debugger.threads\r
+locals fry ;\r
IN: concurrency.mailboxes\r
\r
-TUPLE: mailbox < disposable threads data ;\r
-\r
-M: mailbox dispose* threads>> notify-all ;\r
+TUPLE: mailbox threads data ;\r
\r
: <mailbox> ( -- mailbox )\r
- mailbox new-disposable <dlist> >>threads <dlist> >>data ;\r
+ mailbox new\r
+ <dlist> >>threads\r
+ <dlist> >>data ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
data>> deque-empty? ;\r
[ threads>> ] dip "mailbox" wait ;\r
\r
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
- mailbox check-disposed\r
mailbox data>> pred dlist-any? [\r
mailbox timeout wait-for-mailbox\r
mailbox timeout pred block-unless-pred\r
] unless ; inline recursive\r
\r
: block-if-empty ( mailbox timeout -- mailbox )\r
- over check-disposed\r
over mailbox-empty? [\r
2dup wait-for-mailbox block-if-empty\r
] [\r
mailbox>> mailbox-empty? not ;\r
\r
ERROR: promise-already-fulfilled promise ;\r
+\r
: fulfill ( value promise -- )\r
dup promise-fulfilled? [ \r
promise-already-fulfilled\r
{ release void* }
{ copyDescription void* } ;
-! callback(
CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
info event-stream-callbacks get at [ drop ] or call( changes -- ) ;
: master-event-source-callback ( -- alien )
- "void"
- {
- "FSEventStreamRef"
- "void*" ! info
- "size_t" ! numEvents
- "void*" ! eventPaths
- "FSEventStreamEventFlags*"
- "FSEventStreamEventId*"
- }
- "cdecl" [ (master-event-source-callback) ] alien-callback ;
+ [ (master-event-source-callback) ] FSEventStreamCallback ;
TUPLE: event-stream < disposable info handle ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
-alien alien.accessors alien.c-types alien.data literals cpu.architecture
-cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
+alien alien.accessors alien.c-types alien.complex alien.data
+literals cpu.architecture cpu.ppc.assembler
+cpu.ppc.assembler.backend compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.comparisons
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.cfg.build-stack-frame
{ [ os linux? ] [ "cpu.ppc.linux" require ] }
} cond
-"complex-double" c-type t >>return-in-registers? drop
+complex-double c-type t >>return-in-registers? drop
-unportable
compiler
+untested
-unportable
+untested
compiler
-unportable
+untested
compiler
+++ /dev/null
-unportable
-unportable
+untested
compiler
HELP: <select-by-slots-statement>
{ $values
{ "tuple" tuple } { "class" class }
- { "tuple" tuple } }
+ { "statement" tuple } }
{ $description "A database-specific hook for generating the SQL for a select statement." } ;
HELP: <update-tuple-statement>
{ $list
"Make a new tuple to represent your data"
{ "Map the Factor types to the database types with " { $link define-persistent } }
- { "Make a custom database combinator (see" { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
+ { "Make a custom database combinator (see " { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
{ "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } }
{ "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } }
} ;
HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
HOOK: <update-tuple-statement> db-connection ( class -- object )
HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
-HOOK: <select-by-slots-statement> db-connection ( tuple class -- tuple )
+HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
HOOK: <count-statement> db-connection ( query -- statement )
HOOK: query>statement db-connection ( query -- statement )
HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
drop "Not a tuple" ;
M: bad-superclass summary
- drop "Tuple classes can only inherit from other tuple classes" ;
+ drop "Tuple classes can only inherit from non-final tuple classes" ;
M: no-initial-value summary
drop "Initial value must be provided for slots specialized to this class" ;
+++ /dev/null
-unportable
} ;
HELP: dlist-filter
-{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist'" { $link dlist } } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
{ $side-effects { "dlist" } } ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
-: dlist-filter ( dlist quot -- dlist )
+: dlist-filter ( dlist quot -- dlist' )
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
M: dlist clone
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays calendar classes
-combinators combinators.short-circuit concurrency.promises
-continuations destructors ftp io io.backend io.directories
-io.encodings io.encodings.binary
-tools.files io.encodings.utf8 io.files io.files.info
-io.pathnames io.launcher.unix.parser io.servers.connection
-io.sockets io.streams.duplex io.streams.string io.timeouts
-kernel make math math.bitwise math.parser namespaces sequences
-splitting threads unicode.case logging calendar.format
-strings io.files.links io.files.types io.encodings.8-bit.latin1 ;
+USING: accessors assocs byte-arrays calendar classes combinators
+combinators.short-circuit concurrency.promises continuations
+destructors ftp io io.backend io.directories io.encodings
+io.encodings.binary tools.files io.encodings.utf8 io.files
+io.files.info io.pathnames io.servers.connection io.sockets
+io.streams.duplex io.streams.string io.timeouts kernel make math
+math.bitwise math.parser namespaces sequences splitting threads
+unicode.case logging calendar.format strings io.files.links
+io.files.types io.encodings.8-bit.latin1 simple-tokenizer ;
IN: ftp.server
SYMBOL: server
dup \ <ftp-command> DEBUG log-message
ftp-command new
over >>raw
- swap tokenize-command >>tokenized ;
+ swap tokenize >>tokenized ;
TUPLE: ftp-get path ;
: <ftp-get> ( path -- obj )
USING: accessors arrays assocs generic.standard kernel
lexer locals.types namespaces parser quotations vocabs.parser
-words ;
+words classes.tuple ;
IN: functors.backend
DEFER: functor-words
: define* ( word def -- ) over set-word define ;
-: define-declared* ( word def effect -- ) pick set-word define-declared ;
+: define-declared* ( word def effect -- )
+ pick set-word define-declared ;
-: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+: define-simple-generic* ( word effect -- )
+ over set-word define-simple-generic ;
+: define-tuple-class* ( class superclass slots -- )
+ pick set-word define-tuple-class ;
-USING: classes.struct functors tools.test math words kernel
-multiline parser io.streams.string generic ;
+USING: classes.struct classes.tuple functors tools.test math
+words kernel multiline parser io.streams.string generic ;
QUALIFIED-WITH: alien.c-types c
IN: functors.tests
WHERE
-: WW ( a -- b ) \ W twice ; inline
+: WW ( a -- b ) \ W twice ;
;FUNCTOR
}
] [ a-struct struct-slots ] unit-test
+<<
+
+FUNCTOR: define-an-inline-word ( W -- )
+
+W DEFINES ${W}
+W-W DEFINES ${W}-${W}
+
+WHERE
+
+: W ( -- ) ; inline
+: W-W ( -- ) W W ;
+
+;FUNCTOR
+
+"an-inline-word" define-an-inline-word
+
+>>
+
+[ t ] [ \ an-inline-word inline? ] unit-test
+[ f ] [ \ an-inline-word-an-inline-word inline? ] unit-test
+
+<<
+
+FUNCTOR: define-a-final-class ( T W -- )
+
+T DEFINES-CLASS ${T}
+W DEFINES ${W}
+
+WHERE
+
+TUPLE: T ; final
+
+: W ( -- ) ;
+
+;FUNCTOR
+
+"a-final-tuple" "a-word" define-a-final-class
+
+>>
+
+[ t ] [ a-final-tuple final-class? ] unit-test
make suffix!
]
} case
- \ define-tuple-class suffix! ;
+ \ define-tuple-class* suffix! ;
+
+FUNCTOR-SYNTAX: final
+ [ word make-final ] append! ;
FUNCTOR-SYNTAX: SINGLETON:
scan-param suffix!
controller-state
keyboard-state
mouse-state
+}
+"Convenience functions are provided to convert a pair of key or button state sequences into a sequence of " { $link pressed } "/" { $link released } " deltas:"
+{ $subsections
+ button-delta
+ buttons-delta
+ buttons-delta-as
} ;
HELP: open-game-input
{ "A value of " { $link f } " in any slot (besides the elements of " { $snippet "buttons" } ") indicates that the corresponding element is not present on the device." } } } ;
HELP: keyboard-state
-{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game.input.scancodes" } " vocabulary." }
+{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined by the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game.input.scancodes" } " vocabulary." }
{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game.input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
HELP: mouse-state
"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
} ;
-
{ keyboard-state read-keyboard } related-words
+HELP: button-delta
+{ $values { "old?" boolean } { "new?" boolean } { "delta" { $link pressed } ", " { $link released } ", or " { $link POSTPONE: f } } }
+{ $description "Outputs a symbol representing the change in a key or button's state given a \"before\" and \"after\" sample of its state. Outputs " { $link pressed } " if " { $snippet "old?" } " is false and " { $snippet "new?" } " is true, " { $link released } " if " { $snippet "old?" } " is true and " { $snippet "new?" } " is false, or " { $link POSTPONE: f } " if the two inputs have the same boolean value." } ;
+
+HELP: buttons-delta
+{ $values { "old-buttons" sequence } { "new-buttons" sequence } { "delta" "an array of " { $link pressed } ", " { $link released } ", or " { $link POSTPONE: f } } }
+{ $description "Outputs an array of symbols representing the change in a set of keys or buttons' states given \"before\" and \"after\" samples of their state. For each corresponding pair of values in the two input sequences, outputs " { $link pressed } " if " { $snippet "old-buttons" } " contains a false and " { $snippet "new-buttons" } " a true value, " { $link released } " if " { $snippet "old-buttons" } " contains true and " { $snippet "new-buttons" } " false, or " { $link POSTPONE: f } " if the two elements have the same boolean value."
+$nl
+"This word can be used with two samples of a " { $link keyboard-state } "'s " { $snippet "keys" } " slot or of a " { $link mouse-state } "'s or " { $link controller-state } "'s " { $snippet "buttons" } " slot to convert the button states into pressed/released values. Remember to " { $link clone } " state objects to record snapshots of their state." } ;
+
+HELP: buttons-delta-as
+{ $values { "old-buttons" sequence } { "new-buttons" sequence } { "exemplar" sequence } { "delta" "a sequence of " { $link pressed } ", " { $link released } ", or " { $link POSTPONE: f } } }
+{ $description "Like " { $link buttons-delta } ", but returns a sequence matching the type of the " { $snippet "exemplar" } "." } ;
+
+{ button-delta buttons-delta buttons-delta-as } related-words
+
+HELP: pressed
+{ $class-description "This symbol is returned by " { $link button-delta } " or " { $link buttons-delta } " to represent a button or key being pressed between two samples of its state." } ;
+
+HELP: released
+{ $class-description "This symbol is returned by " { $link button-delta } " or " { $link buttons-delta } " to represent a button or key being released between two samples of its state." } ;
+
+{ pressed released } related-words
+
ABOUT: "game-input"
[ ] [ 1 seconds sleep ] unit-test
[ ] [ close-game-input ] unit-test
] when
+
+[ f ] [ t t button-delta ] unit-test
+[ pressed ] [ f t button-delta ] unit-test
+[ released ] [ t f button-delta ] unit-test
+
+[ f ] [ 0.5 1.0 button-delta ] unit-test
+[ pressed ] [ f 0.7 button-delta ] unit-test
+[ released ] [ 0.2 f button-delta ] unit-test
+
+[ { pressed f f released } ] [ { f t f t } { t t f f } buttons-delta ] unit-test
+[ V{ pressed f f released } ] [ { f t f t } { t t f f } V{ } buttons-delta-as ] unit-test
M: mouse-state clone
call-next-method dup buttons>> clone >>buttons ;
+SYMBOLS: pressed released ;
+
+: button-delta ( old? new? -- delta )
+ {
+ { [ 2dup xor not ] [ 2drop f ] }
+ { [ dup not ] [ 2drop released ] }
+ { [ over not ] [ 2drop pressed ] }
+ } cond ; inline
+
+: buttons-delta-as ( old-buttons new-buttons exemplar -- delta )
+ [ button-delta ] swap 2map-as ; inline
+
+: buttons-delta ( old-buttons new-buttons -- delta )
+ { } buttons-delta-as ; inline
+
{
{ [ os windows? ] [ "game.input.xinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] }
- { [ t ] [ ] }
+ { [ os linux? ] [ "game.input.linux" require ] }
+ [ ]
} cond
--- /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.
-USING: tools.test globs ;
+USING: arrays tools.test globs io.pathnames sequences ;
IN: globs.tests
[ f ] [ "abd" "fdf" glob-matches? ] unit-test
[ f ] [ "foo." "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test
+
+[ f ] [ "foo" "bar" append-path "*" glob-matches? ] unit-test
+[ t ] [ "foo" "bar" append-path "*" "*" append-path glob-matches? ] unit-test
+[ f ] [ "foo" "bar" append-path "foo?bar" glob-matches? ] unit-test
+[ t ] [ "foo" "bar" append-path "fo?" "bar" append-path glob-matches? ] unit-test
+
+[ f ] [ "foo" glob-pattern? ] unit-test
+[ t ] [ "fo?" glob-pattern? ] unit-test
+[ t ] [ "fo*" glob-pattern? ] unit-test
+[ t ] [ "fo[mno]" glob-pattern? ] unit-test
+[ t ] [ "fo\\*" glob-pattern? ] unit-test
+[ t ] [ "fo{o,bro}" glob-pattern? ] unit-test
+
+{ "foo" "bar" } path-separator join 1array
+[ { "foo" "bar" "ba?" } path-separator join glob-parent-directory ] unit-test
+
+[ "foo" ]
+[ { "foo" "b?r" "bas" } path-separator join glob-parent-directory ] unit-test
+
+[ "" ]
+[ { "f*" "bar" "bas" } path-separator join glob-parent-directory ] unit-test
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel regexp.combinators strings unicode.case
-peg.ebnf regexp arrays ;
+USING: sequences io.pathnames kernel regexp.combinators
+strings splitting system unicode.case peg.ebnf regexp arrays ;
IN: globs
+: not-path-separator ( -- sep )
+ os windows? R! [^/\\]! R! [^/]! ? ; foldable
+
EBNF: <glob>
Character = "\\" .:c => [[ c 1string <literal> ]]
AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]]
| Concatenation => [[ 1array ]]
-Element = "*" => [[ R/ .*/ ]]
- | "?" => [[ R/ ./ ]]
+Element = "*" => [[ not-path-separator <zero-or-more> ]]
+ | "?" => [[ not-path-separator ]]
| "[" CharClass:c "]" => [[ c ]]
| "{" AlternationBody:b "}" => [[ b <or> ]]
| Character
: glob-matches? ( input glob -- ? )
[ >case-fold ] bi@ <glob> matches? ;
+
+: glob-pattern? ( string -- ? )
+ [ "\\*?[{" member? ] any? ;
+
+: glob-parent-directory ( glob -- parent-directory )
+ path-separator split harvest dup [ glob-pattern? ] find drop head
+ path-separator join ;
: extract-values ( element -- seq )
\ $values swap elements dup empty? [
- first rest [ first ] map prune
+ first rest [ first ] map
] unless ;
: effect-values ( word -- seq )
"Examples" $heading print-element ;
: $example ( element -- )
- 1 cut* swap "\n" join dup <input> [
- input-style get format nl print-element
+ 1 cut* [ "\n" join ] bi@ over <input> [
+ [ print ] [ output-style get format ] bi*
] ($code) ;
: $unchecked-example ( element -- )
{ wrap-margin f }
} code-style set-global
-SYMBOL: input-style
-H{ { font-style bold } } input-style set-global
+SYMBOL: output-style
+H{
+ { font-style bold }
+ { foreground COLOR: DarkOrange4 }
+} output-style set-global
SYMBOL: url-style
H{
HELP: normalize-image
{ $values
{ "image" image }
- { "image" image }
+ { "image'" image }
}
{ $description "Converts the image to RGBA with ubyte-components. If the image is upside-down, it will be flipped right side up such that the 1st byte in the bitmap slot's byte array corresponds to the first color component of the pixel in the upper-left corner of the image." } ;
HELP: reorder-components
{ $values
{ "image" image } { "component-order" component-order }
- { "image" image }
+ { "image'" image }
}
{ $description "Convert the bitmap in " { $snippet "image" } " such that the pixel sample layout corresponds to " { $snippet "component-order" } ". If the destination layout cannot find a corresponding value from the source layout, the value " { $snippet "255" } " will be substituted for that byte." }
{ $warning "The image's " { $snippet "component-type" } " will be changed to " { $snippet "ubyte-components" } " if it is not already in that format."
M: ubyte-components normalize-component-type*
drop ;
-: normalize-scan-line-order ( image -- image )
+: normalize-scan-line-order ( image -- image' )
dup upside-down?>> [
dup dim>> first 4 * '[
_ <groups> reverse concat
PRIVATE>
-: reorder-components ( image component-order -- image )
+: reorder-components ( image component-order -- image' )
[
dup component-type>> '[ _ normalize-component-type* ] change-bitmap
dup component-order>>
] dip
validate-request [ (reorder-components) ] keep >>component-order ;
-: normalize-image ( image -- image )
+: normalize-image ( image -- image' )
[ >byte-array ] change-bitmap
RGBA reorder-components
normalize-scan-line-order ;
-bitmap graphics
+graphics
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel locals words summary slots quotations
-sequences assocs math arrays stack-checker effects
-continuations debugger classes.tuple namespaces make vectors
-bit-arrays byte-arrays strings sbufs math.functions macros
-sequences.private combinators mirrors splitting combinators.smart
+sequences assocs math arrays stack-checker effects continuations
+classes.tuple namespaces make vectors bit-arrays byte-arrays
+strings sbufs math.functions macros sequences.private
+combinators mirrors splitting combinators.smart
combinators.short-circuit fry words.symbol generalizations
classes ;
IN: inverse
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel bit-arrays sequences assocs unix
-math namespaces accessors math.order locals unix.time fry
-io.ports io.backend.unix io.backend.unix.multiplexers ;
+USING: alien.c-types kernel bit-arrays sequences assocs math
+namespaces accessors math.order locals fry io.ports
+io.backend.unix io.backend.unix.multiplexers unix unix.ffi
+unix.time ;
IN: io.backend.unix.multiplexers.select
TUPLE: select-mx < mx read-fdset write-fdset ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable\r
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
] with-destructors ;
: <fd> ( n -- fd )
- #! We drop the error code rather than calling io-error,
- #! since on OS X 10.3, this operation fails from init-io
- #! when running the Factor.app (presumably because fd 0 and
- #! 1 are closed).
fd new-disposable swap >>fd ;
M: fd dispose
[ drop 0 ] [ (io-error) ] if
] when ;
-: ?flag ( n mask symbol -- n )
- pick rot bitand 0 > [ , ] [ drop ] if ;
+:: ?flag ( n mask symbol -- n )
+ n mask bitand 0 > [ symbol , ] when n ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } }
{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
+HELP: directory-tree-files
+{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } }
+{ $description "Outputs a sequence of all files and subdirectories inside the directory named by " { $snippet "path" } " or recursively inside its subdirectories." } ;
+
HELP: with-directory-files
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+HELP: with-directory-tree-files
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Calls the quotation with the recursive directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+
HELP: with-directory-entries
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
] with-directory-files
] unit-test
+[ { "classes/tuple/tuple.factor" } ] [
+ "resource:core" [
+ "." directory-tree-files [ "classes/tuple/tuple.factor" = ] filter
+ ] with-directory
+] unit-test
+
+[ { "classes/tuple" } ] [
+ "resource:core" [
+ "." directory-tree-files [ "classes/tuple" = ] filter
+ ] with-directory
+] unit-test
+
+[ { "classes/tuple/tuple.factor" } ] [
+ "resource:core" [
+ [ "classes/tuple/tuple.factor" = ] filter
+ ] with-directory-tree-files
+] unit-test
+
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
[ t ] [ "blahblah" temp-file file-info directory? ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators destructors io io.backend
-io.encodings.binary io.files io.pathnames kernel namespaces
-sequences system vocabs.loader fry ;
+USING: accessors arrays combinators destructors io io.backend
+io.encodings.binary io.files io.files.types io.pathnames
+kernel namespaces sequences system vocabs.loader fry ;
IN: io.directories
: set-current-directory ( path -- )
: directory-files ( path -- seq )
directory-entries [ name>> ] map ;
+: directory-tree-files ( path -- seq )
+ dup directory-entries
+ [
+ dup type>> +directory+ =
+ [ name>>
+ [ append-path directory-tree-files ]
+ [ [ prepend-path ] curry map ]
+ [ prefix ] tri
+ ] [ nip name>> 1array ] if
+ ] with map concat ;
+
: with-directory-entries ( path quot -- )
'[ "" directory-entries @ ] with-directory ; inline
: with-directory-files ( path quot -- )
'[ "" directory-files @ ] with-directory ; inline
+: with-directory-tree-files ( path quot -- )
+ '[ "" directory-tree-files @ ] with-directory ; inline
+
! Touching files
HOOK: touch-file io-backend ( path -- )
+++ /dev/null
-unportable
classes.struct unix.ffi ;
IN: io.directories.unix.linux
-M: unix find-next-file ( DIR* -- dirent )
+M: linux find-next-file ( DIR* -- dirent )
dirent <struct>
f <void*>
[ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
HOOK: file-system-info os ( path -- file-system-info )
{
- { [ os unix? ] [ "io.files.info" ] }
+ { [ os unix? ] [ "io.files.info.unix" ] }
{ [ os windows? ] [ "io.files.info.windows" ] }
} cond require
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-IN: io.launcher.unix.parser.tests
-USING: io.launcher.unix.parser tools.test ;
-
-[ "" tokenize-command ] must-fail
-[ " " tokenize-command ] must-fail
-[ V{ "a" } ] [ "a" tokenize-command ] unit-test
-[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test
-[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test
-[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test
-[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
-[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
-[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
-[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
-[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
-[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
-[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
-[ "\"abc def\" \"hey" tokenize-command ] must-fail
-[ "\"abc def" tokenize-command ] must-fail
-[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
-
-[
- V{
- "Hello world.app/Contents/MacOS/hello-ui"
- "-i=boot.macosx-ppc.image"
- "-include= math compiler ui"
- "-deploy-vocab=hello-ui"
- "-output-image=Hello world.app/Contents/Resources/hello-ui.image"
- "-no-stack-traces"
- "-no-user-init"
- }
-] [
- "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: peg peg.ebnf arrays sequences strings kernel ;
-IN: io.launcher.unix.parser
-
-! Our command line parser. Supported syntax:
-! foo bar baz -- simple tokens
-! foo\ bar -- escaping the space
-! "foo bar" -- quotation
-EBNF: tokenize-command
-space = " "
-escaped-char = "\" .:ch => [[ ch ]]
-quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
-unquoted = (escaped-char | [^ "])+
-argument = (quoted | unquoted) => [[ >string ]]
-command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
-;EBNF
+++ /dev/null
-unportable
+++ /dev/null
-unportable
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays assocs combinators
continuations environment io io.backend io.backend.unix
-io.files io.files.private io.files.unix io.launcher
-io.launcher.unix.parser io.pathnames io.ports kernel math
-namespaces sequences strings system threads unix
-unix.process unix.ffi ;
+io.files io.files.private io.files.unix io.launcher io.pathnames
+io.ports kernel math namespaces sequences strings system threads
+unix unix.process unix.ffi simple-tokenizer ;
IN: io.launcher.unix
: get-arguments ( process -- seq )
- command>> dup string? [ tokenize-command ] when ;
+ command>> dup string? [ tokenize ] when ;
: assoc>env ( assoc -- env )
[ "=" glue ] { } assoc>map ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
[ inotify>> handle>> handle-fd ] [ wd>> ] bi
inotify_rm_watch io-error
] if
- ] bi ;
+ ]
+ [ call-next-method ]
+ tri ;
: ignore-flags? ( mask -- ? )
{
+++ /dev/null
-unportable
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.monitors
core-foundation.fsevents continuations kernel sequences
dup [ enqueue-notifications ] curry
path 1array 0 0 <event-stream> >>handle ;
-M: macosx-monitor dispose* handle>> dispose ;
+M: macosx-monitor dispose*
+ [ handle>> dispose ] [ call-next-method ] bi ;
macosx set-io-backend
+++ /dev/null
-unportable
continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint destructors io.timeouts
io.files.temp io.directories io.directories.hierarchy
-io.pathnames accessors ;
+io.pathnames accessors concurrency.promises ;
os { winnt linux macosx } member? [
[
[ [ t ] [ "m" get next-change drop ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
] with-monitors
+
+ ! Disposing a monitor should throw an error in any threads
+ ! waiting on notifications
+ [
+ [ ] [
+ <promise> "p" set
+ "monitor-test" temp-file t <monitor> "m" set
+ 10 seconds "m" get set-timeout
+ ] unit-test
+
+ [
+ [ "m" get next-change ] [ ] recover
+ "p" get fulfill
+ ] in-thread
+
+ [ ] [ 1 seconds sleep ] unit-test
+ [ ] [ "m" get dispose ] unit-test
+ [ t ] [ "p" get 10 seconds ?promise-timeout already-disposed? ] unit-test
+ ] with-monitors
] when
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend kernel continuations destructors namespaces
sequences assocs hashtables sorting arrays threads boxes
M: monitor set-timeout (>>timeout) ;
+<PRIVATE
+
+SYMBOL: monitor-disposed
+
+PRIVATE>
+
+M: monitor dispose*
+ [ monitor-disposed ] dip queue>> mailbox-put ;
+
: new-monitor ( path mailbox class -- monitor )
new-disposable
swap >>queue
TUPLE: file-change path changed monitor ;
: queue-change ( path changes monitor -- )
- 3dup and and
- [ [ file-change boa ] keep queue>> mailbox-put ] [ 3drop ] if ;
+ 3dup and and [
+ [ check-disposed ] keep
+ [ file-change boa ] keep
+ queue>> mailbox-put
+ ] [ 3drop ] if ;
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
<mailbox> (monitor) ;
: next-change ( monitor -- change )
- [ queue>> ] [ timeout ] bi mailbox-get-timeout ;
+ [ check-disposed ]
+ [
+ [ ] [ queue>> ] [ timeout ] tri mailbox-get-timeout
+ dup monitor-disposed eq? [ drop already-disposed ] [ nip ] if
+ ] bi ;
SYMBOL: +add-file+
SYMBOL: +remove-file+
: remove-child-monitor ( monitor -- )
monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
+SYMBOL: +stop+
+
M: recursive-monitor dispose*
- [ "stop" swap thread>> send-synchronous drop ]
- [ queue>> dispose ]
- bi ;
+ [ [ +stop+ ] dip thread>> send ] [ call-next-method ] bi ;
: stop-pump ( -- )
monitor tget children>> values dispose-each ;
: pump-step ( msg -- )
- [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
- monitor tget queue-change ;
+ monitor tget disposed>> [ drop ] [
+ [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
+ monitor tget queue-change
+ ] if ;
: child-added ( path monitor -- )
path>> prepend-path add-child-monitor ;
] with with each ;
: pump-loop ( -- )
- receive dup synchronous? [
- [ stop-pump t ] dip reply-synchronous
+ receive dup +stop+ eq? [
+ drop stop-pump
] [
[ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
pump-loop
] with-destructors ;
M: win32-monitor dispose
- port>> dispose ;
+ [ port>> dispose ] [ call-next-method ] bi ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
: write-object ( str obj -- ) presented associate format ;
: write-image ( image -- ) [ "" ] dip image associate format ;
-
-SYMBOL: stack-effect-style
-H{
- { foreground COLOR: FactorDarkGreen }
- { font-style plain }
-} stack-effect-style set-global
-USING: help.markup help.syntax kernel io system prettyprint continuations quotations ;
+USING: help.markup help.syntax kernel io system prettyprint
+continuations quotations vocabs.loader parser ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
-"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
+"The listener prints values of dynamic variables which are added to a watch list:"
{ $subsections visible-vars }
"To add or remove a single variable:"
{ $subsections
show-vars
hide-vars
}
-"Hiding all visible variables:"
+"Clearing the watch list:"
{ $subsections hide-all-vars } ;
HELP: only-use-vocabs
{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
-"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
+"The listener evaluates Factor expressions read from the input stream. Typically, you write Factor code in a text editor, load it from the listener by calling " { $link require } ", " { $link reload } " or " { $link run-file } ", and then test it from interactively."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
+"New words can also be defined in the listener:"
+{ $example
+ "USE: math.functions"
+ ": twice ( word -- ) [ execute ] [ execute ] bi ; inline"
+ "81 \\ sqrt twice ."
+ "3.0"
+}
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
-"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
+"The listener will display the current contents of the datastack after every line of input."
$nl
-"The listener will display the current contents of the datastack after every expression is evaluated. The listener can additionally watch dynamic variables:"
+"The listener can watch dynamic variables:"
{ $subsections "listener-watch" }
-"To start a nested listener:"
+"Nested listeners can be useful for testing code in other dynamic scopes. For example, when doing database maintanance using the " { $vocab-link "db.tuples" } " vocabulary, it can be useful to start a listener with a database connection:"
+{ $code
+ "USING: db db.sqlite listener ;"
+ "\"data.db\" <sqlite-db> [ listener ] with-db"
+}
+"Starting a nested listener:"
{ $subsections listener }
"To exit a listener, invoke the " { $link return } " word."
$nl
-"Multi-line quotations can be read independently of the rest of the listener:"
+"The listener's mechanism for reading multi-line expressions from the input stream can be called from user code:"
{ $subsections read-quot } ;
ABOUT: "listener"
{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "list" "the resulting list" } { "result" "a list" } }
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "result" "a list" } }
{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
{ $examples
{ $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
HELP: bitroll-32
{ $values
- { "n" integer } { "s" integer }
- { "n'" integer }
+ { "m" integer } { "s" integer }
+ { "n" integer }
}
-{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
+{ $description "Rolls the number " { $snippet "m" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
{ $examples
{ $example "USING: math.bitwise prettyprint ;"
"HEX: 1 10 bitroll-32 .h"
HELP: bitroll-64
{ $values
- { "n" integer } { "s" "a shift integer" }
- { "n'" integer }
+ { "m" integer } { "s" "a shift integer" }
+ { "n" integer }
}
-{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
+{ $description "Rolls the number " { $snippet "m" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
{ $examples
{ $example "USING: math.bitwise prettyprint ;"
"HEX: 1 10 bitroll-64 .h"
HELP: on-bits
{ $values
- { "n" integer }
{ "m" integer }
+ { "n" integer }
}
-{ $description "Returns an integer with " { $snippet "n" } " bits set." }
+{ $description "Returns an integer with " { $snippet "m" } " bits set." }
{ $examples
{ $example "USING: math.bitwise kernel prettyprint ;"
"6 on-bits .h"
HELP: shift-mod
{ $values
- { "n" integer } { "s" integer } { "w" integer }
+ { "m" integer } { "s" integer } { "w" integer }
{ "n" integer }
}
{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ;
HELP: w*
{ $values
- { "int" integer } { "int" integer }
- { "int" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Multiplies two integers and wraps the result to 32 bits." }
{ $examples
HELP: w+
{ $values
- { "int" integer } { "int" integer }
- { "int" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Adds two integers and wraps the result to 32 bits." }
{ $examples
HELP: w-
{ $values
- { "int" integer } { "int" integer }
- { "int" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Subtracts two integers and wraps the result to 32 bits." }
{ $examples
: wrap ( m n -- m' ) 1 - bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 2^ mask ; inline
-: on-bits ( n -- m ) 2^ 1 - ; inline
+: on-bits ( m -- n ) 2^ 1 - ; inline
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
-
-: shift-mod ( n s w -- n )
- [ shift ] dip 2^ wrap ; inline
+: >signed ( x n -- y ) 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
+: >odd ( m -- n ) 0 set-bit ; foldable
+: >even ( m -- n ) 0 clear-bit ; foldable
+: next-even ( m -- n ) >even 2 + ; foldable
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
+: shift-mod ( m s w -- n ) [ shift ] dip 2^ wrap ; inline
: bitroll ( x s w -- y )
[ wrap ] keep
[ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
-: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
+: bitroll-32 ( m s -- n ) 32 bitroll ; inline
-: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
+: bitroll-64 ( m s -- n ) 64 bitroll ; inline
! 32-bit arithmetic
-: w+ ( int int -- int ) + 32 bits ; inline
-: w- ( int int -- int ) - 32 bits ; inline
-: w* ( int int -- int ) * 32 bits ; inline
+: w+ ( x y -- z ) + 32 bits ; inline
+: w- ( x y -- z ) - 32 bits ; inline
+: w* ( x y -- z ) * 32 bits ; inline
! 64-bit arithmetic
-: W+ ( int int -- int ) + 64 bits ; inline
-: W- ( int int -- int ) - 64 bits ; inline
-: W* ( int int -- int ) * 64 bits ; inline
+: W+ ( x y -- z ) + 64 bits ; inline
+: W- ( x y -- z ) - 64 bits ; inline
+: W* ( x y -- z ) * 64 bits ; inline
! flags
MACRO: flags ( values -- )
] if ;
: byte-array-bit-count ( byte-array -- n )
- 0 [ byte-bit-count + ] reduce ;
+ 0 [ byte-bit-count + ] reduce ; inline
PRIVATE>
[ >c-ptr ] [ byte-length ] bi <direct-uchar-array>
byte-array-bit-count ;
-: >signed ( x n -- y )
- 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
-
-: >odd ( n -- int ) 0 set-bit ; foldable
-
-: >even ( n -- int ) 0 clear-bit ; foldable
-
-: next-even ( m -- n ) >even 2 + ; foldable
-
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
-
: even-parity? ( obj -- ? ) bit-count even? ;
: odd-parity? ( obj -- ? ) bit-count odd? ;
{ $subsections
blas-library
blas-fortran-abi
+ deploy-blas?
}
"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
{ $code """
USING: math.blas.config namespaces ;
"X:\\path\\to\\acml.dll" blas-library set-global
intel-windows-abi blas-fortran-abi set-global
+t deploy-blas? set-global
""" }
"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
;
HELP: blas-library
-{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+{ $var-description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
HELP: blas-fortran-abi
-{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+{ $var-description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+HELP: deploy-blas?
+{ $var-description "If set to a true value, the BLAS library will be configured to deploy with applications that use it. To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
ABOUT: "math.blas.config"
USING: alien.fortran combinators kernel namespaces system ;
IN: math.blas.config
-SYMBOLS: blas-library blas-fortran-abi ;
+SYMBOLS: blas-library blas-fortran-abi deploy-blas? ;
blas-library [
{
[ f2c-abi ]
} cond
] initialize
+
+deploy-blas? [ os macosx? not ] initialize
USING: alien.fortran kernel math.blas.config namespaces ;
+FROM: alien.libraries => deploy-library ;
IN: math.blas.ffi
<<
"blas" blas-library blas-fortran-abi [ get ] bi@
add-fortran-library
+
+deploy-blas? get [ "blas" deploy-library ] when
>>
LIBRARY: blas
} ;
HELP: permutation
-{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
+{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq'" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." }
{ $examples
} ;
HELP: all-permutations
-{ $values { "seq" sequence } { "seq" sequence } }
+{ $values { "seq" sequence } { "seq'" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
} ;
HELP: combination
-{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
+{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq'" sequence } }
{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
{ $examples
} ;
HELP: all-combinations
-{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
+{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq'" sequence } }
{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
PRIVATE>
-: permutation ( n seq -- seq )
+: permutation ( n seq -- seq' )
[ permutation-indices ] keep nths ;
-: all-permutations ( seq -- seq )
+: all-permutations ( seq -- seq' )
[ length factorial iota ] keep
'[ _ permutation ] map ;
: map>assoc-combinations ( seq k quot exemplar -- )
[ combinations-quot ] dip map>assoc ; inline
-: combination ( m seq k -- seq )
+: combination ( m seq k -- seq' )
<combo> apply-combination ;
-: all-combinations ( seq k -- seq )
+: all-combinations ( seq k -- seq' )
[ ] combinations-quot map ;
: reduce-combinations ( seq k identity quot -- result )
+++ /dev/null
-USING: kernel arrays math.vectors sequences math ;
-
-IN: math.points
-
-<PRIVATE
-
-: X ( x -- point ) 0 0 3array ;
-: Y ( y -- point ) 0 swap 0 3array ;
-: Z ( z -- point ) 0 0 rot 3array ;
-
-PRIVATE>
-
-: v+x ( seq x -- seq ) X v+ ;
-: v-x ( seq x -- seq ) X v- ;
-
-: v+y ( seq y -- seq ) Y v+ ;
-: v-y ( seq y -- seq ) Y v- ;
-
-: v+z ( seq z -- seq ) Z v+ ;
-: v-z ( seq z -- seq ) Z v- ;
-
-: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
-: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
-: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
-: midpoint ( point point -- point ) v+ 2 v/n ;
-: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
\ No newline at end of file
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 } { 0 1 0 } p= ." "t" } } ;
HELP: ptrim
-{ $values { "p" "a polynomial" } { "p" "a polynomial" } }
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } }
{ $description "Trims excess zeros from a polynomial." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } ptrim ." "{ 0 1 }" } } ;
HELP: 2ptrim
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p'" "a polynomial" } { "q'" "a polynomial" } }
{ $description "Trims excess zeros from two polynomials." }
{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim [ . ] bi@" "{ 0 1 }\n{ 1 }" } } ;
{ $examples { $example "USING: math.polynomials prettyprint ;" "4 { 3 0 1 } n*p ." "{ 12 0 4 }" } } ;
HELP: pextend-conv
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p'" "a polynomial" } { "q'" "a polynomial" } }
{ $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." }
{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ;
: p= ( p q -- ? ) pextend = ;
-: ptrim ( p -- p )
+: ptrim ( p -- q )
dup length 1 = [ [ zero? ] trim-tail ] unless ;
-: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ;
+: 2ptrim ( p q -- p' q' ) [ ptrim ] bi@ ;
: p+ ( p q -- r ) pextend v+ ;
: p- ( p q -- r ) pextend v- ;
: n*p ( n p -- n*p ) n*v ;
-: pextend-conv ( p q -- p q )
+: pextend-conv ( p q -- p' q' )
2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 0 0 1 } { 0 0 1 0 } q/ ." "{ 0 1 0 0 }" } } ;
HELP: q*n
-{ $values { "q" "a quaternion" } { "n" real } { "q" "a quaternion" } }
+{ $values { "q" "a quaternion" } { "n" real } { "r" "a quaternion" } }
{ $description "Multiplies each element of " { $snippet "q" } " by real value " { $snippet "n" } "." }
{ $notes "To multiply a quaternion with a complex value, use " { $link c>q } " " { $link q* } "." } ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2010 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel locals math math.functions
math.libm math.order math.vectors sequences ;
: q/ ( u v -- u/v )
qrecip q* ; inline
-: n*q ( q n -- q )
+: n*q ( q n -- r )
v*n ; inline
-: q*n ( q n -- q )
+: q*n ( q n -- r )
v*n ; inline
: n>q ( n -- q )
HELP: histogram!
{ $values
{ "hashtable" hashtable } { "seq" sequence }
- { "hashtable" hashtable }
}
{ $examples
{ $example "! Count the number of times the elements of two sequences appear."
HELP: sequence>assoc!
{ $values
{ "assoc" assoc } { "seq" sequence } { "quot" quotation }
- { "assoc" assoc }
}
{ $examples
{ $example "! Iterate over a sequence and add the counts to an existing assoc"
$nl
"SIMD support in the processor takes the form of instruction sets which operate on vector registers. By operating on multiple scalar values at the same time, code which operates on points, colors, and other vector data can be sped up."
$nl
-"In Factor, SIMD support is exposed in the form of special-purpose SIMD " { $link "sequence-protocol" } " implementations. These are fixed-length, homogeneous sequences. They are referred to as vectors, but should not be confused with Factor's " { $link "vectors" } ", which can hold any type of object and can be resized.)."
+"In Factor, SIMD support is exposed in the form of special-purpose SIMD " { $link "sequence-protocol" } " implementations. These are fixed-length, homogeneous sequences. They are referred to as vectors, but should not be confused with Factor's " { $link "vectors" } ", which can hold any type of object and can be resized."
$nl
"The words in the " { $vocab-link "math.vectors" } " vocabulary, which can be used with any sequence of numbers, are special-cased by the compiler. If the compiler can prove that only SIMD vectors are used, it expands " { $link "math-vectors" } " into " { $link "math.vectors.simd.intrinsics" } ". While in the general case, SIMD intrinsics operate on heap-allocated SIMD vectors, that too can be optimized since in many cases the compiler unbox SIMD vectors, storing them directly in registers."
$nl
ARTICLE: "math.vectors.simd.types" "SIMD vector types"
"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension."
$nl
-"The following vector types are available:"
+"The following 128-bit vector types are defined in the " { $vocab-link "math.vectors.simd" } " vocabulary:"
{ $code
"char-16"
"uchar-16"
"ulonglong-2"
"float-4"
"double-2"
+}
+"Double-width 256-bit vector types are defined in the " { $vocab-link "math.vectors.simd.cords" } " vocabulary:"
+{ $code
+ "char-32"
+ "uchar-32"
+ "short-16"
+ "ushort-16"
+ "int-8"
+ "uint-8"
+ "longlong-4"
+ "ulonglong-4"
+ "float-8"
+ "double-4"
} ;
ARTICLE: "math.vectors.simd.words" "SIMD vector words"
"""USE: compiler.tree.debugger
M\\ actor advance test-mr mr.""" }
-"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." ;
+"Example of a high-performance algorithms that use SIMD primitives can be found in the following vocabularies:"
+{ $list
+ { $vocab-link "benchmark.nbody-simd" }
+ { $vocab-link "benchmark.raytracer-simd" }
+ { $vocab-link "random.sfmt" }
+} ;
ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
"The words in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary are used to implement SIMD support. These words have three disadvantages compared to the higher-level " { $link "math-vectors" } " words:"
WHERE
-TUPLE: A < simd-128 ;
+TUPLE: A < simd-128 ; final
M: A new-underlying drop \ A boa ; inline
M: A simd-rep drop A-rep ; inline
SYNTAX: GL-FUNCTION:
gl-function-calling-convention
- scan
+ scan-c-type
scan dup
scan drop "}" parse-tokens swap prefix
gl-function-number
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
HELP: gl-shader-info-log
-{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } }
+{ $values { "shader" "A " { $link gl-shader } " object" } { "log" string } }
{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
HELP: gl-program
USING: help.markup help.syntax io kernel
-prettyprint.sections words ;
+prettyprint.sections words quotations ;
IN: prettyprint.config
ABOUT: "prettyprint-variables"
HELP: c-object-pointers?
{ $var-description "Toggles whether C objects such as structs and direct arrays only print their underlying address. If this flag isn't set, C objects will attempt to print their contents. If a C object points to invalid memory, it will display only its address regardless." } ;
+
+HELP: with-short-limits
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation in a new dynamic scope with prettyprinter limits set to produce a single line of output." } ;
+
+HELP: without-limits
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation in a new dynamic scope with prettyprinter limits set to produce unlimited output." } ;
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs io kernel math
-namespaces sequences strings vectors words
-continuations ;
+USING: kernel namespaces ;
IN: prettyprint.config
! Configuration
4 tab-size set-global
64 margin set-global
+15 nesting-limit set-global
+100 length-limit set-global
10 number-base set-global
+string-limit? on
+
+: with-short-limits ( quot -- )
+ [
+ 1 line-limit set
+ 15 length-limit set
+ 2 nesting-limit set
+ string-limit? on
+ boa-tuples? on
+ c-object-pointers? on
+ call
+ ] with-scope ; inline
+
+: without-limits ( quot -- )
+ [
+ nesting-limit off
+ length-limit off
+ line-limit off
+ string-limit? off
+ c-object-pointers? off
+ call
+ ] with-scope ; inline
boa-tuples?
c-object-pointers?
}
-"Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables."
-{
- $warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope."
- $nl
- "Some of the globals are safe to change, like the tab size and wrap margin. However setting limits globally could break code which uses the prettyprinter as a serialization mechanism."
-} ;
+"The default limits are meant to strike a balance between readability, and not producing too much output when large structures are given. There are two combinators that override the defaults:"
+{ $subsections with-short-limits without-limits }
+"That the " { $link short. } " and " { $link pprint-short } " words wrap calls to " { $link . } " and " { $link pprint } " in " { $link with-short-limits } ". Code that uses the prettyprinter for serialization should use " { $link without-limits } " to avoid producing unreadable output." ;
ARTICLE: "prettyprint-limitations" "Prettyprinter limitations"
"When using the prettyprinter as a serialization mechanism, keep the following points in mind:"
] [
[ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split
] unit-test
+
+TUPLE: final-tuple ; final
+
+[
+ {
+ "IN: prettyprint.tests"
+ "TUPLE: final-tuple ; final"
+ ""
+ }
+] [
+ [ \ final-tuple see ] with-string-writer "\n" split
+] unit-test
: unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
: pprint-short ( obj -- )
- H{
- { line-limit 1 }
- { length-limit 15 }
- { nesting-limit 2 }
- { string-limit? t }
- { boa-tuples? t }
- } clone [ pprint ] bind ;
+ [ pprint ] with-short-limits ;
: unparse-short ( obj -- str )
[ pprint-short ] with-string-writer ;
: vocab-style ( vocab -- style )
dim-color colored-presentation-style ;
+SYMBOL: stack-effect-style
+
+H{
+ { foreground COLOR: FactorDarkGreen }
+ { font-style plain }
+} stack-effect-style set-global
+
: effect-style ( effect -- style )
presented associate stack-effect-style get assoc-union ;
HELP: randomize
{ $values
{ "seq" sequence }
- { "seq" sequence }
+ { "randomized" sequence }
}
{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
[ [ random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
-: randomize ( seq -- seq )
+: randomize ( seq -- randomized )
dup length randomize-n-last ;
ERROR: too-many-samples seq n ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
{ >roman >ROMAN roman> } related-words
HELP: roman+
-{ $values { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } }
{ $description "Adds two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman-
-{ $values { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } }
{ $description "Subtracts two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
{ roman+ roman- } related-words
HELP: roman*
-{ $values { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } }
{ $description "Multiplies two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman/i
-{ $values { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } }
{ $description "Computes the integer division of two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman/mod
-{ $values { "x" string } { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } { "w" string } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
{ $examples
{ $example "USING: kernel io roman ;"
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs effects fry generalizations
grouping kernel lexer macros math math.order math.vectors
-namespaces parser quotations sequences sequences.private
-splitting.monotonic stack-checker strings unicode.case words ;
+namespaces parser effects.parser quotations sequences
+sequences.private splitting.monotonic stack-checker strings
+unicode.case words ;
IN: roman
<PRIVATE
SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ]
- dup infer define-declared ;
+ complete-effect define-declared ;
>>
-ROMAN-OP: +
-ROMAN-OP: -
-ROMAN-OP: *
-ROMAN-OP: /i
-ROMAN-OP: /mod
+ROMAN-OP: + ( x y -- z )
+ROMAN-OP: - ( x y -- z )
+ROMAN-OP: * ( x y -- z )
+ROMAN-OP: /i ( x y -- z )
+ROMAN-OP: /mod ( x y -- z w )
SYNTAX: ROMAN: scan roman> suffix! ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate classes.singleton
dup length 1 = [ first ] when
pprint-slot-name ;
+: tuple-declarations. ( class -- )
+ \ final declaration. ;
+
+: superclass. ( class -- )
+ superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
- dup pprint-word
- dup superclass tuple eq? [
- "<" text dup superclass pprint-word
- ] unless
- <block "slots" word-prop [ pprint-slot ] each block>
- pprint-; block> ;
+ {
+ [ pprint-word ]
+ [ superclass. ]
+ [ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
+ [ tuple-declarations. ]
+ } cleave
+ block> ;
M: word see-class* drop ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting binary-search fry math
math.order arrays classes combinators kernel functors math.functions
MIXIN: cord
TUPLE: generic-cord
- { head read-only } { tail read-only } ;
+ { head read-only } { tail read-only } ; final
INSTANCE: generic-cord cord
M: cord length
WHERE
TUPLE: T-cord
- { head T read-only } { tail T read-only } ;
+ { head T read-only } { tail T read-only } ; final
INSTANCE: T-cord cord
M: T cord-append
{ $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 )" } } { "obj" object } }
+{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } }
{ $description "Modifies each sub-node of an object in place, in preorder, and returns that object." }
{ $see-also map! } ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax strings ;
+IN: simple-tokenizer
+
+HELP: tokenize
+{ $values { "input" string } { "ast" "a sequence of strings" } }
+{ $description
+ "Tokenize a string. Supported syntax:"
+ { $list
+ { { $snippet "foo bar baz" } " - simple tokens" }
+ { { $snippet "foo\\ bar" } " - token with an escaped space"}
+ { { $snippet "\"foo bar\"" } " - quoted token" }
+ }
+} ;
--- /dev/null
+IN: simple-tokenizer.tests
+USING: simple-tokenizer tools.test ;
+
+[ "" tokenize ] must-fail
+[ " " tokenize ] must-fail
+[ V{ "a" } ] [ "a" tokenize ] unit-test
+[ V{ "abc" } ] [ "abc" tokenize ] unit-test
+[ V{ "abc" } ] [ "abc " tokenize ] unit-test
+[ V{ "abc" } ] [ " abc" tokenize ] unit-test
+[ V{ "abc" "def" } ] [ "abc def" tokenize ] unit-test
+[ V{ "abc def" } ] [ "abc\\ def" tokenize ] unit-test
+[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize ] unit-test
+[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize ] unit-test
+[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize ] unit-test
+[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize ] unit-test
+[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize ] unit-test
+[ "\"abc def\" \"hey" tokenize ] must-fail
+[ "\"abc def" tokenize ] must-fail
+[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize ] unit-test
+
+[
+ V{
+ "Hello world.app/Contents/MacOS/hello-ui"
+ "-i=boot.macosx-ppc.image"
+ "-include= math compiler ui"
+ "-deploy-vocab=hello-ui"
+ "-output-image=Hello world.app/Contents/Resources/hello-ui.image"
+ "-no-stack-traces"
+ "-no-user-init"
+ }
+] [
+ "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize
+] unit-test
--- /dev/null
+! Copyright (C) 2008, 2010 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: peg peg.ebnf arrays sequences strings kernel ;
+IN: simple-tokenizer
+
+EBNF: tokenize
+space = " "
+escaped-char = "\" .:ch => [[ ch ]]
+quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
+unquoted = (escaped-char | [^ "])+
+argument = (quoted | unquoted) => [[ >string ]]
+command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
+;EBNF
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.parser
assocs byte-arrays classes compiler.units functors kernel lexer
M: bad-byte-array-length summary
drop "Byte array length doesn't divide type width" ;
+ERROR: not-a-byte-array alien ;
+
+M: not-a-byte-array summary
+ drop "Not a byte array" ;
+
: (underlying) ( n c-type -- array )
heap-size * (byte-array) ; inline
TUPLE: A
{ underlying c-ptr read-only }
-{ length array-capacity read-only } ;
+{ length array-capacity read-only } ; final
: <direct-A> ( alien len -- specialized-array ) A boa ; inline
[ \ T heap-size calloc ] keep <direct-A> ; inline
: byte-array>A ( byte-array -- specialized-array )
- >c-ptr dup length \ T heap-size /mod 0 =
- [ drop \ T bad-byte-array-length ] unless
- <direct-A> ; inline
+ >c-ptr dup byte-array? [
+ dup length \ T heap-size /mod 0 =
+ [ <direct-A> ]
+ [ drop \ T bad-byte-array-length ] if
+ ] [ not-a-byte-array ] if ; inline
M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
;FUNCTOR
-GENERIC: (underlying-type) ( c-type -- c-type' )
-
-M: string (underlying-type) c-types get at ;
-M: word (underlying-type) "c-type" word-prop ;
+: (underlying-type) ( word -- c-type ) "c-type" word-prop ; inline
: underlying-type ( c-type -- c-type' )
dup (underlying-type) {
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors classes.algebra fry generic kernel math
-namespaces sequences words sets combinators.short-circuit ;
+USING: assocs accessors classes classes.algebra fry generic
+kernel math namespaces sequences words sets
+combinators.short-circuit classes.tuple ;
FROM: classes.tuple.private => tuple-layout ;
+FROM: assocs => change-at ;
IN: stack-checker.dependencies
! Words that the current quotation depends on
boa conditional-dependencies get
dup [ conjoin ] [ 2drop ] if ; inline
-TUPLE: depends-on-class<= class1 class2 ;
+TUPLE: depends-on-class-predicate class1 class2 result ;
-: depends-on-class<= ( class1 class2 -- )
- \ depends-on-class<= add-conditional-dependency ;
+: depends-on-class-predicate ( class1 class2 result -- )
+ \ depends-on-class-predicate add-conditional-dependency ;
-M: depends-on-class<= satisfied?
+M: depends-on-class-predicate satisfied?
{
- [ class1>> classoid? ]
- [ class2>> classoid? ]
- [ [ class1>> ] [ class2>> ] bi class<= ]
+ [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ]
+ [ [ [ class1>> ] [ class2>> ] bi compare-classes ] [ result>> ] bi eq? ]
} 1&& ;
-TUPLE: depends-on-classes-disjoint class1 class2 ;
+TUPLE: depends-on-instance-predicate object class result ;
-: depends-on-classes-disjoint ( class1 class2 -- )
- \ depends-on-classes-disjoint add-conditional-dependency ;
+: depends-on-instance-predicate ( object class result -- )
+ \ depends-on-instance-predicate add-conditional-dependency ;
-M: depends-on-classes-disjoint satisfied?
+M: depends-on-instance-predicate satisfied?
{
- [ class1>> classoid? ]
- [ class2>> classoid? ]
- [ [ class1>> ] [ class2>> ] bi classes-intersect? not ]
+ [ class>> classoid? ]
+ [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
} 1&& ;
TUPLE: depends-on-next-method class generic next-method ;
M: depends-on-flushable satisfied?
word>> flushable? ;
+TUPLE: depends-on-final class ;
+
+: depends-on-final ( word -- )
+ [ depends-on-conditionally ]
+ [ \ depends-on-final add-conditional-dependency ] bi ;
+
+M: depends-on-final satisfied?
+ class>> final-class? ;
+
: init-dependencies ( -- )
H{ } clone dependencies set
H{ } clone generic-dependencies set
} ;
ARTICLE: "inference-errors" "Stack checker errors"
-"These " { $link "inference" } " failure conditions are reported in one of two ways:"
+"Stack effect checking failure conditions are reported in one of two ways:"
{ $list
- { { $link "tools.inference" } " throws them as errors" }
- { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } }
+ { { $link "tools.inference" } " report them when fed quotations interactively" }
+ { "The " { $link "compiler" } " reports them while compiling words, via the " { $link "tools.errors" } " mechanism" }
}
"Errors thrown when insufficient information is available to calculate the stack effect of a call to a combinator or macro (see " { $link "inference-combinators" } "):"
{ $subsections
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
: word-timing. ( -- )
word-timing get
- >alist [ 1000000 /f ] assoc-map sort-values
+ >alist [ 1,000,000,000 /f ] assoc-map sort-values
simple-table. ;
+++ /dev/null
-unportable
! To make UI browser happy
M: vocab uses drop f ;
-GENERIC: crossref-def ( defspec -- )
-
-M: object crossref-def
+: crossref-def ( defspec -- )
dup uses crossref get add-vertex ;
-M: word crossref-def
- [ call-next-method ] [ subwords [ crossref-def ] each ] bi ;
-
: defs-to-crossref ( -- seq )
[
all-words
+ [ [ generic? not ] filter ]
+ [ [ subwords ] map concat ] bi
+
all-articles [ >link ] map
+
source-files get keys [ <pathname> ] map
] append-outputs ;
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
io.streams.c io.files io.files.temp io.pathnames io.directories
io.directories.hierarchy io.backend quotations io.launcher
tools.deploy.config tools.deploy.config.editor bootstrap.image
-io.encodings.utf8 destructors accessors hashtables ;
+io.encodings.utf8 destructors accessors hashtables
+tools.deploy.libraries vocabs.metadata.resources ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name -- vm )
prepend-path vm over copy-file ;
-CONSTANT: theme-path "basis/ui/gadgets/theme/"
+TUPLE: vocab-manifest vocabs libraries ;
-: copy-theme ( name dir -- )
- deploy-ui? get [
- append-path
- theme-path append-path
- [ make-directories ]
- [ theme-path "resource:" prepend swap copy-tree ] bi
- ] [ 2drop ] if ;
+: copy-resources ( manifest name dir -- )
+ append-path swap vocabs>> [ copy-vocab-resources ] with each ;
+
+ERROR: can't-deploy-library-file library ;
+
+: copy-library ( dir library -- )
+ dup find-library-file
+ [ swap over file-name append-path copy-file ]
+ [ can't-deploy-library-file ] ?if ;
+
+: copy-libraries ( manifest name dir -- )
+ append-path swap libraries>> [ copy-library ] with each ;
: image-name ( vocab bundle-name -- str )
prepend-path ".image" append ;
[ "deploy-config-" prepend temp-file ] bi
[ utf8 set-file-contents ] keep ;
-: deploy-command-line ( image vocab config -- flags )
+: deploy-command-line ( image vocab manifest-file config -- flags )
[
bootstrap-profile ?make-staging-image
"-i=" bootstrap-profile staging-image-name append ,
"-resource-path=" "" resource-path append ,
"-run=tools.deploy.shaker" ,
+ "-vocab-manifest-out=" prepend ,
[ "-deploy-vocab=" prepend , ]
[ make-deploy-config "-deploy-config=" prepend , ] bi
"-output-image=" prepend ,
] { } make
] bind ;
-: make-deploy-image ( vm image vocab config -- )
+: parse-vocab-manifest-file ( path -- vocab-manifest )
+ utf8 file-lines
+ dup first "VOCABS:" =
+ [ { "LIBRARIES:" } split1 vocab-manifest boa ]
+ [ "invalid vocab manifest!" throw ] if ;
+
+: make-deploy-image ( vm image vocab config -- manifest )
make-boot-image
- deploy-command-line run-factor ;
+ over "vocab-manifest-" prepend temp-file
+ [ swap deploy-command-line run-factor ]
+ [ parse-vocab-manifest-file ] bi ;
HOOK: deploy* os ( vocab -- )
"Off by default. During normal execution, the word definition quotation of a word compiled with the optimizing compiler is not used, so disabling this flag can save space. However, some libraries introspect word definitions dynamically (for example, " { $vocab-link "inverse" } ") and so programs using these libraries must retain word definition quotations." } ;
HELP: deploy-c-types?
-{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table, otherwise this table is stripped out, saving space."
+{ $description "Deploy flag. If set, the deploy tool retains word properties containing metadata for C types and struct classes; otherwise, these properties are stripped out, saving space."
$nl
"Off by default."
$nl
{ $link malloc-object }
{ $link malloc-array }
}
-"If your program looks up C types dynamically or from words which do not have a stack effect, you must enable this flag, because in these situations the C type lookup is not folded away and the global table must be consulted at runtime." } ;
+"If your program looks up C types dynamically or from words which do not have a stack effect, you must enable this flag, because in these situations the C type lookup code is not folded away and the word properties must be consulted at runtime." } ;
HELP: deploy-math?
{ $description "Deploy flag. If set, the deployed image will contain support for " { $link ratio } " and " { $link complex } " types."
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io.pathnames kernel parser prettyprint sequences
-splitting tools.deploy.config vocabs.loader vocabs.metadata ;
+USING: assocs io.pathnames kernel parser prettyprint
+prettyprint.config sequences splitting tools.deploy.config
+vocabs.loader vocabs.metadata ;
IN: tools.deploy.config.editor
: deploy-config-path ( vocab -- string )
parse-fresh [ first assoc-union ] unless-empty ;
: set-deploy-config ( assoc vocab -- )
- [ unparse-use string-lines ] dip
+ [ [ unparse-use ] without-limits string-lines ] dip
dup deploy-config-path set-vocab-file-contents ;
: set-deploy-flag ( value key vocab -- )
{ $subsections
"deploy-config"
"deploy-flags"
+ "deploy-resources"
} ;
+ARTICLE: "deploy-resources" "Deployed resource files"
+"To include additional files in your deployed application, specify their names in a vocabulary's " { $snippet "resources.txt" } " file. The " { $snippet "resources.txt" } " file contains one glob pattern per line. These patterns are expanded relative to the vocabulary directory; files outside of the vocabulary directory cannot be referenced. If a file inside the vocabulary directory matches any of these patterns, it will be included in deployed applications that reference the vocabulary. If a subdirectory matches, its contents will be included recursively."
+$nl
+"If the deployed vocabulary includes an icon file for the current platform, it will be embedded in the deployed application as its GUI icon. See " { $link "vocabs.icons" } "." ;
+
ARTICLE: "tools.deploy.usage" "Deploy tool usage"
"Once the necessary deployment flags have been set, the application can be deployed:"
{ $subsections deploy }
-USING: tools.test system io io.encodings.ascii io.pathnames\r
-io.files io.files.info io.files.temp kernel tools.deploy.config\r
-tools.deploy.config.editor tools.deploy.backend math sequences\r
-io.launcher arrays namespaces continuations layouts accessors\r
-urls math.parser io.directories tools.deploy.test ;\r
-IN: tools.deploy.tests\r
-\r
-[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
-\r
-[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
-\r
-[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
-\r
-[ "staging.math-threads-compiler-ui.image" ] [\r
- "hello-ui" deploy-config\r
- [ bootstrap-profile staging-image-name file-name ] bind\r
-] unit-test\r
-\r
-[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
-\r
-[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
-\r
-[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
-\r
-[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test\r
-\r
-[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
-\r
-os macosx? [\r
- [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
-] when\r
-\r
-[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test\r
-\r
-{\r
- "tools.deploy.test.1"\r
- "tools.deploy.test.2"\r
- "tools.deploy.test.3"\r
- "tools.deploy.test.4"\r
-} [\r
- [ ] swap [\r
- shake-and-bake\r
- run-temp-image\r
- ] curry unit-test\r
-] each\r
-\r
-USING: http.client http.server http.server.dispatchers\r
-http.server.responses http.server.static io.servers.connection ;\r
-\r
-SINGLETON: quit-responder\r
-\r
-M: quit-responder call-responder*\r
- 2drop stop-this-server "Goodbye" "text/html" <content> ;\r
-\r
-: add-quot-responder ( responder -- responder )\r
- quit-responder "quit" add-responder ;\r
-\r
-: test-httpd ( responder -- )\r
- [\r
- main-responder set\r
- <http-server>\r
- 0 >>insecure\r
- f >>secure\r
- dup start-server*\r
- sockets>> first addr>> port>>\r
- dup number>string "resource:temp/port-number" ascii set-file-contents\r
- ] with-scope\r
- "port" set ;\r
-\r
-[ ] [\r
- <dispatcher>\r
- add-quot-responder\r
- "vocab:http/test" <static> >>default\r
-\r
- test-httpd\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.5" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-: add-port ( url -- url' )\r
- >url clone "port" get >>port ;\r
-\r
-[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test\r
-\r
-{\r
- "tools.deploy.test.6"\r
- "tools.deploy.test.7"\r
- "tools.deploy.test.9"\r
- "tools.deploy.test.10"\r
- "tools.deploy.test.11"\r
- "tools.deploy.test.12"\r
-} [\r
- [ ] swap [\r
- shake-and-bake\r
- run-temp-image\r
- ] curry unit-test\r
-] each\r
-\r
-os windows? os macosx? or [\r
- [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test\r
-] when\r
-\r
-os macosx? [\r
- [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test\r
-] when\r
-\r
-[ { "a" "b" "c" } ] [\r
- "tools.deploy.test.15" shake-and-bake deploy-test-command\r
- { "a" "b" "c" } append\r
- ascii [ lines ] with-process-reader\r
- rest\r
-] unit-test\r
-\r
-[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test\r
-\r
-[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test\r
+USING: tools.test system io io.encodings.ascii io.pathnames
+io.files io.files.info io.files.temp kernel tools.deploy.config
+tools.deploy.config.editor tools.deploy.backend math sequences
+io.launcher arrays namespaces continuations layouts accessors
+urls math.parser io.directories tools.deploy.test ;
+IN: tools.deploy.tests
+
+[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
+
+[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
+
+[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
+
+[ "staging.math-threads-compiler-ui.image" ] [
+ "hello-ui" deploy-config
+ [ bootstrap-profile staging-image-name file-name ] bind
+] unit-test
+
+[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
+
+[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test
+
+[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test
+
+[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
+
+[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test
+
+os macosx? [
+ [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test
+] when
+
+[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test
+
+{
+ "tools.deploy.test.1"
+ "tools.deploy.test.2"
+ "tools.deploy.test.3"
+ "tools.deploy.test.4"
+} [
+ [ ] swap [
+ shake-and-bake
+ run-temp-image
+ ] curry unit-test
+] each
+
+USING: http.client http.server http.server.dispatchers
+http.server.responses http.server.static io.servers.connection ;
+
+SINGLETON: quit-responder
+
+M: quit-responder call-responder*
+ 2drop stop-this-server "Goodbye" "text/html" <content> ;
+
+: add-quot-responder ( responder -- responder )
+ quit-responder "quit" add-responder ;
+
+: test-httpd ( responder -- )
+ [
+ main-responder set
+ <http-server>
+ 0 >>insecure
+ f >>secure
+ dup start-server*
+ sockets>> first addr>> port>>
+ dup number>string "resource:temp/port-number" ascii set-file-contents
+ ] with-scope
+ "port" set ;
+
+[ ] [
+ <dispatcher>
+ add-quot-responder
+ "vocab:http/test" <static> >>default
+
+ test-httpd
+] unit-test
+
+[ ] [
+ "tools.deploy.test.5" shake-and-bake
+ run-temp-image
+] unit-test
+
+: add-port ( url -- url' )
+ >url clone "port" get >>port ;
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
+
+{
+ "tools.deploy.test.6"
+ "tools.deploy.test.7"
+ "tools.deploy.test.9"
+ "tools.deploy.test.10"
+ "tools.deploy.test.11"
+ "tools.deploy.test.12"
+} [
+ [ ] swap [
+ shake-and-bake
+ run-temp-image
+ ] curry unit-test
+] each
+
+os windows? os macosx? or [
+ [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
+] when
+
+os macosx? [
+ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test
+] when
+
+[ { "a" "b" "c" } ] [
+ "tools.deploy.test.15" shake-and-bake deploy-test-command
+ { "a" "b" "c" } append
+ ascii [ lines ] with-process-reader
+ rest
+] unit-test
+
+[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
+
+[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test
+
+[ t ] [
+ "tools.deploy.test.18" shake-and-bake
+ deploy-test-command ascii [ readln ] with-process-reader
+ "test.image" temp-file =
+] unit-test
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien.libraries io.pathnames io.pathnames.private kernel
+system vocabs.loader ;
+IN: tools.deploy.libraries
+
+HOOK: find-library-file os ( file -- path )
+
+os windows?
+"tools.deploy.libraries.windows"
+"tools.deploy.libraries.unix" ? require
+
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: io.files io.pathnames io.pathnames.private kernel
+sequences system tools.deploy.libraries ;
+IN: tools.deploy.libraries.unix
+
+! stupid hack. better ways to find the library name would be open the library,
+! note a symbol address found in the library, then call dladdr (or use
+: ?exists ( path -- path/f )
+ dup exists? [ drop f ] unless ; inline
+
+M: unix find-library-file
+ dup absolute-path? [ ?exists ] [
+ { "/lib" "/usr/lib" "/usr/local/lib" "/opt/local/lib" "resource:" }
+ [ prepend-path ?exists ] with map-find drop
+ ] if ;
+
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien.strings byte-arrays io.encodings.utf16n kernel
+specialized-arrays system tools.deploy.libraries windows.kernel32
+windows.types ;
+FROM: alien.c-types => ushort ;
+SPECIALIZED-ARRAY: ushort
+IN: tools.deploy.libraries.windows
+
+M: windows find-library-file
+ f DONT_RESOLVE_DLL_REFERENCES LoadLibraryEx [
+ [
+ 32768 (ushort-array) [ 32768 GetModuleFileName drop ] keep
+ utf16n alien>string
+ ] [ FreeLibrary drop ] bi
+ ] [ f ] if* ;
+
tools.deploy.config.editor assocs hashtables prettyprint
io.backend.unix cocoa io.encodings.utf8 io.backend
cocoa.application cocoa.classes cocoa.plists
-combinators ;
+combinators vocabs.metadata vocabs.loader ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
[ bundle-dir prepend-path swap ] keep
"Contents" prepend-path append-path copy-tree ;
-: app-plist ( executable bundle-name -- assoc )
+: app-plist ( icon? executable bundle-name -- assoc )
[
"6.0" "CFBundleInfoDictionaryVersion" set
"APPL" "CFBundlePackageType" set
[ "CFBundleExecutable" set ]
[ "org.factor." prepend "CFBundleIdentifier" set ] bi
+
+ [ "Icon.icns" "CFBundleIconFile" set ] when
] H{ } make-assoc ;
-: create-app-plist ( executable bundle-name -- )
+: create-app-plist ( icon? executable bundle-name -- )
[ app-plist ] keep
"Contents/Info.plist" append-path
write-plist ;
"Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
] [ drop ] if ;
+: copy-icns ( vocab bundle-name -- icon? )
+ swap dup vocab-mac-icon-path vocab-append-path dup exists?
+ [ swap "Contents/Resources/Icon.icns" append-path copy-file t ]
+ [ 2drop f ] if ;
+
: create-app-dir ( vocab bundle-name -- vm )
- [
- nip {
- [ copy-dll ]
- [ copy-nib ]
- [ "Contents/Resources" append-path make-directories ]
- [ "Contents/Resources" copy-theme ]
- } cleave
- ]
- [ create-app-plist ]
- [ "Contents/MacOS/" append-path copy-vm ] 2tri
+ {
+ [
+ nip {
+ [ copy-dll ]
+ [ copy-nib ]
+ [ "Contents/Resources" append-path make-directories ]
+ } cleave
+ ]
+ [ copy-icns ]
+ [ create-app-plist ]
+ [ "Contents/MacOS/" append-path copy-vm ]
+ } 2cleave
dup OCT: 755 set-file-permissions ;
: deploy.app-image ( vocab bundle-name -- str )
[ bundle-name create-app-dir ] keep
[ bundle-name deploy.app-image ] keep
namespace make-deploy-image
+ bundle-name
+ [ "Contents/Resources" copy-resources ]
+ [ "Contents/Frameworks" copy-libraries ] 2bi
bundle-name show-in-finder
] bind
] with-directory ;
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays accessors io.backend io.streams.c init fry
-namespaces math make assocs kernel parser parser.notes lexer
-strings.parser vocabs sequences sequences.deep sequences.private
-words memory kernel.private continuations io vocabs.loader
-system strings sets vectors quotations byte-arrays sorting
-compiler.units definitions generic generic.standard
+USING: arrays alien.libraries accessors io.backend io.encodings.utf8 io.files
+io.streams.c init fry namespaces math make assocs kernel parser
+parser.notes lexer strings.parser vocabs sequences sequences.deep
+sequences.private words memory kernel.private continuations io
+vocabs.loader system strings sets vectors quotations byte-arrays
+sorting compiler.units definitions generic generic.standard
generic.single tools.deploy.config combinators classes
-classes.builtin slots.private grouping command-line ;
+classes.builtin slots.private grouping command-line io.pathnames ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes.private
QUALIFIED: compiler.crossref
QUALIFIED: source-files
QUALIFIED: source-files.errors
QUALIFIED: vocabs
+FROM: alien.libraries.private => >deployed-library-path ;
IN: tools.deploy.shaker
! This file is some hairy shit.
"io.thread" startup-hooks get delete-at
] unless
strip-io? [
- "io.files" startup-hooks get delete-at
"io.backend" startup-hooks get delete-at
"io.thread" startup-hooks get delete-at
] when
strip-dictionary? [
{
- ! "compiler.units"
"vocabs"
"vocabs.cache"
"source-files.errors"
input-stream
output-stream
error-stream
+ vm
+ image
+ current-directory
} %
"io-thread" "io.thread" lookup ,
] when
] when
- deploy-c-types? get [
- "c-types" "alien.c-types" lookup ,
- ] unless
-
"windows-messages" "windows.messages" lookup [ , ] when*
] { } make ;
: startup-stripper ( -- )
t "quiet" set-global
- f output-stream set-global ;
+ f output-stream set-global
+ V{ "resource:" } clone vocab-roots set-global ;
: next-method* ( method -- quot )
[ "method-class" word-prop ]
"Clearing megamorphic caches" show
[ clear-megamorphic-cache ] each ;
-: strip ( -- )
+: 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
+ swap utf8 set-file-lines ;
+
+: prepare-deploy-libraries ( -- )
+ "Preparing deployed libraries" show
+ deploy-libraries get [
+ libraries get [
+ [ path>> >deployed-library-path ] [ abi>> ] bi <library>
+ ] change-at
+ ] each
+
+ [
+ "deploy-libraries" "alien.libraries" lookup forget
+ "deploy-library" "alien.libraries" lookup forget
+ ">deployed-library-path" "alien.libraries.private" lookup forget
+ ] with-compilation-unit ;
+
+: strip ( vocab-manifest-out -- )
+ [ write-vocab-manifest ] when*
startup-stripper
+ prepare-deploy-libraries
strip-libc
strip-destructors
strip-call
1 exit
] recover ; inline
-: (deploy) ( final-image vocab config -- )
+: (deploy) ( final-image vocab-manifest-out vocab config -- )
#! Does the actual work of a deployment in the slave
#! stage2 image
[
"ui.debugger" require
] when
] unless
- deploy-vocab set
- deploy-vocab get require
- deploy-vocab get vocab-main [
- "Vocabulary has no MAIN: word." print flush 1 exit
- ] unless
+ [ deploy-vocab set ] [ require ] [
+ vocab-main [
+ "Vocabulary has no MAIN: word." print flush 1 exit
+ ] unless
+ ] tri
strip
"Saving final image" show
save-image-and-exit
: do-deploy ( -- )
"output-image" get
+ "vocab-manifest-out" get
"deploy-vocab" get
"Deploying " write dup write "..." print
"deploy-config" get parse-file first
+++ /dev/null
-unportable
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.streams.c math.parser system ;
+IN: tools.deploy.test.18
+
+: main ( -- ) image show ;
+
+MAIN: main
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "tools.deploy.test.18" }
+ { deploy-ui? f }
+ { deploy-c-types? f }
+ { deploy-unicode? f }
+ { "stop-after-last-window?" t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-word-props? f }
+ { deploy-math? f }
+ { deploy-threads? f }
+ { deploy-word-defs? f }
+}
[ "test.image" temp-file delete-file ] ignore-errors
"resource:" [
[ vm "test.image" temp-file ] dip
- dup deploy-config make-deploy-image
+ dup deploy-config make-deploy-image drop
] with-directory ;
ERROR: image-too-big actual-size max-size ;
IN: tools.deploy.unix
: create-app-dir ( vocab bundle-name -- vm )
- dup "" copy-theme
copy-vm
dup OCT: 755 set-file-permissions ;
[ bundle-name create-app-dir ] keep
[ bundle-name image-name ] keep
namespace make-deploy-image
+ bundle-name "" [ copy-resources ] [ copy-libraries ] 3bi
bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
] bind
- ] with-directory ;
\ No newline at end of file
+ ] with-directory ;
--- /dev/null
+USING: accessors alien alien.c-types arrays classes.struct combinators
+io.backend kernel locals math sequences specialized-arrays
+tools.deploy.windows windows.kernel32 windows.types ;
+IN: tools.deploy.windows.ico
+
+<PRIVATE
+
+STRUCT: ico-header
+ { Reserved WORD }
+ { Type WORD }
+ { ImageCount WORD } ;
+
+STRUCT: ico-directory-entry
+ { Width BYTE }
+ { Height BYTE }
+ { Colors BYTE }
+ { Reserved BYTE }
+ { Planes WORD }
+ { BitsPerPixel WORD }
+ { ImageSize DWORD }
+ { ImageOffset DWORD } ;
+SPECIALIZED-ARRAY: ico-directory-entry
+
+STRUCT: group-directory-entry
+ { Width BYTE }
+ { Height BYTE }
+ { Colors BYTE }
+ { Reserved BYTE }
+ { Planes WORD }
+ { BitsPerPixel WORD }
+ { ImageSize DWORD }
+ { ImageResourceID WORD } ;
+
+: ico>group-directory-entry ( ico i -- group )
+ [ {
+ [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
+ [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
+ } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
+
+: ico-icon ( directory-entry bytes -- subbytes )
+ [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
+
+:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
+ bytes ico-header memory>struct :> header
+
+ ico-header heap-size bytes <displaced-alien>
+ header ImageCount>> <direct-ico-directory-entry-array> :> directory
+
+ directory dup length iota [ ico>group-directory-entry ] { } 2map-as
+ :> group-directory
+ directory [ bytes ico-icon ] { } map-as :> icon-bytes
+
+ header clone >c-ptr group-directory concat append
+ icon-bytes ; inline
+
+PRIVATE>
+
+:: embed-icon-resource ( exe ico-bytes id -- )
+ exe normalize-path 1 BeginUpdateResource :> hUpdate
+ hUpdate [
+ ico-bytes ico-group-and-icons :> ( group icons )
+ hUpdate RT_GROUP_ICON id 0 group dup byte-length
+ UpdateResource drop
+
+ icons [| icon i |
+ hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
+ UpdateResource drop
+ ] each-index
+
+ hUpdate 0 EndUpdateResource drop
+ ] when ;
+
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.pathnames io.directories io.encodings.ascii kernel namespaces
+USING: io io.encodings.binary io.files io.pathnames io.directories
+io.encodings.ascii kernel namespaces
sequences locals system splitting tools.deploy.backend
tools.deploy.config tools.deploy.config.editor assocs hashtables
-prettyprint combinators windows.shell32 windows.user32 ;
+prettyprint combinators windows.kernel32 windows.shell32 windows.user32
+alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico ;
IN: tools.deploy.windows
+CONSTANT: app-icon-resource-id "APPICON"
+
: copy-dll ( bundle-name -- )
"resource:factor.dll" swap copy-file-into ;
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dll
- deploy-ui? get [
- [ "" copy-theme ] [ ".exe" copy-vm ] bi
- ] [ ".com" copy-vm ] if ;
+ deploy-ui? get ".exe" ".com" ? copy-vm ;
+
+: embed-ico ( vm vocab -- )
+ dup vocab-windows-icon-path vocab-append-path dup exists?
+ [ binary file-contents app-icon-resource-id embed-icon-resource ]
+ [ 2drop ] if ;
M: winnt deploy*
"resource:" [
dup deploy-config [
deploy-name get
- [
- [ create-exe-dir ]
+ {
+ [ create-exe-dir dup ]
+ [ drop embed-ico ]
[ image-name ]
- [ drop ]
- 2tri namespace make-deploy-image
- ]
- [ nip open-in-explorer ] 2bi
+ [ drop namespace make-deploy-image ]
+ [ nip "" [ copy-resources ] [ copy-libraries ] 3bi ]
+ [ nip open-in-explorer ]
+ } 2cleave
] bind
] with-directory ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! See http://factorcode.org/license.txt for BSD license.
USING: assocs io.files io.pathnames io.directories
io.encodings.utf8 hashtables kernel namespaces sequences
-vocabs.loader io combinators calendar accessors math.parser
-io.streams.string ui.tools.operations quotations strings arrays
-prettyprint words vocabs sorting sets classes math alien urls
-splitting ascii combinators.short-circuit alarms words.symbol
-system summary ;
+vocabs.loader vocabs.metadata io combinators calendar accessors
+math.parser io.streams.string ui.tools.operations quotations
+strings arrays prettyprint words vocabs sorting sets classes
+math alien urls splitting ascii combinators.short-circuit alarms
+words.symbol system summary ;
IN: tools.scaffold
SYMBOL: developer-name
ERROR: not-a-vocab-root string ;
ERROR: vocab-name-contains-separator path ;
ERROR: vocab-name-contains-dot path ;
-ERROR: no-vocab vocab ;
ERROR: bad-developer-name name ;
M: bad-developer-name summary
: check-root ( string -- string )
dup vocab-root? [ not-a-vocab-root ] unless ;
-: check-vocab ( vocab -- vocab )
- dup find-vocab-root [ no-vocab ] unless ;
-
: check-vocab-root/vocab ( vocab-root string -- vocab-root string )
[ check-root ] [ check-vocab-name ] bi* ;
+++ /dev/null
-unportable
HELP: TUPLE-ARRAY:
{ $syntax "TUPLE-ARRAY: class" }
+{ $values { "class" "a final tuple class" } }
{ $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ;
ARTICLE: "tuple-arrays" "Tuple arrays"
-"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
+"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of references to heap-allocated objects, a tuple array stores its elements as values."
$nl
-"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "."
+"Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
+$nl
+"Since value semantics are incompatible with inheritance, the base type of a tuple array must be declared " { $link POSTPONE: final } ". A best practice that is not enforced is to have all slots in the tuple declared " { $link read-only } "."
+$nl
+"Tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
$nl
-"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
{ $subsections POSTPONE: TUPLE-ARRAY: }
"An example:"
{ $example
"USE: tuple-arrays"
"IN: scratchpad"
- "TUPLE: point x y ;"
+ "TUPLE: point x y ; final"
"TUPLE-ARRAY: point"
"{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short."
"T{ point f 1 2 }"
USING: tuple-arrays sequences tools.test namespaces kernel
-math accessors ;
+math accessors classes.tuple eval ;
IN: tuple-arrays.tests
SYMBOL: mat
-TUPLE: foo bar ;
+TUPLE: foo bar ; final
C: <foo> foo
TUPLE-ARRAY: foo
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
-TUPLE: baz { bing integer } bong ;
+TUPLE: baz { bing integer } bong ; final
TUPLE-ARRAY: baz
[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
[ f ] [ 1 <baz-array> first bong>> ] unit-test
-TUPLE: broken x ;
+TUPLE: broken x ; final
: broken ( -- ) ;
TUPLE-ARRAY: broken
-[ 100 ] [ 100 <broken-array> length ] unit-test
\ No newline at end of file
+[ 100 ] [ 100 <broken-array> length ] unit-test
+
+! Can't define a tuple array for a non-tuple class
+[ "IN: tuple-arrays.tests USING: tuple-arrays words ; TUPLE-ARRAY: word" eval( -- ) ]
+[ error>> not-a-tuple? ]
+must-fail-with
+
+! Can't define a tuple array for a non-final class
+TUPLE: non-final x ;
+
+[ "IN: tuple-arrays.tests USE: tuple-arrays TUPLE-ARRAY: non-final" eval( -- ) ]
+[ error>> not-final? ]
+must-fail-with
\ No newline at end of file
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators.smart fry functors kernel
kernel.private macros sequences combinators sequences.private
-stack-checker parser math classes.tuple.private ;
+stack-checker parser math classes.tuple classes.tuple.private ;
FROM: inverse => undo ;
IN: tuple-arrays
+ERROR: not-final class ;
+
<PRIVATE
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
[ tuple-arity iota <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
+: check-final ( class -- )
+ {
+ { [ dup tuple-class? not ] [ not-a-tuple ] }
+ { [ dup final-class? not ] [ not-final ] }
+ [ drop ]
+ } cond ;
+
PRIVATE>
FUNCTOR: define-tuple-array ( CLASS -- )
WHERE
+CLASS check-final
+
TUPLE: CLASS-array
{ seq array read-only }
{ n array-capacity read-only }
ARTICLE: "typed" "Strongly-typed word definitions"
"The Factor compiler supports advanced compiler optimizations that take advantage of the type information it can glean from source code. The " { $vocab-link "typed" } " vocabulary provides syntax that allows words to provide checked type information about their inputs and outputs and improve the performance of compiled code."
+$nl
+"Parameters and return values of typed words where the type is declared to be a " { $link POSTPONE: final } " tuple class with all slots " { $link read-only } " are passed by value."
{ $subsections
POSTPONE: TYPED:
POSTPONE: TYPED::
+}
+"Defining typed words at run time:"
+{ $subsections
define-typed
+}
+"Errors:"
+{ $subsections
input-mismatch-error
output-mismatch-error
} ;
most-positive-fixnum neg 1 - 1quotation
[ most-positive-fixnum 1 fix+ ] unit-test
-TUPLE: tweedle-dee ;
-TUPLE: tweedle-dum ;
+TUPLE: tweedle-dee ; final
+TUPLE: tweedle-dum ; final
TYPED: dee ( x: tweedle-dee -- y )
drop \ tweedle-dee ;
TUPLE: unboxable
{ x fixnum read-only }
- { y fixnum read-only } ;
+ { y fixnum read-only } ; final
TUPLE: unboxable2
{ u unboxable read-only }
- { xy fixnum read-only } ;
+ { xy fixnum read-only } ; final
TYPED: unboxy ( in: unboxable -- out: unboxable2 )
dup [ x>> ] [ y>> ] bi - unboxable2 boa ;
TUPLE: unboxable
{ x fixnum read-only }
{ y fixnum read-only }
- { z float read-only } ;
+ { z float read-only } ; final
""" eval( -- )
"""
[ 1 ] [ no-inputs ] unit-test
TUPLE: unboxable3
- { x read-only } ;
+ { x read-only } ; final
TYPED: no-inputs-unboxable-output ( -- out: unboxable3 )
T{ unboxable3 } ;
[ T{ unboxable3 } ] [ no-inputs-unboxable-output ] unit-test
+[ f ] [ no-inputs-unboxable-output no-inputs-unboxable-output eq? ] unit-test
+
SYMBOL: buh
TYPED: no-outputs ( x: integer -- )
buh set ;
[ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
+
+[ f ] [
+ T{ unboxable3 } no-outputs-unboxable-input buh get
+ T{ unboxable3 } no-outputs-unboxable-input buh get
+ eq?
+] unit-test
+
+! Reported by littledan
+TUPLE: superclass { x read-only } ;
+TUPLE: subclass < superclass { y read-only } ; final
+
+TYPED: unbox-fail ( a: superclass -- ? ) subclass? ;
+
+[ t ] [ subclass new unbox-fail ] unit-test
+
+! If a final class becomes non-final, typed words need to be recompiled
+TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
+
+[ f ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
+
+[ ] [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
+
+[ t ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
{
[ all-slots empty? not ]
[ immutable-tuple-class? ]
+ [ final-class? ]
} 1&& ;
! typed inputs
: input-mismatch-quot ( word types -- quot )
[ input-mismatch-error ] 2curry ;
+: depends-on-unboxing ( class -- )
+ [ dup tuple-layout depends-on-tuple-layout ]
+ [ depends-on-final ]
+ bi ;
+
: (unboxer) ( type -- quot )
dup unboxable-tuple-class? [
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
all-slots [
[ name>> reader-word 1quotation ]
[ class>> (unboxer) ] bi compose
: (unboxed-types) ( type -- types )
dup unboxable-tuple-class?
[
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
all-slots [ class>> (unboxed-types) ] map concat
]
[ 1array ] if ;
: boxer ( type -- quot )
dup unboxable-tuple-class?
[
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
[ all-slots [ class>> ] map make-boxer ]
[ [ boa ] curry ]
bi compose
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays ascii assocs colors
-classes.struct combinators io.encodings.ascii
-io.encodings.string io.encodings.utf8 kernel literals math
-namespaces sequences strings ui ui.backend ui.clipboards
-ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gestures ui.pixel-formats ui.pixel-formats.private
-ui.private x11 x11.clipboard x11.constants x11.events x11.glx
-x11.io x11.windows x11.xim x11.xlib environment command-line
-combinators.short-circuit ;
+USING: accessors alien.c-types ascii assocs classes.struct combinators
+combinators.short-circuit command-line environment io.encodings.ascii
+io.encodings.string io.encodings.utf8 kernel literals locals math
+namespaces sequences specialized-arrays.instances.alien.c-types.uchar
+strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
+ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
+x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
M: x11-ui-backend beep ( -- )
dpy get 100 XBell drop ;
+: black ( -- xcolor ) 0 0 0 0 0 0 XColor <struct-boa> ; inline
+
+M:: x11-ui-backend (grab-input) ( handle -- )
+ handle window>> :> wnd
+ dpy get :> dpy
+ dpy wnd uchar-array{ 0 0 0 0 0 0 0 0 } 8 8 XCreateBitmapFromData :> pixmap
+ dpy pixmap dup black dup 0 0 XCreatePixmapCursor :> cursor
+
+ dpy wnd 1 NoEventMask GrabModeAsync dup wnd cursor CurrentTime XGrabPointer drop
+
+ dpy cursor XFreeCursor drop
+ dpy pixmap XFreePixmap drop ;
+
+M: x11-ui-backend (ungrab-input)
+ drop dpy get CurrentTime XUngrabPointer drop ;
+
x11-ui-backend ui-backend set-global
[ "DISPLAY" os-env "ui.tools" "listener" ? ]
combinators.smart fry kernel locals math math.rectangles
math.vectors models namespaces opengl opengl.gl quotations
sequences strings ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.labels ui.gadgets.packs ui.gadgets.tracks
-ui.gadgets.worlds ui.gestures ui.pens ui.pens.image
-ui.pens.solid ui.pens.tile ;
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.theme
+ui.gadgets.tracks ui.gadgets.worlds ui.gestures ui.pens
+ui.pens.image ui.pens.solid ui.pens.tile ;
FROM: models => change-model ;
IN: ui.gadgets.buttons
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces ui.gadgets.frames
-ui.pens.image ui.gadgets.icons ui.gadgets.grids ;
+ui.pens.image ui.gadgets.icons ui.gadgets.grids ui.gadgets.theme ;
IN: ui.gadgets.corners
CONSTANT: @center { 1 1 }
: make-corners ( class name quot -- corners )
[ [ [ 3 3 ] dip new-frame { 1 1 } >>filled-cell ] dip name ] dip
- with-variable ; inline
\ No newline at end of file
+ with-variable ; inline
{ undo-action com-undo }
{ redo-action com-redo }
{ T{ key-down f f "DELETE" } delete-next-character }
- { T{ key-down f { S+ } "DELETE" } delete-next-character }
{ T{ key-down f f "BACKSPACE" } delete-previous-character }
{ T{ key-down f { S+ } "BACKSPACE" } delete-previous-character }
{ T{ key-down f { C+ } "DELETE" } delete-previous-word }
USING: accessors kernel delegate fry sequences models
combinators.short-circuit models.search models.delay calendar locals
ui.gestures ui.pens ui.pens.image ui.gadgets.editors ui.gadgets.labels
-ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.tracks
+ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.theme ui.gadgets.tracks
ui.gadgets.borders ui.gadgets.buttons ui.baseline-alignment ui.gadgets ;
IN: ui.gadgets.search-tables
M: search-table model-changed
nip field>> clear-search-field ;
-M: search-table focusable-child* field>> ;
\ No newline at end of file
+M: search-table focusable-child* field>> ;
vectors models models.range math.vectors math.functions quotations
colors colors.constants math.rectangles fry combinators ui.gestures
ui.pens ui.gadgets ui.gadgets.buttons ui.gadgets.tracks math.order
-ui.gadgets.icons ui.pens.tile ui.pens.image ;
+ui.gadgets.icons ui.gadgets.theme ui.pens.tile ui.pens.image ;
IN: ui.gadgets.sliders
TUPLE: slider < track elevator thumb saved line ;
! See http://factorcode.org/license.txt for BSD license.
USING: ui.pens ui.gadgets.tracks ui.gadgets.buttons
ui.gadgets.buttons.private ui.gadgets.books ui.gadgets.packs
-ui.gadgets.borders ui.gadgets.icons ui.gadgets ui.pens.image
-sequences models accessors kernel colors colors.constants ;
+ui.gadgets.borders ui.gadgets.icons ui.gadgets ui.gadgets.theme
+ui.pens.image sequences models accessors kernel colors
+colors.constants ;
IN: ui.gadgets.tabbed
TUPLE: tabbed-gadget < track tabs book ;
--- /dev/null
+! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
+USING: io.pathnames sequences ui.images ;
+IN: ui.gadgets.theme
+
+: theme-image ( name -- image-name )
+ "vocab:ui/gadgets/theme/" prepend-path ".tiff" append <image-name> ;
{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
HELP: window-resource
-{ $values { "resource" disposable } { "resource" disposable } }
+{ $values { "resource" disposable } }
{ $description "Marks " { $snippet "resource" } " to be destroyed with " { $link dispose } " when the window with the currently active OpenGL context (set by " { $link set-gl-context } ") is closed. " { $snippet "resource" } " is left unmodified at the top of the stack." } ;
HELP: flush-gl-context
bi*
] H{ } assoc-map-as
H{
+ { T{ key-down f { S+ } "DELETE" } [ \ cut-action send-action ] }
+ { T{ key-down f { S+ } "INSERT" } [ \ paste-action send-action ] }
+ { T{ key-down f { C+ } "INSERT" } [ \ copy-action send-action ] }
{ T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
{ T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
{ T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
M: image-pen pen-pref-dim nip image>> image-dim ;
-: theme-image ( name -- image-name )
- "vocab:ui/gadgets/theme/" prepend-path ".tiff" append <image-name> ;
\ No newline at end of file
+++ /dev/null
-unportable
--- /dev/null
+linux
+freebsd
+netbsd
+openbsd
+++ /dev/null
-unportable
+++ /dev/null
-unportable\r
$nl
"Interactors are created by calling " { $link <interactor> } "."
$nl
-"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
+"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link stream-read-quot } " generic words." } ;
ARTICLE: "ui-listener" "UI listener"
"The graphical listener adds input history and word and vocabulary completion. See " { $link "listener" } " for general information on the listener."
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.bsd.macosx ;
+USING: alien.syntax unix.ffi.bsd.macosx ;
IN: unix.utmpx.macosx
! empty
+++ /dev/null
-unportable
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.utmpx unix.bsd.netbsd accessors
-unix.utmpx system kernel unix combinators ;
+USING: alien.syntax unix unix.utmpx unix.ffi.bsd.netbsd accessors
+system kernel combinators ;
IN: unix.utmpx.netbsd
-TUPLE: netbsd-utmpx-record < utmpx-record termination exit
-sockaddr ;
-
+TUPLE: netbsd-utmpx-record < utmpx-record
+termination exit sockaddr ;
+
M: netbsd new-utmpx-record ( -- utmpx-record )
- netbsd-utmpx-record new ;
-
+ netbsd-utmpx-record new ;
+
M: netbsd utmpx>utmpx-record ( utmpx -- record )
- [ new-utmpx-record ] keep
- {
- [
- utmpx-ut_exit
- [ exit_struct-e_termination >>termination ]
- [ exit_struct-e_exit >>exit ] bi
- ]
- [ utmpx-ut_ss >>sockaddr ]
- } cleave ;
+ [ new-utmpx-record ] dip
+ [
+ ut_exit>>
+ [ e_termination>> >>termination ]
+ [ e_exit>> >>exit ] bi
+ ]
+ [ ut_ss>> >>sockaddr ] bi ;
+++ /dev/null
-unportable
--- /dev/null
+macosx
+netbsd
+++ /dev/null
-unportable
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data alien.syntax combinators
continuations io.encodings.string io.encodings.utf8 kernel
-sequences strings unix calendar system accessors unix.time
-calendar.unix vocabs.loader classes.struct ;
+sequences strings calendar system accessors unix unix.time
+unix.ffi calendar.unix vocabs.loader classes.struct ;
IN: unix.utmpx
CONSTANT: EMPTY 0
CONSTANT: SIGNATURE 10
CONSTANT: SHUTDOWN_TIME 11
+C-TYPE: utmpx
+
FUNCTION: void setutxent ( ) ;
FUNCTION: void endutxent ( ) ;
FUNCTION: utmpx* getutxent ( ) ;
-Slava Pestov
\ No newline at end of file
+Slava Pestov
+Joe Groff
\ No newline at end of file
IN: vocabs.metadata
ARTICLE: "vocabs.metadata" "Vocabulary metadata"
-"Vocabulary summaries:"
+"Vocabulary directories can contain text files with metadata:"
+{ $list
+ { { $snippet "authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } "." }
+ { { $snippet "platforms.txt" } " - a series of lines, with one operating system name per line." }
+ { { $snippet "resources.txt" } " - a series of lines, with one file glob pattern per line. Files inside the vocabulary directory whose names match any of these glob patterns will be included with the compiled application as " { $link "deploy-resources" } "." }
+ { { $snippet "summary.txt" } " - a one-line description." }
+ { { $snippet "tags.txt" } " - a series of lines, with one tag per line. Tags help classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can reuse." }
+}
+"Words for reading and writing " { $snippet "summary.txt" } ":"
{ $subsections
vocab-summary
set-vocab-summary
}
-"Vocabulary authors:"
+"Words for reading and writing " { $snippet "authors.txt" } ":"
{ $subsections
vocab-authors
set-vocab-authors
}
-"Vocabulary tags:"
+"Words for reading and writing " { $snippet "tags.txt" } ":"
{ $subsections
vocab-tags
set-vocab-tags
add-vocab-tags
}
+"Words for reading and writing " { $snippet "platforms.txt" } ":"
+{ $subsections
+ vocab-platforms
+ set-vocab-platforms
+}
+"Words for reading and writing " { $snippet "resources.txt" } ":"
+{ $subsections
+ vocab-resources
+ set-vocab-resources
+}
"Getting and setting arbitrary vocabulary metadata:"
{ $subsections
vocab-file-contents
{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
+HELP: vocab-platforms
+{ $values { "vocab" "a vocabulary specifier" } { "platforms" "a sequence of operating system symbols" } }
+{ $description "Outputs a list of operating systems supported by " { $snippet "vocab" } ", as specified by the " { $snippet "platforms.txt" } " file in the vocabulary's directory. Outputs an empty array if the file doesn't exist." }
+{ $notes "Operating system symbols are defined in the " { $vocab-link "system" } " vocabulary." } ;
+
+HELP: set-vocab-platforms
+{ $values { "platforms" "a sequence of operating system symbols" } { "vocab" "a vocabulary specifier" } }
+{ $description "Stores a list of operating systems supported by " { $snippet "vocab" } " to the " { $snippet "platforms.txt" } " file in the vocabulary's directory." }
+{ $notes "Operating system symbols are defined in the " { $vocab-link "system" } " vocabulary." } ;
+
+HELP: vocab-resources
+{ $values { "vocab" "a vocabulary specifier" } { "patterns" "a sequence of glob patterns" } }
+{ $description "Outputs a list of glob patterns matching files that will be deployed with an application that includes " { $snippet "vocab" } ", as specified by the " { $snippet "resources.txt" } " file in the vocabulary's directory. Outputs an empty array if the file doesn't exist." }
+{ $notes "The " { $vocab-link "vocabs.metadata.resources" } " vocabulary contains words that will expand the glob patterns and directory names in " { $snippet "patterns" } " and return all the matching files." } ;
+
+HELP: set-vocab-resources
+{ $values { "patterns" "a sequence of glob patterns" } { "vocab" "a vocabulary specifier" } }
+{ $description "Stores a list of glob patterns matching files that will be deployed with an application that includes " { $snippet "vocab" } " to the " { $snippet "resources.txt" } " file in the vocabulary's directory." } ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs io.encodings.utf8 io.files
-io.pathnames kernel make math.parser memoize sequences sets
-sorting summary vocabs vocabs.loader ;
+USING: accessors arrays assocs io.directories io.encodings.utf8
+io.files io.pathnames kernel make math.parser memoize sequences
+sets sorting summary vocabs vocabs.loader words system
+classes.algebra combinators.short-circuit fry continuations
+namespaces ;
IN: vocabs.metadata
+: check-vocab ( vocab -- vocab )
+ dup find-vocab-root [ no-vocab ] unless ;
+
MEMO: vocab-file-contents ( vocab name -- seq )
vocab-append-path dup
[ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
+: ?delete-file ( pathname -- ) '[ _ delete-file ] ignore-errors ;
+
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-append-path [
- utf8 set-file-lines
+ swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty
\ vocab-file-contents reset-memoized
- ] [
- "The " swap vocab-name
- " vocabulary was not loaded from the file system"
- 3append throw
- ] ?if ;
+ ] [ vocab-name no-vocab ] ?if ;
+
+: vocab-windows-icon-path ( vocab -- string )
+ vocab-dir "icon.ico" append-path ;
+
+: vocab-mac-icon-path ( vocab -- string )
+ vocab-dir "icon.icns" append-path ;
+
+: vocab-resources-path ( vocab -- string )
+ vocab-dir "resources.txt" append-path ;
+
+: vocab-resources ( vocab -- patterns )
+ dup vocab-resources-path vocab-file-contents harvest ;
+
+: set-vocab-resources ( patterns vocab -- )
+ dup vocab-resources-path set-vocab-file-contents ;
: vocab-summary-path ( vocab -- string )
vocab-dir "summary.txt" append-path ;
: add-vocab-tags ( tags vocab -- )
[ vocab-tags append prune ] keep set-vocab-tags ;
+: remove-vocab-tags ( tags vocab -- )
+ [ vocab-tags swap diff ] keep set-vocab-tags ;
+
: vocab-authors-path ( vocab -- string )
vocab-dir "authors.txt" append-path ;
: set-vocab-authors ( authors vocab -- )
dup vocab-authors-path set-vocab-file-contents ;
+: vocab-platforms-path ( vocab -- string )
+ vocab-dir "platforms.txt" append-path ;
+
+ERROR: bad-platform name ;
+
+: vocab-platforms ( vocab -- platforms )
+ dup vocab-platforms-path vocab-file-contents
+ [ dup "system" lookup [ ] [ bad-platform ] ?if ] map ;
+
+: set-vocab-platforms ( platforms vocab -- )
+ [ [ name>> ] map ] dip
+ dup vocab-platforms-path set-vocab-file-contents ;
+
+: supported-platform? ( platforms -- ? )
+ [ t ] [ [ os swap class<= ] any? ] if-empty ;
+
: unportable? ( vocab -- ? )
- vocab-tags "unportable" swap member? ;
\ No newline at end of file
+ {
+ [ vocab-tags "untested" swap member? ]
+ [ vocab-platforms supported-platform? not ]
+ } 1|| ;
+
+TUPLE: unsupported-platform vocab requires ;
+
+: unsupported-platform ( vocab requires -- )
+ \ unsupported-platform boa throw-continue ;
+
+M: unsupported-platform summary
+ drop "Current operating system not supported by this vocabulary" ;
+
+[
+ dup vocab-platforms dup supported-platform?
+ [ 2drop ] [ [ vocab-name ] dip unsupported-platform ] if
+] check-vocab-hook set-global
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: help.markup help.syntax kernel ;
+IN: vocabs.metadata.resources
+
+HELP: expand-vocab-resource-files
+{ $values
+ { "vocab" "a vocabulary specifier" } { "resource-glob-strings" "a sequence of glob patterns" }
+ { "filenames" "a sequence of filenames" }
+}
+{ $description "Matches all the glob patterns in " { $snippet "resource-glob-strings" } " to the set of files inside " { $snippet "vocab" } "'s directory and outputs a sequence containing the individual files and directories that match. Any matching directories will also have their contents recursively included in the output. The paths in the output will be relative to " { $snippet "vocab" } "'s directory." } ;
+
+HELP: vocab-resource-files
+{ $values
+ { "vocab" "a vocabulary specifier" }
+ { "filenames" "a sequence of filenames" }
+}
+{ $description "Outputs a sequence containing the individual resource files and directories that match the patterns specified in " { $snippet "vocab" } "'s " { $snippet "resources.txt" } " file. Any matching directories will also have their contents recursively included in the output. The paths in the output will be relative to " { $snippet "vocab" } "'s directory." } ;
+
+ARTICLE: "vocabs.metadata.resources" "Vocabulary resource metadata"
+"The " { $vocab-link "vocabs.metadata.resources" } " vocabulary contains words to retrieve the full list of files that match the patterns specified in a vocabulary's " { $snippet "resources.txt" } " file."
+{ $subsections
+ vocab-resource-files
+ expand-vocab-resource-files
+} ;
+
+ABOUT: "vocabs.metadata.resources"
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: sorting tools.test vocabs.metadata.resources ;
+IN: vocabs.metadata.resources.tests
+
+[ { "bar" "bas" "foo" } ]
+[ "vocabs.metadata.resources.test.1" vocab-resource-files natural-sort ] unit-test
+
+[ { "bar.wtf" "foo.wtf" } ]
+[ "vocabs.metadata.resources.test.2" vocab-resource-files natural-sort ] unit-test
+
+[ {
+ "resource-dir"
+ "resource-dir/bar"
+ "resource-dir/bas"
+ "resource-dir/bas/zang"
+ "resource-dir/bas/zim"
+ "resource-dir/foo"
+} ] [ "vocabs.metadata.resources.test.3" vocab-resource-files natural-sort ] unit-test
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: arrays fry globs io.directories io.files.info
+io.pathnames kernel regexp sequences vocabs.loader
+vocabs.metadata ;
+IN: vocabs.metadata.resources
+
+<PRIVATE
+
+: (expand-vocab-resource) ( resource-path -- filenames )
+ dup file-info directory?
+ [ dup '[ _ directory-tree-files [ append-path ] with map ] [ prefix ] bi ]
+ [ 1array ] if ;
+
+: filter-resources ( vocab-files resource-globs -- resource-files )
+ '[ _ [ matches? ] with any? ] filter ;
+
+: copy-vocab-resource ( to from file -- )
+ [ append-path ] curry bi@
+ dup file-info directory?
+ [ drop make-directories ]
+ [ swap [ parent-directory make-directories ] [ copy-file ] bi ] if ;
+
+PRIVATE>
+
+: vocab-dir-in-root ( vocab -- dir )
+ [ find-vocab-root ] [ vocab-dir ] bi append-path ;
+
+: expand-vocab-resource-files ( vocab resource-glob-strings -- filenames )
+ [ vocab-dir-in-root ] dip [ <glob> ] map '[
+ _ filter-resources
+ [ (expand-vocab-resource) ] map concat
+ ] with-directory-tree-files ;
+
+: vocab-resource-files ( vocab -- filenames )
+ dup vocab-resources
+ [ drop f ] [ expand-vocab-resource-files ] if-empty ;
+
+: copy-vocab-resources ( dir vocab -- )
+ dup vocab-resource-files
+ [ 2drop ] [
+ [ [ vocab-dir append-path ] [ vocab-dir-in-root ] bi ] dip
+ [ 2drop make-directories ]
+ [ [ copy-vocab-resource ] with with each ] 3bi
+ ] if-empty ;
+
--- /dev/null
+USING: io kernel ;
+IN: vocabs.metadata.resources.test.1
+
+: main ( -- ) "Resources test 1" print ;
+
+MAIN: main
--- /dev/null
+foo
+bar
+bas
--- /dev/null
+USING: io kernel ;
+IN: vocabs.metadata.resources.test.2
+
+: main ( -- ) "Resources test 2" print ;
+
+MAIN: main
--- /dev/null
+USING: io kernel ;
+IN: vocabs.metadata.resources.test.3
+
+: main ( -- ) "Resources test 3" print ;
+
+MAIN: main
--- /dev/null
+resource-dir
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: windows.com windows.kernel32 windows.ole32
-prettyprint.custom prettyprint.sections sequences ;
+USING: windows.kernel32 windows.ole32 prettyprint.custom
+prettyprint.sections sequences ;
IN: windows.com.prettyprint
M: GUID pprint* guid>string "GUID: " prepend text ;
+++ /dev/null
-unportable
: (parse-com-function) ( tokens -- definition )
[ second ]
- [ first ]
+ [ first parse-c-type ]
[
3 tail [ CHAR: , swap remove ] map
2 group [ first2 normalize-c-arg 2array ] map
-unportable
bindings
+ffi
CONSTANT: D3DMULTISAMPLE_15_SAMPLES 15
CONSTANT: D3DMULTISAMPLE_16_SAMPLES 16
CONSTANT: D3DMULTISAMPLE_FORCE_DWORD HEX: 7fffffff
-
-:: MAKEFOURCC ( ch0 ch1 ch2 ch3 -- n )
- ch3 HEX: ff bitand 24 shift
- ch2 HEX: ff bitand 16 shift
- ch1 HEX: ff bitand 8 shift
- ch0 HEX: ff bitand bitor bitor bitor ; inline
TYPEDEF: int D3DFORMAT
CONSTANT: D3DFMT_UNKNOWN 0
CONSTANT: D3DFMT_Q8W8V8U8 63
CONSTANT: D3DFMT_V16U16 64
CONSTANT: D3DFMT_A2W10V10U10 67
-#! : D3DFMT_UYVY ( -- n ) 'U' 'Y' 'V' 'Y' MAKEFOURCC
-#! D3DFMT_R8G8_B8G8 = MAKEFOURCC('R', 'G', 'B', 'G'),
-#! D3DFMT_YUY2 = MAKEFOURCC('Y', 'U', 'Y', '2'),
-#! D3DFMT_G8R8_G8B8 = MAKEFOURCC('G', 'R', 'G', 'B'),
-#! D3DFMT_DXT1 = MAKEFOURCC('D', 'X', 'T', '1'),
-#! D3DFMT_DXT2 = MAKEFOURCC('D', 'X', 'T', '2'),
-#! D3DFMT_DXT3 = MAKEFOURCC('D', 'X', 'T', '3'),
-#! D3DFMT_DXT4 = MAKEFOURCC('D', 'X', 'T', '4'),
-#! D3DFMT_DXT5 = MAKEFOURCC('D', 'X', 'T', '5'),
+CONSTANT: D3DFMT_UYVY HEX: 55595659
+CONSTANT: D3DFMT_R8G8_B8G8 HEX: 52474247
+CONSTANT: D3DFMT_YUY2 HEX: 59555932
+CONSTANT: D3DFMT_G8R8_G8B8 HEX: 47524742
+CONSTANT: D3DFMT_DXT1 HEX: 44585431
+CONSTANT: D3DFMT_DXT2 HEX: 44585432
+CONSTANT: D3DFMT_DXT3 HEX: 44585433
+CONSTANT: D3DFMT_DXT4 HEX: 44585434
+CONSTANT: D3DFMT_DXT5 HEX: 44585435
CONSTANT: D3DFMT_D16_LOCKABLE 70
CONSTANT: D3DFMT_D32 71
CONSTANT: D3DFMT_D15S1 73
CONSTANT: D3DFMT_INDEX16 101
CONSTANT: D3DFMT_INDEX32 102
CONSTANT: D3DFMT_Q16W16V16U16 110
-#! D3DFMT_MULTI2_ARGB8 = MAKEFOURCC('M', 'E', 'T', '1'),
+CONSTANT: D3DFMT_MULTI2_ARGB8 HEX: 4d455431
CONSTANT: D3DFMT_R16F 111
CONSTANT: D3DFMT_G16R16F 112
CONSTANT: D3DFMT_A16B16G16R16F 113
+++ /dev/null
-unportable
+++ /dev/null
-USING: alien.strings io.encodings.utf16n windows.com\r
-windows.com.wrapper combinators windows.kernel32 windows.ole32\r
-windows.shell32 kernel accessors windows.types\r
-prettyprint namespaces ui.tools.listener ui.tools.workspace\r
-alien.data alien sequences math classes.struct ;\r
-SPECIALIZED-ARRAY: WCHAR\r
-IN: windows.dragdrop-listener\r
-\r
-: filenames-from-hdrop ( hdrop -- filenames )\r
- dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
- [\r
- 2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
- dup WCHAR <c-array>\r
- [ swap DragQueryFile drop ] keep\r
- utf16n alien>string\r
- ] with map ;\r
-\r
-: filenames-from-data-object ( data-object -- filenames )\r
- FORMATETC <struct>\r
- CF_HDROP >>cfFormat\r
- f >>ptd\r
- DVASPECT_CONTENT >>dwAspect\r
- -1 >>lindex\r
- TYMED_HGLOBAL >>tymed\r
- STGMEDIUM <struct>\r
- [ IDataObject::GetData ] keep swap succeeded? [\r
- dup data>>\r
- [ filenames-from-hdrop ] with-global-lock\r
- swap ReleaseStgMedium\r
- ] [ drop f ] if ;\r
-\r
-TUPLE: listener-dragdrop hWnd last-drop-effect ;\r
-\r
-: <listener-dragdrop> ( hWnd -- object )\r
- DROPEFFECT_NONE listener-dragdrop construct-boa ;\r
-\r
-SYMBOL: +listener-dragdrop-wrapper+\r
-{\r
- { "IDropTarget" {\r
- [ ! DragEnter\r
- [\r
- 2drop\r
- filenames-from-data-object\r
- length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if\r
- dup 0\r
- ] dip set-ulong-nth\r
- >>last-drop-effect drop\r
- S_OK\r
- ] [ ! DragOver\r
- [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth\r
- S_OK\r
- ] [ ! DragLeave\r
- drop S_OK\r
- ] [ ! Drop\r
- [\r
- 2drop nip\r
- filenames-from-data-object\r
- dup length 1 = [\r
- first unparse [ "USE: parser " % % " run-file" % ] "" make\r
- eval-listener\r
- DROPEFFECT_COPY\r
- ] [ 2drop DROPEFFECT_NONE ] if\r
- 0\r
- ] dip set-ulong-nth\r
- S_OK\r
- ]\r
- } }\r
-} <com-wrapper> +listener-dragdrop-wrapper+ set-global\r
-\r
-: dragdrop-listener-window ( -- )\r
- get-workspace parent>> handle>> hWnd>>\r
- dup <listener-dragdrop>\r
- +listener-dragdrop-wrapper+ get-global com-wrap\r
- [ RegisterDragDrop ole32-error ] with-com-interface ;\r
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel windows.types
-multiline classes.struct ;
+math multiline classes.struct ;
IN: windows.kernel32
CONSTANT: MAX_PATH 260
CONSTANT: FILE_ACTION_RENAMED_OLD_NAME 4
CONSTANT: FILE_ACTION_RENAMED_NEW_NAME 5
+CONSTANT: DONT_RESOLVE_DLL_REFERENCES 1
+
STRUCT: FILE_NOTIFY_INFORMATION
{ NextEntryOffset DWORD }
{ Action DWORD }
CONSTANT: STATUS_FLOAT_MULTIPLE_FAULTS HEX: C00002B4
CONSTANT: STATUS_FLOAT_MULTIPLE_TRAPS HEX: C00002B5
+! Resource IDs
+: MAKEINTRESOURCE ( int -- resource ) HEX: ffff bitand <alien> ; inline
+
+: RT_CURSOR ( -- id ) 1 MAKEINTRESOURCE ; inline
+: RT_BITMAP ( -- id ) 2 MAKEINTRESOURCE ; inline
+: RT_ICON ( -- id ) 3 MAKEINTRESOURCE ; inline
+: RT_MENU ( -- id ) 4 MAKEINTRESOURCE ; inline
+: RT_DIALOG ( -- id ) 5 MAKEINTRESOURCE ; inline
+: RT_STRING ( -- id ) 6 MAKEINTRESOURCE ; inline
+: RT_FONTDIR ( -- id ) 7 MAKEINTRESOURCE ; inline
+: RT_FONT ( -- id ) 8 MAKEINTRESOURCE ; inline
+: RT_ACCELERATOR ( -- id ) 9 MAKEINTRESOURCE ; inline
+: RT_RCDATA ( -- id ) 10 MAKEINTRESOURCE ; inline
+: RT_MESSAGETABLE ( -- id ) 11 MAKEINTRESOURCE ; inline
+: RT_GROUP_CURSOR ( -- id ) 12 MAKEINTRESOURCE ; inline
+: RT_GROUP_ICON ( -- id ) 14 MAKEINTRESOURCE ; inline
+: RT_VERSION ( -- id ) 16 MAKEINTRESOURCE ; inline
+: RT_DLGINCLUDE ( -- id ) 17 MAKEINTRESOURCE ; inline
+: RT_PLUGPLAY ( -- id ) 19 MAKEINTRESOURCE ; inline
+: RT_VXD ( -- id ) 20 MAKEINTRESOURCE ; inline
+: RT_ANICURSOR ( -- id ) 21 MAKEINTRESOURCE ; inline
+: RT_ANIICON ( -- id ) 22 MAKEINTRESOURCE ; inline
+: RT_MANIFEST ( -- id ) 24 MAKEINTRESOURCE ; inline
+
LIBRARY: kernel32
! FUNCTION: _hread
! FUNCTION: _hwrite
! FUNCTION: BaseUpdateAppcompatCache
! FUNCTION: Beep
! FUNCTION: BeginUpdateResourceA
-! FUNCTION: BeginUpdateResourceW
+FUNCTION: HANDLE BeginUpdateResourceW ( LPCTSTR pFileName, BOOL bDeleteExistingResources ) ;
+ALIAS: BeginUpdateResource BeginUpdateResourceW
! FUNCTION: BindIoCompletionCallback
! FUNCTION: BuildCommDCBA
! FUNCTION: BuildCommDCBAndTimeoutsA
! FUNCTION: EncodePointer
! FUNCTION: EncodeSystemPointer
! FUNCTION: EndUpdateResourceA
-! FUNCTION: EndUpdateResourceW
+FUNCTION: BOOL EndUpdateResourceW ( HANDLE hUpdate, BOOL fDiscard ) ;
+ALIAS: EndUpdateResource EndUpdateResourceW
! FUNCTION: EnterCriticalSection
! FUNCTION: EnumCalendarInfoA
! FUNCTION: EnumCalendarInfoExA
! FUNCTION: FreeEnvironmentStringsA
FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ;
ALIAS: FreeEnvironmentStrings FreeEnvironmentStringsW
-! FUNCTION: FreeLibrary
+FUNCTION: BOOL FreeLibrary ( HMODULE hModule ) ;
! FUNCTION: FreeLibraryAndExitThread
! FUNCTION: FreeResource
! FUNCTION: FreeUserPhysicalPages
! FUNCTION: GetLongPathNameW
! FUNCTION: GetMailslotInfo
! FUNCTION: GetModuleFileNameA
-! FUNCTION: GetModuleFileNameW
+FUNCTION: DWORD GetModuleFileNameW ( HMODULE hModule, LPTSTR lpFilename, DWORD nSize ) ;
+ALIAS: GetModuleFileName GetModuleFileNameW
FUNCTION: HMODULE GetModuleHandleW ( LPCWSTR lpModuleName ) ;
ALIAS: GetModuleHandle GetModuleHandleW
! FUNCTION: GetModuleHandleExA
! FUNCTION: UnregisterWait
! FUNCTION: UnregisterWaitEx
! FUNCTION: UpdateResourceA
-! FUNCTION: UpdateResourceW
+FUNCTION: BOOL UpdateResourceW ( HANDLE hUpdate, LPCTSTR lpType, LPCTSTR lpName, WORD wLanguage, LPVOID lpData, DWORD cbData ) ;
+ALIAS: UpdateResource UpdateResourceW
! FUNCTION: UTRegister
! FUNCTION: UTUnRegister
! FUNCTION: ValidateLCType
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable\r
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable\r
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
+! 5.2 - Creating, Recoloring, and Freeing Cursors
+
+C-TYPE: XColor
+X-FUNCTION: Cursor XCreatePixmapCursor ( Display* display, Pixmap source, Pixmap mask, XColor* foreground_color, XColor* background_color, uint x, uint y ) ;
+X-FUNCTION: int XFreeCursor ( Display* display, Cursor cursor ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 6 - Color Management Functions
X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
+X-FUNCTION: int XGrabKeyboard ( Display* display, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode, Time time ) ;
X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
X-FUNCTION: Status XGetInputFocus ( Display* display,
{ colormap_size int }
{ bits_per_rgb int } ;
+! 16.9 Manipulating Bitmaps
+X-FUNCTION: Pixmap XCreateBitmapFromData (
+ Display* display,
+ Drawable d,
+ char* data,
+ uint width,
+ uint height ) ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Appendix D - Compatibility Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: post-rpc
{ $values { "rpc" "an XML-RPC input tuple" } { "url" "a URL" }
- { "rpc" "an XML-RPC output tuple" } }
+ { "rpc'" "an XML-RPC output tuple" } }
{ $description "posts an XML-RPC document to the specified URL, receives the response and parses it as XML-RPC, returning the tuple" } ;
ARTICLE: { "xml-rpc" "intro" } "XML-RPC"
PRIVATE>
-: post-rpc ( rpc url -- rpc )
+: post-rpc ( rpc url -- rpc' )
! This needs to do something in the event of an error
rpc-post-request http-request nip string>xml receive-rpc ;
{ $see-also first-child-tag } ;
HELP: first-child-tag
-{ $values { "tag" "an XML tag or document" } { "tag" tag } }
+{ $values { "tag" "an XML tag or document" } { "child" tag } }
{ $description "Returns the first child of the given tag that is a tag." }
{ $see-also children-tags } ;
: children-tags ( tag -- sequence )
children>> [ tag? ] filter ;
-: first-child-tag ( tag -- tag )
+: first-child-tag ( tag -- child )
children>> [ tag? ] find nip ;
: tag-named? ( name elem -- ? )
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel kernel.private accessors math
alien.accessors byte-arrays io io.encodings io.encodings.utf8
M: tuple string>alien drop underlying>> ;
-HOOK: alien>native-string os ( alien -- string )
+HOOK: native-string-encoding os ( -- encoding ) foldable
-M: windows alien>native-string utf16n alien>string ;
+M: unix native-string-encoding utf8 ;
+M: windows native-string-encoding utf16n ;
-M: unix alien>native-string utf8 alien>string ;
+: alien>native-string ( alien -- string )
+ native-string-encoding alien>string ; inline
-HOOK: native-string>alien os ( string -- alien )
-
-M: windows native-string>alien utf16n string>alien ;
-
-M: unix native-string>alien utf8 string>alien ;
+: native-string>alien ( string -- alien )
+ native-string-encoding string>alien ; inline
: dll-path ( dll -- string )
path>> alien>native-string ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
M: array resize resize-array ; inline
-
-: >array ( seq -- array ) { } clone-like ;
-
+M: array equal? over array? [ sequence= ] [ 2drop f ] if ;
M: object new-sequence drop 0 <array> ; inline
-
M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
-M: array equal?
- over array? [ sequence= ] [ 2drop f ] if ;
-
INSTANCE: array sequence
+: >array ( seq -- array ) { } clone-like ;
: 1array ( x -- array ) 1 swap <array> ; inline
-
: 2array ( x y -- array ) { } 2sequence ; inline
-
: 3array ( x y z -- array ) { } 3sequence ; inline
-
: 4array ( w x y z -- array ) { } 4sequence ; inline
PREDICATE: pair < array length 2 number= ;
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences
-sequences.private namespaces math quotations assocs.private ;
+sequences.private namespaces math quotations assocs.private
+sets ;
IN: assocs
ARTICLE: "alists" "Association lists"
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
+$nl
+"Set-theoretic operations:"
{ $subsections
assoc-subset?
assoc-intersect
substitute
extract-keys
}
+"Adding elements to sets:"
+{ $subsections
+ conjoin
+ conjoin-at
+}
"Destructive operations:"
{ $subsections
assoc-union!
HELP: assoc-like
{ $values { "assoc" assoc } { "exemplar" assoc } { "newassoc" "a new assoc" } }
-{ $contract "Creates a new assoc having the same entries as "{ $snippet "assoc" } " and the same type as " { $snippet "exemplar" } "." } ;
+{ $contract "Creates a new assoc having the same entries as " { $snippet "assoc" } " and the same type as " { $snippet "exemplar" } "." } ;
HELP: assoc-empty?
{ $values { "assoc" assoc } { "?" "a boolean" } }
{ $side-effects "assoc" } ;
HELP: 2cache
-{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
+{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key1 key2 -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If a single key composed of the input keys is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the keys/value pair into the assoc. Returns the value stored in the assoc. Returns a value either looked up or newly stored in the assoc." }
{ $side-effects "assoc" } ;
HELP: assoc-map-as
{ $values
- { "assoc" assoc } { "quot" quotation } { "exemplar" assoc }
+ { "assoc" assoc } { "quot" { $quotation "( key value -- newkey newvalue )" } } { "exemplar" assoc }
{ "newassoc" assoc } }
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." }
{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
"SYMBOLS:"
"CONSTANT:"
"TUPLE:"
+ "final"
"SLOT:"
"T{"
"UNION:"
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
+
+SYMBOL: +incomparable+
+
+: compare-classes ( class1 class2 -- ? )
+ {
+ { [ 2dup class<= ] [ t ] }
+ { [ 2dup classes-intersect? not ] [ f ] }
+ [ +incomparable+ ]
+ } cond 2nip ;
[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test
+
+GENERIC: generic-predicate? ( a -- b )
+
+[ ] [ "IN: classes.tests TUPLE: generic-predicate ;" eval( -- ) ] unit-test
+
+[ f ] [ \ generic-predicate? generic? ] unit-test
: classes ( -- seq ) implementors-map get keys ;
+PREDICATE: predicate < word "predicating" word-prop >boolean ;
+
: create-predicate-word ( word -- predicate )
- [ name>> "?" append ] [ vocabulary>> ] bi create ;
+ [ name>> "?" append ] [ vocabulary>> ] bi create
+ dup predicate? [ dup reset-generic ] unless ;
: predicate-word ( word -- predicate )
"predicate" word-prop first ;
-PREDICATE: predicate < word "predicating" word-prop >boolean ;
-
M: predicate flushable? drop t ;
M: predicate forget*
: create-class-in ( string -- word )
current-vocab create
+ dup set-word
dup save-class-location
- dup create-predicate-word dup set-word save-location ;
+ dup create-predicate-word save-location ;
: CREATE-CLASS ( -- word )
scan create-class-in ;
"tuple-inheritance-example"
"tuple-inheritance-anti-example"
}
+"Declaring a tuple class final prohibits other classes from subclassing it:"
+{ $subsections POSTPONE: final }
{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
{ $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" } ")." } ;
+
+HELP: bad-superclass
+{ $error-description "Thrown if an attempt is made to subclass a class that is not a tuple class, or a tuple class declared " { $link POSTPONE: final } "." } ;
] unit-test
[ 31337 ] [ factor-crashes-anymore ] unit-test
+
+TUPLE: tuple-predicate-redefine-test ;
+
+[ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
+
+[ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test
+
+! Final classes
+TUPLE: final-superclass ;
+TUPLE: final-subclass < final-superclass ;
+
+[ final-superclass ] [ final-subclass superclass ] unit-test
+
+! Making the superclass final should change the superclass of the subclass
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
+
+[ tuple ] [ final-subclass superclass ] unit-test
+
+[ f ] [ \ final-subclass final-class? ] unit-test
+
+! Subclassing a final class should fail
+[ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ]
+[ error>> bad-superclass? ] must-fail-with
+
+! Making a final class non-final should work
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
+
+! Changing a superclass should not change the final status of a subclass
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
+
+[ t ] [ \ final-subclass final-class? ] unit-test
] [ 2drop f ] if
] [ 2drop f ] if ; inline
+GENERIC: final-class? ( class -- ? )
+
+M: tuple-class final-class? "final" word-prop ;
+
+M: builtin-class final-class? tuple eq? not ;
+
+M: class final-class? drop t ;
+
<PRIVATE
: tuple-predicate-quot/1 ( class -- quot )
[ [ "slots" word-prop ] dip = ]
bi-curry* bi and ;
-GENERIC: valid-superclass? ( class -- ? )
-
-M: tuple-class valid-superclass? drop t ;
-
-M: builtin-class valid-superclass? tuple eq? ;
-
-M: class valid-superclass? drop f ;
-
: check-superclass ( superclass -- )
- dup valid-superclass? [ bad-superclass ] unless drop ;
+ dup final-class? [ bad-superclass ] when drop ;
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
read-only suffix
] map ;
+: reset-final ( class -- )
+ dup final-class? [
+ [ f "final" set-word-prop ]
+ [ changed-conditionally ]
+ bi
+ ] [ drop ] if ;
+
PRIVATE>
: define-tuple-class ( class superclass slots -- )
over prepare-slots
(define-tuple-class) ;
+GENERIC: make-final ( class -- )
+
+M: tuple-class make-final
+ [ dup class-usage keys ?metaclass-changed ]
+ [ t "final" set-word-prop ]
+ bi ;
+
M: word (define-tuple-class)
define-new-tuple-class ;
M: tuple-class (define-tuple-class)
+ pick reset-final
3dup tuple-class-unchanged?
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
] with each
] [
[ call-next-method ]
- [ { "layout" "slots" "boa-check" "prototype" } reset-props ]
+ [ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ]
bi
] bi ;
{ $subsections "conditionals-boolean-equivalence" }
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
-ARTICLE: "dataflow-combinators" "Data flow combinators"
-"Data flow combinators express common dataflow patterns such as performing a operation while preserving its inputs, applying multiple operations to a single value, applying a set of operations to a set of values, or applying a single operation to multiple values."
+ARTICLE: "dataflow-combinators" "Dataflow combinators"
+"Dataflow combinators express common dataflow patterns such as performing a operation while preserving its inputs, applying multiple operations to a single value, applying a set of operations to a set of values, or applying a single operation to multiple values."
{ $subsections
"dip-keep-combinators"
"cleave-combinators"
"spread-combinators"
"apply-combinators"
}
-"More intricate data flow can be constructed by composing " { $link "curried-dataflow" } "." ;
+"More intricate dataflow can be constructed by composing " { $link "curried-dataflow" } "." ;
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
hashtables sorting words sets math.order make ;
IN: combinators
+! Most of these combinators have compile-time expansions in
+! the optimizing compiler. See stack-checker.transforms and
+! compiler.tree.propagation.call-effect
+
<PRIVATE
: call-effect-unsafe ( quot effect -- ) drop call ;
PRIVATE>
-ERROR: wrong-values quot effect ;
+ERROR: wrong-values quot call-site ;
! We can't USE: effects here so we forward reference slots instead
SLOT: in
TUPLE: redefine-error def ;
: redefine-error ( definition -- )
- \ redefine-error boa
- { { "Continue" t } } throw-restarts drop ;
+ \ redefine-error boa throw-continue ;
<PRIVATE
throw-restarts
rethrow-restarts
}
+"A utility word using the above:"
+{ $subsections
+ throw-continue
+}
"The list of restarts from the most recently-thrown error is stored in a global variable:"
{ $subsections restarts }
-"To invoke restarts, see " { $link "debugger" } "." ;
+"To invoke restarts, use " { $link "debugger" } "." ;
ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;
-{ throw rethrow throw-restarts rethrow-restarts } related-words
+{ throw rethrow throw-restarts rethrow-restarts throw-continue } related-words
+
+HELP: throw-continue
+{ $values { "error" object } }
+{ $description "Throws a resumable error. If the user elects to continue execution, this word returns normally." } ;
HELP: compute-restarts
{ $values { "error" object } { "seq" "a sequence" } }
: rethrow-restarts ( error restarts -- restart )
[ <condition> rethrow ] callcc1 2nip ;
+: throw-continue ( error -- )
+ { { "Continue" t } } throw-restarts drop ;
+
TUPLE: restart name obj continuation ;
C: <restart> restart
HELP: (call-next-method)
{ $values { "method" method } }
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
-{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
+{ $notes
+ "The " { $link POSTPONE: call-next-method } " word parses into this word. The following are equivalent:"
+ { $code
+ "M: class generic call-next-method ;"
+ "M: class generic M\\ class generic (call-next-method) ;"
+ }
+} ;
HELP: no-next-method
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
{ $description "Prepends the " { $link current-directory } " to the pathname, resolves a " { $snippet "resource:" } " or " { $snippet "vocab:" } " prefix, if present (see " { $link "io.pathnames.special" } "). Also converts the path into a UNC path on Windows." }
{ $notes "High-level words, such as " { $link <file-reader> } " and " { $link delete-file } " call this word for you. It only needs to be called directly when passing pathnames to C functions or external processes. This is because Factor does not use the operating system's notion of a current directory, and instead maintains its own dynamically-scoped " { $link current-directory } " variable." }
-{ $notes "On Windows NT platforms, this word does prepends the Unicode path prefix." }
+{ $notes "On Windows NT platforms, this word prepends the Unicode path prefix." }
{ $examples
"For example, if you create a file named " { $snippet "data.txt" } " in the current directory, and wish to pass it to a process, you must normalize it:"
{ $code
{ $notes "This operation is efficient and does not copy the quotation." } ;
HELP: with
-{ $values { "param" object } { "obj" object } { "quot" { $quotation "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
+{ $values { "param" object } { "obj" object } { "quot" { $quotation "( param elt -- ... )" } } { "curry" curry } }
{ $description "Partial application on the left. The following two lines are equivalent:"
{ $code "swap [ swap A ] curry B" }
{ $code "[ A ] with B" }
HELP: make
{ $values { "quot" quotation } { "exemplar" sequence } { "seq" "a new sequence" } }
-{ $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." }
+{ $description "Calls the quotation in a new dynamic scope with the " { $link building } " variable bound to a new resizable mutable sequence. The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." }
{ $examples { $example "USING: make prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ;
HELP: ,
HELP: rem
{ $values { "x" rational } { "y" rational } { "z" rational } }
{ $description
- "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive."
+ "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive or zero."
{ $list
"Given fixnums, always yields a fixnum."
"Given bignums, always yields a bignum."
{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-base
-{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } { "parsed" integer } }
+{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } }
{ $description "Reads an integer in a specific numerical base from the parser input." }
$parsing-note ;
] unit-test
[ t ] [
- "foo?" "parser.tests" lookup word eq?
+ "foo" "parser.tests" lookup word eq?
] unit-test
[ ] [
HELP: reduce-index
{ $values
- { "seq" sequence } { "identity" object } { "quot" quotation } }
+ { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt index -- result )" } } }
{ $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!
-{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "seq" sequence } }
+{ $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: each-index
{ $values
- { "seq" sequence } { "quot" quotation } }
+ { "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: sequences prettyprint math ;"
-"{ 10 20 30 } [ + . ] each-index"
-"10\n21\n32"
+{ $examples { $example "USING: arrays sequences prettyprint ;"
+"{ 10 20 30 } [ 2array . ] each-index"
+"{ 10 0 }\n{ 20 1 }\n{ 30 2 }"
} } ;
HELP: map-index
{ $values
- { "seq" sequence } { "quot" quotation } { "newseq" sequence } }
+ { "seq" sequence } { "quot" { $quotation "( elt index -- result )" } } { "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: sequences prettyprint math ;"
-"{ 10 20 30 } [ + ] map-index ."
-"{ 10 21 32 }"
+{ $examples { $example "USING: arrays sequences prettyprint ;"
+"{ 10 20 30 } [ 2array ] map-index ."
+"{ { 10 0 } { 20 1 } { 30 2 } }"
} } ;
HELP: change-nth
{ $side-effects "seq" } ;
HELP: map!
-{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } { "seq" "a mutable sequence" } }
+{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } }
{ $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 "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 -- ? )" } } { "seq" "a resizable mutable sequence" } }
+{ $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" } ;
{ $side-effects "seq" } ;
HELP: remove!
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } { "elt" object } }
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } " and returns " { $snippet "seq" } "." }
{ $notes "This word uses equality comparison (" { $link = } ")." }
{ $side-effects "seq" } ;
HELP: remove-eq!
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } { "seq" "a resizable mutable sequence" } }
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except the given element." }
{ $notes "This word uses identity comparison (" { $link eq? } ")." }
{ $side-effects "seq" } ;
HELP: remove-nth!
-{ $values { "n" "a non-negative integer" } { "seq" "a resizable mutable sequence" } { "seq" "a resizable mutable sequence" } }
+{ $values { "n" "a non-negative integer" } { "seq" "a resizable mutable sequence" } }
{ $description "Removes the " { $snippet "n" } "th element from the sequence, shifting all other elements down and reducing its length by one." }
{ $side-effects "seq" } ;
} ;
HELP: suffix!
-{ $values { "seq" sequence } { "elt" object } { "seq" sequence } }
+{ $values { "seq" sequence } { "elt" object } }
{ $description "Modifiers a sequence in-place by adding " { $snippet "elt" } " to the end of " { $snippet "seq" } ". Outputs " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq" } "." }
{ $examples
} ;
HELP: append!
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq1" sequence } }
+{ $values { "seq1" sequence } { "seq2" sequence } }
{ $description "Modifiers " { $snippet "seq1" } " in-place by adding the elements from " { $snippet "seq2" } " to the end and outputs " { $snippet "seq1" } "." }
{ $examples
{ $example "USING: prettyprint sequences ;" "V{ 1 2 3 } { 4 5 6 } append! ." "V{ 1 2 3 4 5 6 }" }
HELP: selector
{ $values
- { "quot" "a predicate quotation" }
- { "quot" quotation } { "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-as
{ $values
- { "len" integer } { "quot" quotation } { "exemplar" sequence }
+ { "len" integer } { "quot" { $quotation "( -- elt )" } } { "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 } { "reduce-quot" quotation }
+ { "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation "( elt1 elt2 -- intermediate )" } } { "reduce-quot" { $quotation "( prev intermediate -- result )" } }
{ "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: 2selector
{ $values
{ "quot" quotation }
- { "quot" quotation } { "accum1" vector } { "accum2" vector } }
+ { "selector" quotation } { "accum1" vector } { "accum2" vector } }
{ $description "Creates two new vectors to accumultate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
HELP: 2reverse-each
HELP: binary-reduce
{ $values
- { "seq" sequence } { "start" integer } { "quot" quotation }
+ { "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 }
+ { "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: short
{ $values
- { "seq" sequence } { "n" integer }
- { "seq" sequence } { "n'" integer } }
+ { "seq" sequence } { "n" integer } { "n'" integer } }
{ $description "Returns the input sequence and its length or " { $snippet "n" } ", whichever is less." }
{ $examples { $example "USING: sequences kernel prettyprint ;"
"\"abcd\" 3 short [ . ] bi@"
ARTICLE: "sequences-integers" "Counted loops"
"A virtual sequence is defined for iterating over integers from zero."
{ $subsection iota }
-"For example, calling " { $link iota } " on the integer 3 produces a sequence containing the elements 0, 1, and 2. This is very useful for performing counted loops."
-$nl
-"This means the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
+"For example, calling " { $link iota } " on the integer 3 produces a sequence containing the elements 0, 1, and 2. This is very useful for performing counted loops using words such as " { $link each } ":"
{ $example "3 iota [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
: push-if ( elt quot accum -- )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
-: selector-for ( quot exemplar -- quot accum )
+: selector-for ( quot exemplar -- selector accum )
[ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline
-: selector ( quot -- quot accum )
+: selector ( quot -- selector accum )
V{ } selector-for ; inline
: filter-as ( seq quot exemplar -- subseq )
: push-either ( elt quot accum1 accum2 -- )
[ keep swap ] 2dip ? push ; inline
-: 2selector ( quot -- quot accum1 accum2 )
+: 2selector ( quot -- selector accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq )
"Adding elements to sets:"
{ $subsections
adjoin
- conjoin
- conjoin-at
}
{ $see-also member? member-eq? any? all? "assocs-sets" } ;
{ $code "TUPLE: person" "{ age integer initial: 0 }" "{ department string initial: \"Marketing\" }" "manager ;" }
} ;
+HELP: final
+{ $syntax "TUPLE: ... ; final" }
+{ $description "Declares the most recently defined word as a final tuple class which cannot be subclassed. Attempting to subclass a final class raises a " { $link bad-superclass } " error." } ;
+
HELP: initial:
{ $syntax "TUPLE: ... { slot initial: value } ... ;" }
{ $values { "slot" "a slot name" } { "value" "any literal" } }
parse-tuple-definition define-tuple-class
] define-core-syntax
+ "final" [
+ word make-final
+ ] define-core-syntax
+
"SLOT:" [
scan define-protocol-slot
] define-core-syntax
"You can store your own vocabularies in the " { $snippet "work" } " directory."
{ $subsections "add-vocab-roots" } ;
+ARTICLE: "vocabs.icons" "Vocabulary icons"
+"An icon file representing the vocabulary can be provided for use by " { $link "tools.deploy" } ". A file named " { $snippet "icon.ico" } " will be used as the application icon when the application is deployed on Windows. A file named " { $snippet "icon.icns" } " will be used when the application is deployed on MacOS X." ;
+
ARTICLE: "vocabs.loader" "Vocabulary loader"
-"The vocabulary loader combines the vocabulary system with " { $link "parser" } " in order to implement automatic loading of vocabulary source files. The vocabulary loader is implemented in the " { $vocab-link "vocabs.loader" } " vocabulary."
-$nl
-"When an attempt is made to use a vocabulary that has not been loaded into the image, the vocabulary loader is asked to locate the vocabulary's source files, and load them."
+"The " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " words load vocabularies using the vocabulary loader. The vocabulary loader is implemented in the " { $vocab-link "vocabs.loader" } " vocabulary."
$nl
"The vocabulary loader searches for vocabularies in a set of directories known as vocabulary roots."
{ $subsections "vocabs.roots" }
{ { $snippet "foo/bar/bar-docs.factor" } " - documentation, see " { $link "writing-help" } }
{ { $snippet "foo/bar/bar-tests.factor" } " - unit tests, see " { $link "tools.test" } }
}
-"Finally, optional three text files may contain meta-data:"
-{ $list
- { { $snippet "foo/bar/authors.txt" } " - a series of lines, with one author name per line. These are listed under " { $link "vocab-authors" } }
- { { $snippet "foo/bar/summary.txt" } " - a one-line description" }
- { { $snippet "foo/bar/tags.txt" } " - a whitespace-separated list of tags which classify the vocabulary. Consult " { $link "vocab-tags" } " for a list of existing tags you can re-use" }
-}
-"The " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " words load vocabularies which have not been loaded yet, as needed."
-$nl
+"Optional text files may contain metadata."
+{ $subsections "vocabs.metadata" "vocabs.icons" }
"Vocabularies can also be loaded at run time, without altering the vocabulary search path. This is done by calling a word which loads a vocabulary if it is not in the image, doing nothing if it is:"
{ $subsections require }
"The above word will only ever load a vocabulary once in a given session. There is another word which unconditionally loads vocabulary from disk, regardless of whether or not is has already been loaded:"
-! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2007, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make sequences io io.files io.pathnames kernel
assocs words vocabs definitions parser continuations hashtables
SYMBOL: load-help?
+! Defined by vocabs.metadata
+SYMBOL: check-vocab-hook
+
+check-vocab-hook [ [ drop ] ] initialize
+
<PRIVATE
: load-source ( vocab -- )
+ dup check-vocab-hook get call( vocab -- )
[
+parsing+ >>source-loaded?
dup vocab-source-path [ parse-file ] [ [ ] ] if*
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: vocab-link (load-vocab)
- vocab-name create-vocab (load-vocab) ;
+ vocab-name (load-vocab) ;
-M: string (load-vocab)
- create-vocab (load-vocab) ;
+M: string (load-vocab) create-vocab (load-vocab) ;
PRIVATE>
<< global [ "count-me" inc ] bind >>
-: v-l-t-a-hello 4 ;
+: v-l-t-a-hello ( -- a ) 4 ;
-: byebye v-l-t-a-hello ;
+: byebye ( -- a ) v-l-t-a-hello ;
[ this is an error
-comments
-annotation
+tools
} case ;
: check-chunk ( chunk id class -- ? )
- heap-size [ id= ] [ [ length ] dip >= ] bi-curry* bi and ;
+ heap-size [ id= ] [ [ length ] dip >= ] bi-curry* bi and ; inline
! Factor port of the raytracer benchmark from
-! http://www.ffconsultancy.com/free/ray_tracer/languages.html
+! http://www.ffconsultancy.com/languages/ray_tracer/index.html
USING: arrays accessors io io.files io.files.temp
io.encodings.binary kernel math math.constants math.functions
-math.vectors math.vectors.simd math.vectors.simd.cords math.parser
-make sequences sequences.private words hints classes.struct ;
-QUALIFIED-WITH: alien.c-types c
+math.vectors math.vectors.simd math.vectors.simd.cords
+math.parser make sequences words combinators ;
IN: benchmark.raytracer-simd
+<< SYNTAX: no-compile word t "no-compile" set-word-prop ; >>
+
! parameters
! Normalized { -1 -3 2 }.
CONSTANT: size 200
-: delta ( -- n ) epsilon sqrt ; inline
+: delta ( -- n ) epsilon sqrt ; inline no-compile
TUPLE: ray { orig double-4 read-only } { dir double-4 read-only } ;
C: <hit> hit
-GENERIC: intersect-scene ( hit ray scene -- hit )
-
TUPLE: sphere { center double-4 read-only } { radius float read-only } ;
C: <sphere> sphere
-: sphere-v ( sphere ray -- v )
- [ center>> ] [ orig>> ] bi* v- ; inline
+: sphere-v ( sphere ray -- v ) [ center>> ] [ orig>> ] bi* v- ; inline no-compile
-: sphere-b ( v ray -- b )
- dir>> v. ; inline
+: sphere-b ( v ray -- b ) dir>> v. ; inline no-compile
-: sphere-d ( sphere b v -- d )
- [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
+: sphere-d ( sphere b v -- d ) [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline no-compile
-: -+ ( x y -- x-y x+y )
- [ - ] [ + ] 2bi ; inline
+: -+ ( x y -- x-y x+y ) [ - ] [ + ] 2bi ; inline no-compile
: sphere-t ( b d -- t )
-+ dup 0.0 <
- [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
+ [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline no-compile
: sphere-b&v ( sphere ray -- b v )
[ sphere-v ] [ nip ] 2bi
- [ sphere-b ] [ drop ] 2bi ; inline
+ [ sphere-b ] [ drop ] 2bi ; inline no-compile
: ray-sphere ( sphere ray -- t )
[ drop ] [ sphere-b&v ] 2bi
[ drop ] [ sphere-d ] 3bi
- dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
+ dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline no-compile
-: if-ray-sphere ( hit ray sphere quot -- hit )
- #! quot: hit ray sphere l -- hit
+: if-ray-sphere ( hit ray sphere quot: ( hit ray sphere l -- hit ) -- hit )
[
[ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
[ drop ] [ < ] 2bi
- ] dip [ 3drop ] if ; inline
+ ] dip [ 3drop ] if ; inline no-compile
: sphere-n ( ray sphere l -- n )
[ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
- swap [ v*n ] dip v- v+ ; inline
-
-M: sphere intersect-scene ( hit ray sphere -- hit )
- [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
-
-HINTS: M\ sphere intersect-scene { hit ray sphere } ;
+ swap [ v*n ] dip v- v+ ; inline no-compile
TUPLE: group < sphere { objs array read-only } ;
: <group> ( objs bound -- group )
- [ center>> ] [ radius>> ] bi rot group boa ; inline
+ swap [ [ center>> ] [ radius>> ] bi ] dip group boa ; inline no-compile
: make-group ( bound quot -- )
- swap [ { } make ] dip <group> ; inline
+ swap [ { } make ] dip <group> ; inline no-compile
-M: group intersect-scene ( hit ray group -- hit )
- [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
-
-HINTS: M\ group intersect-scene { hit ray group } ;
+: intersect-scene ( hit ray scene -- hit )
+ {
+ { [ dup group? ] [ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ] }
+ { [ dup sphere? ] [ [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ] }
+ } cond ; inline recursive no-compile
CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. }
: initial-intersect ( ray scene -- hit )
- [ initial-hit ] 2dip intersect-scene ; inline
+ [ initial-hit ] 2dip intersect-scene ; inline no-compile
: ray-o ( ray hit -- o )
[ [ orig>> ] [ normal>> delta v*n ] bi* ]
[ [ dir>> ] [ lambda>> ] bi* v*n ]
- 2bi v+ v+ ; inline
+ 2bi v+ v+ ; inline no-compile
: sray-intersect ( ray scene hit -- ray )
- swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
+ swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline no-compile
-: ray-g ( hit -- g ) normal>> light v. ; inline
+: ray-g ( hit -- g ) normal>> light v. ; inline no-compile
: cast-ray ( ray scene -- g )
2dup initial-intersect dup lambda>> 1/0. = [
] [
[ sray-intersect lambda>> 1/0. = ] keep swap
[ ray-g neg ] [ drop 0.0 ] if
- ] if ; inline
+ ] if ; inline no-compile
: create-center ( c r d -- c2 )
- [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
+ [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline no-compile
DEFER: create ( level c r -- scene )
: create-step ( level c r d -- scene )
over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
-: create-offsets ( quot -- )
+CONSTANT: create-offsets
{
double-4{ -1.0 1.0 -1.0 0.0 }
double-4{ 1.0 1.0 -1.0 0.0 }
double-4{ -1.0 1.0 1.0 0.0 }
double-4{ 1.0 1.0 1.0 0.0 }
- } swap each ; inline
+ }
: create-bound ( c r -- sphere ) 3.0 * <sphere> ;
: create-group ( level c r -- scene )
2dup create-bound [
2dup <sphere> ,
- [ [ 3dup ] dip create-step , ] create-offsets 3drop
+ create-offsets [ create-step , ] with with with each
] make-group ;
: create ( level c r -- scene )
pick 1 = [ <sphere> nip ] [ create-group ] if ;
: ss-point ( dx dy -- point )
- [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
-
-: ss-grid ( -- ss-grid )
- oversampling iota [ oversampling iota [ ss-point ] with map ] map ;
-
-: ray-grid ( point ss-grid -- ray-grid )
- [
- [ v+ normalize double-4{ 0.0 0.0 -4.0 0.0 } swap <ray> ] with map
- ] with map ;
-
-: ray-pixel ( scene point -- n )
- ss-grid ray-grid [ 0.0 ] 2dip
- [ [ swap cast-ray + ] with each ] with each ;
-
-: pixel-grid ( -- grid )
- size iota reverse [
+ [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ; inline no-compile
+
+: ray-pixel ( scene point -- ray-grid )
+ [ 0.0 ] 2dip
+ oversampling iota [
+ oversampling iota [
+ ss-point v+ normalize
+ double-4{ 0.0 0.0 -4.0 0.0 } swap <ray>
+ swap cast-ray +
+ ] with with with each
+ ] with with each ; inline no-compile
+
+: ray-trace ( scene -- grid )
+ size iota <reversed> [
size iota [
[ size 0.5 * - ] bi@ swap size
- 0.0 double-4-boa
- ] with map
- ] map ;
+ 0.0 double-4-boa ray-pixel
+ ] with with map
+ ] with map ;
: pgm-header ( w h -- )
"P5\n" % swap # " " % # "\n255\n" % ;
: pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
-: ray-trace ( scene -- pixels )
- pixel-grid [ [ ray-pixel ] with map ] with map ;
-
: run ( -- string )
levels double-4{ 0.0 -1.0 0.0 0.0 } 1.0 create ray-trace [
size size pgm-header
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions tuple-arrays accessors fry sequences
prettyprint ;
IN: benchmark.tuple-arrays
-TUPLE: point { x float } { y float } { z float } ;
+TUPLE: point { x float } { y float } { z float } ; final
TUPLE-ARRAY: point
! Copyright (C) 2010 Erik Charlebois
! See http:// factorcode.org/license.txt for BSD license.
-USING: accessors chipmunk classes.struct game.loop game.worlds gpu
-gpu.util.wasd kernel literals locals math method-chains opengl.gl
-random sequences specialized-arrays
-specialized-arrays.instances.alien.c-types.void* ui.gadgets.worlds
+USING: accessors chipmunk classes.struct game.worlds kernel locals
+math method-chains opengl.gl random sequences specialized-arrays
+specialized-arrays.instances.alien.c-types.void* ui ui.gadgets.worlds
ui.pixel-formats ;
IN: chipmunk.demo
cpCircleShapeAlloc body 0.95 0 0 cpv cpCircleShapeInit cpCircleShape memory>struct
[ shape>> 0 >>e ] [ shape>> 0 >>u ] bi drop ;
-TUPLE: chipmunk-world < wasd-world
+TUPLE: chipmunk-world < game-world
space ;
AFTER: chipmunk-world tick-game-world
M:: chipmunk-world begin-game-world ( world -- )
cpInitChipmunk
- init-gpu
- world { -0.2 0.13 0.1 } 1.1 0.2 set-wasd-view drop
cpSpaceAlloc cpSpaceInit cpSpace memory>struct :> space
[ cpSpaceFreeChildren ]
[ cpSpaceFree ] bi ;
-M: chipmunk-world wasd-movement-speed drop 1/160. ;
-M: chipmunk-world wasd-near-plane drop 1/32. ;
-M: chipmunk-world wasd-far-plane drop 256.0 ;
-
-GAME: chipmunk-demo {
- { world-class chipmunk-world }
- { title "Chipmunk Physics Demo" }
- { pixel-format-attributes {
- windowed
- double-buffered
- T{ depth-bits { value 24 } }
- } }
- { grab-input? t }
- { use-game-input? t }
- { pref-dim { 640 480 } }
- { tick-interval-micros $[ 60 fps ] }
- } ;
+: chipmunk-demo ( -- )
+ [
+ f
+ T{ game-attributes
+ { world-class chipmunk-world }
+ { title "Chipmunk Physics Demo" }
+ { pixel-format-attributes
+ { windowed double-buffered }
+ }
+ { pref-dim { 640 480 } }
+ { tick-interval-micros 16666 }
+ }
+ clone
+ open-window
+ ] with-ui ;
+
-FFI bindings to the Chipmunk 2D physics library.
+Chipmunk 2D physics library binding
+++ /dev/null
-unportable
+++ /dev/null
-unportable
{ "tick-interval-micros" integer } { "delegate" "a " { $link "game.loop-delegates" } }
{ "loop" game-loop }
}
-{ $description "Constructs a new stopped " { $link game-loop } " object. When started, the game loop will call the " { $link tick* } " method on the " { $snippet "delegate" } " every " { $snippet "tick-interval-micros" } " microseconds, and " { $link draw* } " on the delegate as frequently as possible. The " { $link start-loop } " and " { $link stop-loop } " words start and stop the game loop." } ;
+{ $description "Constructs a new stopped " { $link game-loop } " object. When started, the game loop will call the " { $link tick* } " method on the " { $snippet "delegate" } " every " { $snippet "tick-interval-micros" } " microseconds, and " { $link draw* } " on the same delegate object as frequently as possible. The " { $link start-loop } " and " { $link stop-loop } " words start and stop the game loop."
+$nl
+"To initialize the game loop with separate tick and draw delegates, use " { $link <game-loop*> } "." } ;
+
+HELP: <game-loop*>
+{ $values
+ { "tick-interval-micros" integer } { "tick-delegate" "a " { $link "game.loop-delegates" } } { "draw-delegate" "a " { $link "game.loop-delegates" } }
+ { "loop" game-loop }
+}
+{ $description "Constructs a new stopped " { $link game-loop } " object. When started, the game loop will call the " { $link tick* } " method on the " { $snippet "tick-delegate" } " every " { $snippet "tick-interval-micros" } " microseconds, and " { $link draw* } " on the " { $snippet "draw-delegate" } " as frequently as possible. The " { $link start-loop } " and " { $link stop-loop } " words start and stop the game loop."
+$nl
+"The " { $link <game-loop> } " word provides a shorthand for initializing a game loop that uses the same object for the " { $snippet "tick-delegate" } " and " { $snippet "draw-delegate" } "." } ;
+
+{ <game-loop> <game-loop*> } related-words
HELP: benchmark-frames-per-second
{ $values
{ "loop" game-loop }
{ "n" float }
}
-{ $description "Returns the average number of times per second the game loop has called " { $link tick* } " on its delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
+{ $description "Returns the average number of times per second the game loop has called " { $link tick* } " on its tick delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
{ reset-loop-benchmark benchmark-frames-per-second benchmark-ticks-per-second } related-words
{ $values
{ "tick-slice" float } { "delegate" "a " { $link "game.loop-delegates" } }
}
-{ $description "This generic word is called by a " { $link game-loop } " on its " { $snippet "delegate" } " object in a tight loop while the game loop is running. The " { $snippet "tick-slice" } " value represents what fraction of the game loop's " { $snippet "tick-interval-micros" } " time period has passed since " { $link tick* } " was most recently called on the delegate." } ;
+{ $description "This generic word is called by a " { $link game-loop } " on its " { $snippet "draw-delegate" } " object in a tight loop while the game loop is running. The " { $snippet "tick-slice" } " value represents what fraction of the game loop's " { $snippet "tick-interval-micros" } " time period has passed since " { $link tick* } " was most recently called on the " { $snippet "tick-delegate" } "." } ;
HELP: game-loop
-{ $class-description "Objects of the " { $snippet "game-loop" } " class manage game loops. See " { $link "game.loop" } " for an overview of the game loop library. To construct a game loop, use " { $link <game-loop> } ". To start and stop a game loop, use the " { $link start-loop } " and " { $link stop-loop } " words." } ;
+{ $class-description "Objects of the " { $snippet "game-loop" } " class manage game loops. See " { $link "game.loop" } " for an overview of the game loop library. To construct a game loop, use " { $link <game-loop> } ". To start and stop a game loop, use the " { $link start-loop } " and " { $link stop-loop } " words."
+$nl
+"The " { $snippet "tick-delegate" } " and " { $snippet "draw-delegate" } " slots of a game loop object determine where the loop sends its " { $link tick* } " and " { $link draw* } " events. These slots can be changed while the game loop is running." } ;
HELP: game-loop-error
{ $values
{ $values
{ "delegate" "a " { $link "game.loop-delegates" } }
}
-{ $description "This generic word is called by a " { $link game-loop } " on its " { $snippet "delegate" } " object at regular intervals while the game loop is running. The game loop's " { $snippet "tick-interval-micros" } " attribute determines the number of microseconds between invocations of " { $snippet "tick*" } "." } ;
+{ $description "This generic word is called by a " { $link game-loop } " on its " { $snippet "tick-delegate" } " object at regular intervals while the game loop is running. The game loop's " { $snippet "tick-interval-micros" } " attribute determines the number of microseconds between invocations of " { $snippet "tick*" } "." } ;
{ draw* tick* } related-words
ARTICLE: "game.loop-delegates" "Game loop delegate"
-"A " { $link game-loop } " object requires a " { $snippet "delegate" } " that implements the logic that controls the game. A game loop delegate can be any object that provides two methods for the following generic words:"
+"A " { $link game-loop } " object requires a " { $snippet "tick-delegate" } " and " { $snippet "draw-delegate" } " that together implement the logic that controls the game. Both delegates can also be the same object. A game loop delegate can be any object that provides two methods for the following generic words:"
{ $subsections
tick*
draw*
}
-{ $snippet "tick*" } " will be called at a regular interval determined by the game loop's " { $snippet "tick-interval-micros" } " attribute. " { $snippet "draw*" } " will be invoked in a tight loop, updating as frequently as possible." ;
+{ $snippet "tick*" } " will be called at a regular interval determined by the game loop's " { $snippet "tick-interval-micros" } " attribute on the tick delegate. " { $snippet "draw*" } " will be invoked on the draw delegate in a tight loop, updating as frequently as possible."
+$nl
+"It is possible to change the " { $snippet "tick-delegate" } " and " { $snippet "draw-delegate" } " slots of a game loop while it is running, for example, to use different delegates to control a game while it's in the menu, paused, or running the main game." ;
ARTICLE: "game.loop" "Game loops"
-"The " { $vocab-link "game.loop" } " vocabulary contains the implementation of a game loop. The game loop supports decoupled rendering and game logic timers; given a delegate object with methods on the " { $link tick* } " and " { $link draw* } " methods, the game loop will invoke the " { $snippet "tick*" } " method at regular intervals while invoking the " { $snippet "draw*" } " method as frequently as possible. Game loop objects must first be constructed:"
+"The " { $vocab-link "game.loop" } " vocabulary contains the implementation of a game loop. The game loop supports decoupled rendering and game logic timers; given a \"tick delegate\" object with a method on the " { $link tick* } " generic and a \"draw delegate\" with a " { $link draw* } " method, the game loop will invoke the " { $snippet "tick*" } " method on the former at regular intervals while invoking the " { $snippet "draw*" } " method on the latter as frequently as possible. Game loop objects must first be constructed:"
{ $subsections
"game.loop-delegates"
<game-loop>
+ <game-loop*>
}
"Once constructed, the game loop can be started and stopped:"
{ $subsections
start-loop
stop-loop
}
-"The game loop maintains performance counters for measuring drawing frames and ticks per second:"
+"The game loop maintains performance counters:"
{ $subsections
reset-loop-benchmark
benchmark-frames-per-second
benchmark-ticks-per-second
}
-"The game loop manages errors that occur in the delegate's methods during the course of the game loop:"
+"The game loop catches errors that occur in the delegate's methods during the course of the game loop:"
{ $subsections
game-loop-error
}
TUPLE: game-loop
{ tick-interval-micros integer read-only }
- delegate
+ tick-delegate
+ draw-delegate
{ last-tick integer }
thread
{ running? boolean }
: redraw ( loop -- )
[ 1 + ] change-frame-number
- [ tick-slice ] [ delegate>> ] bi draw* ;
+ [ tick-slice ] [ draw-delegate>> ] bi draw* ;
: tick ( loop -- )
- delegate>> tick* ;
+ tick-delegate>> tick* ;
: increment-tick ( loop -- )
[ 1 + ] change-tick-number
f >>thread
drop ;
-: <game-loop> ( tick-interval-micros delegate -- loop )
+: <game-loop*> ( tick-interval-micros tick-delegate draw-delegate -- loop )
system-micros f f 0 0 system-micros 0 0
game-loop boa ;
+: <game-loop> ( tick-interval-micros delegate -- loop )
+ dup <game-loop*> ; inline
+
M: game-loop dispose
stop-loop ;
HELP: z-up { $class-description "Right-handed 3D coordinate system where Z is up." } ;
HELP: >y-up-axis!
-{ $values { "seq" sequence } { "from-axis" rh-up } { "seq" sequence } }
+{ $values { "seq" sequence } { "from-axis" rh-up } }
{ $description "Destructively swizzles the first three elements of the input sequence to a right-handed 3D coordinate system where Y is up and returns the modified sequence." } ;
HELP: source>seq
{ $description "Convert the mesh tag's vertices element to a pair for further lookup in " { $link collect-sources } ". " } ;
HELP: collect-sources
-{ $values { "sources" hashtable } { "vertices" pair } { "inputs" tag sequence } { "sources" sequence } }
+{ $values { "sources" hashtable } { "vertices" pair } { "inputs" tag sequence } { "seq" sequence } }
{ $description "Look up the sources for these " { $emphasis "input" } " elements and return a sequence of " { $link source } " tuples." } ;
HELP: group-indices
] x*
] bi 2array ;
-:: collect-sources ( sources vertices inputs -- sources )
+:: collect-sources ( sources vertices inputs -- seq )
inputs
[| input |
input "source" x@ rest vertices first =
{ $description "Convert a face line to a sequence of vertex attributes." } ;
HELP: push*
-{ $values { "elt" "an object" } { "seq" sequence } { "seq" sequence } }
+{ $values { "elt" "an object" } { "seq" sequence } }
{ $description "Push the value onto the sequence, keeping the sequence on the stack." } ;
HELP: push-current-model
combinators.short-circuit game.loop game.worlds gpu gpu.buffers
gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
gpu.textures gpu.util grouping http.client images images.loader
-io io.encodings.ascii io.files io.files.temp kernel locals math
-math.matrices math.vectors.simd math.parser math.vectors
+images.tiff io io.encodings.ascii io.files io.files.temp kernel
+locals math math.matrices math.vectors.simd math.parser math.vectors
method-chains namespaces sequences splitting threads ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats specialized-arrays
specialized-vectors literals ;
USING: tools.deploy.config ;
H{
- { deploy-name "gpu.demos.bunny" }
- { deploy-word-defs? f }
- { deploy-io 3 }
+ { deploy-name "Bunny" }
+ { deploy-ui? t }
+ { deploy-c-types? f }
+ { deploy-unicode? f }
{ "stop-after-last-window?" t }
- { deploy-math? t }
+ { deploy-io 3 }
+ { deploy-reflection 1 }
{ deploy-word-props? f }
+ { deploy-math? t }
{ deploy-threads? t }
- { deploy-c-types? f }
- { deploy-reflection 2 }
- { deploy-unicode? f }
- { deploy-ui? t }
+ { deploy-word-defs? f }
}
--- /dev/null
+loading.tiff
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "Raytrace" }
+ { deploy-ui? t }
+ { deploy-c-types? f }
+ { deploy-unicode? f }
+ { "stop-after-last-window?" t }
+ { deploy-io 2 }
+ { deploy-reflection 2 }
+ { deploy-word-props? f }
+ { deploy-math? t }
+ { deploy-threads? t }
+ { deploy-word-defs? f }
+}
--- /dev/null
+green-ball.aiff
+mirror-ball.aiff
+red-ball.aiff
+yellow-ball.aiff
"gpu.shaders"
"gpu.render"
}
-"The library is built on top of the OpenGL API, but it aims to be complete enough that raw OpenGL calls are never needed. OpenGL 2.0 with the vertex array object extension (" { $snippet "GL_APPLE_vertex_array_object" } " or " { $snippet "GL_ARB_vertex_array_object" } ") is required. Some features require later OpenGL versions or additional extensions; these requirements are documented alongside individual words. To make full use of the library, an OpenGL 3.1 or later implementation is recommended." ;
+"The library is built on top of the OpenGL API, but it aims to be complete enough that raw OpenGL calls are never needed. OpenGL 2.0 is required. Some features require later OpenGL versions or additional extensions; these requirements are documented alongside individual words. To make full use of the library, an OpenGL 3.1 or later implementation is recommended." ;
ABOUT: "gpu-summary"
VARIANT: gpu-api
opengl-2 opengl-3 ;
+SYMBOL: has-vertex-array-objects?
+
: set-gpu-api ( -- )
"2.0" require-gl-version
"3.0" { { "GL_ARB_vertex_array_object" "GL_APPLE_vertex_array_object" } }
- require-gl-version-or-extensions
+ has-gl-version-or-extensions? has-vertex-array-objects? set-global
"3.0" has-gl-version? opengl-3 opengl-2 ? gpu-api set-global ;
HOOK: init-gpu-api gpu-api ( -- )
<PRIVATE
-: bind-vertex-array ( vertex-array -- )
- handle>> glBindVertexArray ;
-
: bind-unnamed-output-attachments ( framebuffer attachments -- )
[ gl-attachment ] with map
dup length 1 =
TUPLE: render-set
{ primitive-mode primitive-mode read-only }
- { vertex-array vertex-array read-only }
+ { vertex-array vertex-array initial: T{ vertex-array-collection } read-only }
{ uniforms uniform-tuple read-only }
{ indexes vertex-indexes initial: T{ index-range } read-only }
{ instances ?integer initial: f read-only }
{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a vertex shader." } ;
HELP: vertex-array
-{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <multi-vertex-array> } " or " { $link <vertex-array*> } " words." } ;
+{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <multi-vertex-array> } " or " { $link <vertex-array*> } " words. The actual type of a vertex-array object is opaque, but the " { $link vertex-array-buffers } " word can be used to query a vertex array object for its component buffers." } ;
+
+HELP: vertex-array-buffers
+{ $values
+ { "vertex-array" vertex-array }
+ { "buffers" sequence }
+}
+{ $description "Returns a sequence containing all of the " { $link buffer } " objects that make up " { $snippet "vertex-array" } "." } ;
HELP: vertex-array-buffer
{ $values
{ "vertex-array" vertex-array }
{ "vertex-buffer" buffer }
}
-{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
+{ $description "Returns the first " { $link buffer } " object that makes up " { $snippet "vertex-array" } "." } ;
+
+{ vertex-array-buffer vertex-array-buffers } related-words
HELP: vertex-attribute
{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
{ $subsections
vertex-array
<multi-vertex-array>
- vertex-array
+ <vertex-array*>
+ <vertex-array>
POSTPONE: VERTEX-FORMAT:
} ;
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs byte-arrays classes.mixin classes.parser
classes.singleton classes.struct combinators combinators.short-circuit
-definitions destructors fry generic.parser gpu gpu.buffers hashtables
-images io.encodings.ascii io.files io.pathnames kernel lexer
-literals locals math math.parser memoize multiline namespaces
+definitions destructors fry generic.parser gpu gpu.buffers gpu.private
+gpu.state hashtables images io.encodings.ascii io.files io.pathnames
+kernel lexer literals locals math math.parser memoize multiline namespaces
opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
SYNTAX: VERTEX-STRUCT:
CREATE-CLASS scan-word define-vertex-struct ;
-TUPLE: vertex-array < gpu-object
+TUPLE: vertex-array-object < gpu-object
{ program-instance program-instance read-only }
{ vertex-buffers sequence read-only } ;
-M: vertex-array dispose
+TUPLE: vertex-array-collection
+ { vertex-formats sequence read-only }
+ { program-instance program-instance read-only } ;
+
+UNION: vertex-array
+ vertex-array-object vertex-array-collection ;
+
+M: vertex-array-object dispose
[ [ delete-vertex-array ] when* f ] change-handle drop ;
: ?>buffer-ptr ( buffer/ptr -- buffer-ptr )
: ?>buffer ( buffer/ptr -- buffer )
dup buffer? [ buffer>> ] unless ; inline
-:: <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
+<PRIVATE
+
+: normalize-vertex-formats ( vertex-formats -- vertex-formats' )
+ [ first2 [ ?>buffer-ptr ] dip 2array ] map ; inline
+
+: (bind-vertex-array) ( vertex-formats program-instance -- )
+ '[ _ swap first2 bind-vertex-format ] each ; inline
+
+: (reset-vertex-array) ( -- )
+ GL_MAX_VERTEX_ATTRIBS get-gl-int iota [ glDisableVertexAttribArray ] each ; inline
+
+:: <multi-vertex-array-object> ( vertex-formats program-instance -- vertex-array )
gen-vertex-array :> handle
handle glBindVertexArray
- vertex-formats [ program-instance swap first2 [ ?>buffer-ptr ] dip bind-vertex-format ] each
+ vertex-formats normalize-vertex-formats program-instance (bind-vertex-array)
+
handle program-instance vertex-formats [ first ?>buffer ] map
- vertex-array boa window-resource ; inline
+ vertex-array-object boa window-resource ; inline
-:: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
+: <multi-vertex-array-collection> ( vertex-formats program-instance -- vertex-array )
+ [ normalize-vertex-formats ] dip vertex-array-collection boa ; inline
+
+:: <vertex-array-object> ( vertex-buffer program-instance format -- vertex-array )
gen-vertex-array :> handle
handle glBindVertexArray
program-instance vertex-buffer ?>buffer-ptr format bind-vertex-format
handle program-instance vertex-buffer ?>buffer 1array
- vertex-array boa window-resource ; inline
+ vertex-array-object boa window-resource ; inline
+
+: <vertex-array-collection> ( vertex-buffer program-instance format -- vertex-array )
+ swap [ [ ?>buffer-ptr ] dip 2array 1array ] dip <multi-vertex-array-collection> ; inline
+
+PRIVATE>
+
+GENERIC: bind-vertex-array ( vertex-array -- )
+
+M: vertex-array-object bind-vertex-array
+ handle>> glBindVertexArray ; inline
+
+M: vertex-array-collection bind-vertex-array
+ (reset-vertex-array)
+ [ vertex-formats>> ] [ program-instance>> ] bi (bind-vertex-array) ; inline
+
+: <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
+ has-vertex-array-objects? get
+ [ <multi-vertex-array-object> ]
+ [ <multi-vertex-array-collection> ] if ; inline
+
+: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
+ has-vertex-array-objects? get
+ [ <vertex-array-object> ]
+ [ <vertex-array-collection> ] if ; inline
: <vertex-array> ( vertex-buffer program-instance -- vertex-array )
dup program>> vertex-formats>> first <vertex-array*> ; inline
-TYPED: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
- vertex-buffers>> first ;
+GENERIC: vertex-array-buffers ( vertex-array -- buffers )
+
+M: vertex-array-object vertex-array-buffers
+ vertex-buffers>> ; inline
+
+M: vertex-array-collection vertex-array-buffers
+ vertex-formats>> [ first buffer>> ] map ; inline
+
+: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
+ vertex-array-buffers first ; inline
TUPLE: compile-shader-error shader log ;
TUPLE: link-program-error program log ;
[ [ set-gpu-state* ] each ]
[ set-gpu-state* ] if ; inline
-<PRIVATE
-
: get-gl-bool ( enum -- value )
0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
: get-gl-int ( enum -- value )
: gl-enabled? ( enum -- ? )
glIsEnabled c-bool> ;
-PRIVATE>
-
TYPED: get-viewport-state ( -- viewport-state: viewport-state )
GL_VIEWPORT get-gl-rect <viewport-state> ;
{ { $link DXT1-RGBA } }
{ { $link DXT3 } }
{ { $link DXT5 } }
+{ { $link LATC1 } }
+{ { $link LATC1-SIGNED } }
+{ { $link LATC2 } }
+{ { $link LATC2-SIGNED } }
{ { $link RGTC1 } }
{ { $link RGTC1-SIGNED } }
{ { $link RGTC2 } }
{ { $link RGTC2-SIGNED } }
} }
-{ $notes "The " { $snippet "DXT1" } " formats require either the " { $snippet "GL_EXT_texture_compression_s3tc" } " or " { $snippet "GL_EXT_texture_compression_dxt1" } " extension. The other " { $snippet "DXT" } " formats require the " { $snippet "GL_EXT_texture_compression_s3tc" } " extension. The " { $snippet "RGTC" } " formats require OpenGL 3.0 or later or the " { $snippet "GL_EXT_texture_compression_rgtc" } " extension." } ;
+{ $notes "The " { $snippet "DXT1" } " formats require either the " { $snippet "GL_EXT_texture_compression_s3tc" } " or " { $snippet "GL_EXT_texture_compression_dxt1" } " extension. The other " { $snippet "DXT" } " formats require the " { $snippet "GL_EXT_texture_compression_s3tc" } " extension. The " { $snippet "LATC" } " formats require the " { $snippet "GL_EXT_texture_compression_latc" } " extension. The " { $snippet "RGTC" } " formats require OpenGL 3.0 or later or the " { $snippet "GL_EXT_texture_compression_rgtc" } " extension." } ;
HELP: compressed-texture-data
{ $class-description { $snippet "compressed-texture-data" } " tuples are used to feed compressed texture data to " { $link allocate-compressed-texture } " and " { $link update-compressed-texture } "."
VARIANT: compressed-texture-format
DXT1-RGB DXT1-RGBA DXT3 DXT5
+ LATC1 LATC1-SIGNED LATC2 LATC2-SIGNED
RGTC1 RGTC1-SIGNED RGTC2 RGTC2-SIGNED ;
TUPLE: compressed-texture-data
"[let { 1 2 3 4 } :> myarr [infix myarr[4/2]*3 infix] ] ."
"9"
}
-"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
-{ $example
- "USING: arrays infix locals ;"
- ":: add-2nd-elements ( x y -- res )"
- " [infix x[1] + y[1] infix] ;"
- "{ 1 2 3 } { 0 1 2 3 } add-2nd-elements ."
- "3"
-}
;
ABOUT: "infix"
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax alien.data
classes.struct combinators io.ports io.streams.duplex
-system kernel math math.bitwise vocabs.loader unix io.serial
-io.serial.unix.termios io.backend.unix ;
+system kernel math math.bitwise vocabs.loader io.serial
+io.serial.unix.termios io.backend.unix unix unix.ffi ;
IN: io.serial.unix
<< {
+++ /dev/null
-unportable
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files.windows io.streams.duplex kernel math
-math.bitwise windows.kernel32 accessors alien.c-types
-windows io.files.windows fry locals continuations
-classes.struct ;
+math.bitwise windows windows.kernel32 windows.errors accessors
+alien.c-types fry locals continuations classes.struct ;
IN: io.serial.windows
: <serial-stream> ( path encoding -- duplex )
--- /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: accessors alien alien.c-types alien.libraries
+alien.syntax classes.struct combinators endian io.binary
+kernel locals math sequences specialized-arrays
+system unix.time unix.types ;
+FROM: alien.c-types => short ;
+IN: libusb
+
+<< "libusb" {
+ { [ os windows? ] [ "libusb-1.0.dll" ] }
+ { [ os macosx? ] [ "libusb-1.0.dylib" ] }
+ { [ os unix? ] [ "libusb-1.0.so" ] }
+ } cond "cdecl" add-library >>
+LIBRARY: libusb
+
+: libusb_cpu_to_le16 ( x -- y )
+ 2 >native-endian le> ; inline
+
+ALIAS: libusb_le16_to_cpu libusb_cpu_to_le16
+
+CONSTANT: LIBUSB_CLASS_PER_INTERFACE 0
+CONSTANT: LIBUSB_CLASS_AUDIO 1
+CONSTANT: LIBUSB_CLASS_COMM 2
+CONSTANT: LIBUSB_CLASS_HID 3
+CONSTANT: LIBUSB_CLASS_PRINTER 7
+CONSTANT: LIBUSB_CLASS_PTP 6
+CONSTANT: LIBUSB_CLASS_MASS_STORAGE 8
+CONSTANT: LIBUSB_CLASS_HUB 9
+CONSTANT: LIBUSB_CLASS_DATA 10
+CONSTANT: LIBUSB_CLASS_VENDOR_SPEC HEX: ff
+TYPEDEF: int libusb_class_code
+
+CONSTANT: LIBUSB_DT_DEVICE HEX: 01
+CONSTANT: LIBUSB_DT_CONFIG HEX: 02
+CONSTANT: LIBUSB_DT_STRING HEX: 03
+CONSTANT: LIBUSB_DT_INTERFACE HEX: 04
+CONSTANT: LIBUSB_DT_ENDPOINT HEX: 05
+CONSTANT: LIBUSB_DT_HID HEX: 21
+CONSTANT: LIBUSB_DT_REPORT HEX: 22
+CONSTANT: LIBUSB_DT_PHYSICAL HEX: 23
+CONSTANT: LIBUSB_DT_HUB HEX: 29
+TYPEDEF: int libusb_descriptor_type
+
+CONSTANT: LIBUSB_DT_DEVICE_SIZE 18
+CONSTANT: LIBUSB_DT_CONFIG_SIZE 9
+CONSTANT: LIBUSB_DT_INTERFACE_SIZE 9
+CONSTANT: LIBUSB_DT_ENDPOINT_SIZE 7
+CONSTANT: LIBUSB_DT_ENDPOINT_AUDIO_SIZE 9
+CONSTANT: LIBUSB_DT_HUB_NONVAR_SIZE 7
+
+CONSTANT: LIBUSB_ENDPOINT_ADDRESS_MASK HEX: 0f
+CONSTANT: LIBUSB_ENDPOINT_DIR_MASK HEX: 80
+
+CONSTANT: LIBUSB_ENDPOINT_IN HEX: 80
+CONSTANT: LIBUSB_ENDPOINT_OUT HEX: 00
+TYPEDEF: int libusb_endpoint_direction
+
+CONSTANT: LIBUSB_TRANSFER_TYPE_MASK HEX: 03
+
+CONSTANT: LIBUSB_TRANSFER_TYPE_CONTROL 0
+CONSTANT: LIBUSB_TRANSFER_TYPE_ISOCHRONOUS 1
+CONSTANT: LIBUSB_TRANSFER_TYPE_BULK 2
+CONSTANT: LIBUSB_TRANSFER_TYPE_INTERRUPT 3
+TYPEDEF: int libusb_transfer_type
+
+CONSTANT: LIBUSB_REQUEST_GET_STATUS HEX: 00
+CONSTANT: LIBUSB_REQUEST_CLEAR_FEATURE HEX: 01
+CONSTANT: LIBUSB_REQUEST_SET_FEATURE HEX: 03
+CONSTANT: LIBUSB_REQUEST_SET_ADDRESS HEX: 05
+CONSTANT: LIBUSB_REQUEST_GET_DESCRIPTOR HEX: 06
+CONSTANT: LIBUSB_REQUEST_SET_DESCRIPTOR HEX: 07
+CONSTANT: LIBUSB_REQUEST_GET_CONFIGURATION HEX: 08
+CONSTANT: LIBUSB_REQUEST_SET_CONFIGURATION HEX: 09
+CONSTANT: LIBUSB_REQUEST_GET_INTERFACE HEX: 0A
+CONSTANT: LIBUSB_REQUEST_SET_INTERFACE HEX: 0B
+CONSTANT: LIBUSB_REQUEST_SYNCH_FRAME HEX: 0C
+TYPEDEF: int libusb_standard_request
+
+CONSTANT: LIBUSB_REQUEST_TYPE_STANDARD HEX: 00
+CONSTANT: LIBUSB_REQUEST_TYPE_CLASS HEX: 20
+CONSTANT: LIBUSB_REQUEST_TYPE_VENDOR HEX: 40
+CONSTANT: LIBUSB_REQUEST_TYPE_RESERVED HEX: 60
+
+CONSTANT: LIBUSB_RECIPIENT_DEVICE HEX: 00
+CONSTANT: LIBUSB_RECIPIENT_INTERFACE HEX: 01
+CONSTANT: LIBUSB_RECIPIENT_ENDPOINT HEX: 02
+CONSTANT: LIBUSB_RECIPIENT_OTHER HEX: 03
+TYPEDEF: int libusb_request_recipient
+
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_MASK HEX: 0C
+
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_NONE 0
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_ASYNC 1
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_ADAPTIVE 2
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_SYNC 3
+TYPEDEF: int libusb_iso_sync_type
+
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_MASK HEX: 30
+
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_DATA 0
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_FEEDBACK 1
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_IMPLICIT 2
+TYPEDEF: int libusb_iso_usage_type
+
+STRUCT: libusb_device_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bcdUSB uint16_t }
+ { bDeviceClass uint8_t }
+ { bDeviceSubClass uint8_t }
+ { bDeviceProtocol uint8_t }
+ { bMaxPacketSize0 uint8_t }
+ { idVendor uint16_t }
+ { idProduct uint16_t }
+ { bcdDevice uint16_t }
+ { iManufacturer uint8_t }
+ { iProduct uint8_t }
+ { iSerialNumber uint8_t }
+ { bNumConfigurations uint8_t } ;
+
+STRUCT: libusb_endpoint_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bEndpointAddress uint8_t }
+ { bmAttributes uint8_t }
+ { wMaxPacketSize uint16_t }
+ { bInterval uint8_t }
+ { bRefresh uint8_t }
+ { bSynchAddress uint8_t }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_interface_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bInterfaceNumber uint8_t }
+ { bAlternateSetting uint8_t }
+ { bNumEndpoints uint8_t }
+ { bInterfaceClass uint8_t }
+ { bInterfaceSubClass uint8_t }
+ { bInterfaceProtocol uint8_t }
+ { iInterface uint8_t }
+ { endpoint libusb_endpoint_descriptor* }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_interface
+ { altsetting libusb_interface_descriptor* }
+ { num_altsetting int } ;
+
+STRUCT: libusb_config_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { wTotalLength uint16_t }
+ { bNumInterfaces uint8_t }
+ { bConfigurationValue uint8_t }
+ { iConfiguration uint8_t }
+ { bmAttributes uint8_t }
+ { MaxPower uint8_t }
+ { interface libusb_interface* }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_control_setup
+ { bmRequestType uint8_t }
+ { bRequest uint8_t }
+ { wValue uint16_t }
+ { wIndex uint16_t }
+ { wLength uint16_t } ;
+
+: LIBUSB_CONTROL_SETUP_SIZE ( -- x ) libusb_control_setup heap-size ; inline
+
+C-TYPE: libusb_context
+C-TYPE: libusb_device
+C-TYPE: libusb_device_handle
+
+CONSTANT: LIBUSB_SUCCESS 0
+CONSTANT: LIBUSB_ERROR_IO -1
+CONSTANT: LIBUSB_ERROR_INVALID_PARAM -2
+CONSTANT: LIBUSB_ERROR_ACCESS -3
+CONSTANT: LIBUSB_ERROR_NO_DEVICE -4
+CONSTANT: LIBUSB_ERROR_NOT_FOUND -5
+CONSTANT: LIBUSB_ERROR_BUSY -6
+CONSTANT: LIBUSB_ERROR_TIMEOUT -7
+CONSTANT: LIBUSB_ERROR_OVERFLOW -8
+CONSTANT: LIBUSB_ERROR_PIPE -9
+CONSTANT: LIBUSB_ERROR_INTERRUPTED -10
+CONSTANT: LIBUSB_ERROR_NO_MEM -11
+CONSTANT: LIBUSB_ERROR_NOT_SUPPORTED -12
+CONSTANT: LIBUSB_ERROR_OTHER -99
+TYPEDEF: int libusb_error
+
+C-ENUM:
+ LIBUSB_TRANSFER_COMPLETED
+ LIBUSB_TRANSFER_ERROR
+ LIBUSB_TRANSFER_TIMED_OUT
+ LIBUSB_TRANSFER_CANCELLED
+ LIBUSB_TRANSFER_STALL
+ LIBUSB_TRANSFER_NO_DEVICE
+ LIBUSB_TRANSFER_OVERFLOW ;
+TYPEDEF: int libusb_transfer_status
+
+CONSTANT: LIBUSB_TRANSFER_SHORT_NOT_OK 1
+CONSTANT: LIBUSB_TRANSFER_FREE_BUFFER 2
+CONSTANT: LIBUSB_TRANSFER_FREE_TRANSFER 4
+TYPEDEF: int libusb_transfer_flags
+
+STRUCT: libusb_iso_packet_descriptor
+ { length uint }
+ { actual_length uint }
+ { status libusb_transfer_status } ;
+SPECIALIZED-ARRAY: libusb_iso_packet_descriptor
+
+C-TYPE: libusb_transfer
+
+CALLBACK: void libusb_transfer_cb_fn ( libusb_transfer* transfer ) ;
+
+STRUCT: libusb_transfer
+ { dev_handle libusb_device_handle* }
+ { flags uint8_t }
+ { endpoint uchar }
+ { type uchar }
+ { timeout uint }
+ { status libusb_transfer_status }
+ { length int }
+ { actual_length int }
+ { callback libusb_transfer_cb_fn }
+ { user_data void* }
+ { buffer uchar* }
+ { num_iso_packets int }
+ { iso_packet_desc libusb_iso_packet_descriptor[0] } ;
+
+FUNCTION: int libusb_init ( libusb_context** ctx ) ;
+FUNCTION: void libusb_exit ( libusb_context* ctx ) ;
+FUNCTION: void libusb_set_debug ( libusb_context* ctx, int level ) ;
+
+FUNCTION: ssize_t libusb_get_device_list ( libusb_context* ctx, libusb_device*** list ) ;
+FUNCTION: void libusb_free_device_list ( libusb_device** list, int unref_devices ) ;
+FUNCTION: libusb_device* libusb_ref_device ( libusb_device* dev ) ;
+FUNCTION: void libusb_unref_device ( libusb_device* dev ) ;
+
+FUNCTION: int libusb_get_configuration ( libusb_device_handle* dev, int* config ) ;
+FUNCTION: int libusb_get_device_descriptor ( libusb_device* dev, libusb_device_descriptor* desc ) ;
+FUNCTION: int libusb_get_active_config_descriptor ( libusb_device* dev, libusb_config_descriptor** config ) ;
+FUNCTION: int libusb_get_config_descriptor ( libusb_device* dev, uint8_t config_index, libusb_config_descriptor** config ) ;
+FUNCTION: int libusb_get_config_descriptor_by_value ( libusb_device* dev, uint8_t bConfigurationValue, libusb_config_descriptor** config ) ;
+FUNCTION: void libusb_free_config_descriptor ( libusb_config_descriptor* config ) ;
+FUNCTION: uint8_t libusb_get_bus_number ( libusb_device* dev ) ;
+FUNCTION: uint8_t libusb_get_device_address ( libusb_device* dev ) ;
+FUNCTION: int libusb_get_max_packet_size ( libusb_device* dev, uchar endpoint ) ;
+
+FUNCTION: int libusb_open ( libusb_device* dev, libusb_device_handle** handle ) ;
+FUNCTION: void libusb_close ( libusb_device_handle* dev_handle ) ;
+FUNCTION: libusb_device* libusb_get_device ( libusb_device_handle* dev_handle ) ;
+
+FUNCTION: int libusb_set_configuration ( libusb_device_handle* dev, int configuration ) ;
+FUNCTION: int libusb_claim_interface ( libusb_device_handle* dev, int iface ) ;
+FUNCTION: int libusb_release_interface ( libusb_device_handle* dev, int iface ) ;
+
+FUNCTION: libusb_device_handle* libusb_open_device_with_vid_pid ( libusb_context* ctx, uint16_t vendor_id, uint16_t product_id ) ;
+
+FUNCTION: int libusb_set_interface_alt_setting ( libusb_device_handle* dev, int interface_number, int alternate_setting ) ;
+FUNCTION: int libusb_clear_halt ( libusb_device_handle* dev, uchar endpoint ) ;
+FUNCTION: int libusb_reset_device ( libusb_device_handle* dev ) ;
+
+FUNCTION: int libusb_kernel_driver_active ( libusb_device_handle* dev, int interface ) ;
+FUNCTION: int libusb_detach_kernel_driver ( libusb_device_handle* dev, int interface ) ;
+FUNCTION: int libusb_attach_kernel_driver ( libusb_device_handle* dev, int interface ) ;
+
+: libusb_control_transfer_get_data ( transfer -- data )
+ buffer>> LIBUSB_CONTROL_SETUP_SIZE swap <displaced-alien> ; inline
+
+: libusb_control_transfer_get_setup ( transfer -- setup )
+ buffer>> libusb_control_setup memory>struct ; inline
+
+:: libusb_fill_control_setup ( buffer bmRequestType bRequest wValue wIndex wLength -- )
+ buffer libusb_control_setup memory>struct
+ bmRequestType >>bmRequestType
+ bRequest >>bRequest
+ wValue libusb_cpu_to_le16 >>wValue
+ wIndex libusb_cpu_to_le16 >>wIndex
+ wLength libusb_cpu_to_le16 >>wLength drop ; inline
+
+FUNCTION: libusb_transfer* libusb_alloc_transfer ( int iso_packets ) ;
+FUNCTION: int libusb_submit_transfer ( libusb_transfer* transfer ) ;
+FUNCTION: int libusb_cancel_transfer ( libusb_transfer* transfer ) ;
+FUNCTION: void libusb_free_transfer ( libusb_transfer* transfer ) ;
+
+:: libusb_fill_control_transfer ( transfer dev_handle buffer callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ 0 >>endpoint
+ LIBUSB_TRANSFER_TYPE_CONTROL >>type
+ timeout >>timeout
+ buffer >>buffer
+ user_data >>user_data
+ callback >>callback
+
+ buffer [
+ libusb_control_setup memory>struct wLength>> LIBUSB_CONTROL_SETUP_SIZE +
+ ] [ 0 ] if* >>length drop ; inline
+
+:: libusb_fill_bulk_transfer ( transfer dev_handle endpoint buffer length callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_BULK >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+:: libusb_fill_interrupt_transfer ( transfer dev_handle endpoint buffer length callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_INTERRUPT >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+:: libusb_fill_iso_transfer ( transfer dev_handle endpoint buffer length num_iso_packets callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_ISOCHRONOUS >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ num_iso_packets >>num_iso_packets
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+: libusb_set_iso_packet_lengths ( transfer length -- )
+ [ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array>
+ ] dip [ >>length drop ] curry each ; inline
+
+:: libusb_get_iso_packet_buffer ( transfer packet -- data )
+ packet transfer num_iso_packets>> >=
+ [ f ]
+ [
+ transfer
+ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array> 0
+ [ length>> + ] reduce
+ transfer buffer>> <displaced-alien>
+ ] if ;
+
+:: libusb_get_iso_packet_buffer_simple ( transfer packet -- data )
+ packet transfer num_iso_packets>> >=
+ [ f ]
+ [
+ 0 transfer
+ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array> nth
+ length>> packet *
+ transfer buffer>> <displaced-alien>
+ ] if ;
+
+FUNCTION: int libusb_control_transfer ( libusb_device_handle* dev_handle,
+ uint8_t request_type, uint8_t request, uint16_t value, uint16_t index,
+ uchar* data, uint16_t length, uint timeout ) ;
+
+FUNCTION: int libusb_bulk_transfer ( libusb_device_handle* dev_handle,
+ uchar endpoint, uchar* data, int length,
+ int* actual_length, uint timeout ) ;
+
+FUNCTION: int libusb_interrupt_transfer ( libusb_device_handle* dev_handle,
+ uchar endpoint, uchar* data, int length,
+ int* actual_length, int timeout ) ;
+
+:: libusb_get_descriptor ( dev desc_type desc_index data length -- int )
+ dev LIBUSB_ENDPOINT_IN LIBUSB_REQUEST_GET_DESCRIPTOR
+ desc_type 8 shift desc_index bitor 0 data
+ length 1000 libusb_control_transfer ; inline
+
+:: libusb_get_string_descriptor ( dev desc_index langid data length -- int )
+ dev LIBUSB_ENDPOINT_IN LIBUSB_REQUEST_GET_DESCRIPTOR
+ LIBUSB_DT_STRING 8 shift desc_index bitor
+ langid data length 1000 libusb_control_transfer ; inline
+
+FUNCTION: int libusb_get_string_descriptor_ascii ( libusb_device_handle* dev,
+ uint8_t index,
+ uchar* data,
+ int length ) ;
+
+FUNCTION: int libusb_try_lock_events ( libusb_context* ctx ) ;
+FUNCTION: void libusb_lock_events ( libusb_context* ctx ) ;
+FUNCTION: void libusb_unlock_events ( libusb_context* ctx ) ;
+FUNCTION: int libusb_event_handling_ok ( libusb_context* ctx ) ;
+FUNCTION: int libusb_event_handler_active ( libusb_context* ctx ) ;
+FUNCTION: void libusb_lock_event_waiters ( libusb_context* ctx ) ;
+FUNCTION: void libusb_unlock_event_waiters ( libusb_context* ctx ) ;
+FUNCTION: int libusb_wait_for_event ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_handle_events_timeout ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_handle_events ( libusb_context* ctx ) ;
+FUNCTION: int libusb_handle_events_locked ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_get_next_timeout ( libusb_context* ctx, timeval* tv ) ;
+
+STRUCT: libusb_pollfd
+ { fd int }
+ { events short } ;
+
+CALLBACK: void libusb_pollfd_added_cb ( int fd, short events, void* user_data ) ;
+CALLBACK: void libusb_pollfd_removed_cb ( int fd, void* user_data ) ;
+
+FUNCTION: libusb_pollfd** libusb_get_pollfds ( libusb_context* ctx ) ;
+FUNCTION: void libusb_set_pollfd_notifiers ( libusb_context* ctx,
+ libusb_pollfd_added_cb added_cb,
+ libusb_pollfd_removed_cb removed_cb,
+ void* user_data ) ;
--- /dev/null
+Bindings to libusb
bindings
-unportable
+untested
: clone-factor ( -- )
{ "git" "clone" } home "factor" append-path suffix try-process ;
+: save-git-id ( -- )
+ git-id "git-id" to-file ;
+
+: delete-git-tree ( -- )
+ ".git" delete-tree ;
+
+: download-images ( -- )
+ images [ download-image ] each ;
+
: prepare-source ( -- )
- "factor" [
- ".git" delete-tree
- images [ download-image ] each
- ] with-directory ;
+ "factor" [ save-git-id delete-git-tree download-images ] with-directory ;
: package-name ( version -- string )
"factor-src-" ".zip" surround ;
--- /dev/null
+USING: kernel arrays math.vectors sequences math ;
+
+IN: math.points
+
+<PRIVATE
+
+: X ( x -- point ) 0 0 3array ;
+: Y ( y -- point ) 0 swap 0 3array ;
+: Z ( z -- point ) 0 0 rot 3array ;
+
+PRIVATE>
+
+: v+x ( seq x -- seq ) X v+ ;
+: v-x ( seq x -- seq ) X v- ;
+
+: v+y ( seq y -- seq ) Y v+ ;
+: v-y ( seq y -- seq ) Y v- ;
+
+: v+z ( seq z -- seq ) Z v+ ;
+: v-z ( seq z -- seq ) Z v- ;
+
+: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
+: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
+: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
+: midpoint ( point point -- point ) v+ 2 v/n ;
+: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
\ No newline at end of file
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax math ;
+IN: math.splines
+
+HELP: <bezier-curve>
+{ $values
+ { "control-points" "sequence of control points same dimension" }
+ { "polynomials" "sequence of polynomials for each dimension" }
+}
+{ $description "Creates bezier curve polynomials for the given control points." } ;
+
+HELP: <catmull-rom-spline>
+{ $values
+ { "points" "points on the spline" } { "m0" "initial tangent vector" } { "mn" "final tangent vector" }
+ { "polynomials-sequence" "sequence of sequences of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points and generating tangents for C1 continuity." } ;
+
+HELP: <cubic-hermite-curve>
+{ $values
+ { "p0" "start point" } { "m0" "start tangent" } { "p1" "end point" } { "m1" "end tangent" }
+ { "polynomials" "sequence of polynomials" }
+}
+{ $description "Creates a sequence of polynomials (one per dimension) for the curve passing through " { $emphasis "p0" } " and " { $emphasis "p1" } "." } ;
+
+HELP: <cubic-hermite-spline>
+{ $values
+ { "point-tangent-pairs" "sequence of point and tangent pairs" }
+ { "polynomials-sequence" "sequence of sequences of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points with the given tangents." } ;
+
+HELP: <kochanek-bartels-curve>
+{ $values
+ { "points" "points on the spline" } { "m0" "start tangent" } { "mn" "end tangent" } { "tension" number } { "bias" number } { "continuity" number }
+ { "polynomials-sequence" "sequence of sequence of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points, generating tangents with the given tuning parameters." } ;
+
+ARTICLE: "math.splines" "Common parametric curves."
+"The curve creating functions create sequences of polynomials, one for each degree of the input points. The spline creating functions create sequences of these curve polynomial sequences. The " { $vocab-link "math.splines.viewer" } " vocabulary provides a gadget to evaluate the generated polynomials and view the results.";
+
+ABOUT: "math.splines"
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel locals math math.combinatorics
+math.polynomials opengl.gl sequences ui.gadgets ui.gadgets.panes
+ui.render arrays grouping math.vectors assocs
+ui.gestures ;
+IN: math.splines
+
+<PRIVATE
+:: bernstein-polynomial-ith ( n i -- p )
+ n i nCk { 0 1 } i p^ { 1 -1 } n i - p^ p* n*p ;
+
+:: hermite-polynomial ( p0 m0 p1 m1 -- poly )
+ p0
+ m0
+ -3 p0 * -2 m0 * + 3 p1 * + m1 neg +
+ 2 p0 * m0 + -2 p1 * + m1 +
+ 4array ;
+
+:: kochanek-bartels-coefficients ( tension bias continuity -- s1 d1 s2 d2 )
+ 1 tension -
+ [
+ 1 bias +
+ [ 1 continuity + * * 2 / ]
+ [ 1 continuity - * * 2 / ] 2bi
+ ]
+ [
+ 1 bias -
+ [ 1 continuity - * * 2 / ]
+ [ 1 continuity + * * 2 / ] 2bi
+ ] bi ;
+
+:: kochanek-bartels-tangents ( points m0 mn c1 c2 -- tangents )
+ points 3 clump [
+ first3 :> ( pi-1 pi pi+1 )
+ pi pi-1 v- c1 v*n
+ pi+1 pi v- c2 v*n v+
+ ] map
+ m0 prefix
+ mn suffix ;
+PRIVATE>
+
+:: <bezier-curve> ( control-points -- polynomials )
+ control-points
+ [ length 1 - ]
+ [ first length [ { 0 } ] replicate ]
+ bi :> ( n acc )
+
+ control-points [| pt i |
+ n i bernstein-polynomial-ith :> poly
+ pt [| v j |
+ j acc [ v poly n*p p+ ] change-nth
+ ] each-index
+ ] each-index
+ acc ;
+
+:: <cubic-hermite-curve> ( p0 m0 p1 m1 -- polynomials )
+ p0 length iota [
+ {
+ [ p0 nth ] [ m0 nth ]
+ [ p1 nth ] [ m1 nth ]
+ } cleave
+ hermite-polynomial
+ ] map ;
+
+<PRIVATE
+: (cubic-hermite-spline) ( point-in-out-triplets -- polynomials-sequence )
+ 2 clump [
+ first2 [ first2 ] [ [ first ] [ third ] bi ] bi* <cubic-hermite-curve>
+ ] map ;
+PRIVATE>
+
+: <cubic-hermite-spline> ( point-tangent-pairs -- polynomials-sequence )
+ 2 clump [ first2 [ first2 ] bi@ <cubic-hermite-curve> ] map ;
+
+:: <kochanek-bartels-curve> ( points m0 mn tension bias continuity -- polynomials-sequence )
+ tension bias continuity kochanek-bartels-coefficients :> ( s1 d1 s2 d2 )
+ points m0 mn
+ [ s1 s2 kochanek-bartels-tangents ]
+ [ d1 d2 kochanek-bartels-tangents ] 3bi :> ( in out )
+ points in out [ 3array ] 3map (cubic-hermite-spline) ;
+
+: <catmull-rom-spline> ( points m0 mn -- polynomials-sequence )
+ 0 0 0 <kochanek-bartels-curve> ;
--- /dev/null
+Common parametric curves
--- /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: locals math.splines math.splines.viewer arrays ;
+IN: math.splines.testing
+
+: test1 ( -- )
+ {
+ { { 0 0 } { 0 200 } }
+ { { 100 50 } { 0 -200 } }
+ { { 300 300 } { 500 200 } }
+ { { 400 400 } { 300 0 } }
+ } <cubic-hermite-spline> { 50 100 } 4 spline. ;
+
+: test2 ( -- )
+ {
+ { 50 50 }
+ { 100 100 }
+ { 300 200 }
+ { 350 0 }
+ { 400 400 }
+ } { 0 100 } { 100 0 } <catmull-rom-spline> { 100 50 } 50 spline. ;
+
+:: test3 ( x y z -- )
+ {
+ { 100 50 }
+ { 200 350 }
+ { 300 50 }
+ } { 0 100 } { 0 -100 } x y z <kochanek-bartels-curve> { 50 50 } 1000 spline. ;
+
+: test4 ( -- )
+ {
+ { 0 5 }
+ { 0.5 3 }
+ { 10 10 }
+ { 12 4 }
+ { 15 5 }
+ } <bezier-curve> 1array { 100 100 } 100 spline. ;
+
+: test-splines ( -- )
+ test1 test2
+ 1 0 0 test3
+ -1 0 0 test3
+ 0 1 0 test3
+ 0 -1 0 test3
+ 0 0 1 test3
+ 0 0 -1 test3
+ test4 ;
+
+
--- /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: accessors kernel locals math math.order math.polynomials
+math.splines opengl.gl sequences ui.gadgets ui.gadgets.panes ui.render
+arrays ;
+IN: math.splines.viewer
+
+<PRIVATE
+: eval-polynomials ( polynomials-seq n -- xy-sequence )
+ [
+ [ 1 + iota ] keep [
+ /f swap [ polyval ] with map
+ ] curry with map
+ ] curry map concat ;
+PRIVATE>
+
+TUPLE: spline-gadget < gadget polynomials steps spline-dim ;
+
+M: spline-gadget pref-dim* spline-dim>> ;
+
+M:: spline-gadget draw-gadget* ( gadget -- )
+ 0 0 0 glColor3f
+
+ gadget [ polynomials>> ] [ steps>> ] bi eval-polynomials :> pts
+
+ pts [ first ] [ max ] map-reduce :> x-max
+ pts [ first ] [ min ] map-reduce :> x-min
+ pts [ second ] [ max ] map-reduce :> y-max
+ pts [ second ] [ min ] map-reduce :> y-min
+
+ pts [
+ [ first x-min - x-max x-min - / gadget spline-dim>> first * ]
+ [ second y-min - y-max y-min - / gadget spline-dim>> second * ] bi 2array
+ ] map :> pts
+
+ GL_LINE_STRIP glBegin
+ pts [
+ first2 neg gadget spline-dim>> second + glVertex2f
+ ] each
+ glEnd ;
+
+:: <spline-gadget> ( polynomials dim steps -- gadget )
+ spline-gadget new
+ dim >>spline-dim
+ polynomials >>polynomials
+ steps >>steps ;
+
+: spline. ( curve dim steps -- )
+ <spline-gadget> gadget. ;
IN: math.transforms.fft
HELP: fft
-{ $values { "seq" sequence } { "seq" sequence } }
+{ $values { "seq" sequence } { "seq'" sequence } }
{ $description "Fast Fourier transform function." } ;
: omega ( n -- n' )
recip -2 pi i* * * exp ;
-: twiddle ( seq -- seq )
+: twiddle ( seq -- seq' )
dup length [ omega ] [ n^v ] bi v* ;
PRIVATE>
DEFER: fft
-: two ( seq -- seq )
+: two ( seq -- seq' )
fft 2 v/n dup append ;
<PRIVATE
-: even ( seq -- seq ) 2 group 0 <column> ;
-: odd ( seq -- seq ) 2 group 1 <column> ;
+: even ( seq -- seq' ) 2 group 0 <column> ;
+: odd ( seq -- seq' ) 2 group 1 <column> ;
-: (fft) ( seq -- seq )
+: (fft) ( seq -- seq' )
[ odd two twiddle ] [ even two ] bi v+ ;
PRIVATE>
-: fft ( seq -- seq )
+: fft ( seq -- seq' )
dup length 1 = [ (fft) ] unless ;
IN: math.transforms.haar
HELP: haar
-{ $values { "seq" sequence } { "seq" sequence } }
+{ $values { "seq" sequence } { "seq'" sequence } }
{ $description "Haar wavelet transform function." }
{ $notes "The sequence length should be a power of two." }
{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 7 1 6 6 3 -5 4 2 } haar ." "{ 3 2 -1 -2 3 0 4 1 }" } } ;
HELP: rev-haar
-{ $values { "seq" sequence } { "seq" sequence } }
+{ $values { "seq" sequence } { "seq'" sequence } }
{ $description "Reverse Haar wavelet transform function." }
{ $notes "The sequence length should be a power of two." }
{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 3 2 -1 -2 3 0 4 1 } rev-haar ." "{ 7 1 6 6 3 -5 4 2 }" } } ;
<PRIVATE
-: averages ( seq -- seq )
+: averages ( seq -- seq' )
[ mean ] map ;
: differences ( seq averages -- differences )
PRIVATE>
-: haar ( seq -- seq )
+: haar ( seq -- seq' )
dup length 1 <= [ haar-step haar prepend ] unless ;
-: rev-haar ( seq -- seq )
+: rev-haar ( seq -- seq' )
dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ;
HELP: pile-align
{ $values
{ "pile" pile } { "align" "a power of two" }
- { "pile" pile }
}
{ $description "Adjusts a " { $link pile } "'s internal state so that the next call to " { $link pile-alloc } " will return a pointer aligned to " { $snippet "align" } " bytes relative to the pile's initial offset." } ;
+++ /dev/null
-unportable
-
HELP: >upsert
{ $values
{ "mdb-update-msg" "a mdb-update-msg" }
- { "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" }
}
{ $description "Marks a mdb-update-msg as upsert operation"
"(inserts object identified by the update selector if it doesn't exist in the collection)" } ;
{ $values
{ "mdb-query-msg" "a query" }
{ "index-hint" "a hint to an index" }
- { "mdb-query-msg" "modified query object" }
}
{ $description "Annotates the query with a hint to an index. "
"For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } }
{ $values
{ "mdb-query-msg" "a query" }
{ "limit#" "number of objects that should be returned at most" }
- { "mdb-query-msg" "modified query object" }
}
{ $description "Limits the number of returned objects to limit#" }
{ $examples
{ $values
{ "mdb-query-msg" "a query message" }
{ "skip#" "number of objects to skip" }
- { "mdb-query-msg" "annotated query message" }
}
{ $description "annotates a query message with a number of objects to skip when returning the results" } ;
{ $values
{ "mdb-query-msg" "a query message" }
{ "sort-quot" "a quotation with sort specifiers" }
- { "mdb-query-msg" "annotated query message" }
}
{ $description "annotates the query message for sort specifiers" } ;
! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
+USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal openal.alut parser sequences splitting strings synth synth.buffers ;
IN: morse
ERROR: no-morse-ch ch ;
-USING: alien.c-types alien.syntax io io.encodings.utf16n
-io.encodings.utf8 io.files kernel namespaces sequences system threads
+! Copyright (C) 2009 Phil Dawes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.strings alien.syntax io
+io.encodings.utf8 io.files kernel sequences system threads
unix.utilities ;
IN: native-thread-test
FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ;
-HOOK: native-string-encoding os ( -- encoding )
-M: windows native-string-encoding utf16n ;
-M: unix native-string-encoding utf8 ;
-
: start-vm-in-os-thread ( args -- threadhandle )
- \ vm get-global prefix
+ vm prefix
[ length ] [ native-string-encoding strings>alien ] bi
- start_standalone_factor_in_new_thread ;
+ start_standalone_factor_in_new_thread ;
: start-tetris-in-os-thread ( -- )
- { "-run=tetris" } start-vm-in-os-thread drop ;
+ { "-run=tetris" } start-vm-in-os-thread drop ;
+
+: start-test-thread-in-os-thread ( -- )
+ { "-run=native-thread-test" } start-vm-in-os-thread drop ;
-: start-testthread-in-os-thread ( -- )
- { "-run=native-thread-test" } start-vm-in-os-thread drop ;
-
-: testthread ( -- )
- "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
+: test-thread ( -- )
+ "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ;
-MAIN: testthread
+MAIN: test-thread
{ [ os macosx? ] [ "libogg.0.dylib" ] }
{ [ os unix? ] [ "libogg.so" ] }
} cond "cdecl" add-library
+
+"ogg" deploy-library
>>
LIBRARY: ogg
{ [ os macosx? ] [ "libvorbis.0.dylib" ] }
{ [ os unix? ] [ "libvorbis.so" ] }
} cond "cdecl" add-library
+
+"vorbis" deploy-library
>>
LIBRARY: vorbis
--- /dev/null
+! Copyright (C) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel accessors arrays alien system combinators\r
+alien.syntax namespaces alien.c-types sequences vocabs.loader\r
+shuffle openal openal.alut.backend alien.libraries generalizations\r
+specialized-arrays alien.destructors ;\r
+FROM: alien.c-types => float short ;\r
+SPECIALIZED-ARRAY: uint\r
+IN: openal.alut\r
+\r
+<< "alut" {\r
+ { [ os windows? ] [ "alut.dll" ] }\r
+ { [ os macosx? ] [\r
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"\r
+ ] }\r
+ { [ os unix? ] [ "libalut.so" ] }\r
+ } cond "cdecl" add-library >>\r
+\r
+<< os macosx? [ "alut" deploy-library ] unless >>\r
+\r
+LIBRARY: alut\r
+\r
+CONSTANT: ALUT_API_MAJOR_VERSION 1\r
+CONSTANT: ALUT_API_MINOR_VERSION 1\r
+CONSTANT: ALUT_ERROR_NO_ERROR 0\r
+CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200\r
+CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201\r
+CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202\r
+CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203\r
+CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204\r
+CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205\r
+CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206\r
+CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207\r
+CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208\r
+CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209\r
+CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A\r
+CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B\r
+CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C\r
+CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D\r
+CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E\r
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F\r
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210\r
+CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211\r
+CONSTANT: ALUT_WAVEFORM_SINE HEX: 100\r
+CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101\r
+CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102\r
+CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103\r
+CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104\r
+CONSTANT: ALUT_LOADER_BUFFER HEX: 300\r
+CONSTANT: ALUT_LOADER_MEMORY HEX: 301\r
+\r
+FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;\r
+FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;\r
+FUNCTION: ALboolean alutExit ( ) ;\r
+FUNCTION: ALenum alutGetError ( ) ;\r
+FUNCTION: char* alutGetErrorString ( ALenum error ) ;\r
+FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;\r
+FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;\r
+FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;\r
+FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;\r
+FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;\r
+FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;\r
+FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;\r
+FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;\r
+FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;\r
+FUNCTION: ALint alutGetMajorVersion ( ) ;\r
+FUNCTION: ALint alutGetMinorVersion ( ) ;\r
+FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;\r
+\r
+FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;\r
+\r
+SYMBOL: init\r
+\r
+: init-openal ( -- )\r
+ init get-global expired? [\r
+ f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when\r
+ 1337 <alien> init set-global\r
+ ] when ;\r
+\r
+: exit-openal ( -- )\r
+ init get-global expired? [\r
+ alutExit 0 = [ "Could not close OpenAL" throw ] when\r
+ f init set-global\r
+ ] unless ;\r
+\r
+: create-buffer-from-file ( filename -- buffer )\r
+ alutCreateBufferFromFile dup AL_NONE = [\r
+ "create-buffer-from-file failed" throw\r
+ ] when ;\r
+\r
+os macosx? "openal.alut.macosx" "openal.alut.other" ? require\r
+\r
+: create-buffer-from-wav ( filename -- buffer )\r
+ gen-buffer dup rot load-wav-file\r
+ [ alBufferData ] 4 nkeep alutUnloadWAV ;\r
+\r
+: check-error ( -- )\r
+ alGetError dup ALUT_ERROR_NO_ERROR = [\r
+ drop\r
+ ] [\r
+ alGetString throw\r
+ ] if ;\r
+\r
--- /dev/null
+Chris Double
--- /dev/null
+USING: namespaces system ;
+IN: openal.alut.backend
+
+HOOK: load-wav-file os ( filename -- format data size frequency )
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel alien alien.syntax shuffle
+openal openal.alut.backend namespaces system generalizations ;
+IN: openal.alut.macosx
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
+
+M: macosx load-wav-file ( path -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ alutLoadWAVFile ] 4 nkeep
+ [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax combinators generalizations
+kernel openal openal.alut.backend ;
+IN: openal.alut.other
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
+
+M: object load-wav-file ( filename -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ 0 <char> alutLoadWAVFile ] 4 nkeep
+ { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: namespaces system ;
-IN: openal.backend
-
-HOOK: load-wav-file os ( filename -- format data size frequency )
! Copyright (C) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar kernel openal sequences threads ;\r
+USING: calendar kernel openal openal.alut sequences threads ;\r
IN: openal.example\r
\r
: play-hello ( -- )\r
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel alien alien.syntax shuffle
-openal openal.backend namespaces system generalizations ;
-IN: openal.macosx
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
-
-M: macosx load-wav-file ( path -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ alutLoadWAVFile ] 4 nkeep
- [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
+++ /dev/null
-unportable
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors arrays alien system combinators
alien.syntax namespaces alien.c-types sequences vocabs.loader
-shuffle openal.backend alien.libraries generalizations
+shuffle alien.libraries generalizations
specialized-arrays alien.destructors ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: uint
IN: openal
-<< "alut" {
- { [ os windows? ] [ "alut.dll" ] }
- { [ os macosx? ] [
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"
- ] }
- { [ os unix? ] [ "libalut.so" ] }
- } cond "cdecl" add-library >>
-
<< "openal" {
{ [ os windows? ] [ "OpenAL32.dll" ] }
{ [ os macosx? ] [
{ [ os unix? ] [ "libopenal.so" ] }
} cond "cdecl" add-library >>
+<< os macosx? [ "openal" deploy-library ] unless >>
+
LIBRARY: openal
TYPEDEF: char ALboolean
DESTRUCTOR: alcCloseDevice*
DESTRUCTOR: alcDestroyContext
-LIBRARY: alut
-
-CONSTANT: ALUT_API_MAJOR_VERSION 1
-CONSTANT: ALUT_API_MINOR_VERSION 1
-CONSTANT: ALUT_ERROR_NO_ERROR 0
-CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
-CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
-CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
-CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
-CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
-CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
-CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
-CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
-CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
-CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
-CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
-CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
-CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
-CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
-CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
-CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
-CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
-CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
-CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
-CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
-CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
-CONSTANT: ALUT_LOADER_BUFFER HEX: 300
-CONSTANT: ALUT_LOADER_MEMORY HEX: 301
-
-FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutExit ( ) ;
-FUNCTION: ALenum alutGetError ( ) ;
-FUNCTION: char* alutGetErrorString ( ALenum error ) ;
-FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
-FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
-FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
-FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
-FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
-FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
-FUNCTION: ALint alutGetMajorVersion ( ) ;
-FUNCTION: ALint alutGetMinorVersion ( ) ;
-FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
-
-FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
-
-SYMBOL: init
-
-: init-openal ( -- )
- init get-global expired? [
- f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
- 1337 <alien> init set-global
- ] when ;
-
-: exit-openal ( -- )
- init get-global expired? [
- alutExit 0 = [ "Could not close OpenAL" throw ] when
- f init set-global
- ] unless ;
-
: gen-sources ( size -- seq )
dup <uint-array> [ alGenSources ] keep ;
: gen-buffer ( -- buffer ) 1 gen-buffers first ;
-: create-buffer-from-file ( filename -- buffer )
- alutCreateBufferFromFile dup AL_NONE = [
- "create-buffer-from-file failed" throw
- ] when ;
-
-os macosx? "openal.macosx" "openal.other" ? require
-
-: create-buffer-from-wav ( filename -- buffer )
- gen-buffer dup rot load-wav-file
- [ alBufferData ] 4 nkeep alutUnloadWAV ;
-
: queue-buffers ( source buffers -- )
[ length ] [ >uint-array ] bi alSourceQueueBuffers ;
: source-stop ( source -- ) alSourceStop ;
-: check-error ( -- )
- alGetError dup ALUT_ERROR_NO_ERROR = [
- drop
- ] [
- alGetString throw
- ] if ;
-
: source-playing? ( source -- bool )
AL_SOURCE_STATE get-source-param AL_PLAYING = ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax combinators generalizations
-kernel openal openal.backend ;
-IN: openal.other
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
-
-M: object load-wav-file ( filename -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ 0 <char> alutLoadWAVFile ] 4 nkeep
- { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
-USING: classes.struct cocoa cocoa.application cocoa.classes
-cocoa.enumeration cocoa.plists core-foundation.strings kernel ;
+USING: alien.c-types classes.struct cocoa cocoa.application
+cocoa.classes cocoa.enumeration cocoa.plists core-foundation
+core-foundation.strings kernel ;
IN: qtkit
STRUCT: QTTime
+++ /dev/null
-unportable
math
math.order
openal
+ openal.alut
opengl.gl
sequences
ui
HELP: run-spider
{ $values
- { "spider" spider }
{ "spider" spider } }
{ $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel namespaces make openal sequences
+USING: accessors arrays kernel namespaces make openal openal.alut sequences
synth synth.buffers ;
IN: synth.example
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
+USING: accessors kernel locals math math.constants math.functions memoize openal openal.alut synth.buffers sequences sequences.modified sequences.repeating ;
IN: synth
MEMO: single-sine-wave ( samples/wave -- seq )
tools
applications
demos
-networking
+network
+++ /dev/null
-unportable
<login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
<pastebin> <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> "builds.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
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
main-responder set-global ;
--- /dev/null
+USING: alien.strings io.encodings.utf16n windows.com\r
+windows.com.wrapper combinators windows.kernel32 windows.ole32\r
+windows.shell32 kernel accessors windows.types\r
+prettyprint namespaces ui.tools.listener ui.tools.workspace\r
+alien.data alien sequences math classes.struct ;\r
+SPECIALIZED-ARRAY: WCHAR\r
+IN: windows.dragdrop-listener\r
+\r
+: filenames-from-hdrop ( hdrop -- filenames )\r
+ dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
+ [\r
+ 2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
+ dup WCHAR <c-array>\r
+ [ swap DragQueryFile drop ] keep\r
+ utf16n alien>string\r
+ ] with map ;\r
+\r
+: filenames-from-data-object ( data-object -- filenames )\r
+ FORMATETC <struct>\r
+ CF_HDROP >>cfFormat\r
+ f >>ptd\r
+ DVASPECT_CONTENT >>dwAspect\r
+ -1 >>lindex\r
+ TYMED_HGLOBAL >>tymed\r
+ STGMEDIUM <struct>\r
+ [ IDataObject::GetData ] keep swap succeeded? [\r
+ dup data>>\r
+ [ filenames-from-hdrop ] with-global-lock\r
+ swap ReleaseStgMedium\r
+ ] [ drop f ] if ;\r
+\r
+TUPLE: listener-dragdrop hWnd last-drop-effect ;\r
+\r
+: <listener-dragdrop> ( hWnd -- object )\r
+ DROPEFFECT_NONE listener-dragdrop construct-boa ;\r
+\r
+SYMBOL: +listener-dragdrop-wrapper+\r
+{\r
+ { "IDropTarget" {\r
+ [ ! DragEnter\r
+ [\r
+ 2drop\r
+ filenames-from-data-object\r
+ length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if\r
+ dup 0\r
+ ] dip set-ulong-nth\r
+ >>last-drop-effect drop\r
+ S_OK\r
+ ] [ ! DragOver\r
+ [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth\r
+ S_OK\r
+ ] [ ! DragLeave\r
+ drop S_OK\r
+ ] [ ! Drop\r
+ [\r
+ 2drop nip\r
+ filenames-from-data-object\r
+ dup length 1 = [\r
+ first unparse [ "USE: parser " % % " run-file" % ] "" make\r
+ eval-listener\r
+ DROPEFFECT_COPY\r
+ ] [ 2drop DROPEFFECT_NONE ] if\r
+ 0\r
+ ] dip set-ulong-nth\r
+ S_OK\r
+ ]\r
+ } }\r
+} <com-wrapper> +listener-dragdrop-wrapper+ set-global\r
+\r
+: dragdrop-listener-window ( -- )\r
+ get-workspace parent>> handle>> hWnd>>\r
+ dup <listener-dragdrop>\r
+ +listener-dragdrop-wrapper+ get-global com-wrap\r
+ [ RegisterDragDrop ole32-error ] with-com-interface ;\r
-fraptor ICON "misc/icons/Factor.ico"
+APPICON ICON "misc/icons/Factor.ico"
projects / factor.git / commitdiff