Merge branch 'master' into inline_caching

basis/calendar/calendar-tests.factor

@@ -1,5 +1,5 @@
 USING: arrays calendar kernel math sequences tools.test
-continuations system math.order threads ;
+continuations system math.order threads accessors ;
 IN: calendar.tests
 
 [ f ] [ 2004 12 32 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
@@ -163,3 +163,10 @@ IN: calendar.tests
 [ t ] [ now 50 milliseconds sleep now before? ] unit-test
 [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
 [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
+
+[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
+[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
+
+[ f ] [ now dup midnight eq? ] unit-test
+[ f ] [ now dup easter eq? ] unit-test
+[ f ] [ now dup beginning-of-year eq? ] unit-test

basis/calendar/calendar.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.tuple combinators combinators.short-circuit
+USING: accessors arrays classes.tuple combinators
-    kernel locals math math.functions math.order namespaces sequences strings
+combinators.short-circuit kernel locals math math.functions
-    summary system threads vocabs.loader ;
+math.order sequences summary system threads vocabs.loader ;
 IN: calendar
 
 HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
 :: julian-day-number ( year month day -- n )
     #! Returns a composite date number
     #! Not valid before year -4800
-    [let* | a [ 14 month - 12 /i ]
+    14 month - 12 /i :> a
-            y [ year 4800 + a - ]
+    year 4800 + a - :> y
-            m [ month 12 a * + 3 - ] |
+    month 12 a * + 3 - :> m
-        day 153 m * 2 + 5 /i + 365 y * +
+
-        y 4 /i + y 100 /i - y 400 /i + 32045 -
+    day 153 m * 2 + 5 /i + 365 y * +
-    ] ;
+    y 4 /i + y 100 /i - y 400 /i + 32045 - ;
 
 :: julian-day-number>date ( n -- year month day )
     #! Inverse of julian-day-number
-    [let* | a [ n 32044 + ]
+    n 32044 + :> a
-            b [ 4 a * 3 + 146097 /i ]
+    4 a * 3 + 146097 /i :> b
-            c [ a 146097 b * 4 /i - ]
+    a 146097 b * 4 /i - :> c
-            d [ 4 c * 3 + 1461 /i ]
+    4 c * 3 + 1461 /i :> d
-            e [ c 1461 d * 4 /i - ]
+    c 1461 d * 4 /i - :> e
-            m [ 5 e * 2 + 153 /i ] |
+    5 e * 2 + 153 /i :> m
-        100 b * d + 4800 -
+
-        m 10 /i + m 3 +
+    100 b * d + 4800 -
-        12 m 10 /i * -
+    m 10 /i + m 3 +
-        e 153 m * 2 + 5 /i - 1+
+    12 m 10 /i * -
-    ] ;
+    e 153 m * 2 + 5 /i - 1+ ;
+
+GENERIC: easter ( obj -- obj' )
+
+:: easter-month-day ( year -- month day )
+    year 19 mod :> a
+    year 100 /mod :> c :> b
+    b 4 /mod :> e :> d
+    b 8 + 25 /i :> f
+    b f - 1 + 3 /i :> g
+    19 a * b + d - g - 15 + 30 mod :> h
+    c 4 /mod :> k :> i
+    32 2 e * + 2 i * + h - k - 7 mod :> l
+    a 11 h * + 22 l * + 451 /i :> m
+
+    h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
+    month day ;
+
+M: integer easter ( year -- timestamp )
+    dup easter-month-day <date> ;
+
+M: timestamp easter ( timestamp -- timestamp )
+    clone
+    dup year>> easter-month-day
+    swapd >>day swap >>month ;
 
 : >date< ( timestamp -- year month day )
     [ year>> ] [ month>> ] [ day>> ] tri ;

basis/checksums/md5/md5.factor

@@ -14,7 +14,7 @@ IN: checksums.md5
 SYMBOLS: a b c d old-a old-b old-c old-d ;
 
 : T ( N -- Y )
-    sin abs 4294967296 * >integer ; foldable
+    sin abs 32 2^ * >integer ; foldable
 
 : initialize-md5 ( -- )
     0 bytes-read set

basis/compiler/tests/alien.factor

@@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string
 memory system threads tools.test math accessors combinators
 specialized-arrays.float alien.libraries io.pathnames
 io.backend ;
-IN: compiler.tests
+IN: compiler.tests.alien
 
 <<
 : libfactor-ffi-tests-path ( -- string )

basis/compiler/tests/codegen.factor

@@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
 slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
 combinators vectors grouping make ;
-IN: compiler.tests
+IN: compiler.tests.codegen
 
 ! Originally, this file did black box testing of templating
 ! optimization. We now have a different codegen, but the tests

basis/compiler/tests/curry.factor

@@ -1,6 +1,6 @@
 USING: tools.test quotations math kernel sequences
 assocs namespaces make compiler.units compiler ;
-IN: compiler.tests
+IN: compiler.tests.curry
 
 [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
 [ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test

basis/compiler/tests/float.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.float
 USING: compiler.units compiler kernel kernel.private memory math
 math.private tools.test math.floats.private ;
 

basis/compiler/tests/folding.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel classes.mixin arrays ;
-IN: compiler.tests
+IN: compiler.tests.folding
 
 ! Calls to generic words were not folded away.
 

basis/compiler/tests/intrinsics.factor

@@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
 alien.accessors alien.c-types alien.syntax alien.strings
 namespaces libc sequences.private io.encodings.ascii
 classes compiler ;
-IN: compiler.tests
+IN: compiler.tests.intrinsics
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test

basis/compiler/tests/optimizer.factor

@@ -5,7 +5,7 @@ quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
 compiler.tree.builder compiler.tree.optimizer sequences.deep
 compiler ;
-IN: optimizer.tests
+IN: compiler.tests.optimizer
 
 GENERIC: xyz ( obj -- obj )
 M: array xyz xyz ;

basis/compiler/tests/peg-regression-2.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.peg-regression-2
 USING: peg.ebnf strings tools.test ;
 
 GENERIC: <times> ( times -- term' )

basis/compiler/tests/peg-regression.factor

@@ -5,7 +5,7 @@
 ! end of a compilation unit.
 
 USING: kernel accessors peg.ebnf ;
-IN: compiler.tests
+IN: compiler.tests.peg-regression
 
 TUPLE: pipeline-expr background ;
 

basis/compiler/tests/redefine1.factor

@@ -1,7 +1,7 @@
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
 definitions arrays words assocs eval strings ;
-IN: compiler.tests
+IN: compiler.tests.redefine1
 
 GENERIC: method-redefine-generic-1 ( a -- b )
 
@@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
 
 [ 6 ] [ method-redefine-test-1 ] unit-test
 
-[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
 
 [ 7 ] [ method-redefine-test-1 ] unit-test
 
@@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
 
 [ 6 ] [ method-redefine-test-2 ] unit-test
 
-[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
 
 [ 7 ] [ method-redefine-test-2 ] unit-test
 

basis/compiler/tests/redefine10.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine10
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine11.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel classes.mixin arrays ;
-IN: compiler.tests
+IN: compiler.tests.redefine11
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine2.factor

@@ -1,11 +1,11 @@
-IN: compiler.tests
+IN: compiler.tests.redefine2
 USING: compiler compiler.units tools.test math parser kernel
 sequences sequences.private classes.mixin generic definitions
 arrays words assocs eval words.symbol ;
 
 DEFER: redefine2-test
 
-[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
+[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
 
 [ t ] [ \ redefine2-test symbol? ] unit-test
 

basis/compiler/tests/redefine3.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.redefine3
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
 definitions arrays words assocs eval ;
@@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 
-[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
 
 [ "wake up" ] [ sheeple-test ] unit-test
 [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

basis/compiler/tests/redefine4.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.redefine4
 USING: io.streams.string kernel tools.test eval ;
 
 : declaration-test-1 ( -- a ) 3 ; flushable
@@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
 
 [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
 
-[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
 
 [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

basis/compiler/tests/redefine5.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine5
 
 ! Regression: if dispatch was eliminated but method was not inlined,
 ! compiled usage information was not recorded.

basis/compiler/tests/redefine6.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine6
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine7.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine7
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine8.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine8
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/redefine9.factor

@@ -1,6 +1,6 @@
 USING: eval tools.test compiler.units vocabs multiline words
 kernel generic.math ;
-IN: compiler.tests
+IN: compiler.tests.redefine9
 
 ! Mixin redefinition did not recompile all necessary words.
 

basis/compiler/tests/reload.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.reload
 USE: vocabs.loader
 
 ! "parser" reload

basis/compiler/tests/simple.factor

@@ -1,7 +1,7 @@
 USING: compiler compiler.units tools.test kernel kernel.private
 sequences.private math.private math combinators strings alien
 arrays memory vocabs parser eval ;
-IN: compiler.tests
+IN: compiler.tests.simple
 
 ! Test empty word
 [ ] [ [ ] compile-call ] unit-test

basis/compiler/tests/spilling.factor

@@ -1,6 +1,6 @@
 USING: math.private kernel combinators accessors arrays
 generalizations tools.test ;
-IN: compiler.tests
+IN: compiler.tests.spilling
 
 : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
     {

basis/compiler/tests/stack-trace.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.stack-trace
 USING: compiler tools.test namespaces sequences
 kernel.private kernel math continuations continuations.private
 words splitting grouping sorting accessors ;

basis/compiler/tests/tuples.factor

@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.tuples
 USING: kernel tools.test compiler.units compiler ;
 
 TUPLE: color red green blue ;

basis/io/directories/search/search.factor

@@ -39,55 +39,55 @@ TUPLE: directory-iterator path bfs queue ;
         dup directory?
         [ name>> over push-directory-entries next-directory-entry ]
         [ nip ] if
-    ] if ; recursive
+    ] if ;
 
-:: iterate-directory-entries ( iter quot -- directory-entry/f )
+:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
     iter next-directory-entry [
-        quot call( obj -- obj )
+        quot call
         [ iter quot iterate-directory-entries ] unless*
     ] [
         f
     ] if* ; inline recursive
 
 : iterate-directory ( iter quot -- path/f )
-    [ name>> ] prepose iterate-directory-entries ;
+    [ name>> ] prepose iterate-directory-entries ; inline
 
 : setup-traversal ( path bfs quot -- iterator quot' )
-    [ <directory-iterator> ] dip [ f ] compose ;
+    [ <directory-iterator> ] dip [ f ] compose ; inline
 
 PRIVATE>
 
 : each-file ( path bfs? quot -- )
-    setup-traversal iterate-directory drop ;
+    setup-traversal iterate-directory drop ; inline
 
 : each-directory-entry ( path bfs? quot -- )
-    setup-traversal iterate-directory-entries drop ;
+    setup-traversal iterate-directory-entries drop ; inline
 
 : recursive-directory-files ( path bfs? -- paths )
-    [ ] accumulator [ each-file ] dip ;
+    [ ] accumulator [ each-file ] dip ; inline
 
-: recursive-directory-entries ( path bfs? -- paths )
+: recursive-directory-entries ( path bfs? -- directory-entries )
-    [ ] accumulator [ each-directory-entry ] dip ;
+    [ ] accumulator [ each-directory-entry ] dip ; inline
 
 : find-file ( path bfs? quot -- path/f )
     [ <directory-iterator> ] dip
-    [ keep and ] curry iterate-directory ;
+    [ keep and ] curry iterate-directory ; inline
 
 : find-all-files ( path quot -- paths/f )
     [ f <directory-iterator> ] dip pusher
-    [ [ f ] compose iterate-directory drop ] dip ;
+    [ [ f ] compose iterate-directory drop ] dip ; inline
 
 ERROR: file-not-found path bfs? quot ;
 
 : find-file-throws ( path bfs? quot -- path )
-    3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ;
+    3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline
 
 : find-in-directories ( directories bfs? quot -- path'/f )
     '[ _ [ _ _ find-file-throws ] attempt-all ]
-    [ drop f ] recover ;
+    [ drop f ] recover ; inline
 
 : find-all-in-directories ( directories quot -- paths/f )
-    '[ _ find-all-files ] map concat ;
+    '[ _ find-all-files ] map concat ; inline
 
 : link-size/0 ( path -- n )
     [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;

basis/io/mmap/functor/functor.factor

@@ -9,13 +9,14 @@ SLOT: length
 
 : mapped-file>direct ( mapped-file type -- alien length )
     [ [ address>> ] [ length>> ] bi ] dip
-    heap-size [ 1- + ] keep /i ;
+    heap-size [ 1 - + ] keep /i ;
 
 FUNCTOR: define-mapped-array ( T -- )
 
-<mapped-A>         DEFINES <mapped-${T}-array>
+<mapped-A>                DEFINES <mapped-${T}-array>
-<A>                IS      <direct-${T}-array>
+<A>                       IS      <direct-${T}-array>
-with-mapped-A-file DEFINES with-mapped-${T}-file
+with-mapped-A-file        DEFINES with-mapped-${T}-file
+with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader
 
 WHERE
 
@@ -25,4 +26,7 @@ WHERE
 : with-mapped-A-file ( path quot -- )
     '[ <mapped-A> @ ] with-mapped-file ; inline
 
+: with-mapped-A-file-reader ( path quot -- )
+    '[ <mapped-A> @ ] with-mapped-file-reader ; inline
+
 ;FUNCTOR

basis/io/mmap/mmap-docs.factor

@@ -18,7 +18,13 @@ HELP: <mapped-file>
 
 HELP: with-mapped-file
 { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
-{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
+{ $errors "Throws an error if a memory mapping could not be established." } ;
+
+HELP: with-mapped-file-reader
+{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
+{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
 { $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 

basis/io/mmap/mmap-tests.factor

@@ -7,6 +7,7 @@ IN: io.mmap.tests
 [ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
 [ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
 [ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test
 [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
 [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
 

basis/io/mmap/mmap.factor

@@ -8,14 +8,27 @@ IN: io.mmap
 
 TUPLE: mapped-file address handle length disposed ;
 
-HOOK: (mapped-file) os ( path length -- address handle )
+HOOK: (mapped-file-reader) os ( path length -- address handle )
+HOOK: (mapped-file-r/w) os ( path length -- address handle )
 
 ERROR: bad-mmap-size path size ;
 
-: <mapped-file> ( path -- mmap )
+<PRIVATE
+
+: prepare-mapped-file ( path -- path' n )
     [ normalize-path ] [ file-info size>> ] bi
-    dup 0 <= [ bad-mmap-size ] when
+    dup 0 <= [ bad-mmap-size ] when ;
-    [ (mapped-file) ] keep
+
+PRIVATE>
+
+: <mapped-file-reader> ( path -- mmap )
+    prepare-mapped-file
+    [ (mapped-file-reader) ] keep
+    f mapped-file boa ;
+
+: <mapped-file> ( path -- mmap )
+    prepare-mapped-file
+    [ (mapped-file-r/w) ] keep
     f mapped-file boa ;
 
 HOOK: close-mapped-file io-backend ( mmap -- )
@@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
 : with-mapped-file ( path quot -- )
     [ <mapped-file> ] dip with-disposal ; inline
 
+: with-mapped-file-reader ( path quot -- )
+    [ <mapped-file-reader> ] dip with-disposal ; inline
+
 {
     { [ os unix? ] [ "io.mmap.unix" require ] }
     { [ os winnt? ] [ "io.mmap.windows" require ] }

basis/io/mmap/unix/unix.factor

@@ -4,21 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix
 io.backend.unix io.ports io.mmap destructors locals accessors ;
 IN: io.mmap.unix
 
-: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
+:: mmap-open ( path length prot flags open-mode -- alien fd )
-
-:: mmap-open ( path length prot flags -- alien fd )
     [
         f length prot flags
-        path open-r/w [ <fd> |dispose drop ] keep
+        path open-mode file-mode open-file [ <fd> |dispose drop ] keep
         [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
     ] with-destructors ;
 
-M: unix (mapped-file)
+M: unix (mapped-file-r/w)
     { PROT_READ PROT_WRITE } flags
     { MAP_FILE MAP_SHARED } flags
-    mmap-open ;
+    O_RDWR mmap-open ;
+
+M: unix (mapped-file-reader)
+    { PROT_READ } flags
+    { MAP_FILE MAP_SHARED } flags
+    O_RDONLY mmap-open ;
 
 M: unix close-mapped-file ( mmap -- )
     [ [ address>> ] [ length>> ] bi munmap io-error ]
-    [ handle>> close-file ]
+    [ handle>> close-file ] bi ;
-    bi ;

basis/io/mmap/windows/windows.factor

@@ -28,7 +28,7 @@ M: win32-mapped-file dispose
 
 C: <win32-mapped-file> win32-mapped-file
 
-M: windows (mapped-file)
+M: windows (mapped-file-r/w)
     [
         { GENERIC_WRITE GENERIC_READ } flags
         OPEN_ALWAYS
@@ -37,6 +37,15 @@ M: windows (mapped-file)
         -rot <win32-mapped-file>
     ] with-destructors ;
 
+M: windows (mapped-file-reader)
+    [
+        GENERIC_READ
+        OPEN_ALWAYS
+        { PAGE_READONLY SEC_COMMIT } flags
+        FILE_MAP_READ mmap-open
+        -rot <win32-mapped-file>
+    ] with-destructors ;
+
 M: windows close-mapped-file ( mapped-file -- )
     [
         [ handle>> &dispose drop ]

basis/math/blas/config/config.factor

@@ -18,7 +18,7 @@ blas-fortran-abi [
         { [ os netbsd?  cpu x86.64? and ] [ g95-abi        ] }
         { [ os windows? cpu x86.64? and ] [ gfortran-abi   ] }
         { [ os freebsd?                 ] [ gfortran-abi   ] }
-        { [ os linux?   cpu x86.32? and ] [ gfortran-abi   ] }
+        { [ os linux?                   ] [ gfortran-abi   ] }
         [ f2c-abi ]
     } cond
 ] initialize

extra/benchmark/fasta/fasta.factor

@@ -46,8 +46,8 @@ CONSTANT: homo-sapiens
     }
 
 : make-cumulative ( freq -- chars floats )
-    dup keys >byte-array
+    [ keys >byte-array ]
-    swap values >double-array unclip [ + ] accumulate swap suffix ;
+    [ values >double-array ] bi unclip [ + ] accumulate swap suffix ;
 
 :: select-random ( seed chars floats -- seed elt )
     floats seed random -rot
@@ -55,7 +55,7 @@ CONSTANT: homo-sapiens
     chars nth-unsafe ; inline
 
 : make-random-fasta ( seed len chars floats -- seed )
-    [ rot drop select-random ] 2curry B{ } map-as print ; inline
+    [ rot drop select-random ] 2curry "" map-as print ; inline
 
 : write-description ( desc id -- )
     ">" write write bl print ; inline
@@ -71,7 +71,7 @@ CONSTANT: homo-sapiens
 
 :: make-repeat-fasta ( k len alu -- k' )
     [let | kn [ alu length ] |
-        len [ k + kn mod alu nth-unsafe ] B{ } map-as print
+        len [ k + kn mod alu nth-unsafe ] "" map-as print
         k len +
     ] ; inline
 

extra/id3/id3.factor

@@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
 io.encodings.string io.encodings.utf16 assocs math.parser
 combinators.short-circuit fry namespaces combinators.smart
 splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search literals math.functions ;
+io.directories.search literals math.functions continuations ;
 IN: id3
 
 <PRIVATE
@@ -205,7 +205,9 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
         drop
     ] if ;
 
-: (mp3>id3) ( path -- id3v2/f )
+PRIVATE>
+
+: mp3>id3 ( path -- id3/f )
     [
         [ <id3> ] dip
         {
@@ -213,12 +215,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ]
             [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
             [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
         } cleave
-    ] with-mapped-uchar-file ;
+    ] with-mapped-uchar-file-reader ;
-
-PRIVATE>
-
-: mp3>id3 ( path -- id3/f )
-    dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ;
 
 : find-id3-frame ( id3 name -- obj/f )
     swap frames>> at* [ data>> ] when ;
@@ -239,8 +236,14 @@ PRIVATE>
 : find-mp3s ( path -- seq )
     [ >lower ".mp3" tail? ] find-all-files ;
 
+ERROR: id3-parse-error path error ;
+
+: (mp3-paths>id3s) ( seq -- seq' )
+    [ dup [ mp3>id3 ] [ \ id3-parse-error boa ] recover ] { } map>assoc ;
+
 : mp3-paths>id3s ( seq -- seq' )
-    [ dup mp3>id3 ] { } map>assoc ;
+    (mp3-paths>id3s)
+    [ dup second id3-parse-error? [ f over set-second ] when ] map ;
 
 : parse-mp3-directory ( path -- seq )
     find-mp3s mp3-paths>id3s ;

extra/images/viewer/viewer.factor

@@ -2,33 +2,26 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors images images.loader io.pathnames kernel namespaces
 opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
-ui.gadgets.panes ui.render ;
+ui.gadgets.panes ui.render ui.images ;
 IN: images.viewer
 
-TUPLE: image-gadget < gadget { image image } ;
+TUPLE: image-gadget < gadget image-name ;
 
 M: image-gadget pref-dim*
-    image>> dim>> ;
+    image-name>> image-dim ;
-
-: draw-image ( image -- )
-    0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
-    [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
-    glDrawPixels ;
 
 M: image-gadget draw-gadget* ( gadget -- )
-    image>> draw-image ;
+    image-name>> draw-image ;
 
-: <image-gadget> ( image -- gadget )
+: <image-gadget> ( image-name -- gadget )
     \ image-gadget new
-        swap >>image ;
+        swap >>image-name ;
 
 : image-window ( path -- gadget )
-    [ load-image <image-gadget> dup ] [ open-window ] bi ;
+    [ <image-name> <image-gadget> dup ] [ open-window ] bi ;
 
 GENERIC: image. ( object -- )
 
-M: string image. ( image -- ) load-image image. ;
+M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
 
-M: pathname image. ( image -- ) load-image image. ;
+M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
-
-M: image image. ( image -- ) <image-gadget> gadget. ;

extra/mason/notify/notify.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors io io.sockets io.encodings.utf8 io.files
 io.launcher kernel make mason.config mason.common mason.email
-mason.twitter namespaces sequences ;
+mason.twitter namespaces sequences prettyprint ;
 IN: mason.notify
 
 : status-notify ( input-file args -- )
@@ -38,7 +38,7 @@ IN: mason.notify
     f { "test" } status-notify ;
 
 : notify-report ( status -- )
-    [ "Build finished with status: " write print flush ]
+    [ "Build finished with status: " write . flush ]
     [
         [ "report" utf8 file-contents ] dip email-report
         "report" { "report" } status-notify

extra/mason/report/report.factor

@@ -28,7 +28,7 @@ IN: mason.report
         common-report
         _ call( -- xml )
         [XML <html><body><-><-></body></html> XML]
-        pprint-xml
+        write-xml
     ] with-file-writer ; inline
 
 :: failed-report ( error file what -- status )

extra/morse/morse-tests.factor

@@ -3,7 +3,7 @@
 USING: arrays morse strings tools.test ;
 IN: morse.tests
 
-[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
+[ "?" ] [ CHAR: \\ ch>morse ] unit-test
 [ "..." ] [ CHAR: s ch>morse ] unit-test
 [ CHAR: s ] [ "..." morse>ch ] unit-test
 [ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
@@ -41,3 +41,4 @@ IN: morse.tests
     MORSE] ] unit-test
 ! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
 ! [ ] [ "Factor rocks!" play-as-morse ] unit-test
+! [ ] [ "\n" play-as-morse ] unit-test

extra/morse/morse.factor

@@ -3,13 +3,15 @@
 USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
 IN: morse
 
+ERROR: no-morse-code ch ;
+
 <PRIVATE
 
 CONSTANT: dot-char CHAR: .
 CONSTANT: dash-char CHAR: -
 CONSTANT: char-gap-char CHAR: \s
 CONSTANT: word-gap-char CHAR: /
-CONSTANT: unknown-char CHAR: ?
+CONSTANT: unknown-char "?"
 
 PRIVATE>
 
@@ -74,10 +76,10 @@ CONSTANT: morse-code-table $[
 ]
 
 : ch>morse ( ch -- morse )
-    ch>lower morse-code-table at [ unknown-char ] unless* ;
+    ch>lower morse-code-table at unknown-char or ;
 
 : morse>ch ( str -- ch )
-    morse-code-table value-at [ char-gap-char ] unless* ;
+    morse-code-table value-at char-gap-char or ;
     
 <PRIVATE
     
@@ -148,12 +150,13 @@ CONSTANT: beep-freq 880
         source get source-play
     ] with-scope ; inline
 
-: play-char ( ch -- )
+: play-char ( string -- )
     [ intra-char-gap ] [
         {
             { dot-char [ dot ] }
             { dash-char [ dash ] }
             { word-gap-char [ intra-char-gap ] }
+            [ drop intra-char-gap ]
         } case
     ] interleave ;
 

extra/pair-rocket/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/pair-rocket/pair-rocket-docs.factor

@@ -0,0 +1,15 @@
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax multiline ;
+IN: pair-rocket
+
+HELP: =>
+{ $syntax "a => b" }
+{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." }
+{ $examples
+{ $unchecked-example <" USING: pair-rocket prettyprint ;
+
+H{ "foo" => 1 "bar" => 2 } .
+"> <" H{ { "foo" 1 } { "bar" 2 } } "> }
+}
+;
+

extra/pair-rocket/pair-rocket-tests.factor

@@ -0,0 +1,10 @@
+! (c)2009 Joe Groff bsd license
+USING: kernel pair-rocket tools.test ;
+IN: pair-rocket.tests
+
+[ { "a" 1 } ] [ "a" => 1 ] unit-test
+[ { { "a" } { 1 } } ] [ { "a" } => { 1 } ] unit-test
+[ { drop 1 } ] [ drop => 1 ] unit-test
+
+[ H{ { "zippity" 5 } { "doo" 2 } { "dah" 7 } } ]
+[ H{ "zippity" => 5 "doo" => 2 "dah" => 7 } ] unit-test

extra/pair-rocket/pair-rocket.factor

@@ -0,0 +1,6 @@
+! (c)2009 Joe Groff bsd license
+USING: arrays kernel parser sequences ;
+IN: pair-rocket
+
+SYNTAX: => dup pop scan-object 2array parsed ;
+

extra/pair-rocket/summary.txt

@@ -0,0 +1 @@
+H{ "foo" => 1 "bar" => 2 } style literal syntax

extra/qw/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/qw/qw-docs.factor

@@ -0,0 +1,12 @@
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax multiline ;
+IN: qw
+
+HELP: qw{
+{ $syntax "qw{ lorem ipsum }" }
+{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." }
+{ $examples
+{ $unchecked-example <" USING: prettyprint qw ;
+qw{ pop quiz my hive of big wild ex tranny jocks } . ">
+<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> }
+} ;

extra/qw/qw-tests.factor

@@ -0,0 +1,5 @@
+! (c)2009 Joe Groff bsd license
+USING: qw tools.test ;
+IN: qw.tests
+
+[ { "zippity" "doo" "dah" } ] [ qw{ zippity doo dah } ] unit-test

extra/qw/qw.factor

@@ -0,0 +1,5 @@
+! (c)2009 Joe Groff bsd license
+USING: lexer parser ;
+IN: qw
+
+SYNTAX: qw{ "}" parse-tokens parsed ;

extra/qw/summary.txt

@@ -0,0 +1 @@
+Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar })

extra/roles/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/roles/roles-docs.factor

@@ -0,0 +1,48 @@
+! (c)2009 Joe Groff bsd license
+USING: classes.mixin help.markup help.syntax kernel multiline roles ;
+IN: roles
+
+HELP: ROLE:
+{ $syntax <" ROLE: name slots... ;
+ROLE: name < role slots... ;
+ROLE: name <{ roles... } slots... ; "> }
+{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "."
+$nl
+"Slot specifiers take one of the following three forms:"
+{ $list
+    { { $snippet "name" } " - a slot which can hold any object, with no attributes" }
+    { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
+    { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
+}
+"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; 
+
+HELP: TUPLE:
+{ $syntax <" TUPLE: name slots ;
+TUPLE: name < estate slots ;
+TUPLE: name <{ estates... } slots... ; "> }
+{ $description "Defines a new " { $link tuple } " class."
+$nl
+"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "."
+$nl
+"Slot specifiers take one of the following three forms:"
+{ $list
+    { { $snippet "name" } " - a slot which can hold any object, with no attributes" }
+    { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
+    { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
+}
+"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; 
+
+{
+    POSTPONE: ROLE:
+    POSTPONE: TUPLE:
+} related-words
+
+HELP: role
+{ $class-description "The superclass of all role classes. A " { $snippet "role" } " is a " { $link mixin-class } " that includes a set of slot definitions that can be added to " { $link tuple } " classes alongside other " { $snippet "role" } "s." } ;
+
+HELP: multiple-inheritance-attempted
+{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " definition attempts to inherit more than one " { $link tuple } " class." } ;
+
+HELP: role-slot-overlap
+{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ;
+

extra/roles/roles-tests.factor

@@ -0,0 +1,67 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors classes.tuple compiler.units kernel qw roles sequences
+tools.test ;
+IN: roles.tests
+
+ROLE: fork tines ;
+ROLE: spoon bowl ;
+ROLE: instrument tone ;
+ROLE: tuning-fork <{ fork instrument } volume ;
+
+TUPLE: utensil handle ;
+
+! role consumption and tuple inheritance can be mixed
+TUPLE: foon <{ utensil fork spoon } ;
+TUPLE: tuning-spork <{ utensil spoon tuning-fork } ;
+
+! role class testing
+[ t ] [ fork role? ] unit-test
+[ f ] [ foon role? ] unit-test
+
+! roles aren't tuple classes by themselves and can't be instantiated
+[ f ] [ fork tuple-class? ] unit-test
+[ fork new ] must-fail
+
+! tuples which consume roles fall under their class
+[ t ] [ foon new fork? ] unit-test
+[ t ] [ foon new spoon? ] unit-test
+[ f ] [ foon new tuning-fork? ] unit-test
+[ f ] [ foon new instrument? ] unit-test
+
+[ t ] [ tuning-spork new fork? ] unit-test
+[ t ] [ tuning-spork new spoon? ] unit-test
+[ t ] [ tuning-spork new tuning-fork? ] unit-test
+[ t ] [ tuning-spork new instrument? ] unit-test
+
+! consumed role slots are placed in tuples in order
+[ qw{ handle tines bowl } ] [ foon all-slots [ name>> ] map ] unit-test
+[ qw{ handle bowl tines tone volume } ] [ tuning-spork all-slots [ name>> ] map ] unit-test
+
+! can't combine roles whose slots overlap
+ROLE: bong bowl ;
+SYMBOL: spong
+
+[ [ spong { spoon bong } { } define-tuple-class-with-roles ] with-compilation-unit ]
+[ role-slot-overlap? ] must-fail-with 
+
+[ [ spong { spoon bong } { } define-role ] with-compilation-unit ]
+[ role-slot-overlap? ] must-fail-with 
+
+! can't try to inherit multiple tuple classes
+TUPLE: tool blade ;
+SYMBOL: knife
+
+[ knife { utensil tool } { } define-tuple-class-with-roles ]
+[ multiple-inheritance-attempted? ] must-fail-with 
+
+! make sure method dispatch works
+GENERIC: poke ( pokee poker -- result )
+GENERIC: scoop ( scoopee scooper -- result )
+GENERIC: tune ( tunee tuner -- result )
+
+M: fork poke drop " got poked" append ;
+M: spoon scoop drop " got scooped" append ;
+M: instrument tune drop " got tuned" append ;
+
+[ "potato got poked" "potato got scooped" "potato got tuned" ]
+[ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test

extra/roles/roles.factor

@@ -0,0 +1,69 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays classes classes.mixin classes.parser
+classes.tuple classes.tuple.parser combinators
+combinators.short-circuit kernel lexer make parser sequences
+sets strings words ;
+IN: roles
+
+ERROR: role-slot-overlap class slots ;
+ERROR: multiple-inheritance-attempted classes ;
+
+PREDICATE: role < class
+    { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ;
+
+: parse-role-definition ( -- class superroles slots )
+    CREATE-CLASS scan {
+        { ";" [ { } { } ] }
+        { "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] }
+        { "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] }
+        [ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
+    } case ;
+
+: slot-name ( name/array -- name )
+    dup string? [ ] [ first ] if ;
+: slot-names ( array -- names )
+    [ slot-name ] map ;
+
+: role-slots ( role -- slots )
+    [ "superroles" word-prop [ role-slots ] map concat ]
+    [ "role-slots" word-prop ] bi append ;
+
+: role-or-tuple-slot-names ( role-or-tuple -- names )
+    dup role?
+    [ role-slots slot-names ]
+    [ all-slots [ name>> ] map ] if ;
+
+: check-for-slot-overlap ( class roles-and-superclass slots -- )
+    [ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append
+    duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
+
+: roles>slots ( roles-and-superclass slots -- superclass slots' )
+    [
+        [ role? ] partition
+        dup length {
+            { 0 [ drop tuple ] }
+            { 1 [ first ] }
+            [ drop multiple-inheritance-attempted ]
+        } case
+        swap [ role-slots ] map concat
+    ] dip append ;
+
+: add-to-roles ( class roles -- )
+    [ add-mixin-instance ] with each ;
+
+: (define-role) ( class superroles slots -- )
+    [ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry*
+    [ define-mixin-class ] tri ;
+
+: define-role ( class superroles slots -- )
+    [ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ;
+
+: define-tuple-class-with-roles ( class roles-and-superclass slots -- )
+    [ check-for-slot-overlap ]
+    [ roles>slots define-tuple-class ]
+    [ drop [ role? ] filter add-to-roles ] 3tri ;
+
+SYNTAX: ROLE: parse-role-definition define-role ;
+SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ;
+
+

extra/roles/summary.txt

@@ -0,0 +1 @@
+Mixins for tuples

vm/code_gc.c

@@ -1,5 +1,10 @@
 #include "master.h"
 
+static void clear_free_list(F_HEAP *heap)
+{
+	memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST));
+}
+
 /* This malloc-style heap code is reasonably generic. Maybe in the future, it
 will be used for the data heap too, if we ever get incremental
 mark/sweep/compact GC. */
@@ -8,17 +13,23 @@ void new_heap(F_HEAP *heap, CELL size)
 	heap->segment = alloc_segment(align_page(size));
 	if(!heap->segment)
 		fatal_error("Out of memory in new_heap",size);
-	heap->free_list = NULL;
+
+	clear_free_list(heap);
 }
 
-/* If there is no previous block, next_free becomes the head of the free list,
+void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block)
-else its linked in */
-INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free)
 {
-	if(prev)
+	if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
-		prev->next_free = next_free;
+	{
+		int index = block->block.size / BLOCK_SIZE_INCREMENT;
+		block->next_free = heap->free.small[index];
+		heap->free.small[index] = block;
+	}
 	else
-		heap->free_list = next_free;
+	{
+		block->next_free = heap->free.large;
+		heap->free.large = block;
+	}
 }
 
 /* Called after reading the code heap from the image file, and after code GC.
@@ -28,7 +39,11 @@ compiling.limit. */
 void build_free_list(F_HEAP *heap, CELL size)
 {
 	F_BLOCK *prev = NULL;
-	F_FREE_BLOCK *prev_free = NULL;
+
+	clear_free_list(heap);
+
+	size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+
 	F_BLOCK *scan = first_block(heap);
 	F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size);
 
@@ -38,8 +53,7 @@ void build_free_list(F_HEAP *heap, CELL size)
 		switch(scan->status)
 		{
 		case B_FREE:
-			update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan);
+			add_to_free_list(heap,(F_FREE_BLOCK *)scan);
-			prev_free = (F_FREE_BLOCK *)scan;
 			break;
 		case B_ALLOCATED:
 			break;
@@ -58,10 +72,9 @@ void build_free_list(F_HEAP *heap, CELL size)
 	{
 		end->block.status = B_FREE;
 		end->block.size = heap->segment->end - (CELL)end;
-		end->next_free = NULL;
 
 		/* add final free block */
-		update_free_list(heap,prev_free,end);
+		add_to_free_list(heap,end);
 	}
 	/* This branch is taken if the newly loaded image fits exactly, or
 	after code GC */
@@ -70,63 +83,88 @@ void build_free_list(F_HEAP *heap, CELL size)
 		/* even if there's no room at the end of the heap for a new
 		free block, we might have to jigger it up by a few bytes in
 		case prev + prev->size */
-		if(prev)
+		if(prev) prev->size = heap->segment->end - (CELL)prev;
-			prev->size = heap->segment->end - (CELL)prev;
-
-		/* this is the last free block */
-		update_free_list(heap,prev_free,NULL);
 	}
 
 }
 
+static void assert_free_block(F_FREE_BLOCK *block)
+{
+	if(block->block.status != B_FREE)
+		critical_error("Invalid block in free list",(CELL)block);
+}
+		
+F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size)
+{
+	CELL attempt = size;
+
+	while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+	{
+		int index = attempt / BLOCK_SIZE_INCREMENT;
+		F_FREE_BLOCK *block = heap->free.small[index];
+		if(block)
+		{
+			assert_free_block(block);
+			heap->free.small[index] = block->next_free;
+			return block;
+		}
+
+		attempt *= 2;
+	}
+
+	F_FREE_BLOCK *prev = NULL;
+	F_FREE_BLOCK *block = heap->free.large;
+
+	while(block)
+	{
+		assert_free_block(block);
+		if(block->block.size >= size)
+		{
+			if(prev)
+				prev->next_free = block->next_free;
+			else
+				heap->free.large = block->next_free;
+			return block;
+		}
+
+		prev = block;
+		block = block->next_free;
+	}
+
+	return NULL;
+}
+
+F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size)
+{
+	if(block->block.size != size )
+	{
+		/* split the block in two */
+		F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size);
+		split->block.status = B_FREE;
+		split->block.size = block->block.size - size;
+		split->next_free = block->next_free;
+		block->block.size = size;
+		add_to_free_list(heap,split);
+	}
+
+	return block;
+}
+
 /* Allocate a block of memory from the mark and sweep GC heap */
 F_BLOCK *heap_allot(F_HEAP *heap, CELL size)
 {
-	F_FREE_BLOCK *prev = NULL;
+	size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
-	F_FREE_BLOCK *scan = heap->free_list;
 
-	size = (size + 31) & ~31;
+	F_FREE_BLOCK *block = find_free_block(heap,size);
-
+	if(block)
-	while(scan)
 	{
-		if(scan->block.status != B_FREE)
+		block = split_free_block(heap,block,size);
-			critical_error("Invalid block in free list",(CELL)scan);
 
-		if(scan->block.size < size)
+		block->block.status = B_ALLOCATED;
-		{
+		return &block->block;
-			prev = scan;
-			scan = scan->next_free;
-			continue;
-		}
-
-		/* we found a candidate block */
-		F_FREE_BLOCK *next_free;
-
-		if(scan->block.size - size <= sizeof(F_BLOCK) * 2)
-		{
-			/* too small to be split */
-			next_free = scan->next_free;
-		}
-		else
-		{
-			/* split the block in two */
-			F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size);
-			split->block.status = B_FREE;
-			split->block.size = scan->block.size - size;
-			split->next_free = scan->next_free;
-			scan->block.size = size;
-			next_free = split;
-		}
-
-		/* update the free list */
-		update_free_list(heap,prev,next_free);
-
-		/* this is our new block */
-		scan->block.status = B_ALLOCATED;
-		return &scan->block;
 	}
-
+	else
-	return NULL;
+		return NULL;
 }
 
 void mark_block(F_BLOCK *block)
@@ -162,8 +200,10 @@ void unmark_marked(F_HEAP *heap)
 
 /* After code GC, all referenced code blocks have status set to B_MARKED, so any
 which are allocated and not marked can be reclaimed. */
-void free_unmarked(F_HEAP *heap)
+void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter)
 {
+	clear_free_list(heap);
+
 	F_BLOCK *prev = NULL;
 	F_BLOCK *scan = first_block(heap);
 
@@ -183,10 +223,15 @@ void free_unmarked(F_HEAP *heap)
 		case B_FREE:
 			if(prev && prev->status == B_FREE)
 				prev->size += scan->size;
+			else
+				prev = scan;
 			break;
 		case B_MARKED:
+			if(prev && prev->status == B_FREE)
+				add_to_free_list(heap,(F_FREE_BLOCK *)prev);
 			scan->status = B_ALLOCATED;
 			prev = scan;
+			iter(scan);
 			break;
 		default:
 			critical_error("Invalid scan->status",(CELL)scan);
@@ -195,7 +240,8 @@ void free_unmarked(F_HEAP *heap)
 		scan = next_block(heap,scan);
 	}
 
-	build_free_list(heap,heap->segment->size);
+	if(prev && prev->status == B_FREE)
+		add_to_free_list(heap,(F_FREE_BLOCK *)prev);
 }
 
 /* Compute total sum of sizes of free blocks, and size of largest free block */

vm/code_gc.h

@@ -1,14 +1,24 @@
+#define FREE_LIST_COUNT 16
+#define BLOCK_SIZE_INCREMENT 32
+
+typedef struct {
+	F_FREE_BLOCK *small[FREE_LIST_COUNT];
+	F_FREE_BLOCK *large;
+} F_HEAP_FREE_LIST;
+
 typedef struct {
 	F_SEGMENT *segment;
-	F_FREE_BLOCK *free_list;
+	F_HEAP_FREE_LIST free;
 } F_HEAP;
 
+typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled);
+
 void new_heap(F_HEAP *heap, CELL size);
 void build_free_list(F_HEAP *heap, CELL size);
 F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
 void mark_block(F_BLOCK *block);
 void unmark_marked(F_HEAP *heap);
-void free_unmarked(F_HEAP *heap);
+void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter);
 void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
 CELL heap_size(F_HEAP *heap);
 CELL compute_heap_forwarding(F_HEAP *heap);

vm/data_gc.c

@@ -416,13 +416,6 @@ void end_gc(CELL gc_elapsed)
 		reset_generations(NURSERY,collecting_gen);
 	}
 
-	if(collecting_gen == TENURED)
-	{
-		/* now that all reachable code blocks have been marked,
-		deallocate the rest */
-		free_unmarked(&code_heap);
-	}
-
 	collecting_aging_again = false;
 }
 
@@ -491,7 +484,7 @@ void garbage_collection(CELL gen,
 		code_heap_scans++;
 
 		if(collecting_gen == TENURED)
-			update_code_heap_roots();
+			free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_references);
 		else
 			copy_code_heap_roots();