Merge git://factorcode.org/git/factor

Makefile

@@ -1,4 +1,6 @@
 CC = gcc
+AR = ar
+LD = ld
 
 EXECUTABLE = factor
 VERSION = 0.91

core/alien/c-types/c-types.factor

@@ -29,7 +29,7 @@ TUPLE: no-c-type name ;
         dup string? [ (c-type) ] when
     ] when ;
 
-GENERIC: c-type ( name -- type )
+GENERIC: c-type ( name -- type ) foldable
 
 : resolve-pointer-type ( name -- name )
     c-types get at dup string?

core/alien/compiler/compiler.factor

@@ -387,7 +387,7 @@ TUPLE: callback-context ;
     dup alien-callback-xt dup rot [
         init-templates
         generate-profiler-prologue
-        %save-xt
+        %save-word-xt
         %prologue-later
         dup alien-stack-frame [
             dup registers>objects

core/bootstrap/image/image.factor

@@ -157,7 +157,7 @@ GENERIC: ' ( obj -- ptr )
     #! n is positive or zero.
     [ dup 0 > ]
     [ dup bignum-bits neg shift swap bignum-radix bitand ]
-    { } unfold ;
+    [ ] unfold nip ;
 
 : emit-bignum ( n -- )
     dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
@@ -442,7 +442,7 @@ M: curry '
 
 PRIVATE>
 
-: make-image ( architecture -- )
+: make-image ( arch -- )
     [
         parse-hook off
         prepare-image
@@ -452,6 +452,9 @@ PRIVATE>
         image get image-name write-image
     ] with-scope ;
 
+: my-arch ( -- arch )
+    cpu dup "ppc" = [ os "-" rot 3append ] when ;
+
 : make-images ( -- )
     {
         "x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm"

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

core/classes/classes.factor

@@ -133,7 +133,7 @@ PRIVATE>
     >vector
     [ dup empty? not ]
     [ dup largest-class >r over delete-nth r> ]
-    { } unfold ;
+    [ ] unfold nip ;
 
 : class-or ( class1 class2 -- class )
     {

core/cpu/architecture/architecture.factor

@@ -50,7 +50,12 @@ HOOK: %epilogue compiler-backend ( n -- )
 HOOK: %profiler-prologue compiler-backend ( word -- )
 
 ! Store word XT in stack frame
-HOOK: %save-xt compiler-backend ( -- )
+HOOK: %save-word-xt compiler-backend ( -- )
+
+! Store dispatch branch XT in stack frame
+HOOK: %save-dispatch-xt compiler-backend ( -- )
+
+M: object %save-dispatch-xt %save-word-xt ;
 
 ! Call another label
 HOOK: %call-label compiler-backend ( label -- )

core/cpu/arm/architecture/architecture.factor

@@ -47,6 +47,16 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap <+/-> ;
         "end" resolve-label
     ] with-scope ;
 
+: call-cell ( -- )
+    ! Compute return address; we skip 3 instructions
+    LR PC 8 ADD
+    ! Load target address
+    R12 PC 0 <+> LDR
+    ! Jump to target address
+    R12 BX
+    ! The target address
+    0 , ;
+
 M: arm-backend load-indirect ( obj reg -- )
     tuck load-cell rc-absolute-cell rel-literal
     dup 0 <+> LDR ;
@@ -66,9 +76,12 @@ M: immediate load-literal
 M: arm-backend stack-frame ( n -- i )
     factor-area-size + 8 align ;
 
-M: arm-backend %save-xt ( -- )
+M: arm-backend %save-word-xt ( -- )
     R12 PC 9 cells SUB ;
 
+M: arm-backend %save-dispatch-xt ( -- )
+    R12 PC 2 cells SUB ;
+
 M: arm-backend %prologue ( n -- )
     SP SP pick SUB
     R11 over MOV
@@ -98,30 +111,36 @@ M: arm-backend %call-label ( label -- ) BL ;
 
 M: arm-backend %jump-label ( label -- ) B ;
 
-: %prepare-primitive ( word -- )
+: %prepare-primitive ( -- )
     #! Save stack pointer to stack_chain->callstack_top, load XT
-    R1 SP MOV
+    R1 SP MOV ;
-    T{ temp-reg } load-literal
-    R12 R12 word-xt-offset <+> LDR ;
 
 M: arm-backend %call-primitive ( word -- )
-    %prepare-primitive R12 BLX ;
+    %prepare-primitive
+    call-cell rc-absolute-cell rel-word ;
 
 M: arm-backend %jump-primitive ( word -- )
-    %prepare-primitive R12 BX ;
+    %prepare-primitive
+    ! Load target address
+    R12 PC 0 <+> LDR
+    ! Jump to target address
+    R12 BX
+    ! The target address
+    0 , rc-absolute-cell rel-word ;
 
 M: arm-backend %jump-t ( label -- )
     "flag" operand f v>operand CMP NE B ;
 
-: (%dispatch) ( word-table# reg -- )
+: (%dispatch) ( word-table# -- )
     #! Load jump table target address into reg.
     "scratch" operand PC "n" operand 1 <LSR> ADD
-    "scratch" operand 0 <+> LDR
+    "scratch" operand dup 0 <+> LDR
-    rc-indirect-arm rel-dispatch ;
+    rc-indirect-arm rel-dispatch
+    "scratch" operand dup compiled-header-size ADD ;
 
 M: arm-backend %call-dispatch ( word-table# -- )
     [
-        "scratch" operand (%dispatch)
+        (%dispatch)
         "scratch" operand BLX
     ] H{
         { +input+ { { f "n" } } }
@@ -131,7 +150,8 @@ M: arm-backend %call-dispatch ( word-table# -- )
 M: arm-backend %jump-dispatch ( word-table# -- )
     [
         %epilogue-later
-        PC (%dispatch)
+        (%dispatch)
+        "scratch" operand BX
     ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "scratch" } } }
@@ -259,14 +279,7 @@ M: arm-backend %prepare-alien-invoke
     rs-reg R12 12 <+> STR ;
 
 M: arm-backend %alien-invoke ( symbol dll -- )
-    ! Load target address
+    call-cell rc-absolute-cell rel-dlsym ;
-    R12 PC 4 <+> LDR
-    ! Store address of next instruction in LR
-    LR PC 4 ADD
-    ! Jump to target address
-    R12 BX
-    ! The target address
-    0 , rc-absolute rel-dlsym ;
 
 M: arm-backend %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke

core/cpu/ppc/architecture/architecture.factor

@@ -76,7 +76,7 @@ M: ppc-backend load-indirect ( obj reg -- )
     [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
     dup 0 LWZ ;
 
-M: ppc-backend %save-xt ( -- )
+M: ppc-backend %save-word-xt ( -- )
     0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ;
 
 M: ppc-backend %prologue ( n -- )

core/cpu/x86/architecture/architecture.factor

@@ -44,7 +44,7 @@ M: immediate load-literal v>operand swap v>operand MOV ;
 M: x86-backend stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
-M: x86-backend %save-xt ( -- )
+M: x86-backend %save-word-xt ( -- )
     xt-reg 0 MOV rc-absolute-cell rel-current-word ;
 
 : factor-area-size 4 cells ;

core/dlists/authors.txt

@@ -1 +1,2 @@
 Mackenzie Straight
+Doug Coleman

core/dlists/dlists-docs.factor

@@ -0,0 +1,104 @@
+USING: help.markup help.syntax kernel ;
+IN: dlists
+
+ARTICLE: "dlists" "Doubly-linked lists"
+"A doubly-linked list, or dlist, is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object."
+$nl
+"While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time."
+$nl
+"When using a dlist as a simple queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "."
+$nl
+"Dlists form a class:"
+{ $subsection dlist }
+{ $subsection dlist? }
+"Constructing a dlist:"
+{ $subsection <dlist> }
+"Double-ended queue protocol:"
+{ $subsection dlist-empty? }
+{ $subsection push-front }
+{ $subsection pop-front }
+{ $subsection pop-front* }
+{ $subsection push-back }
+{ $subsection pop-back }
+{ $subsection pop-back* }
+"Finding out the length:"
+{ $subsection dlist-length }
+"Iterating over elements:"
+{ $subsection dlist-each }
+{ $subsection dlist-find }
+{ $subsection dlist-contains? }
+"Deleting a node matching a predicate:"
+{ $subsection delete-node* }
+{ $subsection delete-node }
+"Consuming all nodes:"
+{ $subsection dlist-slurp } ;
+
+ABOUT: "dlists"
+
+HELP: dlist-empty?
+{ $values { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $description "Returns true if a " { $link dlist } " is empty." }
+{ $notes "This operation is O(1)." } ;
+
+HELP: push-front
+{ $values { "obj" "an object" } { "dlist" dlist } }
+{ $description "Push the object onto the front of the " { $link dlist } "." } 
+{ $notes "This operation is O(1)." }
+{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
+
+HELP: push-back
+{ $values { "obj" "an object" } { "dlist" dlist } }
+{ $description "Push the object onto the back of the " { $link dlist } "." } 
+{ $notes "This operation is O(1)." }
+{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
+
+HELP: pop-front
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Pop the object off the front of the " { $link dlist } " and return the object." }
+{ $notes "This operation is O(1)." }
+{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
+
+HELP: pop-front*
+{ $values { "dlist" dlist } }
+{ $description "Pop the object off the front of the " { $link dlist } "." }
+{ $notes "This operation is O(1)." }
+{ $see-also push-front push-back pop-front pop-back pop-back* } ;
+
+HELP: pop-back
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Pop the object off the back of the " { $link dlist } " and return the object." }
+{ $notes "This operation is O(1)." }
+{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
+
+HELP: pop-back*
+{ $values { "dlist" dlist } }
+{ $description "Pop the object off the back of the " { $link dlist } "." }
+{ $notes "This operation is O(1)." }
+{ $see-also push-front push-back pop-front pop-front* pop-back } ;
+
+HELP: dlist-find
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached.  Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
+{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
+    $nl
+    "This operation is O(n)."
+} ;
+
+HELP: dlist-contains?
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
+{ $notes "This operation is O(n)." } ;
+
+HELP: delete-node*
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any.  Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
+{ $notes "This operation is O(n)." } ;
+
+HELP: delete-node
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
+{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
+{ $notes "This operation is O(n)." } ;
+
+HELP: dlist-each
+{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } }
+{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

core/dlists/dlists-tests.factor

@@ -0,0 +1,61 @@
+USING: dlists dlists.private kernel tools.test ;
+IN: temporary
+
+[ t ] [ <dlist> dlist-empty? ] unit-test
+
+[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ]
+[ <dlist> 1 over push-front ] unit-test
+
+! Make sure empty lists are empty
+[ t ] [ <dlist> dlist-empty? ] unit-test
+[ f ] [ <dlist> 1 over push-front dlist-empty? ] unit-test
+[ f ] [ <dlist> 1 over push-back dlist-empty? ] unit-test
+
+[ 1 ] [ <dlist> 1 over push-front pop-front ] unit-test
+[ 1 ] [ <dlist> 1 over push-front pop-back ] unit-test
+[ 1 ] [ <dlist> 1 over push-back pop-front ] unit-test
+[ 1 ] [ <dlist> 1 over push-back pop-back ] unit-test
+[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-front* ] unit-test
+[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-front dup pop-back* ] unit-test
+[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-front* ] unit-test
+[ T{ dlist f f f 0 } ] [ <dlist> 1 over push-back dup pop-back* ] unit-test
+
+! Test the prev,next links for two nodes
+[ f ] [
+    <dlist> 1 over push-back 2 over push-back
+    dlist-front dlist-node-prev
+] unit-test
+
+[ 2 ] [
+    <dlist> 1 over push-back 2 over push-back
+    dlist-front dlist-node-next dlist-node-obj
+] unit-test
+
+[ 1 ] [
+    <dlist> 1 over push-back 2 over push-back
+    dlist-front dlist-node-next dlist-node-prev dlist-node-obj
+] unit-test
+
+[ f ] [
+    <dlist> 1 over push-back 2 over push-back
+    dlist-front dlist-node-next dlist-node-next
+] unit-test
+
+[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
+[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
+[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
+[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
+
+[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
+[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test
+
+[ 0 ] [ <dlist> dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
+[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test

core/dlists/dlists.factor

@@ -0,0 +1,130 @@
+! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel math ;
+IN: dlists
+
+TUPLE: dlist front back length ;
+
+: <dlist> ( -- obj )
+    dlist construct-empty
+    0 over set-dlist-length ;
+
+: dlist-empty? ( dlist -- ? ) dlist-front not ;
+
+<PRIVATE
+TUPLE: dlist-node obj prev next ;
+C: <dlist-node> dlist-node
+
+: inc-length ( dlist -- )
+    [ dlist-length 1+ ] keep set-dlist-length ; inline
+
+: dec-length ( dlist -- )
+    [ dlist-length 1- ] keep set-dlist-length ; inline
+
+: set-prev-when ( dlist-node dlist-node/f -- )
+    [ set-dlist-node-prev ] [ drop ] if* ;
+
+: set-next-when ( dlist-node dlist-node/f -- )
+    [ set-dlist-node-next ] [ drop ] if* ;
+
+: set-next-prev ( dlist-node -- )
+    dup dlist-node-next set-prev-when ;
+
+: normalize-front ( dlist -- )
+    dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
+
+: normalize-back ( dlist -- )
+    dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
+
+: set-back-to-front ( dlist -- )
+    dup dlist-back
+    [ drop ] [ dup dlist-front swap set-dlist-back ] if ;
+
+: set-front-to-back ( dlist -- )
+    dup dlist-front
+    [ drop ] [ dup dlist-back swap set-dlist-front ] if ;
+
+: (dlist-find-node) ( quot dlist-node -- node/f ? )
+    dup dlist-node-obj pick dupd call [
+        drop nip t
+    ] [
+        drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
+    ] if ;
+
+: dlist-find-node ( quot dlist -- node/f ? )
+    dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
+
+: (dlist-each-node) ( quot dlist -- )
+    over
+    [ 2dup call >r dlist-node-next r> (dlist-each-node) ]
+    [ 2drop ] if ;
+
+: dlist-each-node ( quot dlist -- )
+    >r dlist-front r> (dlist-each-node) ; inline
+PRIVATE>
+
+: push-front ( obj dlist -- )
+    [ dlist-front f swap <dlist-node> dup set-next-prev ] keep
+    [ set-dlist-front ] keep
+    [ set-back-to-front ] keep
+    inc-length ;
+
+: push-back ( obj dlist -- )
+    [ dlist-back f <dlist-node> ] keep
+    [ dlist-back set-next-when ] 2keep
+    [ set-dlist-back ] keep
+    [ set-front-to-back ] keep
+    inc-length ;
+
+: pop-front ( dlist -- obj )
+    dup dlist-front [
+        dlist-node-next
+        f over set-prev-when
+        swap set-dlist-front
+    ] 2keep dlist-node-obj
+    swap [ normalize-back ] keep dec-length ;
+
+: pop-front* ( dlist -- ) pop-front drop ;
+
+: pop-back ( dlist -- obj )
+    [
+        dlist-back dup dlist-node-prev f over set-next-when
+    ] keep
+    [ set-dlist-back ] keep
+    [ normalize-front ] keep
+    dec-length
+    dlist-node-obj ;
+
+: pop-back* ( dlist -- ) pop-back drop ;
+
+: dlist-find ( quot dlist -- obj/f ? )
+    dlist-find-node dup [ >r dlist-node-obj r> ] when ;
+
+: dlist-contains? ( quot dlist -- ? )
+    dlist-find nip ;
+
+: (delete-node) ( dlist dlist-node -- )
+    {
+        { [ 2dup >r dlist-front r> = ] [ drop pop-front* ] }
+        { [ 2dup >r dlist-back r> = ] [ drop pop-back* ] }
+        { [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when
+                  dec-length ] }
+    } cond ;
+
+: delete-node* ( quot dlist -- obj/f ? )
+    tuck dlist-find-node [
+        [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
+    ] [
+        2drop f f
+    ] if ;
+
+: delete-node ( quot dlist -- obj/f )
+    delete-node* drop ;
+
+: dlist-each ( dlist quot -- )
+    [ dlist-node-obj ] swap compose dlist-each-node ; inline
+
+: dlist-slurp ( dlist quot -- )
+    over dlist-empty?
+    [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ;
+    inline

core/generator/generator.factor

@@ -60,7 +60,7 @@ GENERIC: generate-node ( node -- next )
     [
         init-templates
         generate-profiler-prologue
-        %save-xt
+        %save-word-xt
         %prologue-later
         current-label-start define-label
         current-label-start resolve-label
@@ -189,7 +189,7 @@ M: #if generate-node
     gensym [
         rot [
             copy-templates
-            %save-xt
+            %save-dispatch-xt
             %prologue-later
             [ generate-nodes ] with-node-iterator
         ] generate-1

core/heaps/heaps-docs.factor

@@ -0,0 +1,79 @@
+USING: heaps.private help.markup help.syntax kernel math assocs ;
+IN: heaps
+
+ARTICLE: "heaps" "Heaps"
+"A heap is an implementation of a " { $emphasis "priority queue" } ", which is a structure that maintains a sorted set of elements. The key property is that insertion of an arbitrary element and removal of the first element (determined by order) is performed in O(log n) time."
+$nl
+"Heap elements are key/value pairs and are compared using the " { $link <=> } " generic word on the first element of the pair."
+$nl
+"There are two classes of heaps. Min-heaps sort their elements so that the minimum element is first:"
+{ $subsection min-heap }
+{ $subsection min-heap? }
+{ $subsection <min-heap> }
+"Max-heaps sort their elements so that the maximum element is first:"
+{ $subsection min-heap }
+{ $subsection min-heap? }
+{ $subsection <min-heap> }
+"Both obey a protocol."
+$nl
+"Queries:"
+{ $subsection heap-empty? }
+{ $subsection heap-length }
+{ $subsection heap-peek }
+"Insertion:"
+{ $subsection heap-push }
+{ $subsection heap-push-all }
+"Removal:"
+{ $subsection heap-pop* }
+{ $subsection heap-pop } ;
+
+ABOUT: "heaps"
+
+HELP: <min-heap>
+{ $values { "min-heap" min-heap } }
+{ $description "Create a new " { $link min-heap } "." }
+{ $see-also <max-heap> } ;
+
+HELP: <max-heap>
+{ $values { "max-heap" max-heap } }
+{ $description "Create a new " { $link max-heap } "." }
+{ $see-also <min-heap> } ;
+
+HELP: heap-push
+{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
+{ $description "Push an pair onto a heap.  The key must be comparable with all other keys by the " { $link <=> } " generic word." }
+{ $side-effects "heap" }
+{ $see-also heap-push-all heap-pop } ;
+
+HELP: heap-push-all
+{ $values { "assoc" assoc } { "heap" heap } }
+{ $description "Push every key/value pair of an assoc onto a heap." }
+{ $side-effects "heap" }
+{ $see-also heap-push heap-pop } ;
+
+HELP: heap-peek
+{ $values { "heap" heap } { "key" object } { "value" object } }
+{ $description "Outputs the first element in the heap, leaving it in the heap." }
+{ $see-also heap-pop heap-pop* } ;
+
+HELP: heap-pop*
+{ $values { "heap" heap } }
+{ $description "Removes the first element from the heap." }
+{ $side-effects "heap" }
+{ $see-also heap-pop heap-push heap-peek } ;
+
+HELP: heap-pop
+{ $values { "heap" heap } { "key" object } { "value" object } }
+{ $description "Outputs the first element in the heap and removes it from the heap." }
+{ $side-effects "heap" }
+{ $see-also heap-pop* heap-push heap-peek } ;
+
+HELP: heap-empty?
+{ $values { "heap" heap } { "?" "a boolean" } }
+{ $description "Tests if a " { $link heap } " has no nodes." }
+{ $see-also heap-length heap-peek } ;
+
+HELP: heap-length
+{ $values { "heap" heap } { "n" integer } }
+{ $description "Returns the number of key/value pairs in the heap." }
+{ $see-also heap-empty? } ;

core/heaps/heaps-tests.factor

@@ -0,0 +1,35 @@
+! 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> heap-pop ] unit-test-fails
+[ <max-heap> heap-pop ] unit-test-fails
+
+[ t ] [ <min-heap> heap-empty? ] unit-test
+[ f ] [ <min-heap> 1 t pick heap-push heap-empty? ] unit-test
+[ t ] [ <max-heap> heap-empty? ] unit-test
+[ f ] [ <max-heap> 1 t pick heap-push 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 t } { 3 t } T{ min-heap } heap-compare ] unit-test
+{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test
+
+[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
+[ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
+
+[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
+    <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all
+    3 [ dup heap-pop* ] times
+] unit-test
+
+[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
+
+[ t 1 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
+
+[ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
+
+[ 0 ] [ <max-heap> heap-length ] unit-test
+[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test

core/heaps/heaps.factor

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

core/io/files/files-docs.factor

@@ -7,7 +7,7 @@ ARTICLE: "file-streams" "Reading and writing files"
 { $subsection <file-writer> }
 { $subsection <file-appender> }
 "Pathname manipulation:"
-{ $subsection parent-dir }
+{ $subsection parent-directory }
 { $subsection file-name }
 { $subsection last-path-separator }
 { $subsection path+ }
@@ -101,10 +101,10 @@ HELP: file-modified
 { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
 { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
 
-HELP: parent-dir
+HELP: parent-directory
 { $values { "path" "a pathname string" } { "parent" "a pathname string" } }
 { $description "Strips the last component off a pathname." }
-{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-dir print" "/etc" } } ;
+{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc" } } ;
 
 HELP: file-name
 { $values { "path" "a pathname string" } { "string" string } }

core/io/files/files.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.files
-USING: io.backend io.files.private hashtables kernel math memory
+USING: io.backend io.files.private io hashtables kernel math
-namespaces sequences strings arrays definitions system
+memory namespaces sequences strings arrays definitions system
 combinators splitting ;
 
 HOOK: <file-reader> io-backend ( path -- stream )
@@ -58,13 +58,16 @@ M: object root-directory? ( path -- ? ) "/" = ;
 
 TUPLE: no-parent-directory path ;
 
-: parent-dir ( path -- parent )
+: no-parent-directory ( path -- * )
+    \ no-parent-directory construct-boa throw ;
+
+: parent-directory ( path -- parent )
     {
         { [ dup root-directory? ] [ ] }
         { [ dup "/\\" split ".." over member? "." rot member? or ]
-            [ \ no-parent-directory construct-boa throw ] }
+            [ no-parent-directory ] }
         { [ t ] [ dup last-path-separator
-                [ 1+ head ] [ 2drop "." ] if ] }
+            [ 1+ head ] [ 2drop "." ] if ] }
     } cond ;
 
 : file-name ( path -- string )
@@ -72,7 +75,7 @@ TUPLE: no-parent-directory path ;
     [ 1+ tail ] [ drop ] if ;
 
 : resource-path ( path -- newpath )
-    \ resource-path get [ image parent-dir ] unless*
+    \ resource-path get [ image parent-directory ] unless*
     swap path+ ;
 
 : ?resource-path ( path -- newpath )
@@ -86,7 +89,7 @@ TUPLE: no-parent-directory path ;
         { [ dup empty? ] [ ] }
         { [ dup exists? ] [ ] }
         { [ t ] [
-            dup parent-dir make-directories
+            dup parent-directory make-directories
             dup make-directory
         ] }
     } cond drop ;
@@ -103,3 +106,18 @@ M: pathname <=> [ pathname-string ] compare ;
         { [ wince? ] [ "" resource-path ] }
         { [ unix? ] [ "HOME" os-env ] }
     } cond ;
+
+: copy-file ( from to -- )
+    dup parent-directory make-directories
+    <file-writer> [
+        stdio get swap
+        <file-reader> [
+            stdio get swap stream-copy
+        ] with-stream
+    ] with-stream ;
+
+: copy-directory ( from to -- )
+    dup make-directories
+    >r dup directory swap r> [
+        >r >r first r> over path+ r> rot path+ copy-file
+    ] 2curry each ;

core/io/io.factor

@@ -86,7 +86,7 @@ SYMBOL: stdio
     presented associate format ;
 
 : lines ( stream -- seq )
-    [ [ readln dup ] [ ] { } unfold ] with-stream ;
+    [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
 
 : contents ( stream -- str )
     2048 <sbuf> [ stream-copy ] keep >string ;

core/kernel/kernel-docs.factor

@@ -60,6 +60,8 @@ $nl
 "A pair of utility words built from " { $link 2apply } ":"
 { $subsection both? }
 { $subsection either? }
+"A looping combinator:"
+{ $subsection while }
 "Quotations can be composed using efficient quotation-specific operations:"
 { $subsection curry }
 { $subsection 2curry }
@@ -538,3 +540,15 @@ HELP: 3compose
     }
     "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
 } ;
+
+HELP: while
+{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation" } { "tail" "a quotation" } }
+{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
+{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
+$nl
+"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
+{ $code
+    "[ P ] [ Q ] [ T ] while"
+    "[ P ] [ Q ] [ ] while T"
+}
+"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;

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/none/deploy.factor

@@ -0,0 +1,13 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-math? f }
+    { deploy-word-defs? f }
+    { deploy-word-props? f }
+    { deploy-name "none" }
+    { "stop-after-last-window?" t }
+    { deploy-c-types? f }
+    { deploy-compiler? f }
+    { deploy-io 1 }
+    { deploy-ui? f }
+    { deploy-reflection 1 }
+}

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/queues/authors.txt

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

core/queues/queues-docs.factor

@@ -1,77 +0,0 @@
-USING: help.markup help.syntax kernel ;
-IN: queues
-
-ARTICLE: "queues" "Queues"
-"Last-in-first-out queues are defined in the " { $vocab-link "queues" } " vocabulary."
-$nl
-"Queues are a class."
-{ $subsection queue }
-{ $subsection queue? }
-{ $subsection <queue> }
-"Testing queues:"
-{ $subsection queue-empty? }
-"Adding elements:"
-{ $subsection deque }
-"Removing elements:"
-{ $subsection enque }
-{ $subsection clear-queue }
-{ $subsection queue-each }
-"An example:"
-{ $code
-    "<queue> \"q\" set"
-    "5 \"q\" get enque"
-    "3 \"q\" get enque"
-    "7 \"q\" get enque"
-    "\"q\" get deque ."
-    "  5"
-    "\"q\" get deque ."
-    "  3"
-    "\"q\" get deque ."
-    "  7"
-} ;
-
-ABOUT: "queues"
-
-HELP: queue
-{ $class-description "A simple first-in-first-out queue. See " { $link "queues" } "." } ;
-
-HELP: entry
-{ $class-description "The class of entries in a " { $link queue } ". Each entry holds an object and a reference to the next entry." } ;
-
-HELP: <entry>
-{ $values { "obj" object } { "entry" entry } }
-{ $description "Creates a new queue entry." }
-{ $notes "This word is a factor of " { $link enque } "." } ;
-
-HELP: <queue>
-{ $values { "queue" queue } }
-{ $description "Makes a new queue with no elements." } ;
-
-HELP: queue-empty?
-{ $values { "queue" queue } { "?" "a boolean" } }
-{ $description "Tests if a queue contains no elements." } ;
-
-HELP: deque
-{ $values { "queue" queue } { "elt" object } }
-{ $description "Removes an element from the front of the queue." }
-{ $errors "Throws an " { $link empty-queue-error } " if the queue has no entries." }
-{ $side-effects "queue" } ;
-
-HELP: enque
-{ $values { "elt" object } { "queue" queue } }
-{ $description "Adds an element to the back of the queue." }
-{ $side-effects "queue" } ;
-
-HELP: empty-queue-error
-{ $description "Throws an " { $link empty-queue-error } "." }
-{ $error-description "Thrown by " { $link deque } " if the queue has no entries." } ;
-
-HELP: clear-queue
-{ $values { "queue" queue } }
-{ $description "Removes all entries from the queue." }
-{ $side-effects "queue" } ;
-
-HELP: queue-each
-{ $values { "queue" queue } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
-{ $description "Applies the quotation to each entry in the queue, starting from the least recently added entry, clearing the queue in the process." }
-{ $side-effects "queue" } ;

core/queues/queues-tests.factor

@@ -1,12 +0,0 @@
-USING: kernel math namespaces queues sequences tools.test ;
-IN: temporary
-
-<queue> "queue" set
-
-[ t ] [ "queue" get queue-empty? ] unit-test
-
-[ ] [ [ 1 2 3 4 5 ] [ "queue" get enque ] each ] unit-test
-
-[ { 1 2 3 4 5 } ] [ 5 [ drop "queue" get deque ] map ] unit-test
-
-[ "queue" get deque ] unit-test-fails

core/queues/queues.factor

@@ -1,57 +0,0 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: queues
-USING: kernel inspector ;
-
-TUPLE: entry obj next ;
-
-: <entry> ( obj -- entry ) f entry construct-boa ;
-
-TUPLE: queue head tail ;
-
-: <queue> ( -- queue ) queue construct-empty ;
-
-: queue-empty? ( queue -- ? ) queue-head not ;
-
-: (enque) ( entry queue -- )
-    [ set-queue-head ] 2keep set-queue-tail ;
-
-: clear-queue ( queue -- )
-    f swap (enque) ;
-
-: enque ( elt queue -- )
-    >r <entry> r> dup queue-empty? [
-        (enque)
-    ] [
-        [ queue-tail set-entry-next ] 2keep set-queue-tail
-    ] if ;
-
-: clear-entry ( entry -- )
-    f over set-entry-obj f swap set-entry-next ;
-
-: (deque) ( queue -- )
-    dup queue-head over queue-tail eq? [
-        clear-queue
-    ] [
-        dup queue-head dup entry-next rot set-queue-head
-        clear-entry
-    ] if ;
-
-TUPLE: empty-queue-error ;
-: empty-queue-error ( -- * )
-    \ empty-queue-error construct-empty throw ;
-
-: deque ( queue -- elt )
-    dup queue-empty? [
-        empty-queue-error
-    ] [
-        dup queue-head entry-obj >r (deque) r>
-    ] if ;
-
-M: empty-queue-error summary
-    drop "Empty queue" ;
-
-: queue-each ( queue quot -- )
-    over queue-empty?
-    [ 2drop ] [ [ >r deque r> call ] 2keep queue-each ] if ;
-    inline

core/queues/summary.txt

@@ -1 +0,0 @@
-FIFO queues

core/sequences/sequences-docs.factor

@@ -127,8 +127,9 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
 { $subsection 2reduce }
 "Mapping:"
 { $subsection map }
-{ $subsection accumulate }
 { $subsection 2map }
+{ $subsection accumulate }
+{ $subsection unfold }
 "Filtering:"
 { $subsection push-if }
 { $subsection subset } ;
@@ -230,6 +231,7 @@ $nl
 { $subsection "sequences-tests" }
 { $subsection "sequences-search" }
 { $subsection "sequences-comparing" }
+{ $subsection "sequences-split" }
 { $subsection "sequences-destructive" }
 { $subsection "sequences-stacks" }
 "For inner loops:"
@@ -961,3 +963,13 @@ HELP: supremum
 { $values { "seq" "a sequence of real numbers" } { "n" "a number" } }
 { $description "Outputs the greatest element of " { $snippet "seq" } "." }
 { $errors "Throws an error if the sequence is empty." } ;
+
+HELP: unfold
+{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation with stack effect " { $snippet "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
+{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
+{ $examples
+    "The following example divides a number by two until we reach zero, and accumulates intermediate results:"
+    { $example "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
+    "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:"
+    { $unchecked-example "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
+} ;

core/sequences/sequences.factor

@@ -414,12 +414,10 @@ PRIVATE>
 : interleave ( seq between quot -- )
     [ (interleave) ] 2curry iterate-seq 2each ; inline
 
-: unfold ( obj pred quot exemplar -- seq )
+: unfold ( pred quot tail -- seq )
-    [
+    V{ } clone [
-        10 swap new-resizable [
+        swap >r [ push ] curry compose r> while
-            [ push ] curry compose [ drop ] while
+    ] keep { } like ; inline
-        ] keep
-    ] keep like ; inline
 
 : index ( obj seq -- n )
     [ = ] curry* find drop ;

core/threads/threads-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel kernel.private io
-threads.private continuations queues ;
+threads.private continuations dlists ;
 IN: threads
 
 ARTICLE: "threads" "Threads"
@@ -20,8 +20,8 @@ $nl
 ABOUT: "threads"
 
 HELP: run-queue
-{ $values { "queue" queue } }
+{ $values { "queue" dlist } }
-{ $description "Outputs the runnable thread queue." } ;
+{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } 
" and dequeued with " { $link pop-back } "." } ;
 
 HELP: schedule-thread
 { $values { "continuation" "a continuation reified by " { $link callcc0 } } }

core/threads/threads.factor

@@ -2,34 +2,30 @@
 ! Copyright (C) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: threads
-USING: arrays init hashtables heaps io.backend kernel kernel.private
+USING: arrays init hashtables heaps io.backend kernel
-math namespaces queues sequences vectors io system sorting
+kernel.private math namespaces sequences vectors io system
-continuations debugger ;
+continuations debugger dlists ;
 
 <PRIVATE
 
 SYMBOL: sleep-queue
 
-TUPLE: sleeping ms continuation ;
-
-M: sleeping <=> ( obj1 obj2 -- n )
-    [ sleeping-ms ] 2apply - ;
-
 : sleep-time ( -- ms )
-    sleep-queue get-global
+    sleep-queue get-global dup heap-empty?
-    dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ;
+    [ drop 1000 ] [ heap-peek nip millis [-] ] if ;
 
 : run-queue ( -- queue ) \ run-queue get-global ;
 
-: schedule-sleep ( ms continuation -- )
+: schedule-sleep ( continuation ms -- )
-    sleeping construct-boa sleep-queue get-global push-heap ;
+    sleep-queue get-global heap-push ;
 
 : wake-up ( -- continuation )
-    sleep-queue get-global pop-heap sleeping-continuation ;
+    sleep-queue get-global heap-pop drop ;
 
 PRIVATE>
 
-: schedule-thread ( continuation -- ) run-queue enque ;
+: schedule-thread ( continuation -- )
+    run-queue push-front ;
 
 : schedule-thread-with ( obj continuation -- )
     2array schedule-thread ;
@@ -38,14 +34,14 @@ PRIVATE>
     walker-hook [
         f swap continue-with
     ] [
-        run-queue deque dup array?
+        run-queue pop-back dup array?
         [ first2 continue-with ] [ continue ] if
     ] if* ;
 
 : yield ( -- ) [ schedule-thread stop ] callcc0 ;
 
 : sleep ( ms -- )
-    >fixnum millis + [ schedule-sleep stop ] callcc0 drop ;
+    >fixnum millis + [ schedule-sleep stop ] curry callcc0 ;
 
 : in-thread ( quot -- )
     [
@@ -64,10 +60,10 @@ PRIVATE>
     [ 0 ? io-multiplex ] if ;
 
 : idle-thread ( -- )
-    run-queue queue-empty? (idle-thread) yield idle-thread ;
+    run-queue dlist-empty? (idle-thread) yield idle-thread ;
 
 : init-threads ( -- )
-    <queue> \ run-queue set-global
+    <dlist> \ run-queue set-global
     <min-heap> sleep-queue set-global
     [ idle-thread ] in-thread ;
 

core/tuples/tuples.factor

@@ -107,7 +107,7 @@ M: tuple equal?
     [ dup , delegate (delegates) ] when* ;
 
 : delegates ( obj -- seq )
-    [ dup ] [ [ delegate ] keep ] { } unfold ;
+    [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
 
 : is? ( obj quot -- ? ) >r delegates r> contains? ; inline
 

extra/automata/ui/deploy.factor

@@ -1,16 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-prettyprint? t }
-    { strip-globals? t }
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
     { "stop-after-last-window?" t }
-    { "bundle-name" "Cellular Automata.app" }
+    { deploy-name "Cellular Automata" }
 }

extra/boids/ui/deploy.factor

@@ -1,13 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
-    { "bundle-name" "Boids.app" }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Boids" }
 }

extra/bunny/deploy.factor

@@ -1,12 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? t }
     { deploy-ui? t }
-    { "bundle-name" "Bunny.app" }
+    { deploy-io 3 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Bunny" }
 }

extra/catalyst-talk/deploy.factor

@@ -0,0 +1,12 @@
+USING: tools.deploy.config ;
+V{
+    { deploy-ui? t }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Catalyst Talk" }
+}

extra/cfdg/models/flower6/deploy.factor

@@ -0,0 +1,12 @@
+USING: tools.deploy.config ;
+V{
+    { deploy-ui? t }
+    { deploy-io 1 }
+    { deploy-reflection 2 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { "bundle-name" "cfdg.models.flower6.app" }
+}

extra/channels/channels-tests.factor

@@ -5,44 +5,40 @@ USING: kernel tools.test math channels channels.private
 sequences threads sorting ;
 IN: temporary
 
-{ 3 t } [
-    V{ 1 2 3 4 } clone [ delete-random ] keep length swap integer?
-] unit-test
-
 { V{ 10 } } [
-   V{ } clone <channel>
+    V{ } clone <channel>
-   [ from swap push ] in-thread
+    [ from swap push ] in-thread
-   10 swap to 
+    10 swap to 
 ] unit-test
 
 { 20 } [
-   <channel>
+    <channel>
-   [ 20 swap to ] in-thread
+    [ 20 swap to ] in-thread
-   from 
+    from 
 ] unit-test
 
 { V{ 1 2 3 4 } } [
-   V{ } clone <channel>
+    V{ } clone <channel>
-   [ from swap push ] in-thread
+    [ from swap push ] in-thread
-   [ from swap push ] in-thread
+    [ from swap push ] in-thread
-   [ from swap push ] in-thread
+    [ from swap push ] in-thread
-   [ from swap push ] in-thread
+    [ from swap push ] in-thread
-   4 over to 
+    4 over to 
-   2 over to 
+    2 over to 
-   1 over to 
+    1 over to 
-   3 swap to 
+    3 swap to 
-   [ <=> ] sort
+    natural-sort
 ] unit-test
 
 { V{ 1 2 4 9 } } [
-   V{ } clone <channel>
+    V{ } clone <channel>
-   [ 4 swap to ] in-thread
+    [ 4 swap to ] in-thread
-   [ 2 swap to ] in-thread
+    [ 2 swap to ] in-thread
-   [ 1 swap to ] in-thread
+    [ 1 swap to ] in-thread
-   [ 9 swap to ] in-thread
+    [ 9 swap to ] in-thread
-   2dup from swap push 
+    2dup from swap push 
-   2dup from swap push 
+    2dup from swap push 
-   2dup from swap push 
+    2dup from swap push 
-   dupd from swap push 
+    dupd from swap push 
-   [ <=> ] sort
+    natural-sort
 ] unit-test

extra/channels/channels.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! Channels - based on ideas from newsqueak
-USING: kernel sequences threads continuations random math ;
+USING: kernel sequences sequences.lib threads continuations random math ;
 IN: channels
 
 TUPLE: channel receivers senders ;
@@ -15,9 +15,6 @@ GENERIC: from ( channel -- value )
 
 <PRIVATE
 
-: delete-random ( seq -- value )
-    [ length random ] keep [ nth ] 2keep delete-nth ;
-
 : wait ( channel -- )
     [ channel-senders push stop ] curry callcc0 ;
 

extra/channels/remote/remote.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! Remote Channels
-USING: kernel init namespaces assocs arrays 
+USING: kernel init namespaces assocs arrays random
 sequences channels match concurrency concurrency.distributed ;
 IN: channels.remote
 
@@ -13,7 +13,7 @@ IN: channels.remote
 PRIVATE>
 
 : publish ( channel -- id )
-    random-64 dup >r remote-channels set-at r> ;
+    random-256 dup >r remote-channels set-at r> ;
 
 : get-channel ( id -- channel )
     remote-channels at ;

extra/color-picker/deploy.factor

@@ -1,12 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
-    { "bundle-name" "Color Picker.app" }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Color Picker" }
 }

extra/concurrency/concurrency.factor

@@ -26,7 +26,7 @@ TUPLE: thread timeout continuation continued? ;
     mailbox-data dlist-empty? ;
 
 : mailbox-put ( obj mailbox -- )
-    [ mailbox-data dlist-push-end ] keep
+    [ mailbox-data push-back ] keep
     [ mailbox-threads ] keep
     V{ } clone swap set-mailbox-threads
     [ thread-continuation schedule-thread ] each yield ;
@@ -51,7 +51,7 @@ TUPLE: thread timeout continuation continued? ;
 PRIVATE>
 : mailbox-get* ( mailbox timeout -- obj )
     (mailbox-block-if-empty)
-    mailbox-data dlist-pop-front ;
+    mailbox-data pop-front ;
 
 : mailbox-get ( mailbox -- obj )
     f mailbox-get* ;
@@ -59,8 +59,8 @@ PRIVATE>
 : mailbox-get-all* ( mailbox timeout -- array )
     (mailbox-block-if-empty)
     [ dup mailbox-empty? ]
-    [ dup mailbox-data dlist-pop-front ]
+    [ dup mailbox-data pop-front ]
-    { } unfold ;
+    [ ] unfold nip ;
 
 : mailbox-get-all ( mailbox -- array )
     f mailbox-get-all* ;
@@ -74,7 +74,7 @@ PRIVATE>
 
 : mailbox-get?* ( pred mailbox timeout -- obj )
     2over >r >r (mailbox-block-unless-pred) r> r>
-    mailbox-data dlist-remove ; inline
+    mailbox-data delete-node ; inline
 
 : mailbox-get? ( pred mailbox -- obj )
     f mailbox-get?* ;
@@ -85,21 +85,19 @@ C: <process> process
 
 GENERIC: send ( message process -- )
 
-: random-pid ( -- id ) 8 big-random ;
-
 <PRIVATE
 : make-process ( -- process )
     #! Return a process set to run on the local node. A process is
     #! 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-pid make-mailbox <process> ;
+    [ ] random-256 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-pid make-mailbox <process> ;
+    1quotation random-256 make-mailbox <process> ;
 PRIVATE>
 
 : self ( -- process )
@@ -206,7 +204,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-pid r> 3array ;
+    >r self random-256 r> 3array ;
 PRIVATE>
 
 : send-synchronous ( message process -- reply )

extra/contributors/contributors.factor

@@ -5,7 +5,7 @@ sequences combinators.lib assocs system sorting math.parser ;
 IN: contributors
 
 : changelog ( -- authors )
-    image parent-dir cd
+    image parent-directory cd
     "git-log --pretty=format:%an" <process-stream> lines ;
 
 : patch-counts ( authors -- assoc )

extra/dlists/dlists-tests.factor

@@ -1,54 +0,0 @@
-IN: temporary
-USING: dlists kernel strings tools.test math ;
-
-[ "junk" ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ string? ] swap dlist-remove 
-] unit-test
-
-[ 5 20 ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ string? ] over dlist-remove drop
-  [ ] dlist-each
-] unit-test
-
-[ "junk" ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ integer? ] over dlist-remove drop
-  [ integer? ] over dlist-remove drop
-  [ ] dlist-each
-] unit-test
-
-[ t ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ string? ] swap dlist-contains?
-] unit-test
-
-[ t ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ integer? ] swap dlist-contains?
-] unit-test
-
-[ f ] [ 
-  <dlist> 
-  5 over dlist-push-end 
-  "junk" over dlist-push-end 
-  20 over dlist-push-end 
-  [ string? ] over dlist-remove drop
-  [ string? ] swap dlist-contains?
-] unit-test

extra/dlists/dlists.factor

@@ -1,100 +0,0 @@
-! Copyright (C) 2005 Mackenzie Straight.
-! See http://factorcode.org/license.txt for BSD license.
-IN: dlists
-USING: kernel math  ;
-
-! Double-linked lists.
-
-TUPLE: dlist first last ;
-
-: <dlist> dlist construct-empty ;
-
-TUPLE: dlist-node data prev next ;
-
-C: <dlist-node> dlist-node
-
-: dlist-push-end ( data dlist -- )
-    [ dlist-last f <dlist-node> ] keep
-    [ dlist-last [ dupd set-dlist-node-next ] when* ] keep
-    2dup set-dlist-last
-    dup dlist-first [ 2drop ] [ set-dlist-first ] if ;
-
-: dlist-empty? ( dlist -- ? )
-    dlist-first f = ;
-    
-: (unlink-prev) ( dlist dnode -- )
-    dup dlist-node-prev [
-        dupd swap dlist-node-next swap set-dlist-node-next
-    ] when*
-    2dup swap dlist-first eq? [ 
-        dlist-node-next swap set-dlist-first 
-    ] [ 2drop ] if ;
-
-: (unlink-next) ( dlist dnode -- )
-    dup dlist-node-next [
-        dupd swap dlist-node-prev swap set-dlist-node-prev
-    ] when*
-    2dup swap dlist-last eq? [
-        dlist-node-prev swap set-dlist-last
-    ] [ 2drop ] if ;
-
-: (dlist-unlink) ( dlist dnode -- )
-    [ (unlink-prev) ] 2keep (unlink-next) ;
-
-: (dlist-pop-front) ( dlist -- data )
-    [ dlist-first dlist-node-data ] keep dup dlist-first (dlist-unlink) ;
-
-: dlist-pop-front ( dlist -- data )
-    dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] if ;
-
-: (dlist-remove) ( dlist quot dnode -- obj/f )
-    [
-        [ dlist-node-data swap call ] 2keep rot [
-            swapd [ (dlist-unlink) ] keep dlist-node-data nip
-        ] [
-            dlist-node-next (dlist-remove)
-        ] if
-    ] [
-        2drop f
-    ] if* ; inline
-
-: dlist-remove ( quot dlist -- obj/f )
-    #! Return first item in the dlist that when passed to the
-    #! predicate quotation, true is left on the stack. The
-    #! item is removed from the dlist. The quotation
-    #! must have stack effect ( obj -- bool ).
-    #! TODO: needs a better name.
-    dup dlist-first swapd (dlist-remove) ; inline
-
-: (dlist-contains?) ( pred dnode -- bool )
-    [
-        [ dlist-node-data swap call ] 2keep rot [
-            2drop t
-        ] [
-            dlist-node-next (dlist-contains?)
-        ] if
-    ] [
-        drop f
-    ] if* ; inline
-
-: dlist-contains? ( quot dlist -- obj/f )
-    #! Return true if any item in the dlist that when passed to the
-    #! predicate quotation, true is left on the stack.
-    #! The 'pred' quotation must have stack effect ( obj -- bool ).
-    #! TODO: needs a better name.
-    dlist-first (dlist-contains?) ; inline
-
-: (dlist-each) ( quot dnode -- )
-    [
-        [ dlist-node-data swap call ] 2keep 
-        dlist-node-next (dlist-each)
-    ] [
-        drop
-    ] if* ; inline
-
-: dlist-each ( dlist quot -- )
-    swap dlist-first (dlist-each) ; inline
-
-: dlist-length ( dlist -- length )
-    0 swap [ drop 1+ ] dlist-each ;
-

extra/dlists/tags.txt

@@ -1 +0,0 @@
-collections

extra/editors/editors-docs.factor

@@ -4,8 +4,8 @@ IN: editors
 ARTICLE: "editor" "Editor integration"
 "Factor development is best done with one of the supported editors; this allows you to quickly jump to definitions from the Factor environment."
 { $subsection edit }
-"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } "."
+"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ", for example:"
-$nl
+{ $code "USE: editors.emacs" }
 "Editor integration vocabularies store a quotation in a global variable when loaded:"
 { $subsection edit-hook }
 "If a syntax error was thrown while loading a source file, you can jump to the location of the error in your editor:"

extra/gesture-logger/deploy.factor

@@ -1,13 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-word-props? t }
-    { strip-word-names? f }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
-    { strip-prettyprint? f }
+    { deploy-io 1 }
-    { "bundle-name" "Gesture Logger.app" }
+    { deploy-reflection 3 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Gesture Logger" }
 }

extra/golden-section/deploy.factor

@@ -1,17 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-io? t }
-    { strip-prettyprint? t }
-    { strip-globals? t }
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
     { "stop-after-last-window?" t }
-    { "bundle-name" "Golden Section.app" }
+    { deploy-name "Golden Section" }
 }

extra/heaps/heaps-tests.factor

@@ -1,32 +0,0 @@
-! 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

@@ -1,112 +0,0 @@
-! 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/hello-ui/deploy.factor

@@ -1,16 +1,13 @@
 USING: tools.deploy.config ;
-V{
+H{
-    { strip-prettyprint? t }
-    { strip-globals? t }
-    { strip-word-props? t }
-    { strip-word-names? f }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
     { deploy-math? t }
-    { deploy-compiled? t }
+    { deploy-reflection 2 }
-    { deploy-io? f }
+    { deploy-io 1 }
-    { deploy-ui? t }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
     { "stop-after-last-window?" t }
-    { "bundle-name" "Hello World.app" }
+    { deploy-ui? t }
+    { deploy-compiler? t }
+    { deploy-name "Hello world" }
+    { deploy-c-types? f }
 }

extra/hello-world/deploy.factor

@@ -1,15 +1,13 @@
 USING: tools.deploy.config ;
-V{
+H{
-    { strip-prettyprint? t }
-    { strip-globals? t }
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
     { deploy-math? f }
-    { deploy-compiled? f }
+    { deploy-word-defs? f }
-    { deploy-io? f }
+    { deploy-word-props? f }
-    { deploy-ui? f }
+    { deploy-name "Hello world (console)" }
     { "stop-after-last-window?" t }
+    { deploy-c-types? f }
+    { deploy-compiler? f }
+    { deploy-io 2 }
+    { deploy-ui? f }
+    { deploy-reflection 1 }
 }

extra/help/crossref/crossref.factor

@@ -14,7 +14,7 @@ M: link uses
     collect-elements [ \ f or ] map ;
 
 : help-path ( topic -- seq )
-    [ dup ] [ [ article-parent ] keep ] { } unfold 1 tail ;
+    [ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
 
 : set-article-parents ( parent article -- )
     article-children [ set-article-parent ] curry* each ;

extra/help/handbook/handbook.factor

@@ -122,12 +122,13 @@ ARTICLE: "collections" "Collections"
 { $heading "Associative mappings" }
 { $subsection "assocs" }
 { $subsection "namespaces" }
-{ $subsection "graphs" }
 "Implementations:"
 { $subsection "hashtables" }
 { $subsection "alists" }
 { $heading "Other collections" }
-{ $subsection "queues" }
+{ $subsection "dlists" }
+{ $subsection "heaps" }
+{ $subsection "graphs" }
 { $subsection "buffers" } ;
 
 USE: io.sockets

extra/help/markup/markup-docs.factor

@@ -100,7 +100,7 @@ HELP: $link
 { $values { "element" "a markup element of the form " { $snippet "{ topic }" } } }
 { $description "Prints a link to a help article or word." }
 { $examples
-    { $markup-example { $link "queues" } }
+    { $markup-example { $link "dlists" } }
     { $markup-example { $link + } }
 } ;
 
@@ -123,7 +123,7 @@ HELP: $see-also
 { $values { "topics" "a sequence of article names or words" } }
 { $description "Prints a heading followed by a series of links." }
 { $examples
-    { $markup-example { $see-also "graphs" "queues" } }
+    { $markup-example { $see-also "graphs" "dlists" } }
 } ;
 
 { $see-also $related related-words } related-words

extra/http/server/templating/templating.factor

@@ -88,7 +88,7 @@ DEFER: <% delimiter
     ] assert-depth drop ;
 
 : run-relative-template-file ( filename -- )
-    file get source-file-path parent-dir
+    file get source-file-path parent-directory
     swap path+ run-template-file ;
 
 : template-convert ( infile outfile -- )

extra/icfp/2006/2006.factor

@@ -4,7 +4,7 @@
 USING: kernel math sequences kernel.private namespaces arrays
 io io.files splitting io.binary math.functions vectors
 quotations combinators.private ;
-IN: universal-machine
+IN: icfp.2006
 
 SYMBOL: regs
 SYMBOL: arrays

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/io/sockets/impl/impl.factor

@@ -12,7 +12,10 @@ GENERIC: protocol-family ( addrspec -- af )
 
 GENERIC: sockaddr-type ( addrspec -- type )
 
-GENERIC: make-sockaddr ( addrspec -- sockaddr type )
+GENERIC: make-sockaddr ( addrspec -- sockaddr )
+
+: make-sockaddr/size ( addrspec -- sockaddr size )
+    dup make-sockaddr swap sockaddr-type heap-size ;
 
 GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
 
@@ -36,16 +39,15 @@ M: inet4 address-size drop 4 ;
 
 M: inet4 protocol-family drop PF_INET ;
 
-M: inet4 sockaddr-type drop "sockaddr-in" ;
+M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
 
-M: inet4 make-sockaddr ( inet -- sockaddr type )
+M: inet4 make-sockaddr ( inet -- sockaddr )
     "sockaddr-in" <c-object>
     AF_INET over set-sockaddr-in-family
     over inet4-port htons over set-sockaddr-in-port
     over inet4-host
     "0.0.0.0" or
-    rot inet-pton *uint over set-sockaddr-in-addr
+    rot inet-pton *uint over set-sockaddr-in-addr ;
-    "sockaddr-in" ;
 
 M: inet4 parse-sockaddr
     >r dup sockaddr-in-addr <uint> r> inet-ntop
@@ -65,15 +67,14 @@ M: inet6 address-size drop 16 ;
 
 M: inet6 protocol-family drop PF_INET6 ;
 
-M: inet6 sockaddr-type drop "sockaddr-in6" ;
+M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
 
-M: inet6 make-sockaddr ( inet -- sockaddr type )
+M: inet6 make-sockaddr ( inet -- sockaddr )
     "sockaddr-in6" <c-object>
     AF_INET6 over set-sockaddr-in6-family
     over inet6-port htons over set-sockaddr-in6-port
     over inet6-host "::" or
-    rot inet-pton over set-sockaddr-in6-addr
+    rot inet-pton over set-sockaddr-in6-addr ;
-    "sockaddr-in6" ;
 
 M: inet6 parse-sockaddr
     >r dup sockaddr-in6-addr r> inet-ntop
@@ -97,7 +98,7 @@ M: f parse-sockaddr nip ;
 : parse-addrinfo-list ( addrinfo -- seq )
     [ dup ]
     [ dup addrinfo-next swap addrinfo>addrspec ]
-    { } unfold [ ] subset ;
+    [ ] unfold nip [ ] subset ;
 
 M: object resolve-host ( host serv passive? -- seq )
     >r dup integer? [ number>string ] when

extra/io/unix/files/files-tests.factor

@@ -1,8 +1,8 @@
 USING: tools.test io.files ;
 IN: temporary
 
-[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-dir ] unit-test
+[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
-[ "/etc/" ] [ "/etc/passwd" parent-dir ] unit-test
+[ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test
-[ "/" ] [ "/etc/" parent-dir ] unit-test
+[ "/" ] [ "/etc/" parent-directory ] unit-test
-[ "/" ] [ "/etc" parent-dir ] unit-test
+[ "/" ] [ "/etc" parent-directory ] unit-test
-[ "/" ] [ "/" parent-dir ] unit-test
+[ "/" ] [ "/" parent-directory ] unit-test

extra/io/unix/sockets/sockets.factor

@@ -45,9 +45,9 @@ M: connect-task task-container drop write-tasks get-global ;
     [ swap <connect-task> add-io-task stop ] callcc0 drop ;
 
 M: unix-io (client) ( addrspec -- stream )
-    dup make-sockaddr >r >r
+    dup make-sockaddr/size >r >r
     protocol-family SOCK_STREAM socket-fd
-    dup r> r> heap-size connect
+    dup r> r> connect
     zero? err_no EINPROGRESS = or [
         dup init-client-socket
         dup handle>duplex-stream
@@ -92,7 +92,7 @@ USE: io.sockets
 : server-fd ( addrspec type -- fd )
     >r dup protocol-family r>  socket-fd
     dup init-server-socket
-    dup rot make-sockaddr heap-size bind
+    dup rot make-sockaddr/size bind
     zero? [ dup close (io-error) ] unless ;
 
 M: unix-io <server> ( addrspec -- stream )
@@ -190,20 +190,19 @@ M: send-task task-container drop write-tasks get ;
 
 M: unix-io send ( packet addrspec datagram -- )
     3dup check-datagram-send
-    [ >r make-sockaddr heap-size r> wait-send ] keep
+    [ >r make-sockaddr/size r> wait-send ] keep
     pending-error ;
 
 M: local protocol-family drop PF_UNIX ;
 
-M: local sockaddr-type drop "sockaddr-un" ;
+M: local sockaddr-type drop "sockaddr-un" c-type ;
 
 M: local make-sockaddr
     local-path
     dup length 1 + max-un-path > [ "Path too long" throw ] when
     "sockaddr-un" <c-object>
     AF_UNIX over set-sockaddr-un-family
-    dup sockaddr-un-path rot string>char-alien dup length memcpy
+    dup sockaddr-un-path rot string>char-alien dup length memcpy ;
-   "sockaddr-un" ;
 
 M: local parse-sockaddr
     drop

extra/io/windows/ce/ce.factor

@@ -153,7 +153,7 @@ M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
 
 : do-connect ( addrspec -- socket )
     [ tcp-socket dup ] keep
-    make-sockaddr heap-size
+    make-sockaddr/size
     f f f f windows.winsock:WSAConnect zero? [
         winsock-error-string throw
     ] unless ;
@@ -227,7 +227,7 @@ M: windows-ce-io send ( packet addrspec datagram -- )
     [ windows.winsock:set-WSABUF-len ] keep
     [ windows.winsock:set-WSABUF-buf ] keep
     
-    rot make-sockaddr heap-size
+    rot make-sockaddr/size
     >r >r 1 0 <uint> 0 r> r> f f 
     windows.winsock:WSASendTo zero? [
         winsock-error-string throw

extra/io/windows/nt/sockets/sockets.factor

@@ -29,8 +29,7 @@ TUPLE: ConnectEx-args port
     s* name* namelen* lpSendBuffer* dwSendDataLength*
     lpdwBytesSent* lpOverlapped* ptr* ;
 
-: init-connect ( sockaddr sockaddr-name ConnectEx -- )
+: init-connect ( sockaddr size ConnectEx -- )
-    >r heap-size r>
     [ set-ConnectEx-args-namelen* ] keep
     [ set-ConnectEx-args-name* ] keep
     f over set-ConnectEx-args-lpSendBuffer*
@@ -55,7 +54,7 @@ TUPLE: ConnectEx-args port
 M: windows-nt-io (client) ( addrspec -- duplex-stream )
     [
         \ ConnectEx-args construct-empty
-        over make-sockaddr pick init-connect
+        over make-sockaddr/size pick init-connect
         over tcp-socket over set-ConnectEx-args-s*
         dup ConnectEx-args-s* add-completion
         dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr*
@@ -229,9 +228,9 @@ TUPLE: WSASendTo-args port
         >r delegate port-handle delegate win32-file-handle r>
         set-WSASendTo-args-s*
     ] keep [
-        >r make-sockaddr >r
+        >r make-sockaddr/size >r
         malloc-byte-array dup free-always
-        r> heap-size r>
+        r> r>
         [ set-WSASendTo-args-iToLen* ] keep
         set-WSASendTo-args-lpTo*
     ] keep [

extra/io/windows/windows-tests.factor

@@ -1,14 +1,14 @@
 USING: io.files kernel tools.test ;
 IN: temporary
 
-[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-dir ] unit-test
+[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo\\" parent-dir ] unit-test
+[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo" parent-dir ] unit-test
+[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
 ! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
-[ "c:\\" ] [ "c:\\" parent-dir ] unit-test
+[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
-[ "Z:\\" ] [ "Z:\\" parent-dir ] unit-test
+[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
-[ "c:" ] [ "c:" parent-dir ] unit-test
+[ "c:" ] [ "c:" parent-directory ] unit-test
-[ "Z:" ] [ "Z:" parent-dir ] unit-test
+[ "Z:" ] [ "Z:" parent-directory ] unit-test
 [ t ] [ "c:\\" root-directory? ] unit-test
 [ t ] [ "Z:\\" root-directory? ] unit-test
 [ f ] [ "c:\\foo" root-directory? ] unit-test

extra/io/windows/windows.factor

@@ -175,7 +175,7 @@ USE: windows.winsock
 : server-fd ( addrspec type -- fd )
     >r dup protocol-family r> open-socket
         dup close-socket-later
-    dup rot make-sockaddr heap-size bind socket-error ;
+    dup rot make-sockaddr/size bind socket-error ;
 
 USE: namespaces
 

extra/lint/tags.txt

@@ -1 +0,0 @@
-lint refactor

extra/lsys/summary.txt

@@ -1 +1 @@
-L-system explorer
+Lindenmayer system explorer

extra/lsys/ui/deploy.factor

@@ -1,13 +1,13 @@
-USING: tools.deploy ;
+USING: tools.deploy.config ;
 V{
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
-    { "bundle-name" "Lindenmayer Systems.app" }
+    { deploy-io 1 }
+    { deploy-reflection 2 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? t }
+    { deploy-word-defs? t }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Lindenmayer System Explorer" }
 }

extra/mad/api/api.factor

@@ -52,7 +52,6 @@ VARS: buffer-start buffer-length output-callback-var ;
 
 : output ( data header pcm -- mad_flow ) 
   "output" . flush
-  break
   -rot 2drop output-callback-var> call
   [ MAD_FLOW_CONTINUE ] [ MAD_FLOW_STOP ] if ;
 

extra/mad/player/player.factor

@@ -47,7 +47,6 @@ VARS: openal-buffer ;
   malloc [ fill-data ] keep ;
 
 : output-openal ( pcm -- ? )
-  break
   openal-buffer> swap     ! buffer pcm
   [ get-format ] keep     ! buffer format pcm
   [ get-data ] keep       ! buffer format size alien pcm

extra/math/quadratic/quadratic.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.functions ;
-IN: quadratic
+IN: math.quadratic
 
 : monic ( c b a -- c' b' ) tuck / >r / r> ;
 

extra/maze/deploy.factor

@@ -1,13 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-word-props? t }
-    { strip-word-names? f }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
-    { "bundle-name" "Maze.app" }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Maze" }
 }

extra/models/models-tests.factor

@@ -1,6 +1,6 @@
 IN: temporary
-USING: arrays generic kernel math models namespaces sequences
+USING: arrays generic kernel math models namespaces sequences assocs
-tools.test assocs ;
+tools.test ;
 
 TUPLE: model-tester hit? ;
 
@@ -137,3 +137,38 @@ f <history> "history" set
 ] unit-test
 
 [ ] [ "m" get deactivate-model ] unit-test
+
+! Test <range> 
+: setup-range 0 0 0 255 <range> ;
+
+! clamp-value should not go past range ends
+[ 0   ] [ -10 setup-range clamp-value ] unit-test
+[ 255 ] [ 2000 setup-range clamp-value ] unit-test
+[ 14  ] [ 14 setup-range clamp-value ] unit-test
+
+! range min/max/page values should be correct
+[ 0 ] [ setup-range range-page-value ] unit-test
+[ 0 ] [ setup-range range-min-value ] unit-test
+[ 255 ] [ setup-range range-max-value ] unit-test
+
+! should be able to set the value within the range and get back
+[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
+[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
+[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
+
+! should be able to change the range min/max/page value
+[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
+[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
+[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
+
+! should be able to move by positive and negative values
+[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
+[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
+
+! should be able to move by a page of 10
+[ 10 ] [ 
+  setup-range 10 over set-range-page-value 
+  1 over move-by-page range-value 
+] unit-test
+
+

extra/models/models.factor

@@ -207,7 +207,8 @@ M: range range-max-value range-max model-value ;
 M: range range-max-value*
     dup range-max-value swap range-page-value [-] ;
 
-M: range set-range-value range-model set-model ;
+M: range set-range-value
+    [ clamp-value ] keep range-model set-model ;
 
 M: range set-range-page-value range-page set-model ;
 

extra/nehe/deploy.factor

@@ -1,13 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
-    { "bundle-name" "NeHe Demos.app" }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "NeHe OpenGL demos" }
 }

extra/opengl/opengl.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! Portions copyright (C) 2007 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types io kernel math namespaces
+USING: alien alien.c-types kernel math namespaces sequences
-sequences math.vectors math.constants math.functions opengl.gl opengl.glu combinators arrays ;
+math.vectors math.constants math.functions opengl.gl opengl.glu
+combinators arrays ;
 IN: opengl
 
 : coordinates [ first2 ] 2apply ;
@@ -19,7 +20,7 @@ IN: opengl
 
 : gl-error ( -- )
     glGetError dup zero? [
-        "GL error: " write dup gluErrorString print flush
+        "GL error: " dup gluErrorString append throw
     ] unless drop ;
 
 : do-state ( what quot -- )

extra/random/random-docs.factor

@@ -21,3 +21,11 @@ HELP: random
 { $values { "seq" "a sequence" } { "elt" "a random element" } }
 { $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." }
 { $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ;
+
+HELP: big-random
+{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $description "Outputs an integer with n bytes worth of bits." } ;
+
+HELP: random-256
+{ $values { "r" "a random integer" } }
+{ $description "Outputs an random integer 256 bits in length." } ;

extra/random/random.factor

@@ -93,6 +93,8 @@ PRIVATE>
 : big-random ( n -- r )
     [ drop (random) ] map >c-uint-array byte-array>bignum ;
 
+: random-256 ( -- r ) 8 big-random ; inline
+
 : random ( seq -- elt )
     dup empty? [
         drop f

extra/sequences/lib/lib-tests.factor

@@ -33,3 +33,9 @@ math.functions tools.test ;
 [ { 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
+[ f ] [ { } singleton? ] unit-test
+[ t ] [ { "asdf" } singleton? ] unit-test
+[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test
+
+[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
+[ V{ } [ delete-random drop ] keep length ] unit-test-fails

extra/sequences/lib/lib.factor

@@ -1,6 +1,5 @@
 USING: combinators.lib kernel sequences math namespaces
-sequences.private shuffle ;
+random sequences.private shuffle ;
-
 IN: sequences.lib
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -61,3 +60,5 @@ IN: sequences.lib
 : singleton? ( seq -- ? )
     length 1 = ;
 
+: delete-random ( seq -- value )
+    [ length random ] keep [ nth ] 2keep delete-nth ;

extra/serialize/serialize.factor

@@ -261,7 +261,7 @@ DEFER: (deserialize) ( -- obj )
     V{ } clone serialized rot with-variable ; inline
 
 : deserialize-sequence ( -- seq )
-    [ [ deserialize* ] [ ] { } unfold ] with-serialized ;
+    [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ;
 
 : deserialize ( -- obj )
     [ (deserialize) ] with-serialized ;

extra/springies/models/belt-tire/deploy.factor

@@ -0,0 +1,13 @@
+USING: tools.deploy.config ;
+V{
+    { deploy-ui? t }
+    { deploy-io 2 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { "bundle-name" "Belt Tire.app" }
+}

extra/tetris/deploy.factor

@@ -1,13 +1,12 @@
 USING: tools.deploy.config ;
 V{
-    { strip-word-props? t }
-    { strip-word-names? t }
-    { strip-dictionary? t }
-    { strip-debugger? t }
-    { strip-c-types? t }
-    { deploy-math? t }
-    { deploy-compiled? t }
-    { deploy-io? f }
     { deploy-ui? t }
-    { "bundle-name" "Tetris.app" }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Tetris" }
 }

extra/tools/deploy/config/config-docs.factor

@@ -9,10 +9,11 @@ ARTICLE: "deploy-config" "Deployment configuration"
 { $subsection deploy-config }
 { $subsection set-deploy-config }
 "A utility word is provided to load the configuration, change a flag, and store it back to disk:"
-{ $subsection set-deploy-flag } ;
+{ $subsection set-deploy-flag }
+"The " { $link "ui.tools.deploy" } " provides a graphical way of editing the configuration." ;
 
 ARTICLE: "deploy-flags" "Deployment flags"
-"There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:"
+"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
 { $subsection deploy-math?     }
 { $subsection deploy-compiler? }
 { $subsection deploy-ui?       }
@@ -29,15 +30,36 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application"
 
 ABOUT: "prepare-deploy"
 
+HELP: deploy-name
+{ $description "Deploy setting. The name of the executable."
+$nl
+"On Mac OS X, this becomes the name of the application bundle, with " { $snippet ".app" } " appended. On Windows, this becomes the name of the directory containing the executable." } ;
+
 HELP: deploy-word-props?
 { $description "Deploy flag. If set, the deploy tool retains all word properties. Otherwise, it applies various heuristics to strip out un-needed word properties from words in the dictionary."
 $nl
 "Off by default. Enable this if the heuristics strip out required word properties." } ;
 
-HELP: deploy-c-types?
+HELP: deploy-word-defs?
-{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table."
+{ $description "Deploy flag. If set, the deploy tool retains word definition quotations for words compiled with the optimizing compiler. Otherwise, word definitions are stripped from words compiled with the optimizing compiler."
 $nl
-"Off by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link <c-object> } ", " { $link <c-array> } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ;
+"Off by default. During normal execution, the word definition quotation of a word compiled with the optimizing compiler is not used, so disabling this flag can save space. However, some libraries introspect word definitions dynamically (for example, " { $link "inverse" } ") and so programs using these libraries must retain word definition quotations." } ;
+
+HELP: deploy-c-types?
+{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table, otherwise this table is stripped out, saving space."
+$nl
+"Off by default."
+$nl
+"The optimizing compiler is able to fold away calls to various words which take a C type as an input if the C type is a literal string:"
+{ $list
+    { $link c-type }
+    { $link heap-size }
+    { $link <c-object> }
+    { $link <c-array> }
+    { $link malloc-object }
+    { $link malloc-array }
+}
+"If your program looks up C types dynamically or from words which do not have a stack effect, you must enable this flag, because in these situations the C type lookup is not folded away and the global table must be consulted at runtime." } ;
 
 HELP: deploy-math?
 { $description "Deploy flag. If set, the deployed image will contain support for " { $link ratio } " and " { $link complex } " types."
@@ -45,7 +67,7 @@ $nl
 "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
 
 HELP: deploy-compiler?
-{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible."
+{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
 $nl
 "On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
 
@@ -55,14 +77,31 @@ $nl
 "Off by default. Programs wishing to use the UI must be deployed with this flag on." } ;
 
 HELP: deploy-io
-{ $description "The level of I/O support required by the deployed image." } ;
+{ $description "The level of I/O support required by the deployed image:"
+    { $table
+        { "Value" "Description" }
+        { "1" "No input/output" }
+        { "2" "Basic ANSI C streams" }
+        { "3" "Non-blocking streams and networking" }
+    }
+"The default value is 1, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such are not available." } ;
 
 HELP: deploy-reflection
-{ $description "The level of reflection support required by the deployed image." } ;
+{ $description "The level of reflection support required by the deployed image."
+    { $table
+        { "Value" "Description" }
+        { "1" "No reflection" }
+        { "2" "Retain word names" }
+        { "3" "Prettyprinter" }
+        { "4" "Debugger" }
+        { "5" "Parser" }
+        { "6" "Full environment" }
+    }
+"The defalut value is 1, no reflection. Programs which use the above features will need to be deployed with a higher level of reflection support." } ;
 
 HELP: default-config
-{ $values { "assoc" assoc } }
+{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
-{ $description "Outputs the default deployment configuration." } ;
+{ $description "Outputs the default deployment configuration for a vocabulary." } ;
 
 HELP: deploy-config
 { $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }

extra/tools/deploy/config/config.factor

@@ -1,9 +1,12 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: vocabs.loader io.files io kernel sequences assocs
-splitting parser prettyprint namespaces math ;
+splitting parser prettyprint namespaces math vocabs
+hashtables ;
 IN: tools.deploy.config
 
+SYMBOL: deploy-name
+
 SYMBOL: deploy-ui?
 SYMBOL: deploy-compiler?
 SYMBOL: deploy-math?
@@ -17,7 +20,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 = ;
 
@@ -40,29 +43,31 @@ SYMBOL: deploy-reflection
 : strip-globals? deploy-reflection get 6 < ;
 
 SYMBOL: deploy-word-props?
+SYMBOL: deploy-word-defs?
 SYMBOL: deploy-c-types?
 
 SYMBOL: deploy-vm
 SYMBOL: deploy-image
 
-: default-config ( -- assoc )
+: default-config ( vocab -- assoc )
-    V{
+    vocab-name deploy-name associate H{
         { deploy-ui?                f }
         { deploy-io                 2 }
         { deploy-reflection         1 }
         { deploy-compiler?          t }
         { deploy-math?              t }
         { deploy-word-props?        f }
+        { deploy-word-defs?         f }
         { deploy-c-types?           f }
-        ! default value for deploy.app
+        ! default value for deploy.macosx
         { "stop-after-last-window?" t }
-    } clone ;
+    } union ;
 
 : deploy-config-path ( vocab -- string )
     vocab-dir "deploy.factor" path+ ;
 
 : deploy-config ( vocab -- assoc )
-    default-config swap
+    dup default-config swap
     dup deploy-config-path vocab-file-contents
     parse-fresh dup empty? [ drop ] [ first union ] if ;
 

extra/tools/deploy/deploy-docs.factor

@@ -2,16 +2,20 @@ USING: help.markup help.syntax words alien.c-types assocs
 kernel ;
 IN: tools.deploy
 
-ARTICLE: "tools.deploy" "Stand-alone image deployment"
+ARTICLE: "tools.deploy" "Application deployment"
-"The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook."
+"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
 $nl
 "For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
-{ $code "\"hello-world\" deploy" }
+{ $code "\"hello-ui\" deploy" }
-"This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):"
+"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message."
-{ $code "./factor -i=hello-world.image" "Hello world" }
+$nl
-
+"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
-"Once the necessary deployment flags have been set, a deployment image can be generated:"
+$nl
-{ $subsection deploy } ;
+"You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment."
+{ $subsection "prepare-deploy" }
+"Once the necessary deployment flags have been set, the application can be deployed:"
+{ $subsection deploy }
+{ $see-also "ui.tools.deploy" } ;
 
 ABOUT: "tools.deploy"
 

extra/tools/deploy/deploy.factor

@@ -5,25 +5,30 @@ 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 io.launcher words.private tools.deploy.config ;
+quotations io.launcher words.private tools.deploy.config
+bootstrap.image ;
 IN: tools.deploy
 
 <PRIVATE
 
+: boot-image-name ( -- string )
+    "boot." my-arch ".image" 3append ;
+
+: stage1 ( -- )
+    #! If stage1 image doesn't exist, create one.
+    boot-image-name resource-path exists?
+    [ my-arch make-image ] unless ;
+
 : (copy-lines) ( stream -- stream )
     dup stream-readln [ print flush (copy-lines) ] when* ;
 
 : copy-lines ( stream -- )
     [ (copy-lines) ] [ stream-close ] [ ] cleanup ;
 
-: boot-image-name ( -- string )
-    cpu dup "ppc" = [ os "-" rot 3append ] when ;
-
 : stage2 ( vm flags -- )
 	[
-        "\"" % swap % "\" -i=boot." %
+        "\"" % swap % "\" -i=" %
-        boot-image-name
+        boot-image-name %
-        % ".image" %
         [ " " % % ] each
     ] "" make
     dup print <process-stream>
@@ -37,8 +42,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 )
@@ -57,8 +62,12 @@ IN: tools.deploy
 PRIVATE>
 
 : deploy* ( vm image vocab config -- )
-    deploy-command-line stage2 ;
+    stage1 deploy-command-line stage2 ;
 
-: deploy ( vocab -- )
+SYMBOL: deploy-implementation
-    "" resource-path cd
+
-    vm over ".image" append rot dup deploy-config deploy* ;
+HOOK: deploy deploy-implementation ( vocab -- )
+
+USE-IF: macosx? tools.deploy.macosx
+
+USE-IF: winnt? tools.deploy.windows

extra/tools/deploy/macosx/macosx.factor

@@ -3,10 +3,7 @@
 USING: io io.files io.launcher kernel namespaces sequences
 system cocoa.plists cocoa.application tools.deploy
 tools.deploy.config assocs hashtables prettyprint ;
-IN: tools.deploy.app
+IN: tools.deploy.macosx
-
-: mkdir ( path -- )
-    "mkdir -p \"" swap "\"" 3append run-process ;
 
 : touch ( path -- )
     "touch \"" swap "\"" 3append run-process ;
@@ -14,22 +11,24 @@ IN: tools.deploy.app
 : rm ( path -- )
     "rm -rf \"" swap "\"" 3append run-process ;
 
-: cp ( from to -- )
+: chmod ( path perms -- )
-    "Copying " write over write " to " write dup print
+    [ "chmod " % % " \"" % % "\"" % ] "" make run-process ;
-    dup parent-dir mkdir
+
-    [ "cp -R \"" % swap % "\" \"" % % "\"" % ] "" make
+: bundle-dir ( -- dir )
-    run-process ;
+    vm parent-directory parent-directory ;
 
 : copy-bundle-dir ( name dir -- )
-    vm parent-dir parent-dir over path+ -rot
+    bundle-dir over path+ -rot
-    >r "Contents" path+ r> path+ cp ;
+    >r "Contents" path+ r> path+ copy-directory ;
 
 : copy-vm ( executable bundle-name -- vm )
-    "Contents/MacOS/" path+ swap path+ vm swap [ cp ] keep ;
+    "Contents/MacOS/" path+ swap path+ vm swap
+    [ copy-file ] keep
+    [ "755" chmod ] keep ;
 
 : copy-fonts ( name -- )
     "fonts/" resource-path
-    swap "Contents/Resources/fonts/" path+ cp ;
+    swap "Contents/Resources/fonts/" path+ copy-directory ;
 
 : print-app-plist ( executable bundle-name -- )
     [
@@ -57,16 +56,19 @@ IN: tools.deploy.app
 : deploy.app-image ( vocab bundle-name -- str )
     [ % "/Contents/Resources/" % % ".image" % ] "" make ;
 
-: deploy.app-config ( vocab -- assoc )
+: bundle-name ( -- string )
-    [ ".app" append "bundle-name" associate ] keep
+    deploy-name get ".app" append ;
-    deploy-config union ;
 
-: deploy.app ( vocab -- )
+TUPLE: macosx-deploy-implementation ;
+
+T{ macosx-deploy-implementation } deploy-implementation set-global
+
+M: macosx-deploy-implementation deploy ( vocab -- )
     ".app deploy tool" assert.app
     "." resource-path cd
-    dup deploy.app-config [
+    dup deploy-config [
-        "bundle-name" get rm
+        bundle-name rm
-        [ "bundle-name" get create-app-dir ] keep
+        [ bundle-name create-app-dir ] keep
-        [ "bundle-name" get deploy.app-image ] keep
+        [ bundle-name deploy.app-image ] keep
         namespace
     ] bind deploy* ;