steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
John Benediktsson 2009-05-10 06:30:44 -07:00
parent e530198446 bb8aaf9ce0
commit ecba1f73fb
148 changed files with 2399 additions and 1147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

201
basis/bootstrap/image/image.factor
View File

@ -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

1
basis/bootstrap/image/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
basis/bootstrap/image/syntax/syntax.factor Normal file
View File

@ -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 ;

11
basis/cocoa/plists/plists.factor
View File

@ -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 )

2
basis/compiler/codegen/codegen.factor
View File

@ -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 ;

7
basis/compiler/codegen/fixup/fixup.factor
View File

@ -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 ;

27
basis/compiler/constants/constants.factor
View File

@ -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,14 +14,14 @@ 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
@ -42,15 +42,14 @@ 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-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? ;

6
basis/compiler/tests/optimizer.factor
View File

@ -390,3 +390,9 @@ DEFER: loop-bbb
[ f ] [ \ broken-declaration optimized? ] 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

10
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
View File

@ -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

8
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
View File

@ -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 ;

19
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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

3
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -691,3 +691,6 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
TUPLE: circle me ;
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
! Joe found an oversight
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test

9
basis/core-graphics/core-graphics.factor
View File

@ -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 )

3
basis/core-graphics/types/types.factor
View File

@ -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

1
basis/cpu/architecture/architecture.factor
View File

@ -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 ( -- )

4
basis/cpu/ppc/assembler/assembler.factor
View File

@ -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

14
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -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 ;

163
basis/cpu/ppc/bootstrap.factor
View File

@ -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

54
basis/cpu/ppc/ppc.factor
View File

@ -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

6
basis/cpu/x86/32/32.factor
View File

@ -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

8
basis/cpu/x86/32/bootstrap.factor
View File

@ -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 >>

2
basis/cpu/x86/64/64.factor
View File

@ -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 ;

5
basis/cpu/x86/64/bootstrap.factor
View File

@ -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

30
basis/cpu/x86/assembler/assembler.factor
View File

@ -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 ;

39
basis/cpu/x86/bootstrap.factor
View File

@ -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)
[
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
] [ ] make
[ length JNE ] [ % ] bi
! fall-through on miss
] mega-lookup jit-define

20
basis/cpu/x86/x86.factor
View File

@ -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 )

6
basis/dlists/dlists-docs.factor
View File

@ -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." }

5
basis/dlists/dlists-tests.factor
View File

@ -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

7
basis/dlists/dlists.factor
View File

@ -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 ;

4
basis/io/backend/windows/privileges/privileges-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: io.backend.windows.privileges.tests
USING: io.backend.windows.privileges tools.test ;
[ [ ] with-privileges ] must-infer

9
basis/io/backend/windows/privileges/privileges.factor Normal file → Executable file
View File

@ -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 ] }

3
basis/io/files/unique/unique.factor
View File

@ -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

12
basis/io/launcher/windows/nt/nt-tests.factor
View File

@ -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" =

24
basis/literals/literals-docs.factor
View File

@ -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"

70
basis/math/combinatorics/combinatorics-docs.factor
View File

@ -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

53
basis/math/combinatorics/combinatorics-tests.factor
View File

@ -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

102
basis/math/combinatorics/combinatorics.factor
View File

@ -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,8 +12,21 @@ 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 ;
@ -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

6
basis/math/intervals/intervals.factor
View File

@ -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 ]

100
basis/math/miller-rabin/miller-rabin-docs.factor Normal file
View File

@ -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"

12
basis/math/miller-rabin/miller-rabin-tests.factor
View File

@ -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

46
basis/math/miller-rabin/miller-rabin.factor
View File

@ -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,7 +21,7 @@ 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
] [
@ -30,8 +33,6 @@ TUPLE: positive-even-expected n ;
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 ;

1
basis/math/rectangles/prettyprint/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

7
basis/math/rectangles/prettyprint/prettyprint.factor Normal file
View File

@ -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 ;

11
basis/math/rectangles/rectangles.factor
View File

@ -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

2
basis/math/vectors/vectors-tests.factor
View File

@ -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

4
basis/math/vectors/vectors.factor
View File

@ -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 ;

26
basis/opengl/textures/textures.factor
View File

@ -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> ]

9
basis/random/random.factor
View File

@ -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

11
basis/specialized-arrays/specialized-arrays-tests.factor
View File

@ -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

25
basis/tools/deploy/shaker/shaker.factor
View File

@ -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 %

2
basis/tools/time/time.factor
View File

@ -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

28
basis/tools/trace/trace-tests.factor
View File

@ -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
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

29
basis/tools/trace/trace.factor
View File

@ -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 call>> innermost-frame-executing quotation? [
dup continuation-current end eq? [
[ print-depth ]
[ print-step ]
[
dup continuation-current into?
[ continuation-step-into ] [ continuation-step ] if
] tri
] unless ;
[ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
tri
] unless
] when ;
PRIVATE>
: trace ( quot -- data )
[ [ trace-step ] break-hook ] dip

4
basis/ui/backend/backend.factor
View File

@ -32,3 +32,7 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h )
[ flush-gl-context gl-error ] bi ; inline
HOOK: (with-ui) ui-backend ( quot -- )
HOOK: (grab-input) ui-backend ( handle -- )
HOOK: (ungrab-input) ui-backend ( handle -- )

13
basis/ui/backend/cocoa/cocoa.factor
View File

@ -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>> [

16
basis/ui/backend/windows/windows.factor
View File

@ -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

10
basis/ui/gadgets/gadgets.factor
View File

@ -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

1
basis/ui/gadgets/prettyprint/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

7
basis/ui/gadgets/prettyprint/prettyprint.factor Normal file
View File

@ -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 ;

7
basis/ui/gadgets/worlds/worlds.factor
View File

@ -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 ;

17
basis/ui/ui.factor
View File

@ -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?
[ ?grab-input ] [
dup raised-window
focus-path f focus-gestures ;
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 ;

6
basis/windows/user32/user32.factor Normal file → Executable file
View File

@ -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

4
core/bootstrap/primitives.factor
View File

@ -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" (( -- )) }

16
core/continuations/continuations-docs.factor
View File

@ -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 } "." } ;

2
core/continuations/continuations.factor
View File

@ -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 )

2
core/generic/hook/hook.factor
View File

@ -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 ;

2
core/generic/single/single-tests.factor
View File

@ -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

10
core/generic/single/single.factor
View File

@ -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 )

13
core/generic/standard/standard.factor
View File

@ -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 ;

4
core/hashtables/hashtables.factor
View File

@ -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

5
core/io/io-docs.factor
View File

@ -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* }

33
core/math/math-docs.factor
View File

@ -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 } }

17
core/math/math-tests.factor
View File

@ -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

64
core/math/math.factor
View File

@ -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

3
core/words/words.factor
View File

@ -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"

2
extra/benchmark/pidigits/pidigits.factor
View File

@ -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 )

2
extra/bunny/model/model.factor
View File

@ -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

2
extra/bunny/outlined/outlined.factor
View File

@ -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? {

4
extra/game-input/game-input-docs.factor
View File

@ -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" } }

50
extra/game-input/game-input.factor
View File

@ -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 ] }

99
extra/game-input/iokit/iokit.factor
View File

@ -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,12 +154,13 @@ 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 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 ] }
@ -167,30 +170,39 @@ CONSTANT: pov-values
{ [ 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 ;

4
extra/game-loop/game-loop.factor
View File

@ -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 -- )

25
extra/game-worlds/game-worlds.factor Normal file
View File

@ -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 ;

16
extra/hello-world/deploy.factor
View File

@ -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 }
}

2
extra/images/viewer/viewer.factor
View File

@ -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 ;

5
extra/key-caps/key-caps.factor
View File

@ -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 ;

11
extra/mason/build/build.factor
View File

@ -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

13
extra/mason/common/common.factor
View File

@ -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 )

3
extra/mason/email/email-tests.factor
View File

@ -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

8
extra/mason/email/email.factor
View File

@ -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 ;

10
extra/mason/release/branch/branch.factor
View File

@ -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" [

3
extra/mason/report/report.factor
View File

@ -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>
@ -113,7 +113,6 @@ IN: mason.report
benchmark-error-messages-file
error-dump
"Benchmark timings"
benchmarks-file eval-file benchmarks-table
] output>array
] with-report ;

62
extra/perlin-noise/perlin-noise.factor → extra/noise/noise.factor
View File

@ -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 ;

4
extra/opengl/demo-support/demo-support.factor
View File

@ -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

22
extra/poker/poker-docs.factor
View File

@ -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." } ;

4
extra/poker/poker-tests.factor
View File

@ -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

67
extra/poker/poker.factor
View File

@ -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 ;

2
extra/poker/summary.txt
View File

@ -1 +1 @@
5-card poker hand evaluator
Poker hand evaluator

6
extra/project-euler/001/001.factor
View File

@ -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)

6
extra/project-euler/005/005.factor
View File

@ -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