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

db4
Doug Coleman 2009-05-08 21:58:50 -05:00
commit 8e581ffaf2
55 changed files with 705 additions and 398 deletions

View File

@ -4,7 +4,7 @@
USING: strings arrays hashtables assocs sequences fry macros USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays 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 ; core-foundation.data core-foundation.utilities ;
IN: cocoa.plists IN: cocoa.plists
@ -41,10 +41,16 @@ DEFER: plist>
*void* [ -> release "read-plist failed" throw ] when* ; *void* [ -> release "read-plist failed" throw ] when* ;
MACRO: objc-class-case ( alist -- quot ) 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> PRIVATE>
ERROR: invalid-plist-object object ;
: plist> ( plist -- value ) : plist> ( plist -- value )
{ {
{ NSString [ (plist-NSString>) ] } { NSString [ (plist-NSString>) ] }
@ -53,6 +59,7 @@ PRIVATE>
{ NSArray [ (plist-NSArray>) ] } { NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] } { NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] } { NSObject [ ] }
[ invalid-plist-object ]
} objc-class-case ; } objc-class-case ;
: read-plist ( path -- assoc ) : read-plist ( path -- assoc )

View File

@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ; 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 <PRIVATE
: bitmap-flags ( -- flags ) : bitmap-flags ( -- flags )

View File

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

View File

@ -1,37 +1,93 @@
USING: help.markup help.syntax kernel math math.order sequences ; USING: help.markup help.syntax kernel math math.order multiline sequences ;
IN: math.combinatorics IN: math.combinatorics
HELP: factorial HELP: factorial
{ $values { "n" "a non-negative integer" } { "n!" integer } } { $values { "n" "a non-negative integer" } { "n!" integer } }
{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } { $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 HELP: nPk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } { $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" } "." } { $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 HELP: nCk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } { $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\"." } { $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 HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } { $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-" } "." } { $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 HELP: all-permutations
{ $values { "seq" sequence } { "seq" sequence } } { $values { "seq" sequence } { "seq" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } { $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 HELP: inverse-permutation
{ $values { "seq" sequence } { "permutation" sequence } } { $values { "seq" sequence } { "permutation" sequence } }
{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } { $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 IN: math.combinatorics.private

View File

@ -1,18 +1,6 @@
USING: math.combinatorics math.combinatorics.private tools.test ; USING: math.combinatorics math.combinatorics.private tools.test sequences ;
IN: math.combinatorics.tests 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 ] [ 0 factorial ] unit-test
[ 1 ] [ 1 factorial ] unit-test [ 1 ] [ 1 factorial ] unit-test
[ 3628800 ] [ 10 factorial ] unit-test [ 3628800 ] [ 10 factorial ] unit-test
@ -31,6 +19,19 @@ IN: math.combinatorics.tests
[ 2598960 ] [ 52 5 nCk ] unit-test [ 2598960 ] [ 52 5 nCk ] unit-test
[ 2598960 ] [ 52 47 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 [ { "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" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "a" "b" "c" } ] [ 18 { "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 [ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
[ { 3 0 2 1 } ] [ { 12 45 34 2 } 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

View File

@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. ! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: math.combinatorics
<PRIVATE <PRIVATE
@ -12,14 +12,27 @@ IN: math.combinatorics
: twiddle ( n k -- n k ) : twiddle ( n k -- n k )
2dup - dupd > [ dupd - ] when ; inline 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 ) : factoradic ( n -- factoradic )
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ; 0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq ) : (>permutation) ( seq n -- seq )
[ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation ) : >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ; reverse 1 cut [ (>permutation) ] each ;
@ -29,27 +42,84 @@ IN: math.combinatorics
PRIVATE> 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 ( n seq -- seq )
[ permutation-indices ] keep nths ; [ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq ) : all-permutations ( seq -- seq )
[ length factorial ] keep '[ _ permutation ] map ; [ length factorial ] keep
'[ _ permutation ] map ;
: each-permutation ( seq quot -- ) : each-permutation ( seq quot -- )
[ [ length factorial ] keep ] dip [ [ length factorial ] keep ] dip
'[ _ permutation @ ] each ; inline '[ _ permutation @ ] each ; inline
: reduce-permutations ( seq initial quot -- result ) : reduce-permutations ( seq identity quot -- result )
swapd each-permutation ; inline swapd each-permutation ; inline
: inverse-permutation ( seq -- permutation ) : inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ; <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

View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (c) 2008-2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel locals math math.functions math.ranges 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
@ -27,7 +27,7 @@ IN: math.miller-rabin
] [ ] [
r iota [ r iota [
2^ s * a swap n ^mod n - -1 = 2^ s * a swap n ^mod n - -1 =
] any? not ] any? not
] if ] if
] any? not ; ] any? not ;

View File

@ -21,6 +21,8 @@ M: rect pprint*
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ; : 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 -- ) -- ) : with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
[ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline [ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline

View File

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

View File

@ -122,6 +122,17 @@ M:: cocoa-ui-backend (open-window) ( world -- )
M: cocoa-ui-backend (close-window) ( handle -- ) M: cocoa-ui-backend (close-window) ( handle -- )
window>> -> release ; 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 -- ) M: cocoa-ui-backend close-window ( gadget -- )
find-world [ find-world [
handle>> [ handle>> [

View File

@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render ascii math.bitwise locals command-line shuffle opengl ui.render ascii math.bitwise locals
accessors math.rectangles math.order ascii calendar accessors math.rectangles math.order ascii calendar
io.encodings.utf16n windows.errors literals ui.pixel-formats 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 IN: ui.backend.windows
SINGLETON: windows-ui-backend SINGLETON: windows-ui-backend
@ -703,9 +703,23 @@ M: windows-ui-backend beep ( -- )
"MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize "MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
[ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ; [ 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 ) : hwnd>RECT ( hwnd -- RECT )
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ; "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 ) : fullscreen-flags ( -- n )
{ WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline

View File

@ -11,7 +11,7 @@ CONSTANT: default-world-pixel-format-attributes
{ windowed double-buffered T{ depth-bits { value 16 } } } { windowed double-buffered T{ depth-bits { value 16 } } }
TUPLE: world < track TUPLE: world < track
active? focused? active? focused? grab-input?
layers layers
title status status-owner title status status-owner
text-handle handle images text-handle handle images
@ -20,6 +20,7 @@ TUPLE: world < track
TUPLE: world-attributes TUPLE: world-attributes
{ world-class initial: world } { world-class initial: world }
grab-input?
title title
status status
gadgets gadgets
@ -63,13 +64,15 @@ M: world request-focus-on ( child gadget -- )
vertical swap new-track vertical swap new-track
t >>root? t >>root?
t >>active? t >>active?
{ 0 0 } >>window-loc ; { 0 0 } >>window-loc
f >>grab-input? ;
: apply-world-attributes ( world attributes -- world ) : apply-world-attributes ( world attributes -- world )
{ {
[ title>> >>title ] [ title>> >>title ]
[ status>> >>status ] [ status>> >>status ]
[ pixel-format-attributes>> >>pixel-format-attributes ] [ pixel-format-attributes>> >>pixel-format-attributes ]
[ grab-input?>> >>grab-input? ]
[ gadgets>> [ 1 track-add ] each ] [ gadgets>> [ 1 track-add ] each ]
} cleave ; } cleave ;

View File

@ -41,14 +41,23 @@ SYMBOL: windows
lose-focus swap each-gesture lose-focus swap each-gesture
gain-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 -- ) : focus-world ( world -- )
t >>focused? t >>focused?
dup raised-window [ ?grab-input ] [
focus-path f focus-gestures ; dup raised-window
focus-path f focus-gestures
] bi ;
: unfocus-world ( world -- ) : unfocus-world ( world -- )
f >>focused? f >>focused?
focus-path f swap focus-gestures ; [ ?ungrab-input ]
[ focus-path f swap focus-gestures ] bi ;
: try-to-open-window ( world -- ) : try-to-open-window ( world -- )
{ {

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

@ -652,9 +652,9 @@ FUNCTION: HDC BeginPaint ( HWND hwnd, LPPAINTSTRUCT lpPaint ) ;
FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ; FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ;
! FUNCTION: ChildWindowFromPointEx ! FUNCTION: ChildWindowFromPointEx
! FUNCTION: ClientThreadSetup ! FUNCTION: ClientThreadSetup
! FUNCTION: ClientToScreen FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ;
! FUNCTION: CliImmSetHotKey ! FUNCTION: CliImmSetHotKey
! FUNCTION: ClipCursor FUNCTION: int ClipCursor ( RECT* clipRect ) ;
FUNCTION: BOOL CloseClipboard ( ) ; FUNCTION: BOOL CloseClipboard ( ) ;
! FUNCTION: CloseDesktop ! FUNCTION: CloseDesktop
! FUNCTION: CloseWindow ! FUNCTION: CloseWindow
@ -1363,7 +1363,7 @@ CONSTANT: HWND_TOP f
! FUNCTION: SetWindowWord ! FUNCTION: SetWindowWord
! FUNCTION: SetWinEventHook ! FUNCTION: SetWinEventHook
! FUNCTION: ShowCaret ! FUNCTION: ShowCaret
! FUNCTION: ShowCursor FUNCTION: int ShowCursor ( BOOL show ) ;
! FUNCTION: ShowOwnedPopups ! FUNCTION: ShowOwnedPopups
! FUNCTION: ShowScrollBar ! FUNCTION: ShowScrollBar
! FUNCTION: ShowStartGlass ! FUNCTION: ShowStartGlass

View File

@ -18,7 +18,7 @@ IN: benchmark.pidigits
: >matrix ( q s r t -- z ) : >matrix ( q s r t -- z )
4array 2 group ; 4array 2 group ;
: produce ( z n -- z' ) : produce ( z y -- z' )
[ 10 ] dip -10 * 0 1 >matrix swap m. ; [ 10 ] dip -10 * 0 1 >matrix swap m. ;
: gen-x ( x -- matrix ) : gen-x ( x -- matrix )

View File

@ -27,10 +27,10 @@ ARTICLE: "game-input" "Game controller input"
{ $subsection mouse-state } ; { $subsection mouse-state } ;
HELP: open-game-input 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 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? HELP: game-input-opened?
{ $values { "?" "a boolean" } } { $values { "?" "a boolean" } }

View File

@ -1,38 +1,61 @@
USING: arrays accessors continuations kernel system USING: arrays accessors continuations kernel math system
sequences namespaces init vocabs vocabs.loader combinators ; sequences namespaces init vocabs vocabs.loader combinators ;
IN: game-input IN: game-input
SYMBOLS: game-input-backend game-input-opened ; SYMBOLS: game-input-backend game-input-opened ;
game-input-opened [ 0 ] initialize
HOOK: (open-game-input) game-input-backend ( -- ) HOOK: (open-game-input) game-input-backend ( -- )
HOOK: (close-game-input) game-input-backend ( -- ) HOOK: (close-game-input) game-input-backend ( -- )
HOOK: (reset-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? ( -- ? )
game-input-opened get ; game-input-opened get zero? not ;
<PRIVATE <PRIVATE
M: f (reset-game-input) ; M: f (reset-game-input) ;
: reset-game-input ( -- ) : reset-game-input ( -- )
game-input-opened off
(reset-game-input) ; (reset-game-input) ;
[ reset-game-input ] "game-input" add-init-hook [ reset-game-input ] "game-input" add-init-hook
PRIVATE> PRIVATE>
ERROR: game-input-not-open ;
: open-game-input ( -- ) : open-game-input ( -- )
game-input-opened? [ game-input-opened? [
(open-game-input) (open-game-input)
game-input-opened on ] unless
] unless ; game-input-opened [ 1+ ] change-global
reset-mouse ;
: close-game-input ( -- ) : close-game-input ( -- )
game-input-opened [
dup zero? [ game-input-not-open ] when
1-
] change-global
game-input-opened? [ game-input-opened? [
(close-game-input) (close-game-input)
reset-game-input reset-game-input
] when ; ] unless ;
: with-game-input ( quot -- ) : with-game-input ( quot -- )
open-game-input [ close-game-input ] [ ] cleanup ; inline open-game-input [ close-game-input ] [ ] cleanup ; inline
@ -48,12 +71,6 @@ SYMBOLS:
pov-up pov-up-right pov-right pov-down-right pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left ; 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 ) : find-controller-products ( product-id -- sequence )
get-controllers [ product-id = ] with filter ; get-controllers [ product-id = ] with filter ;
: find-controller-instance ( product-id instance-id -- controller/f ) : 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 [ instance-id = ] 2bi* and
] with with find nip ; ] with with find nip ;
HOOK: read-controller game-input-backend ( controller -- controller-state )
HOOK: calibrate-controller game-input-backend ( controller -- )
TUPLE: keyboard-state keys ; TUPLE: keyboard-state keys ;
M: keyboard-state clone M: keyboard-state clone
call-next-method dup keys>> clone >>keys ; 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 ; TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
M: mouse-state clone M: mouse-state clone
call-next-method dup buttons>> clone >>buttons ; 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 windows? ] [ "game-input.dinput" require ] }
{ [ os macosx? ] [ "game-input.iokit" require ] } { [ os macosx? ] [ "game-input.iokit" require ] }

View File

@ -1,13 +1,15 @@
USING: cocoa cocoa.plists core-foundation iokit iokit.hid USING: cocoa cocoa.plists core-foundation iokit iokit.hid
kernel cocoa.enumeration destructors math.parser cocoa.application kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit threads 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 core-foundation.run-loop accessors sequences.private
alien.c-types math parser game-input vectors ; alien.c-types math parser game-input vectors ;
IN: game-input.iokit IN: game-input.iokit
SINGLETON: iokit-game-input-backend SINGLETON: iokit-game-input-backend
SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
iokit-game-input-backend game-input-backend set-global iokit-game-input-backend game-input-backend set-global
: hid-manager-matching ( matching-seq -- alien ) : hid-manager-matching ( matching-seq -- alien )
@ -23,7 +25,6 @@ iokit-game-input-backend game-input-backend set-global
CONSTANT: game-devices-matching-seq CONSTANT: game-devices-matching-seq
{ {
H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers
H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
@ -88,19 +89,17 @@ CONSTANT: hat-switch-matching-hash
game-devices-matching-seq hid-manager-matching ; game-devices-matching-seq hid-manager-matching ;
: device-property ( device key -- value ) : device-property ( device key -- value )
<NSString> IOHIDDeviceGetProperty plist> ; <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
: element-property ( element key -- value ) : element-property ( element key -- value )
<NSString> IOHIDElementGetProperty plist> ; <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
: set-element-property ( element key value -- ) : set-element-property ( element key value -- )
[ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ; [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
: transfer-element-property ( element from-key to-key -- ) : 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 -- ? ) : mouse-device? ( device -- ? )
{ 1 2 IOHIDDeviceConformsTo ;
[ 1 1 IOHIDDeviceConformsTo ]
[ 1 2 IOHIDDeviceConformsTo ]
} 1|| ;
: controller-device? ( device -- ? ) : controller-device? ( device -- ? )
{ {
@ -113,28 +112,31 @@ CONSTANT: hat-switch-matching-hash
[ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
2array ; 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} -- ? ) : x-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 30 } = ; inline IOHIDElementGetUsage HEX: 30 = ; inline
: y-axis? ( {usage-page,usage} -- ? ) : y-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 31 } = ; inline IOHIDElementGetUsage HEX: 31 = ; inline
: z-axis? ( {usage-page,usage} -- ? ) : z-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 32 } = ; inline IOHIDElementGetUsage HEX: 32 = ; inline
: rx-axis? ( {usage-page,usage} -- ? ) : rx-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 33 } = ; inline IOHIDElementGetUsage HEX: 33 = ; inline
: ry-axis? ( {usage-page,usage} -- ? ) : ry-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 34 } = ; inline IOHIDElementGetUsage HEX: 34 = ; inline
: rz-axis? ( {usage-page,usage} -- ? ) : rz-axis? ( {usage-page,usage} -- ? )
{ 1 HEX: 35 } = ; inline IOHIDElementGetUsage HEX: 35 = ; inline
: slider? ( {usage-page,usage} -- ? ) : slider? ( {usage-page,usage} -- ? )
{ 1 HEX: 36 } = ; inline IOHIDElementGetUsage HEX: 36 = ; inline
: wheel? ( {usage-page,usage} -- ? ) : wheel? ( {usage-page,usage} -- ? )
{ 1 HEX: 38 } = ; inline IOHIDElementGetUsage HEX: 38 = ; inline
: hat-switch? ( {usage-page,usage} -- ? ) : hat-switch? ( {usage-page,usage} -- ? )
{ 1 HEX: 39 } = ; inline IOHIDElementGetUsage HEX: 39 = ; inline
CONSTANT: pov-values CONSTANT: pov-values
{ {
@ -152,45 +154,55 @@ CONSTANT: pov-values
: pov-value ( value -- pov-direction ) : pov-value ( value -- pov-direction )
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; 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 -- ) : record-controller ( controller-state value -- )
dup IOHIDValueGetElement element-usage { dup IOHIDValueGetElement {
{ [ dup button? ] [ rot record-button ] } { [ dup button? ] [ record-button ] }
{ [ dup x-axis? ] [ drop axis-value >>x drop ] } { [ dup axis? ] [ {
{ [ dup y-axis? ] [ drop axis-value >>y drop ] } { [ dup x-axis? ] [ drop axis-value >>x drop ] }
{ [ dup z-axis? ] [ drop axis-value >>z drop ] } { [ dup y-axis? ] [ drop axis-value >>y drop ] }
{ [ dup rx-axis? ] [ drop axis-value >>rx drop ] } { [ dup z-axis? ] [ drop axis-value >>z drop ] }
{ [ dup ry-axis? ] [ drop axis-value >>ry drop ] } { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
{ [ dup rz-axis? ] [ drop axis-value >>rz drop ] } { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
{ [ dup slider? ] [ drop axis-value >>slider drop ] } { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
{ [ dup hat-switch? ] [ drop pov-value >>pov drop ] } { [ dup slider? ] [ drop axis-value >>slider drop ] }
{ [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
[ 3drop ]
} cond ] }
[ 3drop ] [ 3drop ]
} cond ; } cond ;
SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; HINTS: record-controller { controller-state alien } ;
: ?set-nth ( value nth seq -- ) : ?set-nth ( value nth seq -- )
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; 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> ] [ 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 ; } cond ;
HINTS: record-mouse { mouse-state alien } ;
M: iokit-game-input-backend read-mouse M: iokit-game-input-backend read-mouse
+mouse-state+ get ; +mouse-state+ get ;
@ -263,8 +275,8 @@ M: iokit-game-input-backend reset-mouse
{ [ sender controller-device? ] [ { [ sender controller-device? ] [
sender +controller-states+ get at value record-controller 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 } cond
] IOHIDValueCallback ; ] IOHIDValueCallback ;
@ -289,7 +301,7 @@ M: iokit-game-input-backend (open-game-input)
} cleave ; } cleave ;
M: iokit-game-input-backend (reset-game-input) 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 ; [ f swap set-global ] each ;
M: iokit-game-input-backend (close-game-input) M: iokit-game-input-backend (close-game-input)
@ -304,6 +316,7 @@ M: iokit-game-input-backend (close-game-input)
f f
] change-global ] change-global
f +keyboard-state+ set-global f +keyboard-state+ set-global
f +mouse-state+ set-global
f +controller-states+ set-global f +controller-states+ set-global
] when ; ] when ;

View File

@ -162,18 +162,19 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
relayout-1 ; relayout-1 ;
M: key-caps-gadget graft* M: key-caps-gadget graft*
open-game-input
dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
drop ; drop ;
M: key-caps-gadget ungraft* M: key-caps-gadget ungraft*
alarm>> [ cancel-alarm ] when* ; alarm>> [ cancel-alarm ] when*
close-game-input ;
M: key-caps-gadget handle-gesture M: key-caps-gadget handle-gesture
drop [ key-down? ] [ key-up? ] bi or not ; drop [ key-down? ] [ key-up? ] bi or not ;
: key-caps ( -- ) : key-caps ( -- )
[ [
open-game-input
<key-caps-gadget> { 5 5 } <border> "Key Caps" open-window <key-caps-gadget> { 5 5 } <border> "Key Caps" open-window
] with-ui ; ] with-ui ;

View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ;
IN: poker IN: poker
HELP: <hand> 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" } "." } { $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
{ $examples { $examples
{ $example "USING: kernel math.order poker prettyprint ;" { $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)." } ; { $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 HELP: >cards
{ $values { "hand" "a hand" } { "str" string } } { $values { "hand" hand } { "str" string } }
{ $description "Outputs a string representation of a hand's cards." } { $description "Outputs a string representation of a hand's cards." }
{ $examples { $examples
{ $example "USING: poker prettyprint ;" { $example "USING: poker prettyprint ;"
@ -21,10 +29,18 @@ HELP: >cards
} ; } ;
HELP: >value HELP: >value
{ $values { "hand" "a hand" } { "str" string } } { $values { "hand" hand } { "str" string } }
{ $description "Outputs a string representation of a hand's value." } { $description "Outputs a string representation of a hand's value." }
{ $examples { $examples
{ $example "USING: poker prettyprint ;" { $example "USING: poker prettyprint ;"
"\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" } "\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
} }
{ $notes "This should not be used as a basis for hand comparison." } ; { $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." } ;

View File

@ -1,4 +1,4 @@
USING: accessors poker poker.private tools.test math.order kernel ; USING: accessors kernel math.order poker poker.private tools.test ;
IN: poker.tests IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test [ 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 [ 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 [ 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

View File

@ -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 IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
@ -47,19 +49,21 @@ CONSTANT: QUEEN 10
CONSTANT: KING 11 CONSTANT: KING 11
CONSTANT: ACE 12 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: 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" } "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
: card-rank-prime ( rank -- n ) : card-rank-prime ( rank -- n )
@ -108,6 +112,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
#! Cactus Kev Format #! Cactus Kev Format
>upper 1 cut (>ckf) ; >upper 1 cut (>ckf) ;
: parse-cards ( str -- seq )
" " split [ >ckf ] map ;
: flush? ( cards -- ? ) : flush? ( cards -- ? )
HEX: F000 [ bitand ] reduce 0 = not ; HEX: F000 [ bitand ] reduce 0 = not ;
@ -152,8 +159,8 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
[ drop "S" ] [ drop "S" ]
} cond ; } cond ;
: hand-rank ( hand -- rank ) : hand-rank ( value -- rank )
value>> { {
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two 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 [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ; } cond ;
: card>string ( card -- str )
[ >card-rank ] [ >card-suit ] bi append ;
PRIVATE> PRIVATE>
TUPLE: hand TUPLE: hand
{ cards sequence } { cards sequence }
{ value integer } ; { value integer initial: 9999 } ;
M: hand <=> [ value>> ] compare ; M: hand <=> [ value>> ] compare ;
M: hand equal? M: hand equal?
over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ; over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
: <hand> ( str -- hand ) : <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 ( hand -- str )
cards>> [ cards>> [ card>string ] map " " join ;
[ >card-rank ] [ >card-suit ] bi append
] map " " join ;
: >value ( hand -- str ) : >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 ;

View File

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

View File

@ -1,4 +1,4 @@
! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. ! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges project-euler.common sequences USING: kernel math math.functions math.ranges project-euler.common sequences
sets ; sets ;
@ -47,14 +47,14 @@ PRIVATE>
: euler001b ( -- answer ) : 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 ! [ euler001b ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials) ! 0 ms ave run time - 0.06 SD (100 trials)
: euler001c ( -- answer ) : euler001c ( -- answer )
1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ; 1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ;
! [ euler001c ] 100 ave-time ! [ euler001c ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials) ! 0 ms ave run time - 0.06 SD (100 trials)

View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Aaron Schaefer. ! Copyright (c) 2007, 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: project-euler.005
! http://projecteuler.net/index.php?section=problems&id=5 ! http://projecteuler.net/index.php?section=problems&id=5
@ -18,7 +18,7 @@ IN: project-euler.005
! -------- ! --------
: euler005 ( -- answer ) : euler005 ( -- answer )
20 1 [ 1+ lcm ] reduce ; 20 [1,b] 1 [ lcm ] reduce ;
! [ euler005 ] 100 ave-time ! [ euler005 ] 100 ave-time
! 0 ms ave run time - 0.14 SD (100 trials) ! 0 ms ave run time - 0.14 SD (100 trials)

View File

@ -1,6 +1,6 @@
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: project-euler.018
! http://projecteuler.net/index.php?section=problems&id=18 ! 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 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 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 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> PRIVATE>

View File

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

View File

@ -1,7 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer. ! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: project-euler.027
! http://projecteuler.net/index.php?section=problems&id=27 ! http://projecteuler.net/index.php?section=problems&id=27
@ -47,7 +46,7 @@ IN: project-euler.027
<PRIVATE <PRIVATE
: source-027 ( -- seq ) : 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 ; cartesian-product [ first2 < ] filter ;
: quadratic ( b a n -- m ) : quadratic ( b a n -- m )

View File

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

View File

@ -28,7 +28,7 @@ IN: project-euler.032
: source-032 ( -- seq ) : source-032 ( -- seq )
9 factorial iota [ 9 factorial iota [
9 permutation [ 1+ ] map 10 digits>integer 9 permutation [ 1 + ] map 10 digits>integer
] map ; ] map ;
: 1and4 ( n -- ? ) : 1and4 ( n -- ? )

View File

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

View File

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

View File

@ -1,6 +1,7 @@
! Copyright (c) 2008 Samuel Tardieu ! Copyright (c) 2008 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: project-euler.057
! http://projecteuler.net/index.php?section=problems&id=57 ! http://projecteuler.net/index.php?section=problems&id=57
@ -11,14 +12,14 @@ IN: project-euler.057
! It is possible to show that the square root of two can be expressed ! It is possible to show that the square root of two can be expressed
! as an infinite continued fraction. ! as an infinite continued fraction.
! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213... ! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
! By expanding this for the first four iterations, we get: ! By expanding this for the first four iterations, we get:
! 1 + 1/2 = 3/2 = 1.5 ! 1 + 1/2 = 3/2 = 1.5
! 1 + 1/(2 + 1/2) = 7/5 = 1.4 ! 1 + 1/(2 + 1/2) = 7/5 = 1.4
! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666... ! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379... ! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
! The next three expansions are 99/70, 239/169, and 577/408, but the ! The next three expansions are 99/70, 239/169, and 577/408, but the
! eighth expansion, 1393/985, is the first example where the number of ! eighth expansion, 1393/985, is the first example where the number of
@ -35,9 +36,9 @@ IN: project-euler.057
>fraction [ number>string length ] bi@ > ; inline >fraction [ number>string length ] bi@ > ; inline
: euler057 ( -- answer ) : 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 SOLUTION: euler057

View File

@ -1,6 +1,7 @@
! Copyright (c) 2008 Eric Mertens. ! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: project-euler.150
! http://projecteuler.net/index.php?section=problems&id=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 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq ) : 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 ) :: (euler150) ( m -- n )
[let | table [ sums-triangle ] | [let | table [ sums-triangle ] |
m [| x | m [| x |
x 1+ [| y | x 1+ [| y |
m x - iota [| z | m x - [0,b) [| z |
x z + table nth-unsafe x z + table nth-unsafe
[ y z + 1+ swap nth-unsafe ] [ y z + 1+ swap nth-unsafe ]
[ y swap nth-unsafe ] bi - [ y swap nth-unsafe ] bi -

View File

@ -10,7 +10,7 @@ IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ] CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
CONSTANT: FAR-PLANE 1.0 CONSTANT: FAR-PLANE 2.0
CONSTANT: EYE-START { 0.5 0.5 1.2 } CONSTANT: EYE-START { 0.5 0.5 1.2 }
CONSTANT: TICK-LENGTH $[ 1000 30 /i ] CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
@ -111,6 +111,7 @@ TUPLE: terrain-world < world
key-s keys nth [ world move-backward ] when key-s keys nth [ world move-backward ] when
key-a keys nth [ world move-leftward ] when key-a keys nth [ world move-leftward ] when
key-d keys nth [ world move-rightward ] when key-d keys nth [ world move-rightward ] when
key-escape keys nth [ world close-window ] when
world read-mouse rotate-with-mouse world read-mouse rotate-with-mouse
reset-mouse ; reset-mouse ;
@ -126,8 +127,8 @@ M: terrain-world draw*
GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri 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_MAG_FILTER GL_LINEAR glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ; GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
M: terrain-world begin-world M: terrain-world begin-world
"2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
@ -146,10 +147,11 @@ M: terrain-world begin-world
>>terrain-program >>terrain-program
vertex-array >vertex-buffer >>terrain-vertex-buffer vertex-array >vertex-buffer >>terrain-vertex-buffer
TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
reset-mouse open-game-input
drop ; drop ;
M: terrain-world end-world M: terrain-world end-world
close-game-input
{ {
[ game-loop>> stop-loop ] [ game-loop>> stop-loop ]
[ terrain-vertex-buffer>> delete-gl-buffer ] [ terrain-vertex-buffer>> delete-gl-buffer ]
@ -177,7 +179,6 @@ M: terrain-world pref-dim* drop { 640 480 } ;
: terrain-window ( -- ) : terrain-window ( -- )
[ [
open-game-input
f T{ world-attributes f T{ world-attributes
{ world-class terrain-world } { world-class terrain-world }
{ title "Terrain" } { title "Terrain" }
@ -186,5 +187,6 @@ M: terrain-world pref-dim* drop { 640 480 } ;
double-buffered double-buffered
T{ depth-bits { value 24 } } T{ depth-bits { value 24 } }
} } } }
{ grab-input? t }
} open-window } open-window
] with-ui ; ] with-ui ;

View File

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

View File

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

View File

@ -3,6 +3,21 @@
namespace factor 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) void flush_icache_for(code_block *block)
{ {
flush_icache((cell)block,block->size); flush_icache((cell)block,block->size);
@ -125,11 +140,11 @@ void *get_rel_symbol(array *literals, cell index)
cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{ {
array *literals = untag<array>(compiled->literals); array *literals = untag<array>(compiled->literals);
cell offset = REL_OFFSET(rel) + (cell)compiled->xt(); cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
#define ARG array_nth(literals,index) #define ARG array_nth(literals,index)
switch(REL_TYPE(rel)) switch(relocation_type_of(rel))
{ {
case RT_PRIMITIVE: case RT_PRIMITIVE:
return (cell)primitives[untag_fixnum(ARG)]; return (cell)primitives[untag_fixnum(ARG)];
@ -174,7 +189,7 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter)
{ {
relocation_entry rel = relocation->data<relocation_entry>()[i]; relocation_entry rel = relocation->data<relocation_entry>()[i];
iter(rel,index,compiled); iter(rel,index,compiled);
index += number_of_parameters(REL_TYPE(rel)); index += number_of_parameters(relocation_type_of(rel));
} }
} }
} }
@ -217,25 +232,25 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
store_address_2_2((cell *)offset,absolute_value); store_address_2_2((cell *)offset,absolute_value);
break; break;
case RC_ABSOLUTE_PPC_2: 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; break;
case RC_RELATIVE_PPC_2: 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; break;
case RC_RELATIVE_PPC_3: 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; break;
case RC_RELATIVE_ARM_3: case RC_RELATIVE_ARM_3:
store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2, store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
REL_RELATIVE_ARM_3_MASK,2); rel_relative_arm_3_mask,2);
break; break;
case RC_INDIRECT_ARM: case RC_INDIRECT_ARM:
store_address_masked((cell *)offset,relative_value - sizeof(cell), store_address_masked((cell *)offset,relative_value - sizeof(cell),
REL_INDIRECT_ARM_MASK,0); rel_indirect_arm_mask,0);
break; break;
case RC_INDIRECT_ARM_PC: case RC_INDIRECT_ARM_PC:
store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2, store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
REL_INDIRECT_ARM_MASK,0); rel_indirect_arm_mask,0);
break; break;
default: default:
critical_error("Bad rel class",klass); critical_error("Bad rel class",klass);
@ -245,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) 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); array *literals = untag<array>(compiled->literals);
fixnum absolute_value = array_nth(literals,index); 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);
} }
} }
@ -297,14 +312,14 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp
tagged<byte_array>(compiled->relocation).untag_check(); tagged<byte_array>(compiled->relocation).untag_check();
#endif #endif
store_address_in_code_block(REL_CLASS(rel), store_address_in_code_block(relocation_class_of(rel),
REL_OFFSET(rel) + (cell)compiled->xt(), relocation_offset_of(rel) + (cell)compiled->xt(),
compute_relocation(rel,index,compiled)); compute_relocation(rel,index,compiled));
} }
void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) 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) if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
relocate_code_block_step(rel,index,compiled); relocate_code_block_step(rel,index,compiled);
} }
@ -369,7 +384,7 @@ void mark_stack_frame_step(stack_frame *frame)
/* Mark code blocks executing in currently active stack frames. */ /* Mark code blocks executing in currently active stack frames. */
void mark_active_blocks(context *stacks) void mark_active_blocks(context *stacks)
{ {
if(collecting_gen == TENURED) if(collecting_gen == data->tenured())
{ {
cell top = (cell)stacks->callstack_top; cell top = (cell)stacks->callstack_top;
cell bottom = (cell)stacks->callstack_bottom; cell bottom = (cell)stacks->callstack_bottom;
@ -410,7 +425,7 @@ void mark_object_code_block(object *object)
/* Perform all fixups on a code block */ /* Perform all fixups on a code block */
void relocate_code_block(code_block *compiled) void relocate_code_block(code_block *compiled)
{ {
compiled->last_scan = NURSERY; compiled->last_scan = data->nursery();
compiled->needs_fixup = false; compiled->needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step); iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled); flush_icache_for(compiled);
@ -480,7 +495,7 @@ code_block *add_code_block(
/* compiled header */ /* compiled header */
compiled->type = type; compiled->type = type;
compiled->last_scan = NURSERY; compiled->last_scan = data->nursery();
compiled->needs_fixup = true; compiled->needs_fixup = true;
compiled->relocation = relocation.value(); compiled->relocation = relocation.value();
@ -499,7 +514,7 @@ code_block *add_code_block(
/* next time we do a minor GC, we have to scan the code heap for /* next time we do a minor GC, we have to scan the code heap for
literals */ literals */
last_code_heap_scan = NURSERY; last_code_heap_scan = data->nursery();
return compiled; return compiled;
} }

View File

@ -51,17 +51,14 @@ enum relocation_class {
RC_INDIRECT_ARM_PC 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 */ /* code relocation table consists of a table of entries for each fixup */
typedef u32 relocation_entry; 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); void flush_icache_for(code_block *compiled);

View File

@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size)
static void add_to_free_list(heap *heap, free_heap_block *block) 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]; block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block; heap->free.small_blocks[index] = block;
} }
@ -45,7 +45,7 @@ void build_free_list(heap *heap, cell size)
clear_free_list(heap); 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); heap_block *scan = first_block(heap);
free_heap_block *end = (free_heap_block *)(heap->seg->start + size); 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; 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]; free_heap_block *block = heap->free.small_blocks[index];
if(block) 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 */ /* Allocate a block of memory from the mark and sweep GC heap */
heap_block *heap_allot(heap *heap, cell size) 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); free_heap_block *block = find_free_block(heap,size);
if(block) if(block)

View File

@ -1,11 +1,11 @@
namespace factor 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 { 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; free_heap_block *large_blocks;
}; };

View File

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

View File

@ -27,7 +27,7 @@ inline static void check_call_site(cell return_address)
#endif #endif
} }
#define B_MASK 0x3fffffc static const cell b_mask = 0x3fffffc;
inline static void *get_call_target(cell return_address) inline static void *get_call_target(cell return_address)
{ {
@ -35,7 +35,7 @@ inline static void *get_call_target(cell return_address)
check_call_site(return_address); check_call_site(return_address);
cell insn = *(cell *)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; fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
return (void *)(signed_addr + return_address); return (void *)(signed_addr + return_address);
} }
@ -48,7 +48,7 @@ inline static void set_call_target(cell return_address, void *target)
cell insn = *(cell *)return_address; cell insn = *(cell *)return_address;
fixnum relative_address = ((cell)target - return_address); fixnum relative_address = ((cell)target - return_address);
insn = ((insn & ~B_MASK) | (relative_address & B_MASK)); insn = ((insn & ~b_mask) | (relative_address & b_mask));
*(cell *)return_address = insn; *(cell *)return_address = insn;
/* Flush the cache line containing the call we just patched */ /* Flush the cache line containing the call we just patched */

View File

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

View File

@ -24,10 +24,10 @@ void gc();
inline static bool collecting_accumulation_gen_p() 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_aging_again)
|| collecting_gen == TENURED); || collecting_gen == data->tenured());
} }
void copy_handle(cell *handle); 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 /* 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 allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */ 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) inline static object *allot_zone(zone *z, cell a)
{ {
@ -63,11 +63,11 @@ inline static object *allot_object(header header, cell size)
object *obj; 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 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; cell h = nursery.here;
nursery.here = h + align8(size); nursery.here = h + align8(size);
@ -77,20 +77,20 @@ inline static object *allot_object(header header, cell size)
tenured space */ tenured space */
else else
{ {
zone *tenured = &data->generations[TENURED]; zone *tenured = &data->generations[data->tenured()];
/* If tenured space does not have enough room, collect */ /* If tenured space does not have enough room, collect */
if(tenured->here + size > tenured->end) if(tenured->here + size > tenured->end)
{ {
gc(); gc();
tenured = &data->generations[TENURED]; tenured = &data->generations[data->tenured()];
} }
/* If it still won't fit, grow the heap */ /* If it still won't fit, grow the heap */
if(tenured->here + size > tenured->end) 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); obj = allot_zone(tenured,size);

View File

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

View File

@ -34,20 +34,22 @@ struct data_heap {
cell *decks; cell *decks;
cell *decks_end; 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; 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) inline static bool in_zone(zone *z, object *pointer)
{ {

View File

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

View File

@ -1,8 +1,8 @@
namespace factor 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 { struct image_header {
cell magic; cell magic;

View File

@ -23,8 +23,10 @@ inline static cell align(cell a, cell b)
return (a + (b-1)) & ~(b-1); 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) #define WORD_SIZE (signed)(sizeof(cell)*8)
@ -297,12 +299,6 @@ struct dll : public object {
void *dll; void *dll;
}; };
struct callstack : public object {
static const cell type_number = CALLSTACK_TYPE;
/* tagged */
cell length;
};
struct stack_frame struct stack_frame
{ {
void *xt; void *xt;
@ -310,6 +306,15 @@ struct stack_frame
cell size; 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 { struct tuple : public object {
static const cell type_number = TUPLE_TYPE; static const cell type_number = TUPLE_TYPE;
/* tagged layout */ /* tagged layout */

View File

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

View File

@ -24,8 +24,8 @@ PRIMITIVE(fixnum_divint)
fixnum y = untag_fixnum(dpop()); \ fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek()); fixnum x = untag_fixnum(dpeek());
fixnum result = x / y; fixnum result = x / y;
if(result == -FIXNUM_MIN) if(result == -fixnum_min)
drepl(allot_integer(-FIXNUM_MIN)); drepl(allot_integer(-fixnum_min));
else else
drepl(tag_fixnum(result)); drepl(tag_fixnum(result));
} }
@ -34,9 +34,9 @@ PRIMITIVE(fixnum_divmod)
{ {
cell y = ((cell *)ds)[0]; cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1]; 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); ((cell *)ds)[0] = tag_fixnum(0);
} }
else 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 * 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. * 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) PRIMITIVE(fixnum_shift)
{ {
@ -63,14 +74,14 @@ PRIMITIVE(fixnum_shift)
return; return;
else if(y < 0) else if(y < 0)
{ {
y = BRANCHLESS_MAX(y,-WORD_SIZE + 1); y = branchless_max(y,-WORD_SIZE + 1);
drepl(tag_fixnum(x >> -y)); drepl(tag_fixnum(x >> -y));
return; return;
} }
else if(y < WORD_SIZE - TAG_BITS) else if(y < WORD_SIZE - TAG_BITS)
{ {
fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y)); 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)); drepl(tag_fixnum(x << y));
return; return;
@ -226,7 +237,7 @@ cell unbox_array_size()
case FIXNUM_TYPE: case FIXNUM_TYPE:
{ {
fixnum n = untag_fixnum(dpeek()); fixnum n = untag_fixnum(dpeek());
if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX) if(n >= 0 && n < (fixnum)array_size_max)
{ {
dpop(); dpop();
return n; return n;
@ -236,7 +247,7 @@ cell unbox_array_size()
case BIGNUM_TYPE: case BIGNUM_TYPE:
{ {
bignum * zero = untag<bignum>(bignum_zero); 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()); bignum * n = untag<bignum>(dpeek());
if(bignum_compare(n,zero) != bignum_comparison_less if(bignum_compare(n,zero) != bignum_comparison_less
&& bignum_compare(n,max) == 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 */ 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) 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))); dpush(tag<bignum>(long_long_to_bignum(n)));
else else
dpush(tag_fixnum(n)); 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) 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))); dpush(tag<bignum>(ulong_long_to_bignum(n)));
else else
dpush(tag_fixnum(n)); dpush(tag_fixnum(n));

View File

@ -5,10 +5,9 @@ extern cell bignum_zero;
extern cell bignum_pos_one; extern cell bignum_pos_one;
extern cell bignum_neg_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_add);
PRIMITIVE(fixnum_subtract); PRIMITIVE(fixnum_subtract);
@ -45,7 +44,7 @@ PRIMITIVE(byte_array_to_bignum);
inline static cell allot_integer(fixnum x) 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)); return tag<bignum>(fixnum_to_bignum(x));
else else
return tag_fixnum(x); return tag_fixnum(x);
@ -53,7 +52,7 @@ inline static cell allot_integer(fixnum x)
inline static cell allot_cell(cell 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)); return tag<bignum>(cell_to_bignum(x));
else else
return tag_fixnum(x); return tag_fixnum(x);

View File

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

View File

@ -12,24 +12,24 @@ VM_C_API factor::cell decks_offset;
namespace factor 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; 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) 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) 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) inline static cell card_offset(card *c)
@ -39,48 +39,48 @@ inline static cell card_offset(card *c)
typedef u8 card_deck; 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) 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) 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) 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; extern cell allot_markers_offset;
inline static card *addr_to_allot_marker(object *a) 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 /* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */ pointer from an older generation to a younger one */
inline static void write_barrier(object *obj) 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 */ /* we need to remember the first object allocated in the card */
inline static void allot_barrier(object *address) inline static void allot_barrier(object *address)
{ {
card *ptr = addr_to_allot_marker(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);
} }
} }