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

basis/bootstrap/image/image.factor

@@ -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-relocations
-SYMBOL: jit-define-rt
-SYMBOL: jit-define-offset
 
-: compute-offset ( -- offset )
+: compute-offset ( rc -- offset )
-    building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
+    [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
 
 : jit-rel ( rc rt -- )
-    jit-define-rt set
+    over compute-offset 3array jit-relocations get push-all ;
-    jit-define-rc set
-    compute-offset jit-define-offset set ;
 
-: make-jit ( quot -- quad )
+: make-jit ( quot -- jit-data )
     [
+        V{ } clone jit-relocations set
         call( -- )
-        jit-define-rc get
+        jit-relocations get >array
-        jit-define-rt get
-        jit-define-offset get 3array
     ] B{ } make prefix ;
 
 : jit-define ( quot name -- )
@@ -128,98 +126,59 @@ SYMBOL: big-endian
 ! Bootstrap architecture name
 SYMBOL: architecture
 
-! Bootstrap global namesapce
+RESET
-SYMBOL: bootstrap-global
 
 ! 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
+USERENV: jit-prolog 23
-SYMBOL: jit-primitive-word
+USERENV: jit-primitive-word 24
-SYMBOL: jit-primitive
+USERENV: jit-primitive 25
-SYMBOL: jit-word-jump
+USERENV: jit-word-jump 26
-SYMBOL: jit-word-call
+USERENV: jit-word-call 27
-SYMBOL: jit-push-immediate
+USERENV: jit-word-special 28
-SYMBOL: jit-if-word
+USERENV: jit-if-word 29
-SYMBOL: jit-if-1
+USERENV: jit-if 30
-SYMBOL: jit-if-2
+USERENV: jit-epilog 31
-SYMBOL: jit-dip-word
+USERENV: jit-return 32
-SYMBOL: jit-dip
+USERENV: jit-profiling 33
-SYMBOL: jit-2dip-word
+USERENV: jit-push-immediate 34
-SYMBOL: jit-2dip
+USERENV: jit-dip-word 35
-SYMBOL: jit-3dip-word
+USERENV: jit-dip 36
-SYMBOL: jit-3dip
+USERENV: jit-2dip-word 37
-SYMBOL: jit-execute-word
+USERENV: jit-2dip 38
-SYMBOL: jit-execute-jump
+USERENV: jit-3dip-word 39
-SYMBOL: jit-execute-call
+USERENV: jit-3dip 40
-SYMBOL: jit-epilog
+USERENV: jit-execute-word 41
-SYMBOL: jit-return
+USERENV: jit-execute-jump 42
-SYMBOL: jit-profiling
+USERENV: jit-execute-call 43
-SYMBOL: jit-save-stack
 
 ! PIC stubs
-SYMBOL: pic-load
+USERENV: pic-load 47
-SYMBOL: pic-tag
+USERENV: pic-tag 48
-SYMBOL: pic-hi-tag
+USERENV: pic-hi-tag 49
-SYMBOL: pic-tuple
+USERENV: pic-tuple 50
-SYMBOL: pic-hi-tag-tuple
+USERENV: pic-hi-tag-tuple 51
-SYMBOL: pic-check-tag
+USERENV: pic-check-tag 52
-SYMBOL: pic-check
+USERENV: pic-check 53
-SYMBOL: pic-hit
+USERENV: pic-hit 54
-SYMBOL: pic-miss-word
+USERENV: pic-miss-word 55
+USERENV: pic-miss-tail-word 56
 
 ! Megamorphic dispatch
-SYMBOL: mega-lookup
+USERENV: mega-lookup 57
-SYMBOL: mega-lookup-word
+USERENV: mega-lookup-word 58
-SYMBOL: mega-miss-word
+USERENV: mega-miss-word 59
 
 ! Default definition for undefined words
-SYMBOL: undefined-quot
+USERENV: undefined-quot 60
-
-: 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-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 set ;
-    bootstrap-global emit-userenv ;
-
-: emit-boot-quot ( -- )
-    bootstrap-boot-quot emit-userenv ;
 
 : 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
+    [ undefined ] undefined-quot set ;
-    {
+
-        jit-prolog
+: emit-userenvs ( -- )
-        jit-primitive-word
+    userenvs get keys [ emit-userenv ] each ;
-        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 ;
 
 : 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
+    "Serializing user environment..." print flush
-    emit-boot-quot
+    emit-userenvs
     "Performing word fixups..." print flush
     fixup-words
     "Performing header fixups..." print flush

basis/bootstrap/image/syntax/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/bootstrap/image/syntax/syntax.factor

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

basis/cocoa/plists/plists.factor

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

basis/compiler/codegen/codegen.factor

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

basis/compiler/codegen/fixup/fixup.factor

@@ -56,8 +56,11 @@ SYMBOL: literal-table
 : rel-word ( word class -- )
     [ add-literal ] dip rt-xt rel-fixup ;
 
-: rel-word-direct ( word class -- )
+: rel-word-pic ( word class -- )
-    [ add-literal ] dip rt-xt-direct rel-fixup ;
+    [ 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 ;

basis/compiler/constants/constants.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel layouts system strings words quotations byte-arrays
-alien arrays ;
+alien arrays literals sequences ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
@@ -14,43 +14,42 @@ CONSTANT: deck-bits 18
 : float-offset ( -- n ) 8 float tag-number - ; inline
 : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
 : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
+: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
 : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
 : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
 : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
+: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
 : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
+: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
 : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
 
 ! Relocation classes
-CONSTANT: rc-absolute-cell    0
+CONSTANT: rc-absolute-cell 0
-CONSTANT: rc-absolute         1
+CONSTANT: rc-absolute 1
-CONSTANT: rc-relative         2
+CONSTANT: rc-relative 2
 CONSTANT: rc-absolute-ppc-2/2 3
-CONSTANT: rc-absolute-ppc-2   4
+CONSTANT: rc-absolute-ppc-2 4
-CONSTANT: rc-relative-ppc-2   5
+CONSTANT: rc-relative-ppc-2 5
-CONSTANT: rc-relative-ppc-3   6
+CONSTANT: rc-relative-ppc-3 6
-CONSTANT: rc-relative-arm-3   7
+CONSTANT: rc-relative-arm-3 7
-CONSTANT: rc-indirect-arm     8
+CONSTANT: rc-indirect-arm 8
-CONSTANT: rc-indirect-arm-pc  9
+CONSTANT: rc-indirect-arm-pc 9
 
 ! Relocation types
-CONSTANT: rt-primitive   0
+CONSTANT: rt-primitive 0
-CONSTANT: rt-dlsym       1
+CONSTANT: rt-dlsym 1
-CONSTANT: rt-dispatch    2
+CONSTANT: rt-dispatch 2
-CONSTANT: rt-xt          3
+CONSTANT: rt-xt 3
-CONSTANT: rt-xt-direct   4
+CONSTANT: rt-xt-pic 4
-CONSTANT: rt-here        5
+CONSTANT: rt-xt-pic-tail 5
-CONSTANT: rt-this        6
+CONSTANT: rt-here 6
-CONSTANT: rt-immediate   7
+CONSTANT: rt-this 7
-CONSTANT: rt-stack-chain 8
+CONSTANT: rt-immediate 8
-CONSTANT: rt-untagged    9
+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-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
-    [ rc-absolute-cell = ]
-    [ rc-absolute = ]
-    tri or or ;

basis/compiler/tests/optimizer.factor

@@ -389,4 +389,10 @@ DEFER: loop-bbb
 
 [ f ] [ \ broken-declaration optimized? ] unit-test
 
-[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+
+! Modular arithmetic bug
+: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
+
+[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
+[ -10 ] [ -10 modular-arithmetic-bug ] unit-test

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

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

basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

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

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -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<
+        in-d>> dup first value-info interval>> [0,inf] interval-subset?
-        [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
+        [ 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

basis/compiler/tree/propagation/propagation-tests.factor

@@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 ! Mutable tuples with circularity should not cause problems
 TUPLE: circle me ;
 
-[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+
+! Joe found an oversight
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test

basis/core-graphics/core-graphics.factor

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

basis/core-graphics/types/types.factor

@@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
 TYPEDEF: uint CGBitmapInfo
 
 TYPEDEF: int CGLError
+TYPEDEF: int CGError
+TYPEDEF: uint CGDirectDisplayID
+TYPEDEF: int boolean_t
 TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
+TYPEDEF: int CGLContextParameter

basis/cpu/architecture/architecture.factor

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

basis/cpu/ppc/assembler/assembler.factor

@@ -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
+USING: kernel namespaces words io.binary math math.order
-io.binary math math.order cpu.ppc.assembler.backend ;
+cpu.ppc.assembler.backend ;
 IN: cpu.ppc.assembler
 
 ! See the Motorola or IBM documentation for details. The opcode

basis/cpu/ppc/assembler/backend/backend.factor

@@ -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
+USING:  kernel namespaces make sequences words math
-compiler.constants kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer fry ;
-math.bitwise io.binary parser lexer ;
 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
+    '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
-    (( bo -- )) define-declared ;

basis/cpu/ppc/bootstrap.factor

@@ -9,8 +9,8 @@ IN: bootstrap.ppc
 4 \ cell set
 big-endian on
 
-CONSTANT: ds-reg 29
+CONSTANT: ds-reg 13
-CONSTANT: rs-reg 30
+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
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    11 6 profile-count-offset LWZ
+    11 3 profile-count-offset LWZ
     11 11 1 tag-fixnum ADDI
-    11 6 profile-count-offset STW
+    11 3 profile-count-offset STW
-    11 6 word-code-offset LWZ
+    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
+    3 1 xt-save STW
-    stack-frame 6 LI
+    stack-frame 3 LI
-    6 1 next-save STW
+    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
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
-    6 ds-reg 4 STWU
+    3 ds-reg 4 STWU
 ] jit-push-immediate jit-define
 
 [
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
-    7 6 0 LWZ
+    4 3 0 LWZ
-    1 7 0 STW
+    1 4 0 STW
-] jit-save-stack jit-define
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
-
+    3 MTCTR
-[
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
-    6 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

basis/cpu/ppc/ppc.factor

@@ -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
+alien alien.c-types literals cpu.architecture cpu.ppc.assembler
-compiler.cfg.registers compiler.cfg.instructions
+cpu.ppc.assembler.backend literals compiler.cfg.registers
-compiler.constants compiler.codegen compiler.codegen.fixup
+compiler.cfg.instructions compiler.constants compiler.codegen
-compiler.cfg.intrinsics compiler.cfg.stack-frame ;
+compiler.codegen.fixup compiler.cfg.intrinsics
+compiler.cfg.stack-frame ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
-! r2-r27: integer vregs
+! r2-r12: integer vregs
-! r28: integer scratch
+! r15-r29
-! r29: data stack
+! r30: integer scratch
-! r30: retain stack
 ! 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 } }
+        { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
-        { double-float-regs T{ range f 0 29 1 } }
+        { 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: ds-reg 13
-CONSTANT: rs-reg 30
+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

basis/cpu/x86/32/32.factor

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

basis/cpu/x86/32/bootstrap.factor

@@ -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
+    ! call the primitive
-
+    0 JMP rc-relative rt-primitive jit-rel
-[
-    (JMP) drop rc-relative rt-primitive jit-rel
 ] jit-primitive jit-define
 
 << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>

basis/cpu/x86/64/64.factor

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

basis/cpu/x86/64/bootstrap.factor

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

basis/cpu/x86/assembler/assembler.factor

@@ -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
+USING: arrays io.binary kernel combinators
-compiler.codegen.fixup io.binary kernel combinators
+kernel.private math namespaces make sequences words system layouts
-kernel.private math namespaces make sequences words system
+math.order accessors cpu.x86.assembler.syntax ;
-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: integer JMP HEX: e9 , 4, ;
-M: f JMP (JMP) 2drop ;
-M: callable JMP (JMP) rel-word ;
-M: label JMP (JMP) label-fixup ;
 M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 
 GENERIC: CALL ( op -- )
-: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
+M: integer CALL HEX: e8 , 4, ;
-M: f CALL (CALL) 2drop ;
-M: callable CALL (CALL) rel-word-direct ;
-M: label CALL (CALL) label-fixup ;
 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: integer JUMPcc extended-opcode, 4, ;
-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 ;
 
 : JO  ( dst -- ) HEX: 80 JUMPcc ;
 : JNO ( dst -- ) HEX: 81 JUMPcc ;

basis/cpu/x86/bootstrap.factor

@@ -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
+    0 JNE rc-relative rt-xt jit-rel
-] jit-if-1 jit-define
-
-[
     ! jump to false branch if equal
-    f JMP rc-relative rt-xt jit-rel
+    0 JMP rc-relative rt-xt jit-rel
-] jit-if-2 jit-define
+] 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++
-        temp0 temp0 bootstrap-cell [+] MOV
+    temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
-        temp0 word-xt-offset [+] JMP
+    temp1 [] 1 ADD
-    ] [ ] make
+    ! goto get(cache + bootstrap-cell)
-    [ length JNE ] [ % ] bi
+    temp0 temp0 bootstrap-cell [+] MOV
+    temp0 word-xt-offset [+] JMP
     ! fall-through on miss
 ] mega-lookup jit-define
 

basis/cpu/x86/x86.factor

@@ -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 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
-M: x86 %jump-label ( label -- ) JMP ;
+
+: 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 )

basis/dlists/dlists-docs.factor

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

basis/dlists/dlists-tests.factor

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

basis/dlists/dlists.factor

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

basis/io/backend/windows/privileges/privileges-tests.factor

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

basis/io/backend/windows/privileges/privileges.factor

@@ -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
+    [ '[ _ [ t set-privilege ] each @ ] ]
-    swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
+    [ drop '[ _ [ f set-privilege ] each ] ]
+    2bi [ ] cleanup ; inline
 
 {
     { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }

basis/io/files/unique/unique.factor

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

basis/io/launcher/windows/nt/nt-tests.factor

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

basis/literals/literals-docs.factor

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

basis/math/combinatorics/combinatorics-docs.factor

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

basis/math/combinatorics/combinatorics-tests.factor

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

basis/math/combinatorics/combinatorics.factor

@@ -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
+USING: accessors assocs binary-search fry kernel locals math math.order
-namespaces sequences sorting fry ;
+    math.ranges mirrors namespaces sequences sorting ;
 IN: math.combinatorics
 
 <PRIVATE
@@ -12,14 +12,27 @@ IN: math.combinatorics
 : twiddle ( n k -- n k )
     2dup - dupd > [ dupd - ] when ; inline
 
-! See this article for explanation of the factoradic-based permutation methodology:
+PRIVATE>
-! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
+
+: factorial ( n -- n! )
+    1 [ 1 + * ] reduce ;
+
+: nPk ( n k -- nPk )
+    2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
+
+: nCk ( n k -- nCk )
+    twiddle [ nPk ] keep factorial / ;
+
+
+! Factoradic-based permutation methodology
+
+<PRIVATE
 
 : factoradic ( n -- factoradic )
-    0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ;
+    0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
 
 : (>permutation) ( seq n -- seq )
-    [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
+    [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
 
 : >permutation ( factoradic -- permutation )
     reverse 1 cut [ (>permutation) ] each ;
@@ -29,27 +42,84 @@ IN: math.combinatorics
 
 PRIVATE>
 
-: factorial ( n -- n! )
-    1 [ 1+ * ] reduce ;
-
-: nPk ( n k -- nPk )
-    2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
-
-: nCk ( n k -- nCk )
-    twiddle [ nPk ] keep factorial / ;
-
 : permutation ( n seq -- seq )
     [ permutation-indices ] keep nths ;
 
 : all-permutations ( seq -- seq )
-    [ length factorial ] keep '[ _ permutation ] map ;
+    [ length factorial ] keep
+    '[ _ permutation ] map ;
 
 : each-permutation ( seq quot -- )
     [ [ length factorial ] keep ] dip
     '[ _ permutation @ ] each ; inline
 
-: reduce-permutations ( seq initial quot -- result )
+: reduce-permutations ( seq identity quot -- result )
     swapd each-permutation ; inline
 
 : inverse-permutation ( seq -- permutation )
     <enum> >alist sort-values keys ;
+
+
+! Combinadic-based combination methodology
+
+<PRIVATE
+
+TUPLE: combo
+    { seq sequence }
+    { k integer } ;
+
+C: <combo> combo
+
+: choose ( combo -- nCk )
+    [ seq>> length ] [ k>> ] bi nCk ;
+
+: largest-value ( a b x -- v )
+    dup 0 = [
+        drop 1 - nip
+    ] [
+        [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
+    ] if ;
+
+:: next-values ( a b x -- a' b' x' v )
+    a b x largest-value dup :> v  ! a'
+    b 1 -                         ! b'
+    x v b nCk -                   ! x'
+    v ;                           ! v == a'
+
+: dual-index ( m combo -- m' )
+    choose 1 - swap - ;
+
+: initial-values ( combo m -- n k m )
+    [ [ seq>> length ] [ k>> ] bi ] dip ;
+
+: combinadic ( combo m -- combinadic )
+    initial-values [ over 0 > ] [ next-values ] produce
+    [ 3drop ] dip ;
+
+: combination-indices ( m combo -- seq )
+    [ tuck dual-index combinadic ] keep
+    seq>> length 1 - swap [ - ] with map ;
+
+: apply-combination ( m combo -- seq )
+    [ combination-indices ] keep seq>> nths ;
+
+PRIVATE>
+
+: combination ( m seq k -- seq )
+    <combo> apply-combination ;
+
+: all-combinations ( seq k -- seq )
+    <combo> [ choose [0,b) ] keep
+    '[ _ apply-combination ] map ;
+
+: each-combination ( seq k quot -- )
+    [ <combo> [ choose [0,b) ] keep ] dip
+    '[ _ apply-combination @ ] each ; inline
+
+: map-combinations ( seq k quot -- )
+    [ <combo> [ choose [0,b) ] keep ] dip
+    '[ _ apply-combination @ ] map ; inline
+
+: reduce-combinations ( seq k identity quot -- result )
+    [ -rot ] dip each-combination ; inline
+

basis/math/intervals/intervals.factor

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

basis/math/miller-rabin/miller-rabin-docs.factor

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

basis/math/miller-rabin/miller-rabin-tests.factor

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

basis/math/miller-rabin/miller-rabin.factor

@@ -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 ) 0 set-bit ; foldable
-
-: >odd ( n -- int ) dup even? [ 1 + ] when ; foldable
 
 : >even ( n -- int ) 0 clear-bit ; foldable
 
-TUPLE: positive-even-expected n ;
+: next-even ( m -- n ) >even 2 + ;
+
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
+
+<PRIVATE
 
 :: (miller-rabin) ( n trials -- ? )
     n 1 - :> n-1
@@ -18,20 +21,18 @@ TUPLE: positive-even-expected n ;
     0 :> a!
     trials [
         drop
-        n 1 - [1,b] random a!
+        2 n 2 - [a,b] random a!
         a s n ^mod 1 = [
             f
         ] [
             r iota [
                 2^ s * a swap n ^mod n - -1 =
-            ] any? not 
+            ] any? not
         ] if
     ] any? not ;
 
 PRIVATE>
 
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
-
 : miller-rabin* ( n numtrials -- ? )
     over {
         { [ dup 1 <= ] [ 3drop f ] }
@@ -42,11 +43,21 @@ PRIVATE>
 
 : miller-rabin ( n -- ? ) 10 miller-rabin* ;
 
+ERROR: prime-range-error n ;
+
 : next-prime ( n -- p )
-    next-odd dup miller-rabin [ next-prime ] unless ;
+    dup 1 < [ prime-range-error ] when
+    dup 1 = [
+        drop 2
+    ] [
+        next-odd dup miller-rabin [ next-prime ] unless
+    ] if ;
+
+: random-bits* ( numbits -- n )
+    1 - [ random-bits ] keep set-bit ;
 
 : random-prime ( numbits -- p )
-    random-bits next-prime ;
+    random-bits* next-prime ;
 
 ERROR: no-relative-prime n ;
 
@@ -80,10 +91,7 @@ ERROR: too-few-primes ;
 
 <PRIVATE
 
-: >safe-prime-form ( q -- p ) 2 * 1 + ;
-
 : safe-prime-candidate? ( n -- ? )
-    >safe-prime-form
     1 + 6 divisor? ;
 
 : next-safe-prime-candidate ( n -- candidate )
@@ -99,14 +107,8 @@ PRIVATE>
     } 1&& ;
 
 : next-safe-prime ( n -- q )
-    1 - >even 2 /
     next-safe-prime-candidate
-    dup >safe-prime-form
+    dup safe-prime? [ next-safe-prime ] unless ;
-    dup miller-rabin
-    [ nip ] [ drop next-safe-prime ] if ;
-
-: random-bits* ( numbits -- n )
-    [ random-bits ] keep set-bit ;
 
 : random-safe-prime ( numbits -- p )
-    1- random-bits* next-safe-prime ;
+    random-bits* next-safe-prime ;

basis/math/rectangles/prettyprint/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/math/rectangles/prettyprint/prettyprint.factor

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

basis/math/rectangles/rectangles.factor

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

basis/math/vectors/vectors-tests.factor

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

basis/math/vectors/vectors.factor

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

basis/opengl/textures/textures.factor

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

basis/random/random.factor

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

basis/specialized-arrays/specialized-arrays-tests.factor

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

basis/tools/deploy/shaker/shaker.factor

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

basis/tools/time/time.factor

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

basis/tools/trace/trace-tests.factor

@@ -1,4 +1,30 @@
 IN: tools.trace.tests
-USING: tools.trace tools.test sequences ;
+USING: tools.trace tools.test tools.continuations kernel math combinators
+sequences ;
 
-[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
+
+GENERIC: method-breakpoint-test ( x -- y )
+
+TUPLE: method-breakpoint-tuple ;
+
+M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
+
+\ method-breakpoint-test don't-step-into
+
+[ 3 ]
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test
+
+: case-breakpoint-test ( -- x )
+    5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test
+
+: call(-breakpoint-test ( -- x )
+    [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test

basis/tools/trace/trace.factor

@@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel
 sequences concurrency.messaging locals continuations threads
 namespaces namespaces.private make assocs accessors io strings
 prettyprint math math.parser words effects summary io.styles classes
-generic.math combinators.short-circuit ;
+generic.math combinators.short-circuit kernel.private quotations ;
 IN: tools.trace
 
-: callstack-depth ( callstack -- n )
-    callstack>array length 2/ ;
-
-SYMBOL: end
-
 SYMBOL: exclude-vocabs
 SYMBOL: include-vocabs
 
 exclude-vocabs { "math" "accessors" } swap set-global
 
+<PRIVATE
+
+: callstack-depth ( callstack -- n )
+    callstack>array length 2/ ;
+
+SYMBOL: end
+
 : include? ( vocab -- ? )
     include-vocabs get dup [ member? ] [ 2drop t ] if ;
 
@@ -65,15 +67,20 @@ M: trace-step summary
     [ CHAR: \s <string> write ]
     [ number>string write ": " write ] bi ;
 
+: trace-into? ( continuation -- ? )
+    continuation-current into? ;
+
 : trace-step ( continuation -- continuation' )
-    dup continuation-current end eq? [
+    dup call>> innermost-frame-executing quotation? [
-        [ print-depth ]
+        dup continuation-current end eq? [
-        [ print-step ]
+            [ print-depth ]
-        [
+            [ print-step ]
-            dup continuation-current into?
+            [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
-            [ continuation-step-into ] [ continuation-step ] if
+            tri
-        ] tri
+        ] unless
-    ] unless ;
+    ] when ;
+
+PRIVATE>
 
 : trace ( quot -- data )
     [ [ trace-step ] break-hook ] dip

basis/ui/backend/backend.factor

@@ -31,4 +31,8 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h )
     '[ select-gl-context @ ]
     [ flush-gl-context gl-error ] bi ; inline
 
-HOOK: (with-ui) ui-backend ( quot -- )
+HOOK: (with-ui) ui-backend ( quot -- )
+
+HOOK: (grab-input) ui-backend ( handle -- )
+
+HOOK: (ungrab-input) ui-backend ( handle -- )

basis/ui/backend/cocoa/cocoa.factor

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

basis/ui/backend/windows/windows.factor

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

basis/ui/gadgets/gadgets.factor

@@ -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
+concurrency.flags math.order math.rectangles fry locals ;
-prettyprint.backend prettyprint.custom ;
 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

basis/ui/gadgets/prettyprint/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/ui/gadgets/prettyprint/prettyprint.factor

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

basis/ui/gadgets/worlds/worlds.factor

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

basis/ui/ui.factor

@@ -41,14 +41,23 @@ SYMBOL: windows
     lose-focus swap each-gesture
     gain-focus swap each-gesture ;
 
+: ?grab-input ( world -- )
+    dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
+
+: ?ungrab-input ( world -- )
+    dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
+
 : focus-world ( world -- )
     t >>focused?
-    dup raised-window
+    [ ?grab-input ] [
-    focus-path f focus-gestures ;
+        dup raised-window
+        focus-path f focus-gestures
+    ] bi ;
 
 : unfocus-world ( world -- )
     f >>focused?
-    focus-path f swap focus-gestures ;
+    [ ?ungrab-input ]
+    [ focus-path f swap focus-gestures ] bi ;
 
 : try-to-open-window ( world -- )
     {
@@ -145,7 +154,9 @@ SYMBOL: ui-thread
 PRIVATE>
 
 : find-window ( quot -- world )
-    [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
+    [ windows get values ] dip
+    '[ dup children>> [ ] [ nip first ] if-empty @ ]
+    find-last nip ; inline
 
 : ui-running? ( -- ? )
     \ ui-running get-global ;

basis/windows/user32/user32.factor

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

core/bootstrap/primitives.factor

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

core/continuations/continuations-docs.factor

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

core/continuations/continuations.factor

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

core/generic/hook/hook.factor

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

core/generic/single/single-tests.factor

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

core/generic/single/single.factor

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

core/generic/standard/standard.factor

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

core/hashtables/hashtables.factor

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

core/io/io-docs.factor

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

core/math/math-docs.factor

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

core/math/math-tests.factor

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

core/math/math.factor

@@ -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: object fp-qnan?
-M: float fp-nan?
+    drop f ;
-    double>bits -51 shift HEX: fff [ bitand ] keep = ;
+M: object fp-snan?
-
+    drop f ;
-GENERIC: fp-infinity? ( x -- ? )
-
 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 = [
+    dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
-        HEX: fffffffffffff bitand 0 =
+        dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
-    ] [
+            1 + bits>double ! positive
-        drop f
+        ] if
-    ] 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

core/words/words.factor

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

extra/benchmark/pidigits/pidigits.factor

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

extra/bunny/model/model.factor

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

extra/bunny/outlined/outlined.factor

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

extra/game-input/game-input-docs.factor

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

extra/game-input/game-input.factor

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

extra/game-input/iokit/iokit.factor

@@ -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 2 IOHIDDeviceConformsTo ;
-        [ 1 1 IOHIDDeviceConformsTo ]
-        [ 1 2 IOHIDDeviceConformsTo ]
-    } 1|| ;
 
 : controller-device? ( device -- ? )
     {
@@ -113,28 +112,31 @@ CONSTANT: hat-switch-matching-hash
     [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
     2array ;
 
-: button? ( {usage-page,usage} -- ? )
+: button? ( element -- ? )
-    first 9 = ; inline
+    IOHIDElementGetUsagePage 9 = ; inline
-: keyboard-key? ( {usage-page,usage} -- ? )
+: keyboard-key? ( element -- ? )
-    first 7 = ; inline
+    IOHIDElementGetUsagePage 7 = ; inline
+: axis? ( element -- ? )
+    IOHIDElementGetUsagePage 1 = ; inline
+
 : x-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 30 } = ; inline
+    IOHIDElementGetUsage HEX: 30 = ; inline
 : y-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 31 } = ; inline
+    IOHIDElementGetUsage HEX: 31 = ; inline
 : z-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 32 } = ; inline
+    IOHIDElementGetUsage HEX: 32 = ; inline
 : rx-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 33 } = ; inline
+    IOHIDElementGetUsage HEX: 33 = ; inline
 : ry-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 34 } = ; inline
+    IOHIDElementGetUsage HEX: 34 = ; inline
 : rz-axis? ( {usage-page,usage} -- ? )
-    { 1 HEX: 35 } = ; inline
+    IOHIDElementGetUsage HEX: 35 = ; inline
 : slider? ( {usage-page,usage} -- ? )
-    { 1 HEX: 36 } = ; inline
+    IOHIDElementGetUsage HEX: 36 = ; inline
 : wheel? ( {usage-page,usage} -- ? )
-    { 1 HEX: 38 } = ; inline
+    IOHIDElementGetUsage HEX: 38 = ; inline
 : hat-switch? ( {usage-page,usage} -- ? )
-    { 1 HEX: 39 } = ; inline
+    IOHIDElementGetUsage HEX: 39 = ; inline
 
 CONSTANT: pov-values
     {
@@ -152,45 +154,55 @@ CONSTANT: pov-values
 : pov-value ( value -- pov-direction )
     IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
 
-: record-button ( hid-value usage state -- )
+: record-button ( state hid-value element -- )
-    [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
+    [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
 
 : record-controller ( controller-state value -- )
-    dup IOHIDValueGetElement element-usage {
+    dup IOHIDValueGetElement {
-        { [ dup button? ] [ rot record-button ] } 
+        { [ dup button? ] [ record-button ] } 
-        { [ dup x-axis? ] [ drop axis-value >>x drop ] }
+        { [ dup axis? ] [ {
-        { [ dup y-axis? ] [ drop axis-value >>y drop ] }
+            { [ dup x-axis? ] [ drop axis-value >>x drop ] }
-        { [ dup z-axis? ] [ drop axis-value >>z drop ] }
+            { [ dup y-axis? ] [ drop axis-value >>y drop ] }
-        { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+            { [ dup z-axis? ] [ drop axis-value >>z drop ] }
-        { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+            { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
-        { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+            { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
-        { [ dup slider? ] [ drop axis-value >>slider drop ] }
+            { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
-        { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+            { [ dup slider? ] [ drop axis-value >>slider drop ] }
+            { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+            [ 3drop ]
+        } cond ] }
         [ 3drop ]
     } cond ;
 
-SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+HINTS: record-controller { controller-state alien } ;
 
 : ?set-nth ( value nth seq -- )
     2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
 
-: record-keyboard ( value -- )
+: record-keyboard ( keyboard-state value -- )
-    dup IOHIDValueGetElement element-usage keyboard-key? [
+    dup IOHIDValueGetElement dup keyboard-key? [
         [ IOHIDValueGetIntegerValue c-bool> ]
-        [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
+        [ IOHIDElementGetUsage ] bi*
-        +keyboard-state+ get ?set-nth
+        rot ?set-nth
-    ] [ drop ] if ;
+    ] [ 3drop ] if ;
 
-: record-mouse ( value -- )
+HINTS: record-keyboard { array alien } ;
-    dup IOHIDValueGetElement element-usage {
+
-        { [ dup button? ] [ +mouse-state+ get record-button ] }
+: record-mouse ( mouse-state value -- )
-        { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
+    dup IOHIDValueGetElement {
-        { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
+        { [ dup button? ] [ record-button ] }
-        { [ dup wheel?  ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
+        { [ dup axis? ] [ {
-        { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
+            { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
-        [ 2drop ]
+            { [ 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 ] }
+            { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
-            [ value record-keyboard ]
+            [ +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 ;
 

extra/game-loop/game-loop.factor

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

extra/game-worlds/game-worlds.factor

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

extra/hello-world/deploy.factor

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

extra/images/viewer/viewer.factor

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

extra/key-caps/key-caps.factor

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

extra/mason/build/build.factor

@@ -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
+io.files io.launcher namespaces prettyprint mason.child mason.cleanup
-mason.help mason.release mason.report mason.email mason.notify
+mason.common mason.help mason.release mason.report mason.email
-namespaces prettyprint ;
+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

extra/mason/common/common.factor

@@ -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
+        5 [ { scp local scp-remote } short-running-process ] retry
-        { ssh host "-l" username "mv" temp remote } short-running-process
+        5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
     ] ;
 
 : eval-file ( file -- obj )

extra/mason/email/email-tests.factor

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

extra/mason/email/email.factor

@@ -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
+prettyprint sequences io io.streams.string io.encodings.utf8 io.files
-mason.common mason.platform mason.config ;
+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 ;

extra/mason/release/branch/branch.factor

@@ -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
+namespaces prettyprint sequences mason.common mason.config
-sequences ;
+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" [

extra/mason/report/report.factor

@@ -12,7 +12,7 @@ IN: mason.report
     target-cpu get
     host-name
     build-dir
-    "git-id" eval-file
+    current-git-id get
     [XML
     <h1>Build report for <->/<-></h1>
     <table>
@@ -112,8 +112,7 @@ IN: mason.report
             benchmark-error-vocabs-file
             benchmark-error-messages-file
             error-dump
-            
+
-            "Benchmark timings"
             benchmarks-file eval-file benchmarks-table
         ] output>array
     ] with-report ;

extra/noise/noise.factor

@@ -1,11 +1,17 @@
-USING: byte-arrays combinators images kernel locals math math.affine-transforms
+USING: byte-arrays combinators fry images kernel locals math
-math.functions math.polynomials math.vectors random sequences
+math.affine-transforms math.functions math.order
-sequences.product ;
+math.polynomials math.vectors random random.mersenne-twister
-IN: perlin-noise
+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 )
+: clamp-0-1 ( sequence -- sequence' )
-    [ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ]
+    [ 0.0 max 1.0 min ] map ;
-    [ swap [ L f ] dip image boa ] bi ;
 
+: 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 ;

extra/opengl/demo-support/demo-support.factor

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

extra/poker/poker-docs.factor

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

extra/poker/poker-tests.factor

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

extra/poker/poker.factor

@@ -1,7 +1,9 @@
-! Copyright (c) 2009 Aaron Schaefer.
+! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
-! See http://factorcode.org/license.txt for BSD license.
+! The contents of this file are licensed under the Simplified BSD License
-USING: accessors ascii binary-search combinators kernel locals math
+! A copy of the license is available at http://factorcode.org/license.txt
-    math.bitwise math.order poker.arrays sequences splitting ;
+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: STRAIGHT_FLUSH   0
-CONSTANT: FOUR_OF_A_KIND   2
+CONSTANT: FOUR_OF_A_KIND   1
-CONSTANT: FULL_HOUSE       3
+CONSTANT: FULL_HOUSE       2
-CONSTANT: FLUSH            4
+CONSTANT: FLUSH            3
-CONSTANT: STRAIGHT         5
+CONSTANT: STRAIGHT         4
-CONSTANT: THREE_OF_A_KIND  6
+CONSTANT: THREE_OF_A_KIND  5
-CONSTANT: TWO_PAIR         7
+CONSTANT: TWO_PAIR         6
-CONSTANT: ONE_PAIR         8
+CONSTANT: ONE_PAIR         7
-CONSTANT: HIGH_CARD        9
+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 )
+: hand-rank ( value -- rank )
-    value>> {
+    {
         { [ 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
+    parse-cards dup hand-value hand boa ;
-    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>> [
+    cards>> [ card>string ] map " " join ;
-        [ >card-rank ] [ >card-suit ] bi append
-    ] 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 ;
+

extra/poker/summary.txt

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

extra/project-euler/001/001.factor

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

extra/project-euler/005/005.factor

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