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

core/definitions/definitions.factor

@@ -43,7 +43,7 @@ M: object uses drop f ;
 
 : xref ( defspec -- ) dup uses crossref get add-vertex ;
 
-: usage ( defspec -- seq ) crossref get at keys ;
+: usage ( defspec -- seq ) \ f or crossref get at keys ;
 
 GENERIC: redefined* ( defspec -- )
 

core/generic/generic.factor

@@ -102,11 +102,13 @@ M: method-body stack-effect
 
 ! Definition protocol
 M: method-spec where
-    dup first2 method [ method-loc ] [ second where ] ?if ;
+    dup first2 method [ method-word ] [ second ] ?if where ;
 
-M: method-spec set-where first2 method set-method-loc ;
+M: method-spec set-where
+    first2 method method-word set-where ;
 
-M: method-spec definer drop \ M: \ ; ;
+M: method-spec definer
+    drop \ M: \ ; ;
 
 M: method-spec definition
     first2 method dup [ method-def ] when ;
@@ -114,9 +116,21 @@ M: method-spec definition
 : forget-method ( class generic -- )
     check-method
     [ delete-at* ] with-methods
-    [ method-word forget ] [ drop ] if ;
+    [ method-word forget-word ] [ drop ] if ;
 
-M: method-spec forget* first2 forget-method ;
+M: method-spec forget*
+    first2 forget-method ;
+
+M: method-body definer
+    drop \ M: \ ; ;
+
+M: method-body definition
+    "method" word-prop method-def ;
+
+M: method-body forget*
+    "method" word-prop
+    { method-specializer method-generic } get-slots
+    forget-method ;
 
 : implementors* ( classes -- words )
     all-words [

core/heaps/heaps-tests.factor

@@ -15,8 +15,8 @@ IN: temporary
 
 ! Binary Min Heap
 { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
-{ t } [ t 5 <entry> t 3 <entry> T{ min-heap } heap-compare ] unit-test
+{ t } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
-{ f } [ t 5 <entry> t 3 <entry> T{ max-heap } heap-compare ] unit-test
+{ f } [ t 5 f <entry> t 3 f <entry> T{ max-heap } heap-compare ] 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
 

core/heaps/heaps.factor

@@ -22,9 +22,9 @@ GENERIC: heap-size ( heap -- n )
 : <heap> ( class -- heap )
     >r V{ } clone r> construct-delegate ; inline
 
-TUPLE: entry value key index ;
+TUPLE: entry value key heap index ;
 
-: <entry> ( value key -- entry ) f entry construct-boa ;
+: <entry> ( value key heap -- entry ) f entry construct-boa ;
 
 PRIVATE>
 
@@ -153,7 +153,7 @@ DEFER: down-heap
 PRIVATE>
 
 M: priority-queue heap-push* ( value key heap -- entry )
-    >r <entry> dup r> [ data-push ] keep up-heap ;
+    [ <entry> dup ] keep [ data-push ] keep up-heap ;
 
 : heap-push ( value key heap -- ) heap-push* drop ;
 
@@ -166,8 +166,14 @@ M: priority-queue heap-push* ( value key heap -- entry )
 M: priority-queue heap-peek ( heap -- value key )
     data-first >entry< ;
 
+: entry>index ( entry heap -- n )
+    over entry-heap eq? [
+        "Invalid entry passed to heap-delete" throw
+    ] unless
+    entry-index ;
+
 M: priority-queue heap-delete ( entry heap -- )
-    >r entry-index r>
+    [ entry>index ] keep
     2dup heap-size 1- = [
         nip data-pop*
     ] [

core/parser/parser-tests.factor

@@ -351,13 +351,18 @@ IN: temporary
     << file get parsed >> file set
 
     : ~a ;
-    : ~b ~a ;
+
+    DEFER: ~b
+
+    "IN: temporary : ~b ~a ;" <string-reader>
+    "smudgy" parse-stream drop
+
     : ~c ;
     : ~d ;
 
-    { H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
+    { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
     
-    { H{ { ~d ~d } } H{ } } new-definitions set
+    { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
     
     [ V{ ~b } { ~a } { ~a ~c } ] [
         smudged-usage
@@ -365,6 +370,24 @@ IN: temporary
     ] unit-test
 ] with-scope
 
+[
+    << file get parsed >> file set
+
+    GENERIC: ~e
+
+    : ~f ~e ;
+
+    : ~g ;
+
+    { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
+    
+    { H{ { ~g ~g } } H{ } } new-definitions set
+
+    [ V{ } { } { ~e ~f } ]
+    [ smudged-usage natural-sort ]
+    unit-test
+] with-scope
+
 [ ] [
     "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
 ] unit-test

core/parser/parser.factor

@@ -439,11 +439,12 @@ SYMBOL: interactive-vocabs
         "Warning: the following definitions were removed from sources," print
         "but are still referenced from other definitions:" print
         nl
-        dup stack.
+        dup sorted-definitions.
         nl
         "The following definitions need to be updated:" print
         nl
-        over stack.
+        over sorted-definitions.
+        nl
     ] when 2drop ;
 
 : filter-moved ( assoc -- newassoc )

core/prettyprint/prettyprint.factor

@@ -174,6 +174,12 @@ M: hook-generic synopsis*
 M: method-spec synopsis*
     dup definer. [ pprint-word ] each ;
 
+M: method-body synopsis*
+    dup definer.
+    "method" word-prop dup
+    method-specializer pprint*
+    method-generic pprint* ;
+
 M: mixin-instance synopsis*
     dup definer.
     dup mixin-instance-class pprint-word
@@ -188,6 +194,15 @@ M: pathname synopsis* pprint* ;
         [ synopsis* ] with-in
     ] with-string-writer ;
 
+: synopsis-alist ( definitions -- alist )
+    [ dup synopsis swap ] { } map>assoc ;
+
+: definitions. ( alist -- )
+    [ write-object nl ] assoc-each ;
+
+: sorted-definitions. ( definitions -- )
+    synopsis-alist sort-keys definitions. ;
+
 GENERIC: declarations. ( obj -- )
 
 M: object declarations. drop ;
@@ -253,7 +268,9 @@ M: builtin-class see-class*
     natural-sort [ nl see ] each ;
 
 : see-implementors ( class -- seq )
-    dup implementors [ 2array ] with map ;
+    dup implementors
+    [ method method-word ] with map
+    natural-sort ;
 
 : see-class ( class -- )
     dup class? [
@@ -263,8 +280,9 @@ M: builtin-class see-class*
     ] when drop ;
 
 : see-methods ( generic -- seq )
-    [ "methods" word-prop keys natural-sort ] keep
+    "methods" word-prop
-    [ 2array ] curry map ;
+    [ nip method-word ] { } assoc>map
+    natural-sort ;
 
 M: word see
     dup see-class

core/sequences/sequences.factor

@@ -310,13 +310,11 @@ M: immutable-sequence clone-like like ;
 
 <PRIVATE
 
-: iterate-seq >r dup length swap r> ; inline
-
 : (each) ( seq quot -- n quot' )
-    iterate-seq [ >r nth-unsafe r> call ] 2curry ; inline
+    >r dup length swap [ nth-unsafe ] curry r> compose ; inline
 
 : (collect) ( quot into -- quot' )
-    [ >r over slip r> set-nth-unsafe ] 2curry ; inline
+    [ >r keep r> set-nth-unsafe ] 2curry ; inline
 
 : collect ( n quot into -- )
     (collect) each-integer ; inline
@@ -415,7 +413,7 @@ PRIVATE>
     >r dup length 1- swap r> (monotonic) all? ; inline
 
 : interleave ( seq between quot -- )
-    [ (interleave) ] 2curry iterate-seq 2each ; inline
+    [ (interleave) ] 2curry >r dup length swap r> 2each ; inline
 
 : unfold ( pred quot tail -- seq )
     V{ } clone [
@@ -695,9 +693,9 @@ PRIVATE>
 
 : sequence-hashcode-step ( oldhash newpart -- newhash )
     swap [
-        dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
+        dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
         fixnum+fast fixnum+fast
-    ] keep bitxor ; inline
+    ] keep fixnum-bitxor ; inline
 
 : sequence-hashcode ( n seq -- x )
     0 -rot [

core/source-files/source-files.factor

@@ -97,16 +97,8 @@ SYMBOL: file
         [ ] [ file get rollback-source-file ] cleanup
     ] with-scope ; inline
 
-: smart-usage ( word -- definitions )
-    \ f or usage [
-        dup method-body? [
-            "method" word-prop
-            { method-specializer method-generic } get-slots
-            2array
-        ] when
-    ] map ;
-
 : outside-usages ( seq -- usages )
     dup [
-        over smart-usage [ pathname? not ] subset seq-diff
+        over usage
+        [ dup pathname? not swap where and ] subset seq-diff
     ] curry { } map>assoc ;

extra/alarms/alarms-docs.factor

@@ -14,14 +14,14 @@ HELP: later
 
 HELP: cancel-alarm
 { $values { "alarm" alarm } }
-{ $description "Cancels an alarm." }
+{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
-{ $errors "Throws an error if the alarm is not active." } ;
 
 ARTICLE: "alarms" "Alarms"
 "Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
 { $subsection alarm }
 { $subsection add-alarm }
 { $subsection later }
-{ $subsection cancel-alarm } ;
+{ $subsection cancel-alarm }
+"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
 
 ABOUT: "alarms"

extra/alarms/alarms.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays calendar combinators generic init kernel math
-namespaces sequences heaps boxes threads debugger quotations ;
+namespaces sequences heaps boxes threads debugger quotations
+assocs ;
 IN: alarms
 
 TUPLE: alarm quot time interval entry ;
@@ -55,20 +56,23 @@ SYMBOL: alarm-thread
 : trigger-alarms ( alarms -- )
     now (trigger-alarms) ;
 
-: next-alarm ( alarms -- ms )
+: next-alarm ( alarms -- timestamp/f )
     dup heap-empty?
-    [ drop f ]
+    [ drop f ] [ heap-peek drop alarm-time ] if ;
-    [ heap-peek drop alarm-time now timestamp- 1000 * 0 max ]
-    if ;
 
 : alarm-thread-loop ( -- )
     alarms get-global
-    dup next-alarm nap drop
+    dup next-alarm nap-until drop
     dup trigger-alarms
     alarm-thread-loop ;
 
+: cancel-alarms ( alarms -- )
+    [
+        heap-pop-all [ nip alarm-entry box> drop ] assoc-each
+    ] when* ;
+
 : init-alarms ( -- )
-    <min-heap> alarms set-global
+    alarms global [ cancel-alarms <min-heap> ] change-at
     [ alarm-thread-loop ] "Alarms" spawn
     alarm-thread set-global ;
 
@@ -83,4 +87,5 @@ PRIVATE>
     from-now f add-alarm ;
 
 : cancel-alarm ( alarm -- )
-    alarm-entry box> alarms get-global heap-delete ;
+    alarm-entry ?box
+    [ alarms get-global heap-delete ] [ drop ] if ;

extra/benchmark/sockets/sockets.factor

@@ -34,10 +34,10 @@ IN: benchmark.sockets
 : socket-benchmarks
     10 clients
     20 clients
-    40 clients
+    40 clients ;
-    80 clients
+    ! 80 clients
-    160 clients
+    ! 160 clients
-    320 clients
+    ! 320 clients
-    640 clients ;
+    ! 640 clients ;
 
 MAIN: socket-benchmarks

extra/builder/builder.factor

@@ -2,21 +2,15 @@
 USING: kernel namespaces sequences splitting system combinators continuations
        parser io io.files io.launcher io.sockets prettyprint threads
        bootstrap.image benchmark vars bake smtp builder.util accessors
-       builder.benchmark ;
+       calendar
+       builder.common
+       builder.benchmark
+       builder.release ;
 
 IN: builder
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-SYMBOL: builds-dir
-
-: builds ( -- path )
-  builds-dir get
-  home "/builds" append
-  or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 : prepare-build-machine ( -- )
   builds make-directory
   builds cd
@@ -32,8 +26,6 @@ SYMBOL: builds-dir
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-VAR: stamp
-
 : enter-build-dir ( -- )
   datestamp >stamp
   builds cd
@@ -89,7 +81,7 @@ VAR: stamp
     +closed+      >>stdin
     "../boot-log" >>stdout
     +stdout+      >>stderr
-    20 minutes>ms >>timeout
+    20 minutes    >>timeout
   >desc ;
 
 : builder-test-cmd ( -- cmd )
@@ -101,7 +93,7 @@ VAR: stamp
     +closed+         >>stdin
     "../test-log"    >>stdout
     +stdout+         >>stderr
-    45 minutes>ms    >>timeout
+    45 minutes       >>timeout
   >desc ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -225,7 +217,7 @@ USE: bootstrap.image.download
   ]
   [ drop ]
   recover
-  5 minutes>ms sleep
+  5 minutes sleep
   build-loop ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/builder/common/common.factor

@@ -0,0 +1,18 @@
+
+USING: kernel namespaces io.files sequences vars ;
+
+IN: builder.common
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builds-dir
+
+: builds ( -- path )
+  builds-dir get
+  home "/builds" append
+  or ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: stamp
+

extra/builder/release/release.factor

@@ -0,0 +1,117 @@
+
+USING: kernel namespaces sequences combinators io.files io.launcher
+       combinators.cleave builder.common builder.util ;
+
+IN: builder.release
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: releases ( -- path ) builds "/releases" append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: common-files ( -- seq )
+  {
+    "boot.x86.32.image"
+    "boot.x86.64.image"
+    "boot.macosx-ppc.boot"
+    "vm"
+    "temp"
+    "logs"
+    ".git"
+    ".gitignore"
+    "Makefile"
+    "cp_dir"
+    "unmaintained"
+    "misc/target"
+    "misc/wordsize"
+    "misc/wordsize.c"
+    "misc/macos-release.sh"
+    "misc/source-release.sh"
+    "misc/windows-release.sh"
+    "misc/version.sh"
+  } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: system sequences splitting ;
+
+: cpu- ( -- cpu ) cpu "." split "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: extension ( -- extension )
+  os
+  {
+    { "linux" [ ".tar.gz" ] }
+    { "winnt" [ ".zip" ] }
+    { "macosx" [ ".dmg" ] }
+  }
+  case ;
+
+: archive-name ( -- string ) base-name extension append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-file ( source destination -- ) swap { "mv" , , } run-process drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: linux-release ( -- )
+
+  { "rm" "-rf" "Factor.app" } run-process drop
+
+  { "rm" "-rf" common-files } to-strings run-process drop
+
+  ".." cd
+
+  { "tar" "-cvzf" archive-name "factor" } to-strings run-process drop
+
+  archive-name releases move-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: windows-release ( -- )
+
+  { "rm" "-rf" "Factor.app" } run-process drop
+
+  { "rm" "-rf" common-files } to-strings run-process drop
+
+  ".." cd
+
+  { "zip" "-r" archive-name "factor" } to-strings run-process drop
+
+  archive-name releases move-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: macosx-release ( -- )
+
+  { "rm" "-rf" common-files } to-strings run-process drop
+
+  ".." cd
+
+  { "hdiutil" "create"
+              "-srcfolder" "factor"
+              "-fs" "HFS+"
+              "-volname" "factor"
+              archive-name }
+  to-strings run-process drop
+
+  archive-name releases move-file ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: release ( -- )
+  os
+    {
+      { "linux"  [ linux-release   ] }
+      { "winnt"  [ windows-release ] }
+      { "macosx" [ macosx-release  ] }
+    }
+  case ;
+  

extra/combinators/cleave/cleave.factor

@@ -1,5 +1,5 @@
 
-USING: kernel ;
+USING: kernel sequences macros ;
 
 IN: combinators.cleave
 
@@ -19,6 +19,22 @@ IN: combinators.cleave
 
 : 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! General cleave
+
+MACRO: cleave ( seq -- )
+  dup
+    [ drop [ dup ] ] map concat
+  swap
+  dup
+    [ drop [ >r ] ]  map concat
+  swap
+    [ [ r> ] append ] map concat
+  3append
+    [ drop ]
+  append ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! The spread family
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -30,3 +46,14 @@ IN: combinators.cleave
 
 : tetra* ( obj obj obj obj quot quot quot quot -- val val val val )
   >r roll >r tri* r> r> call ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! General spread
+
+MACRO: spread ( seq -- )
+  dup
+    [ drop [ >r ] ]        map concat
+  swap
+    [ [ r> ] swap append ] map concat
+  append ;

extra/editors/editors.factor

@@ -43,7 +43,7 @@ SYMBOL: edit-hook
 
 : fix ( word -- )
     "Fixing " write dup pprint " and all usages..." print nl
-    dup smart-usage swap add* [
+    dup usage swap add* [
         "Editing " write dup .
         "RETURN moves on to the next usage, C+d stops." print
         flush

extra/fry/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Eduardo Cavazos

extra/fry/fry-tests.factor

@@ -0,0 +1,42 @@
+IN: temporary
+USING: fry tools.test math prettyprint kernel io arrays
+sequences ;
+
+[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
+
+[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
+
+[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
+
+[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
+
+[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
+
+[ [ "a" write "b" print ] ]
+[ "a" "b" '[ , write , print ] ] unit-test
+
+[ [ 1 2 + 3 4 - ] ]
+[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
+
+[ 1/2 ] [
+    1 '[ , _ / ] 2 swap call
+] unit-test
+
+[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
+    1 '[ , _ _ 3array ]
+    { "a" "b" "c" } { "A" "B" "C" } rot 2map
+] unit-test
+
+[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
+    '[ 1 _ 2array ]
+    { "a" "b" "c" } swap map
+] unit-test
+
+[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
+    1 2 '[ , _ , 3array ]
+    { "a" "b" "c" } swap map
+] unit-test
+
+: funny-dip '[ @ _ ] call ; inline
+
+[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test

extra/fry/fry.factor

@@ -0,0 +1,39 @@
+! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences combinators parser splitting
+quotations ;
+IN: fry
+
+: , "Only valid inside a fry" throw ;
+: @ "Only valid inside a fry" throw ;
+: _ "Only valid inside a fry" throw ;
+
+DEFER: (fry)
+
+: ((fry)) ( accum quot adder -- result )
+    >r [ ] swap (fry) r>
+    append swap dup empty? [ drop ] [
+        [ swap compose ] curry append
+    ] if ; inline
+
+: (fry) ( accum quot -- result )
+    dup empty? [
+        drop 1quotation
+    ] [
+        unclip {
+            { , [ [ curry ] ((fry)) ] }
+            { @ [ [ compose ] ((fry)) ] }
+            [ swap >r add r> (fry) ]
+        } case
+    ] if ;
+
+: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
+
+: fry ( quot -- quot' )
+    { _ } last-split1 [
+        >r fry [ [ dip ] curry ] r> trivial-fry [ compose ] compose 3compose
+    ] [
+        trivial-fry
+    ] if* ;
+
+: '[ \ ] parse-until fry over push-all ; parsing

extra/fry/summary.txt

@@ -0,0 +1 @@
+Syntax for pictured partial application and composition

extra/fry/tags.txt

@@ -0,0 +1 @@
+extensions

extra/furnace/furnace.factor

@@ -57,17 +57,9 @@ SYMBOL: validation-errors
         ] if*
     ] with map ;
 
-: expire-sessions ( -- )
-    sessions get-global
-    [ nip session-last-seen 20 minutes ago <=> 0 > ]
-    [ 2drop ] heap-pop-while ;
-
 : lookup-session ( hash -- session )
-    "furnace-session-id" over at sessions get-global at [
+    "furnace-session-id" over at get-session
-        nip
+    [ ] [ new-session "furnace-session-id" roll set-at ] ?if ;
-    ] [
-        new-session rot "furnace-session-id" swap set-at
-    ] if* ;
 
 : quot>query ( seq action -- hash )
     >r >array r> "action-params" word-prop

extra/furnace/sessions/sessions.factor

@@ -1,37 +1,48 @@
-USING: assoc-heaps assocs calendar crypto.sha2 heaps
+USING: assocs calendar init kernel math.parser
-init kernel math.parser namespaces random ;
+namespaces random boxes alarms ;
 IN: furnace.sessions
 
 SYMBOL: sessions
 
+: timeout ( -- dt ) 20 minutes ;
+
 [
-    H{ } clone <min-heap> <assoc-heap>
+    H{ } clone sessions set-global
-    sessions set-global
 ] "furnace.sessions" add-init-hook
 
 : new-session-id ( -- str )
-    4 big-random number>string string>sha-256-string
+    4 big-random >hex
-    dup sessions get-global at [ drop new-session-id ] when ;
+    dup sessions get-global key?
+    [ drop new-session-id ] when ;
 
-TUPLE: session created last-seen user-agent namespace ;
+TUPLE: session id namespace alarm user-agent ;
 
-M: session <=> ( session1 session2 -- n )
+: cancel-timeout ( session -- )
-    [ session-last-seen ] 2apply <=> ;
+    session-alarm ?box [ cancel-alarm ] [ drop ] if ;
 
-: <session> ( -- obj )
+: delete-session ( session -- )
-    now dup H{ } clone
+    sessions get-global delete-at*
-    [ set-session-created set-session-last-seen set-session-namespace ]
+    [ cancel-timeout ] [ drop ] if ;
-    \ session construct ;
 
-: new-session ( -- obj id )
+: touch-session ( session -- )
-    <session> new-session-id [ sessions get-global set-at ] 2keep ;
+    dup cancel-timeout
+    dup [ session-id delete-session ] curry timeout later
+    swap session-alarm >box ;
 
-: get-session ( id -- obj/f )
+: <session> ( id -- session )
-    sessions get-global at* [ "no session found 1" throw ] unless ;
+    H{ } clone <box> f session construct-boa ;
 
-! Delete from the assoc only, the heap will timeout
+: new-session ( -- session id )
-: destroy-session ( id -- )
+    new-session-id [
-    sessions get-global assoc-heap-assoc delete-at ;
+        dup <session> [
+            [ sessions get-global set-at ] keep
+            touch-session
+        ] keep
+    ] keep ;
+
+: get-session ( id -- session/f )
+    sessions get-global at*
+    [ dup touch-session ] when ;
 
 : session> ( str -- obj )
     session get session-namespace at ;

extra/partial-apply/partial-apply.factor

@@ -1,26 +0,0 @@
-
-USING: kernel sequences quotations math parser
-       shuffle combinators.cleave combinators.lib sequences.lib ;
-
-IN: partial-apply
-
-! Basic conceptual implementation. Todo: get it to compile.
-
-: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ;
-
-SYMBOL: _
-
-SYMBOL: ~
-
-: blank-positions ( quot -- seq )
-  [ length 2 - ] [ _ indices ] bi [ - ] map-with ;
-  
-: partial-apply ( pattern -- quot )
-  [ blank-positions length nrev ]
-  [ peek 1quotation ]
-  [ blank-positions ]
-  tri
-  [ apply-n ] each ;
-
-: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing
-

extra/sequences/next/next.factor

@@ -3,6 +3,8 @@ IN: sequences.next
 
 <PRIVATE
 
+: iterate-seq >r dup length swap r> ; inline
+
 : (map-next) ( i seq quot -- )
     ! this uses O(n) more bounds checks than is really necessary
     >r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline

extra/smtp/server/server.factor

@@ -28,7 +28,7 @@
 ! Connection closed by foreign host.
 
 USING: combinators kernel prettyprint io io.timeouts io.server
-sequences namespaces io.sockets continuations ;
+sequences namespaces io.sockets continuations calendar ;
 IN: smtp.server
 
 SYMBOL: data-mode

extra/smtp/smtp.factor

@@ -10,7 +10,7 @@ IN: smtp
 SYMBOL: smtp-domain
 SYMBOL: smtp-host       "localhost" smtp-host set-global
 SYMBOL: smtp-port       25 smtp-port set-global
-SYMBOL: read-timeout    60000 read-timeout set-global
+SYMBOL: read-timeout    1 minutes read-timeout set-global
 SYMBOL: esmtp           t esmtp set-global
 
 : log-smtp-connection ( host port -- ) 2drop ;

extra/tools/crossref/crossref-tests.factor

@@ -1,5 +1,5 @@
 USING: math kernel sequences io.files tools.crossref tools.test
-parser namespaces source-files ;
+parser namespaces source-files generic definitions ;
 IN: temporary
 
 GENERIC: foo
@@ -8,5 +8,5 @@ M: integer foo + ;
 
 "resource:extra/tools/test/foo.factor" run-file
 
-[ t ] [ { integer foo } \ + smart-usage member? ] unit-test
+[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test
-[ t ] [ \ foo smart-usage [ pathname? ] contains? ] unit-test
+[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test

extra/tools/crossref/crossref.factor

@@ -6,14 +6,8 @@ generic tools.completion quotations parser inspector
 sorting hashtables vocabs parser source-files ;
 IN: tools.crossref
 
-: synopsis-alist ( definitions -- alist )
-    [ dup synopsis swap ] { } map>assoc ;
-
-: definitions. ( alist -- )
-    [ write-object nl ] assoc-each ;
-
 : usage. ( word -- )
-    smart-usage synopsis-alist sort-keys definitions. ;
+    usage sorted-definitions. ;
 
 : words-matching ( str -- seq )
     all-words [ dup word-name ] { } map>assoc completions ;

extra/ui/tools/search/search.factor

@@ -3,8 +3,8 @@
 USING: assocs ui.tools.interactor ui.tools.listener
 ui.tools.workspace help help.topics io.files io.styles kernel
 models namespaces prettyprint quotations sequences sorting
-source-files strings tools.completion tools.crossref tuples
+source-files definitions strings tools.completion tools.crossref
-ui.commands ui.gadgets ui.gadgets.editors
+tuples ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
 ui.gestures ui.operations vocabs words vocabs.loader
 tools.browser unicode.case calendar ;
@@ -93,7 +93,7 @@ M: live-search pref-dim* drop { 400 200 } ;
     "Words in " rot vocab-name append show-titled-popup ;
 
 : show-word-usage ( workspace word -- )
-    "" over smart-usage f <definition-search>
+    "" over usage f <definition-search>
     "Words and methods using " rot word-name append
     show-titled-popup ;
 

misc/target

@@ -8,7 +8,10 @@ then
   echo macosx-x86-`./misc/wordsize`
 elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
 then
-  echo linux-x86-`./misc/wordsize`
+  echo linux-x86-32
+elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ]
+then
+  echo linux-x86-64
 elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
 then
   echo winnt-x86-`./misc/wordsize`