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

core/bootstrap/ui/tools/tools.factor

@@ -1,4 +1,4 @@
-USING: kernel vocabs vocabs.loader sequences ;
+USING: kernel vocabs vocabs.loader sequences system ;
 
 { "ui" "help" "tools" }
 [ "bootstrap." swap append vocab ] all? [
@@ -8,3 +8,5 @@ USING: kernel vocabs vocabs.loader sequences ;
         "ui.cocoa.tools" require
     ] when
 ] when
+
+macosx? [ "ui.tools.deploy" require ] when

core/bootstrap/ui/ui.factor

@@ -12,5 +12,3 @@ vocabs vocabs.loader ;
 
     "ui.freetype" require
 ] when
-
-macosx? [ "ui.tools.deploy" require ] when

core/cpu/arm/architecture/architecture.factor

@@ -278,7 +278,7 @@ M: arm-backend %alien-indirect ( -- )
 
 M: arm-backend %alien-callback ( quot -- )
     R0 load-indirect
-    "run_callback" f %alien-invoke ;
+    "c_to_factor" f %alien-invoke ;
 
 M: arm-backend %callback-value ( ctype -- )
     ! Save top of data stack

core/cpu/arm/arm.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types kernel math namespaces
 cpu.architecture cpu.arm.architecture cpu.arm.assembler
 cpu.arm.intrinsics generator generator.registers continuations
-compiler io vocabs.loader sequences ;
+compiler io vocabs.loader sequences system ;
 
 ! EABI passes floats in integer registers.
 [ alien-float ]
@@ -53,4 +53,4 @@ T{ arm-backend } compiler-backend set-global
     t have-BLX? set-global
 ] when
 
-7 cells set-profiler-prologue
+7 cells set-profiler-prologues

core/heaps/heaps-tests.factor

@@ -0,0 +1,32 @@
+! Copyright 2007 Ryan Murphy
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel math tools.test heaps heaps.private ;
+IN: temporary
+
+[ <min-heap> pop-heap ] unit-test-fails
+[ <max-heap> pop-heap ] unit-test-fails
+
+[ t ] [ <min-heap> heap-empty? ] unit-test
+[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
+[ t ] [ <max-heap> heap-empty? ] unit-test
+[ f ] [ <max-heap> 1 over push-heap heap-empty? ] unit-test
+
+! Binary Min Heap
+{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
+{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test
+{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
+
+[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
+[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test
+
+[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
+    <min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
+    3 [ dup pop-heap* ] times
+] unit-test
+
+[ 2 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test
+
+[ 1 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
+
+[ 400 ] [ <max-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test

core/heaps/heaps.factor

@@ -0,0 +1,112 @@
+! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: heaps
+
+<PRIVATE
+TUPLE: heap data ;
+
+: <heap> ( -- obj )
+    V{ } clone heap construct-boa ;
+PRIVATE>
+
+TUPLE: min-heap ;
+
+: <min-heap> ( -- obj )
+    <heap> min-heap construct-delegate ;
+
+TUPLE: max-heap ;
+
+: <max-heap> ( -- obj )
+    <heap> max-heap construct-delegate ;
+
+<PRIVATE
+: left ( n -- m ) 2 * 1+ ;
+: right ( n -- m ) 2 * 2 + ;
+: up ( n -- m ) 1- 2 /i ;
+: left-value ( n heap -- obj ) >r left r> nth ;
+: right-value ( n heap -- obj ) >r right r> nth ;
+: up-value ( n vec -- obj ) >r up r> nth ;
+: swap-up ( n vec -- ) >r dup up r> exchange ;
+: last-index ( vec -- n ) length 1- ;
+
+GENERIC: heap-compare ( obj1 obj2 heap -- ? )
+
+M: min-heap heap-compare drop <=> 0 > ;
+M: max-heap heap-compare drop <=> 0 < ;
+
+: left-bounds-check? ( m heap -- ? )
+    >r left r> heap-data length >= ;
+
+: right-bounds-check? ( m heap -- ? )
+    >r right r> heap-data length >= ;
+
+: (up-heap) ( vec heap -- )
+    [
+        >r [ last-index ] keep [ up-value ] keep peek r> heap-compare
+    ] 2keep rot [
+        >r dup last-index
+        [ over swap-up ] keep
+        up 1+ head-slice
+        r> (up-heap)
+    ] [
+        2drop
+    ] if ;
+
+: up-heap ( heap -- )
+    [ heap-data ] keep (up-heap) ;
+
+: child ( m heap -- n )
+    2dup right-bounds-check? [
+        drop left
+    ] [
+        dupd
+        [ heap-data left-value ] 2keep
+        [ heap-data right-value ] keep heap-compare [
+            right
+        ] [
+            left
+        ] if
+    ] if ;
+
+: swap-down ( m heap -- )
+    [ child ] 2keep heap-data exchange ;
+
+DEFER: down-heap
+
+: (down-heap) ( m heap -- )
+    2dup [ heap-data nth ] 2keep child pick
+    dupd [ heap-data nth swapd ] keep
+    heap-compare [
+        -rot [ swap-down ] keep down-heap
+    ] [
+        3drop
+    ] if ;
+
+: down-heap ( m heap -- )
+    2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
+
+PRIVATE>
+
+: push-heap ( obj heap -- )
+    tuck heap-data push up-heap ;
+
+: push-heap* ( seq heap -- )
+    swap [ swap push-heap ] curry* each ;
+
+: peek-heap ( heap -- obj )
+    heap-data first ;
+
+: pop-heap* ( heap -- )
+    dup heap-data length 1 > [
+        [ heap-data pop 0 ] keep
+        [ heap-data set-nth ] keep
+        >r 0 r> down-heap
+    ] [
+        heap-data pop*
+    ] if ;
+
+: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
+
+: heap-empty? ( heap -- ? )
+    heap-data empty? ;

core/memory/memory.factor

@@ -16,29 +16,3 @@ math strings combinators ;
     pusher >r each-object r> >array ; inline
 
 : save ( -- ) image save-image ;
-
-<PRIVATE
-
-: intern-objects ( predicate -- )
-    instances
-    dup H{ } clone [ [ ] cache ] curry map
-    become ; inline
-
-: prepare-compress-image ( -- seq )
-    [ sbuf? ] instances [ underlying ] map ;
-
-PRIVATE>
-
-: compress-image ( -- )
-    prepare-compress-image "bad-strings" [
-        [
-            {
-                { [ dup quotation? ] [ t ] }
-                { [ dup wrapper? ] [ t ] }
-                { [ dup fixnum? ] [ f ] }
-                { [ dup number? ] [ t ] }
-                { [ dup string? ] [ dup "bad-strings" get memq? not ] }
-                { [ t ] [ f ] }
-            } cond nip
-        ] intern-objects
-    ] with-variable ;

core/optimizer/known-words/known-words.factor

@@ -5,7 +5,7 @@ USING: alien arrays generic hashtables inference.dataflow
 inference.class kernel assocs math math.private kernel.private
 sequences words parser vectors strings sbufs io namespaces
 assocs quotations sequences.private io.binary io.crc32
-io.buffers io.streams.string layouts splitting math.intervals
+io.streams.string layouts splitting math.intervals
 math.floats.private tuples tuples.private classes
 optimizer.def-use optimizer.backend optimizer.pattern-match
 float-arrays combinators.private ;
@@ -148,5 +148,3 @@ float-arrays combinators.private ;
 \ >le { { fixnum bignum } fixnum } "specializer" set-word-prop
 
 \ >be { { fixnum bignum } fixnum } "specializer" set-word-prop
-
-\ search-buffer-until { fixnum fixnum simple-alien string } "specializer" set-word-prop

core/threads/threads.factor

@@ -2,7 +2,7 @@
 ! Copyright (C) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: threads
-USING: arrays init hashtables io.backend kernel kernel.private
+USING: arrays init hashtables heaps io.backend kernel kernel.private
 math namespaces queues sequences vectors io system sorting
 continuations debugger ;
 
@@ -10,21 +10,22 @@ continuations debugger ;
 
 SYMBOL: sleep-queue
 
+TUPLE: sleeping ms continuation ;
+
+M: sleeping <=> ( obj1 obj2 -- n )
+    [ sleeping-ms ] 2apply - ;
+
 : sleep-time ( -- ms )
     sleep-queue get-global
-    dup empty? [ drop 1000 ] [ first first millis [-] ] if ;
+    dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ;
 
 : run-queue ( -- queue ) \ run-queue get-global ;
 
 : schedule-sleep ( ms continuation -- )
-    2array global [
+    sleeping construct-boa sleep-queue get-global push-heap ;
-        sleep-queue [ swap add sort-keys ] change
-    ] bind ;
 
 : wake-up ( -- continuation )
-    global [
+    sleep-queue get-global pop-heap sleeping-continuation ;
-        sleep-queue [ unclip second swap ] change
-    ] bind ;
 
 PRIVATE>
 
@@ -67,9 +68,8 @@ PRIVATE>
 
 : init-threads ( -- )
     <queue> \ run-queue set-global
-    f sleep-queue set-global
+    <min-heap> sleep-queue set-global
     [ idle-thread ] in-thread ;
 
 [ init-threads ] "threads" add-init-hook
-
 PRIVATE>

extra/calendar/calendar-tests.factor

@@ -126,16 +126,16 @@ continuations system ;
         2004 1 1 13 30 0 0 make-timestamp = ] unit-test
 
 [ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp
-        2004 1 1 12 30 0 -1 make-timestamp compare-timestamps ] unit-test
+        2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test
 
 [ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp
-        2004 1 1 12 30 0 0 make-timestamp compare-timestamps ] unit-test
+        2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test
 
 [ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp
-        2004 1 1 13 30 0 0 make-timestamp compare-timestamps ] unit-test
+        2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
 
 [ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp
-        2004 1 1 13 30 0 0 make-timestamp compare-timestamps ] unit-test
+        2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test
 
 [ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test
 [ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test

extra/calendar/calendar.factor

@@ -205,7 +205,7 @@ M: number +second ( timestamp n -- timestamp )
 : >gmt ( timestamp -- timestamp )
     0 convert-timezone ;
 
-: compare-timestamps ( tuple tuple -- n )
+M: timestamp <=> ( ts1 ts2 -- n )
     [ >gmt tuple-slots ] compare ;
 
 : timestamp- ( timestamp timestamp -- seconds )

extra/concurrency/concurrency.factor

@@ -5,11 +5,20 @@
 ! concurrency.
 USING: vectors dlists threads sequences continuations
        namespaces random math quotations words kernel match
-       arrays io assocs init ;
+       arrays io assocs init shuffle system ;
 IN: concurrency
 
 TUPLE: mailbox threads data ;
 
+TUPLE: thread timeout continuation continued? ;
+
+: <thread> ( timeout continuation -- obj )
+    >r dup [ millis + ] when r>
+    {
+        set-thread-timeout
+        set-thread-continuation
+    } thread construct ;
+
 : make-mailbox ( -- mailbox )
     V{ } clone <dlist> mailbox construct-boa ;
 
@@ -18,34 +27,44 @@ TUPLE: mailbox threads data ;
 
 : mailbox-put ( obj mailbox -- )
     [ mailbox-data dlist-push-end ] keep
-    [ mailbox-threads ] keep 0 <vector> swap set-mailbox-threads
+    [ mailbox-threads ] keep
-    [ schedule-thread ] each yield ;
+    V{ } clone swap set-mailbox-threads
+    [ thread-continuation schedule-thread ] each yield ;
 
 <PRIVATE
-: (mailbox-block-unless-pred) ( pred mailbox -- )
+: (mailbox-block-unless-pred) ( pred mailbox timeout -- )
-    2dup mailbox-data dlist-contains? [
+    2over mailbox-data dlist-contains? [
-        2drop
+        3drop
     ] [
-        [ swap mailbox-threads push stop ] callcc0
+        [ <thread> swap mailbox-threads push stop ] callcc0
         (mailbox-block-unless-pred)
     ] if ; inline
 
-: (mailbox-block-if-empty) ( mailbox -- mailbox2 )
+: (mailbox-block-if-empty) ( mailbox timeout -- mailbox2 )
-    dup mailbox-empty? [
+    over mailbox-empty? [
-        [ swap mailbox-threads push stop ] callcc0
+        [ <thread> swap mailbox-threads push stop ] callcc0
+        "(mailbox-block-if-empty)" print flush
         (mailbox-block-if-empty)
-    ] when ;
+    ] [
+        drop
+    ] if ;
 PRIVATE>
-: mailbox-get ( mailbox -- obj )
+: mailbox-get* ( mailbox timeout -- obj )
     (mailbox-block-if-empty)
     mailbox-data dlist-pop-front ;
 
-: mailbox-get-all ( mailbox -- array )
+: mailbox-get ( mailbox -- obj )
+    f mailbox-get* ;
+
+: mailbox-get-all* ( mailbox timeout -- array )
     (mailbox-block-if-empty)
     [ dup mailbox-empty? ]
     [ dup mailbox-data dlist-pop-front ]
     { } unfold ;
 
+: mailbox-get-all ( mailbox -- array )
+    f mailbox-get-all* ;
+
 : while-mailbox-empty ( mailbox quot -- )
     over mailbox-empty? [
         dup >r swap slip r> while-mailbox-empty
@@ -53,10 +72,12 @@ PRIVATE>
         2drop
     ] if ; inline
 
+: mailbox-get?* ( pred mailbox timeout -- obj )
+    2over >r >r (mailbox-block-unless-pred) r> r>
+    mailbox-data dlist-remove ; inline
+
 : mailbox-get? ( pred mailbox -- obj )
-    2dup (mailbox-block-unless-pred)
+    f mailbox-get?* ;
-    mailbox-data dlist-remove ;
-    inline
 
 TUPLE: process links pid mailbox ;
 
@@ -64,9 +85,7 @@ C: <process> process
 
 GENERIC: send ( message process -- )
 
-: random-64 ( -- id )
+: random-pid ( -- id ) 8 big-random ;
-    #! Generate a random id to use for pids
-    "ID" 64 [ drop 10 random CHAR: 0 + ] map append ;
 
 <PRIVATE
 : make-process ( -- process )
@@ -74,13 +93,13 @@ GENERIC: send ( message process -- )
     #! similar to a thread but can send and receive messages to and
     #! from other processes. It may also be linked to other processes so
     #! that it receives a message if that process terminates.
-    [ ] random-64 make-mailbox <process> ;
+    [ ] random-pid make-mailbox <process> ;
 
 : make-linked-process ( process -- process )
     #! Return a process set to run on the local node. That process is
     #! linked to the process on the stack. It will receive a message if
     #! that process terminates.
-    1quotation random-64 make-mailbox <process> ;
+    1quotation random-pid make-mailbox <process> ;
 PRIVATE>
 
 : self ( -- process )
@@ -187,7 +206,7 @@ MATCH-VARS: ?from ?tag ;
 <PRIVATE
 : tag-message ( message -- tagged-message )
     #! Given a message, wrap it with the sending process and a unique tag.
-    >r self random-64 r> 3array ;
+    >r self random-pid r> 3array ;
 PRIVATE>
 
 : send-synchronous ( message process -- reply )
@@ -286,23 +305,29 @@ TUPLE: promise fulfilled? value processes ;
         [ set-promise-value ] keep
         [ t swap set-promise-fulfilled? ] keep
         [ promise-processes ] keep
-        0 <vector> swap set-promise-processes
+        V{ } clone swap set-promise-processes
-        [ schedule-thread ] each yield
+        [ thread-continuation schedule-thread ] each yield
     ] if ;
 
 <PRIVATE
- : (maybe-block-promise) ( promise -- promise )
+ : (maybe-block-promise) ( promise timeout -- promise )
     #! Block the process if the promise is unfulfilled. This is different from
     #! (mailbox-block-if-empty) in that when a promise is fulfilled, all threads
     #! need to be resumed, rather than just one.
-    dup promise-fulfilled? [
+    over promise-fulfilled? [
-        [ swap promise-processes push stop ] callcc0
+        drop
-    ] unless ;
+    ] [
+        [ <thread> swap promise-processes push stop ] callcc0
+        drop
+    ] if ;
 PRIVATE>
 
-: ?promise ( promise -- result )
+: ?promise* ( promise timeout -- result )
     (maybe-block-promise) promise-value ;
 
+: ?promise ( promise -- result )
+    f ?promise* ;
+
 ! ******************************
 ! Experimental code below
 ! ******************************

extra/heaps/heaps-tests.factor

@@ -0,0 +1,32 @@
+! Copyright 2007 Ryan Murphy
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel math tools.test heaps heaps.private ;
+IN: temporary
+
+[ <min-heap> pop-heap ] unit-test-fails
+[ <max-heap> pop-heap ] unit-test-fails
+
+[ t ] [ <min-heap> heap-empty? ] unit-test
+[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
+[ t ] [ <max-heap> heap-empty? ] unit-test
+[ f ] [ <max-heap> 1 over push-heap heap-empty? ] unit-test
+
+! Binary Min Heap
+{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
+{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test
+{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
+
+[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
+[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test
+
+[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
+    <min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
+    3 [ dup pop-heap* ] times
+] unit-test
+
+[ 2 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test
+
+[ 1 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
+
+[ 400 ] [ <max-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test

extra/heaps/heaps.factor

@@ -0,0 +1,112 @@
+! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: heaps
+
+<PRIVATE
+TUPLE: heap data ;
+
+: <heap> ( -- obj )
+    V{ } clone heap construct-boa ;
+PRIVATE>
+
+TUPLE: min-heap ;
+
+: <min-heap> ( -- obj )
+    <heap> min-heap construct-delegate ;
+
+TUPLE: max-heap ;
+
+: <max-heap> ( -- obj )
+    <heap> max-heap construct-delegate ;
+
+<PRIVATE
+: left ( n -- m ) 2 * 1+ ;
+: right ( n -- m ) 2 * 2 + ;
+: up ( n -- m ) 1- 2 /i ;
+: left-value ( n heap -- obj ) >r left r> nth ;
+: right-value ( n heap -- obj ) >r right r> nth ;
+: up-value ( n vec -- obj ) >r up r> nth ;
+: swap-up ( n vec -- ) >r dup up r> exchange ;
+: last-index ( vec -- n ) length 1- ;
+
+GENERIC: heap-compare ( obj1 obj2 heap -- ? )
+
+M: min-heap heap-compare drop <=> 0 > ;
+M: max-heap heap-compare drop <=> 0 < ;
+
+: left-bounds-check? ( m heap -- ? )
+    >r left r> heap-data length >= ;
+
+: right-bounds-check? ( m heap -- ? )
+    >r right r> heap-data length >= ;
+
+: (up-heap) ( vec heap -- )
+    [
+        >r [ last-index ] keep [ up-value ] keep peek r> heap-compare
+    ] 2keep rot [
+        >r dup last-index
+        [ over swap-up ] keep
+        up 1+ head-slice
+        r> (up-heap)
+    ] [
+        2drop
+    ] if ;
+
+: up-heap ( heap -- )
+    [ heap-data ] keep (up-heap) ;
+
+: child ( m heap -- n )
+    2dup right-bounds-check? [
+        drop left
+    ] [
+        dupd
+        [ heap-data left-value ] 2keep
+        [ heap-data right-value ] keep heap-compare [
+            right
+        ] [
+            left
+        ] if
+    ] if ;
+
+: swap-down ( m heap -- )
+    [ child ] 2keep heap-data exchange ;
+
+DEFER: down-heap
+
+: (down-heap) ( m heap -- )
+    2dup [ heap-data nth ] 2keep child pick
+    dupd [ heap-data nth swapd ] keep
+    heap-compare [
+        -rot [ swap-down ] keep down-heap
+    ] [
+        3drop
+    ] if ;
+
+: down-heap ( m heap -- )
+    2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
+
+PRIVATE>
+
+: push-heap ( obj heap -- )
+    tuck heap-data push up-heap ;
+
+: push-heap* ( seq heap -- )
+    swap [ swap push-heap ] curry* each ;
+
+: peek-heap ( heap -- obj )
+    heap-data first ;
+
+: pop-heap* ( heap -- )
+    dup heap-data length 1 > [
+        [ heap-data pop 0 ] keep
+        [ heap-data set-nth ] keep
+        >r 0 r> down-heap
+    ] [
+        heap-data pop*
+    ] if ;
+
+: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
+
+: heap-empty? ( heap -- ? )
+    heap-data empty? ;

extra/http/server/responders/callback/callback.factor

@@ -2,8 +2,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: html http http.server.responders io kernel math namespaces
-continuations random system sequences assocs ;
+prettyprint continuations random system sequences assocs ;
-
 IN: http.server.responders.callback
 
 #! Name of the variable holding the continuation used to exit
@@ -58,7 +57,7 @@ TUPLE: request stream exitcc method url raw-query query header response ;
 
 : get-random-id ( -- id ) 
     #! Generate a random id to use for continuation URL's
-    "ID" 32 [ drop 9 random CHAR: 0 + ] map append ;
+    4 big-random unparse ;
 
 : callback-table ( -- <hashtable> ) 
     #! Return the global table of continuations

extra/io/buffers/buffers.factor

@@ -3,7 +3,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.buffers
 USING: alien alien.syntax kernel kernel.private libc math
-sequences strings ;
+sequences strings hints ;
 
 TUPLE: buffer size ptr fill pos ;
 
@@ -54,6 +54,8 @@ TUPLE: buffer size ptr fill pos ;
 : search-buffer-until ( start end alien separators -- n )
     [ >r swap alien-unsigned-1 r> memq? ] 2curry find* drop ;
 
+HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
+
 : finish-buffer-until ( buffer n -- string separator )
     [
         over buffer-pos -

extra/roman/roman-tests.factor

@@ -1,9 +1,5 @@
 USING: arrays kernel math roman roman.private sequences tools.test ;
 
-[ { { 1 } { -1 5 } { 2 4 } } ]
-[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
-[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
-[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
 [ "i" ] [ 1 >roman ] unit-test
 [ "ii" ] [ 2 >roman ] unit-test
 [ "iii" ] [ 3 >roman ] unit-test

extra/roman/roman.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: arrays assocs kernel math math.vectors namespaces
-quotations sequences sequences.private strings ;
+quotations sequences sequences.lib sequences.private strings ;
 IN: roman
 
 <PRIVATE
@@ -22,16 +22,6 @@ TUPLE: roman-range-error n ;
         roman-range-error construct-boa throw
     ] if ;
 
-: ,, building get peek push ;
-: v, V{ } clone , ;
-: ,v building get dup peek empty? [ dup pop* ] when drop ;
-
-: monotonic-split ( seq quot -- newseq )
-    [
-        >r dup unclip add r>
-        v, [ pick ,, call [ v, ] unless ] curry 2each ,v
-    ] { } make ;
-
 : roman<= ( ch1 ch2 -- ? )
     [ 1string roman-digits index ] 2apply >= ;
 

extra/sequences/lib/lib-tests.factor

@@ -1,4 +1,5 @@
-USING: kernel sequences.lib math math.functions tools.test ;
+USING: arrays kernel sequences sequences.lib math
+math.functions tools.test ;
 
 [ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
 [ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@@ -28,3 +29,7 @@ USING: kernel sequences.lib math math.functions tools.test ;
 [ -11 -9 ] [ { -11 -10 -9 } minmax ] unit-test
 [ -1/0. 1/0. ] [ { -1/0. 1/0. -11 -10 -9 } minmax ] unit-test
 
+[ { { 1 } { -1 5 } { 2 4 } } ]
+[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
+[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
+[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test

extra/sequences/lib/lib.factor

@@ -1,4 +1,4 @@
-USING: combinators.lib kernel sequences math
+USING: combinators.lib kernel sequences math namespaces
 sequences.private shuffle ;
 
 IN: sequences.lib
@@ -46,3 +46,18 @@ IN: sequences.lib
     #! find the min and max of a seq in one pass
     1/0. -1/0. rot [ tuck max >r min r> ] each ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ,, building get peek push ;
+: v, V{ } clone , ;
+: ,v building get dup peek empty? [ dup pop* ] when drop ;
+
+: monotonic-split ( seq quot -- newseq )
+    [
+        >r dup unclip add r>
+        v, [ pick ,, call [ v, ] unless ] curry 2each ,v
+    ] { } make ;
+
+: singleton? ( seq -- ? )
+    length 1 = ;
+

extra/store/store-tests.factor

@@ -0,0 +1,41 @@
+USING: assocs continuations debugger io.files kernel
+namespaces store tools.test ;
+IN: temporary
+
+SYMBOL: store
+SYMBOL: foo
+SYMBOL: bar
+
+
+: the-store ( -- path )
+    "store-test.store" resource-path ;
+
+: delete-the-store ( -- )
+    [ the-store delete-file ] catch drop ;
+
+: load-the-store ( -- )
+    the-store load-store store set ;
+
+: save-the-store ( -- )
+    store get save-store ;
+
+delete-the-store
+the-store load-store store set
+
+[ f ] [ foo store get store-data at ] unit-test
+
+[ ] [ 100 foo store get store-variable ] unit-test
+
+[ ] [ save-the-store ] unit-test
+
+[ 100 ] [ foo store get store-data at ] unit-test
+
+1000 foo set
+
+[ ] [ save-the-store ] unit-test
+
+[ ] [ load-the-store ] unit-test
+
+[ 1000 ] [ foo store get store-data at ] unit-test
+
+delete-the-store

extra/store/store.factor

@@ -11,12 +11,12 @@ C: <store> store
     [ store-data ] keep store-path <file-writer> [
         [
             dup
-            [ drop [ get ] keep rot set-at ] curry* assoc-each
+            [ >r drop [ get ] keep r> set-at ] curry assoc-each
         ] keep serialize
     ] with-stream ;
 
 : load-store ( path -- store )
-    resource-path dup exists? [
+    dup exists? [
         dup <file-reader> [
             deserialize
         ] with-stream
@@ -30,4 +30,3 @@ C: <store> store
     ] [
         drop >r 2dup set-global r> set-at
     ] if ;
-

extra/tools/deploy/config/config.factor

@@ -17,7 +17,7 @@ SYMBOL: deploy-io
         { 3 "Level 3 - Non-blocking streams and networking" }
     } ;
 
-: strip-io? deploy-io get zero? ;
+: strip-io? deploy-io get 1 = ;
 
 : native-io? deploy-io get 3 = ;
 

extra/tools/deploy/deploy.factor

@@ -37,8 +37,8 @@ IN: tools.deploy
         ""
         deploy-math? get " math" ?append
         deploy-compiler? get " compiler" ?append
-        native-io? " io" ?append
         deploy-ui? get " ui" ?append
+        native-io? " io" ?append
     ] bind ;
 
 : deploy-command-line ( vm image vocab config -- vm flags )
@@ -49,7 +49,7 @@ IN: tools.deploy
 
         "\"-output-image=" swap "\"" 3append ,
 
-        "-no-stack-traces" ,
+        ! "-no-stack-traces" ,
         
         "-no-user-init" ,
     ] { } make ;

extra/tools/deploy/shaker/shaker.factor

@@ -5,7 +5,7 @@ assocs kernel vocabs words sequences memory io system arrays
 continuations math definitions mirrors splitting parser classes
 inspector layouts vocabs.loader prettyprint.config prettyprint
 debugger io.streams.c io.streams.duplex io.files io.backend
-quotations words.private tools.deploy.config ;
+quotations words.private tools.deploy.config compiler ;
 IN: tools.deploy.shaker
 
 : show ( msg -- )
@@ -23,6 +23,15 @@ IN: tools.deploy.shaker
         "Stripping debugger" show
         "resource:extra/tools/deploy/shaker/strip-debugger.factor"
         run-file
+        recompile
+    ] when ;
+
+: strip-libc ( -- )
+    "libc" vocab [
+        "Stripping manual memory management debug code" show
+        "resource:extra/tools/deploy/shaker/strip-libc.factor"
+        run-file
+        recompile
     ] when ;
 
 : strip-cocoa ( -- )
@@ -30,6 +39,7 @@ IN: tools.deploy.shaker
         "Stripping unused Cocoa methods" show
         "resource:extra/tools/deploy/shaker/strip-cocoa.factor"
         run-file
+        recompile
     ] when ;
 
 : strip-assoc ( retained-keys assoc -- newassoc )
@@ -70,8 +80,8 @@ IN: tools.deploy.shaker
     strip-word-defs ;
 
 : strip-environment ( retain-globals -- )
-    "Stripping environment" show
     strip-globals? [
+        "Stripping environment" show
         global strip-assoc 21 setenv
     ] [ drop ] if ;
 
@@ -126,7 +136,7 @@ SYMBOL: deploy-vocab
             } %
         ] unless
 
-        deploy-c-types? get deploy-ui? get or [
+        deploy-c-types? get [
             "c-types" "alien.c-types" lookup ,
         ] when
 
@@ -141,6 +151,7 @@ SYMBOL: deploy-vocab
     ] { } make dup . ;
 
 : strip ( -- )
+    strip-libc
     strip-cocoa
     strip-debugger
     strip-init-hooks
@@ -160,8 +171,6 @@ SYMBOL: deploy-vocab
             deploy-vocab get require
             r> [ call ] when*
             strip
-            "Compressing image" show
-            compress-image
             finish-deploy
         ] [
             print-error flush 1 exit

extra/tools/deploy/shaker/strip-libc.factor

@@ -0,0 +1,8 @@
+USING: libc.private ;
+IN: libc
+
+: malloc (malloc) ;
+
+: free (free) ;
+
+: realloc (realloc) ;

extra/ui/gadgets/buttons/buttons.factor

@@ -4,7 +4,8 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.borders
 ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
 ui.render kernel math models namespaces sequences strings
-quotations assocs combinators classes colors tuples ;
+quotations assocs combinators classes colors tuples opengl
+math.vectors ;
 IN: ui.gadgets.buttons
 
 TUPLE: button pressed? selected? quot ;
@@ -95,6 +96,18 @@ repeat-button H{
     repeat-button construct-empty
     [ >r <bevel-button> r> set-gadget-delegate ] keep ;
 
+TUPLE: checkmark-paint color ;
+
+C: <checkmark-paint> checkmark-paint
+
+M: checkmark-paint draw-interior
+    checkmark-paint-color gl-color
+    origin get [
+        rect-dim
+        { 0 0 } over gl-line
+        dup { 0 1 } v* swap { 1 0 } v* gl-line
+    ] with-translation ;
+
 : checkmark-theme ( gadget -- )
     f
     f
@@ -125,6 +138,18 @@ repeat-button H{
     [ set-button-selected? ] <control>
     dup checkbox-theme ;
 
+TUPLE: radio-paint color ;
+
+C: <radio-paint> radio-paint
+
+M: radio-paint draw-interior
+    radio-paint-color gl-color
+    origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
+
+M: radio-paint draw-boundary
+    radio-paint-color gl-color
+    origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
+
 : radio-knob-theme ( gadget -- )
     f
     f

extra/ui/render/render.factor

@@ -140,32 +140,6 @@ M: polygon draw-interior
     >r <polygon> <gadget> r> over set-rect-dim
     [ set-gadget-interior ] keep ;
 
-! Checkbox and radio button pens
-TUPLE: checkmark-paint color ;
-
-C: <checkmark-paint> checkmark-paint
-
-M: checkmark-paint draw-interior
-    checkmark-paint-color gl-color
-    origin get [
-        rect-dim
-        { 0 0 } over gl-line
-        dup { 0 1 } v* swap { 1 0 } v* gl-line
-    ] with-translation ;
-
-
-TUPLE: radio-paint color ;
-
-C: <radio-paint> radio-paint
-
-M: radio-paint draw-interior
-    radio-paint-color gl-color
-    origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
-
-M: radio-paint draw-boundary
-    radio-paint-color gl-color
-    origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
-
 ! Font rendering
 SYMBOL: font-renderer
 

unmaintained/heap/heap.factor

@@ -1,74 +0,0 @@
-! Binary Min Heap
-! Copyright 2007 Ryan Murphy
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel math sequences ;
-IN: heap
-
-: [comp] ( elt elt -- ? ) <=> 0 > ;
-
-: <heap> ( -- heap ) V{ } clone ;
-
-: left ( index -- index ) ! left child
-    2 * 1 + ;
-
-: leftv ( heap index -- value )
-    left swap nth ;
-
-: right ( index -- index ) ! right child
-    2 * 2 + ;
-
-: rightv ( heap index -- value )
-    right swap nth ;
-
-: l-oob ( i heap -- ? ) swap left swap length >= ;
-: r-oob ( i heap -- ? ) swap right swap length >= ;
-
-: up ( index -- index ) ! parent node
-    1 -  2 /i ;
-
-: upv ( heap index -- value ) ! parent's value
-    up swap nth ;
-
-: lasti ( seq -- index ) length 1 - ;
-
-: swapup ( heap index -- ) dup up rot exchange ;
-
-: (farchild) ( heap index -- index ) tuck 2dup leftv -rot rightv [comp] [ right ] [ left ] if ;
-
-: farchild ( heap index -- index ) dup right pick length >= [ nip left ] [ (farchild) ] if ;
-
-: farchildv ( heap index -- value ) dupd farchild swap nth ;
-
-: swapdown ( heap index -- ) 2dup farchild rot exchange ;
-
-: upheap ( heap -- )
-    dup dup lasti upv over peek [comp]
-    [ dup lasti 2dup swapup up 1 + head-slice upheap ] [ drop ] if ;
-
-: add ( elt heap -- )
-    tuck push upheap ;
-
-: add-many ( seq heap -- )
-    swap [ swap add ] each-with ;
-
-DEFER: (downheap)
-
-: (downheap2) ( i heap -- )
-    2dup nth -rot
-    2dup swap farchild dup pick nth 2swap
-    >r >r
-    swapd [comp]
-    [ r> r> tuck swap swapdown (downheap) ] [ drop r> r> 2drop ] if ;
-
-: (downheap) ( i heap -- )
-    over left over length >= [ 2drop ] [ (downheap2) ] if ;
-
-: downheap ( heap -- )
-    0 swap (downheap) ;
-
-: bump ( heap -- )
-    dup peek 0 pick set-nth dup pop* downheap ;
-
-: gbump ( heap -- first )
-    dup first swap bump ;

unmaintained/heap/heap.facts

@@ -1,76 +0,0 @@
-! Binary Min Heap
-! Copyright 2007 Ryan Murphy
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: help heap sequences ;
-
-ARTICLE: { "heap" "heap" } "Binary Min Heap"
-"A vector-based implementation of a binary min heap.  Elements are simply stored in a vector, so use " { $link first } " to access the root of the heap."
-{ $subsection <heap> }
-{ $subsection add }
-{ $subsection add-many }
-{ $subsection bump }
-{ $subsection gbump }
-{ $subsection print-heap }
-;
-
-HELP: <heap>
-"Creates a new heap with nothing on it." ;
-
-HELP: add
-"Adds 1 element to the heap."
-{ $examples
-  { $code
-    "USE: heap"
-    "<heap> 3 over add 4 over add 5 over add"
-    "print-heap"
-  }
-}
-;
-
-HELP: add-many
-"For each element in the sequence, add it to the heap."
-{ $examples
-  { $code
-    "USE: heap"
-    "<heap> { 7 6 5 4 3 2 1 } over add-many"
-    "print-heap"
-  }
-}
-;
-
-HELP: bump
-"\"Bumps\" the root element off of the heap, rearranging the remaining elements so that the heap remains valid."
-{ $examples
-  { $code
-    "USE: heap"
-    "<heap> { 7 6 5 4 3 2 1 } over add-many"
-    "dup print-heap"
-    "dup bump \"(bump)\" print dup print-heap"
-    "dup bump \"(bump)\" print dup print-heap"
-    "dup bump \"(bump)\" print dup print-heap"
-  }
-}
-;
-
-HELP: gbump
-"(\"Get-bump\") Does a " { $link bump } ", but leaves the bumped element on the stack instead of discarding it."
-{ $examples
-  { $code
-    "USE: heap"
-    "<heap> { 7 6 5 4 3 2 1 } over add-many"
-    "dup gbump"
-  }
-}
-;
-
-HELP: print-heap
-"Prints the heap in tree form."
-{ $examples
-  { $code
-    "USE: heap"
-    "<heap> { 7 6 5 4 3 2 1 } over add-many"
-    "print-heap"
-  }
-}
-;

unmaintained/heap/human tests.factor

@@ -1,100 +0,0 @@
-: test-agg2 ( -- )
-    {
-    } >vector
-    {
-      "bbbbbbb"
-      "bbbbbbb"
-    } >vector
-    aggregate2 [ print ] each "" print
-
-    {
-      "aa"
-      "aa"
-    } >vector
-    {
-    } >vector
-    aggregate2 [ print ] each "" print
-
-    {
-    } >vector
-    {
-    } >vector
-    aggregate2 [ print ] each "" print
-
-    {
-      "aaaaaaa"
-      "aaaaaaa"
-      "aaaaaaa"
-      "aaaaaaa"
-      "aaaaaaa"
-      "aaaaaaa"
-    } >vector
-    {
-      "bbbb"
-      "bbbb"
-      "bbbb"
-    } >vector
-    aggregate2 [ print ] each "" print
-
-    {
-      "aaaa"
-      "aaaa"
-      "aaaa"
-    } >vector
-    {
-      "bbbbbbb"
-      "bbbbbbb"
-      "bbbbbbb"
-      "bbbbbbb"
-      "bbbbbbb"
-      "bbbbbbb"
-      "bbbbbbb"
-      "bbbbbbb"
-    } >vector
-    aggregate2 [ print ] each "" print
-    ;
-
-
-
-
-: test-agg ( -- )
-    {
-      "....5.."
-      "...|.|."
-      "..7...9"
-      ".|....."
-      "8......"
-    } >vector
-    {
-      "..3.."
-      ".|.|."
-      "4...4"
-    } >vector
-    {
-      ".2."
-      "|.|"
-    } >vector
-    aggregate3 [ print ] each "" print
-
-    {
-      "....5.."
-      "...|.|."
-      "..7...9"
-      ".|....."
-      "8......"
-    } >vector
-    {
-      "......3...."
-      ".....|.|..."
-      "....4...4.."
-      "...|.|....."
-      "..5...6...."
-      ".|........."
-      "6.........."
-    } >vector
-    {
-      ".2."
-      "|.|"
-    } >vector
-    aggregate3 [ print ] each "" print
-    ;

unmaintained/heap/load.factor

@@ -1,16 +0,0 @@
-! Binary Min Heap
-! Copyright 2007 Ryan Murphy
-! See http://factorcode.org/license.txt for BSD license.
-
-PROVIDE: libs/heap
-
-{ +files+ { 
-    "heap.factor"
-    "print.factor"
-
-    "heap.facts"
-} }
-
-{ +tests+ {
-    "tests.factor"
-} } ;

unmaintained/heap/print.factor

@@ -1,51 +0,0 @@
-! Binary Min Heap
-! Copyright 2007 Ryan Murphy
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: namespaces kernel math sequences prettyprint io ;
-IN: heap
-
-: spaces ( n -- str )
-    [ [ " " % ] times ] "" make ;
-
-: prepend-s ( v1 n -- v1' )
-    spaces   swap [ append ] map-with ;
-
-: append-s ( v1 v2 -- v1' )
-    spaces   swap [ swap append ] map-with ;
-
-: pad-r ( lv rv -- rv' )
-    dup first length spaces   pick length pick length -
-    [ [ dup , ] times ] V{ } make  
-    nip append nip ;
-
-: pad-l ( lv rv -- lv' )
-    swap pad-r ;
-
-: (aggregate2) ( lv rv -- v )
-    over length over length >= [ dupd pad-r ] [ tuck pad-l swap ] if
-    [ append ] 2map ;
-
-: aggregate2 ( lv rv -- v )
-    dup empty? [ drop ] [ over empty? [ nip ] [ (aggregate2) ] if ] if ;
-
-: (agg3len) ( v -- len )
-    dup empty? [ drop 0 ] [ first length ] if ;
-
-: aggregate3 ( lv rv pv -- v )
-    dup (agg3len) -roll
-    pick (agg3len) prepend-s
-    over (agg3len) append-s
-    -roll -rot swap append-s
-    swap aggregate2 append ;
-
-: output-node ( elt -- str ) [ [ pprint ] string-out , ] V{ } make ;
-
-: (print-heap) ( i heap -- vector )
-    2dup l-oob [ V{ } clone ] [ over  left over (print-heap) ] if -rot
-    2dup r-oob [ V{ } clone ] [ over right over (print-heap) ] if -rot
-    V{ } clone pick pick nth  output-node append
-    -rot 2drop aggregate3 ;
-
-: print-heap ( heap -- )
-    dup empty? [ drop ] [ 0 swap (print-heap) [ print ] each ] if ;

unmaintained/heap/tests.factor

@@ -1,35 +0,0 @@
-! Binary Min Heap
-! Copyright 2007 Ryan Murphy
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: heap test kernel ;
-
-{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
-{ t } [ 5 3 [comp] ] unit-test
-{ V{ } } [ <heap> ] unit-test
-
-{ V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } [ <heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over add-many ] unit-test
-
-
-
-{ V{ "hire" "hose" } } [ V{ "hi" "ho" } V{ "re" "se" } aggregate2 ] unit-test
-{ V{ "hire" "hose" "  it" } } [ V{ "hi" "ho" } V{ "re" "se" "it" } aggregate2 ] unit-test
-{ V{ "tracks" "snacks" "crack " } } [ V{ "track" "snack" "crack" } V{ "s" "s" } aggregate2 ] unit-test
-
-
-
-{ V{ "    top     " "left   right" } } [ V{ "left" } V{ "right" } V{ "top" } aggregate3 ] unit-test
-
-{ V{ "    top     "
-     "    dog     "
-     "left   right"
-     "over   on   "
-     "       man  " } } [ V{ "left" "over" } V{ "right" "on   " "man  " } V{ "top" "dog" } aggregate3 ] unit-test
-
-{ V{ "           -6       "
-     "      -4        2   "
-     "   1     5    3   2 "
-     " 4   3  7 6  8 3 4 4"
-     "6 5 5               " } } [ 0 <heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over add-many (print-heap) ] unit-test
-
-{ V{ 5 6 6 7 8 } } [ <heap> { 3 5 4 6 5 7 6 8 } over add-many dup bump dup bump dup bump ] unit-test

vm/os-windows.c

@@ -51,8 +51,7 @@ void ffi_dlopen (F_DLL *dll, bool error)
 	{
 		dll->dll = NULL;
 		if(error)
-			general_error(ERROR_FFI,F,F,
+			general_error(ERROR_FFI,F,tag_object(get_error_message()),NULL);
-				(void*)tag_object(get_error_message()));
 		else
 			return;
 	}