Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
ecba1f73fb
|
|
@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs
|
|||
vocabs.loader source-files definitions debugger quotations.private
|
||||
sequences.private combinators math.order math.private accessors
|
||||
slots.private generic.single.private compiler.units compiler.constants
|
||||
fry ;
|
||||
fry bootstrap.image.syntax ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
|
|
@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
|
|||
|
||||
M: integer (eql?) = ;
|
||||
|
||||
M: float (eql?)
|
||||
over float? [ fp-bitwise= ] [ 2drop f ] if ;
|
||||
|
||||
M: sequence (eql?)
|
||||
over sequence? [
|
||||
2dup [ length ] bi@ =
|
||||
|
|
@ -93,24 +96,19 @@ CONSTANT: -1-offset 9
|
|||
|
||||
SYMBOL: sub-primitives
|
||||
|
||||
SYMBOL: jit-define-rc
|
||||
SYMBOL: jit-define-rt
|
||||
SYMBOL: jit-define-offset
|
||||
SYMBOL: jit-relocations
|
||||
|
||||
: compute-offset ( -- offset )
|
||||
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
|
||||
: compute-offset ( rc -- offset )
|
||||
[ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
|
||||
|
||||
: jit-rel ( rc rt -- )
|
||||
jit-define-rt set
|
||||
jit-define-rc set
|
||||
compute-offset jit-define-offset set ;
|
||||
over compute-offset 3array jit-relocations get push-all ;
|
||||
|
||||
: make-jit ( quot -- quad )
|
||||
: make-jit ( quot -- jit-data )
|
||||
[
|
||||
V{ } clone jit-relocations set
|
||||
call( -- )
|
||||
jit-define-rc get
|
||||
jit-define-rt get
|
||||
jit-define-offset get 3array
|
||||
jit-relocations get >array
|
||||
] B{ } make prefix ;
|
||||
|
||||
: jit-define ( quot name -- )
|
||||
|
|
@ -128,98 +126,59 @@ SYMBOL: big-endian
|
|||
! Bootstrap architecture name
|
||||
SYMBOL: architecture
|
||||
|
||||
! Bootstrap global namesapce
|
||||
SYMBOL: bootstrap-global
|
||||
RESET
|
||||
|
||||
! Boot quotation, set in stage1.factor
|
||||
SYMBOL: bootstrap-boot-quot
|
||||
USERENV: bootstrap-boot-quot 20
|
||||
|
||||
! Bootstrap global namesapce
|
||||
USERENV: bootstrap-global 21
|
||||
|
||||
! JIT parameters
|
||||
SYMBOL: jit-prolog
|
||||
SYMBOL: jit-primitive-word
|
||||
SYMBOL: jit-primitive
|
||||
SYMBOL: jit-word-jump
|
||||
SYMBOL: jit-word-call
|
||||
SYMBOL: jit-push-immediate
|
||||
SYMBOL: jit-if-word
|
||||
SYMBOL: jit-if-1
|
||||
SYMBOL: jit-if-2
|
||||
SYMBOL: jit-dip-word
|
||||
SYMBOL: jit-dip
|
||||
SYMBOL: jit-2dip-word
|
||||
SYMBOL: jit-2dip
|
||||
SYMBOL: jit-3dip-word
|
||||
SYMBOL: jit-3dip
|
||||
SYMBOL: jit-execute-word
|
||||
SYMBOL: jit-execute-jump
|
||||
SYMBOL: jit-execute-call
|
||||
SYMBOL: jit-epilog
|
||||
SYMBOL: jit-return
|
||||
SYMBOL: jit-profiling
|
||||
SYMBOL: jit-save-stack
|
||||
USERENV: jit-prolog 23
|
||||
USERENV: jit-primitive-word 24
|
||||
USERENV: jit-primitive 25
|
||||
USERENV: jit-word-jump 26
|
||||
USERENV: jit-word-call 27
|
||||
USERENV: jit-word-special 28
|
||||
USERENV: jit-if-word 29
|
||||
USERENV: jit-if 30
|
||||
USERENV: jit-epilog 31
|
||||
USERENV: jit-return 32
|
||||
USERENV: jit-profiling 33
|
||||
USERENV: jit-push-immediate 34
|
||||
USERENV: jit-dip-word 35
|
||||
USERENV: jit-dip 36
|
||||
USERENV: jit-2dip-word 37
|
||||
USERENV: jit-2dip 38
|
||||
USERENV: jit-3dip-word 39
|
||||
USERENV: jit-3dip 40
|
||||
USERENV: jit-execute-word 41
|
||||
USERENV: jit-execute-jump 42
|
||||
USERENV: jit-execute-call 43
|
||||
|
||||
! PIC stubs
|
||||
SYMBOL: pic-load
|
||||
SYMBOL: pic-tag
|
||||
SYMBOL: pic-hi-tag
|
||||
SYMBOL: pic-tuple
|
||||
SYMBOL: pic-hi-tag-tuple
|
||||
SYMBOL: pic-check-tag
|
||||
SYMBOL: pic-check
|
||||
SYMBOL: pic-hit
|
||||
SYMBOL: pic-miss-word
|
||||
USERENV: pic-load 47
|
||||
USERENV: pic-tag 48
|
||||
USERENV: pic-hi-tag 49
|
||||
USERENV: pic-tuple 50
|
||||
USERENV: pic-hi-tag-tuple 51
|
||||
USERENV: pic-check-tag 52
|
||||
USERENV: pic-check 53
|
||||
USERENV: pic-hit 54
|
||||
USERENV: pic-miss-word 55
|
||||
USERENV: pic-miss-tail-word 56
|
||||
|
||||
! Megamorphic dispatch
|
||||
SYMBOL: mega-lookup
|
||||
SYMBOL: mega-lookup-word
|
||||
SYMBOL: mega-miss-word
|
||||
USERENV: mega-lookup 57
|
||||
USERENV: mega-lookup-word 58
|
||||
USERENV: mega-miss-word 59
|
||||
|
||||
! Default definition for undefined words
|
||||
SYMBOL: undefined-quot
|
||||
|
||||
: userenvs ( -- assoc )
|
||||
H{
|
||||
{ bootstrap-boot-quot 20 }
|
||||
{ bootstrap-global 21 }
|
||||
{ jit-prolog 23 }
|
||||
{ jit-primitive-word 24 }
|
||||
{ jit-primitive 25 }
|
||||
{ jit-word-jump 26 }
|
||||
{ jit-word-call 27 }
|
||||
{ jit-if-word 28 }
|
||||
{ jit-if-1 29 }
|
||||
{ jit-if-2 30 }
|
||||
{ jit-epilog 33 }
|
||||
{ jit-return 34 }
|
||||
{ jit-profiling 35 }
|
||||
{ jit-push-immediate 36 }
|
||||
{ jit-save-stack 38 }
|
||||
{ jit-dip-word 39 }
|
||||
{ jit-dip 40 }
|
||||
{ jit-2dip-word 41 }
|
||||
{ jit-2dip 42 }
|
||||
{ jit-3dip-word 43 }
|
||||
{ jit-3dip 44 }
|
||||
{ jit-execute-word 45 }
|
||||
{ jit-execute-jump 46 }
|
||||
{ jit-execute-call 47 }
|
||||
{ pic-load 48 }
|
||||
{ pic-tag 49 }
|
||||
{ pic-hi-tag 50 }
|
||||
{ pic-tuple 51 }
|
||||
{ pic-hi-tag-tuple 52 }
|
||||
{ pic-check-tag 53 }
|
||||
{ pic-check 54 }
|
||||
{ pic-hit 55 }
|
||||
{ pic-miss-word 56 }
|
||||
{ mega-lookup 57 }
|
||||
{ mega-lookup-word 58 }
|
||||
{ mega-miss-word 59 }
|
||||
{ undefined-quot 60 }
|
||||
} ; inline
|
||||
USERENV: undefined-quot 60
|
||||
|
||||
: userenv-offset ( symbol -- n )
|
||||
userenvs at header-size + ;
|
||||
userenvs get at header-size + ;
|
||||
|
||||
: emit ( cell -- ) image get push ;
|
||||
|
||||
|
|
@ -351,7 +310,8 @@ M: f '
|
|||
[ vocabulary>> , ]
|
||||
[ def>> , ]
|
||||
[ props>> , ]
|
||||
[ direct-entry-def>> , ] ! direct-entry-def
|
||||
[ pic-def>> , ]
|
||||
[ pic-tail-def>> , ]
|
||||
[ drop 0 , ] ! count
|
||||
[ word-sub-primitive , ]
|
||||
[ drop 0 , ] ! xt
|
||||
|
|
@ -510,11 +470,7 @@ M: quotation '
|
|||
class<=-cache class-not-cache classes-intersect-cache
|
||||
class-and-cache class-or-cache next-method-quot-cache
|
||||
} [ H{ } clone ] H{ } map>assoc assoc-union
|
||||
bootstrap-global set
|
||||
bootstrap-global emit-userenv ;
|
||||
|
||||
: emit-boot-quot ( -- )
|
||||
bootstrap-boot-quot emit-userenv ;
|
||||
bootstrap-global set ;
|
||||
|
||||
: emit-jit-data ( -- )
|
||||
\ if jit-if-word set
|
||||
|
|
@ -524,46 +480,13 @@ M: quotation '
|
|||
\ 3dip jit-3dip-word set
|
||||
\ (execute) jit-execute-word set
|
||||
\ inline-cache-miss \ pic-miss-word set
|
||||
\ inline-cache-miss-tail \ pic-miss-tail-word set
|
||||
\ mega-cache-lookup \ mega-lookup-word set
|
||||
\ mega-cache-miss \ mega-miss-word set
|
||||
[ undefined ] undefined-quot set
|
||||
{
|
||||
jit-prolog
|
||||
jit-primitive-word
|
||||
jit-primitive
|
||||
jit-word-jump
|
||||
jit-word-call
|
||||
jit-push-immediate
|
||||
jit-if-word
|
||||
jit-if-1
|
||||
jit-if-2
|
||||
jit-dip-word
|
||||
jit-dip
|
||||
jit-2dip-word
|
||||
jit-2dip
|
||||
jit-3dip-word
|
||||
jit-3dip
|
||||
jit-execute-word
|
||||
jit-execute-jump
|
||||
jit-execute-call
|
||||
jit-epilog
|
||||
jit-return
|
||||
jit-profiling
|
||||
jit-save-stack
|
||||
pic-load
|
||||
pic-tag
|
||||
pic-hi-tag
|
||||
pic-tuple
|
||||
pic-hi-tag-tuple
|
||||
pic-check-tag
|
||||
pic-check
|
||||
pic-hit
|
||||
pic-miss-word
|
||||
mega-lookup
|
||||
mega-lookup-word
|
||||
mega-miss-word
|
||||
undefined-quot
|
||||
} [ emit-userenv ] each ;
|
||||
[ undefined ] undefined-quot set ;
|
||||
|
||||
: emit-userenvs ( -- )
|
||||
userenvs get keys [ emit-userenv ] each ;
|
||||
|
||||
: fixup-header ( -- )
|
||||
heap-size data-heap-size-offset fixup ;
|
||||
|
|
@ -580,8 +503,8 @@ M: quotation '
|
|||
emit-jit-data
|
||||
"Serializing global namespace..." print flush
|
||||
emit-global
|
||||
"Serializing boot quotation..." print flush
|
||||
emit-boot-quot
|
||||
"Serializing user environment..." print flush
|
||||
emit-userenvs
|
||||
"Performing word fixups..." print flush
|
||||
fixup-words
|
||||
"Performing header fixups..." print flush
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser kernel namespaces assocs words.symbol ;
|
||||
IN: bootstrap.image.syntax
|
||||
|
||||
SYMBOL: userenvs
|
||||
|
||||
SYNTAX: RESET H{ } clone userenvs set-global ;
|
||||
|
||||
SYNTAX: USERENV:
|
||||
CREATE-WORD scan-word
|
||||
[ swap userenvs get set-at ]
|
||||
[ drop define-symbol ]
|
||||
2bi ;
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
USING: strings arrays hashtables assocs sequences fry macros
|
||||
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
||||
namespaces io.backend math cocoa.enumeration byte-arrays
|
||||
combinators alien.c-types words core-foundation
|
||||
combinators alien.c-types words core-foundation quotations
|
||||
core-foundation.data core-foundation.utilities ;
|
||||
IN: cocoa.plists
|
||||
|
||||
|
|
@ -41,10 +41,16 @@ DEFER: plist>
|
|||
*void* [ -> release "read-plist failed" throw ] when* ;
|
||||
|
||||
MACRO: objc-class-case ( alist -- quot )
|
||||
[ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
|
||||
[
|
||||
dup callable?
|
||||
[ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
|
||||
unless
|
||||
] map '[ _ cond ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: invalid-plist-object object ;
|
||||
|
||||
: plist> ( plist -- value )
|
||||
{
|
||||
{ NSString [ (plist-NSString>) ] }
|
||||
|
|
@ -53,6 +59,7 @@ PRIVATE>
|
|||
{ NSArray [ (plist-NSArray>) ] }
|
||||
{ NSDictionary [ (plist-NSDictionary>) ] }
|
||||
{ NSObject [ ] }
|
||||
[ invalid-plist-object ]
|
||||
} objc-class-case ;
|
||||
|
||||
: read-plist ( path -- assoc )
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ M: ##call generate-insn
|
|||
word>> dup sub-primitive>>
|
||||
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
|
||||
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
|
||||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
|
|
|
|||
|
|
@ -56,8 +56,11 @@ SYMBOL: literal-table
|
|||
: rel-word ( word class -- )
|
||||
[ add-literal ] dip rt-xt rel-fixup ;
|
||||
|
||||
: rel-word-direct ( word class -- )
|
||||
[ add-literal ] dip rt-xt-direct rel-fixup ;
|
||||
: rel-word-pic ( word class -- )
|
||||
[ add-literal ] dip rt-xt-pic rel-fixup ;
|
||||
|
||||
: rel-word-pic-tail ( word class -- )
|
||||
[ add-literal ] dip rt-xt-pic-tail rel-fixup ;
|
||||
|
||||
: rel-primitive ( word class -- )
|
||||
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel layouts system strings words quotations byte-arrays
|
||||
alien arrays ;
|
||||
alien arrays literals sequences ;
|
||||
IN: compiler.constants
|
||||
|
||||
! These constants must match vm/memory.h
|
||||
|
|
@ -14,43 +14,42 @@ CONSTANT: deck-bits 18
|
|||
: float-offset ( -- n ) 8 float tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
|
||||
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
|
||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
||||
! Relocation classes
|
||||
CONSTANT: rc-absolute-cell 0
|
||||
CONSTANT: rc-absolute 1
|
||||
CONSTANT: rc-relative 2
|
||||
CONSTANT: rc-absolute-cell 0
|
||||
CONSTANT: rc-absolute 1
|
||||
CONSTANT: rc-relative 2
|
||||
CONSTANT: rc-absolute-ppc-2/2 3
|
||||
CONSTANT: rc-absolute-ppc-2 4
|
||||
CONSTANT: rc-relative-ppc-2 5
|
||||
CONSTANT: rc-relative-ppc-3 6
|
||||
CONSTANT: rc-relative-arm-3 7
|
||||
CONSTANT: rc-indirect-arm 8
|
||||
CONSTANT: rc-indirect-arm-pc 9
|
||||
CONSTANT: rc-absolute-ppc-2 4
|
||||
CONSTANT: rc-relative-ppc-2 5
|
||||
CONSTANT: rc-relative-ppc-3 6
|
||||
CONSTANT: rc-relative-arm-3 7
|
||||
CONSTANT: rc-indirect-arm 8
|
||||
CONSTANT: rc-indirect-arm-pc 9
|
||||
|
||||
! Relocation types
|
||||
CONSTANT: rt-primitive 0
|
||||
CONSTANT: rt-dlsym 1
|
||||
CONSTANT: rt-dispatch 2
|
||||
CONSTANT: rt-xt 3
|
||||
CONSTANT: rt-xt-direct 4
|
||||
CONSTANT: rt-here 5
|
||||
CONSTANT: rt-this 6
|
||||
CONSTANT: rt-immediate 7
|
||||
CONSTANT: rt-stack-chain 8
|
||||
CONSTANT: rt-untagged 9
|
||||
CONSTANT: rt-primitive 0
|
||||
CONSTANT: rt-dlsym 1
|
||||
CONSTANT: rt-dispatch 2
|
||||
CONSTANT: rt-xt 3
|
||||
CONSTANT: rt-xt-pic 4
|
||||
CONSTANT: rt-xt-pic-tail 5
|
||||
CONSTANT: rt-here 6
|
||||
CONSTANT: rt-this 7
|
||||
CONSTANT: rt-immediate 8
|
||||
CONSTANT: rt-stack-chain 9
|
||||
CONSTANT: rt-untagged 10
|
||||
CONSTANT: rt-megamorphic-cache-hits 11
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
[ rc-absolute-ppc-2/2 = ]
|
||||
[ rc-absolute-cell = ]
|
||||
[ rc-absolute = ]
|
||||
tri or or ;
|
||||
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
|
||||
|
|
|
|||
|
|
@ -389,4 +389,10 @@ DEFER: loop-bbb
|
|||
|
||||
[ f ] [ \ broken-declaration optimized? ] unit-test
|
||||
|
||||
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
||||
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
||||
|
||||
! Modular arithmetic bug
|
||||
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
|
||||
|
||||
[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
|
||||
[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
|
||||
|
|
@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
>fixnum 256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
dup 0 >= [ 256 mod ] when
|
||||
|
|
@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
{ integer } declare [ 256 rem ] map
|
||||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.partial-dispatch namespaces sequences sets
|
||||
accessors assocs words kernel memoize fry combinators
|
||||
combinators.short-circuit
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.def-use
|
||||
|
|
@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
|
|||
: optimize->fixnum ( #call -- nodes )
|
||||
dup redundant->fixnum? [ drop f ] when ;
|
||||
|
||||
: optimize->integer ( #call -- nodes )
|
||||
dup out-d>> first actually-used-by dup length 1 = [
|
||||
first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
|
||||
[ drop { } ] when
|
||||
] [ drop ] if ;
|
||||
|
||||
MEMO: fixnum-coercion ( flags -- nodes )
|
||||
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
|
||||
|
||||
|
|
@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
|
|||
M: #call optimize-modular-arithmetic*
|
||||
dup word>> {
|
||||
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
|
||||
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
||||
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
comparison-ops
|
||||
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
|
||||
|
||||
! generic-comparison-ops [
|
||||
! dup specific-comparison define-comparison-constraints
|
||||
! ] each
|
||||
|
||||
! Remove redundant comparisons
|
||||
: fold-comparison ( info1 info2 word -- info )
|
||||
[ [ interval>> ] bi@ ] dip interval-comparison {
|
||||
|
|
@ -217,6 +213,8 @@ generic-comparison-ops [
|
|||
{ >float float }
|
||||
{ fixnum>float float }
|
||||
{ bignum>float float }
|
||||
|
||||
{ >integer integer }
|
||||
} [
|
||||
'[
|
||||
_
|
||||
|
|
@ -228,19 +226,26 @@ generic-comparison-ops [
|
|||
] "outputs" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
: rem-custom-inlining ( #call -- quot/f )
|
||||
second value-info literal>> dup integer?
|
||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
mod-integer-integer
|
||||
mod-integer-fixnum
|
||||
mod-fixnum-integer
|
||||
fixnum-mod
|
||||
rem
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal<
|
||||
[ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
|
||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||
[ rem-custom-inlining ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ rem [
|
||||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
|
|
|
|||
|
|
@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
|
|||
! Mutable tuples with circularity should not cause problems
|
||||
TUPLE: circle me ;
|
||||
|
||||
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
||||
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
||||
|
||||
! Joe found an oversight
|
||||
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
|
||||
|
|
@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
|
|||
|
||||
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
|
||||
|
||||
FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
|
||||
|
||||
FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
|
||||
FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
|
||||
|
||||
FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
|
||||
|
||||
FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: bitmap-flags ( -- flags )
|
||||
|
|
|
|||
|
|
@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
|
|||
TYPEDEF: uint CGBitmapInfo
|
||||
|
||||
TYPEDEF: int CGLError
|
||||
TYPEDEF: int CGError
|
||||
TYPEDEF: uint CGDirectDisplayID
|
||||
TYPEDEF: int boolean_t
|
||||
TYPEDEF: void* CGLContextObj
|
||||
TYPEDEF: int CGLContextParameter
|
||||
TYPEDEF: int CGLContextParameter
|
||||
|
|
|
|||
|
|
@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
|
|||
|
||||
HOOK: stack-frame-size cpu ( stack-frame -- n )
|
||||
HOOK: %call cpu ( word -- )
|
||||
HOOK: %jump cpu ( word -- )
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup kernel namespaces words
|
||||
io.binary math math.order cpu.ppc.assembler.backend ;
|
||||
USING: kernel namespaces words io.binary math math.order
|
||||
cpu.ppc.assembler.backend ;
|
||||
IN: cpu.ppc.assembler
|
||||
|
||||
! See the Motorola or IBM documentation for details. The opcode
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup cpu.architecture
|
||||
compiler.constants kernel namespaces make sequences words math
|
||||
math.bitwise io.binary parser lexer ;
|
||||
USING: kernel namespaces make sequences words math
|
||||
math.bitwise io.binary parser lexer fry ;
|
||||
IN: cpu.ppc.assembler.backend
|
||||
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
|
||||
|
|
@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
|
|||
|
||||
GENERIC# (B) 2 ( dest aa lk -- )
|
||||
M: integer (B) 18 i-insn ;
|
||||
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
|
||||
GENERIC: BC ( a b c -- )
|
||||
M: integer BC 0 0 16 b-insn ;
|
||||
M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
: CREATE-B ( -- word ) scan "B" prepend create-in ;
|
||||
|
||||
SYNTAX: BC:
|
||||
CREATE-B scan-word scan-word
|
||||
[ rot BC ] 2curry (( c -- )) define-declared ;
|
||||
'[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
|
||||
|
||||
SYNTAX: B:
|
||||
CREATE-B scan-word scan-word scan-word scan-word scan-word
|
||||
[ b-insn ] curry curry curry curry curry
|
||||
(( bo -- )) define-declared ;
|
||||
'[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
|
||||
|
|
|
|||
|
|
@ -9,8 +9,8 @@ IN: bootstrap.ppc
|
|||
4 \ cell set
|
||||
big-endian on
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
||||
|
|
@ -21,46 +21,48 @@ CONSTANT: rs-reg 30
|
|||
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
11 6 profile-count-offset LWZ
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
11 3 profile-count-offset LWZ
|
||||
11 11 1 tag-fixnum ADDI
|
||||
11 6 profile-count-offset STW
|
||||
11 6 word-code-offset LWZ
|
||||
11 3 profile-count-offset STW
|
||||
11 3 word-code-offset LWZ
|
||||
11 11 compiled-header-size ADDI
|
||||
11 MTCTR
|
||||
BCTR
|
||||
] jit-profiling jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
|
||||
0 MFLR
|
||||
1 1 stack-frame SUBI
|
||||
6 1 xt-save STW
|
||||
stack-frame 6 LI
|
||||
6 1 next-save STW
|
||||
3 1 xt-save STW
|
||||
stack-frame 3 LI
|
||||
3 1 next-save STW
|
||||
0 1 lr-save stack-frame + STW
|
||||
] jit-prolog jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
6 ds-reg 4 STWU
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
3 ds-reg 4 STWU
|
||||
] jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
|
||||
7 6 0 LWZ
|
||||
1 7 0 STW
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
|
||||
6 MTCTR
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
|
||||
4 3 0 LWZ
|
||||
1 4 0 STW
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
|
||||
3 MTCTR
|
||||
BCTR
|
||||
] jit-primitive jit-define
|
||||
|
||||
[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
|
||||
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
|
||||
|
||||
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
|
||||
0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -68,11 +70,8 @@ CONSTANT: rs-reg 30
|
|||
0 3 \ f tag-number CMPI
|
||||
2 BEQ
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
] jit-if-1 jit-define
|
||||
|
||||
[
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
] jit-if-2 jit-define
|
||||
] jit-if jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
4 ds-reg 0 LWZ
|
||||
|
|
@ -138,6 +137,16 @@ CONSTANT: rs-reg 30
|
|||
jit-3r>
|
||||
] jit-3dip jit-define
|
||||
|
||||
: prepare-(execute) ( -- operand )
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 ;
|
||||
|
||||
[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
|
||||
|
||||
[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
|
||||
|
||||
[
|
||||
0 1 lr-save stack-frame + LWZ
|
||||
1 1 stack-frame ADDI
|
||||
|
|
@ -146,7 +155,99 @@ CONSTANT: rs-reg 30
|
|||
|
||||
[ BLR ] jit-return jit-define
|
||||
|
||||
! Sub-primitives
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! Don't touch r6 here; it's used to pass the tail call site
|
||||
! address for tail PICs
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
|
||||
] pic-load jit-define
|
||||
|
||||
! Tag
|
||||
: load-tag ( -- )
|
||||
4 4 tag-mask get ANDI
|
||||
4 4 tag-bits get SLWI ;
|
||||
|
||||
[ load-tag ] pic-tag jit-define
|
||||
|
||||
! Hi-tag
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 object tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 object tag-number neg LWZ
|
||||
] pic-hi-tag jit-define
|
||||
|
||||
! Tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 tuple tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 tuple tag-number neg bootstrap-cell + LWZ
|
||||
] pic-tuple jit-define
|
||||
|
||||
! Hi-tag and tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
|
||||
0 4 BIN: 110 tag-fixnum CMPI
|
||||
5 BLT
|
||||
! Untag r3
|
||||
3 3 0 0 31 tag-bits get - RLWINM
|
||||
! Set r4 to 0 for objects, and bootstrap-cell for tuples
|
||||
4 4 1 tag-fixnum ANDI
|
||||
4 4 1 SRAWI
|
||||
! Load header cell or tuple layout cell
|
||||
4 4 3 LWZX
|
||||
] pic-hi-tag-tuple jit-define
|
||||
|
||||
[
|
||||
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
||||
[
|
||||
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
4 0 5 CMP
|
||||
] pic-check jit-define
|
||||
|
||||
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
[
|
||||
! cache = ...
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
! key = class
|
||||
5 4 MR
|
||||
! key &= cache.length - 1
|
||||
5 5 mega-cache-size get 1- bootstrap-cell * ANDI
|
||||
! cache += array-start-offset
|
||||
3 3 array-start-offset ADDI
|
||||
! cache += key
|
||||
3 3 5 ADD
|
||||
! if(get(cache) == class)
|
||||
6 3 0 LWZ
|
||||
6 0 4 CMP
|
||||
10 BNE
|
||||
! megamorphic_cache_hits++
|
||||
0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
|
||||
5 4 0 LWZ
|
||||
5 5 1 ADDI
|
||||
5 4 0 STW
|
||||
! ... goto get(cache + bootstrap-cell)
|
||||
3 3 4 LWZ
|
||||
3 3 word-xt-offset LWZ
|
||||
3 MTCTR
|
||||
BCTR
|
||||
! fall-through on miss
|
||||
] mega-lookup jit-define
|
||||
|
||||
! ! ! Sub-primitives
|
||||
|
||||
! Quotations and words
|
||||
[
|
||||
|
|
@ -157,14 +258,6 @@ CONSTANT: rs-reg 30
|
|||
BCTR
|
||||
] \ (call) define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 MTCTR
|
||||
BCTR
|
||||
] \ (execute) define-sub-primitive
|
||||
|
||||
! Objects
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
|
|||
|
|
@ -1,33 +1,39 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences kernel combinators make math
|
||||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.c-types cpu.architecture cpu.ppc.assembler
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.constants compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
|
||||
alien alien.c-types literals cpu.architecture cpu.ppc.assembler
|
||||
cpu.ppc.assembler.backend literals compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.constants compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame ;
|
||||
IN: cpu.ppc
|
||||
|
||||
! PowerPC register assignments:
|
||||
! r2-r27: integer vregs
|
||||
! r28: integer scratch
|
||||
! r29: data stack
|
||||
! r30: retain stack
|
||||
! r2-r12: integer vregs
|
||||
! r15-r29
|
||||
! r30: integer scratch
|
||||
! f0-f29: float vregs
|
||||
! f30, f31: float scratch
|
||||
! f30: float scratch
|
||||
|
||||
! Add some methods to the assembler that are useful to us
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
enable-float-intrinsics
|
||||
|
||||
<< \ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop >>
|
||||
<<
|
||||
\ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop
|
||||
>>
|
||||
|
||||
M: ppc machine-registers
|
||||
{
|
||||
{ int-regs T{ range f 2 26 1 } }
|
||||
{ double-float-regs T{ range f 0 29 1 } }
|
||||
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
|
||||
{ double-float-regs $[ 0 29 [a,b] ] }
|
||||
} ;
|
||||
|
||||
CONSTANT: scratch-reg 28
|
||||
CONSTANT: scratch-reg 30
|
||||
CONSTANT: fp-scratch-reg 30
|
||||
|
||||
M: ppc two-operand? f ;
|
||||
|
|
@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- )
|
|||
M: ppc %alien-global ( register symbol dll -- )
|
||||
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
GENERIC: loc-reg ( loc -- reg )
|
||||
|
||||
|
|
@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i )
|
|||
factor-area-size +
|
||||
4 cells align ;
|
||||
|
||||
M: ppc %call ( label -- ) BL ;
|
||||
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
|
||||
|
||||
M: ppc %jump ( word -- )
|
||||
0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
|
||||
0 B rc-relative-ppc-3 rel-word-pic-tail ;
|
||||
|
||||
M: ppc %jump-label ( label -- ) B ;
|
||||
M: ppc %return ( -- ) BLR ;
|
||||
|
||||
|
|
@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- )
|
|||
BCTR ;
|
||||
|
||||
M: ppc %dispatch-label ( word -- )
|
||||
0 , rc-absolute-cell rel-word ;
|
||||
B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
|
||||
|
||||
:: (%slot) ( obj slot tag temp -- reg offset )
|
||||
temp slot obj ADD
|
||||
|
|
@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
|
|||
|
||||
M: ppc %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
13 3 MR ;
|
||||
15 3 MR ;
|
||||
|
||||
M: ppc %alien-indirect ( -- )
|
||||
13 MTLR BLRL ;
|
||||
15 MTLR BLRL ;
|
||||
|
||||
M: ppc %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
|
|
@ -702,3 +713,4 @@ USE: vocabs.loader
|
|||
} cond
|
||||
|
||||
"complex-double" c-type t >>return-in-registers? drop
|
||||
"bool" c-type 4 >>size 4 >>align drop
|
||||
|
|
@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- )
|
|||
M: x86.32 param-reg-1 EAX ;
|
||||
M: x86.32 param-reg-2 EDX ;
|
||||
|
||||
M: x86.32 pic-tail-reg EBX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants ;
|
||||
|
|
@ -26,10 +26,8 @@ IN: bootstrap.x86
|
|||
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
|
||||
! save stack pointer
|
||||
temp0 [] stack-reg MOV
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
(JMP) drop rc-relative rt-primitive jit-rel
|
||||
! call the primitive
|
||||
0 JMP rc-relative rt-primitive jit-rel
|
||||
] jit-primitive jit-define
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||
|
|
|
|||
|
|
@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
|
|||
M: x86.64 param-reg-2 int-regs param-regs second ;
|
||||
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
|
||||
|
|
@ -25,9 +25,6 @@ IN: bootstrap.x86
|
|||
temp0 temp0 [] MOV
|
||||
! save stack pointer
|
||||
temp0 [] stack-reg MOV
|
||||
] jit-save-stack jit-define
|
||||
|
||||
[
|
||||
! load XT
|
||||
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
|
||||
! go
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays cpu.architecture compiler.constants
|
||||
compiler.codegen.fixup io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system
|
||||
layouts math.order accessors cpu.x86.assembler.syntax ;
|
||||
USING: arrays io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system layouts
|
||||
math.order accessors cpu.x86.assembler.syntax ;
|
||||
IN: cpu.x86.assembler
|
||||
|
||||
! A postfix assembler for x86 and AMD64.
|
||||
! A postfix assembler for x86-32 and x86-64.
|
||||
|
||||
! In 32-bit mode, { 1234 } is absolute indirect addressing.
|
||||
! In 64-bit mode, { 1234 } is RIP-relative.
|
||||
|
|
@ -296,36 +295,23 @@ M: operand (MOV-I)
|
|||
{ BIN: 000 t HEX: c6 }
|
||||
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
|
||||
|
||||
PREDICATE: callable < word register? not ;
|
||||
|
||||
GENERIC: MOV ( dst src -- )
|
||||
M: immediate MOV swap (MOV-I) ;
|
||||
M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
|
||||
M: operand MOV HEX: 88 2-operand ;
|
||||
|
||||
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
|
||||
|
||||
! Control flow
|
||||
GENERIC: JMP ( op -- )
|
||||
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
|
||||
M: f JMP (JMP) 2drop ;
|
||||
M: callable JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: integer JMP HEX: e9 , 4, ;
|
||||
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC: CALL ( op -- )
|
||||
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
||||
M: f CALL (CALL) 2drop ;
|
||||
M: callable CALL (CALL) rel-word-direct ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: integer CALL HEX: e8 , 4, ;
|
||||
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||
: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
|
||||
M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
|
||||
M: integer JUMPcc (JUMPcc) drop ;
|
||||
M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
|
||||
M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
|
||||
M: integer JUMPcc extended-opcode, 4, ;
|
||||
|
||||
: JO ( dst -- ) HEX: 80 JUMPcc ;
|
||||
: JNO ( dst -- ) HEX: 81 JUMPcc ;
|
||||
|
|
|
|||
|
|
@ -42,13 +42,18 @@ big-endian off
|
|||
] jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
f JMP rc-relative rt-xt jit-rel
|
||||
temp3 0 MOV rc-absolute-cell rt-here jit-rel
|
||||
0 JMP rc-relative rt-xt-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
[
|
||||
f CALL rc-relative rt-xt-direct jit-rel
|
||||
0 CALL rc-relative rt-xt-pic jit-rel
|
||||
] jit-word-call jit-define
|
||||
|
||||
[
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-word-special jit-define
|
||||
|
||||
[
|
||||
! load boolean
|
||||
temp0 ds-reg [] MOV
|
||||
|
|
@ -57,13 +62,10 @@ big-endian off
|
|||
! compare boolean with f
|
||||
temp0 \ f tag-number CMP
|
||||
! jump to true branch if not equal
|
||||
f JNE rc-relative rt-xt jit-rel
|
||||
] jit-if-1 jit-define
|
||||
|
||||
[
|
||||
0 JNE rc-relative rt-xt jit-rel
|
||||
! jump to false branch if equal
|
||||
f JMP rc-relative rt-xt jit-rel
|
||||
] jit-if-2 jit-define
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-if jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
rs-reg bootstrap-cell ADD
|
||||
|
|
@ -115,19 +117,19 @@ big-endian off
|
|||
|
||||
[
|
||||
jit->r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-r>
|
||||
] jit-dip jit-define
|
||||
|
||||
[
|
||||
jit-2>r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-2r>
|
||||
] jit-2dip jit-define
|
||||
|
||||
[
|
||||
jit-3>r
|
||||
f CALL rc-relative rt-xt jit-rel
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-3r>
|
||||
] jit-3dip jit-define
|
||||
|
||||
|
|
@ -152,6 +154,8 @@ big-endian off
|
|||
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! The PIC and megamorphic code stubs are not permitted to touch temp3.
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel
|
||||
|
|
@ -194,7 +198,7 @@ big-endian off
|
|||
[
|
||||
! Untag temp0
|
||||
temp0 tag-mask get bitnot AND
|
||||
! Set temp1 to 0 for objects, and 8 for tuples
|
||||
! Set temp1 to 0 for objects, and bootstrap-cell for tuples
|
||||
temp1 1 tag-fixnum AND
|
||||
bootstrap-cell 4 = [ temp1 1 SHR ] when
|
||||
! Load header cell or tuple layout cell
|
||||
|
|
@ -211,7 +215,7 @@ big-endian off
|
|||
temp1 temp2 CMP
|
||||
] pic-check jit-define
|
||||
|
||||
[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
|
||||
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
|
|
@ -229,12 +233,13 @@ big-endian off
|
|||
temp0 temp2 ADD
|
||||
! if(get(cache) == class)
|
||||
temp0 [] temp1 CMP
|
||||
! ... goto get(cache + bootstrap-cell)
|
||||
[
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-xt-offset [+] JMP
|
||||
] [ ] make
|
||||
[ length JNE ] [ % ] bi
|
||||
bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
|
||||
! megamorphic_cache_hits++
|
||||
temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
|
||||
temp1 [] 1 ADD
|
||||
! goto get(cache + bootstrap-cell)
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-xt-offset [+] JMP
|
||||
! fall-through on miss
|
||||
] mega-lookup jit-define
|
||||
|
||||
|
|
|
|||
|
|
@ -11,6 +11,10 @@ IN: cpu.x86
|
|||
|
||||
<< enable-fixnum-log2 >>
|
||||
|
||||
! Add some methods to the assembler to be more useful to the backend
|
||||
M: label JMP 0 JMP rc-relative label-fixup ;
|
||||
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
|
||||
|
||||
M: x86 two-operand? t ;
|
||||
|
||||
HOOK: temp-reg-1 cpu ( -- reg )
|
||||
|
|
@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg )
|
|||
HOOK: param-reg-1 cpu ( -- reg )
|
||||
HOOK: param-reg-2 cpu ( -- reg )
|
||||
|
||||
HOOK: pic-tail-reg cpu ( -- reg )
|
||||
|
||||
M: x86 %load-immediate MOV ;
|
||||
|
||||
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
|
||||
|
|
@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i )
|
|||
reserved-area-size +
|
||||
align-stack ;
|
||||
|
||||
M: x86 %call ( label -- ) CALL ;
|
||||
M: x86 %jump-label ( label -- ) JMP ;
|
||||
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
|
||||
|
||||
: xt-tail-pic-offset ( -- n )
|
||||
#! See the comment in vm/cpu-x86.hpp
|
||||
cell 4 + 1 + ; inline
|
||||
|
||||
M: x86 %jump ( word -- )
|
||||
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
|
||||
0 JMP rc-relative rel-word-pic-tail ;
|
||||
|
||||
M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
|
||||
|
||||
M: x86 %return ( -- ) 0 RET ;
|
||||
|
||||
: code-alignment ( align -- n )
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ $nl
|
|||
"Iterating over elements:"
|
||||
{ $subsection dlist-each }
|
||||
{ $subsection dlist-find }
|
||||
{ $subsection dlist-filter }
|
||||
{ $subsection dlist-any? }
|
||||
"Deleting a node matching a predicate:"
|
||||
{ $subsection delete-node-if* }
|
||||
|
|
@ -40,6 +41,11 @@ HELP: dlist-find
|
|||
"This operation is O(n)."
|
||||
} ;
|
||||
|
||||
HELP: dlist-filter
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
|
||||
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
|
||||
{ $side-effects { "dlist" } } ;
|
||||
|
||||
HELP: dlist-any?
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
|
||||
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
||||
|
|
|
|||
|
|
@ -79,3 +79,8 @@ IN: dlists.tests
|
|||
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
|
||||
|
||||
[ V{ } ] [ <dlist> dlist>seq ] unit-test
|
||||
|
||||
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
|
|||
[
|
||||
[
|
||||
[ empty-dlist ] unless*
|
||||
[ f ] change-next drop
|
||||
next>>
|
||||
f over set-prev-when
|
||||
] change-front drop
|
||||
] keep
|
||||
|
|
@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
|
|||
[
|
||||
[
|
||||
[ empty-dlist ] unless*
|
||||
[ f ] change-prev drop
|
||||
prev>>
|
||||
f over set-next-when
|
||||
] change-back drop
|
||||
] keep
|
||||
|
|
@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
|
|||
|
||||
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
|
||||
|
||||
: dlist-filter ( dlist quot -- dlist )
|
||||
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
|
||||
|
||||
M: dlist clone
|
||||
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
IN: io.backend.windows.privileges.tests
|
||||
USING: io.backend.windows.privileges tools.test ;
|
||||
|
||||
[ [ ] with-privileges ] must-infer
|
||||
|
|
@ -1,12 +1,13 @@
|
|||
USING: io.backend kernel continuations sequences
|
||||
system vocabs.loader combinators ;
|
||||
system vocabs.loader combinators fry ;
|
||||
IN: io.backend.windows.privileges
|
||||
|
||||
HOOK: set-privilege io-backend ( name ? -- ) inline
|
||||
HOOK: set-privilege io-backend ( name ? -- )
|
||||
|
||||
: with-privileges ( seq quot -- )
|
||||
over [ [ t set-privilege ] each ] curry compose
|
||||
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
|
||||
[ '[ _ [ t set-privilege ] each @ ] ]
|
||||
[ drop '[ _ [ f set-privilege ] each ] ]
|
||||
2bi [ ] cleanup ; inline
|
||||
|
||||
{
|
||||
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }
|
||||
|
|
|
|||
|
|
@ -35,6 +35,9 @@ SYMBOL: unique-retries
|
|||
: random-name ( -- string )
|
||||
unique-length get [ random-ch ] "" replicate-as ;
|
||||
|
||||
: retry ( quot: ( -- ? ) n -- )
|
||||
swap [ drop ] prepose attempt-all ; inline
|
||||
|
||||
: (make-unique-file) ( path prefix suffix -- path )
|
||||
'[
|
||||
_ _ _ random-name glue append-path
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-run=listener" 2array >>command
|
||||
+closed+ >>stdin
|
||||
+stdout+ >>stderr
|
||||
ascii [ input-stream get contents ] with-process-reader
|
||||
ascii [ contents ] with-process-reader
|
||||
] unit-test
|
||||
|
||||
: launcher-test-path ( -- str )
|
||||
|
|
@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests
|
|||
<process>
|
||||
console-vm "-script" "stderr.factor" 3array >>command
|
||||
"err2.txt" temp-file >>stderr
|
||||
ascii <process-reader> lines first
|
||||
ascii <process-reader> stream-lines first
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
|
|
@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests
|
|||
launcher-test-path [
|
||||
<process>
|
||||
console-vm "-script" "env.factor" 3array >>command
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
os-envs =
|
||||
|
|
@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-script" "env.factor" 3array >>command
|
||||
+replace-environment+ >>environment-mode
|
||||
os-envs >>environment
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
os-envs =
|
||||
|
|
@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests
|
|||
<process>
|
||||
console-vm "-script" "env.factor" 3array >>command
|
||||
{ { "A" "B" } } >>environment
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
"A" swap at
|
||||
|
|
@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-script" "env.factor" 3array >>command
|
||||
{ { "USERPROFILE" "XXX" } } >>environment
|
||||
+prepend-environment+ >>environment-mode
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
"USERPROFILE" swap at "XXX" =
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ CONSTANT: five 5
|
|||
USING: kernel literals prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< : seven-eleven ( -- a b ) 7 11 ; >>
|
||||
: seven-eleven ( -- a b ) 7 11 ;
|
||||
{ $ seven-eleven } .
|
||||
"> "{ 7 11 }" }
|
||||
|
||||
|
|
@ -43,7 +43,24 @@ IN: scratchpad
|
|||
|
||||
} ;
|
||||
|
||||
{ POSTPONE: $ POSTPONE: $[ } related-words
|
||||
HELP: ${
|
||||
{ $syntax "${ code }" }
|
||||
{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." }
|
||||
{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
|
||||
{ $examples
|
||||
|
||||
{ $example <"
|
||||
USING: kernel literals math prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
CONSTANT: five 5
|
||||
CONSTANT: six 6
|
||||
${ five six 7 } .
|
||||
"> "{ 5 6 7 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
|
||||
|
||||
ARTICLE: "literals" "Interpolating code results into literal values"
|
||||
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
|
||||
|
|
@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values"
|
|||
USING: kernel literals math prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< CONSTANT: five 5 >>
|
||||
CONSTANT: five 5
|
||||
{ $ five $[ five dup 1+ dup 2 + ] } .
|
||||
"> "{ 5 5 6 8 }" }
|
||||
{ $subsection POSTPONE: $ }
|
||||
{ $subsection POSTPONE: $[ }
|
||||
{ $subsection POSTPONE: ${ }
|
||||
;
|
||||
|
||||
ABOUT: "literals"
|
||||
|
|
|
|||
|
|
@ -1,37 +1,93 @@
|
|||
USING: help.markup help.syntax kernel math math.order sequences ;
|
||||
USING: help.markup help.syntax kernel math math.order multiline sequences ;
|
||||
IN: math.combinatorics
|
||||
|
||||
HELP: factorial
|
||||
{ $values { "n" "a non-negative integer" } { "n!" integer } }
|
||||
{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
|
||||
{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
|
||||
{ $examples
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"4 factorial ." "24" }
|
||||
} ;
|
||||
|
||||
HELP: nPk
|
||||
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
|
||||
{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
|
||||
{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
|
||||
{ $examples
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"10 4 nPk ." "5040" }
|
||||
} ;
|
||||
|
||||
HELP: nCk
|
||||
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
|
||||
{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
|
||||
{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
|
||||
{ $examples
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"10 4 nCk ." "210" }
|
||||
} ;
|
||||
|
||||
HELP: permutation
|
||||
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
|
||||
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
|
||||
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
|
||||
{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
|
||||
{ $examples
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"1 3 permutation ." "{ 0 2 1 }" }
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" }
|
||||
} ;
|
||||
|
||||
HELP: all-permutations
|
||||
{ $values { "seq" sequence } { "seq" sequence } }
|
||||
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
|
||||
{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
|
||||
{ $examples
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
|
||||
} ;
|
||||
|
||||
HELP: each-permutation
|
||||
{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } }
|
||||
{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ;
|
||||
|
||||
HELP: inverse-permutation
|
||||
{ $values { "seq" sequence } { "permutation" sequence } }
|
||||
{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
|
||||
{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
|
||||
{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
|
||||
{ $examples
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" }
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" }
|
||||
} ;
|
||||
|
||||
HELP: combination
|
||||
{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
|
||||
{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
|
||||
{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: math.combinatorics sequences prettyprint ;"
|
||||
"6 7 iota 4 combination ." "{ 0 1 3 6 }" }
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" }
|
||||
} ;
|
||||
|
||||
HELP: all-combinations
|
||||
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
|
||||
{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." }
|
||||
{ $examples
|
||||
{ $example "USING: math.combinatorics prettyprint ;"
|
||||
"{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
|
||||
<" {
|
||||
{ "a" "b" }
|
||||
{ "a" "c" }
|
||||
{ "a" "d" }
|
||||
{ "b" "c" }
|
||||
{ "b" "d" }
|
||||
{ "c" "d" }
|
||||
}"> } } ;
|
||||
|
||||
HELP: each-combination
|
||||
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
|
||||
{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ;
|
||||
|
||||
|
||||
IN: math.combinatorics.private
|
||||
|
|
|
|||
|
|
@ -1,18 +1,6 @@
|
|||
USING: math.combinatorics math.combinatorics.private tools.test ;
|
||||
USING: math.combinatorics math.combinatorics.private tools.test sequences ;
|
||||
IN: math.combinatorics.tests
|
||||
|
||||
[ { } ] [ 0 factoradic ] unit-test
|
||||
[ { 1 0 } ] [ 1 factoradic ] unit-test
|
||||
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
|
||||
|
||||
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
|
||||
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
|
||||
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
|
||||
|
||||
[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
|
||||
[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
|
||||
[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
|
||||
|
||||
[ 1 ] [ 0 factorial ] unit-test
|
||||
[ 1 ] [ 1 factorial ] unit-test
|
||||
[ 3628800 ] [ 10 factorial ] unit-test
|
||||
|
|
@ -31,6 +19,19 @@ IN: math.combinatorics.tests
|
|||
[ 2598960 ] [ 52 5 nCk ] unit-test
|
||||
[ 2598960 ] [ 52 47 nCk ] unit-test
|
||||
|
||||
|
||||
[ { } ] [ 0 factoradic ] unit-test
|
||||
[ { 1 0 } ] [ 1 factoradic ] unit-test
|
||||
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
|
||||
|
||||
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
|
||||
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
|
||||
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
|
||||
|
||||
[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test
|
||||
[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test
|
||||
[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test
|
||||
|
||||
[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
|
||||
[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
|
||||
[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
|
||||
|
|
@ -43,3 +44,29 @@ IN: math.combinatorics.tests
|
|||
[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
|
||||
[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
|
||||
|
||||
|
||||
[ 2598960 ] [ 52 iota 5 <combo> choose ] unit-test
|
||||
|
||||
[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test
|
||||
[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test
|
||||
[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test
|
||||
[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test
|
||||
|
||||
[ 9 ] [ 0 5 iota 3 <combo> dual-index ] unit-test
|
||||
[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
|
||||
[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
|
||||
|
||||
[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
|
||||
[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
|
||||
[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
|
||||
[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test
|
||||
|
||||
[ { 0 1 2 } ] [ 0 5 iota 3 <combo> combination-indices ] unit-test
|
||||
[ { 2 3 4 } ] [ 9 5 iota 3 <combo> combination-indices ] unit-test
|
||||
|
||||
[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
|
||||
[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
|
||||
|
||||
[ { { "a" "b" } { "a" "c" }
|
||||
{ "a" "d" } { "b" "c" }
|
||||
{ "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
|
||||
! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math math.order math.ranges mirrors
|
||||
namespaces sequences sorting fry ;
|
||||
USING: accessors assocs binary-search fry kernel locals math math.order
|
||||
math.ranges mirrors namespaces sequences sorting ;
|
||||
IN: math.combinatorics
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -12,14 +12,27 @@ IN: math.combinatorics
|
|||
: twiddle ( n k -- n k )
|
||||
2dup - dupd > [ dupd - ] when ; inline
|
||||
|
||||
! See this article for explanation of the factoradic-based permutation methodology:
|
||||
! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
|
||||
PRIVATE>
|
||||
|
||||
: factorial ( n -- n! )
|
||||
1 [ 1 + * ] reduce ;
|
||||
|
||||
: nPk ( n k -- nPk )
|
||||
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
|
||||
|
||||
: nCk ( n k -- nCk )
|
||||
twiddle [ nPk ] keep factorial / ;
|
||||
|
||||
|
||||
! Factoradic-based permutation methodology
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: factoradic ( n -- factoradic )
|
||||
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ;
|
||||
0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
|
||||
|
||||
: (>permutation) ( seq n -- seq )
|
||||
[ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
|
||||
[ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
|
||||
|
||||
: >permutation ( factoradic -- permutation )
|
||||
reverse 1 cut [ (>permutation) ] each ;
|
||||
|
|
@ -29,27 +42,84 @@ IN: math.combinatorics
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: factorial ( n -- n! )
|
||||
1 [ 1+ * ] reduce ;
|
||||
|
||||
: nPk ( n k -- nPk )
|
||||
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
|
||||
|
||||
: nCk ( n k -- nCk )
|
||||
twiddle [ nPk ] keep factorial / ;
|
||||
|
||||
: permutation ( n seq -- seq )
|
||||
[ permutation-indices ] keep nths ;
|
||||
|
||||
: all-permutations ( seq -- seq )
|
||||
[ length factorial ] keep '[ _ permutation ] map ;
|
||||
[ length factorial ] keep
|
||||
'[ _ permutation ] map ;
|
||||
|
||||
: each-permutation ( seq quot -- )
|
||||
[ [ length factorial ] keep ] dip
|
||||
'[ _ permutation @ ] each ; inline
|
||||
|
||||
: reduce-permutations ( seq initial quot -- result )
|
||||
: reduce-permutations ( seq identity quot -- result )
|
||||
swapd each-permutation ; inline
|
||||
|
||||
: inverse-permutation ( seq -- permutation )
|
||||
<enum> >alist sort-values keys ;
|
||||
|
||||
|
||||
! Combinadic-based combination methodology
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: combo
|
||||
{ seq sequence }
|
||||
{ k integer } ;
|
||||
|
||||
C: <combo> combo
|
||||
|
||||
: choose ( combo -- nCk )
|
||||
[ seq>> length ] [ k>> ] bi nCk ;
|
||||
|
||||
: largest-value ( a b x -- v )
|
||||
dup 0 = [
|
||||
drop 1 - nip
|
||||
] [
|
||||
[ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
|
||||
] if ;
|
||||
|
||||
:: next-values ( a b x -- a' b' x' v )
|
||||
a b x largest-value dup :> v ! a'
|
||||
b 1 - ! b'
|
||||
x v b nCk - ! x'
|
||||
v ; ! v == a'
|
||||
|
||||
: dual-index ( m combo -- m' )
|
||||
choose 1 - swap - ;
|
||||
|
||||
: initial-values ( combo m -- n k m )
|
||||
[ [ seq>> length ] [ k>> ] bi ] dip ;
|
||||
|
||||
: combinadic ( combo m -- combinadic )
|
||||
initial-values [ over 0 > ] [ next-values ] produce
|
||||
[ 3drop ] dip ;
|
||||
|
||||
: combination-indices ( m combo -- seq )
|
||||
[ tuck dual-index combinadic ] keep
|
||||
seq>> length 1 - swap [ - ] with map ;
|
||||
|
||||
: apply-combination ( m combo -- seq )
|
||||
[ combination-indices ] keep seq>> nths ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: combination ( m seq k -- seq )
|
||||
<combo> apply-combination ;
|
||||
|
||||
: all-combinations ( seq k -- seq )
|
||||
<combo> [ choose [0,b) ] keep
|
||||
'[ _ apply-combination ] map ;
|
||||
|
||||
: each-combination ( seq k quot -- )
|
||||
[ <combo> [ choose [0,b) ] keep ] dip
|
||||
'[ _ apply-combination @ ] each ; inline
|
||||
|
||||
: map-combinations ( seq k quot -- )
|
||||
[ <combo> [ choose [0,b) ] keep ] dip
|
||||
'[ _ apply-combination @ ] map ; inline
|
||||
|
||||
: reduce-combinations ( seq k identity quot -- result )
|
||||
[ -rot ] dip each-combination ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -48,6 +48,8 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
|
||||
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
|
||||
|
||||
: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
|
||||
|
||||
: [-inf,inf] ( -- interval ) full-interval ; inline
|
||||
|
||||
: compare-endpoints ( p1 p2 quot -- ? )
|
||||
|
|
@ -262,7 +264,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
: interval-abs ( i1 -- i2 )
|
||||
{
|
||||
{ [ dup empty-interval eq? ] [ ] }
|
||||
{ [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
|
||||
{ [ dup full-interval eq? ] [ drop [0,inf] ] }
|
||||
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
|
||||
[ (interval-abs) points>interval ]
|
||||
} cond ;
|
||||
|
|
@ -376,7 +378,7 @@ SYMBOL: incomparable
|
|||
: interval-log2 ( i1 -- i2 )
|
||||
{
|
||||
{ empty-interval [ empty-interval ] }
|
||||
{ full-interval [ 0 [a,inf] ] }
|
||||
{ full-interval [ [0,inf] ] }
|
||||
[
|
||||
to>> first 1 max dup most-positive-fixnum >
|
||||
[ drop full-interval interval-log2 ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,100 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel sequences math ;
|
||||
IN: math.miller-rabin
|
||||
|
||||
HELP: find-relative-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
|
||||
|
||||
HELP: find-relative-prime*
|
||||
{ $values
|
||||
{ "n" integer } { "guess" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
|
||||
|
||||
HELP: miller-rabin
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
|
||||
|
||||
{ miller-rabin miller-rabin* } related-words
|
||||
|
||||
HELP: miller-rabin*
|
||||
{ $values
|
||||
{ "n" integer } { "numtrials" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
|
||||
|
||||
HELP: next-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
|
||||
|
||||
HELP: next-safe-prime
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
{ "q" integer }
|
||||
}
|
||||
{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
|
||||
|
||||
HELP: random-bits*
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: random-prime
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: random-safe-prime
|
||||
{ $values
|
||||
{ "numbits" integer }
|
||||
{ "p" integer }
|
||||
}
|
||||
{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
|
||||
|
||||
HELP: safe-prime?
|
||||
{ $values
|
||||
{ "q" integer }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
|
||||
|
||||
HELP: unique-primes
|
||||
{ $values
|
||||
{ "numbits" integer } { "n" integer }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
|
||||
|
||||
ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
|
||||
"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
|
||||
"The Miller-Rabin probabilistic primality test:"
|
||||
{ $subsection miller-rabin }
|
||||
{ $subsection miller-rabin* }
|
||||
"Generating relative prime numbers:"
|
||||
{ $subsection find-relative-prime }
|
||||
{ $subsection find-relative-prime* }
|
||||
"Generating prime numbers:"
|
||||
{ $subsection next-prime }
|
||||
{ $subsection random-prime }
|
||||
"Generating safe prime numbers:"
|
||||
{ $subsection next-safe-prime }
|
||||
{ $subsection random-safe-prime } ;
|
||||
|
||||
ABOUT: "math.miller-rabin"
|
||||
|
|
@ -1,4 +1,5 @@
|
|||
USING: math.miller-rabin tools.test kernel sequences ;
|
||||
USING: math.miller-rabin tools.test kernel sequences
|
||||
math.miller-rabin.private math ;
|
||||
IN: math.miller-rabin.tests
|
||||
|
||||
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
|
||||
|
|
@ -6,6 +7,9 @@ IN: math.miller-rabin.tests
|
|||
[ t ] [ 3 miller-rabin ] unit-test
|
||||
[ f ] [ 36 miller-rabin ] unit-test
|
||||
[ t ] [ 37 miller-rabin ] unit-test
|
||||
[ 2 ] [ 1 next-prime ] unit-test
|
||||
[ 3 ] [ 2 next-prime ] unit-test
|
||||
[ 5 ] [ 3 next-prime ] unit-test
|
||||
[ 101 ] [ 100 next-prime ] unit-test
|
||||
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
|
||||
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
|
||||
|
|
@ -14,6 +18,12 @@ IN: math.miller-rabin.tests
|
|||
[ f ] [ 862 safe-prime? ] unit-test
|
||||
[ t ] [ 7 safe-prime? ] unit-test
|
||||
[ f ] [ 31 safe-prime? ] unit-test
|
||||
[ t ] [ 47 safe-prime-candidate? ] unit-test
|
||||
[ t ] [ 47 safe-prime? ] unit-test
|
||||
[ t ] [ 863 safe-prime? ] unit-test
|
||||
|
||||
[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
|
||||
|
||||
[ 47 ] [ 31 next-safe-prime ] unit-test
|
||||
[ 49 ] [ 50 random-prime log2 ] unit-test
|
||||
[ 49 ] [ 50 random-bits* log2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,16 +1,19 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! Copyright (c) 2008-2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel locals math math.functions math.ranges
|
||||
random sequences sets combinators.short-circuit math.bitwise ;
|
||||
random sequences sets combinators.short-circuit math.bitwise
|
||||
math math.order ;
|
||||
IN: math.miller-rabin
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: >odd ( n -- int ) dup even? [ 1 + ] when ; foldable
|
||||
: >odd ( n -- int ) 0 set-bit ; foldable
|
||||
|
||||
: >even ( n -- int ) 0 clear-bit ; foldable
|
||||
|
||||
TUPLE: positive-even-expected n ;
|
||||
: next-even ( m -- n ) >even 2 + ;
|
||||
|
||||
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: (miller-rabin) ( n trials -- ? )
|
||||
n 1 - :> n-1
|
||||
|
|
@ -18,20 +21,18 @@ TUPLE: positive-even-expected n ;
|
|||
0 :> a!
|
||||
trials [
|
||||
drop
|
||||
n 1 - [1,b] random a!
|
||||
2 n 2 - [a,b] random a!
|
||||
a s n ^mod 1 = [
|
||||
f
|
||||
] [
|
||||
r iota [
|
||||
2^ s * a swap n ^mod n - -1 =
|
||||
] any? not
|
||||
] any? not
|
||||
] if
|
||||
] any? not ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
|
||||
|
||||
: miller-rabin* ( n numtrials -- ? )
|
||||
over {
|
||||
{ [ dup 1 <= ] [ 3drop f ] }
|
||||
|
|
@ -42,11 +43,21 @@ PRIVATE>
|
|||
|
||||
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
|
||||
|
||||
ERROR: prime-range-error n ;
|
||||
|
||||
: next-prime ( n -- p )
|
||||
next-odd dup miller-rabin [ next-prime ] unless ;
|
||||
dup 1 < [ prime-range-error ] when
|
||||
dup 1 = [
|
||||
drop 2
|
||||
] [
|
||||
next-odd dup miller-rabin [ next-prime ] unless
|
||||
] if ;
|
||||
|
||||
: random-bits* ( numbits -- n )
|
||||
1 - [ random-bits ] keep set-bit ;
|
||||
|
||||
: random-prime ( numbits -- p )
|
||||
random-bits next-prime ;
|
||||
random-bits* next-prime ;
|
||||
|
||||
ERROR: no-relative-prime n ;
|
||||
|
||||
|
|
@ -80,10 +91,7 @@ ERROR: too-few-primes ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: >safe-prime-form ( q -- p ) 2 * 1 + ;
|
||||
|
||||
: safe-prime-candidate? ( n -- ? )
|
||||
>safe-prime-form
|
||||
1 + 6 divisor? ;
|
||||
|
||||
: next-safe-prime-candidate ( n -- candidate )
|
||||
|
|
@ -99,14 +107,8 @@ PRIVATE>
|
|||
} 1&& ;
|
||||
|
||||
: next-safe-prime ( n -- q )
|
||||
1 - >even 2 /
|
||||
next-safe-prime-candidate
|
||||
dup >safe-prime-form
|
||||
dup miller-rabin
|
||||
[ nip ] [ drop next-safe-prime ] if ;
|
||||
|
||||
: random-bits* ( numbits -- n )
|
||||
[ random-bits ] keep set-bit ;
|
||||
dup safe-prime? [ next-safe-prime ] unless ;
|
||||
|
||||
: random-safe-prime ( numbits -- p )
|
||||
1- random-bits* next-safe-prime ;
|
||||
random-bits* next-safe-prime ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ;
|
||||
IN: math.rectangles.prettyprint
|
||||
|
||||
M: rect pprint*
|
||||
\ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays sequences math math.vectors accessors
|
||||
parser prettyprint.custom prettyprint.backend ;
|
||||
parser ;
|
||||
IN: math.rectangles
|
||||
|
||||
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
||||
|
|
@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
|
|||
|
||||
SYNTAX: RECT: scan-object scan-object <rect> parsed ;
|
||||
|
||||
M: rect pprint*
|
||||
\ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
|
||||
|
||||
: <zero-rect> ( -- rect ) rect new ; inline
|
||||
|
||||
: point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
|
||||
|
|
@ -21,6 +18,8 @@ M: rect pprint*
|
|||
|
||||
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
|
||||
|
||||
: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
|
||||
|
||||
: with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
|
||||
[ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
|
||||
|
||||
|
|
@ -62,3 +61,7 @@ M: rect contains-point?
|
|||
[ [ loc>> ] dip (>>loc) ]
|
||||
[ [ dim>> ] dip (>>dim) ]
|
||||
2bi ; inline
|
||||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
|
||||
|
|
@ -14,3 +14,5 @@ USING: math.vectors tools.test ;
|
|||
[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test
|
||||
|
||||
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
|
||||
|
||||
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
|
||||
|
|
|
|||
|
|
@ -41,6 +41,10 @@ IN: math.vectors
|
|||
: set-axis ( u v axis -- w )
|
||||
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
|
||||
|
||||
: bilerp ( aa ba ab bb {t,u} -- a_tu )
|
||||
[ first lerp ] [ second lerp ] bi-curry
|
||||
[ 2bi@ ] [ call ] bi* ;
|
||||
|
||||
: vlerp ( a b t -- a_t )
|
||||
[ lerp ] 3map ;
|
||||
|
||||
|
|
|
|||
|
|
@ -39,6 +39,8 @@ SLOT: display-list
|
|||
|
||||
GENERIC: draw-scaled-texture ( dim texture -- )
|
||||
|
||||
DEFER: make-texture
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
|
||||
|
|
@ -61,18 +63,6 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
|
|||
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
|
||||
glTexSubImage2D ;
|
||||
|
||||
: make-texture ( image -- id )
|
||||
#! We use glTexSubImage2D to work around the power of 2 texture size
|
||||
#! limitation
|
||||
gen-texture [
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
non-power-of-2-textures? get
|
||||
[ dup bitmap>> (tex-image) ]
|
||||
[ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
|
||||
] do-attribs
|
||||
] keep ;
|
||||
|
||||
: init-texture ( -- )
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
|
||||
|
|
@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 }
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: make-texture ( image -- id )
|
||||
#! We use glTexSubImage2D to work around the power of 2 texture size
|
||||
#! limitation
|
||||
gen-texture [
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
non-power-of-2-textures? get
|
||||
[ dup bitmap>> (tex-image) ]
|
||||
[ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
|
||||
] do-attribs
|
||||
] keep ;
|
||||
|
||||
: <texture> ( image loc -- texture )
|
||||
over dim>> max-texture-size [ <= ] 2all?
|
||||
[ <single-texture> ]
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien.c-types kernel math namespaces sequences
|
||||
io.backend io.binary combinators system vocabs.loader
|
||||
summary math.bitwise byte-vectors fry byte-arrays
|
||||
math.ranges math.constants math.functions ;
|
||||
math.ranges math.constants math.functions accessors ;
|
||||
IN: random
|
||||
|
||||
SYMBOL: system-random-generator
|
||||
|
|
@ -70,8 +70,11 @@ PRIVATE>
|
|||
secure-random-generator get swap with-random ; inline
|
||||
|
||||
: uniform-random-float ( min max -- n )
|
||||
64 random-bits >float [ over - 2.0 -64 ^ * ] dip
|
||||
* + ;
|
||||
4 random-bytes underlying>> *uint >float
|
||||
4 random-bytes underlying>> *uint >float
|
||||
2.0 32 ^ * +
|
||||
[ over - 2.0 -64 ^ * ] dip
|
||||
* + ; inline
|
||||
|
||||
: normal-random-float ( mean sigma -- n )
|
||||
0.0 1.0 uniform-random-float
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@ IN: specialized-arrays.tests
|
|||
USING: tools.test specialized-arrays sequences
|
||||
specialized-arrays.int specialized-arrays.bool
|
||||
specialized-arrays.ushort alien.c-types accessors kernel
|
||||
specialized-arrays.direct.int specialized-arrays.char arrays ;
|
||||
specialized-arrays.direct.int specialized-arrays.char
|
||||
specialized-arrays.uint arrays combinators ;
|
||||
|
||||
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
|
||||
|
||||
|
|
@ -10,7 +11,13 @@ specialized-arrays.direct.int specialized-arrays.char arrays ;
|
|||
|
||||
[ 2 ] [ int-array{ 1 2 3 } second ] unit-test
|
||||
|
||||
[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test
|
||||
[ t ] [
|
||||
{ t f t } >bool-array underlying>>
|
||||
{ 1 0 1 } "bool" heap-size {
|
||||
{ 1 [ >char-array ] }
|
||||
{ 4 [ >uint-array ] }
|
||||
} case underlying>> =
|
||||
] unit-test
|
||||
|
||||
[ ushort-array{ 1234 } ] [
|
||||
little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
|
||||
|
|
|
|||
|
|
@ -23,7 +23,13 @@ IN: tools.deploy.shaker
|
|||
|
||||
: strip-init-hooks ( -- )
|
||||
"Stripping startup hooks" show
|
||||
{ "cpu.x86" "command-line" "libc" "system" "environment" }
|
||||
{
|
||||
"command-line"
|
||||
"cpu.x86"
|
||||
"environment"
|
||||
"libc"
|
||||
"alien.strings"
|
||||
}
|
||||
[ init-hooks get delete-at ] each
|
||||
deploy-threads? get [
|
||||
"threads" init-hooks get delete-at
|
||||
|
|
@ -36,8 +42,12 @@ IN: tools.deploy.shaker
|
|||
"io.backend" init-hooks get delete-at
|
||||
] when
|
||||
strip-dictionary? [
|
||||
"compiler.units" init-hooks get delete-at
|
||||
"vocabs.cache" init-hooks get delete-at
|
||||
{
|
||||
"compiler.units"
|
||||
"vocabs"
|
||||
"vocabs.cache"
|
||||
"source-files.errors"
|
||||
} [ init-hooks get delete-at ] each
|
||||
] when ;
|
||||
|
||||
: strip-debugger ( -- )
|
||||
|
|
@ -260,21 +270,20 @@ IN: tools.deploy.shaker
|
|||
compiler.errors:compiler-errors
|
||||
definition-observers
|
||||
interactive-vocabs
|
||||
layouts:num-tags
|
||||
layouts:num-types
|
||||
layouts:tag-mask
|
||||
layouts:tag-numbers
|
||||
layouts:type-numbers
|
||||
lexer-factory
|
||||
print-use-hook
|
||||
root-cache
|
||||
source-files.errors:error-types
|
||||
source-files.errors:error-observers
|
||||
vocabs:dictionary
|
||||
vocabs:load-vocab-hook
|
||||
vocabs:vocab-observers
|
||||
word
|
||||
parser-notes
|
||||
} %
|
||||
|
||||
{ } { "layouts" } strip-vocab-globals %
|
||||
|
||||
{ } { "math.partial-dispatch" } strip-vocab-globals %
|
||||
|
||||
{ } { "peg" } strip-vocab-globals %
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.vectors memory io io.styles prettyprint
|
||||
USING: kernel math memory io io.styles prettyprint
|
||||
namespaces system sequences splitting grouping assocs strings
|
||||
generic.single combinators ;
|
||||
IN: tools.time
|
||||
|
|
|
|||
|
|
@ -1,4 +1,30 @@
|
|||
IN: tools.trace.tests
|
||||
USING: tools.trace tools.test sequences ;
|
||||
USING: tools.trace tools.test tools.continuations kernel math combinators
|
||||
sequences ;
|
||||
|
||||
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
|
||||
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
|
||||
|
||||
GENERIC: method-breakpoint-test ( x -- y )
|
||||
|
||||
TUPLE: method-breakpoint-tuple ;
|
||||
|
||||
M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
|
||||
|
||||
\ method-breakpoint-test don't-step-into
|
||||
|
||||
[ 3 ]
|
||||
[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test
|
||||
|
||||
: case-breakpoint-test ( -- x )
|
||||
5 { [ break 1 + ] } case ;
|
||||
|
||||
\ case-breakpoint-test don't-step-into
|
||||
|
||||
[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test
|
||||
|
||||
: call(-breakpoint-test ( -- x )
|
||||
[ break 1 ] call( -- x ) 2 + ;
|
||||
|
||||
\ call(-breakpoint-test don't-step-into
|
||||
|
||||
[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel
|
|||
sequences concurrency.messaging locals continuations threads
|
||||
namespaces namespaces.private make assocs accessors io strings
|
||||
prettyprint math math.parser words effects summary io.styles classes
|
||||
generic.math combinators.short-circuit ;
|
||||
generic.math combinators.short-circuit kernel.private quotations ;
|
||||
IN: tools.trace
|
||||
|
||||
: callstack-depth ( callstack -- n )
|
||||
callstack>array length 2/ ;
|
||||
|
||||
SYMBOL: end
|
||||
|
||||
SYMBOL: exclude-vocabs
|
||||
SYMBOL: include-vocabs
|
||||
|
||||
exclude-vocabs { "math" "accessors" } swap set-global
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: callstack-depth ( callstack -- n )
|
||||
callstack>array length 2/ ;
|
||||
|
||||
SYMBOL: end
|
||||
|
||||
: include? ( vocab -- ? )
|
||||
include-vocabs get dup [ member? ] [ 2drop t ] if ;
|
||||
|
||||
|
|
@ -65,15 +67,20 @@ M: trace-step summary
|
|||
[ CHAR: \s <string> write ]
|
||||
[ number>string write ": " write ] bi ;
|
||||
|
||||
: trace-into? ( continuation -- ? )
|
||||
continuation-current into? ;
|
||||
|
||||
: trace-step ( continuation -- continuation' )
|
||||
dup continuation-current end eq? [
|
||||
[ print-depth ]
|
||||
[ print-step ]
|
||||
[
|
||||
dup continuation-current into?
|
||||
[ continuation-step-into ] [ continuation-step ] if
|
||||
] tri
|
||||
] unless ;
|
||||
dup call>> innermost-frame-executing quotation? [
|
||||
dup continuation-current end eq? [
|
||||
[ print-depth ]
|
||||
[ print-step ]
|
||||
[ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
|
||||
tri
|
||||
] unless
|
||||
] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: trace ( quot -- data )
|
||||
[ [ trace-step ] break-hook ] dip
|
||||
|
|
|
|||
|
|
@ -31,4 +31,8 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h )
|
|||
'[ select-gl-context @ ]
|
||||
[ flush-gl-context gl-error ] bi ; inline
|
||||
|
||||
HOOK: (with-ui) ui-backend ( quot -- )
|
||||
HOOK: (with-ui) ui-backend ( quot -- )
|
||||
|
||||
HOOK: (grab-input) ui-backend ( handle -- )
|
||||
|
||||
HOOK: (ungrab-input) ui-backend ( handle -- )
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{
|
|||
{ fullscreen { $ NSOpenGLPFAFullScreen } }
|
||||
{ windowed { $ NSOpenGLPFAWindow } }
|
||||
{ accelerated { $ NSOpenGLPFAAccelerated } }
|
||||
{ software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
|
||||
{ software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } }
|
||||
{ backing-store { $ NSOpenGLPFABackingStore } }
|
||||
{ multisampled { $ NSOpenGLPFAMultisample } }
|
||||
{ supersampled { $ NSOpenGLPFASupersample } }
|
||||
|
|
@ -122,6 +122,17 @@ M:: cocoa-ui-backend (open-window) ( world -- )
|
|||
M: cocoa-ui-backend (close-window) ( handle -- )
|
||||
window>> -> release ;
|
||||
|
||||
M: cocoa-ui-backend (grab-input) ( handle -- )
|
||||
0 CGAssociateMouseAndMouseCursorPosition drop
|
||||
CGMainDisplayID CGDisplayHideCursor drop
|
||||
window>> -> frame CGRect>rect rect-center
|
||||
first2 <CGPoint> CGWarpMouseCursorPosition drop ;
|
||||
|
||||
M: cocoa-ui-backend (ungrab-input) ( handle -- )
|
||||
drop
|
||||
CGMainDisplayID CGDisplayShowCursor drop
|
||||
1 CGAssociateMouseAndMouseCursorPosition drop ;
|
||||
|
||||
M: cocoa-ui-backend close-window ( gadget -- )
|
||||
find-world [
|
||||
handle>> [
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations
|
|||
command-line shuffle opengl ui.render ascii math.bitwise locals
|
||||
accessors math.rectangles math.order ascii calendar
|
||||
io.encodings.utf16n windows.errors literals ui.pixel-formats
|
||||
ui.pixel-formats.private memoize classes ;
|
||||
ui.pixel-formats.private memoize classes struct-arrays ;
|
||||
IN: ui.backend.windows
|
||||
|
||||
SINGLETON: windows-ui-backend
|
||||
|
|
@ -703,9 +703,23 @@ M: windows-ui-backend beep ( -- )
|
|||
"MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
|
||||
[ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
|
||||
|
||||
: client-area>RECT ( hwnd -- RECT )
|
||||
"RECT" <c-object>
|
||||
[ GetClientRect win32-error=0/f ]
|
||||
[ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
|
||||
[ nip ] 2tri ;
|
||||
|
||||
: hwnd>RECT ( hwnd -- RECT )
|
||||
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
|
||||
|
||||
M: windows-ui-backend (grab-input) ( handle -- )
|
||||
0 ShowCursor drop
|
||||
hWnd>> client-area>RECT ClipCursor drop ;
|
||||
M: windows-ui-backend (ungrab-input) ( handle -- )
|
||||
drop
|
||||
f ClipCursor drop
|
||||
1 ShowCursor drop ;
|
||||
|
||||
: fullscreen-flags ( -- n )
|
||||
{ WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -3,8 +3,7 @@
|
|||
USING: accessors arrays hashtables kernel models math namespaces
|
||||
make sequences quotations math.vectors combinators sorting
|
||||
binary-search vectors dlists deques models threads
|
||||
concurrency.flags math.order math.rectangles fry locals
|
||||
prettyprint.backend prettyprint.custom ;
|
||||
concurrency.flags math.order math.rectangles fry locals ;
|
||||
IN: ui.gadgets
|
||||
|
||||
! Values for orientation slot
|
||||
|
|
@ -28,9 +27,6 @@ interior
|
|||
boundary
|
||||
model ;
|
||||
|
||||
! Don't print gadgets with RECT: syntax
|
||||
M: gadget pprint* pprint-tuple ;
|
||||
|
||||
M: gadget equal? 2drop f ;
|
||||
|
||||
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
|
||||
|
|
@ -397,3 +393,7 @@ M: f request-focus-on 2drop ;
|
|||
|
||||
: focus-path ( gadget -- seq )
|
||||
[ focus>> ] follow ;
|
||||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.gadgets prettyprint.backend prettyprint.custom ;
|
||||
IN: ui.gadgets.prettyprint
|
||||
|
||||
! Don't print gadgets with RECT: syntax
|
||||
M: gadget pprint* pprint-tuple ;
|
||||
|
|
@ -11,7 +11,7 @@ CONSTANT: default-world-pixel-format-attributes
|
|||
{ windowed double-buffered T{ depth-bits { value 16 } } }
|
||||
|
||||
TUPLE: world < track
|
||||
active? focused?
|
||||
active? focused? grab-input?
|
||||
layers
|
||||
title status status-owner
|
||||
text-handle handle images
|
||||
|
|
@ -20,6 +20,7 @@ TUPLE: world < track
|
|||
|
||||
TUPLE: world-attributes
|
||||
{ world-class initial: world }
|
||||
grab-input?
|
||||
title
|
||||
status
|
||||
gadgets
|
||||
|
|
@ -63,13 +64,15 @@ M: world request-focus-on ( child gadget -- )
|
|||
vertical swap new-track
|
||||
t >>root?
|
||||
t >>active?
|
||||
{ 0 0 } >>window-loc ;
|
||||
{ 0 0 } >>window-loc
|
||||
f >>grab-input? ;
|
||||
|
||||
: apply-world-attributes ( world attributes -- world )
|
||||
{
|
||||
[ title>> >>title ]
|
||||
[ status>> >>status ]
|
||||
[ pixel-format-attributes>> >>pixel-format-attributes ]
|
||||
[ grab-input?>> >>grab-input? ]
|
||||
[ gadgets>> [ 1 track-add ] each ]
|
||||
} cleave ;
|
||||
|
||||
|
|
|
|||
|
|
@ -41,14 +41,23 @@ SYMBOL: windows
|
|||
lose-focus swap each-gesture
|
||||
gain-focus swap each-gesture ;
|
||||
|
||||
: ?grab-input ( world -- )
|
||||
dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
|
||||
|
||||
: ?ungrab-input ( world -- )
|
||||
dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
|
||||
|
||||
: focus-world ( world -- )
|
||||
t >>focused?
|
||||
dup raised-window
|
||||
focus-path f focus-gestures ;
|
||||
[ ?grab-input ] [
|
||||
dup raised-window
|
||||
focus-path f focus-gestures
|
||||
] bi ;
|
||||
|
||||
: unfocus-world ( world -- )
|
||||
f >>focused?
|
||||
focus-path f swap focus-gestures ;
|
||||
[ ?ungrab-input ]
|
||||
[ focus-path f swap focus-gestures ] bi ;
|
||||
|
||||
: try-to-open-window ( world -- )
|
||||
{
|
||||
|
|
@ -145,7 +154,9 @@ SYMBOL: ui-thread
|
|||
PRIVATE>
|
||||
|
||||
: find-window ( quot -- world )
|
||||
[ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
|
||||
[ windows get values ] dip
|
||||
'[ dup children>> [ ] [ nip first ] if-empty @ ]
|
||||
find-last nip ; inline
|
||||
|
||||
: ui-running? ( -- ? )
|
||||
\ ui-running get-global ;
|
||||
|
|
|
|||
|
|
@ -652,9 +652,9 @@ FUNCTION: HDC BeginPaint ( HWND hwnd, LPPAINTSTRUCT lpPaint ) ;
|
|||
FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ;
|
||||
! FUNCTION: ChildWindowFromPointEx
|
||||
! FUNCTION: ClientThreadSetup
|
||||
! FUNCTION: ClientToScreen
|
||||
FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ;
|
||||
! FUNCTION: CliImmSetHotKey
|
||||
! FUNCTION: ClipCursor
|
||||
FUNCTION: int ClipCursor ( RECT* clipRect ) ;
|
||||
FUNCTION: BOOL CloseClipboard ( ) ;
|
||||
! FUNCTION: CloseDesktop
|
||||
! FUNCTION: CloseWindow
|
||||
|
|
@ -1363,7 +1363,7 @@ CONSTANT: HWND_TOP f
|
|||
! FUNCTION: SetWindowWord
|
||||
! FUNCTION: SetWinEventHook
|
||||
! FUNCTION: ShowCaret
|
||||
! FUNCTION: ShowCursor
|
||||
FUNCTION: int ShowCursor ( BOOL show ) ;
|
||||
! FUNCTION: ShowOwnedPopups
|
||||
! FUNCTION: ShowScrollBar
|
||||
! FUNCTION: ShowStartGlass
|
||||
|
|
|
|||
|
|
@ -231,7 +231,8 @@ bi
|
|||
"vocabulary"
|
||||
{ "def" { "quotation" "quotations" } initial: [ ] }
|
||||
"props"
|
||||
{ "direct-entry-def" }
|
||||
"pic-def"
|
||||
"pic-tail-def"
|
||||
{ "counter" { "fixnum" "math" } }
|
||||
{ "sub-primitive" read-only }
|
||||
} define-builtin
|
||||
|
|
@ -505,6 +506,7 @@ tuple
|
|||
{ "load-locals" "locals.backend" (( ... n -- )) }
|
||||
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
|
||||
{ "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
|
||||
{ "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
|
||||
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
|
||||
{ "lookup-method" "generic.single.private" (( object methods -- method )) }
|
||||
{ "reset-dispatch-stats" "generic.single" (( -- )) }
|
||||
|
|
|
|||
|
|
@ -79,7 +79,6 @@ $nl
|
|||
{ $subsection continue-with }
|
||||
"Continuations as control-flow:"
|
||||
{ $subsection attempt-all }
|
||||
{ $subsection retry }
|
||||
{ $subsection with-return }
|
||||
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
|
||||
{ $subsection "continuations.private" } ;
|
||||
|
|
@ -232,21 +231,6 @@ HELP: attempt-all
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: retry
|
||||
{ $values
|
||||
{ "quot" quotation } { "n" integer }
|
||||
}
|
||||
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
|
||||
{ $examples
|
||||
"Try to get a 0 as a random number:"
|
||||
{ $unchecked-example "USING: continuations math prettyprint random ;"
|
||||
"[ 5 random 0 = ] 5 retry"
|
||||
"t"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ attempt-all retry } related-words
|
||||
|
||||
HELP: return
|
||||
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -155,8 +155,6 @@ ERROR: attempt-all-error ;
|
|||
] { } make peek swap [ rethrow ] when
|
||||
] if ; inline
|
||||
|
||||
: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline
|
||||
|
||||
TUPLE: condition error restarts continuation ;
|
||||
|
||||
C: <condition> condition ( error restarts cc -- condition )
|
||||
|
|
|
|||
|
|
@ -17,8 +17,6 @@ M: hook-combination picker
|
|||
|
||||
M: hook-combination dispatch# drop 0 ;
|
||||
|
||||
M: hook-combination inline-cache-quot 2drop f ;
|
||||
|
||||
M: hook-combination mega-cache-quot
|
||||
1quotation picker [ lookup-method (execute) ] surround ;
|
||||
|
||||
|
|
|
|||
|
|
@ -273,5 +273,5 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
|
|||
[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
|
||||
|
||||
[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test
|
||||
[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
|
||||
[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
|
||||
|
|
@ -163,7 +163,7 @@ M: hi-tag-dispatch-engine compile-engine
|
|||
|
||||
: build-fast-hash ( methods -- buckets )
|
||||
>alist V{ } clone [ hashcode 1array ] distribute-buckets
|
||||
[ compile-engines* >alist >array ] map ;
|
||||
[ compile-engines* >alist { } join ] map ;
|
||||
|
||||
M: echelon-dispatch-engine compile-engine
|
||||
dup n>> 0 = [
|
||||
|
|
@ -238,10 +238,14 @@ M: f compile-engine ;
|
|||
[ <engine> compile-engine ] bi
|
||||
] tri ;
|
||||
|
||||
HOOK: inline-cache-quot combination ( word methods -- quot/f )
|
||||
HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
|
||||
|
||||
M: single-combination inline-cache-quots 2drop f f ;
|
||||
|
||||
: define-inline-cache-quot ( word methods -- )
|
||||
[ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ;
|
||||
[ drop ] [ inline-cache-quots ] 2bi
|
||||
[ >>pic-def ] [ >>pic-tail-def ] bi*
|
||||
drop ;
|
||||
|
||||
HOOK: mega-cache-quot combination ( methods -- quot/f )
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors definitions generic generic.single kernel
|
||||
namespaces words math math.order combinators sequences
|
||||
generic.single.private quotations kernel.private
|
||||
assocs arrays layouts ;
|
||||
assocs arrays layouts make ;
|
||||
IN: generic.standard
|
||||
|
||||
TUPLE: standard-combination < single-combination # ;
|
||||
|
|
@ -38,17 +38,22 @@ M: standard-generic effective-method
|
|||
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
|
||||
(effective-method) ;
|
||||
|
||||
M: standard-combination inline-cache-quot ( word methods -- )
|
||||
: inline-cache-quot ( word methods miss-word -- quot )
|
||||
[ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
|
||||
|
||||
M: standard-combination inline-cache-quots
|
||||
#! Direct calls to the generic word (not tail calls or indirect calls)
|
||||
#! will jump to the inline cache entry point instead of the megamorphic
|
||||
#! dispatch entry point.
|
||||
combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
|
||||
[ \ inline-cache-miss inline-cache-quot ]
|
||||
[ \ inline-cache-miss-tail inline-cache-quot ]
|
||||
2bi ;
|
||||
|
||||
: make-empty-cache ( -- array )
|
||||
mega-cache-size get f <array> ;
|
||||
|
||||
M: standard-combination mega-cache-quot
|
||||
combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
|
||||
combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ;
|
||||
|
||||
M: standard-generic definer drop \ GENERIC# f ;
|
||||
|
||||
|
|
|
|||
|
|
@ -139,14 +139,14 @@ M: hashtable set-at ( value key hash -- )
|
|||
PRIVATE>
|
||||
|
||||
M: hashtable >alist
|
||||
[ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
|
||||
[ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
|
||||
[
|
||||
[
|
||||
[ 1 fixnum-shift-fast ] dip
|
||||
[ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
|
||||
] dip
|
||||
pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
|
||||
] 2curry each
|
||||
] 2curry each-integer
|
||||
] keep { } like ;
|
||||
|
||||
M: hashtable clone
|
||||
|
|
|
|||
|
|
@ -117,6 +117,7 @@ HELP: seek-relative
|
|||
}
|
||||
{ $description "Seeks to an offset from the current position of the stream pointer." } ;
|
||||
|
||||
{ seek-absolute seek-relative seek-end } related-words
|
||||
|
||||
HELP: seek-input
|
||||
{ $values
|
||||
|
|
@ -343,6 +344,10 @@ $nl
|
|||
{ $subsection bl }
|
||||
"Seeking on the default output stream:"
|
||||
{ $subsection seek-output }
|
||||
"Seeking descriptors:"
|
||||
{ $subsection seek-absolute }
|
||||
{ $subsection seek-relative }
|
||||
{ $subsection seek-end }
|
||||
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
|
||||
{ $subsection with-output-stream }
|
||||
{ $subsection with-output-stream* }
|
||||
|
|
|
|||
|
|
@ -245,10 +245,22 @@ HELP: times
|
|||
{ $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
|
||||
} ;
|
||||
|
||||
HELP: fp-special?
|
||||
{ $values { "x" real } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
|
||||
|
||||
HELP: fp-nan?
|
||||
{ $values { "x" real } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
|
||||
|
||||
HELP: fp-qnan?
|
||||
{ $values { "x" real } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
|
||||
|
||||
HELP: fp-snan?
|
||||
{ $values { "x" real } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
|
||||
|
||||
HELP: fp-infinity?
|
||||
{ $values { "x" real } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." }
|
||||
|
|
@ -257,7 +269,26 @@ HELP: fp-infinity?
|
|||
{ $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
|
||||
} ;
|
||||
|
||||
{ fp-nan? fp-infinity? } related-words
|
||||
HELP: fp-nan-payload
|
||||
{ $values { "x" real } { "bits" integer } }
|
||||
{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
|
||||
|
||||
HELP: <fp-nan>
|
||||
{ $values { "payload" integer } { "nan" float } }
|
||||
{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." }
|
||||
{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ;
|
||||
|
||||
{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload <fp-nan> } related-words
|
||||
|
||||
HELP: next-float
|
||||
{ $values { "m" float } { "n" float } }
|
||||
{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
|
||||
|
||||
HELP: prev-float
|
||||
{ $values { "m" float } { "n" float } }
|
||||
{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
|
||||
|
||||
{ next-float prev-float } related-words
|
||||
|
||||
HELP: real-part
|
||||
{ $values { "z" number } { "x" real } }
|
||||
|
|
|
|||
|
|
@ -12,7 +12,24 @@ IN: math.tests
|
|||
[ f ] [ 1/0. fp-nan? ] unit-test
|
||||
[ f ] [ -1/0. fp-nan? ] unit-test
|
||||
[ t ] [ -0/0. fp-nan? ] unit-test
|
||||
[ t ] [ 1 <fp-nan> fp-nan? ] unit-test
|
||||
! [ t ] [ 1 <fp-nan> fp-snan? ] unit-test
|
||||
! [ f ] [ 1 <fp-nan> fp-qnan? ] unit-test
|
||||
[ t ] [ HEX: 8000000000001 <fp-nan> fp-nan? ] unit-test
|
||||
[ f ] [ HEX: 8000000000001 <fp-nan> fp-snan? ] unit-test
|
||||
[ t ] [ HEX: 8000000000001 <fp-nan> fp-qnan? ] unit-test
|
||||
|
||||
[ t ] [ 1/0. fp-infinity? ] unit-test
|
||||
[ t ] [ -1/0. fp-infinity? ] unit-test
|
||||
[ f ] [ -0/0. fp-infinity? ] unit-test
|
||||
|
||||
[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
|
||||
[ t ] [ 0 <fp-nan> fp-infinity? ] unit-test
|
||||
|
||||
[ 0.0 ] [ -0.0 next-float ] unit-test
|
||||
[ t ] [ 1.0 dup next-float < ] unit-test
|
||||
[ t ] [ -1.0 dup next-float < ] unit-test
|
||||
|
||||
[ -0.0 ] [ 0.0 prev-float ] unit-test
|
||||
[ t ] [ 1.0 dup prev-float > ] unit-test
|
||||
[ t ] [ -1.0 dup prev-float > ] unit-test
|
||||
|
|
|
|||
|
|
@ -81,26 +81,64 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ;
|
|||
|
||||
UNION: number real complex ;
|
||||
|
||||
GENERIC: fp-nan? ( x -- ? )
|
||||
: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline
|
||||
|
||||
GENERIC: fp-special? ( x -- ? )
|
||||
GENERIC: fp-nan? ( x -- ? )
|
||||
GENERIC: fp-qnan? ( x -- ? )
|
||||
GENERIC: fp-snan? ( x -- ? )
|
||||
GENERIC: fp-infinity? ( x -- ? )
|
||||
GENERIC: fp-nan-payload ( x -- bits )
|
||||
|
||||
M: object fp-special?
|
||||
drop f ;
|
||||
M: object fp-nan?
|
||||
drop f ;
|
||||
|
||||
M: float fp-nan?
|
||||
double>bits -51 shift HEX: fff [ bitand ] keep = ;
|
||||
|
||||
GENERIC: fp-infinity? ( x -- ? )
|
||||
|
||||
M: object fp-qnan?
|
||||
drop f ;
|
||||
M: object fp-snan?
|
||||
drop f ;
|
||||
M: object fp-infinity?
|
||||
drop f ;
|
||||
M: object fp-nan-payload
|
||||
drop f ;
|
||||
|
||||
M: float fp-infinity? ( float -- ? )
|
||||
M: float fp-special?
|
||||
double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
|
||||
|
||||
M: float fp-nan-payload
|
||||
double>bits HEX: fffffffffffff bitand ; foldable flushable
|
||||
|
||||
M: float fp-nan?
|
||||
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
|
||||
|
||||
M: float fp-qnan?
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
|
||||
|
||||
M: float fp-snan?
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
|
||||
|
||||
M: float fp-infinity?
|
||||
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
|
||||
|
||||
: <fp-nan> ( payload -- nan )
|
||||
HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
|
||||
|
||||
: next-float ( m -- n )
|
||||
double>bits
|
||||
dup -52 shift HEX: 7ff [ bitand ] keep = [
|
||||
HEX: fffffffffffff bitand 0 =
|
||||
] [
|
||||
drop f
|
||||
] if ;
|
||||
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
|
||||
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
|
||||
1 + bits>double ! positive
|
||||
] if
|
||||
] if ; foldable flushable
|
||||
|
||||
: prev-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
|
||||
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
|
||||
1 - bits>double ! positive non-zero
|
||||
] if
|
||||
] if ; foldable flushable
|
||||
|
||||
: next-power-of-2 ( m -- n )
|
||||
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
|
||||
|
|
|
|||
|
|
@ -155,7 +155,8 @@ M: word reset-word
|
|||
[ subwords forget-all ]
|
||||
[ reset-word ]
|
||||
[
|
||||
f >>direct-entry-def
|
||||
f >>pic-def
|
||||
f >>pic-tail-def
|
||||
{
|
||||
"methods"
|
||||
"combination"
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ IN: benchmark.pidigits
|
|||
: >matrix ( q s r t -- z )
|
||||
4array 2 group ;
|
||||
|
||||
: produce ( z n -- z' )
|
||||
: produce ( z y -- z' )
|
||||
[ 10 ] dip -10 * 0 1 >matrix swap m. ;
|
||||
|
||||
: gen-x ( x -- matrix )
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ M: bunny-buffers bunny-geom
|
|||
GL_FLOAT 0 0 buffer-offset glNormalPointer
|
||||
[
|
||||
nv>> "float" heap-size * buffer-offset
|
||||
3 GL_FLOAT 0 roll glVertexPointer
|
||||
[ 3 GL_FLOAT 0 ] dip glVertexPointer
|
||||
] [
|
||||
ni>>
|
||||
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@ TUPLE: bunny-outlined
|
|||
|
||||
: outlining-supported? ( -- ? )
|
||||
"2.0" {
|
||||
"GL_ARB_shading_objects"
|
||||
"GL_ARB_shader_objects"
|
||||
"GL_ARB_draw_buffers"
|
||||
"GL_ARB_multitexture"
|
||||
} has-gl-version-or-extensions? {
|
||||
|
|
|
|||
|
|
@ -27,10 +27,10 @@ ARTICLE: "game-input" "Game controller input"
|
|||
{ $subsection mouse-state } ;
|
||||
|
||||
HELP: open-game-input
|
||||
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
|
||||
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
|
||||
|
||||
HELP: close-game-input
|
||||
{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ;
|
||||
{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
|
||||
|
||||
HELP: game-input-opened?
|
||||
{ $values { "?" "a boolean" } }
|
||||
|
|
|
|||
|
|
@ -1,38 +1,61 @@
|
|||
USING: arrays accessors continuations kernel system
|
||||
USING: arrays accessors continuations kernel math system
|
||||
sequences namespaces init vocabs vocabs.loader combinators ;
|
||||
IN: game-input
|
||||
|
||||
SYMBOLS: game-input-backend game-input-opened ;
|
||||
|
||||
game-input-opened [ 0 ] initialize
|
||||
|
||||
HOOK: (open-game-input) game-input-backend ( -- )
|
||||
HOOK: (close-game-input) game-input-backend ( -- )
|
||||
HOOK: (reset-game-input) game-input-backend ( -- )
|
||||
|
||||
HOOK: get-controllers game-input-backend ( -- sequence )
|
||||
|
||||
HOOK: product-string game-input-backend ( controller -- string )
|
||||
HOOK: product-id game-input-backend ( controller -- id )
|
||||
HOOK: instance-id game-input-backend ( controller -- id )
|
||||
|
||||
HOOK: read-controller game-input-backend ( controller -- controller-state )
|
||||
HOOK: calibrate-controller game-input-backend ( controller -- )
|
||||
|
||||
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
|
||||
|
||||
HOOK: read-mouse game-input-backend ( -- mouse-state )
|
||||
|
||||
HOOK: reset-mouse game-input-backend ( -- )
|
||||
|
||||
: game-input-opened? ( -- ? )
|
||||
game-input-opened get ;
|
||||
game-input-opened get zero? not ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
M: f (reset-game-input) ;
|
||||
|
||||
: reset-game-input ( -- )
|
||||
game-input-opened off
|
||||
(reset-game-input) ;
|
||||
|
||||
[ reset-game-input ] "game-input" add-init-hook
|
||||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: game-input-not-open ;
|
||||
|
||||
: open-game-input ( -- )
|
||||
game-input-opened? [
|
||||
(open-game-input)
|
||||
game-input-opened on
|
||||
] unless ;
|
||||
] unless
|
||||
game-input-opened [ 1+ ] change-global
|
||||
reset-mouse ;
|
||||
: close-game-input ( -- )
|
||||
game-input-opened [
|
||||
dup zero? [ game-input-not-open ] when
|
||||
1-
|
||||
] change-global
|
||||
game-input-opened? [
|
||||
(close-game-input)
|
||||
reset-game-input
|
||||
] when ;
|
||||
] unless ;
|
||||
|
||||
: with-game-input ( quot -- )
|
||||
open-game-input [ close-game-input ] [ ] cleanup ; inline
|
||||
|
|
@ -48,12 +71,6 @@ SYMBOLS:
|
|||
pov-up pov-up-right pov-right pov-down-right
|
||||
pov-down pov-down-left pov-left pov-up-left ;
|
||||
|
||||
HOOK: get-controllers game-input-backend ( -- sequence )
|
||||
|
||||
HOOK: product-string game-input-backend ( controller -- string )
|
||||
HOOK: product-id game-input-backend ( controller -- id )
|
||||
HOOK: instance-id game-input-backend ( controller -- id )
|
||||
|
||||
: find-controller-products ( product-id -- sequence )
|
||||
get-controllers [ product-id = ] with filter ;
|
||||
: find-controller-instance ( product-id instance-id -- controller/f )
|
||||
|
|
@ -63,25 +80,16 @@ HOOK: instance-id game-input-backend ( controller -- id )
|
|||
[ instance-id = ] 2bi* and
|
||||
] with with find nip ;
|
||||
|
||||
HOOK: read-controller game-input-backend ( controller -- controller-state )
|
||||
HOOK: calibrate-controller game-input-backend ( controller -- )
|
||||
|
||||
TUPLE: keyboard-state keys ;
|
||||
|
||||
M: keyboard-state clone
|
||||
call-next-method dup keys>> clone >>keys ;
|
||||
|
||||
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
|
||||
|
||||
TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
|
||||
|
||||
M: mouse-state clone
|
||||
call-next-method dup buttons>> clone >>buttons ;
|
||||
|
||||
HOOK: read-mouse game-input-backend ( -- mouse-state )
|
||||
|
||||
HOOK: reset-mouse game-input-backend ( -- )
|
||||
|
||||
{
|
||||
{ [ os windows? ] [ "game-input.dinput" require ] }
|
||||
{ [ os macosx? ] [ "game-input.iokit" require ] }
|
||||
|
|
|
|||
|
|
@ -1,13 +1,15 @@
|
|||
USING: cocoa cocoa.plists core-foundation iokit iokit.hid
|
||||
kernel cocoa.enumeration destructors math.parser cocoa.application
|
||||
sequences locals combinators.short-circuit threads
|
||||
namespaces assocs vectors arrays combinators
|
||||
namespaces assocs vectors arrays combinators hints alien
|
||||
core-foundation.run-loop accessors sequences.private
|
||||
alien.c-types math parser game-input vectors ;
|
||||
IN: game-input.iokit
|
||||
|
||||
SINGLETON: iokit-game-input-backend
|
||||
|
||||
SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
|
||||
|
||||
iokit-game-input-backend game-input-backend set-global
|
||||
|
||||
: hid-manager-matching ( matching-seq -- alien )
|
||||
|
|
@ -23,7 +25,6 @@ iokit-game-input-backend game-input-backend set-global
|
|||
|
||||
CONSTANT: game-devices-matching-seq
|
||||
{
|
||||
H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers
|
||||
H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
|
||||
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
|
||||
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
|
||||
|
|
@ -88,19 +89,17 @@ CONSTANT: hat-switch-matching-hash
|
|||
game-devices-matching-seq hid-manager-matching ;
|
||||
|
||||
: device-property ( device key -- value )
|
||||
<NSString> IOHIDDeviceGetProperty plist> ;
|
||||
<NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
|
||||
: element-property ( element key -- value )
|
||||
<NSString> IOHIDElementGetProperty plist> ;
|
||||
<NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
|
||||
: set-element-property ( element key value -- )
|
||||
[ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
|
||||
: transfer-element-property ( element from-key to-key -- )
|
||||
[ dupd element-property ] dip swap set-element-property ;
|
||||
[ dupd element-property ] dip swap
|
||||
[ set-element-property ] [ 2drop ] if* ;
|
||||
|
||||
: mouse-device? ( device -- ? )
|
||||
{
|
||||
[ 1 1 IOHIDDeviceConformsTo ]
|
||||
[ 1 2 IOHIDDeviceConformsTo ]
|
||||
} 1|| ;
|
||||
1 2 IOHIDDeviceConformsTo ;
|
||||
|
||||
: controller-device? ( device -- ? )
|
||||
{
|
||||
|
|
@ -113,28 +112,31 @@ CONSTANT: hat-switch-matching-hash
|
|||
[ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
|
||||
2array ;
|
||||
|
||||
: button? ( {usage-page,usage} -- ? )
|
||||
first 9 = ; inline
|
||||
: keyboard-key? ( {usage-page,usage} -- ? )
|
||||
first 7 = ; inline
|
||||
: button? ( element -- ? )
|
||||
IOHIDElementGetUsagePage 9 = ; inline
|
||||
: keyboard-key? ( element -- ? )
|
||||
IOHIDElementGetUsagePage 7 = ; inline
|
||||
: axis? ( element -- ? )
|
||||
IOHIDElementGetUsagePage 1 = ; inline
|
||||
|
||||
: x-axis? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 30 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 30 = ; inline
|
||||
: y-axis? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 31 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 31 = ; inline
|
||||
: z-axis? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 32 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 32 = ; inline
|
||||
: rx-axis? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 33 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 33 = ; inline
|
||||
: ry-axis? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 34 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 34 = ; inline
|
||||
: rz-axis? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 35 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 35 = ; inline
|
||||
: slider? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 36 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 36 = ; inline
|
||||
: wheel? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 38 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 38 = ; inline
|
||||
: hat-switch? ( {usage-page,usage} -- ? )
|
||||
{ 1 HEX: 39 } = ; inline
|
||||
IOHIDElementGetUsage HEX: 39 = ; inline
|
||||
|
||||
CONSTANT: pov-values
|
||||
{
|
||||
|
|
@ -152,45 +154,55 @@ CONSTANT: pov-values
|
|||
: pov-value ( value -- pov-direction )
|
||||
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
|
||||
|
||||
: record-button ( hid-value usage state -- )
|
||||
[ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
|
||||
: record-button ( state hid-value element -- )
|
||||
[ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
|
||||
|
||||
: record-controller ( controller-state value -- )
|
||||
dup IOHIDValueGetElement element-usage {
|
||||
{ [ dup button? ] [ rot record-button ] }
|
||||
{ [ dup x-axis? ] [ drop axis-value >>x drop ] }
|
||||
{ [ dup y-axis? ] [ drop axis-value >>y drop ] }
|
||||
{ [ dup z-axis? ] [ drop axis-value >>z drop ] }
|
||||
{ [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
|
||||
{ [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
|
||||
{ [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
|
||||
{ [ dup slider? ] [ drop axis-value >>slider drop ] }
|
||||
{ [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
|
||||
dup IOHIDValueGetElement {
|
||||
{ [ dup button? ] [ record-button ] }
|
||||
{ [ dup axis? ] [ {
|
||||
{ [ dup x-axis? ] [ drop axis-value >>x drop ] }
|
||||
{ [ dup y-axis? ] [ drop axis-value >>y drop ] }
|
||||
{ [ dup z-axis? ] [ drop axis-value >>z drop ] }
|
||||
{ [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
|
||||
{ [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
|
||||
{ [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
|
||||
{ [ dup slider? ] [ drop axis-value >>slider drop ] }
|
||||
{ [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
|
||||
[ 3drop ]
|
||||
} cond ] }
|
||||
[ 3drop ]
|
||||
} cond ;
|
||||
|
||||
SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
|
||||
HINTS: record-controller { controller-state alien } ;
|
||||
|
||||
: ?set-nth ( value nth seq -- )
|
||||
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
|
||||
|
||||
: record-keyboard ( value -- )
|
||||
dup IOHIDValueGetElement element-usage keyboard-key? [
|
||||
: record-keyboard ( keyboard-state value -- )
|
||||
dup IOHIDValueGetElement dup keyboard-key? [
|
||||
[ IOHIDValueGetIntegerValue c-bool> ]
|
||||
[ IOHIDValueGetElement IOHIDElementGetUsage ] bi
|
||||
+keyboard-state+ get ?set-nth
|
||||
] [ drop ] if ;
|
||||
[ IOHIDElementGetUsage ] bi*
|
||||
rot ?set-nth
|
||||
] [ 3drop ] if ;
|
||||
|
||||
: record-mouse ( value -- )
|
||||
dup IOHIDValueGetElement element-usage {
|
||||
{ [ dup button? ] [ +mouse-state+ get record-button ] }
|
||||
{ [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
|
||||
{ [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
|
||||
{ [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
|
||||
{ [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
|
||||
[ 2drop ]
|
||||
HINTS: record-keyboard { array alien } ;
|
||||
|
||||
: record-mouse ( mouse-state value -- )
|
||||
dup IOHIDValueGetElement {
|
||||
{ [ dup button? ] [ record-button ] }
|
||||
{ [ dup axis? ] [ {
|
||||
{ [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
|
||||
{ [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
|
||||
{ [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
|
||||
{ [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
|
||||
[ 3drop ]
|
||||
} cond ] }
|
||||
[ 3drop ]
|
||||
} cond ;
|
||||
|
||||
HINTS: record-mouse { mouse-state alien } ;
|
||||
|
||||
M: iokit-game-input-backend read-mouse
|
||||
+mouse-state+ get ;
|
||||
|
||||
|
|
@ -263,8 +275,8 @@ M: iokit-game-input-backend reset-mouse
|
|||
{ [ sender controller-device? ] [
|
||||
sender +controller-states+ get at value record-controller
|
||||
] }
|
||||
{ [ sender mouse-device? ] [ value record-mouse ] }
|
||||
[ value record-keyboard ]
|
||||
{ [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
|
||||
[ +keyboard-state+ get value record-keyboard ]
|
||||
} cond
|
||||
] IOHIDValueCallback ;
|
||||
|
||||
|
|
@ -289,7 +301,7 @@ M: iokit-game-input-backend (open-game-input)
|
|||
} cleave ;
|
||||
|
||||
M: iokit-game-input-backend (reset-game-input)
|
||||
{ +hid-manager+ +keyboard-state+ +controller-states+ }
|
||||
{ +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
|
||||
[ f swap set-global ] each ;
|
||||
|
||||
M: iokit-game-input-backend (close-game-input)
|
||||
|
|
@ -304,6 +316,7 @@ M: iokit-game-input-backend (close-game-input)
|
|||
f
|
||||
] change-global
|
||||
f +keyboard-state+ set-global
|
||||
f +mouse-state+ set-global
|
||||
f +controller-states+ set-global
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: accessors destructors kernel math math.order namespaces
|
||||
USING: accessors calendar destructors kernel math math.order namespaces
|
||||
system threads ;
|
||||
IN: game-loop
|
||||
|
||||
|
|
@ -50,7 +50,7 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
|
|||
|
||||
: (run-loop) ( loop -- )
|
||||
dup running?>>
|
||||
[ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
|
||||
[ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
|
||||
[ drop ] if ;
|
||||
|
||||
: run-loop ( loop -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,25 @@
|
|||
USING: accessors game-input game-loop kernel math ui.gadgets
|
||||
ui.gadgets.worlds ui.gestures ;
|
||||
IN: game-worlds
|
||||
|
||||
TUPLE: game-world < world
|
||||
game-loop
|
||||
{ tick-slice float initial: 0.0 } ;
|
||||
|
||||
GENERIC: tick-length ( world -- millis )
|
||||
|
||||
M: game-world draw*
|
||||
swap >>tick-slice draw-world ;
|
||||
|
||||
M: game-world begin-world
|
||||
dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
|
||||
drop
|
||||
open-game-input ;
|
||||
|
||||
M: game-world end-world
|
||||
close-game-input
|
||||
[ [ stop-loop ] when* f ] change-game-loop
|
||||
drop ;
|
||||
|
||||
M: game-world focusable-child* drop t ;
|
||||
|
||||
|
|
@ -1,15 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-name "Hello world (console)" }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-name "Hello world (console)" }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-threads? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-math? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ M: image <image-gadget>
|
|||
|
||||
M: string <image-gadget> load-image <image-gadget> ;
|
||||
|
||||
M: pathname <image-gadget> load-image <image-gadget> ;
|
||||
M: pathname <image-gadget> string>> load-image <image-gadget> ;
|
||||
|
||||
: image-window ( object -- ) <image-gadget> "Image" open-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -162,18 +162,19 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
|
|||
relayout-1 ;
|
||||
|
||||
M: key-caps-gadget graft*
|
||||
open-game-input
|
||||
dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
|
||||
drop ;
|
||||
|
||||
M: key-caps-gadget ungraft*
|
||||
alarm>> [ cancel-alarm ] when* ;
|
||||
alarm>> [ cancel-alarm ] when*
|
||||
close-game-input ;
|
||||
|
||||
M: key-caps-gadget handle-gesture
|
||||
drop [ key-down? ] [ key-up? ] bi or not ;
|
||||
|
||||
: key-caps ( -- )
|
||||
[
|
||||
open-game-input
|
||||
<key-caps-gadget> { 5 5 } <border> "Key Caps" open-window
|
||||
] with-ui ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel calendar io.directories io.encodings.utf8
|
||||
io.files io.launcher mason.child mason.cleanup mason.common
|
||||
mason.help mason.release mason.report mason.email mason.notify
|
||||
namespaces prettyprint ;
|
||||
io.files io.launcher namespaces prettyprint mason.child mason.cleanup
|
||||
mason.common mason.help mason.release mason.report mason.email
|
||||
mason.notify ;
|
||||
IN: mason.build
|
||||
|
||||
QUALIFIED: continuations
|
||||
|
|
@ -19,7 +19,10 @@ QUALIFIED: continuations
|
|||
|
||||
: begin-build ( -- )
|
||||
"factor" [ git-id ] with-directory
|
||||
[ "git-id" to-file ] [ notify-begin-build ] bi ;
|
||||
[ "git-id" to-file ]
|
||||
[ current-git-id set ]
|
||||
[ notify-begin-build ]
|
||||
tri ;
|
||||
|
||||
: build ( -- )
|
||||
create-build-dir
|
||||
|
|
|
|||
|
|
@ -4,9 +4,12 @@ USING: kernel namespaces sequences splitting system accessors
|
|||
math.functions make io io.files io.pathnames io.directories
|
||||
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
|
||||
combinators.short-circuit parser combinators calendar
|
||||
calendar.format arrays mason.config locals system debugger ;
|
||||
calendar.format arrays mason.config locals system debugger fry
|
||||
continuations ;
|
||||
IN: mason.common
|
||||
|
||||
SYMBOL: current-git-id
|
||||
|
||||
ERROR: output-process-error output process ;
|
||||
|
||||
M: output-process-error error.
|
||||
|
|
@ -35,15 +38,19 @@ M: unix really-delete-tree delete-tree ;
|
|||
<process>
|
||||
swap >>command
|
||||
15 minutes >>timeout
|
||||
+closed+ >>stdin
|
||||
try-output-process ;
|
||||
|
||||
: retry ( n quot -- )
|
||||
'[ drop @ f ] attempt-all drop ; inline
|
||||
|
||||
:: upload-safely ( local username host remote -- )
|
||||
[let* | temp [ remote ".incomplete" append ]
|
||||
scp-remote [ { username "@" host ":" temp } concat ]
|
||||
scp [ scp-command get ]
|
||||
ssh [ ssh-command get ] |
|
||||
{ scp local scp-remote } short-running-process
|
||||
{ ssh host "-l" username "mv" temp remote } short-running-process
|
||||
5 [ { scp local scp-remote } short-running-process ] retry
|
||||
5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
|
||||
] ;
|
||||
|
||||
: eval-file ( file -- obj )
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
IN: mason.email.tests
|
||||
USING: mason.email mason.common mason.config namespaces tools.test ;
|
||||
|
||||
[ "mason on linux-x86-64: error" ] [
|
||||
[ "mason on linux-x86-64: 12345 -- error" ] [
|
||||
[
|
||||
"linux" target-os set
|
||||
"x86.64" target-cpu set
|
||||
"12345" current-git-id set
|
||||
status-error subject prefix-subject
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces accessors combinators make smtp debugger
|
||||
prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
|
||||
mason.common mason.platform mason.config ;
|
||||
prettyprint sequences io io.streams.string io.encodings.utf8 io.files
|
||||
io.sockets mason.common mason.platform mason.config ;
|
||||
IN: mason.email
|
||||
|
||||
: prefix-subject ( str -- str' )
|
||||
|
|
@ -18,11 +18,11 @@ IN: mason.email
|
|||
send-email ;
|
||||
|
||||
: subject ( status -- str )
|
||||
{
|
||||
[ current-git-id get 7 short head " -- " ] dip {
|
||||
{ status-clean [ "clean" ] }
|
||||
{ status-dirty [ "dirty" ] }
|
||||
{ status-error [ "error" ] }
|
||||
} case ;
|
||||
} case 3append ;
|
||||
|
||||
: email-report ( report status -- )
|
||||
[ "text/html" ] dip subject email-status ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.directories io.files io.launcher kernel make
|
||||
mason.common mason.config mason.platform namespaces prettyprint
|
||||
sequences ;
|
||||
namespaces prettyprint sequences mason.common mason.config
|
||||
mason.platform ;
|
||||
IN: mason.release.branch
|
||||
|
||||
: branch-name ( -- string ) "clean-" platform append ;
|
||||
|
|
@ -21,7 +21,7 @@ IN: mason.release.branch
|
|||
] { } make ;
|
||||
|
||||
: push-to-clean-branch ( -- )
|
||||
push-to-clean-branch-cmd short-running-process ;
|
||||
5 [ push-to-clean-branch-cmd short-running-process ] retry ;
|
||||
|
||||
: upload-clean-image-cmd ( -- args )
|
||||
[
|
||||
|
|
@ -36,7 +36,7 @@ IN: mason.release.branch
|
|||
] { } make ;
|
||||
|
||||
: upload-clean-image ( -- )
|
||||
upload-clean-image-cmd short-running-process ;
|
||||
5 [ upload-clean-image-cmd short-running-process ] retry ;
|
||||
|
||||
: (update-clean-branch) ( -- )
|
||||
"factor" [
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: mason.report
|
|||
target-cpu get
|
||||
host-name
|
||||
build-dir
|
||||
"git-id" eval-file
|
||||
current-git-id get
|
||||
[XML
|
||||
<h1>Build report for <->/<-></h1>
|
||||
<table>
|
||||
|
|
@ -112,8 +112,7 @@ IN: mason.report
|
|||
benchmark-error-vocabs-file
|
||||
benchmark-error-messages-file
|
||||
error-dump
|
||||
|
||||
"Benchmark timings"
|
||||
|
||||
benchmarks-file eval-file benchmarks-table
|
||||
] output>array
|
||||
] with-report ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,17 @@
|
|||
USING: byte-arrays combinators images kernel locals math math.affine-transforms
|
||||
math.functions math.polynomials math.vectors random sequences
|
||||
sequences.product ;
|
||||
IN: perlin-noise
|
||||
USING: byte-arrays combinators fry images kernel locals math
|
||||
math.affine-transforms math.functions math.order
|
||||
math.polynomials math.vectors random random.mersenne-twister
|
||||
sequences sequences.product ;
|
||||
IN: noise
|
||||
|
||||
: <noise-table> ( -- table )
|
||||
: <perlin-noise-table> ( -- table )
|
||||
256 iota >byte-array randomize dup append ;
|
||||
|
||||
: with-seed ( seed quot -- )
|
||||
[ <mersenne-twister> ] dip with-random ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: fade ( point -- point' )
|
||||
{ 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
|
||||
|
||||
|
|
@ -51,7 +57,15 @@ IN: perlin-noise
|
|||
v w quot call
|
||||
; inline
|
||||
|
||||
:: noise ( table point -- value )
|
||||
: >byte-map ( floats -- bytes )
|
||||
[ 255.0 * >fixnum ] B{ } map-as ;
|
||||
|
||||
: >image ( bytes dim -- image )
|
||||
swap [ L f ] dip image boa ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: perlin-noise ( table point -- value )
|
||||
point unit-cube :> cube
|
||||
point dup vfloor v- :> gradients
|
||||
gradients fade :> faded
|
||||
|
|
@ -70,14 +84,38 @@ IN: perlin-noise
|
|||
[ faded second lerp ] 2bi@
|
||||
faded third lerp ;
|
||||
|
||||
: noise-map ( table transform dim -- map )
|
||||
[ iota ] map [ a.v 0.0 suffix noise ] with with product-map ;
|
||||
|
||||
: normalize-0-1 ( sequence -- sequence' )
|
||||
[ supremum ] [ infimum [ - ] keep ] [ ] tri
|
||||
[ swap - ] with map [ swap / ] with map ;
|
||||
|
||||
: noise-image ( table transform dim -- image )
|
||||
[ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ]
|
||||
[ swap [ L f ] dip image boa ] bi ;
|
||||
: clamp-0-1 ( sequence -- sequence' )
|
||||
[ 0.0 max 1.0 min ] map ;
|
||||
|
||||
: perlin-noise-map ( table transform dim -- map )
|
||||
[ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ;
|
||||
|
||||
: perlin-noise-byte-map ( table transform dim -- map )
|
||||
perlin-noise-map normalize-0-1 >byte-map ;
|
||||
|
||||
: perlin-noise-image ( table transform dim -- image )
|
||||
[ perlin-noise-byte-map ] [ >image ] bi ;
|
||||
|
||||
: uniform-noise-map ( seed dim -- map )
|
||||
[ product [ 0.0 1.0 uniform-random-float ] replicate ]
|
||||
curry with-seed ;
|
||||
|
||||
: uniform-noise-byte-map ( seed dim -- map )
|
||||
uniform-noise-map >byte-map ;
|
||||
|
||||
: uniform-noise-image ( seed dim -- image )
|
||||
[ uniform-noise-byte-map ] [ >image ] bi ;
|
||||
|
||||
: normal-noise-map ( seed sigma dim -- map )
|
||||
swap '[ _ product [ 0.5 _ normal-random-float ] replicate ]
|
||||
with-seed ;
|
||||
|
||||
: normal-noise-byte-map ( seed sigma dim -- map )
|
||||
normal-noise-map clamp-0-1 >byte-map ;
|
||||
|
||||
: normal-noise-image ( seed sigma dim -- image )
|
||||
[ normal-noise-byte-map ] [ >image ] bi ;
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
USING: arrays kernel math math.functions math.order math.vectors
|
||||
namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
|
||||
ui.gadgets.worlds ui.render accessors combinators ;
|
||||
ui.gadgets.worlds ui.render accessors combinators literals ;
|
||||
IN: opengl.demo-support
|
||||
|
||||
: FOV ( -- x ) 2.0 sqrt 1+ ; inline
|
||||
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
|
||||
CONSTANT: MOUSE-MOTION-SCALE 0.5
|
||||
CONSTANT: KEY-ROTATE-STEP 10.0
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ;
|
|||
IN: poker
|
||||
|
||||
HELP: <hand>
|
||||
{ $values { "str" string } { "hand" "a new hand" } }
|
||||
{ $values { "str" string } { "hand" "a new " { $link hand } } }
|
||||
{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: kernel math.order poker prettyprint ;"
|
||||
|
|
@ -12,8 +12,16 @@ HELP: <hand>
|
|||
}
|
||||
{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
|
||||
|
||||
HELP: best-hand
|
||||
{ $values { "str" string } { "hand" "a new " { $link hand } } }
|
||||
{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: kernel poker prettyprint ;"
|
||||
"\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" }
|
||||
} ;
|
||||
|
||||
HELP: >cards
|
||||
{ $values { "hand" "a hand" } { "str" string } }
|
||||
{ $values { "hand" hand } { "str" string } }
|
||||
{ $description "Outputs a string representation of a hand's cards." }
|
||||
{ $examples
|
||||
{ $example "USING: poker prettyprint ;"
|
||||
|
|
@ -21,10 +29,18 @@ HELP: >cards
|
|||
} ;
|
||||
|
||||
HELP: >value
|
||||
{ $values { "hand" "a hand" } { "str" string } }
|
||||
{ $values { "hand" hand } { "str" string } }
|
||||
{ $description "Outputs a string representation of a hand's value." }
|
||||
{ $examples
|
||||
{ $example "USING: poker prettyprint ;"
|
||||
"\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
|
||||
}
|
||||
{ $notes "This should not be used as a basis for hand comparison." } ;
|
||||
|
||||
HELP: <deck>
|
||||
{ $values { "deck" "a new " { $link deck } } }
|
||||
{ $description "Creates a standard deck of 52 cards." } ;
|
||||
|
||||
HELP: shuffle
|
||||
{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } }
|
||||
{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: accessors poker poker.private tools.test math.order kernel ;
|
||||
USING: accessors kernel math.order poker poker.private tools.test ;
|
||||
IN: poker.tests
|
||||
|
||||
[ 134236965 ] [ "KD" >ckf ] unit-test
|
||||
|
|
@ -26,3 +26,5 @@ IN: poker.tests
|
|||
|
||||
[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
|
||||
[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
|
||||
|
||||
[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
! Copyright (c) 2009 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors ascii binary-search combinators kernel locals math
|
||||
math.bitwise math.order poker.arrays sequences splitting ;
|
||||
! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
|
||||
! The contents of this file are licensed under the Simplified BSD License
|
||||
! A copy of the license is available at http://factorcode.org/license.txt
|
||||
USING: accessors arrays ascii binary-search combinators kernel locals math
|
||||
math.bitwise math.combinatorics math.order poker.arrays random sequences
|
||||
sequences.product splitting ;
|
||||
IN: poker
|
||||
|
||||
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
|
||||
|
|
@ -47,19 +49,21 @@ CONSTANT: QUEEN 10
|
|||
CONSTANT: KING 11
|
||||
CONSTANT: ACE 12
|
||||
|
||||
CONSTANT: STRAIGHT_FLUSH 1
|
||||
CONSTANT: FOUR_OF_A_KIND 2
|
||||
CONSTANT: FULL_HOUSE 3
|
||||
CONSTANT: FLUSH 4
|
||||
CONSTANT: STRAIGHT 5
|
||||
CONSTANT: THREE_OF_A_KIND 6
|
||||
CONSTANT: TWO_PAIR 7
|
||||
CONSTANT: ONE_PAIR 8
|
||||
CONSTANT: HIGH_CARD 9
|
||||
CONSTANT: STRAIGHT_FLUSH 0
|
||||
CONSTANT: FOUR_OF_A_KIND 1
|
||||
CONSTANT: FULL_HOUSE 2
|
||||
CONSTANT: FLUSH 3
|
||||
CONSTANT: STRAIGHT 4
|
||||
CONSTANT: THREE_OF_A_KIND 5
|
||||
CONSTANT: TWO_PAIR 6
|
||||
CONSTANT: ONE_PAIR 7
|
||||
CONSTANT: HIGH_CARD 8
|
||||
|
||||
CONSTANT: SUIT_STR { "C" "D" "H" "S" }
|
||||
|
||||
CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
|
||||
|
||||
CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
||||
CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
||||
"Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
|
||||
|
||||
: card-rank-prime ( rank -- n )
|
||||
|
|
@ -108,6 +112,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
|||
#! Cactus Kev Format
|
||||
>upper 1 cut (>ckf) ;
|
||||
|
||||
: parse-cards ( str -- seq )
|
||||
" " split [ >ckf ] map ;
|
||||
|
||||
: flush? ( cards -- ? )
|
||||
HEX: F000 [ bitand ] reduce 0 = not ;
|
||||
|
||||
|
|
@ -152,8 +159,8 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
|||
[ drop "S" ]
|
||||
} cond ;
|
||||
|
||||
: hand-rank ( hand -- rank )
|
||||
value>> {
|
||||
: hand-rank ( value -- rank )
|
||||
{
|
||||
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
|
||||
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
|
||||
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
|
||||
|
|
@ -165,24 +172,38 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
|||
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
|
||||
} cond ;
|
||||
|
||||
: card>string ( card -- str )
|
||||
[ >card-rank ] [ >card-suit ] bi append ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: hand
|
||||
{ cards sequence }
|
||||
{ value integer } ;
|
||||
{ value integer initial: 9999 } ;
|
||||
|
||||
M: hand <=> [ value>> ] compare ;
|
||||
M: hand equal?
|
||||
over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
|
||||
|
||||
: <hand> ( str -- hand )
|
||||
" " split [ >ckf ] map
|
||||
dup hand-value hand boa ;
|
||||
parse-cards dup hand-value hand boa ;
|
||||
|
||||
: best-hand ( str -- hand )
|
||||
parse-cards 5 hand new
|
||||
[ dup hand-value hand boa min ] reduce-combinations ;
|
||||
|
||||
: >cards ( hand -- str )
|
||||
cards>> [
|
||||
[ >card-rank ] [ >card-suit ] bi append
|
||||
] map " " join ;
|
||||
cards>> [ card>string ] map " " join ;
|
||||
|
||||
: >value ( hand -- str )
|
||||
hand-rank VALUE_STR nth ;
|
||||
value>> hand-rank VALUE_STR nth ;
|
||||
|
||||
TUPLE: deck
|
||||
{ cards sequence } ;
|
||||
|
||||
: <deck> ( -- deck )
|
||||
RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ;
|
||||
|
||||
: shuffle ( deck -- deck )
|
||||
[ randomize ] change-cards ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
5-card poker hand evaluator
|
||||
Poker hand evaluator
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
|
||||
! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.ranges project-euler.common sequences
|
||||
sets ;
|
||||
|
|
@ -47,14 +47,14 @@ PRIVATE>
|
|||
|
||||
|
||||
: euler001b ( -- answer )
|
||||
1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
|
||||
1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
|
||||
|
||||
! [ euler001b ] 100 ave-time
|
||||
! 0 ms ave run time - 0.06 SD (100 trials)
|
||||
|
||||
|
||||
: euler001c ( -- answer )
|
||||
1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
|
||||
1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ;
|
||||
|
||||
! [ euler001c ] 100 ave-time
|
||||
! 0 ms ave run time - 0.06 SD (100 trials)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (c) 2007 Aaron Schaefer.
|
||||
! Copyright (c) 2007, 2009 Aaron Schaefer.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.functions sequences project-euler.common ;
|
||||
USING: math math.functions math.ranges project-euler.common sequences ;
|
||||
IN: project-euler.005
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=5
|
||||
|
|
@ -18,7 +18,7 @@ IN: project-euler.005
|
|||
! --------
|
||||
|
||||
: euler005 ( -- answer )
|
||||
20 1 [ 1+ lcm ] reduce ;
|
||||
20 [1,b] 1 [ lcm ] reduce ;
|
||||
|
||||
! [ euler005 ] 100 ave-time
|
||||
! 0 ms ave run time - 0.14 SD (100 trials)
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue