+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /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
: import-objc-class ( name quot -- )
over define-objc-class-word
- [ objc-class register-objc-methods ]
- [ objc-meta-class register-objc-methods ] bi ;
+ dup objc_getClass [
+ [ objc-class register-objc-methods ]
+ [ objc-meta-class 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
+++ /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?
-! 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?>>
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
-unportable
compiler
+untested
-unportable
+untested
compiler
-unportable
+untested
compiler
+++ /dev/null
-unportable
-unportable
+untested
compiler
+++ /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: 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 )
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 ] }
+++ /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
+++ /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
-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
+++ /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
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:"
: 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
--- /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
[ \ 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
! 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
-classes.tuple ;
+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 ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /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) 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 -- )
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 (" { $snippet "icon.ico" } " on Windows, or " { $snippet "icon.icns" } " on MacOS X), it will be embedded in the deployed application as its GUI icon." ;
+"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:"
+++ /dev/null
-unportable
+++ /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: 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
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
{ 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 }
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 ] }
+++ /dev/null
-unportable
--- /dev/null
+linux
+freebsd
+netbsd
+openbsd
+++ /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
+++ /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
}
-"Vocabulary resources:"
+"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
{ $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." }
-! 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 ;
: 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? ;
+ {
+ [ 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
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /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
+++ /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
-! 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 ;
: 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 ;
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: 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: ,
"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, four optional text files may contain metadata:"
-{ $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/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 "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 reuse." }
-}
-"An icon file representing the vocabulary can also be provided. 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."
-$nl
-"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:"
SYMBOL: blacklist
+! Defined by vocabs.metadata
+SYMBOL: check-vocab-hook
+
+check-vocab-hook [ [ drop ] ] initialize
+
<PRIVATE
: add-to-blacklist ( error vocab -- )
] [ [ 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) ;
+ [ check-vocab-hook get call( vocab -- ) ]
+ [ create-vocab (load-vocab) ]
+ bi ;
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
+++ /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
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 ;
+++ /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 )
bindings
-unportable
+untested
+++ /dev/null
-unportable
-
-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
+++ /dev/null
-unportable
-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
+++ /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
projects / factor.git / commitdiff