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

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/constants/constants.factor

@@ -49,6 +49,7 @@ CONSTANT: rt-this        7
 CONSTANT: rt-immediate 8
 CONSTANT: rt-stack-chain 9
 CONSTANT: rt-untagged 10
+CONSTANT: rt-megamorphic-cache-hits 11
 
 : rc-absolute? ( n -- ? )
     ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

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

basis/cpu/ppc/bootstrap.factor

@@ -21,43 +21,48 @@ CONSTANT: rs-reg 14
 : 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
-    0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
+    0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
-    6 MTCTR
+    3 MTCTR
     BCTR
 ] jit-primitive 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
@@ -152,6 +157,9 @@ CONSTANT: rs-reg 14
 
 ! ! ! 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
@@ -225,7 +233,12 @@ CONSTANT: rs-reg 14
     ! if(get(cache) == class)
     6 3 0 LWZ
     6 0 4 CMP
-    5 BNE
+    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

basis/cpu/ppc/ppc.factor

@@ -3,9 +3,10 @@
 USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
 alien alien.c-types literals cpu.architecture cpu.ppc.assembler
-literals 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:
@@ -116,7 +117,7 @@ M: ppc stack-frame-size ( stack-frame -- i )
 M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
 
 M: ppc %jump ( word -- )
-    0 3 LOAD32 rc-absolute-ppc-2/2 rel-here
+    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 ;
@@ -130,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
@@ -651,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
@@ -712,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/bootstrap.factor

@@ -233,12 +233,13 @@ big-endian off
     temp0 temp2 ADD
     ! if(get(cache) == class)
     temp0 [] temp1 CMP
-    ! ... goto get(cache + bootstrap-cell)
+    bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
-    [
+    ! megamorphic_cache_hits++
+    temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
+    temp1 [] 1 ADD
+    ! goto get(cache + bootstrap-cell)
     temp0 temp0 bootstrap-cell [+] MOV
     temp0 word-xt-offset [+] JMP
-    ] [ ] make
-    [ length JNE ] [ % ] bi
     ! fall-through on miss
 ] mega-lookup jit-define
 

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,8 +12,21 @@ IN: math.combinatorics
 : twiddle ( n k -- n k )
     2dup - dupd > [ dupd - ] when ; inline
 
-! See this article for explanation of the factoradic-based permutation methodology:
+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 ;
@@ -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/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,7 +21,7 @@ TUPLE: positive-even-expected n ;
     0 :> a!
     trials [
         drop
-        n 1 - [1,b] random a!
+        2 n 2 - [a,b] random a!
         a s n ^mod 1 = [
             f
         ] [
@@ -30,8 +33,6 @@ TUPLE: positive-even-expected n ;
 
 PRIVATE>
 
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
-
 : miller-rabin* ( n numtrials -- ? )
     over {
         { [ dup 1 <= ] [ 3drop f ] }
@@ -42,11 +43,21 @@ PRIVATE>
 
 : miller-rabin ( n -- ? ) 10 miller-rabin* ;
 
+ERROR: prime-range-error n ;
+
 : next-prime ( n -- p )
-    next-odd dup miller-rabin [ next-prime ] unless ;
+    dup 1 < [ prime-range-error ] when
+    dup 1 = [
+        drop 2
+    ] [
+        next-odd dup miller-rabin [ next-prime ] unless
+    ] if ;
+
+: random-bits* ( numbits -- n )
+    1 - [ random-bits ] keep set-bit ;
 
 : random-prime ( numbits -- p )
-    random-bits next-prime ;
+    random-bits* next-prime ;
 
 ERROR: no-relative-prime n ;
 
@@ -80,10 +91,7 @@ ERROR: too-few-primes ;
 
 <PRIVATE
 
-: >safe-prime-form ( q -- p ) 2 * 1 + ;
-
 : safe-prime-candidate? ( n -- ? )
-    >safe-prime-form
     1 + 6 divisor? ;
 
 : next-safe-prime-candidate ( n -- candidate )
@@ -99,14 +107,8 @@ PRIVATE>
     } 1&& ;
 
 : next-safe-prime ( n -- q )
-    1 - >even 2 /
     next-safe-prime-candidate
-    dup >safe-prime-form
+    dup 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/rectangles.factor

@@ -21,6 +21,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
 

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/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/ui/backend/backend.factor

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

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/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?
+    [ ?grab-input ] [
         dup raised-window
-    focus-path f focus-gestures ;
+        focus-path f focus-gestures
+    ] bi ;
 
 : unfocus-world ( world -- )
     f >>focused?
-    focus-path f swap focus-gestures ;
+    [ ?ungrab-input ]
+    [ focus-path f swap focus-gestures ] bi ;
 
 : try-to-open-window ( world -- )
     {

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

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,12 +154,13 @@ 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 axis? ] [ {
             { [ dup x-axis? ] [ drop axis-value >>x drop ] }
             { [ dup y-axis? ] [ drop axis-value >>y drop ] }
             { [ dup z-axis? ] [ drop axis-value >>z drop ] }
@@ -167,30 +170,39 @@ CONSTANT: pov-values
             { [ dup slider? ] [ drop axis-value >>slider drop ] }
             { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
             [ 3drop ]
+        } cond ] }
+        [ 3drop ]
     } cond ;
 
-SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+HINTS: record-controller { controller-state alien } ;
 
 : ?set-nth ( value nth seq -- )
     2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
 
-: record-keyboard ( value -- )
+: 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/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>

extra/noise/noise.factor

@@ -7,6 +7,9 @@ IN: noise
 : <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' )
@@ -54,9 +57,6 @@ IN: noise
     v w quot call
     ; inline
 
-: with-seed ( seed quot -- )
-    [ <mersenne-twister> ] dip with-random ; inline
-
 : >byte-map ( floats -- bytes )
     [ 255.0 * >fixnum ] B{ } map-as ;
 

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)

extra/project-euler/018/018.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math project-euler.common sequences ;
+USING: kernel math math.ranges project-euler.common sequences ;
 IN: project-euler.018
 
 ! http://projecteuler.net/index.php?section=problems&id=18
@@ -66,7 +66,7 @@ IN: project-euler.018
            91  71  52  38  17  14  91  43  58  50  27  29  48
          63  66  04  68  89  53  67  30  73  16  69  87  40  31
        04  62  98  27  23  09  70  98  73  93  38  53  60  04  23
-     } 15 iota [ 1+ cut swap ] map nip ;
+     } 15 [1,b] [ cut swap ] map nip ;
 
 PRIVATE>
 

extra/project-euler/025/025.factor

@@ -39,7 +39,7 @@ IN: project-euler.025
 ! Memoized brute force
 
 MEMO: fib ( m -- n )
-    dup 1 > [ 1- dup fib swap 1- fib + ] when ;
+    dup 1 > [ [ 1 - fib ] [ 2 - fib ] bi + ] when ;
 
 <PRIVATE
 

extra/project-euler/027/027.factor

@@ -1,7 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.primes project-euler.common sequences
+USING: kernel math math.primes math.ranges project-euler.common sequences ;
-project-euler.common ;
 IN: project-euler.027
 
 ! http://projecteuler.net/index.php?section=problems&id=27
@@ -47,7 +46,7 @@ IN: project-euler.027
 <PRIVATE
 
 : source-027 ( -- seq )
-    1000 [ prime? ] filter [ dup [ neg ] map append ] keep
+    1000 [0,b) [ prime? ] filter [ dup [ neg ] map append ] keep
     cartesian-product [ first2 < ] filter ;
 
 : quadratic ( b a n -- m )

extra/project-euler/030/030.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions project-euler.common sequences ;
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
 IN: project-euler.030
 
 ! http://projecteuler.net/index.php?section=problems&id=30
@@ -38,7 +38,7 @@ IN: project-euler.030
 PRIVATE>
 
 : euler030 ( -- answer )
-    325537 [ dup sum-fifth-powers = ] filter sum 1- ;
+    325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ;
 
 ! [ euler030 ] 100 ave-time
 ! 1700 ms ave run time - 64.84 SD (100 trials)

extra/project-euler/048/048.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences project-euler.common ;
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
 IN: project-euler.048
 
 ! http://projecteuler.net/index.php?section=problems&id=48
@@ -17,7 +17,7 @@ IN: project-euler.048
 ! --------
 
 : euler048 ( -- answer )
-    1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ;
+    1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ;
 
 ! [ euler048 ] 100 ave-time
 ! 276 ms run / 1 ms GC ave time - 100 trials

extra/project-euler/055/055.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser project-euler.common sequences ;
+USING: kernel math math.parser math.ranges project-euler.common sequences ;
 IN: project-euler.055
 
 ! http://projecteuler.net/index.php?section=problems&id=55
@@ -61,7 +61,7 @@ IN: project-euler.055
 PRIVATE>
 
 : euler055 ( -- answer )
-    10000 [ lychrel? ] count ;
+    10000 [0,b) [ lychrel? ] count ;
 
 ! [ euler055 ] 100 ave-time
 ! 478 ms ave run time - 30.63 SD (100 trials)

extra/project-euler/057/057.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Samuel Tardieu
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.parser sequences project-euler.common ;
+USING: kernel math math.functions math.parser math.ranges project-euler.common
+    sequences ;
 IN: project-euler.057
 
 ! http://projecteuler.net/index.php?section=problems&id=57
@@ -35,9 +36,9 @@ IN: project-euler.057
     >fraction [ number>string length ] bi@ > ; inline
 
 : euler057 ( -- answer )
-    0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ;
+    0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
 
-! [ euler057 ] time
+! [ euler057 ] 100 ave-time
-! 3.375118 seconds
+! 1728 ms ave run time - 80.81 SD (100 trials)
 
 SOLUTION: euler057

extra/project-euler/150/150.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Eric Mertens.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hints kernel locals math math.order sequences sequences.private project-euler.common ;
+USING: hints kernel locals math math.order math.ranges project-euler.common
+    sequences sequences.private ;
 IN: project-euler.150
 
 ! http://projecteuler.net/index.php?section=problems&id=150
@@ -50,13 +51,13 @@ IN: project-euler.150
     615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
 
 : sums-triangle ( -- seq )
-    0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ;
+    0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
 
 :: (euler150) ( m -- n )
     [let | table [ sums-triangle ] |
         m [| x |
             x 1+ [| y |
-                m x - iota [| z |
+                m x - [0,b) [| z |
                     x z + table nth-unsafe
                     [ y z + 1+ swap nth-unsafe ]
                     [ y        swap nth-unsafe ] bi -

extra/terrain/generation/generation.factor

@@ -0,0 +1,60 @@
+USING: accessors arrays byte-arrays combinators fry grouping
+images kernel math math.affine-transforms math.order
+math.vectors noise random sequences ;
+IN: terrain.generation
+
+CONSTANT: terrain-segment-size { 512 512 }
+CONSTANT: terrain-big-noise-scale { 0.002 0.002 }
+CONSTANT: terrain-small-noise-scale { 0.05 0.05 }
+
+TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ; 
+
+: <terrain> ( -- terrain )
+    <perlin-noise-table> <perlin-noise-table>
+    32 random-bits terrain boa ;
+
+: seed-at ( seed at -- seed' )
+    first2 [ + ] dip [ 32 random-bits + ] curry with-seed ;
+
+: big-noise-segment ( terrain at -- map )
+    [ big-noise-table>> terrain-big-noise-scale first2 <scale> ] dip
+    terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
+: small-noise-segment ( terrain at -- map )
+    [ small-noise-table>> terrain-small-noise-scale first2 <scale> ] dip
+    terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
+: tiny-noise-segment ( terrain at -- map )
+    [ tiny-noise-seed>> ] dip seed-at 0.1
+    terrain-segment-size normal-noise-byte-map ;
+
+: padding ( terrain at -- padding )
+    2drop terrain-segment-size product 255 <repetition> ;
+
+TUPLE: segment image ;
+
+: terrain-segment ( terrain at -- image )
+    {
+        [ big-noise-segment ]
+        [ small-noise-segment ]
+        [ tiny-noise-segment ]
+        [ padding ]
+    } 2cleave
+    4array flip concat >byte-array
+    [ terrain-segment-size RGBA f ] dip image boa ;
+
+: 4max ( a b c d -- max )
+    max max max ; inline
+
+: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' )
+    [ [ 2 <groups> ] map 2 <groups> ] dip
+    '[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline
+
+: group-pixels ( bitmap dim -- scanlines )
+    [ 4 <groups> ] [ first <groups> ] bi* ;
+
+: concat-pixels ( scanlines -- bitmap )
+    [ concat ] map concat ;
+
+: segment-mipmap ( image -- image' )
+    [ clone ] [ bitmap>> ] [ dim>> ] tri
+    group-pixels [ 4max ] mipmap concat-pixels >>bitmap
+    [ 2 v/n ] change-dim ;

extra/terrain/shaders/shaders.factor

@@ -0,0 +1,46 @@
+USING: multiline ;
+IN: terrain.shaders
+
+STRING: terrain-vertex-shader
+
+uniform sampler2D heightmap;
+
+varying vec2 heightcoords;
+
+const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
+
+float height(sampler2D map, vec2 coords)
+{
+    vec4 v = texture2D(map, coords);
+    return dot(v, COMPONENT_SCALE);
+}
+
+void main()
+{
+    gl_Position = gl_ModelViewProjectionMatrix
+        * (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0));
+    heightcoords = gl_Vertex.xz;
+}
+
+;
+
+STRING: terrain-pixel-shader
+
+uniform sampler2D heightmap;
+
+varying vec2 heightcoords;
+
+const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
+
+float height(sampler2D map, vec2 coords)
+{
+    vec4 v = texture2D(map, coords);
+    return dot(v, COMPONENT_SCALE);
+}
+
+void main()
+{
+    gl_FragColor = texture2D(heightmap, heightcoords);
+}
+
+;

extra/terrain/terrain.factor

@@ -0,0 +1,192 @@
+USING: accessors arrays combinators game-input
+game-input.scancodes game-loop kernel literals locals math
+math.constants math.functions math.matrices math.order
+math.vectors opengl opengl.capabilities opengl.gl
+opengl.shaders opengl.textures opengl.textures.private
+sequences sequences.product specialized-arrays.float
+terrain.generation terrain.shaders ui ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ;
+IN: terrain
+
+CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
+CONSTANT: FAR-PLANE 2.0
+CONSTANT: EYE-START { 0.5 0.5 1.2 }
+CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
+CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
+CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ]
+
+CONSTANT: terrain-vertex-size { 512 512 }
+CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
+CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
+
+TUPLE: terrain-world < world
+    eye yaw pitch
+    terrain terrain-segment terrain-texture terrain-program
+    terrain-vertex-buffer
+    game-loop ;
+
+: frustum ( dim -- -x x -y y near far )
+    dup first2 min v/n
+    NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@
+    NEAR-PLANE FAR-PLANE ;
+
+: set-modelview-matrix ( gadget -- )
+    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    GL_MODELVIEW glMatrixMode
+    glLoadIdentity
+    [ pitch>> 1.0 0.0 0.0 glRotatef ]
+    [ yaw>> 0.0 1.0 0.0 glRotatef ]
+    [ eye>> vneg first3 glTranslatef ] tri ;
+
+: vertex-array-vertex ( x z -- vertex )
+    [ terrain-vertex-distance first * ]
+    [ terrain-vertex-distance second * ] bi*
+    [ 0 ] dip float-array{ } 3sequence ;
+
+: vertex-array-row ( z -- vertices )
+    dup 1 + 2array
+    terrain-vertex-size first 1 + iota
+    2array [ first2 swap vertex-array-vertex ] product-map
+    concat ;
+
+: vertex-array ( -- vertices )
+    terrain-vertex-size second iota
+    [ vertex-array-row ] map concat ;
+
+: >vertex-buffer ( bytes -- buffer )
+    [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
+
+: draw-vertex-buffer-row ( i -- )
+    [ GL_TRIANGLE_STRIP ] dip
+    terrain-vertex-row-length * terrain-vertex-row-length
+    glDrawArrays ;
+
+: draw-vertex-buffer ( buffer -- )
+    [ GL_ARRAY_BUFFER ] dip [
+        3 GL_FLOAT 0 f glVertexPointer
+        terrain-vertex-size second iota [ draw-vertex-buffer-row ] each
+    ] with-gl-buffer ;
+
+: degrees ( deg -- rad )
+    pi 180.0 / * ;
+
+:: eye-rotate ( yaw pitch v -- v' )
+    yaw degrees neg :> y
+    pitch degrees neg :> p
+    y cos :> cosy
+    y sin :> siny
+    p cos :> cosp
+    p sin :> sinp
+
+    cosy         0.0       siny        neg 3array
+    siny sinp *  cosp      cosy sinp *     3array
+    siny cosp *  sinp neg  cosy cosp *     3array 3array
+    v swap v.m ;
+
+: forward-vector ( world -- v )
+    [ yaw>> ] [ pitch>> ] bi
+    { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
+: rightward-vector ( world -- v )
+    [ yaw>> ] [ pitch>> ] bi
+    { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
+
+: move-forward ( world -- )
+    dup forward-vector [ v+ ] curry change-eye drop ;
+: move-backward ( world -- )
+    dup forward-vector [ v- ] curry change-eye drop ;
+: move-leftward ( world -- )
+    dup rightward-vector [ v- ] curry change-eye drop ;
+: move-rightward ( world -- )
+    dup rightward-vector [ v+ ] curry change-eye drop ;
+
+: rotate-with-mouse ( world mouse -- )
+    [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
+    [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi
+    drop ;
+
+:: handle-input ( world -- )
+    read-keyboard keys>> :> keys
+    key-w keys nth [ world move-forward ] when 
+    key-s keys nth [ world move-backward ] when 
+    key-a keys nth [ world move-leftward ] when 
+    key-d keys nth [ world move-rightward ] when 
+    key-escape keys nth [ world close-window ] when
+    world read-mouse rotate-with-mouse
+    reset-mouse ;
+
+M: terrain-world tick*
+    [ handle-input ] keep
+    ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
+    drop ;
+
+M: terrain-world draw*
+    nip draw-world ;
+
+: set-heightmap-texture-parameters ( texture -- )
+    GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
+    GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri
+    GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
+
+M: terrain-world begin-world
+    "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
+    require-gl-version-or-extensions
+    GL_DEPTH_TEST glEnable
+    GL_TEXTURE_2D glEnable
+    GL_VERTEX_ARRAY glEnableClientState
+    0.5 0.5 0.5 1.0 glClearColor
+    EYE-START >>eye
+    0.0 >>yaw
+    0.0 >>pitch
+    <terrain> [ >>terrain ] keep
+    { 0 0 } terrain-segment [ >>terrain-segment ] keep
+    make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
+    terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
+    >>terrain-program
+    vertex-array >vertex-buffer >>terrain-vertex-buffer
+    TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
+    open-game-input
+    drop ;
+
+M: terrain-world end-world
+    close-game-input
+    {
+        [ game-loop>> stop-loop ]
+        [ terrain-vertex-buffer>> delete-gl-buffer ]
+        [ terrain-program>> delete-gl-program ]
+        [ terrain-texture>> delete-texture ]
+    } cleave ;
+
+M: terrain-world resize-world
+    GL_PROJECTION glMatrixMode
+    glLoadIdentity
+    dim>> [ [ 0 0 ] dip first2 glViewport ]
+    [ frustum glFrustum ] bi ;
+
+M: terrain-world draw-world*
+    [ set-modelview-matrix ]
+    [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
+    [ dup terrain-program>> [
+        "heightmap" glGetUniformLocation 0 glUniform1i
+        terrain-vertex-buffer>> draw-vertex-buffer
+    ] with-gl-program ]
+    tri gl-error ;
+
+M: terrain-world focusable-child* drop t ;
+M: terrain-world pref-dim* drop { 640 480 } ;
+
+: terrain-window ( -- )
+    [
+        f T{ world-attributes
+            { world-class terrain-world }
+            { title "Terrain" }
+            { pixel-format-attributes {
+                windowed
+                double-buffered
+                T{ depth-bits { value 24 } }
+            } }
+            { grab-input? t }
+        } open-window
+    ] with-ui ;

extra/webapps/wee-url/wee-url.factor

@@ -26,6 +26,9 @@ short-url "SHORT_URLS" {
 : random-url ( -- string )
     1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
 
+: retry ( quot: ( -- ? )  n -- )
+    swap [ drop ] prepose attempt-all ; inline
+
 : insert-short-url ( short-url -- short-url )
     '[ _ dup random-url >>short insert-tuple ] 10 retry ;
 

vm/callstack.cpp

@@ -24,10 +24,7 @@ void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
 
 void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
 {
-	cell top = (cell)FIRST_STACK_FRAME(stack);
+	iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
-	cell bottom = top + untag_fixnum(stack->length);
-
-	iterate_callstack(top,bottom,iterator);
 }
 
 callstack *allot_callstack(cell size)
@@ -75,7 +72,7 @@ PRIMITIVE(callstack)
 		size = 0;
 
 	callstack *stack = allot_callstack(size);
-	memcpy(FIRST_STACK_FRAME(stack),top,size);
+	memcpy(stack->top(),top,size);
 	dpush(tag<callstack>(stack));
 }
 
@@ -84,7 +81,7 @@ PRIMITIVE(set_callstack)
 	callstack *stack = untag_check<callstack>(dpop());
 
 	set_callstack(stack_chain->callstack_bottom,
-		FIRST_STACK_FRAME(stack),
+		stack->top(),
 		untag_fixnum(stack->length),
 		memcpy);
 
@@ -173,12 +170,11 @@ PRIMITIVE(callstack_to_array)
 	dpush(tag<array>(frames));
 }
 
-stack_frame *innermost_stack_frame(callstack *callstack)
+stack_frame *innermost_stack_frame(callstack *stack)
 {
-	stack_frame *top = FIRST_STACK_FRAME(callstack);
+	stack_frame *top = stack->top();
-	cell bottom = (cell)top + untag_fixnum(callstack->length);
+	stack_frame *bottom = stack->bottom();
-
+	stack_frame *frame = bottom - 1;
-	stack_frame *frame = (stack_frame *)bottom - 1;
 
 	while(frame >= top && frame_successor(frame) >= top)
 		frame = frame_successor(frame);

vm/callstack.hpp

@@ -6,8 +6,6 @@ inline static cell callstack_size(cell size)
 	return sizeof(callstack) + size;
 }
 
-#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1)
-
 typedef void (*CALLSTACK_ITER)(stack_frame *frame);
 
 stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);

vm/code_block.cpp

@@ -3,11 +3,179 @@
 namespace factor
 {
 
+static relocation_type relocation_type_of(relocation_entry r)
+{
+	return (relocation_type)((r & 0xf0000000) >> 28);
+}
+
+static relocation_class relocation_class_of(relocation_entry r)
+{
+	return (relocation_class)((r & 0x0f000000) >> 24);
+}
+
+static cell relocation_offset_of(relocation_entry r)
+{
+	return  (r & 0x00ffffff);
+}
+
 void flush_icache_for(code_block *block)
 {
 	flush_icache((cell)block,block->size);
 }
 
+static int number_of_parameters(relocation_type type)
+{
+	switch(type)
+	{
+	case RT_PRIMITIVE:
+	case RT_XT:
+	case RT_XT_PIC:
+	case RT_XT_PIC_TAIL:
+	case RT_IMMEDIATE:
+	case RT_HERE:
+	case RT_UNTAGGED:
+		return 1;
+	case RT_DLSYM:
+		return 2;
+	case RT_THIS:
+	case RT_STACK_CHAIN:
+	case RT_MEGAMORPHIC_CACHE_HITS:
+		return 0;
+	default:
+		critical_error("Bad rel type",type);
+		return -1; /* Can't happen */
+	}
+}
+
+void *object_xt(cell obj)
+{
+	switch(tagged<object>(obj).type())
+	{
+	case WORD_TYPE:
+		return untag<word>(obj)->xt;
+	case QUOTATION_TYPE:
+		return untag<quotation>(obj)->xt;
+	default:
+		critical_error("Expected word or quotation",obj);
+		return NULL;
+	}
+}
+
+static void *xt_pic(word *w, cell tagged_quot)
+{
+	if(tagged_quot == F || max_pic_size == 0)
+		return w->xt;
+	else
+	{
+		quotation *quot = untag<quotation>(tagged_quot);
+		if(quot->compiledp == F)
+			return w->xt;
+		else
+			return quot->xt;
+	}
+}
+
+void *word_xt_pic(word *w)
+{
+	return xt_pic(w,w->pic_def);
+}
+
+void *word_xt_pic_tail(word *w)
+{
+	return xt_pic(w,w->pic_tail_def);
+}
+
+/* References to undefined symbols are patched up to call this function on
+image load */
+void undefined_symbol()
+{
+	general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
+}
+
+/* Look up an external library symbol referenced by a compiled code block */
+void *get_rel_symbol(array *literals, cell index)
+{
+	cell symbol = array_nth(literals,index);
+	cell library = array_nth(literals,index + 1);
+
+	dll *d = (library == F ? NULL : untag<dll>(library));
+
+	if(d != NULL && !d->dll)
+		return (void *)undefined_symbol;
+
+	switch(tagged<object>(symbol).type())
+	{
+	case BYTE_ARRAY_TYPE:
+		{
+			symbol_char *name = alien_offset(symbol);
+			void *sym = ffi_dlsym(d,name);
+
+			if(sym)
+				return sym;
+			else
+			{
+				return (void *)undefined_symbol;
+			}
+		}
+	case ARRAY_TYPE:
+		{
+			cell i;
+			array *names = untag<array>(symbol);
+			for(i = 0; i < array_capacity(names); i++)
+			{
+				symbol_char *name = alien_offset(array_nth(names,i));
+				void *sym = ffi_dlsym(d,name);
+
+				if(sym)
+					return sym;
+			}
+			return (void *)undefined_symbol;
+		}
+	default:
+		critical_error("Bad symbol specifier",symbol);
+		return (void *)undefined_symbol;
+	}
+}
+
+cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
+{
+	array *literals = untag<array>(compiled->literals);
+	cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
+
+#define ARG array_nth(literals,index)
+
+	switch(relocation_type_of(rel))
+	{
+	case RT_PRIMITIVE:
+		return (cell)primitives[untag_fixnum(ARG)];
+	case RT_DLSYM:
+		return (cell)get_rel_symbol(literals,index);
+	case RT_IMMEDIATE:
+		return ARG;
+	case RT_XT:
+		return (cell)object_xt(ARG);
+	case RT_XT_PIC:
+		return (cell)word_xt_pic(untag<word>(ARG));
+	case RT_XT_PIC_TAIL:
+		return (cell)word_xt_pic_tail(untag<word>(ARG));
+	case RT_HERE:
+		return offset + (short)untag_fixnum(ARG);
+	case RT_THIS:
+		return (cell)(compiled + 1);
+	case RT_STACK_CHAIN:
+		return (cell)&stack_chain;
+	case RT_UNTAGGED:
+		return untag_fixnum(ARG);
+	case RT_MEGAMORPHIC_CACHE_HITS:
+		return (cell)&megamorphic_cache_hits;
+	default:
+		critical_error("Bad rel type",rel);
+		return 0; /* Can't happen */
+	}
+
+#undef ARG
+}
+
 void iterate_relocations(code_block *compiled, relocation_iterator iter)
 {
 	if(compiled->relocation != F)
@@ -20,30 +188,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter)
 		for(cell i = 0; i < length; i++)
 		{
 			relocation_entry rel = relocation->data<relocation_entry>()[i];
-
 			iter(rel,index,compiled);
-
+			index += number_of_parameters(relocation_type_of(rel));			
-			switch(REL_TYPE(rel))
-			{
-			case RT_PRIMITIVE:
-			case RT_XT:
-			case RT_XT_PIC:
-			case RT_XT_PIC_TAIL:
-			case RT_IMMEDIATE:
-			case RT_HERE:
-			case RT_UNTAGGED:
-				index++;
-				break;
-			case RT_DLSYM:
-				index += 2;
-				break;
-			case RT_THIS:
-			case RT_STACK_CHAIN:
-				break;
-			default:
-				critical_error("Bad rel type",rel);
-				return; /* Can't happen */
-			}
 		}
 	}
 }
@@ -86,25 +232,25 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
 		store_address_2_2((cell *)offset,absolute_value);
 		break;
 	case RC_ABSOLUTE_PPC_2:
-		store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0);
+		store_address_masked((cell *)offset,absolute_value,rel_absolute_ppc_2_mask,0);
 		break;
 	case RC_RELATIVE_PPC_2:
-		store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
+		store_address_masked((cell *)offset,relative_value,rel_relative_ppc_2_mask,0);
 		break;
 	case RC_RELATIVE_PPC_3:
-		store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
+		store_address_masked((cell *)offset,relative_value,rel_relative_ppc_3_mask,0);
 		break;
 	case RC_RELATIVE_ARM_3:
 		store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
-			REL_RELATIVE_ARM_3_MASK,2);
+			rel_relative_arm_3_mask,2);
 		break;
 	case RC_INDIRECT_ARM:
 		store_address_masked((cell *)offset,relative_value - sizeof(cell),
-			REL_INDIRECT_ARM_MASK,0);
+			rel_indirect_arm_mask,0);
 		break;
 	case RC_INDIRECT_ARM_PC:
 		store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
-			REL_INDIRECT_ARM_MASK,0);
+			rel_indirect_arm_mask,0);
 		break;
 	default:
 		critical_error("Bad rel class",klass);
@@ -114,12 +260,12 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
 
 void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
 {
-	if(REL_TYPE(rel) == RT_IMMEDIATE)
+	if(relocation_type_of(rel) == RT_IMMEDIATE)
 	{
-		cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+		cell offset = relocation_offset_of(rel) + (cell)(compiled + 1);
 		array *literals = untag<array>(compiled->literals);
 		fixnum absolute_value = array_nth(literals,index);
-		store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+		store_address_in_code_block(relocation_class_of(rel),offset,absolute_value);
 	}
 }
 
@@ -158,73 +304,24 @@ void copy_literal_references(code_block *compiled)
 	}
 }
 
-void *object_xt(cell obj)
+/* Compute an address to store at a relocation */
+void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
 {
-	switch(tagged<object>(obj).type())
+#ifdef FACTOR_DEBUG
-	{
+	tagged<array>(compiled->literals).untag_check();
-	case WORD_TYPE:
+	tagged<byte_array>(compiled->relocation).untag_check();
-		return untag<word>(obj)->xt;
+#endif
-	case QUOTATION_TYPE:
-		return untag<quotation>(obj)->xt;
-	default:
-		critical_error("Expected word or quotation",obj);
-		return NULL;
-	}
-}
 
-static void *xt_pic(word *w, cell tagged_quot)
+	store_address_in_code_block(relocation_class_of(rel),
-{
+				    relocation_offset_of(rel) + (cell)compiled->xt(),
-	if(tagged_quot == F || max_pic_size == 0)
+				    compute_relocation(rel,index,compiled));
-		return w->xt;
-	else
-	{
-		quotation *quot = untag<quotation>(tagged_quot);
-		if(quot->compiledp == F)
-			return w->xt;
-		else
-			return quot->xt;
-	}
-}
-
-void *word_xt_pic(word *w)
-{
-	return xt_pic(w,w->pic_def);
-}
-
-void *word_xt_pic_tail(word *w)
-{
-	return xt_pic(w,w->pic_tail_def);
 }
 
 void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
 {
-	relocation_type type = REL_TYPE(rel);
+	relocation_type type = relocation_type_of(rel);
 	if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
-	{
+		relocate_code_block_step(rel,index,compiled);
-		cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
-		array *literals = untag<array>(compiled->literals);
-		cell obj = array_nth(literals,index);
-
-		void *xt;
-		switch(type)
-		{
-		case RT_XT:
-			xt = object_xt(obj);
-			break;
-		case RT_XT_PIC:
-			xt = word_xt_pic(untag<word>(obj));
-			break;
-		case RT_XT_PIC_TAIL:
-			xt = word_xt_pic_tail(untag<word>(obj));
-			break;
-		default:
-			critical_error("Oops",type);
-			xt = NULL;
-			break;
-		}
-
-		store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt);
-	}
 }
 
 /* Relocate new code blocks completely; updating references to literals,
@@ -287,7 +384,7 @@ void mark_stack_frame_step(stack_frame *frame)
 /* Mark code blocks executing in currently active stack frames. */
 void mark_active_blocks(context *stacks)
 {
-	if(collecting_gen == TENURED)
+	if(collecting_gen == data->tenured())
 	{
 		cell top = (cell)stacks->callstack_top;
 		cell bottom = (cell)stacks->callstack_bottom;
@@ -325,118 +422,10 @@ void mark_object_code_block(object *object)
 	}
 }
 
-/* References to undefined symbols are patched up to call this function on
-image load */
-void undefined_symbol()
-{
-	general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
-}
-
-/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(array *literals, cell index)
-{
-	cell symbol = array_nth(literals,index);
-	cell library = array_nth(literals,index + 1);
-
-	dll *d = (library == F ? NULL : untag<dll>(library));
-
-	if(d != NULL && !d->dll)
-		return (void *)undefined_symbol;
-
-	switch(tagged<object>(symbol).type())
-	{
-	case BYTE_ARRAY_TYPE:
-		{
-			symbol_char *name = alien_offset(symbol);
-			void *sym = ffi_dlsym(d,name);
-
-			if(sym)
-				return sym;
-			else
-			{
-				return (void *)undefined_symbol;
-			}
-		}
-	case ARRAY_TYPE:
-		{
-			cell i;
-			array *names = untag<array>(symbol);
-			for(i = 0; i < array_capacity(names); i++)
-			{
-				symbol_char *name = alien_offset(array_nth(names,i));
-				void *sym = ffi_dlsym(d,name);
-
-				if(sym)
-					return sym;
-			}
-			return (void *)undefined_symbol;
-		}
-	default:
-		critical_error("Bad symbol specifier",symbol);
-		return (void *)undefined_symbol;
-	}
-}
-
-/* Compute an address to store at a relocation */
-void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
-{
-#ifdef FACTOR_DEBUG
-	tagged<array>(compiled->literals).untag_check();
-	tagged<byte_array>(compiled->relocation).untag_check();
-#endif
-
-	cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
-	array *literals = untag<array>(compiled->literals);
-	fixnum absolute_value;
-
-#define ARG array_nth(literals,index)
-
-	switch(REL_TYPE(rel))
-	{
-	case RT_PRIMITIVE:
-		absolute_value = (cell)primitives[untag_fixnum(ARG)];
-		break;
-	case RT_DLSYM:
-		absolute_value = (cell)get_rel_symbol(literals,index);
-		break;
-	case RT_IMMEDIATE:
-		absolute_value = ARG;
-		break;
-	case RT_XT:
-		absolute_value = (cell)object_xt(ARG);
-		break;
-	case RT_XT_PIC:
-		absolute_value = (cell)word_xt_pic(untag<word>(ARG));
-		break;
-	case RT_XT_PIC_TAIL:
-		absolute_value = (cell)word_xt_pic_tail(untag<word>(ARG));
-		break;
-	case RT_HERE:
-		absolute_value = offset + (short)untag_fixnum(ARG);
-		break;
-	case RT_THIS:
-		absolute_value = (cell)(compiled + 1);
-		break;
-	case RT_STACK_CHAIN:
-		absolute_value = (cell)&stack_chain;
-		break;
-	case RT_UNTAGGED:
-		absolute_value = untag_fixnum(ARG);
-		break;
-	default:
-		critical_error("Bad rel type",rel);
-		return; /* Can't happen */
-	}
-
-#undef ARG
-
-	store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
-}
-
 /* Perform all fixups on a code block */
 void relocate_code_block(code_block *compiled)
 {
-	compiled->last_scan = NURSERY;
+	compiled->last_scan = data->nursery();
 	compiled->needs_fixup = false;
 	iterate_relocations(compiled,relocate_code_block_step);
 	flush_icache_for(compiled);
@@ -506,7 +495,7 @@ code_block *add_code_block(
 
 	/* compiled header */
 	compiled->type = type;
-	compiled->last_scan = NURSERY;
+	compiled->last_scan = data->nursery();
 	compiled->needs_fixup = true;
 	compiled->relocation = relocation.value();
 
@@ -525,7 +514,7 @@ code_block *add_code_block(
 
 	/* next time we do a minor GC, we have to scan the code heap for
 	literals */
-	last_code_heap_scan = NURSERY;
+	last_code_heap_scan = data->nursery();
 
 	return compiled;
 }

vm/code_block.hpp

@@ -24,6 +24,8 @@ enum relocation_type {
 	RT_STACK_CHAIN,
 	/* untagged fixnum literal */
 	RT_UNTAGGED,
+	/* address of megamorphic_cache_hits var */
+	RT_MEGAMORPHIC_CACHE_HITS,
 };
 
 enum relocation_class {
@@ -49,17 +51,14 @@ enum relocation_class {
 	RC_INDIRECT_ARM_PC
 };
 
-#define REL_ABSOLUTE_PPC_2_MASK 0xffff
+static const cell rel_absolute_ppc_2_mask = 0xffff;
-#define REL_RELATIVE_PPC_2_MASK 0xfffc
+static const cell rel_relative_ppc_2_mask = 0xfffc;
-#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
+static const cell rel_relative_ppc_3_mask = 0x3fffffc;
-#define REL_INDIRECT_ARM_MASK 0xfff
+static const cell rel_indirect_arm_mask = 0xfff;
-#define REL_RELATIVE_ARM_3_MASK 0xffffff
+static const cell rel_relative_arm_3_mask = 0xffffff;
 
 /* code relocation table consists of a table of entries for each fixup */
 typedef u32 relocation_entry;
-#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28)
-#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24)
-#define REL_OFFSET(r) ((r) & 0x00ffffff)
 
 void flush_icache_for(code_block *compiled);
 

vm/code_gc.cpp

@@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size)
 
 static void add_to_free_list(heap *heap, free_heap_block *block)
 {
-	if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+	if(block->size < free_list_count * block_size_increment)
 	{
-		int index = block->size / BLOCK_SIZE_INCREMENT;
+		int index = block->size / block_size_increment;
 		block->next_free = heap->free.small_blocks[index];
 		heap->free.small_blocks[index] = block;
 	}
@@ -45,7 +45,7 @@ void build_free_list(heap *heap, cell size)
 
 	clear_free_list(heap);
 
-	size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+	size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
 
 	heap_block *scan = first_block(heap);
 	free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
@@ -101,9 +101,9 @@ static free_heap_block *find_free_block(heap *heap, cell size)
 {
 	cell attempt = size;
 
-	while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+	while(attempt < free_list_count * block_size_increment)
 	{
-		int index = attempt / BLOCK_SIZE_INCREMENT;
+		int index = attempt / block_size_increment;
 		free_heap_block *block = heap->free.small_blocks[index];
 		if(block)
 		{
@@ -156,7 +156,7 @@ static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cel
 /* Allocate a block of memory from the mark and sweep GC heap */
 heap_block *heap_allot(heap *heap, cell size)
 {
-	size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+	size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
 
 	free_heap_block *block = find_free_block(heap,size);
 	if(block)

vm/code_gc.hpp

@@ -1,11 +1,11 @@
 namespace factor
 {
 
-#define FREE_LIST_COUNT 16
+static const cell free_list_count = 16;
-#define BLOCK_SIZE_INCREMENT 32
+static const cell block_size_increment = 32;
 
 struct heap_free_list {
-	free_heap_block *small_blocks[FREE_LIST_COUNT];
+	free_heap_block *small_blocks[free_list_count];
 	free_heap_block *large_blocks;
 };
 

vm/contexts.cpp

@@ -18,12 +18,12 @@ void reset_retainstack()
 	rs = rs_bot - sizeof(cell);
 }
 
-#define RESERVED (64 * sizeof(cell))
+static const cell stack_reserved = (64 * sizeof(cell));
 
 void fix_stacks()
 {
-	if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
+	if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
-	if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
+	if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
 }
 
 /* called before entry into foreign C code. Note that ds and rs might

vm/cpu-ppc.S

@@ -236,8 +236,10 @@ DEF(void,flush_icache,(void *start, int len)):
 	blr
 
 DEF(void,primitive_inline_cache_miss,(void)):
-    mflr r3
+    mflr r6
+DEF(void,primitive_inline_cache_miss_tail,(void)):
     PROLOGUE
+    mr r3,r6
     bl MANGLE(inline_cache_miss)
     EPILOGUE
     mtctr r3

vm/cpu-ppc.hpp

@@ -7,24 +7,35 @@ namespace factor
 register cell ds asm("r13");
 register cell rs asm("r14");
 
+/* In the instruction sequence:
+
+   LOAD32 r3,...
+   B blah
+
+   the offset from the immediate operand to LOAD32 to the instruction after
+   the branch is two instructions. */
+static const fixnum xt_tail_pic_offset = 4 * 2;
+
 inline static void check_call_site(cell return_address)
 {
 #ifdef FACTOR_DEBUG
 	cell insn = *(cell *)return_address;
-	assert((insn & 0x3) == 0x1);
+	/* Check that absolute bit is 0 */
+	assert((insn & 0x2) == 0x0);
+	/* Check that instruction is branch */
 	assert((insn >> 26) == 0x12);
 #endif
 }
 
-#define B_MASK 0x3fffffc
+static const cell b_mask = 0x3fffffc;
 
 inline static void *get_call_target(cell return_address)
 {
 	return_address -= sizeof(cell);
-
 	check_call_site(return_address);
+
 	cell insn = *(cell *)return_address;
-	cell unsigned_addr = (insn & B_MASK);
+	cell unsigned_addr = (insn & b_mask);
 	fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
 	return (void *)(signed_addr + return_address);
 }
@@ -32,19 +43,25 @@ inline static void *get_call_target(cell return_address)
 inline static void set_call_target(cell return_address, void *target)
 {
 	return_address -= sizeof(cell);
-
-#ifdef FACTOR_DEBUG
-	assert((return_address & ~B_MASK) == 0);
 	check_call_site(return_address);
-#endif
+
 	cell insn = *(cell *)return_address;
-	insn = ((insn & ~B_MASK) | (((cell)target - return_address) & B_MASK));
+
+	fixnum relative_address = ((cell)target - return_address);
+	insn = ((insn & ~b_mask) | (relative_address & b_mask));
 	*(cell *)return_address = insn;
 
 	/* Flush the cache line containing the call we just patched */
 	__asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):);
 }
 
+inline static bool tail_call_site_p(cell return_address)
+{
+	return_address -= sizeof(cell);
+	cell insn = *(cell *)return_address;
+	return (insn & 0x1) == 0;
+}
+
 /* Defined in assembly */
 VM_ASM_API void c_to_factor(cell quot);
 VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);

vm/data_gc.cpp

@@ -9,15 +9,15 @@ bool performing_gc;
 bool performing_compaction;
 cell collecting_gen;
 
-/* if true, we collecting AGING space for the second time, so if it is still
+/* if true, we collecting aging space for the second time, so if it is still
-full, we go on to collect TENURED */
+full, we go on to collect tenured */
 bool collecting_aging_again;
 
 /* in case a generation fills up in the middle of a gc, we jump back
 up to try collecting the next generation. */
 jmp_buf gc_jmp;
 
-gc_stats stats[MAX_GEN_COUNT];
+gc_stats stats[max_gen_count];
 u64 cards_scanned;
 u64 decks_scanned;
 u64 card_scan_time;
@@ -36,7 +36,7 @@ data_heap *old_data_heap;
 void init_data_gc()
 {
 	performing_gc = false;
-	last_code_heap_scan = NURSERY;
+	last_code_heap_scan = data->nursery();
 	collecting_aging_again = false;
 }
 
@@ -66,11 +66,11 @@ static bool should_copy_p(object *untagged)
 {
 	if(in_zone(newspace,untagged))
 		return false;
-	if(collecting_gen == TENURED)
+	if(collecting_gen == data->tenured())
 		return true;
-	else if(HAVE_AGING_P && collecting_gen == AGING)
+	else if(data->have_aging_p() && collecting_gen == data->aging())
-		return !in_zone(&data->generations[TENURED],untagged);
+		return !in_zone(&data->generations[data->tenured()],untagged);
-	else if(collecting_gen == NURSERY)
+	else if(collecting_gen == data->nursery())
 		return in_zone(&nursery,untagged);
 	else
 	{
@@ -186,19 +186,19 @@ static void copy_gen_cards(cell gen)
 
 	/* if we are collecting the nursery, we care about old->nursery pointers
 	but not old->aging pointers */
-	if(collecting_gen == NURSERY)
+	if(collecting_gen == data->nursery())
 	{
-		mask = CARD_POINTS_TO_NURSERY;
+		mask = card_points_to_nursery;
 
 		/* after the collection, no old->nursery pointers remain
 		anywhere, but old->aging pointers might remain in tenured
 		space */
-		if(gen == TENURED)
+		if(gen == data->tenured())
-			unmask = CARD_POINTS_TO_NURSERY;
+			unmask = card_points_to_nursery;
 		/* after the collection, all cards in aging space can be
 		cleared */
-		else if(HAVE_AGING_P && gen == AGING)
+		else if(data->have_aging_p() && gen == data->aging())
-			unmask = CARD_MARK_MASK;
+			unmask = card_mark_mask;
 		else
 		{
 			critical_error("bug in copy_gen_cards",gen);
@@ -208,20 +208,20 @@ static void copy_gen_cards(cell gen)
 	/* if we are collecting aging space into tenured space, we care about
 	all old->nursery and old->aging pointers. no old->aging pointers can
 	remain */
-	else if(HAVE_AGING_P && collecting_gen == AGING)
+	else if(data->have_aging_p() && collecting_gen == data->aging())
 	{
 		if(collecting_aging_again)
 		{
-			mask = CARD_POINTS_TO_AGING;
+			mask = card_points_to_aging;
-			unmask = CARD_MARK_MASK;
+			unmask = card_mark_mask;
 		}
 		/* after we collect aging space into the aging semispace, no
 		old->nursery pointers remain but tenured space might still have
 		pointers to aging space. */
 		else
 		{
-			mask = CARD_POINTS_TO_AGING;
+			mask = card_points_to_aging;
-			unmask = CARD_POINTS_TO_NURSERY;
+			unmask = card_points_to_nursery;
 		}
 	}
 	else
@@ -366,8 +366,8 @@ static cell copy_next_from_aging(cell scan)
 	{
 		obj++;
 
-		cell tenured_start = data->generations[TENURED].start;
+		cell tenured_start = data->generations[data->tenured()].start;
-		cell tenured_end = data->generations[TENURED].end;
+		cell tenured_end = data->generations[data->tenured()].end;
 
 		cell newspace_start = newspace->start;
 		cell newspace_end = newspace->end;
@@ -421,17 +421,17 @@ static cell copy_next_from_tenured(cell scan)
 
 void copy_reachable_objects(cell scan, cell *end)
 {
-	if(collecting_gen == NURSERY)
+	if(collecting_gen == data->nursery())
 	{
 		while(scan < *end)
 			scan = copy_next_from_nursery(scan);
 	}
-	else if(HAVE_AGING_P && collecting_gen == AGING)
+	else if(data->have_aging_p() && collecting_gen == data->aging())
 	{
 		while(scan < *end)
 			scan = copy_next_from_aging(scan);
 	}
-	else if(collecting_gen == TENURED)
+	else if(collecting_gen == data->tenured())
 	{
 		while(scan < *end)
 			scan = copy_next_from_tenured(scan);
@@ -443,12 +443,12 @@ static void begin_gc(cell requested_bytes)
 {
 	if(growing_data_heap)
 	{
-		if(collecting_gen != TENURED)
+		if(collecting_gen != data->tenured())
 			critical_error("Invalid parameters to begin_gc",0);
 
 		old_data_heap = data;
 		set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
-		newspace = &data->generations[TENURED];
+		newspace = &data->generations[data->tenured()];
 	}
 	else if(collecting_accumulation_gen_p())
 	{
@@ -491,12 +491,12 @@ static void end_gc(cell gc_elapsed)
 	if(collecting_accumulation_gen_p())
 	{
 		/* all younger generations except are now empty.
-		if collecting_gen == NURSERY here, we only have 1 generation;
+		if collecting_gen == data->nursery() here, we only have 1 generation;
 		old-school Cheney collector */
-		if(collecting_gen != NURSERY)
+		if(collecting_gen != data->nursery())
-			reset_generations(NURSERY,collecting_gen - 1);
+			reset_generations(data->nursery(),collecting_gen - 1);
 	}
-	else if(collecting_gen == NURSERY)
+	else if(collecting_gen == data->nursery())
 	{
 		nursery.here = nursery.start;
 	}
@@ -504,7 +504,7 @@ static void end_gc(cell gc_elapsed)
 	{
 		/* all generations up to and including the one
 		collected are now empty */
-		reset_generations(NURSERY,collecting_gen);
+		reset_generations(data->nursery(),collecting_gen);
 	}
 
 	collecting_aging_again = false;
@@ -534,17 +534,17 @@ void garbage_collection(cell gen,
 	{
 		/* We have no older generations we can try collecting, so we
 		resort to growing the data heap */
-		if(collecting_gen == TENURED)
+		if(collecting_gen == data->tenured())
 		{
 			growing_data_heap = true;
 
 			/* see the comment in unmark_marked() */
 			unmark_marked(&code);
 		}
-		/* we try collecting AGING space twice before going on to
+		/* we try collecting aging space twice before going on to
-		collect TENURED */
+		collect tenured */
-		else if(HAVE_AGING_P
+		else if(data->have_aging_p()
-			&& collecting_gen == AGING
+			&& collecting_gen == data->aging()
 			&& !collecting_aging_again)
 		{
 			collecting_aging_again = true;
@@ -575,7 +575,7 @@ void garbage_collection(cell gen,
 	{
 		code_heap_scans++;
 
-		if(collecting_gen == TENURED)
+		if(collecting_gen == data->tenured())
 			free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
 		else
 			copy_code_heap_roots();
@@ -595,7 +595,7 @@ void garbage_collection(cell gen,
 
 void gc()
 {
-	garbage_collection(TENURED,false,0);
+	garbage_collection(data->tenured(),false,0);
 }
 
 PRIMITIVE(gc)
@@ -610,7 +610,7 @@ PRIMITIVE(gc_stats)
 	cell i;
 	u64 total_gc_time = 0;
 
-	for(i = 0; i < MAX_GEN_COUNT; i++)
+	for(i = 0; i < max_gen_count; i++)
 	{
 		gc_stats *s = &stats[i];
 		result.add(allot_cell(s->collections));
@@ -635,8 +635,7 @@ PRIMITIVE(gc_stats)
 
 void clear_gc_stats()
 {
-	int i;
+	for(cell i = 0; i < max_gen_count; i++)
-	for(i = 0; i < MAX_GEN_COUNT; i++)
 		memset(&stats[i],0,sizeof(gc_stats));
 
 	cards_scanned = 0;
@@ -683,7 +682,7 @@ PRIMITIVE(become)
 
 VM_C_API void minor_gc()
 {
-	garbage_collection(NURSERY,false,0);
+	garbage_collection(data->nursery(),false,0);
 }
 
 }

vm/data_gc.hpp

@@ -24,10 +24,10 @@ void gc();
 
 inline static bool collecting_accumulation_gen_p()
 {
-	return ((HAVE_AGING_P
+	return ((data->have_aging_p()
-		&& collecting_gen == AGING
+		&& collecting_gen == data->aging()
 		&& !collecting_aging_again)
-		|| collecting_gen == TENURED);
+		|| collecting_gen == data->tenured());
 }
 
 void copy_handle(cell *handle);
@@ -39,7 +39,7 @@ void garbage_collection(volatile cell gen,
 /* We leave this many bytes free at the top of the nursery so that inline
 allocation (which does not call GC because of possible roots in volatile
 registers) does not run out of memory */
-#define ALLOT_BUFFER_ZONE 1024
+static const cell allot_buffer_zone = 1024;
 
 inline static object *allot_zone(zone *z, cell a)
 {
@@ -63,11 +63,11 @@ inline static object *allot_object(header header, cell size)
 
 	object *obj;
 
-	if(nursery.size - ALLOT_BUFFER_ZONE > size)
+	if(nursery.size - allot_buffer_zone > size)
 	{
 		/* If there is insufficient room, collect the nursery */
-		if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end)
+		if(nursery.here + allot_buffer_zone + size > nursery.end)
-			garbage_collection(NURSERY,false,0);
+			garbage_collection(data->nursery(),false,0);
 
 		cell h = nursery.here;
 		nursery.here = h + align8(size);
@@ -77,20 +77,20 @@ inline static object *allot_object(header header, cell size)
 	tenured space */
 	else
 	{
-		zone *tenured = &data->generations[TENURED];
+		zone *tenured = &data->generations[data->tenured()];
 
 		/* If tenured space does not have enough room, collect */
 		if(tenured->here + size > tenured->end)
 		{
 			gc();
-			tenured = &data->generations[TENURED];
+			tenured = &data->generations[data->tenured()];
 		}
 
 		/* If it still won't fit, grow the heap */
 		if(tenured->here + size > tenured->end)
 		{
-			garbage_collection(TENURED,true,size);
+			garbage_collection(data->tenured(),true,size);
-			tenured = &data->generations[TENURED];
+			tenured = &data->generations[data->tenured()];
 		}
 
 		obj = allot_zone(tenured,size);

vm/data_heap.cpp

@@ -26,10 +26,10 @@ cell init_zone(zone *z, cell size, cell start)
 
 void init_card_decks()
 {
-	cell start = align(data->seg->start,DECK_SIZE);
+	cell start = align(data->seg->start,deck_size);
-	allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
+	allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
-	cards_offset = (cell)data->cards - (start >> CARD_BITS);
+	cards_offset = (cell)data->cards - (start >> card_bits);
-	decks_offset = (cell)data->decks - (start >> DECK_BITS);
+	decks_offset = (cell)data->decks - (start >> deck_bits);
 }
 
 data_heap *alloc_data_heap(cell gens,
@@ -37,9 +37,9 @@ data_heap *alloc_data_heap(cell gens,
 	cell aging_size,
 	cell tenured_size)
 {
-	young_size = align(young_size,DECK_SIZE);
+	young_size = align(young_size,deck_size);
-	aging_size = align(aging_size,DECK_SIZE);
+	aging_size = align(aging_size,deck_size);
-	tenured_size = align(tenured_size,DECK_SIZE);
+	tenured_size = align(tenured_size,deck_size);
 
 	data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
 	data->young_size = young_size;
@@ -58,42 +58,42 @@ data_heap *alloc_data_heap(cell gens,
 		return NULL; /* can't happen */
 	}
 
-	total_size += DECK_SIZE;
+	total_size += deck_size;
 
 	data->seg = alloc_segment(total_size);
 
 	data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
 	data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
 
-	cell cards_size = total_size >> CARD_BITS;
+	cell cards_size = total_size >> card_bits;
 	data->allot_markers = (cell *)safe_malloc(cards_size);
 	data->allot_markers_end = data->allot_markers + cards_size;
 
 	data->cards = (cell *)safe_malloc(cards_size);
 	data->cards_end = data->cards + cards_size;
 
-	cell decks_size = total_size >> DECK_BITS;
+	cell decks_size = total_size >> deck_bits;
 	data->decks = (cell *)safe_malloc(decks_size);
 	data->decks_end = data->decks + decks_size;
 
-	cell alloter = align(data->seg->start,DECK_SIZE);
+	cell alloter = align(data->seg->start,deck_size);
 
-	alloter = init_zone(&data->generations[TENURED],tenured_size,alloter);
+	alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter);
-	alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter);
+	alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter);
 
 	if(data->gen_count == 3)
 	{
-		alloter = init_zone(&data->generations[AGING],aging_size,alloter);
+		alloter = init_zone(&data->generations[data->aging()],aging_size,alloter);
-		alloter = init_zone(&data->semispaces[AGING],aging_size,alloter);
+		alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter);
 	}
 
 	if(data->gen_count >= 2)
 	{
-		alloter = init_zone(&data->generations[NURSERY],young_size,alloter);
+		alloter = init_zone(&data->generations[data->nursery()],young_size,alloter);
-		alloter = init_zone(&data->semispaces[NURSERY],0,alloter);
+		alloter = init_zone(&data->semispaces[data->nursery()],0,alloter);
 	}
 
-	if(data->seg->end - alloter > DECK_SIZE)
+	if(data->seg->end - alloter > deck_size)
 		critical_error("Bug in alloc_data_heap",alloter);
 
 	return data;
@@ -141,12 +141,12 @@ void clear_allot_markers(cell from, cell to)
 	/* NOTE: reverse order due to heap layout. */
 	card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
 	card *last_card = addr_to_allot_marker((object *)data->generations[from].end);
-	memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
+	memset(first_card,invalid_allot_marker,last_card - first_card);
 }
 
 void reset_generation(cell i)
 {
-	zone *z = (i == NURSERY ? &nursery : &data->generations[i]);
+	zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
 
 	z->here = z->start;
 	if(secure_gc)
@@ -169,11 +169,11 @@ void reset_generations(cell from, cell to)
 void set_data_heap(data_heap *data_)
 {
 	data = data_;
-	nursery = data->generations[NURSERY];
+	nursery = data->generations[data->nursery()];
 	init_card_decks();
-	clear_cards(NURSERY,TENURED);
+	clear_cards(data->nursery(),data->tenured());
-	clear_decks(NURSERY,TENURED);
+	clear_decks(data->nursery(),data->tenured());
-	clear_allot_markers(NURSERY,TENURED);
+	clear_allot_markers(data->nursery(),data->tenured());
 }
 
 void init_data_heap(cell gens,
@@ -298,7 +298,7 @@ PRIMITIVE(data_room)
 	cell gen;
 	for(gen = 0; gen < data->gen_count; gen++)
 	{
-		zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]);
+		zone *z = (gen == data->nursery() ? &nursery : &data->generations[gen]);
 		a.add(tag_fixnum((z->end - z->here) >> 10));
 		a.add(tag_fixnum((z->size) >> 10));
 	}
@@ -314,7 +314,7 @@ cell heap_scan_ptr;
 /* Disables GC and activates next-object ( -- obj ) primitive */
 void begin_scan()
 {
-	heap_scan_ptr = data->generations[TENURED].start;
+	heap_scan_ptr = data->generations[data->tenured()].start;
 	gc_off = true;
 }
 
@@ -328,7 +328,7 @@ cell next_object()
 	if(!gc_off)
 		general_error(ERROR_HEAP_SCAN,F,F,NULL);
 
-	if(heap_scan_ptr >= data->generations[TENURED].here)
+	if(heap_scan_ptr >= data->generations[data->tenured()].here)
 		return F;
 
 	object *obj = (object *)heap_scan_ptr;

vm/data_heap.hpp

@@ -34,20 +34,22 @@ struct data_heap {
 
 	cell *decks;
 	cell *decks_end;
+	
+	/* the 0th generation is where new objects are allocated. */
+	cell nursery() { return 0; }
+	
+	/* where objects hang around */
+	cell aging() { return gen_count - 2; }
+	
+	/* the oldest generation */
+	cell tenured() { return gen_count - 1; }
+	
+	bool have_aging_p() { return gen_count > 2; }
 };
 
 extern data_heap *data;
 
-/* the 0th generation is where new objects are allocated. */
+static const cell max_gen_count = 3;
-#define NURSERY 0
-/* where objects hang around */
-#define AGING (data->gen_count-2)
-#define HAVE_AGING_P (data->gen_count>2)
-/* the oldest generation */
-#define TENURED (data->gen_count-1)
-
-#define MIN_GEN_COUNT 1
-#define MAX_GEN_COUNT 3
 
 inline static bool in_zone(zone *z, object *pointer)
 {

vm/dispatch.hpp

@@ -1,6 +1,9 @@
 namespace factor
 {
 
+extern cell megamorphic_cache_hits;
+extern cell megamorphic_cache_misses;
+
 cell lookup_method(cell object, cell methods);
 PRIMITIVE(lookup_method);
 

vm/image.cpp

@@ -31,7 +31,7 @@ static void load_data_heap(FILE *file, image_header *h, vm_parameters *p)
 
 	clear_gc_stats();
 
-	zone *tenured = &data->generations[TENURED];
+	zone *tenured = &data->generations[data->tenured()];
 
 	fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
 
@@ -92,10 +92,10 @@ bool save_image(const vm_char *filename)
 		return false;
 	}
 
-	zone *tenured = &data->generations[TENURED];
+	zone *tenured = &data->generations[data->tenured()];
 
-	h.magic = IMAGE_MAGIC;
+	h.magic = image_magic;
-	h.version = IMAGE_VERSION;
+	h.version = image_version;
 	h.data_relocation_base = tenured->start;
 	h.data_size = tenured->here - tenured->start;
 	h.code_relocation_base = code.seg->start;
@@ -165,7 +165,7 @@ static void data_fixup(cell *cell)
 	if(immediate_p(*cell))
 		return;
 
-	zone *tenured = &data->generations[TENURED];
+	zone *tenured = &data->generations[data->tenured()];
 	*cell += (tenured->start - data_relocation_base);
 }
 
@@ -271,7 +271,7 @@ void relocate_data()
 	data_fixup(&bignum_pos_one);
 	data_fixup(&bignum_neg_one);
 
-	zone *tenured = &data->generations[TENURED];
+	zone *tenured = &data->generations[data->tenured()];
 
 	for(relocating = tenured->start;
 		relocating < tenured->here;
@@ -313,10 +313,10 @@ void load_image(vm_parameters *p)
 	if(fread(&h,sizeof(image_header),1,file) != 1)
 		fatal_error("Cannot read image header",0);
 
-	if(h.magic != IMAGE_MAGIC)
+	if(h.magic != image_magic)
 		fatal_error("Bad image: magic number check failed",h.magic);
 
-	if(h.version != IMAGE_VERSION)
+	if(h.version != image_version)
 		fatal_error("Bad image: version number check failed",h.version);
 	
 	load_data_heap(file,&h,p);

vm/image.hpp

@@ -1,8 +1,8 @@
 namespace factor
 {
 
-#define IMAGE_MAGIC 0x0f0e0d0c
+static const cell image_magic = 0x0f0e0d0c;
-#define IMAGE_VERSION 4
+static const cell image_version = 4;
 
 struct image_header {
 	cell magic;

vm/layouts.hpp

@@ -23,8 +23,10 @@ inline static cell align(cell a, cell b)
 	return (a + (b-1)) & ~(b-1);
 }
 
-#define align8(a) align(a,8)
+inline static cell align8(cell a)
-#define align_page(a) align(a,getpagesize())
+{
+	return align(a,8);
+}
 
 #define WORD_SIZE (signed)(sizeof(cell)*8)
 
@@ -297,12 +299,6 @@ struct dll : public object {
 	void *dll;
 };
 
-struct callstack : public object {
-	static const cell type_number = CALLSTACK_TYPE;
-	/* tagged */
-	cell length;
-};
-
 struct stack_frame
 {
 	void *xt;
@@ -310,6 +306,15 @@ struct stack_frame
 	cell size;
 };
 
+struct callstack : public object {
+	static const cell type_number = CALLSTACK_TYPE;
+	/* tagged */
+	cell length;
+	
+	stack_frame *top() { return (stack_frame *)(this + 1); }
+	stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
+};
+
 struct tuple : public object {
 	static const cell type_number = TUPLE_TYPE;
 	/* tagged layout */

vm/master.hpp

@@ -19,6 +19,7 @@
 #include <stdlib.h>
 #include <string.h>
 #include <time.h>
+#include <unistd.h>
 #include <sys/param.h>
 
 /* C++ headers */

vm/math.cpp

@@ -24,8 +24,8 @@ PRIMITIVE(fixnum_divint)
 	fixnum y = untag_fixnum(dpop()); \
 	fixnum x = untag_fixnum(dpeek());
 	fixnum result = x / y;
-	if(result == -FIXNUM_MIN)
+	if(result == -fixnum_min)
-		drepl(allot_integer(-FIXNUM_MIN));
+		drepl(allot_integer(-fixnum_min));
 	else
 		drepl(tag_fixnum(result));
 }
@@ -34,9 +34,9 @@ PRIMITIVE(fixnum_divmod)
 {
 	cell y = ((cell *)ds)[0];
 	cell x = ((cell *)ds)[-1];
-	if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
+	if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min))
 	{
-		((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN);
+		((cell *)ds)[-1] = allot_integer(-fixnum_min);
 		((cell *)ds)[0] = tag_fixnum(0);
 	}
 	else
@@ -50,9 +50,20 @@ PRIMITIVE(fixnum_divmod)
  * If we're shifting right by n bits, we won't overflow as long as none of the
  * high WORD_SIZE-TAG_BITS-n bits are set.
  */
-#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
+static inline fixnum sign_mask(fixnum x)
-#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
+{
-#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
+	return x >> (WORD_SIZE - 1);
+}
+
+static inline fixnum branchless_max(fixnum x, fixnum y)
+{
+	return (x - ((x - y) & sign_mask(x - y)));
+}
+
+static inline fixnum branchless_abs(fixnum x)
+{
+	return (x ^ sign_mask(x)) - sign_mask(x);
+}
 
 PRIMITIVE(fixnum_shift)
 {
@@ -63,14 +74,14 @@ PRIMITIVE(fixnum_shift)
 		return;
 	else if(y < 0)
 	{
-		y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
+		y = branchless_max(y,-WORD_SIZE + 1);
 		drepl(tag_fixnum(x >> -y));
 		return;
 	}
 	else if(y < WORD_SIZE - TAG_BITS)
 	{
 		fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y));
-		if(!(BRANCHLESS_ABS(x) & mask))
+		if(!(branchless_abs(x) & mask))
 		{
 			drepl(tag_fixnum(x << y));
 			return;
@@ -226,7 +237,7 @@ cell unbox_array_size()
 	case FIXNUM_TYPE:
 		{
 			fixnum n = untag_fixnum(dpeek());
-			if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX)
+			if(n >= 0 && n < (fixnum)array_size_max)
 			{
 				dpop();
 				return n;
@@ -236,7 +247,7 @@ cell unbox_array_size()
 	case BIGNUM_TYPE:
 		{
 			bignum * zero = untag<bignum>(bignum_zero);
-			bignum * max = cell_to_bignum(ARRAY_SIZE_MAX);
+			bignum * max = cell_to_bignum(array_size_max);
 			bignum * n = untag<bignum>(dpeek());
 			if(bignum_compare(n,zero) != bignum_comparison_less
 				&& bignum_compare(n,max) == bignum_comparison_less)
@@ -248,7 +259,7 @@ cell unbox_array_size()
 		}
 	}
 
-	general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
+	general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(array_size_max),NULL);
 	return 0; /* can't happen */
 }
 
@@ -428,7 +439,7 @@ VM_C_API void box_unsigned_cell(cell cell)
 
 VM_C_API void box_signed_8(s64 n)
 {
-	if(n < FIXNUM_MIN || n > FIXNUM_MAX)
+	if(n < fixnum_min || n > fixnum_max)
 		dpush(tag<bignum>(long_long_to_bignum(n)));
 	else
 		dpush(tag_fixnum(n));
@@ -450,7 +461,7 @@ VM_C_API s64 to_signed_8(cell obj)
 
 VM_C_API void box_unsigned_8(u64 n)
 {
-	if(n > FIXNUM_MAX)
+	if(n > (u64)fixnum_max)
 		dpush(tag<bignum>(ulong_long_to_bignum(n)));
 	else
 		dpush(tag_fixnum(n));

vm/math.hpp

@@ -5,10 +5,9 @@ extern cell bignum_zero;
 extern cell bignum_pos_one;
 extern cell bignum_neg_one;
 
-#define cell_MAX (cell)(-1)
+static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1);
-#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
+static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
-#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)))
+static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
-#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2))
 
 PRIMITIVE(fixnum_add);
 PRIMITIVE(fixnum_subtract);
@@ -45,7 +44,7 @@ PRIMITIVE(byte_array_to_bignum);
 
 inline static cell allot_integer(fixnum x)
 {
-	if(x < FIXNUM_MIN || x > FIXNUM_MAX)
+	if(x < fixnum_min || x > fixnum_max)
 		return tag<bignum>(fixnum_to_bignum(x));
 	else
 		return tag_fixnum(x);
@@ -53,7 +52,7 @@ inline static cell allot_integer(fixnum x)
 
 inline static cell allot_cell(cell x)
 {
-	if(x > (cell)FIXNUM_MAX)
+	if(x > (cell)fixnum_max)
 		return tag<bignum>(cell_to_bignum(x));
 	else
 		return tag_fixnum(x);

vm/segments.hpp

@@ -7,4 +7,9 @@ struct segment {
 	cell end;
 };
 
+inline static cell align_page(cell a)
+{
+	return align(a,getpagesize());
+}
+
 }

vm/write_barrier.hpp

@@ -12,24 +12,24 @@ VM_C_API factor::cell decks_offset;
 namespace factor
 {
 
-/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
+/* if card_points_to_nursery is set, card_points_to_aging must also be set. */
-#define CARD_POINTS_TO_NURSERY 0x80
+static const cell card_points_to_nursery = 0x80;
-#define CARD_POINTS_TO_AGING 0x40
+static const cell card_points_to_aging = 0x40;
-#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
+static const cell card_mark_mask = (card_points_to_nursery | card_points_to_aging);
 typedef u8 card;
 
-#define CARD_BITS 8
+static const cell card_bits = 8;
-#define CARD_SIZE (1<<CARD_BITS)
+static const cell card_size = (1<<card_bits);
-#define ADDR_CARD_MASK (CARD_SIZE-1)
+static const cell addr_card_mask = (card_size-1);
 
 inline static card *addr_to_card(cell a)
 {
-	return (card*)(((cell)(a) >> CARD_BITS) + cards_offset);
+	return (card*)(((cell)(a) >> card_bits) + cards_offset);
 }
 
 inline static cell card_to_addr(card *c)
 {
-	return ((cell)c - cards_offset) << CARD_BITS;
+	return ((cell)c - cards_offset) << card_bits;
 }
 
 inline static cell card_offset(card *c)
@@ -39,48 +39,48 @@ inline static cell card_offset(card *c)
 
 typedef u8 card_deck;
 
-#define DECK_BITS (CARD_BITS + 10)
+static const cell deck_bits = (card_bits + 10);
-#define DECK_SIZE (1<<DECK_BITS)
+static const cell deck_size = (1<<deck_bits);
-#define ADDR_DECK_MASK (DECK_SIZE-1)
+static const cell addr_deck_mask = (deck_size-1);
 
 inline static card_deck *addr_to_deck(cell a)
 {
-	return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset);
+	return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
 }
 
 inline static cell deck_to_addr(card_deck *c)
 {
-	return ((cell)c - decks_offset) << DECK_BITS;
+	return ((cell)c - decks_offset) << deck_bits;
 }
 
 inline static card *deck_to_card(card_deck *d)
 {
-	return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset);
+	return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
 }
 
-#define INVALID_ALLOT_MARKER 0xff
+static const cell invalid_allot_marker = 0xff;
 
 extern cell allot_markers_offset;
 
 inline static card *addr_to_allot_marker(object *a)
 {
-	return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset);
+	return (card *)(((cell)a >> card_bits) + allot_markers_offset);
 }
 
 /* the write barrier must be called any time we are potentially storing a
 pointer from an older generation to a younger one */
 inline static void write_barrier(object *obj)
 {
-	*addr_to_card((cell)obj) = CARD_MARK_MASK;
+	*addr_to_card((cell)obj) = card_mark_mask;
-	*addr_to_deck((cell)obj) = CARD_MARK_MASK;
+	*addr_to_deck((cell)obj) = card_mark_mask;
 }
 
 /* we need to remember the first object allocated in the card */
 inline static void allot_barrier(object *address)
 {
 	card *ptr = addr_to_allot_marker(address);
-	if(*ptr == INVALID_ALLOT_MARKER)
+	if(*ptr == invalid_allot_marker)
-		*ptr = ((cell)address & ADDR_CARD_MASK);
+		*ptr = ((cell)address & addr_card_mask);
 }
 
 }