Merge branch 'master' of git://factorcode.org/git/factor into bitfields

db4
Daniel Ehrenberg 2009-10-08 14:19:20 -05:00
commit baf754236f
44 changed files with 154 additions and 117 deletions

View File

@ -56,7 +56,6 @@ $nl
{ $subsections { $subsections
malloc-object malloc-object
malloc-byte-array malloc-byte-array
malloc-file-contents
} }
"The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:" "The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:"
{ $subsections { $subsections

View File

@ -56,9 +56,6 @@ M: word <c-direct-array>
: malloc-string ( string encoding -- alien ) : malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ; string>alien malloc-byte-array ;
: malloc-file-contents ( path -- alien len )
binary file-contents [ malloc-byte-array ] [ length ] bi ;
M: memory-stream stream-read M: memory-stream stream-read
[ [
[ index>> ] [ alien>> ] bi <displaced-alien> [ index>> ] [ alien>> ] bi <displaced-alien>
@ -81,3 +78,4 @@ M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ; '[ @ swap @ _ memcpy ] ;

View File

@ -10,7 +10,7 @@ IN: alien.parser
: parse-c-type-name ( name -- word ) : parse-c-type-name ( name -- word )
dup search [ nip ] [ no-word ] if* ; dup search [ nip ] [ no-word ] if* ;
: parse-c-type ( string -- array ) : parse-c-type ( string -- type )
{ {
{ [ dup "void" = ] [ drop void ] } { [ dup "void" = ] [ drop void ] }
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] } { [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }

View File

@ -324,6 +324,46 @@ HOOK: %shr-vector-reps cpu ( -- reps )
HOOK: %horizontal-shl-vector-reps cpu ( -- reps ) HOOK: %horizontal-shl-vector-reps cpu ( -- reps )
HOOK: %horizontal-shr-vector-reps cpu ( -- reps ) HOOK: %horizontal-shr-vector-reps cpu ( -- reps )
M: object %zero-vector-reps { } ;
M: object %fill-vector-reps { } ;
M: object %gather-vector-2-reps { } ;
M: object %gather-vector-4-reps { } ;
M: object %shuffle-vector-reps { } ;
M: object %merge-vector-reps { } ;
M: object %signed-pack-vector-reps { } ;
M: object %unsigned-pack-vector-reps { } ;
M: object %unpack-vector-head-reps { } ;
M: object %unpack-vector-tail-reps { } ;
M: object %integer>float-vector-reps { } ;
M: object %float>integer-vector-reps { } ;
M: object %compare-vector-reps drop { } ;
M: object %compare-vector-ccs 2drop { } f ;
M: object %test-vector-reps { } ;
M: object %add-vector-reps { } ;
M: object %saturated-add-vector-reps { } ;
M: object %add-sub-vector-reps { } ;
M: object %sub-vector-reps { } ;
M: object %saturated-sub-vector-reps { } ;
M: object %mul-vector-reps { } ;
M: object %saturated-mul-vector-reps { } ;
M: object %div-vector-reps { } ;
M: object %min-vector-reps { } ;
M: object %max-vector-reps { } ;
M: object %dot-vector-reps { } ;
M: object %sqrt-vector-reps { } ;
M: object %horizontal-add-vector-reps { } ;
M: object %horizontal-sub-vector-reps { } ;
M: object %abs-vector-reps { } ;
M: object %and-vector-reps { } ;
M: object %andn-vector-reps { } ;
M: object %or-vector-reps { } ;
M: object %xor-vector-reps { } ;
M: object %not-vector-reps { } ;
M: object %shl-vector-reps { } ;
M: object %shr-vector-reps { } ;
M: object %horizontal-shl-vector-reps { } ;
M: object %horizontal-shr-vector-reps { } ;
HOOK: %unbox-alien cpu ( dst src -- ) HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- ) HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- ) HOOK: %box-alien cpu ( dst src temp -- )

View File

@ -256,45 +256,6 @@ M:: ppc %binary-float-function ( dst src1 src2 func -- )
M: ppc %single>double-float double-rep %copy ; M: ppc %single>double-float double-rep %copy ;
M: ppc %double>single-float double-rep %copy ; M: ppc %double>single-float double-rep %copy ;
! VMX/AltiVec not supported yet
M: ppc %zero-vector-reps { } ;
M: ppc %fill-vector-reps { } ;
M: ppc %gather-vector-2-reps { } ;
M: ppc %gather-vector-4-reps { } ;
M: ppc %shuffle-vector-reps { } ;
M: ppc %merge-vector-reps { } ;
M: ppc %signed-pack-vector-reps { } ;
M: ppc %unsigned-pack-vector-reps { } ;
M: ppc %unpack-vector-reps { } ;
M: ppc %integer>float-vector-reps { } ;
M: ppc %float>integer-vector-reps { } ;
M: ppc %compare-vector-reps drop { } ;
M: ppc %test-vector-reps { } ;
M: ppc %add-vector-reps { } ;
M: ppc %saturated-add-vector-reps { } ;
M: ppc %add-sub-vector-reps { } ;
M: ppc %sub-vector-reps { } ;
M: ppc %saturated-sub-vector-reps { } ;
M: ppc %mul-vector-reps { } ;
M: ppc %saturated-mul-vector-reps { } ;
M: ppc %div-vector-reps { } ;
M: ppc %min-vector-reps { } ;
M: ppc %max-vector-reps { } ;
M: ppc %dot-vector-reps { } ;
M: ppc %sqrt-vector-reps { } ;
M: ppc %horizontal-add-vector-reps { } ;
M: ppc %horizontal-sub-vector-reps { } ;
M: ppc %abs-vector-reps { } ;
M: ppc %and-vector-reps { } ;
M: ppc %andn-vector-reps { } ;
M: ppc %or-vector-reps { } ;
M: ppc %xor-vector-reps { } ;
M: ppc %not-vector-reps { } ;
M: ppc %shl-vector-reps { } ;
M: ppc %shr-vector-reps { } ;
M: ppc %horizontal-shl-vector-reps { } ;
M: ppc %horizontal-shr-vector-reps { } ;
M: ppc %unbox-alien ( dst src -- ) M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ; alien-offset LWZ ;

View File

@ -1 +0,0 @@
DirectInput backend for game-input

View File

@ -1 +0,0 @@
IOKit HID Manager backend for game-input

View File

@ -1,6 +1,6 @@
USING: accessors alien alien.c-types alien.strings arrays USING: accessors alien alien.c-types alien.strings arrays
assocs byte-arrays combinators combinators.short-circuit assocs byte-arrays combinators combinators.short-circuit
continuations game-input game-input.dinput.keys-array continuations game.input game.input.dinput.keys-array
io.encodings.utf16 io.encodings.utf16n kernel locals math io.encodings.utf16 io.encodings.utf16n kernel locals math
math.bitwise math.rectangles namespaces parser sequences math.bitwise math.rectangles namespaces parser sequences
shuffle specialized-arrays ui.backend.windows vectors shuffle specialized-arrays ui.backend.windows vectors
@ -8,7 +8,7 @@ windows.com windows.dinput windows.dinput.constants
windows.errors windows.kernel32 windows.messages windows.errors windows.kernel32 windows.messages
windows.ole32 windows.user32 classes.struct alien.data ; windows.ole32 windows.user32 classes.struct alien.data ;
SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game-input.dinput IN: game.input.dinput
CONSTANT: MOUSE-BUFFER-SIZE 16 CONSTANT: MOUSE-BUFFER-SIZE 16

View File

@ -1,6 +1,6 @@
USING: sequences sequences.private math USING: sequences sequences.private math
accessors alien.data ; accessors alien.data ;
IN: game-input.dinput.keys-array IN: game.input.dinput.keys-array
TUPLE: keys-array TUPLE: keys-array
{ underlying sequence read-only } { underlying sequence read-only }

View File

@ -0,0 +1 @@
DirectInput backend for game.input

View File

@ -1,9 +1,9 @@
USING: help.markup help.syntax kernel ui.gestures quotations USING: help.markup help.syntax kernel ui.gestures quotations
sequences strings math ; sequences strings math ;
IN: game-input IN: game.input
ARTICLE: "game-input" "Game controller input" ARTICLE: "game-input" "Game controller input"
"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl "The " { $vocab-link "game.input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
"The game input interface must be initialized before being used:" "The game input interface must be initialized before being used:"
{ $subsections { $subsections
open-game-input open-game-input
@ -136,8 +136,8 @@ HELP: controller-state
{ "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." } } } ; { "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 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 under usage page 7 of 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" } "." } ; { $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 HELP: mouse-state
{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:" { $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"

View File

@ -1,6 +1,6 @@
USING: ui game-input tools.test kernel system threads calendar USING: ui game.input tools.test kernel system threads calendar
combinators.short-circuit ; combinators.short-circuit ;
IN: game-input.tests IN: game.input.tests
os { [ windows? ] [ macosx? ] } 1|| [ os { [ windows? ] [ macosx? ] } 1|| [
[ ] [ open-game-input ] unit-test [ ] [ open-game-input ] unit-test

View File

@ -1,6 +1,6 @@
USING: arrays accessors continuations kernel math system USING: arrays accessors continuations kernel math system
sequences namespaces init vocabs vocabs.loader combinators ; sequences namespaces init vocabs vocabs.loader combinators ;
IN: game-input IN: game.input
SYMBOLS: game-input-backend game-input-opened ; SYMBOLS: game-input-backend game-input-opened ;
@ -91,7 +91,7 @@ M: mouse-state clone
call-next-method dup buttons>> clone >>buttons ; call-next-method dup buttons>> clone >>buttons ;
{ {
{ [ os windows? ] [ "game-input.dinput" require ] } { [ os windows? ] [ "game.input.dinput" require ] }
{ [ os macosx? ] [ "game-input.iokit" require ] } { [ os macosx? ] [ "game.input.iokit" require ] }
{ [ t ] [ ] } { [ t ] [ ] }
} cond } cond

View File

@ -3,9 +3,9 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit threads sequences locals combinators.short-circuit threads
namespaces assocs arrays combinators hints alien namespaces assocs arrays combinators hints alien
core-foundation.run-loop accessors sequences.private core-foundation.run-loop accessors sequences.private
alien.c-types alien.data math parser game-input vectors alien.c-types alien.data math parser game.input vectors
bit-arrays ; bit-arrays ;
IN: game-input.iokit IN: game.input.iokit
SINGLETON: iokit-game-input-backend SINGLETON: iokit-game-input-backend

View File

@ -0,0 +1 @@
IOKit HID Manager backend for game.input

View File

@ -1,4 +1,4 @@
IN: game-input.scancodes IN: game.input.scancodes
CONSTANT: key-undefined HEX: 0000 CONSTANT: key-undefined HEX: 0000
CONSTANT: key-error-roll-over HEX: 0001 CONSTANT: key-error-roll-over HEX: 0001

View File

@ -303,6 +303,12 @@ HELP: ntuck
} }
{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; { $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
HELP: nspin
{ $values
{ "n" integer }
}
{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ;
ARTICLE: "sequence-generalizations" "Generalized sequence operations" ARTICLE: "sequence-generalizations" "Generalized sequence operations"
{ $subsections { $subsections
narray narray
@ -321,6 +327,7 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
nnip nnip
ndrop ndrop
ntuck ntuck
nspin
mnswap mnswap
nweave nweave
} ; } ;

View File

@ -26,6 +26,8 @@ IN: generalizations.tests
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
[ [ 1 ] 5 ndip ] must-infer [ [ 1 ] 5 ndip ] must-infer
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
[ 5 nspin ] must-infer
[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test

View File

@ -2,22 +2,19 @@
! Cavazos, Slava Pestov. ! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math combinators USING: kernel sequences sequences.private math combinators
macros quotations fry effects ; macros quotations fry effects memoize.private ;
IN: generalizations IN: generalizations
<< <<
: n*quot ( n quot -- quot' ) <repetition> concat >quotation ; ALIAS: n*quot (n*quot)
: repeat ( n obj quot -- ) swapd times ; inline : repeat ( n obj quot -- ) swapd times ; inline
>> >>
MACRO: nsequence ( n seq -- ) MACRO: nsequence ( n seq -- )
[ [ [nsequence] ] keep
[ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ; '[ @ _ like ] ;
MACRO: narray ( n -- ) MACRO: narray ( n -- )
@ -27,7 +24,7 @@ MACRO: nsum ( n -- )
1 - [ + ] n*quot ; 1 - [ + ] n*quot ;
MACRO: firstn-unsafe ( n -- ) MACRO: firstn-unsafe ( n -- )
iota [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ; [firstn] ;
MACRO: firstn ( n -- ) MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [ dup zero? [ drop [ drop ] ] [
@ -104,3 +101,6 @@ MACRO: nbi-curry ( n -- )
[ narray concat ] dip like ; inline [ narray concat ] dip like ; inline
: nappend ( n -- seq ) narray concat ; inline : nappend ( n -- seq ) narray concat ; inline
MACRO: nspin ( n -- )
[ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;

View File

@ -39,32 +39,45 @@ ERROR: bad-vconvert-input value expected-type ;
} cond } cond
[ from-type check-vconvert-type ] prepose ; [ from-type check-vconvert-type ] prepose ;
:: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot ) :: check-vpack ( from-element to-element from-type to-type steps -- )
from-size to-size /i log2 :> steps
{ {
[ steps 1 = not ] [ steps 1 = not ]
[ from-element to-element [ float-type? ] bi@ xor ] [ from-element to-element [ float-type? ] bi@ xor ]
[ from-element unsigned-type? to-element unsigned-type? not and ] [ from-element unsigned-type? to-element unsigned-type? not and ]
} 0|| [ from-type to-type bad-vconvert ] when } 0|| [ from-type to-type bad-vconvert ] when ;
to-element unsigned-type? [ to-type (vpack-unsigned) ] [ to-type (vpack-signed) ] ? :: [[vpack-unsigned]] ( from-type to-type -- quot )
[ [ from-type check-vconvert-type ] bi@ ] prepose ; [ [ from-type check-vconvert-type ] bi@ to-type (vpack-unsigned) ] ;
:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot ) :: [[vpack-signed]] ( from-type to-type -- quot )
to-size from-size /i log2 :> steps [ [ from-type check-vconvert-type ] bi@ to-type (vpack-signed) ] ;
:: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot )
from-size to-size /i log2 :> steps
from-element to-element from-type to-type steps check-vpack
from-type to-type to-element unsigned-type?
[ [[vpack-unsigned]] ] [ [[vpack-signed]] ] if ;
:: check-vunpack ( from-element to-element from-type to-type steps -- )
{ {
[ steps 1 = not ] [ steps 1 = not ]
[ from-element to-element [ float-type? ] bi@ xor ] [ from-element to-element [ float-type? ] bi@ xor ]
[ from-element unsigned-type? not to-element unsigned-type? and ] [ from-element unsigned-type? not to-element unsigned-type? and ]
} 0|| [ from-type to-type bad-vconvert ] when } 0|| [ from-type to-type bad-vconvert ] when ;
:: [[vunpack]] ( from-type to-type -- quot )
[ [
from-type check-vconvert-type from-type check-vconvert-type
[ to-type (vunpack-head) ] [ to-type (vunpack-tail) ] bi [ to-type (vunpack-head) ] [ to-type (vunpack-tail) ] bi
] ; ] ;
:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
to-size from-size /i log2 :> steps
from-element to-element from-type to-type steps check-vunpack
from-type to-type [[vunpack]] ;
PRIVATE> PRIVATE>
MACRO:: vconvert ( from-type to-type -- ) MACRO:: vconvert ( from-type to-type -- )

View File

@ -19,12 +19,10 @@ ABOUT: "memoize"
HELP: define-memoized HELP: define-memoized
{ $values { "word" word } { "quot" quotation } { "effect" effect } } { $values { "word" word } { "quot" quotation } { "effect" effect } }
{ $description "defines the given word at runtime as one which memoizes its output given a particular input" } { $description "Defines the given word at run time as one which memoizes its outputs given a particular input." } ;
{ $notes "A maximum of four input and four output arguments can be used" }
{ $see-also POSTPONE: MEMO: } ;
HELP: MEMO: HELP: MEMO:
{ $syntax "MEMO: word ( stack -- effect ) definition ;" } { $syntax "MEMO: word ( stack -- effect ) definition ;" }
{ $description "defines the given word at parsetime as one which memoizes its output given a particular input. The stack effect is mandatory." } { $description "Defines the given word at parse time as one which memoizes its output given a particular input. The stack effect is mandatory." } ;
{ $notes "A maximum of four input and four output arguments can be used" }
{ $see-also define-memoized } ; { define-memoized POSTPONE: MEMO: } related-words

View File

@ -7,9 +7,18 @@ IN: memoize.tests
MEMO: fib ( m -- n ) MEMO: fib ( m -- n )
dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
MEMO: x ( a b c d e -- f g h i j )
[ 1 + ] 4 ndip ;
[ 89 ] [ 10 fib ] unit-test [ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail [
1 0 0 0 0
1 0 0 0 0
] [
0 0 0 0 0 x
0 0 0 0 0 x
] unit-test
MEMO: see-test ( a -- b ) reverse ; MEMO: see-test ( a -- b ) reverse ;

View File

@ -1,22 +1,36 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel hashtables sequences arrays words namespaces make USING: kernel hashtables sequences sequences.private arrays
parser math assocs effects definitions quotations summary words namespaces make parser math assocs effects definitions
accessors fry ; quotations summary accessors fry ;
IN: memoize IN: memoize
ERROR: too-many-arguments ;
M: too-many-arguments summary
drop "There must be no more than 4 input and 4 output arguments" ;
<PRIVATE <PRIVATE
! We can't use n*quot, narray and firstn from generalizations because
! they're macros, and macros use memoize!
: (n*quot) ( n quot -- quotquot )
<repetition> concat >quotation ;
: [nsequence] ( length exemplar -- quot )
[ [ [ 1 - ] keep ] dip '[ _ _ _ new-sequence ] ]
[ drop [ [ set-nth-unsafe ] 2keep [ 1 - ] dip ] (n*quot) ] 2bi
[ nip ] 3append ;
: [firstn] ( length -- quot )
[ 0 swap ] swap
[ [ nth-unsafe ] 2keep [ 1 + ] dip ] (n*quot)
[ 2drop ] 3append ;
: packer ( seq -- quot ) : packer ( seq -- quot )
length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ; length dup 4 <=
[ { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ]
[ { } [nsequence] ] if ;
: unpacker ( seq -- quot ) : unpacker ( seq -- quot )
length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ; length dup 4 <=
[ { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ]
[ [firstn] ] if ;
: pack/unpack ( quot effect -- newquot ) : pack/unpack ( quot effect -- newquot )
[ in>> packer ] [ out>> unpacker ] bi surround ; [ in>> packer ] [ out>> unpacker ] bi surround ;
@ -24,11 +38,7 @@ M: too-many-arguments summary
: unpack/pack ( quot effect -- newquot ) : unpack/pack ( quot effect -- newquot )
[ in>> unpacker ] [ out>> packer ] bi surround ; [ in>> unpacker ] [ out>> packer ] bi surround ;
: check-memoized ( effect -- )
[ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ;
: make-memoizer ( table quot effect -- quot ) : make-memoizer ( table quot effect -- quot )
[ check-memoized ] keep
[ unpack/pack '[ _ _ cache ] ] keep [ unpack/pack '[ _ _ cache ] ] keep
pack/unpack ; pack/unpack ;

View File

@ -1,4 +1,4 @@
USING: calendar game-input threads ui ui.gadgets.worlds kernel USING: calendar game.input threads ui ui.gadgets.worlds kernel
method-chains system ; method-chains system ;
IN: tools.deploy.test.8 IN: tools.deploy.test.8

View File

@ -1,7 +1,7 @@
USING: accessors calendar continuations destructors kernel math USING: accessors calendar continuations destructors kernel math
math.order namespaces system threads ui ui.gadgets.worlds math.order namespaces system threads ui ui.gadgets.worlds
sequences ; sequences ;
IN: game-loop IN: game.loop
TUPLE: game-loop TUPLE: game-loop
{ tick-length integer read-only } { tick-length integer read-only }
@ -106,4 +106,4 @@ M: game-loop dispose
USING: vocabs vocabs.loader ; USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "game-loop.prettyprint" require ] when "prettyprint" vocab [ "game.loop.prettyprint" require ] when

View File

@ -1,6 +1,6 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: accessors debugger game-loop io ; USING: accessors debugger game.loop io ;
IN: game-loop.prettyprint IN: game.loop.prettyprint
M: game-loop-error error. M: game-loop-error error.
"An error occurred inside a game loop." print "An error occurred inside a game loop." print

View File

@ -1,6 +1,6 @@
USING: accessors game-input game-loop kernel math ui.gadgets USING: accessors game.input game.loop kernel math ui.gadgets
ui.gadgets.worlds ui.gestures threads ; ui.gadgets.worlds ui.gestures threads ;
IN: game-worlds IN: game.worlds
TUPLE: game-world < world TUPLE: game-world < world
game-loop game-loop

View File

@ -1,6 +1,6 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types arrays classes.struct combinators USING: accessors alien.c-types arrays classes.struct combinators
combinators.short-circuit game-worlds gpu gpu.buffers combinators.short-circuit game.worlds gpu gpu.buffers
gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
gpu.textures gpu.util grouping http.client images images.loader gpu.textures gpu.util grouping http.client images images.loader
io io.encodings.ascii io.files io.files.temp kernel math io io.encodings.ascii io.files io.files.temp kernel math

View File

@ -1,5 +1,5 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: accessors arrays combinators.tuple game-loop game-worlds USING: accessors arrays combinators.tuple game.loop game.worlds
generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd
kernel literals math math.matrices math.order math.vectors kernel literals math math.matrices math.order math.vectors
method-chains sequences ui ui.gadgets ui.gadgets.worlds method-chains sequences ui ui.gadgets ui.gadgets.worlds

View File

@ -1,6 +1,6 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: accessors arrays combinators.smart game-input USING: accessors arrays combinators.smart game.input
game-input.scancodes game-loop game-worlds game.input.scancodes game.loop game.worlds
gpu.render gpu.state kernel literals gpu.render gpu.state kernel literals
locals math math.constants math.functions math.matrices locals math math.constants math.functions math.matrices
math.order math.vectors opengl.gl sequences math.order math.vectors opengl.gl sequences

View File

@ -1,6 +1,6 @@
USING: ui ui.gadgets sequences kernel arrays math colors USING: ui ui.gadgets sequences kernel arrays math colors
colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
accessors fry ui.gadgets.packs game-input ui.gadgets.labels accessors fry ui.gadgets.packs game.input ui.gadgets.labels
ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ; combinators math.parser assocs threads ;
IN: joystick-demo IN: joystick-demo

View File

@ -1,4 +1,4 @@
USING: game-input game-input.scancodes USING: game.input game.input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors kernel ui.gadgets ui.gadgets.buttons sequences accessors
words arrays assocs math calendar fry alarms ui words arrays assocs math calendar fry alarms ui
ui.gadgets.borders ui.gestures ; ui.gadgets.borders ui.gestures ;

View File

@ -1,12 +1,12 @@
! (c)2009 Joe Groff, Doug Coleman. bsd license ! (c)2009 Joe Groff, Doug Coleman. bsd license
USING: accessors arrays combinators game-input game-loop USING: accessors arrays combinators game.input game.loop
game-input.scancodes grouping kernel literals locals game.input.scancodes grouping kernel literals locals
math math.constants math.functions math.matrices math.order math math.constants math.functions math.matrices math.order
math.vectors opengl opengl.capabilities opengl.gl math.vectors opengl opengl.capabilities opengl.gl
opengl.shaders opengl.textures opengl.textures.private opengl.shaders opengl.textures opengl.textures.private
sequences sequences.product specialized-arrays sequences sequences.product specialized-arrays
terrain.generation terrain.shaders ui ui.gadgets terrain.generation terrain.shaders ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats game-worlds method-chains ui.gadgets.worlds ui.pixel-formats game.worlds method-chains
math.affine-transforms noise ui.gestures combinators.short-circuit math.affine-transforms noise ui.gestures combinators.short-circuit
destructors grid-meshes ; destructors grid-meshes ;
FROM: alien.c-types => float ; FROM: alien.c-types => float ;

View File

@ -10,7 +10,7 @@ const char *vm_executable_path()
static Dl_info info = {0}; static Dl_info info = {0};
if (!info.dli_fname) if (!info.dli_fname)
dladdr((void *)main, &info); dladdr((void *)main, &info);
return info.dli_fname; return safe_strdup(info.dli_fname);
} }
} }