From 3b5afee8dbc616b668af01625a3de2a79322acb1 Mon Sep 17 00:00:00 2001 From: slava Date: Mon, 21 Apr 2008 17:50:40 -0500 Subject: [PATCH 01/77] Try to degrade gracefully if inotify is unavailable --- vm/os-linux.c | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/vm/os-linux.c b/vm/os-linux.c index 935add6714..91017fc3f8 100644 --- a/vm/os-linux.c +++ b/vm/os-linux.c @@ -18,6 +18,8 @@ const char *vm_executable_path(void) } } +#ifdef SYS_inotify_init + int inotify_init(void) { return syscall(SYS_inotify_init); @@ -32,3 +34,25 @@ int inotify_rm_watch(int fd, u32 wd) { return syscall(SYS_inotify_rm_watch, fd, wd); } + +#else + +int inotify_init(void) +{ + not_implemented_error(); + return -1; +} + +int inotify_add_watch(int fd, const char *name, u32 mask) +{ + not_implemented_error(); + return -1; +} + +int inotify_rm_watch(int fd, u32 wd) +{ + not_implemented_error(); + return -1; +} + +#endif From 517671fad00035ca4b272d1128849974229e55be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Apr 2008 03:16:12 -0500 Subject: [PATCH 02/77] Thread refactoring work in progress --- core/threads/threads-tests.factor | 16 +++- core/threads/threads.factor | 71 ++++++++++-------- .../tools/interactor/interactor-tests.factor | 18 ++++- extra/ui/tools/interactor/interactor.factor | 75 ++++++++++--------- extra/ui/tools/listener/listener-tests.factor | 23 +++++- extra/ui/tools/listener/listener.factor | 61 +++++++-------- 6 files changed, 159 insertions(+), 105 deletions(-) diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index 0ac607f0ed..0e33ccd94c 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -1,5 +1,6 @@ USING: namespaces io tools.test threads kernel -concurrency.combinators math ; +concurrency.combinators concurrency.promises locals math +words ; IN: threads.tests 3 "x" set @@ -27,3 +28,16 @@ yield "i" tget ] parallel-map ] unit-test + +[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with + +:: spawn-namespace-test ( -- ) + [let | p [ ] g [ gensym ] | + [ + g "x" set + [ "x" get p fulfill ] "B" spawn drop + ] with-scope + p ?promise g eq? + ] ; + +[ t ] [ spawn-namespace-test ] unit-test diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 2f9c3a73de..fc3915e462 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -90,6 +90,8 @@ PRIVATE> [ sleep-queue heap-peek nip millis [-] ] } cond ; +DEFER: stop + [ ] while drop ; +: start ( namestack thread -- ) + [ + set-self + set-namestack + V{ } set-catchstack + { } set-retainstack + { } set-datastack + self quot>> [ call stop ] call-clear + ] 2 (throw) ; + +DEFER: next + +: no-runnable-threads ( -- * ) + ! We should never be in a state where the only threads + ! are sleeping; the I/O wait thread is always runnable. + ! However, if it dies, we handle this case + ! semi-gracefully. + ! + ! And if sleep-time outputs f, there are no sleeping + ! threads either... so WTF. + sleep-time [ die 0 ] unless* (sleep) next ; + +: (next) ( arg thread -- * ) + f >>state + dup set-self + dup continuation>> ?box + [ nip continue-with ] [ drop start ] if ; + : next ( -- * ) expire-sleep-loop run-queue dup dlist-empty? [ - ! We should never be in a state where the only threads - ! are sleeping; the I/O wait thread is always runnable. - ! However, if it dies, we handle this case - ! semi-gracefully. - ! - ! And if sleep-time outputs f, there are no sleeping - ! threads either... so WTF. - drop sleep-time [ die 0 ] unless* (sleep) next + drop no-runnable-threads ] [ - pop-back - dup array? [ first2 ] [ f swap ] if dup set-self - f >>state - continuation>> box> - continue-with + pop-back dup array? [ first2 ] [ f swap ] if (next) ] if ; PRIVATE> : stop ( -- ) - self dup exit-handler>> call - unregister-thread next ; + self [ exit-handler>> call ] [ unregister-thread ] bi next ; : suspend ( quot state -- obj ) [ - self continuation>> >box - self (>>state) - self swap call next + >r + >r self swap call + r> self (>>state) + r> self continuation>> >box + next ] callcc1 2nip ; inline : yield ( -- ) [ resume ] f suspend drop ; @@ -165,16 +185,7 @@ M: real sleep ] when drop ; : (spawn) ( thread -- ) - [ - resume-now [ - dup set-self - dup register-thread - V{ } set-catchstack - { } set-retainstack - >r { } set-datastack r> - quot>> [ call stop ] call-clear - ] 1 (throw) - ] "spawn" suspend 2drop ; + [ register-thread ] [ namestack swap resume-with ] bi ; : spawn ( quot name -- thread ) [ (spawn) ] keep ; @@ -183,8 +194,8 @@ M: real sleep >r [ [ ] [ ] while ] curry r> spawn ; : in-thread ( quot -- ) - >r datastack namestack r> - [ >r set-namestack set-datastack r> call ] 3curry + >r datastack r> + [ >r set-datastack r> call ] 2curry "Thread" spawn drop ; GENERIC: error-in-thread ( error thread -- ) diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index 99c005451d..509543a20a 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,11 +1,11 @@ IN: ui.tools.interactor.tests USING: ui.tools.interactor ui.gadgets.panes namespaces ui.gadgets.editors concurrency.promises threads listener -tools.test kernel calendar parser ; +tools.test kernel calendar parser accessors ; + +\ must-infer [ - \ must-infer - [ ] [ "interactor" set ] unit-test [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test @@ -13,6 +13,7 @@ tools.test kernel calendar parser ; [ ] [ "promise" set ] unit-test [ + self "interactor" get (>>thread) "interactor" get stream-read-quot "promise" get fulfill ] "Interactor test" spawn drop @@ -27,3 +28,14 @@ tools.test kernel calendar parser ; [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test ] with-interactive-vocabs + +! Hang +[ ] [ "interactor" set ] unit-test + +[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test + +[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test + +[ ] [ 1000 sleep ] unit-test + +[ ] [ "interactor" get interactor-eof ] unit-test diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 3837ce2de1..734f6cb4b8 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -1,53 +1,53 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators continuations documents - hashtables io io.styles kernel math -math.vectors models namespaces parser prettyprint quotations -sequences strings threads listener -classes.tuple ui.commands ui.gadgets ui.gadgets.editors -ui.gadgets.presentations ui.gadgets.worlds ui.gestures -definitions boxes calendar concurrency.flags ui.tools.workspace -accessors ; +hashtables io io.styles kernel math math.vectors models +namespaces parser prettyprint quotations sequences strings +threads listener classes.tuple ui.commands ui.gadgets +ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds +ui.gestures definitions calendar concurrency.flags +ui.tools.workspace accessors ; IN: ui.tools.interactor -TUPLE: interactor history output flag thread help ; +! If waiting is t, we're waiting for user input, and invoking +! evaluate-input resumes the thread. +TUPLE: interactor output history flag thread waiting help ; + +: register-self ( interactor -- ) + self >>thread drop ; : interactor-continuation ( interactor -- continuation ) - interactor-thread box-value - thread-continuation box-value ; + thread>> continuation>> value>> ; : interactor-busy? ( interactor -- ? ) - interactor-thread box-full? not ; + #! We're busy if there's no thread to resume. + [ waiting>> ] + [ thread>> dup [ thread-registered? ] when ] + bi and not ; : interactor-use ( interactor -- seq ) dup interactor-busy? [ drop f ] [ use swap - interactor-continuation continuation-name + interactor-continuation name>> assoc-stack ] if ; -: init-caret-help ( interactor -- ) - dup editor-caret 1/3 seconds - swap set-interactor-help ; - -: init-interactor-history ( interactor -- ) - V{ } clone swap set-interactor-history ; - -: init-interactor-state ( interactor -- ) - over set-interactor-flag - swap set-interactor-thread ; +: ( interactor -- model ) + editor-caret 1/3 seconds ; : ( output -- gadget ) interactor construct-editor - tuck set-interactor-output - dup init-interactor-history - dup init-interactor-state - dup init-caret-help ; + V{ } clone >>history + >>flag + dup >>help + swap >>output ; M: interactor graft* - dup delegate graft* - dup interactor-help add-connection ; + [ delegate graft* ] [ dup help>> add-connection ] bi ; + +M: interactor ungraft* + [ dup help>> remove-connection ] [ delegate ungraft ] bi ; : word-at-loc ( loc interactor -- word ) over [ @@ -58,7 +58,7 @@ M: interactor graft* ] if ; M: interactor model-changed - 2dup interactor-help eq? [ + 2dup help>> eq? [ swap model-value over word-at-loc swap show-summary ] [ delegate model-changed @@ -69,7 +69,7 @@ M: interactor model-changed [ H{ { font-style bold } } format ] with-nesting ; : interactor-input. ( string interactor -- ) - interactor-output [ + output>> [ dup string? [ dup write-input nl ] [ short. ] if ] with-stream* ; @@ -77,7 +77,7 @@ M: interactor model-changed over empty? [ 2drop ] [ interactor-history push-new ] if ; : interactor-continue ( obj interactor -- ) - interactor-thread box> resume-with ; + thread>> resume-with ; : clear-input ( interactor -- ) gadget-model clear-doc ; @@ -99,10 +99,12 @@ M: interactor model-changed ] unless drop ; : interactor-yield ( interactor -- obj ) - [ - [ interactor-thread >box ] keep - interactor-flag raise-flag - ] curry "input" suspend ; + dup thread>> self eq? [ + t >>waiting + [ [ flag>> raise-flag ] curry "input" suspend ] keep + f >>waiting + drop + ] [ drop f ] if ; M: interactor stream-readln [ interactor-yield ] keep interactor-finish @@ -161,7 +163,8 @@ M: interactor stream-read-quot } cond ; M: interactor pref-dim* - 0 over line-height 4 * 2array swap delegate pref-dim* vmax ; + [ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi + vmax ; interactor "interactor" f { { T{ key-down f f "RET" } evaluate-input } diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index cc218533d8..2fae62a8fc 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor ui.tools.listener hashtables kernel namespaces parser sequences tools.test ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.panes vocabs words tools.test.ui slots.private -threads arrays generic ; +threads arrays generic threads accessors listener ; IN: ui.tools.listener.tests [ f ] [ "word" source-editor command-map empty? ] unit-test @@ -15,7 +15,7 @@ IN: ui.tools.listener.tests [ "dup" ] [ \ dup word-completion-string ] unit-test - + [ "equal?" ] [ \ array \ equal? method word-completion-string ] unit-test @@ -28,9 +28,26 @@ IN: ui.tools.listener.tests [ ] [ "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover ] unit-test - + [ t ] [ "i" get gadget-model doc-end "i" get editor-caret* = ] unit-test + + ! Race condition discovered by SimonRC + [ ] [ + [ + "listener" get input>> + [ stream-read-quot drop ] + [ stream-read-quot drop ] bi + ] "OH, HAI" spawn drop + ] unit-test + + [ ] [ "listener" get clear-output ] unit-test + + [ ] [ "listener" get restart-listener ] unit-test + + [ ] [ 1000 sleep ] unit-test + + [ ] [ "listener" get com-end ] unit-test ] with-grafted-gadget diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index d96270075f..9057e1c4bd 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -16,13 +16,11 @@ TUPLE: listener-gadget input output stack ; g-> set-listener-gadget-output "Output" 1 track, ; -: listener-stream ( listener -- stream ) - dup listener-gadget-input - swap listener-gadget-output - ; +: ( listener -- stream ) + [ input>> ] [ output>> ] bi ; : ( listener -- gadget ) - listener-gadget-output ; + output>> ; : listener-input, ( -- ) g g-> set-listener-gadget-input @@ -34,31 +32,29 @@ TUPLE: listener-gadget input output stack ; "cookbook" ($link) "." print nl ; M: listener-gadget focusable-child* - listener-gadget-input ; + input>> ; M: listener-gadget call-tool* ( input listener -- ) - >r input-string r> listener-gadget-input set-editor-string ; + >r string>> r> input>> set-editor-string ; M: listener-gadget tool-scroller - listener-gadget-output find-scroller ; + output>> find-scroller ; : wait-for-listener ( listener -- ) #! Wait for the listener to start. - listener-gadget-input interactor-flag wait-for-flag ; + input>> flag>> wait-for-flag ; : workspace-busy? ( workspace -- ? ) - workspace-listener listener-gadget-input interactor-busy? ; + listener>> input>> interactor-busy? ; : listener-input ( string -- ) - get-workspace - workspace-listener - listener-gadget-input set-editor-string ; + get-workspace listener>> input>> set-editor-string ; : (call-listener) ( quot listener -- ) - listener-gadget-input interactor-call ; + input>> interactor-call ; : call-listener ( quot -- ) - [ workspace-busy? not ] get-workspace* workspace-listener + [ workspace-busy? not ] get-workspace* listener>> [ dup wait-for-listener (call-listener) ] 2curry "Listener call" spawn drop ; @@ -70,8 +66,7 @@ M: listener-operation invoke-command ( target command -- ) : eval-listener ( string -- ) get-workspace - workspace-listener - listener-gadget-input [ set-editor-string ] keep + listener>> input>> [ set-editor-string ] keep evaluate-input ; : listener-run-files ( seq -- ) @@ -82,10 +77,10 @@ M: listener-operation invoke-command ( target command -- ) ] if ; : com-end ( listener -- ) - listener-gadget-input interactor-eof ; + input>> interactor-eof ; : clear-output ( listener -- ) - listener-gadget-output pane-clear ; + output>> pane-clear ; \ clear-output H{ { +listener+ t } } define-command @@ -148,22 +143,27 @@ M: stack-display tool-scroller swap show-tool inspect-object ; : listener-thread ( listener -- ) - dup listener-stream [ - dup [ ui-listener-hook ] curry listener-hook set - dup [ ui-error-hook ] curry error-hook set - [ ui-inspector-hook ] curry inspector-hook set + dup [ + [ [ ui-listener-hook ] curry listener-hook set ] + [ [ ui-error-hook ] curry error-hook set ] + [ [ ui-inspector-hook ] curry inspector-hook set ] tri welcome. listener ] with-stream* ; : start-listener-thread ( listener -- ) - [ listener-thread ] curry "Listener" spawn drop ; + [ + [ input>> register-self ] [ listener-thread ] bi + ] curry "Listener" spawn drop ; : restart-listener ( listener -- ) #! Returns when listener is ready to receive input. - dup com-end dup clear-output - dup start-listener-thread - wait-for-listener ; + { + [ com-end ] + [ clear-output ] + [ start-listener-thread ] + [ wait-for-listener ] + } cleave ; : init-listener ( listener -- ) f swap set-listener-gadget-stack ; @@ -189,10 +189,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? ) [ default-gesture-handler ] [ 3drop f ] if ; M: listener-gadget graft* - dup delegate graft* - dup listener-gadget-input interactor-thread ?box 2drop - restart-listener ; + [ delegate graft* ] [ restart-listener ] bi ; M: listener-gadget ungraft* - dup com-end - delegate ungraft* ; + [ com-end ] [ delegate ungraft* ] bi ; From 796e5f58eb5b237e9bb6fa887cd26cae2b9d8d75 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 2 May 2008 17:52:17 +1000 Subject: [PATCH 03/77] starting to add bouncing to jamshred --- extra/jamshred/oint/oint.factor | 4 ++++ extra/jamshred/player/player.factor | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 11a89b314f..4680be4575 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -74,3 +74,7 @@ TUPLE: oint location forward up left ; : perpendicular-distance ( oint oint -- distance ) tuck distance-vector swap 2dup oint-left scalar-projection abs -rot oint-up scalar-projection abs + ; + +:: reflect ( v l -- v' ) + #! reflect v on l + v l v. l l v. / 2 * l n*v v v- ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 17843ef9c2..3e143a845e 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -28,7 +28,8 @@ TUPLE: player name tunnel nearest-segment ; 0.3 ; : player-speed ( player -- speed ) - dup player-nearest-segment fraction-from-wall sq max-speed * ; + max-speed ; + ! dup player-nearest-segment fraction-from-wall sq max-speed * ; : move-player ( player -- ) dup player-speed over go-forward update-nearest-segment ; From b6d8521c8ceec6d2dec2906435823100399d853e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 2 May 2008 17:11:51 -0500 Subject: [PATCH 04/77] refactor state parser --- extra/state-parser/state-parser.factor | 117 ++++++++++++++----------- 1 file changed, 68 insertions(+), 49 deletions(-) diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index 96ad4ca0b4..17d5377259 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences -strings circular prettyprint debugger ascii ; +strings circular prettyprint debugger ascii sbufs fry inspector +accessors sequences.lib ; IN: state-parser ! * Basic underlying words @@ -11,50 +12,56 @@ TUPLE: spot char line column next ; C: spot -: get-char ( -- char ) spot get spot-char ; -: set-char ( char -- ) spot get set-spot-char ; -: get-line ( -- line ) spot get spot-line ; -: set-line ( line -- ) spot get set-spot-line ; -: get-column ( -- column ) spot get spot-column ; -: set-column ( column -- ) spot get set-spot-column ; -: get-next ( -- char ) spot get spot-next ; -: set-next ( char -- ) spot get set-spot-next ; +: get-char ( -- char ) spot get char>> ; +: set-char ( char -- ) spot get swap >>char drop ; +: get-line ( -- line ) spot get line>> ; +: set-line ( line -- ) spot get swap >>line drop ; +: get-column ( -- column ) spot get column>> ; +: set-column ( column -- ) spot get swap >>column drop ; +: get-next ( -- char ) spot get next>> ; +: set-next ( char -- ) spot get swap >>next drop ; ! * Errors TUPLE: parsing-error line column ; -: ( -- parsing-error ) - get-line get-column parsing-error boa ; -: construct-parsing-error ( ... slots class -- error ) - construct over set-delegate ; inline +: parsing-error ( class -- obj ) + new + get-line >>line + get-column >>column ; +M: parsing-error summary ( obj -- str ) + [ + "Parsing error" print + "Line: " write dup line>> . + "Column: " write column>> . + ] with-string-writer ; -: parsing-error. ( parsing-error -- ) - "Parsing error" print - "Line: " write dup parsing-error-line . - "Column: " write parsing-error-column . ; +TUPLE: expected < parsing-error should-be was ; +: expected ( should-be was -- * ) + \ expected parsing-error + swap >>was + swap >>should-be throw ; +M: expected summary ( obj -- str ) + [ + dup call-next-method write + "Token expected: " write dup should-be>> print + "Token present: " write was>> print + ] with-string-writer ; -TUPLE: expected should-be was ; -: ( should-be was -- error ) - { set-expected-should-be set-expected-was } - expected construct-parsing-error ; -M: expected error. - dup parsing-error. - "Token expected: " write dup expected-should-be print - "Token present: " write expected-was print ; +TUPLE: unexpected-end < parsing-error ; +: unexpected-end \ unexpected-end parsing-error throw ; +M: unexpected-end summary ( obj -- str ) + [ + call-next-method write + "File unexpectedly ended." print + ] with-string-writer ; -TUPLE: unexpected-end ; -: ( -- unexpected-end ) - { } unexpected-end construct-parsing-error ; -M: unexpected-end error. - parsing-error. - "File unexpectedly ended." print ; - -TUPLE: missing-close ; -: ( -- missing-close ) - { } missing-close construct-parsing-error ; -M: missing-close error. - parsing-error. - "Missing closing token." print ; +TUPLE: missing-close < parsing-error ; +: missing-close \ missing-close parsing-error throw ; +M: missing-close summary ( obj -- str ) + [ + call-next-method write + "Missing closing token." print + ] with-string-writer ; SYMBOL: prolog-data @@ -65,7 +72,8 @@ SYMBOL: prolog-data [ 0 get-line 1+ set-line ] [ get-column 1+ ] if set-column ; -: (next) ( -- char ) ! this normalizes \r\n and \r +! (next) normalizes \r\n and \r +: (next) ( -- char ) get-next read1 2dup swap CHAR: \r = [ CHAR: \n = @@ -75,10 +83,7 @@ SYMBOL: prolog-data : next ( -- ) #! Increment spot. - get-char [ - throw - ] unless - (next) record ; + get-char [ unexpected-end ] unless (next) record ; : next* ( -- ) get-char [ (next) record ] when ; @@ -95,9 +100,9 @@ SYMBOL: prolog-data #! Take the substring of a string starting at spot #! from code until the quotation given is true and #! advance spot to after the substring. - [ [ - dup slip swap dup [ get-char , ] unless - ] skip-until ] "" make nip ; inline + 10 [ + '[ @ [ t ] [ get-char , push f ] if ] skip-until + ] keep >string ; inline : take-rest ( -- string ) [ f ] take-until ; @@ -105,6 +110,20 @@ SYMBOL: prolog-data : take-char ( ch -- string ) [ dup get-char = ] take-until nip ; +TUPLE: not-enough-characters < parsing-error ; +: not-enough-characters + \ not-enough-characters parsing-error throw ; +M: not-enough-characters summary ( obj -- str ) + [ + call-next-method write + "Not enough characters" print + ] with-string-writer ; + +: take ( n -- string ) + [ 1- ] [ ] bi [ + '[ drop get-char [ next , push f ] [ t ] if* ] attempt-each drop + ] keep get-char [ over push ] when* >string ; + : pass-blank ( -- ) #! Advance code past any whitespace, including newlines [ get-char blank? not ] skip-until ; @@ -117,16 +136,16 @@ SYMBOL: prolog-data dup length [ 2dup string-matches? ] take-until nip dup length rot length 1- - head - get-char [ throw ] unless next ; + get-char [ missing-close ] unless next ; : expect ( ch -- ) get-char 2dup = [ 2drop ] [ - >r 1string r> 1string throw + >r 1string r> 1string expected ] if next ; : expect-string ( string -- ) dup [ drop get-char next ] map 2dup = - [ 2drop ] [ throw ] if ; + [ 2drop ] [ expected ] if ; : init-parser ( -- ) 0 1 0 f spot set From a77ba70706d4dc2506faefdb9f0ba8cd4420894b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 2 May 2008 17:12:09 -0500 Subject: [PATCH 05/77] refactor xml parser --- extra/xml/backend/backend.factor | 6 + extra/xml/errors/errors.factor | 291 +++++++++++++++++-------------- extra/xml/tests/errors.factor | 28 --- extra/xml/xml.factor | 10 +- 4 files changed, 168 insertions(+), 167 deletions(-) create mode 100644 extra/xml/backend/backend.factor delete mode 100755 extra/xml/tests/errors.factor diff --git a/extra/xml/backend/backend.factor b/extra/xml/backend/backend.factor new file mode 100644 index 0000000000..5dee38695d --- /dev/null +++ b/extra/xml/backend/backend.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +IN: xml.backend + +! A stack of { tag children } pairs +SYMBOL: xml-stack diff --git a/extra/xml/errors/errors.factor b/extra/xml/errors/errors.factor index 5b41a7ff9f..3e24d7e720 100644 --- a/extra/xml/errors/errors.factor +++ b/extra/xml/errors/errors.factor @@ -1,150 +1,179 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: xml.data xml.writer kernel generic io prettyprint math -debugger sequences state-parser ; +debugger sequences state-parser accessors inspector +namespaces io.streams.string xml.backend ; IN: xml.errors -TUPLE: no-entity thing ; -: ( string -- error ) - { set-no-entity-thing } no-entity construct-parsing-error ; -M: no-entity error. - dup parsing-error. - "Entity does not exist: &" write no-entity-thing write ";" print ; - -TUPLE: xml-string-error string ; ! this should not exist -: ( string -- xml-string-error ) - { set-xml-string-error-string } - xml-string-error construct-parsing-error ; -M: xml-string-error error. - dup parsing-error. - xml-string-error-string print ; - -TUPLE: mismatched open close ; -: - { set-mismatched-open set-mismatched-close } - mismatched construct-parsing-error ; -M: mismatched error. - dup parsing-error. - "Mismatched tags" print - "Opening tag: <" write dup mismatched-open print-name ">" print - "Closing tag: " print ; - -TUPLE: unclosed tags ; -! is ( -- unclosed ), see presentation.factor -M: unclosed error. - "Unclosed tags" print - "Tags: " print - unclosed-tags [ " <" write print-name ">" print ] each ; - -TUPLE: bad-uri string ; -: ( string -- bad-uri ) - { set-bad-uri-string } bad-uri construct-parsing-error ; -M: bad-uri error. - dup parsing-error. - "Bad URI:" print bad-uri-string . ; - -TUPLE: nonexist-ns name ; -: ( name-string -- nonexist-ns ) - { set-nonexist-ns-name } - nonexist-ns construct-parsing-error ; -M: nonexist-ns error. - dup parsing-error. - "Namespace " write nonexist-ns-name write " has not been declared" print ; - -TUPLE: unopened ; ! this should give which tag was unopened -: ( -- unopened ) - { } unopened construct-parsing-error ; -M: unopened error. - parsing-error. - "Closed an unopened tag" print ; - -TUPLE: not-yes/no text ; -: ( text -- not-yes/no ) - { set-not-yes/no-text } not-yes/no construct-parsing-error ; -M: not-yes/no error. - dup parsing-error. - "standalone must be either yes or no, not \"" write - not-yes/no-text write "\"." print ; - -TUPLE: extra-attrs attrs ; ! this should actually print the names -: ( attrs -- extra-attrs ) - { set-extra-attrs-attrs } - extra-attrs construct-parsing-error ; -M: extra-attrs error. - dup parsing-error. - "Extra attributes included in xml version declaration:" print - extra-attrs-attrs . ; - -TUPLE: bad-version num ; -: - { set-bad-version-num } - bad-version construct-parsing-error ; -M: bad-version error. - "XML version must be \"1.0\" or \"1.1\". Version here was " write - bad-version-num . ; - -TUPLE: notags ; -C: notags -M: notags error. - drop "XML document lacks a main tag" print ; - TUPLE: multitags ; C: multitags -M: multitags error. - drop "XML document contains multiple main tags" print ; - -TUPLE: bad-prolog prolog ; -: ( prolog -- bad-prolog ) - { set-bad-prolog-prolog } - bad-prolog construct-parsing-error ; -M: bad-prolog error. - dup parsing-error. - "Misplaced XML prolog" print - bad-prolog-prolog write-prolog nl ; - -TUPLE: capitalized-prolog name ; -: ( name -- capitalized-prolog ) - { set-capitalized-prolog-name } - capitalized-prolog construct-parsing-error ; -M: capitalized-prolog error. - dup parsing-error. - "XML prolog name was partially or totally capitalized, using" print - "" write - " instead of " print ; +M: multitags summary ( obj -- str ) + drop "XML document contains multiple main tags" ; TUPLE: pre/post-content string pre? ; C: 
 pre/post-content
-M: pre/post-content error.
-    "The text string:" print
-    dup pre/post-content-string .
-    "was used " write
-    pre/post-content-pre? "before" "after" ? write
-    " the main tag." print ;
+M: pre/post-content summary ( obj -- str )
+    [
+        "The text string:" print
+        dup string>> .
+        "was used " write
+        pre?>> "before" "after" ? write
+        " the main tag." print
+    ] with-string-writer ;
 
-TUPLE: versionless-prolog ;
+TUPLE: no-entity < parsing-error thing ;
+:  ( string -- error )
+    \ no-entity parsing-error swap >>thing ;
+M: no-entity summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Entity does not exist: &" write thing>> write ";" print
+    ] with-string-writer ;
+
+TUPLE: xml-string-error < parsing-error string ; ! this should not exist
+:  ( string -- xml-string-error )
+    \ xml-string-error parsing-error swap >>string ;
+M: xml-string-error summary ( obj -- str )
+    [
+        dup call-next-method write
+        string>> print
+    ] with-string-writer ;
+
+TUPLE: mismatched < parsing-error open close ;
+: 
+    \ mismatched parsing-error swap >>close swap >>open ;
+M: mismatched summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Mismatched tags" print
+        "Opening tag: <" write dup open>> print-name ">" print
+        "Closing tag: > print-name ">" print
+    ] with-string-writer ;
+
+TUPLE: unclosed < parsing-error tags ;
+:  ( -- unclosed )
+    unclosed parsing-error
+        xml-stack get rest-slice [ first opener-name ] map >>tags ;
+M: unclosed summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Unclosed tags" print
+        "Tags: " print
+        tags>> [ "  <" write print-name ">" print ] each
+    ] with-string-writer ;
+
+TUPLE: bad-uri < parsing-error string ;
+:  ( string -- bad-uri )
+    \ bad-uri parsing-error swap >>string ;
+M: bad-uri summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Bad URI:" print string>> .
+    ] with-string-writer ;
+
+TUPLE: nonexist-ns < parsing-error name ;
+:  ( name-string -- nonexist-ns )
+    \ nonexist-ns parsing-error swap >>name ;
+M: nonexist-ns summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Namespace " write name>> write " has not been declared" print
+    ] with-string-writer ;
+
+TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
+:  ( -- unopened )
+    \ unopened parsing-error ;
+M: unopened summary ( obj -- str )
+    [
+        call-next-method write
+        "Closed an unopened tag" print
+    ] with-string-writer ;
+
+TUPLE: not-yes/no < parsing-error text ;
+:  ( text -- not-yes/no )
+    \ not-yes/no parsing-error swap >>text ;
+M: not-yes/no summary ( obj -- str )
+    [
+        dup call-next-method write
+        "standalone must be either yes or no, not \"" write
+        text>> write "\"." print
+    ] with-string-writer ;
+
+! this should actually print the names
+TUPLE: extra-attrs < parsing-error attrs ;
+:  ( attrs -- extra-attrs )
+    \ extra-attrs parsing-error swap >>attrs ;
+M: extra-attrs summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Extra attributes included in xml version declaration:" print
+        attrs>> .
+    ] with-string-writer ;
+
+TUPLE: bad-version < parsing-error num ;
+: 
+    \ bad-version parsing-error swap >>num ;
+M: bad-version summary ( obj -- str )
+    [
+        "XML version must be \"1.0\" or \"1.1\". Version here was " write
+        num>> .
+    ] with-string-writer ;
+
+TUPLE: notags < parsing-error ;
+: 
+    \ notags parsing-error ;
+M: notags summary ( obj -- str )
+    drop "XML document lacks a main tag" ;
+
+TUPLE: bad-prolog < parsing-error prolog ;
+:  ( prolog -- bad-prolog )
+    \ bad-prolog parsing-error swap >>prolog ;
+M: bad-prolog summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced XML prolog" print
+        prolog>> write-prolog nl
+    ] with-string-writer ;
+
+TUPLE: capitalized-prolog < parsing-error name ;
+:  ( name -- capitalized-prolog )
+    \ capitalized-prolog parsing-error swap >>name ;
+M: capitalized-prolog summary ( obj -- str )
+    [
+        dup call-next-method write
+        "XML prolog name was partially or totally capitalized, using" print
+        "> write "...?>" write
+        " instead of " print
+    ] with-string-writer ;
+
+TUPLE: versionless-prolog < parsing-error ;
 :  ( -- versionless-prolog )
-    { } versionless-prolog construct-parsing-error ;
-M: versionless-prolog error.
-    parsing-error.
-    "XML prolog lacks a version declaration" print ;
+    \ versionless-prolog parsing-error ;
+M: versionless-prolog summary ( obj -- str )
+    [
+        call-next-method write
+        "XML prolog lacks a version declaration" print
+    ] with-string-writer ;
 
-TUPLE: bad-instruction inst ;
+TUPLE: bad-instruction < parsing-error instruction ;
 :  ( instruction -- bad-instruction )
-    { set-bad-instruction-inst }
-    bad-instruction construct-parsing-error ;
-M: bad-instruction error.
-    dup parsing-error.
-    "Misplaced processor instruction:" print
-    bad-instruction-inst write-item nl ;
+    \ bad-instruction parsing-error swap >>instruction ;
+M: bad-instruction summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced processor instruction:" print
+        bad-instruction-inst write-item nl
+    ] with-string-writer ;
 
-TUPLE: bad-directive dir ;
+TUPLE: bad-directive < parsing-error dir ;
 :  ( directive -- bad-directive )
-    { set-bad-directive-dir }
-    bad-directive construct-parsing-error ;
-M: bad-directive error.
-    dup parsing-error.
-    "Misplaced directive:" print
-    bad-directive-dir write-item nl ;
+    \ bad-directive parsing-error swap >>dir ;
+M: bad-directive summary ( obj -- str )
+    [
+        dup call-next-method write
+        "Misplaced directive:" print
+        bad-directive-dir write-item nl
+    ] with-string-writer ;
 
 UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
        not-yes/no unclosed mismatched xml-string-error expected no-entity
diff --git a/extra/xml/tests/errors.factor b/extra/xml/tests/errors.factor
deleted file mode 100755
index 6ba0b0d560..0000000000
--- a/extra/xml/tests/errors.factor
+++ /dev/null
@@ -1,28 +0,0 @@
-USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
-IN: xml.tests
-
-: xml-error-test ( expected-error xml-string -- )
-    [ string>xml ] curry swap [ = ] curry must-fail-with ;
-
-T{ no-entity T{ parsing-error f 1 10 } "nbsp" } " " xml-error-test
-T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" }
-} "" xml-error-test
-T{ unclosed f V{ T{ name f "" "x" "" } } } "" xml-error-test
-T{ nonexist-ns T{ parsing-error f 1 5 } "x" } "" xml-error-test
-T{ unopened T{ parsing-error f 1 5 } } "" xml-error-test
-T{ not-yes/no T{ parsing-error f 1 41 } "maybe" } "" xml-error-test
-T{ extra-attrs T{ parsing-error f 1 32 } V{ T{ name f "" "foo" f } }
-} "" xml-error-test
-T{ bad-version T{ parsing-error f 1 28 } "5 million" } "" xml-error-test
-T{ notags f } "" xml-error-test
-T{ multitags f } "" xml-error-test
-T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "UTF-8" f }
-} "" xml-error-test
-T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } ""
-xml-error-test
-T{ pre/post-content f "x" t } "x" xml-error-test
-T{ versionless-prolog T{ parsing-error f 1 8 } } "" xml-error-test
-T{ bad-instruction T{ parsing-error f 1 11 } T{ instruction f "xsl" }
-} "" xml-error-test
-T{ bad-directive T{ parsing-error f 1 15 } T{ directive f "DOCTYPE" }
-} "" xml-error-test
diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor
index 2d7c8c8ff8..f45b27b030 100644
--- a/extra/xml/xml.factor
+++ b/extra/xml/xml.factor
@@ -3,18 +3,12 @@
 USING: io io.streams.string io.files kernel math namespaces
 prettyprint sequences arrays generic strings vectors
 xml.char-classes xml.data xml.errors xml.tokenize xml.writer
-xml.utilities state-parser assocs ascii io.encodings.utf8 ;
+xml.utilities state-parser assocs ascii io.encodings.utf8
+accessors xml.backend ;
 IN: xml
 
 !   -- Overall parser with data tree
 
-! A stack of { tag children } pairs
-SYMBOL: xml-stack
-
-:  ( -- unclosed )
-    xml-stack get rest-slice [ first opener-name ] map
-    { set-unclosed-tags } unclosed construct ;
-
 : add-child ( object -- )
     xml-stack get peek second push ;
 

From 9e726f40aa58516760f3fbb0f5567b7f9a709cfb Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Mon, 5 May 2008 13:27:14 -0500
Subject: [PATCH 06/77] add more unit tests

---
 extra/taxes/taxes-tests.factor | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor
index 6aeb5aa098..32dbd0d625 100644
--- a/extra/taxes/taxes-tests.factor
+++ b/extra/taxes/taxes-tests.factor
@@ -96,3 +96,21 @@ IN: taxes.tests
     1000000 2008 3 t   net
     dollars/cents
 ] unit-test
+
+
+[ 30 97 ] [
+    24000 2008 2 f   withholding biweekly dollars/cents
+] unit-test
+
+[ 173 66 ] [
+    78250 2008 2 f   withholding biweekly dollars/cents
+] unit-test
+
+
+[ 138 69 ] [
+    24000 2008 2 f   withholding biweekly dollars/cents
+] unit-test
+
+[ 754 22 ] [
+    78250 2008 2 f   withholding biweekly dollars/cents
+] unit-test

From e82fb3b6dc3729fbe920b77c9e0ac42a9c760232 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg 
Date: Mon, 5 May 2008 19:52:56 -0500
Subject: [PATCH 07/77] Coalesce function for interval maps

---
 .../interval-maps/interval-maps-tests.factor  |  5 +++++
 extra/interval-maps/interval-maps.factor      | 21 ++++++++++++++++---
 2 files changed, 23 insertions(+), 3 deletions(-)

diff --git a/extra/interval-maps/interval-maps-tests.factor b/extra/interval-maps/interval-maps-tests.factor
index 54d2e9d26b..5a4b508939 100755
--- a/extra/interval-maps/interval-maps-tests.factor
+++ b/extra/interval-maps/interval-maps-tests.factor
@@ -11,3 +11,8 @@ SYMBOL: test
 [ 2 ] [ 1 test get interval-at ] unit-test
 [ f ] [ 2 test get interval-at ] unit-test
 [ f ] [ 0 test get interval-at ] unit-test
+
+[ { { { 1 4 } 3 } { { 4 8 } 6 } }  ] must-fail
+
+[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
+[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test
diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
index bc23d0d346..84d762a232 100755
--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@@ -1,5 +1,5 @@
 USING: kernel sequences arrays math.intervals accessors
-math.order sorting math assocs  ;
+math.order sorting math assocs locals namespaces ;
 IN: interval-maps
 
 TUPLE: interval-map array ;
@@ -24,6 +24,8 @@ M: interval >interval ;
 : ensure-disjoint ( intervals -- intervals )
     dup keys [ interval-intersect not ] monotonic?
     [ "Intervals are not disjoint" throw ] unless ;
+
+
 PRIVATE>
 
 : interval-at* ( key map -- value ? )
@@ -35,7 +37,20 @@ PRIVATE>
 : interval-key? ( key map -- ? ) interval-at* nip ;
 
 :  ( specification -- map )
-    all-intervals ensure-disjoint
-    [ [ first to>> ] compare ] sort
+    all-intervals { } assoc-like
+    [ [ first to>> ] compare ] sort ensure-disjoint
     [ interval-node boa ] { } assoc>map
     interval-map boa ;
+
+:: coalesce ( assoc -- specification )
+    ! Only works with integer keys, because they're discrete
+    ! Makes 2array keys
+    [
+        assoc sort-keys unclip first2 dupd roll
+        [| oldkey oldval key val | ! Underneath is start
+            oldkey 1+ key =
+            oldval val = and
+            [ oldkey 2array oldval 2array , key ] unless
+            key val
+        ] assoc-each [ 2array ] bi@ ,
+    ] { } make ;

From e3808cc50355c1dc68fbeae257bf786f9ea1b430 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg 
Date: Mon, 5 May 2008 23:46:51 -0500
Subject: [PATCH 08/77] Coalescing in interval maps

---
 extra/interval-maps/interval-maps.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
index 84d762a232..7dcb9466cc 100755
--- a/extra/interval-maps/interval-maps.factor
+++ b/extra/interval-maps/interval-maps.factor
@@ -42,11 +42,11 @@ PRIVATE>
     [ interval-node boa ] { } assoc>map
     interval-map boa ;
 
-:: coalesce ( assoc -- specification )
+:: coalesce ( alist -- specification )
     ! Only works with integer keys, because they're discrete
     ! Makes 2array keys
     [
-        assoc sort-keys unclip first2 dupd roll
+        alist sort-keys unclip first2 dupd roll
         [| oldkey oldval key val | ! Underneath is start
             oldkey 1+ key =
             oldval val = and

From d5f63983c39ace23bddbc931386e6c725de1dca6 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg 
Date: Mon, 5 May 2008 23:47:22 -0500
Subject: [PATCH 09/77] Unicode script uses interval maps

---
 extra/unicode/script/script.factor | 46 +++++++++++++-----------------
 1 file changed, 20 insertions(+), 26 deletions(-)

diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor
index 14fba46c4d..d0bb4ac30d 100755
--- a/extra/unicode/script/script.factor
+++ b/extra/unicode/script/script.factor
@@ -1,12 +1,12 @@
 USING: unicode.syntax.backend kernel sequences assocs io.files
 io.encodings ascii math.ranges io splitting math.parser 
 namespaces byte-arrays locals math sets io.encodings.ascii
-words compiler.units ;
+words compiler.units arrays interval-maps ;
 IN: unicode.script
 
 num-table
-VALUE: num>name-table
+VALUE: script-table
+SYMBOL: interned
 
 : parse-script ( stream -- assoc )
     ! assoc is code point/range => name
@@ -14,26 +14,18 @@ VALUE: num>name-table
         ";" split1 [ [ blank? ] trim ] bi@
     ] H{ } map>assoc ;
 
-: set-if ( value var -- )
-    dup 500000 < [ set ] [ 2drop ] if ;
+: range, ( value key -- )
+    swap interned get
+    [ word-name = ] with find nip 2array , ;
 
-: expand-ranges ( assoc -- char-assoc )
-    ! char-assoc is code point => name
-    [ [
-        CHAR: . pick member? [
-            swap ".." split1 [ hex> ] bi@ [a,b]
-            [ set-if ] with each
-        ] [ swap hex> set-if ] if
-    ] assoc-each ] H{ } make-assoc ;
-
-: hash>byte-array ( hash -- byte-array )
-    [ keys supremum 1+  dup ] keep
-    [ -rot set-nth ] with assoc-each ;
-
-: make-char>num ( assoc -- char>num-table )
-    expand-ranges
-    [ num>name-table index ] assoc-map
-    hash>byte-array ;
+: expand-ranges ( assoc -- interval-map )
+    [
+        [
+            CHAR: . pick member? [
+                swap ".." split1 [ hex> ] bi@ 2array
+            ] [ swap hex> ] if range,
+        ] assoc-each
+    ] { } make  ;
 
 : >symbols ( strings -- symbols )
     [
@@ -41,9 +33,9 @@ VALUE: num>name-table
     ] with-compilation-unit ;
 
 : process-script ( ranges -- )
-    [ values prune \ num>name-table set-value ]
-    [ make-char>num \ char>num-table set-value ] bi
-    num>name-table >symbols \ num>name-table set-value ;
+    dup values prune >symbols interned [
+        expand-ranges \ script-table set-value
+    ] with-variable ;
 
 : load-script ( -- )
     "resource:extra/unicode/script/Scripts.txt"
@@ -52,5 +44,7 @@ VALUE: num>name-table
 load-script
 PRIVATE>
 
+SYMBOL: Unknown
+
 : script-of ( char -- script )
-    char>num-table nth num>name-table nth ;
+    script-table interval-at [ Unknown ] unless* ;

From 70ea40681e0b5172caf09bbdaf3bbe2e46462538 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg 
Date: Tue, 6 May 2008 03:46:44 -0500
Subject: [PATCH 10/77] extra/lcs replaces extra/levenshtein... not fully
 debugged

---
 extra/lcs/authors.txt                         |  1 +
 extra/lcs/lcs-docs.factor                     |  6 ++
 .../lcs-tests.factor}                         |  9 +-
 extra/lcs/lcs.factor                          | 94 +++++++++++++++++++
 extra/lcs/summary.txt                         |  1 +
 extra/lcs/tags.txt                            |  1 +
 extra/levenshtein/authors.txt                 |  1 -
 extra/levenshtein/levenshtein.factor          | 47 ----------
 extra/levenshtein/summary.txt                 |  1 -
 9 files changed, 110 insertions(+), 51 deletions(-)
 create mode 100755 extra/lcs/authors.txt
 create mode 100755 extra/lcs/lcs-docs.factor
 rename extra/{levenshtein/levenshtein-tests.factor => lcs/lcs-tests.factor} (55%)
 mode change 100644 => 100755
 create mode 100755 extra/lcs/lcs.factor
 create mode 100755 extra/lcs/summary.txt
 create mode 100755 extra/lcs/tags.txt
 delete mode 100644 extra/levenshtein/authors.txt
 delete mode 100644 extra/levenshtein/levenshtein.factor
 delete mode 100644 extra/levenshtein/summary.txt

diff --git a/extra/lcs/authors.txt b/extra/lcs/authors.txt
new file mode 100755
index 0000000000..504363d316
--- /dev/null
+++ b/extra/lcs/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/extra/lcs/lcs-docs.factor b/extra/lcs/lcs-docs.factor
new file mode 100755
index 0000000000..6c5e2ae992
--- /dev/null
+++ b/extra/lcs/lcs-docs.factor
@@ -0,0 +1,6 @@
+USING: help.syntax help.markup ;
+IN: lcs
+
+HELP: levenshtein
+{ $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } }
+{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;
diff --git a/extra/levenshtein/levenshtein-tests.factor b/extra/lcs/lcs-tests.factor
old mode 100644
new mode 100755
similarity index 55%
rename from extra/levenshtein/levenshtein-tests.factor
rename to extra/lcs/lcs-tests.factor
index 722ccb86ca..45297c1bff
--- a/extra/levenshtein/levenshtein-tests.factor
+++ b/extra/lcs/lcs-tests.factor
@@ -1,9 +1,14 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: levenshtein.tests
-USING: tools.test levenshtein ;
+USING: tools.test lcs ;
 
 [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
 [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
 [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
 [ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
+
+[ "hell" ] [ "hello" "hell" lcs ] unit-test
+[ "hell" ] [ "hell" "hello" lcs ] unit-test
+[ "ell" ] [ "ell" "hell" lcs ] unit-test
+[ "ell" ] [ "hell" "ell" lcs ] unit-test
+[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
new file mode 100755
index 0000000000..b1584af78b
--- /dev/null
+++ b/extra/lcs/lcs.factor
@@ -0,0 +1,94 @@
+USING: sequences kernel math locals math.order math.ranges
+accessors combinators.lib arrays namespaces combinators ;
+IN: lcs
+
+! Classic dynamic programming O(n^2) algorithm for the
+! Longest Common Subsequence
+! Slight modification to get Levenshtein distance
+
+! j is row, i is column
+! Going from str1 to str2
+! str1 along side column, str2 along top row
+
+:: lcs-step ( i j matrix old new change-cost -- )
+    i j matrix nth nth
+        i old nth j new nth = 0 change-cost ? +
+    i j 1+ matrix nth nth 1+ ! insertion cost
+    i 1+ j matrix nth nth 1+ ! deletion cost
+    min min
+    i 1+ j 1+ matrix nth set-nth ;
+
+: lcs-initialize ( |str1| |str2| -- matrix )
+    [ drop 0  ] with map ;
+
+: levenshtein-initialize ( |str1| |str2| -- matrix )
+    [ [ + ] curry map ] with map ;
+
+:: run-lcs ( old new quot change-cost -- matrix )
+    [let | matrix [ old length 1+ new length 1+ quot call ] |
+        old length [0,b) [| i |
+            new length [0,b)
+            [| j | i j matrix old new change-cost lcs-step ]
+            each
+        ] each matrix ] ;
+
+: levenshtein ( old new -- n )
+    [ levenshtein-initialize ] 1 run-lcs peek peek ;
+
+TUPLE: retain item ;
+TUPLE: delete item ;
+TUPLE: insert item ;
+
+TUPLE: trace-state old new table i j ;
+
+: old-nth ( state -- elt )
+    [ i>> 1- ] [ old>> ] bi nth ;
+
+: new-nth ( state -- elt )
+    [ j>> 1- ] [ new>> ] bi nth ;
+
+: top-beats-side? ( state -- ? )
+    [ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]
+    [ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;
+
+: retained? ( state -- ? )
+    {
+        [ i>> 0 > ] [ j>> 0 > ]
+        [ [ old-nth ] [ new-nth ] bi = ]
+    } <-&& ;
+
+: do-retain ( state -- state )
+    dup old-nth retain boa ,
+    [ 1- ] change-i [ 1- ] change-j ;
+
+: inserted? ( state -- ? )
+    [ j>> 0 > ]
+    [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
+
+: do-insert ( state -- state )
+    dup new-nth insert boa , [ 1- ] change-j ;
+
+: deleted? ( state -- ? )
+    [ i>> 0 > ]
+    [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
+
+: do-delete ( state -- state )
+    dup old-nth delete boa , [ 1- ] change-i ;
+
+: (trace-diff) ( state -- )
+    {
+        { [ dup retained? ] [ do-retain (trace-diff) ] }
+        { [ dup inserted? ] [ do-insert (trace-diff) ] }
+        { [ dup deleted? ] [ do-delete (trace-diff) ] }
+        [ drop ] ! i=j=0
+    } cond ;
+
+: trace-diff ( old new table -- diff )
+    [ ] [ first length 1- ] [ length 1- ] tri trace-state boa
+    [ (trace-diff) ] { } make reverse ;
+
+: diff ( old new -- diff )
+    2dup [ lcs-initialize ] 2 run-lcs trace-diff ;
+
+: lcs ( str1 str2 -- lcs )
+    [ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;
diff --git a/extra/lcs/summary.txt b/extra/lcs/summary.txt
new file mode 100755
index 0000000000..9e70fd7e63
--- /dev/null
+++ b/extra/lcs/summary.txt
@@ -0,0 +1 @@
+Levenshtein distance and diff between sequences
diff --git a/extra/lcs/tags.txt b/extra/lcs/tags.txt
new file mode 100755
index 0000000000..4d914f4c46
--- /dev/null
+++ b/extra/lcs/tags.txt
@@ -0,0 +1 @@
+algorithms
diff --git a/extra/levenshtein/authors.txt b/extra/levenshtein/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/extra/levenshtein/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/levenshtein/levenshtein.factor b/extra/levenshtein/levenshtein.factor
deleted file mode 100644
index 07731bfb84..0000000000
--- a/extra/levenshtein/levenshtein.factor
+++ /dev/null
@@ -1,47 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help io kernel math namespaces sequences
-math.order ;
-IN: levenshtein
-
-:  ( m n -- matrix )
-    [ drop 0  ] with map ; inline
-
-: matrix-> nth nth ; inline
-: ->matrix nth set-nth ; inline
-
-SYMBOL: d
-
-: ->d ( n i j -- ) d get ->matrix ; inline
-: d-> ( i j -- n ) d get matrix-> ; inline
-
-SYMBOL: costs
-
-: init-d ( str1 str2 -- )
-    [ length 1+ ] bi@ 2dup  d set
-    [ 0 over ->d ] each
-    [ dup 0 ->d ] each ; inline
-
-: compute-costs ( str1 str2 -- )
-    swap [
-        [ = 0 1 ? ] with { } map-as
-    ] curry { } map-as costs set ; inline
-
-: levenshtein-step ( i j -- )
-    [ 1+ d-> 1+ ] 2keep
-    [ >r 1+ r> d-> 1+ ] 2keep
-    [ d-> ] 2keep
-    [ costs get matrix-> + min min ] 2keep
-    >r 1+ r> 1+ ->d ; inline
-
-: levenshtein-result ( -- n ) d get peek peek ; inline
-
-: levenshtein ( str1 str2 -- n )
-    [
-        2dup init-d
-        2dup compute-costs
-        [ length ] bi@ [
-            [ levenshtein-step ] curry each
-        ] with each
-        levenshtein-result
-    ] with-scope ;
diff --git a/extra/levenshtein/summary.txt b/extra/levenshtein/summary.txt
deleted file mode 100644
index 583669a8b0..0000000000
--- a/extra/levenshtein/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Levenshtein edit distance algorithm

From 32d032e8fcc3cec47b0d6d224feccbb2cd050cd1 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg 
Date: Tue, 6 May 2008 03:47:39 -0500
Subject: [PATCH 11/77] lcs update

---
 extra/lcs/lcs-tests.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/lcs/lcs-tests.factor b/extra/lcs/lcs-tests.factor
index 45297c1bff..c3f1e61342 100755
--- a/extra/lcs/lcs-tests.factor
+++ b/extra/lcs/lcs-tests.factor
@@ -7,8 +7,8 @@ USING: tools.test lcs ;
 [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
 [ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
 
-[ "hell" ] [ "hello" "hell" lcs ] unit-test
-[ "hell" ] [ "hell" "hello" lcs ] unit-test
+! [ "hell" ] [ "hello" "hell" lcs ] unit-test
+! [ "hell" ] [ "hell" "hello" lcs ] unit-test
 [ "ell" ] [ "ell" "hell" lcs ] unit-test
 [ "ell" ] [ "hell" "ell" lcs ] unit-test
-[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
+! [ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test

From 631da78867c84a1b057a937324b6adc2c02050c5 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 6 May 2008 05:01:27 -0500
Subject: [PATCH 12/77] Add Linux constants

---
 extra/unix/linux/linux.factor | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor
index 11db6cc862..74195fae36 100755
--- a/extra/unix/linux/linux.factor
+++ b/extra/unix/linux/linux.factor
@@ -24,6 +24,9 @@ USING: alien.syntax ;
 : SO_SNDTIMEO HEX: 15 ; inline
 : SO_RCVTIMEO HEX: 14 ; inline
 
+: F_SETFD 2 ; inline
+: FD_CLOEXEC 1 ; inline
+
 : F_SETFL 4 ; inline
 : O_NONBLOCK HEX: 800 ; inline
 

From 53832ccd2f070c37349649e7f6f3ea884faf9c14 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 6 May 2008 09:01:28 -0500
Subject: [PATCH 13/77] Fix

---
 core/classes/tuple/tuple-tests.factor   | 12 ++++++++++++
 core/debugger/debugger-docs.factor      |  6 +-----
 extra/tools/deploy/shaker/shaker.factor |  2 +-
 3 files changed, 14 insertions(+), 6 deletions(-)

diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 0cde687f16..fb9530b1c5 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -542,3 +542,15 @@ TUPLE: another-forget-accessors-test ;
 
 ! Missing error check
 [ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+
+TUPLE: subclass-forget-test ;
+
+TUPLE: subclass-forget-test-1 < subclass-forget-test ;
+TUPLE: subclass-forget-test-2 < subclass-forget-test ;
+TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
+
+[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+
+[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
+[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
+[ subclass-forget-test-3 new ] must-fail
diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor
index cb79597a73..071310b433 100755
--- a/core/debugger/debugger-docs.factor
+++ b/core/debugger/debugger-docs.factor
@@ -81,13 +81,9 @@ HELP: print-error
 HELP: restarts.
 { $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
 
-HELP: error-hook
-{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
-{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
-
 HELP: try
 { $values { "quot" "a quotation" } }
-{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
+{ $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." }
 { $examples
     "The following example prints an error and keeps going:"
     { $code
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index 86c50387b5..1374254612 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -114,7 +114,7 @@ IN: tools.deploy.shaker
             continuations:error-continuation
             continuations:error-thread
             continuations:restarts
-            error-hook
+            listener:error-hook
             init:init-hooks
             inspector:inspector-hook
             io.thread:io-thread

From 6590c60cb31abe90449142388db96733819a308c Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 6 May 2008 11:27:13 -0500
Subject: [PATCH 14/77] fix bootstrap

---
 core/debugger/debugger-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor
index cb79597a73..3fbac64099 100755
--- a/core/debugger/debugger-docs.factor
+++ b/core/debugger/debugger-docs.factor
@@ -1,7 +1,7 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
 help generic.standard continuations system debugger.private
-io.files.private ;
+io.files.private listener ;
 IN: debugger
 
 ARTICLE: "errors-assert" "Assertions"

From 0b21c84e75fe3ed1689c656338bf5f9d17d232dd Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 6 May 2008 12:16:04 -0500
Subject: [PATCH 15/77] fix errors i introduced with the state-parser cleanup

---
 extra/xml/errors/errors.factor | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/extra/xml/errors/errors.factor b/extra/xml/errors/errors.factor
index 3e24d7e720..53f2046a54 100644
--- a/extra/xml/errors/errors.factor
+++ b/extra/xml/errors/errors.factor
@@ -119,9 +119,8 @@ M: bad-version summary ( obj -- str )
         num>> .
     ] with-string-writer ;
 
-TUPLE: notags < parsing-error ;
-: 
-    \ notags parsing-error ;
+TUPLE: notags ;
+C:  notags
 M: notags summary ( obj -- str )
     drop "XML document lacks a main tag" ;
 
@@ -162,7 +161,7 @@ M: bad-instruction summary ( obj -- str )
     [
         dup call-next-method write
         "Misplaced processor instruction:" print
-        bad-instruction-inst write-item nl
+        instruction>> write-item nl
     ] with-string-writer ;
 
 TUPLE: bad-directive < parsing-error dir ;

From e7713148337d2d958c40d3529836b3d2aa936a68 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 6 May 2008 12:36:32 -0500
Subject: [PATCH 16/77] add butlast and butlast-slice with docs

---
 core/sequences/sequences-docs.factor | 14 +++++++++++++-
 core/sequences/sequences.factor      |  8 ++++++--
 2 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 2a2fcf29cd..67d26089b0 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -92,6 +92,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
 { $subsection subseq }
 { $subsection head }
 { $subsection tail }
+{ $subsection butlast }
 { $subsection rest }
 { $subsection head* }
 { $subsection tail* }
@@ -106,6 +107,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
 { $subsection  }
 { $subsection head-slice }
 { $subsection tail-slice }
+{ $subsection butlast-slice }
 { $subsection rest-slice }
 { $subsection head-slice* }
 { $subsection tail-slice* }
@@ -836,11 +838,16 @@ HELP: tail-slice
 { $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
 { $errors "Throws an error if the index is out of bounds." } ;
 
+HELP: butlast-slice
+{ $values { "seq" sequence } { "slice" "a slice" } }
+{ $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." }
+{ $errors "Throws an error on an empty sequence." } ;
+
 HELP: rest-slice
 { $values { "seq" sequence } { "slice" "a slice" } }
 { $description "Outputs a virtual sequence sharing storage with all elements from the 1st index until the end of the input sequence." }
 { $notes "Equivalent to " { $snippet "1 tail" } }
-{ $errors "Throws an error if the index is out of bounds." } ;
+{ $errors "Throws an error on an empty sequence." } ;
 
 HELP: head-slice*
 { $values { "seq" sequence } { "n" "a non-negative integer" } { "slice" "a slice" } }
@@ -862,6 +869,11 @@ HELP: tail
 { $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
 { $errors "Throws an error if the index is out of bounds." } ;
 
+HELP: butlast
+{ $values { "seq" sequence } { "headseq" "a new sequence" } }
+{ $description "Outputs a new sequence consisting of the input sequence with the last item removed." }
+{ $errors "Throws an error on an empty sequence." } ;
+
 HELP: rest
 { $values { "seq" sequence } { "tailseq" "a new sequence" } }
 { $description "Outputs a new sequence consisting of the input sequence with the first item removed." }
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index f39bf08e58..1e9d187c2d 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -216,6 +216,8 @@ M: slice length dup slice-to swap slice-from - ;
 
 : tail-slice* ( seq n -- slice ) from-end tail-slice ;
 
+: butlast-slice ( seq -- slice ) 1 head-slice* ;
+
 INSTANCE: slice virtual-sequence
 
 ! One element repeated many times
@@ -263,6 +265,8 @@ PRIVATE>
 
 : tail* ( seq n -- tailseq ) from-end tail ;
 
+: butlast ( seq -- headseq ) 1 head* ;
+
 : copy ( src i dst -- )
     pick length >r 3dup check-copy spin 0 r>
     (copy) drop ; inline
@@ -671,13 +675,13 @@ PRIVATE>
     [ rest ] [ first ] bi ;
 
 : unclip-last ( seq -- butfirst last )
-    [ 1 head* ] [ peek ] bi ;
+    [ butlast ] [ peek ] bi ;
 
 : unclip-slice ( seq -- rest first )
     [ rest-slice ] [ first ] bi ;
 
 : unclip-last-slice ( seq -- butfirst last )
-    [ 1 head-slice* ] [ peek ] bi ;
+    [ butlast-slice ] [ peek ] bi ;
 
 :  ( seq -- slice )
     dup slice? [ { } like ] when 0 over length rot  ;

From 01f20cf32d664743d4e86a5f45e364b4dedc0cee Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 6 May 2008 12:36:49 -0500
Subject: [PATCH 17/77] update core to use butlast, butlast-slice

---
 core/classes/tuple/tuple.factor             | 2 +-
 core/inference/transforms/transforms.factor | 2 +-
 core/prettyprint/prettyprint-tests.factor   | 2 +-
 core/prettyprint/sections/sections.factor   | 2 +-
 core/splitting/splitting.factor             | 2 +-
 5 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index ee7ff8c608..fb6f1ffba0 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -102,7 +102,7 @@ ERROR: bad-superclass class ;
     dup tuple-predicate-quot define-predicate ;
 
 : superclass-size ( class -- n )
-    superclasses 1 head-slice*
+    superclasses butlast-slice
     [ slot-names length ] map sum ;
 
 : generate-tuple-slots ( class slots -- slot-specs )
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 624dcbbf98..cf3dcadd75 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -32,7 +32,7 @@ IN: inference.transforms
         drop [ no-case ]
     ] [
         dup peek quotation? [
-            dup peek swap 1 head*
+            dup peek swap butlast
         ] [
             [ no-case ] swap
         ] if case>quot
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index e94670992c..834cad5b29 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -114,7 +114,7 @@ unit-test
             [ parse-fresh drop ] with-compilation-unit
             [
                 "prettyprint.tests" lookup see
-            ] with-string-writer "\n" split 1 head*
+            ] with-string-writer "\n" split butlast
         ] keep =
     ] with-scope ;
 
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index 5f32539115..0ce8841256 100644
--- a/core/prettyprint/sections/sections.factor
+++ b/core/prettyprint/sections/sections.factor
@@ -284,7 +284,7 @@ M: colon unindent-first-line? drop t ;
 
 ! Long section layout algorithm
 : chop-break ( seq -- seq )
-    dup peek line-break? [ 1 head-slice* chop-break ] when ;
+    dup peek line-break? [ butlast-slice chop-break ] when ;
 
 SYMBOL: prev
 SYMBOL: next
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index 62c5121e50..be0652fd98 100755
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -104,7 +104,7 @@ M: sliced-clumps nth group@  ;
         1array
     ] [
         "\n" split [
-            1 head-slice* [
+            butlast-slice [
                 "\r" ?tail drop "\r" split
             ] map
         ] keep peek "\r" split suffix concat

From 7c09936f30ff9827335d0ffd77124f32d373bd33 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 6 May 2008 12:37:11 -0500
Subject: [PATCH 18/77] use butlast, butlast-slice "extra/foo" resource-path ->
 "resource:extra/foo"

---
 .../benchmark/knucleotide/knucleotide.factor  |  2 +-
 extra/combinators/lib/lib.factor              |  5 +++++
 extra/help/lint/lint.factor                   |  2 +-
 extra/html/parser/analyzer/analyzer.factor    |  2 +-
 extra/html/parser/utils/utils.factor          |  2 +-
 extra/http/http-tests.factor                  |  4 ++--
 extra/icfp/2006/2006.factor                   |  2 +-
 extra/inverse/inverse.factor                  |  2 +-
 extra/io/encodings/8-bit/8-bit.factor         |  5 ++---
 .../windows/nt/launcher/launcher-tests.factor | 14 ++++++-------
 extra/koszul/koszul.factor                    |  2 +-
 extra/locals/locals.factor                    |  2 +-
 extra/mortar/mortar.factor                    |  2 +-
 extra/multiline/multiline.factor              |  4 ++--
 extra/openssl/openssl-tests.factor            | 10 +++++-----
 .../porter-stemmer-tests.factor               |  6 ++----
 extra/porter-stemmer/porter-stemmer.factor    | 12 +++++------
 extra/project-euler/002/002.factor            |  2 +-
 extra/project-euler/022/022.factor            |  2 +-
 extra/project-euler/042/042.factor            |  2 +-
 extra/project-euler/059/059.factor            |  4 ++--
 extra/project-euler/067/067.factor            |  2 +-
 extra/project-euler/079/079.factor            |  2 +-
 extra/rss/rss-tests.factor                    |  4 ++--
 extra/space-invaders/space-invaders.factor    | 20 +++++++++----------
 extra/tangle/tangle.factor                    |  2 +-
 extra/tools/deploy/backend/backend.factor     |  4 ++--
 extra/tuple-syntax/tuple-syntax.factor        |  2 +-
 extra/ui/gestures/gestures.factor             |  2 +-
 extra/unicode/breaks/breaks.factor            |  2 +-
 extra/unicode/data/data.factor                |  4 ++--
 extra/xml/tests/soap.factor                   |  2 +-
 extra/xml/tests/test.factor                   |  2 +-
 extra/xmode/catalog/catalog.factor            |  6 +++---
 extra/xmode/code2html/code2html.factor        |  4 ++--
 extra/xmode/utilities/utilities-tests.factor  |  4 ++--
 extra/yahoo/yahoo-tests.factor                |  2 +-
 37 files changed, 76 insertions(+), 76 deletions(-)

diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor
index e06b81f6de..6bd2d69cfa 100644
--- a/extra/benchmark/knucleotide/knucleotide.factor
+++ b/extra/benchmark/knucleotide/knucleotide.factor
@@ -56,7 +56,7 @@ IN: benchmark.knucleotide
     drop ;
 
 : knucleotide ( -- )
-    "extra/benchmark/knucleotide/knucleotide-input.txt" resource-path
+    "resource:extra/benchmark/knucleotide/knucleotide-input.txt"
     ascii [ read-input ] with-file-reader
     process-input ;
 
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 84b41a91ff..5dfe8527c1 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -169,3 +169,8 @@ MACRO: multikeep ( word out-indexes -- ... )
 : generate ( generator predicate -- obj )
     [ dup ] swap [ dup [ nip ] unless not ] 3compose
     swap [ ] do-while ;
+
+MACRO: predicates ( seq -- quot/f )
+    dup [ 1quotation [ drop ] prepend ] map
+    >r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
+    [ cond ] curry ;
diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor
index fc4b7f6f25..a120d791aa 100755
--- a/extra/help/lint/lint.factor
+++ b/extra/help/lint/lint.factor
@@ -10,7 +10,7 @@ IN: help.lint
 
 : check-example ( element -- )
     rest [
-        1 head* "\n" join 1vector
+        butlast "\n" join 1vector
         [
             use [ clone ] change
             [ eval>string ] with-datastack
diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor
index 160b95ab1d..1912cfb65c 100755
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@@ -99,7 +99,7 @@ IN: html.parser.analyzer
     
 : find-between ( i/f tag/f vector -- vector )
     find-between* dup length 3 >= [
-        [ rest-slice 1 head-slice* ] keep like
+        [ rest-slice butlast-slice ] keep like
     ] when ;
 
 : find-between-first ( string vector -- vector' )
diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor
index 0ae75e41fd..c0eee57ead 100644
--- a/extra/html/parser/utils/utils.factor
+++ b/extra/html/parser/utils/utils.factor
@@ -36,7 +36,7 @@ IN: html.parser.utils
     dup quoted? [ quote ] unless ;
 
 : unquote ( str -- newstr )
-    dup quoted? [ 1 head-slice* rest-slice >string ] when ;
+    dup quoted? [ butlast-slice rest-slice >string ] when ;
 
 : quote? ( ch -- ? ) "'\"" member? ;
 
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 07b34f17c3..21eb241b84 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -166,7 +166,7 @@ test-db [
         
             add-quit-action
             
-                "extra/http/test" resource-path  >>default
+                "resource:extra/http/test"  >>default
             "nested" add-responder
             
                 [ "redirect-loop" f  ] >>display
@@ -178,7 +178,7 @@ test-db [
 ] unit-test
 
 [ t ] [
-    "extra/http/test/foo.html" resource-path ascii file-contents
+    "resource:extra/http/test/foo.html" ascii file-contents
     "http://localhost:1237/nested/foo.html" http-get =
 ] unit-test
 
diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor
index e88301c7f8..ca6f9d5905 100755
--- a/extra/icfp/2006/2006.factor
+++ b/extra/icfp/2006/2006.factor
@@ -148,4 +148,4 @@ SYMBOL: open-arrays
     init f exec-loop ;
 
 : run-sand ( -- )
-    "extra/icfp/2006/sandmark.umz" resource-path run-prog ;
+    "resource:extra/icfp/2006/sandmark.umz" run-prog ;
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index 265675f8df..8c19ade499 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -197,7 +197,7 @@ DEFER: _
 
 \ prefix [ unclip ] define-inverse
 \ unclip [ prefix ] define-inverse
-\ suffix [ dup 1 head* swap peek ] define-inverse
+\ suffix [ dup butlast swap peek ] define-inverse
 
 ! Constructor inverse
 : deconstruct-pred ( class -- quot )
diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor
index 3fbb3908e2..88414efd16 100755
--- a/extra/io/encodings/8-bit/8-bit.factor
+++ b/extra/io/encodings/8-bit/8-bit.factor
@@ -30,9 +30,8 @@ IN: io.encodings.8-bit
 } ;
 
 : encoding-file ( file-name -- stream )
-    "extra/io/encodings/8-bit/" ".TXT"
-    swapd 3append resource-path
-    ascii  ;
+    "resource:extra/io/encodings/8-bit/" ".TXT"
+    swapd 3append ascii  ;
 
 : tail-if ( seq n -- newseq )
     2dup swap length <= [ tail ] [ drop ] if ;
diff --git a/extra/io/windows/nt/launcher/launcher-tests.factor b/extra/io/windows/nt/launcher/launcher-tests.factor
index c5c0e6dec2..254f845c48 100755
--- a/extra/io/windows/nt/launcher/launcher-tests.factor
+++ b/extra/io/windows/nt/launcher/launcher-tests.factor
@@ -41,7 +41,7 @@ sequences parser assocs hashtables math continuations ;
 ] unit-test
 
 [ ] [
-    "extra/io/windows/nt/launcher/test" resource-path [
+    "resource:extra/io/windows/nt/launcher/test" [
         
             vm "-script" "stderr.factor" 3array >>command
             "out.txt" temp-file >>stdout
@@ -59,7 +59,7 @@ sequences parser assocs hashtables math continuations ;
 ] unit-test
 
 [ ] [
-    "extra/io/windows/nt/launcher/test" resource-path [
+    "resource:extra/io/windows/nt/launcher/test" [
         
             vm "-script" "stderr.factor" 3array >>command
             "out.txt" temp-file >>stdout
@@ -73,7 +73,7 @@ sequences parser assocs hashtables math continuations ;
 ] unit-test
 
 [ "output" ] [
-    "extra/io/windows/nt/launcher/test" resource-path [
+    "resource:extra/io/windows/nt/launcher/test" [
         
             vm "-script" "stderr.factor" 3array >>command
             "err2.txt" temp-file >>stderr
@@ -86,7 +86,7 @@ sequences parser assocs hashtables math continuations ;
 ] unit-test
 
 [ t ] [
-    "extra/io/windows/nt/launcher/test" resource-path [
+    "resource:extra/io/windows/nt/launcher/test" [
         
             vm "-script" "env.factor" 3array >>command
         ascii  contents
@@ -96,7 +96,7 @@ sequences parser assocs hashtables math continuations ;
 ] unit-test
 
 [ t ] [
-    "extra/io/windows/nt/launcher/test" resource-path [
+    "resource:extra/io/windows/nt/launcher/test" [
         
             vm "-script" "env.factor" 3array >>command
             +replace-environment+ >>environment-mode
@@ -108,7 +108,7 @@ sequences parser assocs hashtables math continuations ;
 ] unit-test
 
 [ "B" ] [
-    "extra/io/windows/nt/launcher/test" resource-path [
+    "resource:extra/io/windows/nt/launcher/test" [
         
             vm "-script" "env.factor" 3array >>command
             { { "A" "B" } } >>environment
@@ -119,7 +119,7 @@ sequences parser assocs hashtables math continuations ;
 ] unit-test
 
 [ f ] [
-    "extra/io/windows/nt/launcher/test" resource-path [
+    "resource:extra/io/windows/nt/launcher/test" [
         
             vm "-script" "env.factor" 3array >>command
             { { "HOME" "XXX" } } >>environment
diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index e9de82ebb6..5c337f8ce7 100755
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -184,7 +184,7 @@ DEFER: (d)
     [ length ] keep [ (graded-ker/im-d) ] curry map ;
 
 : graded-betti ( generators -- seq )
-    basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ;
+    basis graded graded-ker/im-d flip first2 butlast 0 prefix v- ;
 
 ! Bi-graded for two-step complexes
 : (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index d18017f69b..4ad81ef00a 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -101,7 +101,7 @@ UNION: special local quote local-word local-reader local-writer ;
     ] if ;
 
 : point-free-body ( quot args -- newquot )
-    >r 1 head-slice* r> [ localize ] curry map concat ;
+    >r butlast-slice r> [ localize ] curry map concat ;
 
 : point-free-end ( quot args -- newquot )
     over peek special?
diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor
index b7862af7ac..3d4d287ace 100644
--- a/extra/mortar/mortar.factor
+++ b/extra/mortar/mortar.factor
@@ -122,7 +122,7 @@ over class-class-methods assoc-stack call ;
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : send-message-next ( object message -- )
-over object-class class-methods 1 head* assoc-stack call ;
+over object-class class-methods butlast assoc-stack call ;
 
 : <-~ scan parsed \ send-message-next parsed ; parsing
 
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index e140c5227c..acff8c8669 100755
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -14,7 +14,7 @@ IN: multiline
     ] [ ";" unexpected-eof ] if* ;
 
 : parse-here ( -- str )
-    [ (parse-here) ] "" make 1 head*
+    [ (parse-here) ] "" make butlast
     lexer get next-line ;
 
 : STRING:
@@ -34,7 +34,7 @@ IN: multiline
     [
         lexer get lexer-column swap (parse-multiline-string)
         lexer get set-lexer-column
-    ] "" make rest 1 head* ;
+    ] "" make rest butlast ;
 
 : <"
     "\">" parse-multiline-string parsed ; parsing
diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor
index f42c611fc0..2b840bdb9c 100755
--- a/extra/openssl/openssl-tests.factor
+++ b/extra/openssl/openssl-tests.factor
@@ -27,7 +27,7 @@ math.parser openssl prettyprint sequences tools.test ;
 
 [ ] [ ssl-v23 new-ctx ] unit-test
 
-[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
+[ ] [ get-ctx "resource:extra/openssl/test/server.pem" use-cert-chain ] unit-test
 
 ! TODO: debug 'Memory protection fault at address 6c'
 ! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
@@ -35,10 +35,10 @@ math.parser openssl prettyprint sequences tools.test ;
 [ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
 
 ! Enter PEM pass phrase: password
-[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path
+[ ] [ get-ctx "resource:extra/openssl/test/server.pem"
 SSL_FILETYPE_PEM use-private-key ] unit-test
 
-[ ] [ get-ctx "extra/openssl/test/root.pem" resource-path f
+[ ] [ get-ctx "resource:extra/openssl/test/root.pem" f
 verify-load-locations ] unit-test
 
 [ ] [ get-ctx 1 set-verify-depth ] unit-test
@@ -47,7 +47,7 @@ verify-load-locations ] unit-test
 ! Load Diffie-Hellman parameters
 ! =========================================================
 
-[ ] [ "extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
+[ ] [ "resource:extra/openssl/test/dh1024.pem" "r" bio-new-file ] unit-test
 
 [ ] [ get-bio f f f read-pem-dh-params ] unit-test
 
@@ -131,7 +131,7 @@ verify-load-locations ] unit-test
 ! Dump errors to file
 ! =========================================================
 
-[ ] [ "extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
+[ ] [ "resource:extra/openssl/test/errors.txt" "w" bio-new-file ] unit-test
 
 [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
 
diff --git a/extra/porter-stemmer/porter-stemmer-tests.factor b/extra/porter-stemmer/porter-stemmer-tests.factor
index 32386fed2b..42c358646b 100644
--- a/extra/porter-stemmer/porter-stemmer-tests.factor
+++ b/extra/porter-stemmer/porter-stemmer-tests.factor
@@ -56,11 +56,9 @@ io.files io.encodings.utf8 ;
 [ "hell" ] [ "hell" step5 "" like ] unit-test
 [ "mate" ] [ "mate" step5 "" like ] unit-test
 
-: resource-lines resource-path utf8 file-lines ;
-
 [ { } ] [
-    "extra/porter-stemmer/test/voc.txt" resource-lines
+    "resource:extra/porter-stemmer/test/voc.txt" utf8 file-lines
     [ stem ] map
-    "extra/porter-stemmer/test/output.txt" resource-lines
+    "resource:extra/porter-stemmer/test/output.txt" utf8 file-lines
     [ 2array ] 2map [ first2 = not ] filter
 ] unit-test
diff --git a/extra/porter-stemmer/porter-stemmer.factor b/extra/porter-stemmer/porter-stemmer.factor
index 81820e0152..f6975ccce7 100644
--- a/extra/porter-stemmer/porter-stemmer.factor
+++ b/extra/porter-stemmer/porter-stemmer.factor
@@ -66,8 +66,6 @@ USING: kernel math parser sequences combinators splitting ;
 : r ( str oldsuffix newsuffix -- str )
     pick consonant-seq 0 > [ nip ] [ drop ] if append ;
 
-: butlast ( seq -- seq ) 1 head-slice* ;
-
 : step1a ( str -- newstr )
     dup peek CHAR: s = [
         {
@@ -95,7 +93,7 @@ USING: kernel math parser sequences combinators splitting ;
         { [ "iz" ?tail ] [ "ize" append ] }
         {
             [ dup length 1- over double-consonant? ]
-            [ dup "lsz" last-is? [ butlast ] unless ]
+            [ dup "lsz" last-is? [ butlast-slice ] unless ]
         }
         {
             [ t ]
@@ -122,7 +120,7 @@ USING: kernel math parser sequences combinators splitting ;
     } cond ;
 
 : step1c ( str -- newstr )
-    dup butlast stem-vowel? [
+    dup butlast-slice stem-vowel? [
         "y" ?tail [ "i" append ] when
     ] when ;
 
@@ -198,18 +196,18 @@ USING: kernel math parser sequences combinators splitting ;
 : remove-e? ( str -- ? )
     dup consonant-seq dup 1 >
     [ 2drop t ]
-    [ 1 = [ butlast cvc? not ] [ drop f ] if ] if ;
+    [ 1 = [ butlast-slice cvc? not ] [ drop f ] if ] if ;
 
 : remove-e ( str -- newstr )
     dup peek CHAR: e = [
-        dup remove-e? [ butlast ] when
+        dup remove-e? [ butlast-slice ] when
     ] when ;
 
 : ll->l ( str -- newstr )
     {
         { [ dup peek CHAR: l = not ] [ ] }
         { [ dup length 1- over double-consonant? not ] [ ] }
-        { [ dup consonant-seq 1 > ] [ butlast ] }
+        { [ dup consonant-seq 1 > ] [ butlast-slice ] }
         [ ]
     } cond ;
 
diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor
index c2def03ace..6c9d331c90 100644
--- a/extra/project-euler/002/002.factor
+++ b/extra/project-euler/002/002.factor
@@ -41,7 +41,7 @@ PRIVATE>
 
 : fib-upto* ( n -- seq )
     0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
-    1 head-slice* { 0 1 } prepend ;
+    butlast-slice { 0 1 } prepend ;
 
 : euler002a ( -- answer )
     1000000 fib-upto* [ even? ] filter sum ;
diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor
index 452d2ec637..82054ce014 100644
--- a/extra/project-euler/022/022.factor
+++ b/extra/project-euler/022/022.factor
@@ -28,7 +28,7 @@ IN: project-euler.022
 number ] map ;
 
@@ -78,7 +78,7 @@ INSTANCE: rollover immutable-sequence
     frequency-analysis sort-values keys peek ;
 
 : crack-key ( seq key-length -- key )
-    [ " " decrypt ] dip group 1 head-slice*
+    [ " " decrypt ] dip group butlast-slice
     flip [ most-frequent ] map ;
 
 PRIVATE>
diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor
index 436ccde776..3e16996e04 100644
--- a/extra/project-euler/067/067.factor
+++ b/extra/project-euler/067/067.factor
@@ -38,7 +38,7 @@ IN: project-euler.067
 number ] map ] map ;
 
 PRIVATE>
diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor
index 3674804b0c..cde4dc079b 100644
--- a/extra/project-euler/079/079.factor
+++ b/extra/project-euler/079/079.factor
@@ -27,7 +27,7 @@ IN: project-euler.079
 edges ( seq -- seq )
     [
diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor
index 252defe99b..0e6bb0b9c1 100755
--- a/extra/rss/rss-tests.factor
+++ b/extra/rss/rss-tests.factor
@@ -22,7 +22,7 @@ IN: rss.tests
             f
         }
     }
-} ] [ "extra/rss/rss1.xml" resource-path load-news-file ] unit-test
+} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test
 [ T{
     feed
     f
@@ -39,4 +39,4 @@ IN: rss.tests
             T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
         }
     }
-} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test
+} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test
diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor
index 200257b31c..f773d331b1 100755
--- a/extra/space-invaders/space-invaders.factor
+++ b/extra/space-invaders/space-invaders.factor
@@ -45,21 +45,21 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s
 
 : init-sound ( index cpu filename  -- )
   swapd >r space-invaders-sounds nth AL_BUFFER r> 
-  resource-path create-buffer-from-wav set-source-param ; 
+  create-buffer-from-wav set-source-param ; 
 
 : init-sounds ( cpu -- )
   init-openal
   [ 9 gen-sources swap set-space-invaders-sounds ] keep
-  [ SOUND-SHOT        "extra/space-invaders/resources/Shot.wav" init-sound ] keep 
-  [ SOUND-UFO         "extra/space-invaders/resources/Ufo.wav" init-sound ] keep 
+  [ SOUND-SHOT        "resource:extra/space-invaders/resources/Shot.wav" init-sound ] keep 
+  [ SOUND-UFO         "resource:extra/space-invaders/resources/Ufo.wav" init-sound ] keep 
   [ space-invaders-sounds SOUND-UFO swap nth AL_LOOPING AL_TRUE set-source-param ] keep
-  [ SOUND-BASE-HIT    "extra/space-invaders/resources/BaseHit.wav" init-sound ] keep 
-  [ SOUND-INVADER-HIT "extra/space-invaders/resources/InvHit.wav" init-sound ] keep 
-  [ SOUND-WALK1       "extra/space-invaders/resources/Walk1.wav" init-sound ] keep 
-  [ SOUND-WALK2       "extra/space-invaders/resources/Walk2.wav" init-sound ] keep 
-  [ SOUND-WALK3       "extra/space-invaders/resources/Walk3.wav" init-sound ] keep 
-  [ SOUND-WALK4       "extra/space-invaders/resources/Walk4.wav" init-sound ] keep 
-  [ SOUND-UFO-HIT    "extra/space-invaders/resources/UfoHit.wav" init-sound ] keep
+  [ SOUND-BASE-HIT    "resource:extra/space-invaders/resources/BaseHit.wav" init-sound ] keep 
+  [ SOUND-INVADER-HIT "resource:extra/space-invaders/resources/InvHit.wav" init-sound ] keep 
+  [ SOUND-WALK1       "resource:extra/space-invaders/resources/Walk1.wav" init-sound ] keep 
+  [ SOUND-WALK2       "resource:extra/space-invaders/resources/Walk2.wav" init-sound ] keep 
+  [ SOUND-WALK3       "resource:extra/space-invaders/resources/Walk3.wav" init-sound ] keep 
+  [ SOUND-WALK4       "resource:extra/space-invaders/resources/Walk4.wav" init-sound ] keep 
+  [ SOUND-UFO-HIT    "resource:extra/space-invaders/resources/UfoHit.wav" init-sound ] keep
   f swap set-space-invaders-looping? ;
 
 :  ( -- cpu )
diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor
index afaf3da3cd..52c454f97f 100644
--- a/extra/tangle/tangle.factor
+++ b/extra/tangle/tangle.factor
@@ -65,7 +65,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ;
 :  ( tangle -- dispatcher )
     tangle-dispatcher new-dispatcher swap >>tangle
      >>default
-    "extra/tangle/resources" resource-path  "resources" add-responder
+    "resource:extra/tangle/resources"  "resources" add-responder
      "node" add-responder
      [ all-node-ids  ] >>display "all" add-responder ;
 
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index ed466b6965..60d66e89cd 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -63,11 +63,11 @@ DEFER: ?make-staging-image
         dup empty? [
             "-i=" my-boot-image-name append ,
         ] [
-            dup 1 head* ?make-staging-image
+            dup butlast ?make-staging-image
 
             "-resource-path=" "" resource-path append ,
 
-            "-i=" over 1 head* staging-image-name append ,
+            "-i=" over butlast staging-image-name append ,
 
             "-run=tools.deploy.restage" ,
         ] if
diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor
index 219df5197c..2b9b2c3fb4 100755
--- a/extra/tuple-syntax/tuple-syntax.factor
+++ b/extra/tuple-syntax/tuple-syntax.factor
@@ -7,7 +7,7 @@ IN: tuple-syntax
 
 : parse-slot-writer ( tuple -- slot# )
     scan dup "}" = [ 2drop f ] [
-        1 head* swap object-slots slot-named slot-spec-offset
+        butlast swap object-slots slot-named slot-spec-offset
     ] if ;
 
 : parse-slots ( accum tuple -- accum tuple )
diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor
index 0970bd6027..d13e284160 100755
--- a/extra/ui/gestures/gestures.factor
+++ b/extra/ui/gestures/gestures.factor
@@ -54,7 +54,7 @@ TUPLE: zoom-in-action ;  C:  zoom-in-action
 TUPLE: zoom-out-action ; C:  zoom-out-action
 
 : generalize-gesture ( gesture -- newgesture )
-    tuple>array 1 head* >tuple ;
+    tuple>array butlast >tuple ;
 
 ! Modifiers
 SYMBOLS: C+ A+ M+ S+ ;
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index 9ee65c0018..9635a62e49 100644
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -30,7 +30,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
     concat [ dup ] H{ } map>assoc ;
 
 : other-extend-lines ( -- lines )
-    "extra/unicode/PropList.txt" resource-path ascii file-lines ;
+    "resource:extra/unicode/PropList.txt" ascii file-lines ;
 
 VALUE: other-extend
 
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 85ce50acb9..f33338137a 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -14,7 +14,7 @@ IN: unicode.data
     ascii file-lines [ ";" split ] map ;
 
 : load-data ( -- data )
-    "extra/unicode/UnicodeData.txt" resource-path data ;
+    "resource:extra/unicode/UnicodeData.txt" data ;
 
 : (process-data) ( index data -- newdata )
     [ [ nth ] keep first swap 2array ] with map
@@ -120,7 +120,7 @@ VALUE: special-casing
 
 ! Special casing data
 : load-special-casing ( -- special-casing )
-    "extra/unicode/SpecialCasing.txt" resource-path data
+    "resource:extra/unicode/SpecialCasing.txt" data
     [ length 5 = ] filter
     [ [ set-code-point ] each ] H{ } make-assoc ;
 
diff --git a/extra/xml/tests/soap.factor b/extra/xml/tests/soap.factor
index 775930025f..c7452bb079 100755
--- a/extra/xml/tests/soap.factor
+++ b/extra/xml/tests/soap.factor
@@ -10,6 +10,6 @@ IN: xml.tests
     [ assemble-data ] map ;
 
 [ "http://www.foxnews.com/oreilly/" ] [
-    "extra/xml/tests/soap.xml" resource-path file>xml
+    "resource:extra/xml/tests/soap.xml" file>xml
     parse-result first first
 ] unit-test
diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor
index d85345b3c7..7794930144 100644
--- a/extra/xml/tests/test.factor
+++ b/extra/xml/tests/test.factor
@@ -9,7 +9,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
 \ read-xml must-infer
 
 SYMBOL: xml-file
-[ ] [ "extra/xml/tests/test.xml" resource-path
+[ ] [ "resource:extra/xml/tests/test.xml"
     [ file>xml ] with-html-entities xml-file set ] unit-test
 [ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
 [ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 22d3217ee6..277439c0cd 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -24,7 +24,7 @@ TAGS>
     ] keep ;
 
 : load-catalog ( -- modes )
-    "extra/xmode/modes/catalog" resource-path
+    "resource:extra/xmode/modes/catalog"
     file>xml parse-modes-tag ;
 
 : modes ( -- assoc )
@@ -38,8 +38,8 @@ TAGS>
 MEMO: (load-mode) ( name -- rule-sets )
     modes at [
         mode-file
-        "extra/xmode/modes/" prepend
-        resource-path utf8  parse-mode
+        "resource:extra/xmode/modes/" prepend
+        utf8  parse-mode
     ] [
         "text" (load-mode)
     ] if* ;
diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor
index f6df23b9b2..3977f4277c 100755
--- a/extra/xmode/code2html/code2html.factor
+++ b/extra/xmode/code2html/code2html.factor
@@ -20,8 +20,8 @@ IN: xmode.code2html
 
 : default-stylesheet ( -- )
      ;
 
 : htmlize-stream ( path stream -- )
diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor
index 99689d8819..a2183edbc9 100755
--- a/extra/xmode/utilities/utilities-tests.factor
+++ b/extra/xmode/utilities/utilities-tests.factor
@@ -48,6 +48,6 @@ TAGS>
         "This is a great company"
     }
 ] [
-    "extra/xmode/utilities/test.xml"
-    resource-path file>xml parse-company-tag
+    "resource:extra/xmode/utilities/test.xml"
+    file>xml parse-company-tag
 ] unit-test
diff --git a/extra/yahoo/yahoo-tests.factor b/extra/yahoo/yahoo-tests.factor
index 197fa4900b..46d05ce720 100644
--- a/extra/yahoo/yahoo-tests.factor
+++ b/extra/yahoo/yahoo-tests.factor
@@ -6,6 +6,6 @@ USING: tools.test yahoo kernel io.files xml sequences ;
     "Official Foo Fighters"
     "http://www.foofighters.com/"
     "Official site with news, tour dates, discography, store, community, and more."
-} ] [ "extra/yahoo/test-results.xml" resource-path file>xml parse-yahoo first ] unit-test
+} ] [ "resource:extra/yahoo/test-results.xml" file>xml parse-yahoo first ] unit-test
 
 [ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 query ] unit-test

From 0cd8023a251e8f9015e10778b0e58450bacf5c6d Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 6 May 2008 14:41:59 -0500
Subject: [PATCH 19/77] use resource: instead of resource-path

---
 core/io/io-tests.factor | 10 ++++------
 1 file changed, 4 insertions(+), 6 deletions(-)

diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor
index 7204bde6fb..50a798d290 100755
--- a/core/io/io-tests.factor
+++ b/core/io/io-tests.factor
@@ -8,20 +8,17 @@ IN: io.tests
     "foo" "io.tests" lookup
 ] unit-test
 
-:  ( resource -- stream )
-    resource-path latin1  ;
-
 [
     "This is a line.\rThis is another line.\r"
 ] [
-    "core/io/test/mac-os-eol.txt" 
+    "resource:core/io/test/mac-os-eol.txt" latin1 
     [ 500 read ] with-input-stream
 ] unit-test
 
 [
     255
 ] [
-    "core/io/test/binary.txt" 
+    "resource:core/io/test/binary.txt" latin1 
     [ read1 ] with-input-stream >fixnum
 ] unit-test
 
@@ -36,7 +33,8 @@ IN: io.tests
     }
 ] [
     [
-        "core/io/test/separator-test.txt"  [
+        "resource:core/io/test/separator-test.txt"
+        latin1  [
             "J" read-until 2array ,
             "i" read-until 2array ,
             "X" read-until 2array ,

From 0acbdcdcc64eab65f108aee59a27937315d1e303 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 6 May 2008 14:45:28 -0500
Subject: [PATCH 20/77] remove 

---
 core/io/encodings/encodings-tests.factor | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor
index 79922b019c..e6b180fde2 100755
--- a/core/io/encodings/encodings-tests.factor
+++ b/core/io/encodings/encodings-tests.factor
@@ -2,11 +2,8 @@ USING: io.files io.streams.string io
 tools.test kernel io.encodings.ascii ;
 IN: io.streams.encodings.tests
 
-:  ( resource -- stream )
-    resource-path ascii  ;
-    
 [ { } ]
-[ "core/io/test/empty-file.txt"  lines ]
+[ "resource:core/io/test/empty-file.txt" ascii  lines ]
 unit-test
 
 : lines-test ( stream -- line1 line2 )
@@ -16,21 +13,24 @@ unit-test
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/windows-eol.txt"  lines-test
+    "resource:core/io/test/windows-eol.txt"
+    ascii  lines-test
 ] unit-test
 
 [
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/mac-os-eol.txt"  lines-test
+    "resource:core/io/test/mac-os-eol.txt"
+    ascii  lines-test
 ] unit-test
 
 [
     "This is a line."
     "This is another line."
 ] [
-    "core/io/test/unix-eol.txt"  lines-test
+    "resource:core/io/test/unix-eol.txt"
+    ascii  lines-test
 ] unit-test
 
 [

From ebae774b8c63d69f5b955d6bada8669b374e8dc8 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Tue, 6 May 2008 14:48:28 -0500
Subject: [PATCH 21/77] moved xml errors tests to a new place

---
 extra/xml/errors/errors-tests.factor | 28 ++++++++++++++++++++++++++++
 1 file changed, 28 insertions(+)
 create mode 100755 extra/xml/errors/errors-tests.factor

diff --git a/extra/xml/errors/errors-tests.factor b/extra/xml/errors/errors-tests.factor
new file mode 100755
index 0000000000..402c76dc01
--- /dev/null
+++ b/extra/xml/errors/errors-tests.factor
@@ -0,0 +1,28 @@
+USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
+IN: xml.errors.tests
+
+: xml-error-test ( expected-error xml-string -- )
+    [ string>xml ] curry swap [ = ] curry must-fail-with ;
+
+T{ no-entity f 1 10 "nbsp" } " " xml-error-test
+T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" }
+} "" xml-error-test
+T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "" xml-error-test
+T{ nonexist-ns f 1 5 "x" } "" xml-error-test
+T{ unopened f 1 5 } "" xml-error-test
+T{ not-yes/no f 1 41 "maybe" } "" xml-error-test
+T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
+} "" xml-error-test
+T{ bad-version f 1 28 "5 million" } "" xml-error-test
+T{ notags f 1 0 } "" xml-error-test
+T{ multitags } "" xml-error-test
+T{ bad-prolog  f 1 26 T{ prolog f "1.0" "UTF-8" f }
+} "" xml-error-test
+T{ capitalized-prolog f 1 6 "XmL" } ""
+xml-error-test
+T{ pre/post-content f "x" t } "x" xml-error-test
+T{ versionless-prolog f 1 8 } "" xml-error-test
+T{ bad-instruction f 1 11 T{ instruction f "xsl" }
+} "" xml-error-test
+T{ bad-directive f 1 15 T{ directive f "DOCTYPE" }
+} "" xml-error-test

From d1545ac9297b058832b74ad63085a503677e337f Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg 
Date: Tue, 6 May 2008 15:51:34 -0500
Subject: [PATCH 22/77] LCS docs, bug fixes

---
 extra/lcs/lcs-docs.factor  | 29 +++++++++++++++++++++++++
 extra/lcs/lcs-tests.factor | 17 ++++++++++++---
 extra/lcs/lcs.factor       | 43 ++++++++++++++++++++------------------
 3 files changed, 66 insertions(+), 23 deletions(-)

diff --git a/extra/lcs/lcs-docs.factor b/extra/lcs/lcs-docs.factor
index 6c5e2ae992..49e46c7641 100755
--- a/extra/lcs/lcs-docs.factor
+++ b/extra/lcs/lcs-docs.factor
@@ -4,3 +4,32 @@ IN: lcs
 HELP: levenshtein
 { $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } }
 { $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;
+
+HELP: lcs
+{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "lcs" "a longest common subsequence" } }
+{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ;
+
+HELP: diff
+{ $values { "old" "a sequence" } { "new" "a sequence" } { "diff" "an edit script" } }
+{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ;
+
+HELP: retain
+{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ;
+
+HELP: delete
+{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ;
+
+HELP: insert
+{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ;
+
+ARTICLE: "lcs" "LCS, Diffing and Distance"
+"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences."
+{ $subsection lcs }
+{ $subsection diff }
+{ $subsection levenshtein }
+"The " { $link diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot."
+{ $subsection insert }
+{ $subsection delete }
+{ $subsection retain } ;
+
+ABOUT: "lcs"
diff --git a/extra/lcs/lcs-tests.factor b/extra/lcs/lcs-tests.factor
index c3f1e61342..3aa10a0687 100755
--- a/extra/lcs/lcs-tests.factor
+++ b/extra/lcs/lcs-tests.factor
@@ -7,8 +7,19 @@ USING: tools.test lcs ;
 [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
 [ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
 
-! [ "hell" ] [ "hello" "hell" lcs ] unit-test
-! [ "hell" ] [ "hell" "hello" lcs ] unit-test
+[ "hell" ] [ "hello" "hell" lcs ] unit-test
+[ "hell" ] [ "hell" "hello" lcs ] unit-test
 [ "ell" ] [ "ell" "hell" lcs ] unit-test
 [ "ell" ] [ "hell" "ell" lcs ] unit-test
-! [ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
+[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
+
+[ {
+        T{ delete f CHAR: f }
+        T{ retain f CHAR: a }
+        T{ delete f CHAR: x }
+        T{ retain f CHAR: b }
+        T{ delete f CHAR: c }
+        T{ retain f CHAR: d }
+        T{ insert f CHAR: e }
+        T{ insert f CHAR: f }
+} ] [ "faxbcd" "abdef" diff ] unit-test
diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor
index b1584af78b..cdebfc4325 100755
--- a/extra/lcs/lcs.factor
+++ b/extra/lcs/lcs.factor
@@ -2,21 +2,20 @@ USING: sequences kernel math locals math.order math.ranges
 accessors combinators.lib arrays namespaces combinators ;
 IN: lcs
 
-! Classic dynamic programming O(n^2) algorithm for the
-! Longest Common Subsequence
-! Slight modification to get Levenshtein distance
+r [ 1+ ] bi@ r> min min ;
 
-! j is row, i is column
-! Going from str1 to str2
-! str1 along side column, str2 along top row
+: lcs-step ( insert delete change same? -- next )
+    1 -9999 ? + max max ; ! Replace -9999 with -inf when added
 
-:: lcs-step ( i j matrix old new change-cost -- )
-    i j matrix nth nth
-        i old nth j new nth = 0 change-cost ? +
-    i j 1+ matrix nth nth 1+ ! insertion cost
-    i 1+ j matrix nth nth 1+ ! deletion cost
-    min min
-    i 1+ j 1+ matrix nth set-nth ;
+:: loop-step ( i j matrix old new step -- )
+    i j 1+ matrix nth nth ! insertion
+    i 1+ j matrix nth nth ! deletion
+    i j matrix nth nth ! replace/retain
+    i old nth j new nth = ! same?
+    step call
+    i 1+ j 1+ matrix nth set-nth ; inline
 
 : lcs-initialize ( |str1| |str2| -- matrix )
     [ drop 0  ] with map ;
@@ -24,21 +23,24 @@ IN: lcs
 : levenshtein-initialize ( |str1| |str2| -- matrix )
     [ [ + ] curry map ] with map ;
 
-:: run-lcs ( old new quot change-cost -- matrix )
-    [let | matrix [ old length 1+ new length 1+ quot call ] |
+:: run-lcs ( old new init step -- matrix )
+    [let | matrix [ old length 1+ new length 1+ init call ] |
         old length [0,b) [| i |
             new length [0,b)
-            [| j | i j matrix old new change-cost lcs-step ]
+            [| j | i j matrix old new step loop-step ]
             each
-        ] each matrix ] ;
+        ] each matrix ] ; inline
+PRIVATE>
 
 : levenshtein ( old new -- n )
-    [ levenshtein-initialize ] 1 run-lcs peek peek ;
+    [ levenshtein-initialize ] [ levenshtein-step ]
+    run-lcs peek peek ;
 
 TUPLE: retain item ;
 TUPLE: delete item ;
 TUPLE: insert item ;
 
+
 
 : diff ( old new -- diff )
-    2dup [ lcs-initialize ] 2 run-lcs trace-diff ;
+    2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
 
-: lcs ( str1 str2 -- lcs )
+: lcs ( seq1 seq2 -- lcs )
     [ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;

From 5666cd78b9970e1b553065d7e076699e5f65c31d Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 6 May 2008 21:23:07 -0500
Subject: [PATCH 23/77] Linked error fixes, add 2parallel-each and
 2parallel-map combinators

---
 core/debugger/debugger.factor                 |  5 ++--
 .../combinators/combinators-docs.factor       | 12 +++++++++
 .../combinators/combinators-tests.factor      | 25 ++++++++++++++++++-
 .../combinators/combinators.factor            | 25 ++++++++++++++-----
 .../count-downs/count-downs.factor            | 20 ++++++---------
 extra/concurrency/mailboxes/mailboxes.factor  |  5 +++-
 6 files changed, 68 insertions(+), 24 deletions(-)

diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index e5dd02c25e..ee3352b719 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -269,8 +269,7 @@ M: double-free summary
 M: realloc-error summary
     drop "Memory reallocation failed" ;
 
-: error-in-thread. ( -- )
-    error-thread get-global
+: error-in-thread. ( thread -- )
     "Error in thread " write
     [
         dup thread-id #
@@ -284,7 +283,7 @@ M: thread error-in-thread ( error thread -- )
         die drop
     ] [
         global [
-            error-in-thread. print-error flush
+            error-thread get-global error-in-thread. print-error flush
         ] bind
     ] if ;
 
diff --git a/extra/concurrency/combinators/combinators-docs.factor b/extra/concurrency/combinators/combinators-docs.factor
index bbf8fb0f5f..a23301c1e2 100755
--- a/extra/concurrency/combinators/combinators-docs.factor
+++ b/extra/concurrency/combinators/combinators-docs.factor
@@ -6,11 +6,21 @@ HELP: parallel-map
 { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
 { $errors "Throws an error if one of the iterations throws an error." } ;
 
+HELP: 2parallel-map
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
+{ $errors "Throws an error if one of the iterations throws an error." } ;
+
 HELP: parallel-each
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
 { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
 { $errors "Throws an error if one of the iterations throws an error." } ;
 
+HELP: 2parallel-each
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
+{ $errors "Throws an error if one of the iterations throws an error." } ;
+
 HELP: parallel-filter
 { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }
 { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
@@ -19,7 +29,9 @@ HELP: parallel-filter
 ARTICLE: "concurrency.combinators" "Concurrent combinators"
 "The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
 { $subsection parallel-each }
+{ $subsection 2parallel-each }
 { $subsection parallel-map }
+{ $subsection 2parallel-map }
 { $subsection parallel-filter } ;
 
 ABOUT: "concurrency.combinators"
diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor
index 3381cba5e8..562111242d 100755
--- a/extra/concurrency/combinators/combinators-tests.factor
+++ b/extra/concurrency/combinators/combinators-tests.factor
@@ -1,9 +1,11 @@
 IN: concurrency.combinators.tests
 USING: concurrency.combinators tools.test random kernel math 
-concurrency.mailboxes threads sequences accessors ;
+concurrency.mailboxes threads sequences accessors arrays ;
 
 [ [ drop ] parallel-each ] must-infer
+{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
 [ [ ] parallel-map ] must-infer
+{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as
 [ [ ] parallel-filter ] must-infer
 
 [ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
@@ -22,3 +24,24 @@ concurrency.mailboxes threads sequences accessors ;
     10 over [ push ] curry parallel-each
     length
 ] unit-test
+
+[ { 10 20 30 } ] [
+    { 1 4 3 } { 10 5 10 } [ * ] 2parallel-map
+] unit-test
+
+[ { -9 -1 -7 } ] [
+    { 1 4 3 } { 10 5 10 } [ - ] 2parallel-map
+] unit-test
+
+[
+    { 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each
+] must-fail
+
+[ 20 ]
+[
+    V{ } clone
+    10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each
+    length
+] unit-test
+
+[ { f } [ "OOPS" throw ] parallel-each ] must-fail
diff --git a/extra/concurrency/combinators/combinators.factor b/extra/concurrency/combinators/combinators.factor
index 3c4101e381..eab0ed4cb4 100755
--- a/extra/concurrency/combinators/combinators.factor
+++ b/extra/concurrency/combinators/combinators.factor
@@ -4,14 +4,27 @@ USING: concurrency.futures concurrency.count-downs sequences
 kernel ;
 IN: concurrency.combinators
 
-: parallel-map ( seq quot -- newseq )
-    [ curry future ] curry map dup [ ?future ] change-each ;
-    inline
+: (parallel-each) ( n quot -- )
+    >r  r> keep await ; inline
 
 : parallel-each ( seq quot -- )
-    over length 
-    [ [ >r curry r> spawn-stage ] 2curry each ] keep await ;
-    inline
+    over length [
+        [ >r curry r> spawn-stage ] 2curry each
+    ] (parallel-each) ; inline
+
+: 2parallel-each ( seq1 seq2 quot -- )
+    2over min-length [
+        [ >r 2curry r> spawn-stage ] 2curry 2each
+    ] (parallel-each) ; inline
 
 : parallel-filter ( seq quot -- newseq )
     over >r pusher >r each r> r> like ; inline
+
+: future-values dup [ ?future ] change-each ; inline
+
+: parallel-map ( seq quot -- newseq )
+    [ curry future ] curry map future-values ;
+    inline
+
+: 2parallel-map ( seq1 seq2 quot -- newseq )
+    [ 2curry future ] curry 2map future-values ;
diff --git a/extra/concurrency/count-downs/count-downs.factor b/extra/concurrency/count-downs/count-downs.factor
index 6a75f7206c..93cef250a1 100755
--- a/extra/concurrency/count-downs/count-downs.factor
+++ b/extra/concurrency/count-downs/count-downs.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: dlists kernel math concurrency.promises
-concurrency.mailboxes ;
+concurrency.mailboxes debugger accessors ;
 IN: concurrency.count-downs
 
 ! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
@@ -9,9 +9,7 @@ IN: concurrency.count-downs
 TUPLE: count-down n promise ;
 
 : count-down-check ( count-down -- )
-    dup count-down-n zero? [
-        t swap count-down-promise fulfill
-    ] [ drop ] if ;
+    dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
 
 :  ( n -- count-down )
     dup 0 < [ "Invalid count for count down" throw ] when
@@ -19,15 +17,12 @@ TUPLE: count-down n promise ;
     dup count-down-check ;
 
 : count-down ( count-down -- )
-    dup count-down-n dup zero? [
-        "Count down already done" throw
-    ] [
-        1- over set-count-down-n
-        count-down-check
-    ] if ;
+    dup n>> dup zero?
+    [ "Count down already done" throw ]
+    [ 1- >>n count-down-check ] if ;
 
 : await-timeout ( count-down timeout -- )
-    >r count-down-promise r> ?promise-timeout drop ;
+    >r promise>> r> ?promise-timeout ?linked t assert= ;
 
 : await ( count-down -- )
     f await-timeout ;
@@ -35,5 +30,4 @@ TUPLE: count-down n promise ;
 : spawn-stage ( quot count-down -- )
     [ [ count-down ] curry compose ] keep
     "Count down stage"
-    swap count-down-promise
-    promise-mailbox spawn-linked-to drop ;
+    swap promise>> mailbox>> spawn-linked-to drop ;
diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor
index ac03197708..aa4dc2df3d 100755
--- a/extra/concurrency/mailboxes/mailboxes.factor
+++ b/extra/concurrency/mailboxes/mailboxes.factor
@@ -3,7 +3,7 @@
 IN: concurrency.mailboxes
 USING: dlists threads sequences continuations
 namespaces random math quotations words kernel arrays assocs
-init system concurrency.conditions accessors ;
+init system concurrency.conditions accessors debugger ;
 
 TUPLE: mailbox threads data closed ;
 
@@ -83,6 +83,9 @@ M: mailbox dispose
 
 TUPLE: linked-error error thread ;
 
+M: linked-error error.
+    [ thread>> error-in-thread. ] [ error>> error. ] bi ;
+
 C:  linked-error
 
 : ?linked dup linked-error? [ rethrow ] when ;

From 90299783d6d6edd49c6df30b17f041c59763660e Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 6 May 2008 21:23:18 -0500
Subject: [PATCH 24/77] Cleanup io.pipes and fix io.unix.pipes hang

---
 extra/io/launcher/launcher.factor            | 24 +++++------
 extra/io/pipes/pipes.factor                  | 43 +++++++++-----------
 extra/io/unix/launcher/launcher-tests.factor |  2 +-
 extra/io/unix/pipes/pipes-tests.factor       |  1 +
 4 files changed, 32 insertions(+), 38 deletions(-)

diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 286febd589..e9fbdaea62 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.backend io.timeouts io.pipes system kernel
-namespaces strings hashtables sequences assocs combinators
-vocabs.loader init threads continuations math io.encodings
-io.streams.duplex io.nonblocking io.streams.duplex accessors
-concurrency.flags destructors ;
+USING: system kernel namespaces strings hashtables sequences 
+assocs combinators vocabs.loader init threads continuations
+math accessors concurrency.flags destructors
+io io.backend io.timeouts io.pipes io.pipes.private io.encodings
+io.streams.duplex io.nonblocking ;
 IN: io.launcher
 
 TUPLE: process < identity-tuple
@@ -149,15 +149,11 @@ M: process set-timeout set-process-timeout ;
 
 M: process timed-out kill-process ;
 
-M: object pipeline-element-quot
-    [
-        >process
-            swap >>stdout
-            swap >>stdin
-        run-detached
-    ] curry ;
-
-M: process wait-for-pipeline-element wait-for-process ;
+M: object run-pipeline-element
+    [ >process swap >>stdout swap >>stdin run-detached ]
+    [ drop [ [ close-handle ] when* ] bi@ ]
+    3bi
+    wait-for-process ;
 
 :  ( process encoding -- process stream )
     [
diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor
index 3e91c5e48e..72d27372f3 100644
--- a/extra/io/pipes/pipes.factor
+++ b/extra/io/pipes/pipes.factor
@@ -23,34 +23,31 @@ HOOK: (pipe) io-backend ( -- pipe )
         r> 
     ] with-destructors ;
 
-: with-fds ( input-fd output-fd quot -- )
-    >r >r [  dup add-always-destructor ] [ input-stream get ] if* r> r> [
-        >r [  dup add-always-destructor ] [ output-stream get ] if* r>
-        with-output-stream*
-    ] 2curry with-input-stream* ; inline
+ ( n -- pipes )
-    [ (pipe) dup add-always-destructor ] replicate
-    f f pipe boa [ prefix ] [ suffix ] bi
-    2  ;
+: ?reader [  dup add-always-destructor ] [ input-stream get ] if* ;
+: ?writer [  dup add-always-destructor ] [ output-stream get ] if* ;
 
-: with-pipe-fds ( seq -- results )
+GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
+
+M: callable run-pipeline-element
     [
-        [ length dup zero? [ drop { } ] [ 1-  ] if ] keep
-        [ >r [ first in>> ] [ second out>> ] bi r> 2curry ] 2map
-        [ call ] parallel-map
+        >r [ ?reader ] [ ?writer ] bi*
+        r> with-streams*
     ] with-destructors ;
 
-GENERIC: pipeline-element-quot ( obj -- quot )
+:  ( n -- pipes )
+    [
+        [ (pipe) dup add-error-destructor ] replicate
+        T{ pipe } [ prefix ] [ suffix ] bi
+        2 
+    ] with-destructors ;
 
-M: callable pipeline-element-quot
-    [ with-fds ] curry ;
-
-GENERIC: wait-for-pipeline-element ( obj -- result )
-
-M: object wait-for-pipeline-element ;
+PRIVATE>
 
 : run-pipeline ( seq -- results )
-    [ pipeline-element-quot ] map
-    with-pipe-fds
-    [ wait-for-pipeline-element ] map ;
+    [ length dup zero? [ drop { } ] [ 1-  ] if ] keep
+    [
+        >r [ first in>> ] [ second out>> ] bi
+        r> run-pipeline-element
+    ] 2parallel-map ;
diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor
index 97ffc5287f..177c5775dc 100755
--- a/extra/io/unix/launcher/launcher-tests.factor
+++ b/extra/io/unix/launcher/launcher-tests.factor
@@ -99,7 +99,7 @@ accessors kernel sequences io.encodings.utf8 ;
     utf8 file-contents
 ] unit-test
 
-[ ] [ "append-test" temp-file delete-file ] unit-test
+[ "append-test" temp-file delete-file ] ignore-errors
 
 [ "hi\nhi\n" ] [
     2 [
diff --git a/extra/io/unix/pipes/pipes-tests.factor b/extra/io/unix/pipes/pipes-tests.factor
index 8ff9ba61c8..27a490d801 100644
--- a/extra/io/unix/pipes/pipes-tests.factor
+++ b/extra/io/unix/pipes/pipes-tests.factor
@@ -9,6 +9,7 @@ IN: io.unix.pipes.tests
         "ls"
         [
             input-stream [ utf8  ] change
+            output-stream [ utf8  ] change
             input-stream get lines reverse [ print ] each f
         ]
         "grep x"

From 732b84bcf9da5745163f7cbd5e2bbe75ab8e3498 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 6 May 2008 22:20:55 -0500
Subject: [PATCH 25/77] Mac OS X monitors need to call normalize-path

---
 extra/io/unix/macosx/macosx.factor | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor
index 0a0aec6ab6..8a5d0c490f 100644
--- a/extra/io/unix/macosx/macosx.factor
+++ b/extra/io/unix/macosx/macosx.factor
@@ -13,9 +13,11 @@ TUPLE: macosx-monitor < monitor handle ;
     ] curry each ;
 
 M:: macosx (monitor) ( path recursive? mailbox -- monitor )
-    path mailbox macosx-monitor new-monitor
-    dup [ enqueue-notifications ] curry
-    path 1array 0 0  >>handle ;
+    [let | path [ path normalize-path ] |
+        path mailbox macosx-monitor new-monitor
+        dup [ enqueue-notifications ] curry
+        path 1array 0 0  >>handle
+    ] ;
 
 M: macosx-monitor dispose
     handle>> dispose ;

From 78712fef1b7f68df705287b1912caac198bc7c32 Mon Sep 17 00:00:00 2001
From: Alex Chapman 
Date: Wed, 7 May 2008 13:58:03 +1000
Subject: [PATCH 26/77] jamshred: some dodgy debug logging, and some dodgy
 collision detection :)

---
 extra/jamshred/game/game.factor     |  9 ++--
 extra/jamshred/jamshred.factor      | 26 ++++-----
 extra/jamshred/log/log.factor       | 10 ++++
 extra/jamshred/oint/oint.factor     | 64 +++++++++-------------
 extra/jamshred/player/player.factor | 55 +++++++++++++------
 extra/jamshred/tunnel/tunnel.factor | 82 ++++++++++++++++++++++++-----
 6 files changed, 157 insertions(+), 89 deletions(-)
 create mode 100644 extra/jamshred/log/log.factor

diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor
index 3842816f0e..2a5fefcaed 100644
--- a/extra/jamshred/game/game.factor
+++ b/extra/jamshred/game/game.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel opengl arrays sequences jamshred.tunnel
-jamshred.player math.vectors ;
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ;
 IN: jamshred.game
 
 TUPLE: jamshred tunnel players running ;
@@ -12,15 +11,15 @@ TUPLE: jamshred tunnel players running ;
 
 : jamshred-player ( jamshred -- player )
     ! TODO: support more than one player
-    jamshred-players first ;
+    players>> first ;
 
 : jamshred-update ( jamshred -- )
-    dup jamshred-running [
+    dup running>> [
         jamshred-player update-player
     ] [ drop ] if ;
 
 : toggle-running ( jamshred -- )
-    dup jamshred-running not swap set-jamshred-running ;
+    [ running>> not ] [ (>>running) ] bi ;
 
 : mouse-moved ( x-radians y-radians jamshred -- )
     jamshred-player -rot turn-player ;
diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor
index 42414b9893..3a7047929f 100755
--- a/extra/jamshred/jamshred.factor
+++ b/extra/jamshred/jamshred.factor
@@ -1,14 +1,12 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alarms arrays calendar jamshred.game jamshred.gl kernel math
-math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
-math.vectors ;
+USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render math.vectors ;
 IN: jamshred
 
 TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
 
 :  ( jamshred -- gadget )
-    jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
+    jamshred-gadget construct-gadget swap >>jamshred ;
 
 : default-width ( -- x ) 1024 ;
 : default-height ( -- y ) 768 ;
@@ -17,22 +15,21 @@ M: jamshred-gadget pref-dim*
     drop default-width default-height 2array ;
 
 M: jamshred-gadget draw-gadget* ( gadget -- )
-    dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
+    [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
 
 : tick ( gadget -- )
-    dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
+    [ jamshred>> jamshred-update ] [ relayout-1 ] bi ;
 
 M: jamshred-gadget graft* ( gadget -- )
     [
         [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
-    ] keep set-jamshred-gadget-alarm ;
+    ] keep (>>alarm) ;
 
 M: jamshred-gadget ungraft* ( gadget -- )
-    [ jamshred-gadget-alarm cancel-alarm f ] keep
-    set-jamshred-gadget-alarm ;
+    [ alarm>> cancel-alarm ] [ f >>alarm drop ] bi ;
 
 : jamshred-restart ( jamshred-gadget -- )
-     swap set-jamshred-gadget-jamshred ;
+     >>jamshred drop ;
 
 : pix>radians ( n m -- theta )
     2 / / pi 2 * * ;
@@ -46,21 +43,20 @@ M: jamshred-gadget ungraft* ( gadget -- )
     rect-dim second pix>radians ;
 
 : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
-    over jamshred-gadget-jamshred >r
+    over jamshred>> >r
     [ first swap x>radians ] 2keep second swap y>radians
     r> mouse-moved ;
     
 : handle-mouse-motion ( jamshred-gadget -- )
     hand-loc get [
-        over jamshred-gadget-last-hand-loc [
+        over last-hand-loc>> [
             v- (handle-mouse-motion) 
         ] [ 2drop ] if* 
-    ] 2keep swap set-jamshred-gadget-last-hand-loc ;
+    ] 2keep >>last-hand-loc drop ;
 
-USE: vocabs.loader
 jamshred-gadget H{
     { T{ key-down f f "r" } [ jamshred-restart ] }
-    { T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
+    { T{ key-down f f " " } [ jamshred>> toggle-running ] }
     { T{ motion } [ handle-mouse-motion ] }
 } set-gestures
 
diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor
new file mode 100644
index 0000000000..33498d8a2e
--- /dev/null
+++ b/extra/jamshred/log/log.factor
@@ -0,0 +1,10 @@
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+    "jamshred" swap with-logging ;
+
+: jamshred-log ( message -- )
+    [ (jamshred-log) ] with-jamshred-log ; ! ugly...
diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor
index 4680be4575..6b4f22bb9e 100644
--- a/extra/jamshred/oint/oint.factor
+++ b/extra/jamshred/oint/oint.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
 IN: jamshred.oint
 
 ! An oint is a point with three linearly independent unit vectors
@@ -10,46 +10,23 @@ IN: jamshred.oint
 
 TUPLE: oint location forward up left ;
 
-:  ( location forward up left -- oint )
-    oint boa ;
-
-! : x-rotation ( theta -- matrix )
-!     #! construct this matrix:
-!     #! { { 1           0          0 }
-!     #!   { 0  cos(theta) sin(theta) }
-!     #!   { 0 -sin(theta) cos(theta) } }
-!     dup sin neg swap cos 2dup 0 -rot 3float-array >r
-!     swap neg 0 -rot 3float-array >r
-!     { 1 0 0 } r> r> 3float-array ;
-! 
-! : y-rotation ( theta -- matrix )
-!     #! costruct this matrix:
-!     #! { { cos(theta) 0 -sin(theta) }
-!     #!   {          0 1           0 }
-!     #!   { sin(theta) 0  cos(theta) } }
-!     dup sin swap cos 2dup
-!     0 swap 3float-array >r
-!     { 0 1 0 } >r
-!     0 rot neg 3float-array r> r> 3float-array ;
-
-: apply-to-oint ( oint quot -- )
-    #! apply quot to each of forward, up, and left, storing the results
-    over oint-forward over call pick set-oint-forward
-    over oint-up over call pick set-oint-up
-    over oint-left swap call swap set-oint-left ;
-
 : rotation-quaternion ( theta axis -- quaternion )
     swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
 
+: rotate-vector ( q qrecip v -- v )
+    v>q swap q* q* q>v ;
+
 : rotate-oint ( oint theta axis -- )
-    rotation-quaternion dup qrecip
-    [ rot v>q swap q* q* q>v ] curry curry apply-to-oint ;
+    rotation-quaternion dup qrecip pick
+    [ forward>> rotate-vector >>forward ]
+    [ up>> rotate-vector >>up ]
+    [ left>> rotate-vector >>left ] 3tri drop ;
 
 : left-pivot ( oint theta -- )
-    over oint-left rotate-oint ;
+    over left>> rotate-oint ;
 
 : up-pivot ( oint theta -- )
-    over oint-up rotate-oint ;
+    over up>> rotate-oint ;
 
 : random-float+- ( n -- m )
     #! find a random float between -n/2 and n/2
@@ -59,10 +36,10 @@ TUPLE: oint location forward up left ;
     2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
 
 : go-forward ( distance oint -- )
-    tuck oint-forward n*v over oint-location v+ swap set-oint-location ;
+    [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
 
 : distance-vector ( oint oint -- vector )
-    oint-location swap oint-location v- ;
+    [ location>> ] bi@ swap v- ;
 
 : distance ( oint oint -- distance )
     distance-vector norm ;
@@ -72,9 +49,16 @@ TUPLE: oint location forward up left ;
     tuck v. swap norm / ;
 
 : perpendicular-distance ( oint oint -- distance )
-    tuck distance-vector swap 2dup oint-left scalar-projection abs
-    -rot oint-up scalar-projection abs + ;
+    tuck distance-vector swap 2dup left>> scalar-projection abs
+    -rot up>> scalar-projection abs + ;
 
-:: reflect ( v l -- v' )
-    #! reflect v on l
-    v l v. l l v. / 2 * l n*v v v- ;
+: proj-perp ( v u -- w )
+    dupd proj v- ;
+
+! :: reflect ( v l -- v' )
+!     #! reflect v on l
+!     v l v. l l v. / 2 * l n*v v v- ;
+
+:: reflect ( vec n -- v' )
+    #! bounce v on a surface with normal n
+    vec n v. n n*v -2 * vec v+ ;
diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor
index 3e143a845e..6feca27366 100644
--- a/extra/jamshred/player/player.factor
+++ b/extra/jamshred/player/player.factor
@@ -1,39 +1,64 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: colors jamshred.oint jamshred.tunnel kernel
-math math.constants sequences ;
+USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences ;
 IN: jamshred.player
 
-TUPLE: player name tunnel nearest-segment ;
+TUPLE: player < oint name tunnel nearest-segment ;
 
 :  ( name -- player )
-    f f player boa
-    F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }  over set-delegate ;
+    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f player boa ;
 
 : turn-player ( player x-radians y-radians -- )
     >r over r> left-pivot up-pivot ;
 
 : to-tunnel-start ( player -- )
-    dup player-tunnel first dup oint-location pick set-oint-location
-    swap set-player-nearest-segment ;
+    [ tunnel>> first dup location>> ]
+    [ tuck (>>location) (>>nearest-segment) ] bi ;
 
 : play-in-tunnel ( player segments -- )
-    over set-player-tunnel to-tunnel-start ;
+    >>tunnel to-tunnel-start ;
 
 : update-nearest-segment ( player -- )
-    dup player-tunnel over dup player-nearest-segment nearest-segment
-    swap set-player-nearest-segment ;
+    [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
+    [ (>>nearest-segment) ] tri ;
 
 : max-speed ( -- speed )
-    0.3 ;
+    0.01 ;
 
 : player-speed ( player -- speed )
-    max-speed ;
-    ! dup player-nearest-segment fraction-from-wall sq max-speed * ;
+    drop max-speed ;
+    ! dup nearest-segment>> fraction-from-wall sq max-speed * ;
+
+! : move-player ( player -- )
+!     dup player-speed over go-forward update-nearest-segment ;
+DEFER: (move-player)
+
+: ?bounce ( distance-remaining player -- )
+    over 0 > [
+        [ dup nearest-segment>> bounce ]
+        ! [ (move-player) ] ! uncomment when bounce works...
+        [ 2drop ]
+        bi
+    ] [
+        2drop
+    ] if ;
+
+: move-player-distance ( distance-remaining player distance -- distance-remaining player )
+    pick min tuck over go-forward [ - ] dip ;
+
+USE: prettyprint
+USE: io.streams.string
+: (move-player) ( distance-remaining player -- )
+    over 0 <= [
+        2drop
+    ] [
+        dup dup nearest-segment>> distance-to-collision ! [ .s ] with-string-writer jamshred-log
+        move-player-distance ?bounce
+    ] if ;
 
 : move-player ( player -- )
-    dup player-speed over go-forward update-nearest-segment ;
+    [ player-speed ] [ (move-player) ] [ update-nearest-segment ] tri ;
 
 : update-player ( player -- )
-    dup move-player player-nearest-segment
+    dup move-player nearest-segment>>
     white swap set-segment-color ;
diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
index c3f6b37fb8..7c6740f139 100755
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -1,23 +1,20 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays float-arrays kernel jamshred.oint math math.functions
-math.ranges math.vectors math.constants random sequences vectors ;
+USING: accessors arrays float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors random sequences vectors ;
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline
 
-TUPLE: segment number color radius ;
-
-:  ( number color radius location forward up left -- segment )
-     >r segment boa r> over set-delegate ;
+TUPLE: segment < oint number color radius ;
+C:  segment
 
 : segment-vertex ( theta segment -- vertex )
-     tuck 2dup oint-up swap sin v*n
-     >r oint-left swap cos v*n r> v+
-     swap oint-location v+ ;
+     tuck 2dup up>> swap sin v*n
+     >r left>> swap cos v*n r> v+
+     swap location>> v+ ;
 
 : segment-vertex-normal ( vertex segment -- normal )
-    oint-location swap v- normalize ;
+    location>> swap v- normalize ;
 
 : segment-vertex-and-normal ( segment theta -- vertex normal )
     swap [ segment-vertex ] keep dupd segment-vertex-normal ;
@@ -50,15 +47,15 @@ TUPLE: segment number color radius ;
 : default-segment-radius ( -- r ) 1 ;
 
 : initial-segment ( -- segment )
-    0 random-color default-segment-radius
-    F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }  ;
+        F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
+        0 random-color default-segment-radius  ;
 
 : random-segments ( n -- segments )
     initial-segment 1vector swap (random-segments) ;
 
 : simple-segment ( n -- segment )
-    random-color default-segment-radius pick F{ 0 0 -1 } n*v
-    F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }  ;
+    [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
+    random-color default-segment-radius  ;
 
 : simple-segments ( n -- segments )
     [ simple-segment ] map ;
@@ -111,3 +108,60 @@ TUPLE: segment number color radius ;
 
 : fraction-from-wall ( oint segment -- fraction )
     fraction-from-centre 1 swap - ;
+
+: sideways-heading ( oint segment -- v )
+    [ forward>> ] bi@ proj-perp ;
+
+! : facing-nearest-wall? ( oint segment -- ? )
+!     [ [ location>> ] bi@ distance ]
+!     [ sideways-heading ]
+!     [ [ location>> ] bi@ [ v+ ] dip distance ] tri < ;
+
+! : distance-to-collision ( oint segment -- distance )
+! ! TODO: this isn't right. If oint is facing away from the wall then it should return a much bigger distance...
+!     #! distance on the oint's heading to the segment wall
+!     facing-nearest-wall? [
+!         [ sideways-heading norm ]
+!         [ distance-from-wall ] 2bi swap /
+!     ] [
+!     ] if ;
+
+:: (collision-coefficient) ( -2b sqrt(b^2-2ac) 2a -- c )
+    -2b sqrt(b^2-2ac) + 2a /
+    -2b sqrt(b^2-2ac) - 2a / max ; ! the -ve answer is behind us (I think..)
+
+:: collision-coefficient ( v w -- c )
+    [let* | a [ v dup v. ]
+            b [ v w v. 2 * ]
+            c [ w dup v. v dup v. - ] |
+        b -2 * b sq a c * 2 * - sqrt a 2 * (collision-coefficient) ] ;
+
+: distance-to-collision ( oint segment -- distance )
+    [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ]
+    [ drop forward>> n*v norm ] 2tri ;
+
+:: (wall-normal) ( seg loc -- n )
+    [let* | back [ loc seg location>> v- ]
+           back-proj [ back seg forward>> proj ]
+           perp-point [ loc back-proj v- ] |
+        perp-point seg location>> v- normalize ] ;
+
+: wall-normal ( segment oint -- n )
+    location>> (wall-normal) ;
+
+: bounce-forward ( segment oint -- )
+    [ wall-normal ] [ swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-up ( oint segment -- )
+    2drop ; ! TODO
+
+: bounce-left ( oint segment -- )
+    2drop ; ! TODO
+
+! : bounce ( oint segment -- )
+!     [ swap bounce-forward ]
+!     [ bounce-up ]
+!     [ bounce-left ] 2tri ;
+
+: bounce ( oint segment -- )
+    drop 0.01 left-pivot ; ! just temporary

From 805f025cc5802fc7115309493aa44cd39ee04382 Mon Sep 17 00:00:00 2001
From: Alex Chapman 
Date: Wed, 7 May 2008 16:15:14 +1000
Subject: [PATCH 27/77] jamshred: some very wrong bounce code...

---
 extra/jamshred/game/game.factor       | 12 +++++++---
 extra/jamshred/jamshred.factor        | 23 +++++++++++--------
 extra/jamshred/oint/oint-tests.factor |  4 ++++
 extra/jamshred/oint/oint.factor       |  8 ++-----
 extra/jamshred/player/player.factor   | 23 +++++++++++--------
 extra/jamshred/tunnel/tunnel.factor   | 33 +++++++++++++++------------
 6 files changed, 61 insertions(+), 42 deletions(-)
 create mode 100644 extra/jamshred/oint/oint-tests.factor

diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor
index 2a5fefcaed..e187d26a17 100644
--- a/extra/jamshred/game/game.factor
+++ b/extra/jamshred/game/game.factor
@@ -3,10 +3,10 @@
 USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ;
 IN: jamshred.game
 
-TUPLE: jamshred tunnel players running ;
+TUPLE: jamshred tunnel players running quit ;
 
 :  ( -- jamshred )
-     "Player 1"  2dup swap play-in-tunnel 1array f
+     "Player 1"  2dup swap play-in-tunnel 1array f f
     jamshred boa ;
 
 : jamshred-player ( jamshred -- player )
@@ -19,7 +19,13 @@ TUPLE: jamshred tunnel players running ;
     ] [ drop ] if ;
 
 : toggle-running ( jamshred -- )
-    [ running>> not ] [ (>>running) ] bi ;
+    dup running>> [
+        f >>running drop
+    ] [
+        [ jamshred-player moved ]
+        [ t >>running drop ] bi
+    ] if ;
 
 : mouse-moved ( x-radians y-radians jamshred -- )
     jamshred-player -rot turn-player ;
+
diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor
index 3a7047929f..bdec1e57e5 100755
--- a/extra/jamshred/jamshred.factor
+++ b/extra/jamshred/jamshred.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render math.vectors ;
+USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ;
 IN: jamshred
 
 TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
@@ -8,8 +8,8 @@ TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
 :  ( jamshred -- gadget )
     jamshred-gadget construct-gadget swap >>jamshred ;
 
-: default-width ( -- x ) 1024 ;
-: default-height ( -- y ) 768 ;
+: default-width ( -- x ) 640 ;
+: default-height ( -- y ) 480 ;
 
 M: jamshred-gadget pref-dim*
     drop default-width default-height 2array ;
@@ -17,16 +17,19 @@ M: jamshred-gadget pref-dim*
 M: jamshred-gadget draw-gadget* ( gadget -- )
     [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
 
-: tick ( gadget -- )
-    [ jamshred>> jamshred-update ] [ relayout-1 ] bi ;
+: jamshred-loop ( gadget -- )
+    dup jamshred>> quit>> [
+        drop
+    ] [
+        dup [ jamshred>> jamshred-update ]
+        [ relayout-1 ] bi
+        50 sleep jamshred-loop
+    ] if ;
 
 M: jamshred-gadget graft* ( gadget -- )
-    [
-        [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
-    ] keep (>>alarm) ;
-
+    [ jamshred-loop ] in-thread drop ;
 M: jamshred-gadget ungraft* ( gadget -- )
-    [ alarm>> cancel-alarm ] [ f >>alarm drop ] bi ;
+    jamshred>> t >>quit drop ;
 
 : jamshred-restart ( jamshred-gadget -- )
      >>jamshred drop ;
diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor
new file mode 100644
index 0000000000..cf9f22261a
--- /dev/null
+++ b/extra/jamshred/oint/oint-tests.factor
@@ -0,0 +1,4 @@
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor
index 6b4f22bb9e..9f4eada11e 100644
--- a/extra/jamshred/oint/oint.factor
+++ b/extra/jamshred/oint/oint.factor
@@ -55,10 +55,6 @@ TUPLE: oint location forward up left ;
 : proj-perp ( v u -- w )
     dupd proj v- ;
 
-! :: reflect ( v l -- v' )
-!     #! reflect v on l
-!     v l v. l l v. / 2 * l n*v v v- ;
-
-:: reflect ( vec n -- v' )
+:: reflect ( v n -- v' )
     #! bounce v on a surface with normal n
-    vec n v. n n*v -2 * vec v+ ;
+    v v n v. n n v. / 2 * n n*v v- ;
diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor
index 6feca27366..4aba302a75 100644
--- a/extra/jamshred/player/player.factor
+++ b/extra/jamshred/player/player.factor
@@ -1,12 +1,12 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences ;
+USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences system ;
 IN: jamshred.player
 
-TUPLE: player < oint name tunnel nearest-segment ;
+TUPLE: player < oint name tunnel nearest-segment last-move ;
 
 :  ( name -- player )
-    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f player boa ;
+    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f f player boa ;
 
 : turn-player ( player x-radians y-radians -- )
     >r over r> left-pivot up-pivot ;
@@ -22,19 +22,23 @@ TUPLE: player < oint name tunnel nearest-segment ;
     [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
     [ (>>nearest-segment) ] tri ;
 
-: max-speed ( -- speed )
-    0.01 ;
+: moved ( player -- ) millis swap (>>last-move) ;
+: max-speed ( -- speed ) 1.0 ; ! units/second
 
 : player-speed ( player -- speed )
     drop max-speed ;
     ! dup nearest-segment>> fraction-from-wall sq max-speed * ;
 
-! : move-player ( player -- )
-!     dup player-speed over go-forward update-nearest-segment ;
+: distance-to-move ( player -- distance )
+    [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ]
+    [ (>>last-move) ] tri ;
+
 DEFER: (move-player)
 
+USE: morse
 : ?bounce ( distance-remaining player -- )
     over 0 > [
+        "e" play-as-morse
         [ dup nearest-segment>> bounce ]
         ! [ (move-player) ] ! uncomment when bounce works...
         [ 2drop ]
@@ -52,12 +56,13 @@ USE: io.streams.string
     over 0 <= [
         2drop
     ] [
-        dup dup nearest-segment>> distance-to-collision ! [ .s ] with-string-writer jamshred-log
+        dup dup nearest-segment>> distance-to-collision
+        [ dup . ] with-string-writer jamshred-log
         move-player-distance ?bounce
     ] if ;
 
 : move-player ( player -- )
-    [ player-speed ] [ (move-player) ] [ update-nearest-segment ] tri ;
+    [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
 
 : update-player ( player -- )
     dup move-player nearest-segment>>
diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
index 7c6740f139..3ac864a7f7 100755
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -126,15 +126,23 @@ C:  segment
 !     ] [
 !     ] if ;
 
+USING: jamshred.log prettyprint io.streams.string ;
+
+: distant 10 ; inline
+
 :: (collision-coefficient) ( -2b sqrt(b^2-2ac) 2a -- c )
-    -2b sqrt(b^2-2ac) + 2a /
-    -2b sqrt(b^2-2ac) - 2a / max ; ! the -ve answer is behind us (I think..)
+    sqrt(b^2-2ac) complex? [
+        distant
+    ] [
+        -2b sqrt(b^2-2ac) + 2a /
+        -2b sqrt(b^2-2ac) - 2a / max ! the -ve answer is behind us
+    ] if ;
 
 :: collision-coefficient ( v w -- c )
     [let* | a [ v dup v. ]
             b [ v w v. 2 * ]
             c [ w dup v. v dup v. - ] |
-        b -2 * b sq a c * 2 * - sqrt a 2 * (collision-coefficient) ] ;
+        b neg b sq a c * 4 * - sqrt a 2 * (collision-coefficient) ] ;
 
 : distance-to-collision ( oint segment -- distance )
     [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ]
@@ -150,18 +158,15 @@ C:  segment
     location>> (wall-normal) ;
 
 : bounce-forward ( segment oint -- )
-    [ wall-normal ] [ swap reflect ] [ (>>forward) ] tri ;
+    [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
 
-: bounce-up ( oint segment -- )
-    2drop ; ! TODO
+: bounce-left ( segment oint -- )
+    [ forward>> vneg ] dip [ left>> swap reflect ] [ (>>left) ] bi ;
 
-: bounce-left ( oint segment -- )
-    2drop ; ! TODO
-
-! : bounce ( oint segment -- )
-!     [ swap bounce-forward ]
-!     [ bounce-up ]
-!     [ bounce-left ] 2tri ;
+: bounce-up ( segment oint -- )
+    #! must be done after forward and left!
+    nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
 
 : bounce ( oint segment -- )
-    drop 0.01 left-pivot ; ! just temporary
+    swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+

From fd531c1a31327f28525eb324ddda1f4195aee082 Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Wed, 7 May 2008 01:38:34 -0500
Subject: [PATCH 28/77] rename butlast to but-last

---
 core/classes/tuple/tuple.factor             |  2 +-
 core/inference/transforms/transforms.factor |  2 +-
 core/prettyprint/prettyprint-tests.factor   |  2 +-
 core/prettyprint/sections/sections.factor   |  2 +-
 core/sequences/sequences-docs.factor        |  8 ++++----
 core/sequences/sequences.factor             |  8 ++++----
 core/splitting/splitting.factor             |  2 +-
 extra/help/lint/lint.factor                 |  2 +-
 extra/html/parser/analyzer/analyzer.factor  |  2 +-
 extra/html/parser/utils/utils.factor        |  2 +-
 extra/inverse/inverse.factor                |  2 +-
 extra/koszul/koszul.factor                  |  2 +-
 extra/locals/locals.factor                  |  2 +-
 extra/mortar/mortar.factor                  |  2 +-
 extra/multiline/multiline.factor            |  4 ++--
 extra/porter-stemmer/porter-stemmer.factor  | 10 +++++-----
 extra/project-euler/002/002.factor          |  2 +-
 extra/project-euler/059/059.factor          |  2 +-
 extra/state-parser/state-parser-docs.factor |  2 +-
 extra/tools/deploy/backend/backend.factor   |  4 ++--
 extra/tuple-syntax/tuple-syntax.factor      |  2 +-
 extra/ui/gestures/gestures.factor           |  2 +-
 22 files changed, 34 insertions(+), 34 deletions(-)

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index fb6f1ffba0..5ebcc7a286 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -102,7 +102,7 @@ ERROR: bad-superclass class ;
     dup tuple-predicate-quot define-predicate ;
 
 : superclass-size ( class -- n )
-    superclasses butlast-slice
+    superclasses but-last-slice
     [ slot-names length ] map sum ;
 
 : generate-tuple-slots ( class slots -- slot-specs )
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index cf3dcadd75..0040629edd 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -32,7 +32,7 @@ IN: inference.transforms
         drop [ no-case ]
     ] [
         dup peek quotation? [
-            dup peek swap butlast
+            dup peek swap but-last
         ] [
             [ no-case ] swap
         ] if case>quot
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 834cad5b29..0faae398e9 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -114,7 +114,7 @@ unit-test
             [ parse-fresh drop ] with-compilation-unit
             [
                 "prettyprint.tests" lookup see
-            ] with-string-writer "\n" split butlast
+            ] with-string-writer "\n" split but-last
         ] keep =
     ] with-scope ;
 
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index 0ce8841256..7de5c2aee0 100644
--- a/core/prettyprint/sections/sections.factor
+++ b/core/prettyprint/sections/sections.factor
@@ -284,7 +284,7 @@ M: colon unindent-first-line? drop t ;
 
 ! Long section layout algorithm
 : chop-break ( seq -- seq )
-    dup peek line-break? [ butlast-slice chop-break ] when ;
+    dup peek line-break? [ but-last-slice chop-break ] when ;
 
 SYMBOL: prev
 SYMBOL: next
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 67d26089b0..a2fcc3aea1 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -92,7 +92,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
 { $subsection subseq }
 { $subsection head }
 { $subsection tail }
-{ $subsection butlast }
+{ $subsection but-last }
 { $subsection rest }
 { $subsection head* }
 { $subsection tail* }
@@ -107,7 +107,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
 { $subsection  }
 { $subsection head-slice }
 { $subsection tail-slice }
-{ $subsection butlast-slice }
+{ $subsection but-last-slice }
 { $subsection rest-slice }
 { $subsection head-slice* }
 { $subsection tail-slice* }
@@ -838,7 +838,7 @@ HELP: tail-slice
 { $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
 { $errors "Throws an error if the index is out of bounds." } ;
 
-HELP: butlast-slice
+HELP: but-last-slice
 { $values { "seq" sequence } { "slice" "a slice" } }
 { $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." }
 { $errors "Throws an error on an empty sequence." } ;
@@ -869,7 +869,7 @@ HELP: tail
 { $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
 { $errors "Throws an error if the index is out of bounds." } ;
 
-HELP: butlast
+HELP: but-last
 { $values { "seq" sequence } { "headseq" "a new sequence" } }
 { $description "Outputs a new sequence consisting of the input sequence with the last item removed." }
 { $errors "Throws an error on an empty sequence." } ;
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 1e9d187c2d..8d0e3eec18 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -216,7 +216,7 @@ M: slice length dup slice-to swap slice-from - ;
 
 : tail-slice* ( seq n -- slice ) from-end tail-slice ;
 
-: butlast-slice ( seq -- slice ) 1 head-slice* ;
+: but-last-slice ( seq -- slice ) 1 head-slice* ;
 
 INSTANCE: slice virtual-sequence
 
@@ -265,7 +265,7 @@ PRIVATE>
 
 : tail* ( seq n -- tailseq ) from-end tail ;
 
-: butlast ( seq -- headseq ) 1 head* ;
+: but-last ( seq -- headseq ) 1 head* ;
 
 : copy ( src i dst -- )
     pick length >r 3dup check-copy spin 0 r>
@@ -675,13 +675,13 @@ PRIVATE>
     [ rest ] [ first ] bi ;
 
 : unclip-last ( seq -- butfirst last )
-    [ butlast ] [ peek ] bi ;
+    [ but-last ] [ peek ] bi ;
 
 : unclip-slice ( seq -- rest first )
     [ rest-slice ] [ first ] bi ;
 
 : unclip-last-slice ( seq -- butfirst last )
-    [ butlast-slice ] [ peek ] bi ;
+    [ but-last-slice ] [ peek ] bi ;
 
 :  ( seq -- slice )
     dup slice? [ { } like ] when 0 over length rot  ;
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index be0652fd98..9f6ae75d32 100755
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -104,7 +104,7 @@ M: sliced-clumps nth group@  ;
         1array
     ] [
         "\n" split [
-            butlast-slice [
+            but-last-slice [
                 "\r" ?tail drop "\r" split
             ] map
         ] keep peek "\r" split suffix concat
diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor
index a120d791aa..a9ec7f9267 100755
--- a/extra/help/lint/lint.factor
+++ b/extra/help/lint/lint.factor
@@ -10,7 +10,7 @@ IN: help.lint
 
 : check-example ( element -- )
     rest [
-        butlast "\n" join 1vector
+        but-last "\n" join 1vector
         [
             use [ clone ] change
             [ eval>string ] with-datastack
diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor
index 1912cfb65c..e9906f3f2a 100755
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@@ -99,7 +99,7 @@ IN: html.parser.analyzer
     
 : find-between ( i/f tag/f vector -- vector )
     find-between* dup length 3 >= [
-        [ rest-slice butlast-slice ] keep like
+        [ rest-slice but-last-slice ] keep like
     ] when ;
 
 : find-between-first ( string vector -- vector' )
diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor
index c0eee57ead..5083b1cec2 100644
--- a/extra/html/parser/utils/utils.factor
+++ b/extra/html/parser/utils/utils.factor
@@ -36,7 +36,7 @@ IN: html.parser.utils
     dup quoted? [ quote ] unless ;
 
 : unquote ( str -- newstr )
-    dup quoted? [ butlast-slice rest-slice >string ] when ;
+    dup quoted? [ but-last-slice rest-slice >string ] when ;
 
 : quote? ( ch -- ? ) "'\"" member? ;
 
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index 8c19ade499..705c2d070b 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -197,7 +197,7 @@ DEFER: _
 
 \ prefix [ unclip ] define-inverse
 \ unclip [ prefix ] define-inverse
-\ suffix [ dup butlast swap peek ] define-inverse
+\ suffix [ dup but-last swap peek ] define-inverse
 
 ! Constructor inverse
 : deconstruct-pred ( class -- quot )
diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index 5c337f8ce7..aecae1cf88 100755
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -184,7 +184,7 @@ DEFER: (d)
     [ length ] keep [ (graded-ker/im-d) ] curry map ;
 
 : graded-betti ( generators -- seq )
-    basis graded graded-ker/im-d flip first2 butlast 0 prefix v- ;
+    basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
 
 ! Bi-graded for two-step complexes
 : (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 4ad81ef00a..031348fbe8 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -101,7 +101,7 @@ UNION: special local quote local-word local-reader local-writer ;
     ] if ;
 
 : point-free-body ( quot args -- newquot )
-    >r butlast-slice r> [ localize ] curry map concat ;
+    >r but-last-slice r> [ localize ] curry map concat ;
 
 : point-free-end ( quot args -- newquot )
     over peek special?
diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor
index 3d4d287ace..6173669ad0 100644
--- a/extra/mortar/mortar.factor
+++ b/extra/mortar/mortar.factor
@@ -122,7 +122,7 @@ over class-class-methods assoc-stack call ;
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : send-message-next ( object message -- )
-over object-class class-methods butlast assoc-stack call ;
+over object-class class-methods but-last assoc-stack call ;
 
 : <-~ scan parsed \ send-message-next parsed ; parsing
 
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index acff8c8669..ce79bdaf5f 100755
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -14,7 +14,7 @@ IN: multiline
     ] [ ";" unexpected-eof ] if* ;
 
 : parse-here ( -- str )
-    [ (parse-here) ] "" make butlast
+    [ (parse-here) ] "" make but-last
     lexer get next-line ;
 
 : STRING:
@@ -34,7 +34,7 @@ IN: multiline
     [
         lexer get lexer-column swap (parse-multiline-string)
         lexer get set-lexer-column
-    ] "" make rest butlast ;
+    ] "" make rest but-last ;
 
 : <"
     "\">" parse-multiline-string parsed ; parsing
diff --git a/extra/porter-stemmer/porter-stemmer.factor b/extra/porter-stemmer/porter-stemmer.factor
index f6975ccce7..9a2a08bcbe 100644
--- a/extra/porter-stemmer/porter-stemmer.factor
+++ b/extra/porter-stemmer/porter-stemmer.factor
@@ -93,7 +93,7 @@ USING: kernel math parser sequences combinators splitting ;
         { [ "iz" ?tail ] [ "ize" append ] }
         {
             [ dup length 1- over double-consonant? ]
-            [ dup "lsz" last-is? [ butlast-slice ] unless ]
+            [ dup "lsz" last-is? [ but-last-slice ] unless ]
         }
         {
             [ t ]
@@ -120,7 +120,7 @@ USING: kernel math parser sequences combinators splitting ;
     } cond ;
 
 : step1c ( str -- newstr )
-    dup butlast-slice stem-vowel? [
+    dup but-last-slice stem-vowel? [
         "y" ?tail [ "i" append ] when
     ] when ;
 
@@ -196,18 +196,18 @@ USING: kernel math parser sequences combinators splitting ;
 : remove-e? ( str -- ? )
     dup consonant-seq dup 1 >
     [ 2drop t ]
-    [ 1 = [ butlast-slice cvc? not ] [ drop f ] if ] if ;
+    [ 1 = [ but-last-slice cvc? not ] [ drop f ] if ] if ;
 
 : remove-e ( str -- newstr )
     dup peek CHAR: e = [
-        dup remove-e? [ butlast-slice ] when
+        dup remove-e? [ but-last-slice ] when
     ] when ;
 
 : ll->l ( str -- newstr )
     {
         { [ dup peek CHAR: l = not ] [ ] }
         { [ dup length 1- over double-consonant? not ] [ ] }
-        { [ dup consonant-seq 1 > ] [ butlast-slice ] }
+        { [ dup consonant-seq 1 > ] [ but-last-slice ] }
         [ ]
     } cond ;
 
diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor
index 6c9d331c90..108f5c1e94 100644
--- a/extra/project-euler/002/002.factor
+++ b/extra/project-euler/002/002.factor
@@ -41,7 +41,7 @@ PRIVATE>
 
 : fib-upto* ( n -- seq )
     0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
-    butlast-slice { 0 1 } prepend ;
+    but-last-slice { 0 1 } prepend ;
 
 : euler002a ( -- answer )
     1000000 fib-upto* [ even? ] filter sum ;
diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor
index 25c086144f..dceb01bd16 100644
--- a/extra/project-euler/059/059.factor
+++ b/extra/project-euler/059/059.factor
@@ -78,7 +78,7 @@ INSTANCE: rollover immutable-sequence
     frequency-analysis sort-values keys peek ;
 
 : crack-key ( seq key-length -- key )
-    [ " " decrypt ] dip group butlast-slice
+    [ " " decrypt ] dip group but-last-slice
     flip [ most-frequent ] map ;
 
 PRIVATE>
diff --git a/extra/state-parser/state-parser-docs.factor b/extra/state-parser/state-parser-docs.factor
index cac0e30175..3027c01c19 100644
--- a/extra/state-parser/state-parser-docs.factor
+++ b/extra/state-parser/state-parser-docs.factor
@@ -69,4 +69,4 @@ HELP: next
 { $description "originally written as " { $code "spot inc" } ", code that would no longer run, this word moves the state of the XML parser to the next place in the source file, keeping track of appropriate debugging information." } ;
 
 HELP: parsing-error
-{ $class-description "class to which parsing errors delegate, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ;
+{ $class-description "class from which parsing errors inherit, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ;
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index 60d66e89cd..6dff511238 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -63,11 +63,11 @@ DEFER: ?make-staging-image
         dup empty? [
             "-i=" my-boot-image-name append ,
         ] [
-            dup butlast ?make-staging-image
+            dup but-last ?make-staging-image
 
             "-resource-path=" "" resource-path append ,
 
-            "-i=" over butlast staging-image-name append ,
+            "-i=" over but-last staging-image-name append ,
 
             "-run=tools.deploy.restage" ,
         ] if
diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor
index 2b9b2c3fb4..cf439f6407 100755
--- a/extra/tuple-syntax/tuple-syntax.factor
+++ b/extra/tuple-syntax/tuple-syntax.factor
@@ -7,7 +7,7 @@ IN: tuple-syntax
 
 : parse-slot-writer ( tuple -- slot# )
     scan dup "}" = [ 2drop f ] [
-        butlast swap object-slots slot-named slot-spec-offset
+        but-last swap object-slots slot-named slot-spec-offset
     ] if ;
 
 : parse-slots ( accum tuple -- accum tuple )
diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor
index d13e284160..9835e90b39 100755
--- a/extra/ui/gestures/gestures.factor
+++ b/extra/ui/gestures/gestures.factor
@@ -54,7 +54,7 @@ TUPLE: zoom-in-action ;  C:  zoom-in-action
 TUPLE: zoom-out-action ; C:  zoom-out-action
 
 : generalize-gesture ( gesture -- newgesture )
-    tuple>array butlast >tuple ;
+    tuple>array but-last >tuple ;
 
 ! Modifiers
 SYMBOLS: C+ A+ M+ S+ ;

From cbac71c3bf89a9c901bf68d18094186f1b5734da Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 01:56:55 -0500
Subject: [PATCH 29/77] Another threads fix

---
 core/threads/threads.factor                 |  9 ++++++---
 extra/ui/tools/interactor/interactor.factor | 19 +++++++++++--------
 2 files changed, 17 insertions(+), 11 deletions(-)

diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index 32d5e5234d..2a0d8e68ab 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -12,7 +12,7 @@ SYMBOL: initial-thread
 TUPLE: thread
 name quot exit-handler
 id
-continuation state
+continuation state runnable
 mailbox variables sleep-entry ;
 
 : self ( -- thread ) 40 getenv ; inline
@@ -138,8 +138,11 @@ DEFER: next
 : (next) ( arg thread -- * )
     f >>state
     dup set-self
-    dup continuation>> ?box
-    [ nip continue-with ] [ drop start ] if ;
+    dup runnable>> [
+        continuation>> box> continue-with
+    ] [
+        t >>runnable start
+    ] if ;
 
 : next ( -- * )
     expire-sleep-loop
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 74fc437e05..ffac73d082 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -6,12 +6,12 @@ models namespaces parser prettyprint quotations sequences
 strings threads listener classes.tuple ui.commands ui.gadgets
 ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
 ui.gestures definitions calendar concurrency.flags
-ui.tools.workspace accessors ;
+concurrency.mailboxes ui.tools.workspace accessors ;
 IN: ui.tools.interactor
 
 ! If waiting is t, we're waiting for user input, and invoking
 ! evaluate-input resumes the thread.
-TUPLE: interactor output history flag thread waiting help ;
+TUPLE: interactor output history flag mailbox thread waiting help ;
 
 : register-self ( interactor -- )
     self >>thread drop ;
@@ -40,6 +40,7 @@ TUPLE: interactor output history flag thread waiting help ;
     interactor construct-editor
         V{ } clone >>history
          >>flag
+         >>mailbox
         dup  >>help
         swap >>output ;
 
@@ -77,7 +78,7 @@ M: interactor model-changed
     over empty? [ 2drop ] [ interactor-history push-new ] if ;
 
 : interactor-continue ( obj interactor -- )
-    thread>> resume-with ;
+    mailbox>> mailbox-put ;
 
 : clear-input ( interactor -- ) gadget-model clear-doc ;
 
@@ -100,14 +101,16 @@ M: interactor model-changed
 
 : interactor-yield ( interactor -- obj )
     dup thread>> self eq? [
-        t >>waiting
-        [ [ flag>> raise-flag ] curry "input" suspend ] keep
-        f >>waiting
-        drop
+        {
+            [ t >>waiting drop ]
+            [ flag>> raise-flag ]
+            [ mailbox>> mailbox-get ]
+            [ f >>waiting drop ]
+        } cleave
     ] [ drop f ] if ;
 
 M: interactor stream-readln
-    [ interactor-yield ] keep interactor-finish
+    [ interactor-yield ] [ interactor-finish ] bi
     dup [ first ] when ;
 
 : interactor-call ( quot interactor -- )

From 7fbad98d97f545da288153e5e2153c6e10b12968 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 02:32:58 -0500
Subject: [PATCH 30/77] Interactor fix

---
 extra/ui/tools/interactor/interactor-tests.factor | 2 ++
 extra/ui/tools/interactor/interactor.factor       | 5 +++--
 2 files changed, 5 insertions(+), 2 deletions(-)

diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor
index 509543a20a..f8d5e33df9 100755
--- a/extra/ui/tools/interactor/interactor-tests.factor
+++ b/extra/ui/tools/interactor/interactor-tests.factor
@@ -8,6 +8,8 @@ tools.test kernel calendar parser accessors ;
 [
     [ ] [    "interactor" set ] unit-test
 
+    [ ] [ "interactor" get register-self ] unit-test
+
     [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
 
     [ ] [  "promise" set ] unit-test
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index ffac73d082..2e59363531 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -14,7 +14,9 @@ IN: ui.tools.interactor
 TUPLE: interactor output history flag mailbox thread waiting help ;
 
 : register-self ( interactor -- )
-    self >>thread drop ;
+     >>mailbox
+    self >>thread
+    drop ;
 
 : interactor-continuation ( interactor -- continuation )
     thread>> continuation>> value>> ;
@@ -40,7 +42,6 @@ TUPLE: interactor output history flag mailbox thread waiting help ;
     interactor construct-editor
         V{ } clone >>history
          >>flag
-         >>mailbox
         dup  >>help
         swap >>output ;
 

From 2f44e86ee1551100dd3dafadc373e0d1a902b246 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 02:33:02 -0500
Subject: [PATCH 31/77] Doc fix

---
 core/sequences/sequences-docs.factor | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index a2fcc3aea1..8b15f5b980 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -92,10 +92,11 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
 { $subsection subseq }
 { $subsection head }
 { $subsection tail }
-{ $subsection but-last }
-{ $subsection rest }
 { $subsection head* }
 { $subsection tail* }
+"Removing the first or last element:"
+{ $subsection rest }
+{ $subsection but-last }
 "Taking a sequence apart into a head and a tail:"
 { $subsection unclip }
 { $subsection cut }

From 8065f8834e3353c9f1e75423097ba524bb637590 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 03:28:45 -0500
Subject: [PATCH 32/77] Multiple threads can now wait on one flag
 simultaneously

---
 extra/concurrency/flags/flags-tests.factor |  9 ++++++++-
 extra/concurrency/flags/flags.factor       | 20 +++++++++-----------
 2 files changed, 17 insertions(+), 12 deletions(-)

diff --git a/extra/concurrency/flags/flags-tests.factor b/extra/concurrency/flags/flags-tests.factor
index f23ea95167..d13c474554 100755
--- a/extra/concurrency/flags/flags-tests.factor
+++ b/extra/concurrency/flags/flags-tests.factor
@@ -1,5 +1,6 @@
 IN: concurrency.flags.tests
-USING: tools.test concurrency.flags kernel threads locals ;
+USING: tools.test concurrency.flags concurrency.combinators
+kernel threads locals ;
 
 :: flag-test-1 ( -- )
     [let | f [  ] |
@@ -44,3 +45,9 @@ USING: tools.test concurrency.flags kernel threads locals ;
     ] ;
 
 [ t ] [ flag-test-5 ] unit-test
+
+[ ] [
+    { 1 2 } 
+    [ [ 1000 sleep raise-flag ] curry "Flag test" spawn drop ]
+    [ [ wait-for-flag drop ] curry parallel-each ] bi
+] unit-test
diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor
index b3c76a7a01..ec260961d0 100755
--- a/extra/concurrency/flags/flags.factor
+++ b/extra/concurrency/flags/flags.factor
@@ -1,22 +1,20 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: boxes kernel threads ;
+USING: dlists kernel threads concurrency.conditions accessors ;
 IN: concurrency.flags
 
-TUPLE: flag value? thread ;
+TUPLE: flag value threads ;
 
-:  ( -- flag ) f  flag boa ;
+:  ( -- flag ) f  flag boa ;
 
 : raise-flag ( flag -- )
-    dup flag-value? [
-        t over set-flag-value?
-        dup flag-thread [ resume ] if-box?
-    ] unless drop ;
+    dup value>> [ drop ] [ t >>value threads>> notify-all ] if ;
+
+: wait-for-flag-timeout ( flag timeout -- )
+    over value>> [ 2drop ] [ >r threads>> r> "flag" wait ] if ;
 
 : wait-for-flag ( flag -- )
-    dup flag-value? [ drop ] [
-        [ flag-thread >box ] curry "flag" suspend drop
-    ] if ;
+    f wait-for-flag-timeout ;
 
 : lower-flag ( flag -- )
-    dup wait-for-flag f swap set-flag-value? ;
+    [ wait-for-flag ] [ f >>value drop ] bi ;

From 6464a620cde16274347420a59f44513abbfa994c Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 03:28:53 -0500
Subject: [PATCH 33/77] Fix listener word completion

---
 extra/ui/tools/listener/listener.factor | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index b09732ed2c..48800c0918 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
 ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
 ui.gadgets.tracks ui.gestures ui.operations vocabs words
 prettyprint listener debugger threads boxes concurrency.flags
-math arrays generic accessors combinators ;
+math arrays generic accessors combinators assocs ;
 IN: ui.tools.listener
 
 TUPLE: listener-gadget input output stack ;
@@ -101,12 +101,11 @@ M: engine-word word-completion-string
     "engine-generic" word-prop word-completion-string ;
 
 : use-if-necessary ( word seq -- )
-    >r word-vocabulary vocab-words r>
-    {
-        { [ dup not ] [ 2drop ] }
-        { [ 2dup memq? ] [ 2drop ] }
-        [ push ]
-    } cond ;
+    over word-vocabulary [
+        2dup assoc-stack pick = [ 2drop ] [
+            >r word-vocabulary vocab-words r> push
+        ] if
+    ] [ 2drop ] if ;
 
 : insert-word ( word -- )
     get-workspace workspace-listener input>>

From 7fb8b3c40688862c2ee70215a3e1109795e6a192 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 04:22:48 -0500
Subject: [PATCH 34/77] Fix threads

---
 core/threads/threads.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index 2a0d8e68ab..a1c7e208dc 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -213,6 +213,7 @@ GENERIC: error-in-thread ( error thread -- )
     initial-thread global
     [ drop f "Initial"  ] cache
      >>continuation
+    t >>runnable
     f >>state
     dup register-thread
     set-self ;

From 995f1b80763f25efecc3804ab04341856810318e Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 05:14:25 -0500
Subject: [PATCH 35/77] Fix stack effects

---
 extra/benchmark/sockets/sockets.factor | 2 +-
 extra/contributors/contributors.factor | 8 ++++----
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor
index 1c33bfc4dc..6defd94290 100755
--- a/extra/benchmark/sockets/sockets.factor
+++ b/extra/benchmark/sockets/sockets.factor
@@ -10,7 +10,7 @@ SYMBOL: counter
 : server-addr "127.0.0.1" 7777  ;
 
 : server-loop ( server -- )
-    dup accept [
+    dup accept drop [
         [
             read1 CHAR: x = [
                 "server" get dispose
diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor
index 4b7acb468c..9f2d5a55fa 100755
--- a/extra/contributors/contributors.factor
+++ b/extra/contributors/contributors.factor
@@ -1,13 +1,13 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.launcher io.styles io hashtables kernel
-sequences sequences.lib assocs system sorting math.parser
-sets ;
+USING: io.files io.launcher io.styles io.encodings.ascii io
+hashtables kernel sequences sequences.lib assocs system sorting
+math.parser sets ;
 IN: contributors
 
 : changelog ( -- authors )
     image parent-directory [
-        "git-log --pretty=format:%an"  lines
+        "git-log --pretty=format:%an" ascii  lines
     ] with-directory ;
 
 : patch-counts ( authors -- assoc )

From 25bdb0b875e7be49068d8034cfc68a2dd4fa9768 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 05:15:22 -0500
Subject: [PATCH 36/77] Unit test

---
 extra/contributors/contributors-tests.factor | 5 +++++
 1 file changed, 5 insertions(+)
 create mode 100644 extra/contributors/contributors-tests.factor

diff --git a/extra/contributors/contributors-tests.factor b/extra/contributors/contributors-tests.factor
new file mode 100644
index 0000000000..1476715588
--- /dev/null
+++ b/extra/contributors/contributors-tests.factor
@@ -0,0 +1,5 @@
+IN: contributors.tests
+USING: contributors tools.test ;
+
+\ contributors must-infer
+[ ] [ contributors ] unit-test

From 971bab1ff105a62582a9c29ecfd171b494a0ef01 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 05:17:32 -0500
Subject: [PATCH 37/77] Fix compile error in cairo.png

---
 extra/cairo/png/png.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor
index 1bbad29835..a3b13c9691 100755
--- a/extra/cairo/png/png.factor
+++ b/extra/cairo/png/png.factor
@@ -21,7 +21,7 @@ ERROR: cairo-error string ;
         { CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
         { CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
         [ drop ]
-    } cond ;
+    } case ;
 
 :  ( path -- png )
     normalize-path

From 6bee417504be1587f587d44447f7a52dc0fd640b Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 05:42:23 -0500
Subject: [PATCH 38/77] Move OpenSSL to unmaintained since unit tests are flaky
 and nobody knows how to fix it

---
 {extra => unmaintained}/openssl/authors.txt                | 0
 {extra => unmaintained}/openssl/libcrypto/libcrypto.factor | 0
 {extra => unmaintained}/openssl/libssl/libssl.factor       | 0
 {extra => unmaintained}/openssl/openssl-docs.factor        | 0
 {extra => unmaintained}/openssl/openssl-tests.factor       | 0
 {extra => unmaintained}/openssl/openssl.factor             | 0
 {extra => unmaintained}/openssl/summary.txt                | 0
 {extra => unmaintained}/openssl/tags.txt                   | 0
 {extra => unmaintained}/openssl/test/dh1024.pem            | 0
 {extra => unmaintained}/openssl/test/errors.txt            | 0
 {extra => unmaintained}/openssl/test/root.pem              | 0
 {extra => unmaintained}/openssl/test/server.pem            | 0
 12 files changed, 0 insertions(+), 0 deletions(-)
 rename {extra => unmaintained}/openssl/authors.txt (100%)
 rename {extra => unmaintained}/openssl/libcrypto/libcrypto.factor (100%)
 rename {extra => unmaintained}/openssl/libssl/libssl.factor (100%)
 rename {extra => unmaintained}/openssl/openssl-docs.factor (100%)
 rename {extra => unmaintained}/openssl/openssl-tests.factor (100%)
 rename {extra => unmaintained}/openssl/openssl.factor (100%)
 rename {extra => unmaintained}/openssl/summary.txt (100%)
 rename {extra => unmaintained}/openssl/tags.txt (100%)
 rename {extra => unmaintained}/openssl/test/dh1024.pem (100%)
 rename {extra => unmaintained}/openssl/test/errors.txt (100%)
 rename {extra => unmaintained}/openssl/test/root.pem (100%)
 rename {extra => unmaintained}/openssl/test/server.pem (100%)

diff --git a/extra/openssl/authors.txt b/unmaintained/openssl/authors.txt
similarity index 100%
rename from extra/openssl/authors.txt
rename to unmaintained/openssl/authors.txt
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/unmaintained/openssl/libcrypto/libcrypto.factor
similarity index 100%
rename from extra/openssl/libcrypto/libcrypto.factor
rename to unmaintained/openssl/libcrypto/libcrypto.factor
diff --git a/extra/openssl/libssl/libssl.factor b/unmaintained/openssl/libssl/libssl.factor
similarity index 100%
rename from extra/openssl/libssl/libssl.factor
rename to unmaintained/openssl/libssl/libssl.factor
diff --git a/extra/openssl/openssl-docs.factor b/unmaintained/openssl/openssl-docs.factor
similarity index 100%
rename from extra/openssl/openssl-docs.factor
rename to unmaintained/openssl/openssl-docs.factor
diff --git a/extra/openssl/openssl-tests.factor b/unmaintained/openssl/openssl-tests.factor
similarity index 100%
rename from extra/openssl/openssl-tests.factor
rename to unmaintained/openssl/openssl-tests.factor
diff --git a/extra/openssl/openssl.factor b/unmaintained/openssl/openssl.factor
similarity index 100%
rename from extra/openssl/openssl.factor
rename to unmaintained/openssl/openssl.factor
diff --git a/extra/openssl/summary.txt b/unmaintained/openssl/summary.txt
similarity index 100%
rename from extra/openssl/summary.txt
rename to unmaintained/openssl/summary.txt
diff --git a/extra/openssl/tags.txt b/unmaintained/openssl/tags.txt
similarity index 100%
rename from extra/openssl/tags.txt
rename to unmaintained/openssl/tags.txt
diff --git a/extra/openssl/test/dh1024.pem b/unmaintained/openssl/test/dh1024.pem
similarity index 100%
rename from extra/openssl/test/dh1024.pem
rename to unmaintained/openssl/test/dh1024.pem
diff --git a/extra/openssl/test/errors.txt b/unmaintained/openssl/test/errors.txt
similarity index 100%
rename from extra/openssl/test/errors.txt
rename to unmaintained/openssl/test/errors.txt
diff --git a/extra/openssl/test/root.pem b/unmaintained/openssl/test/root.pem
similarity index 100%
rename from extra/openssl/test/root.pem
rename to unmaintained/openssl/test/root.pem
diff --git a/extra/openssl/test/server.pem b/unmaintained/openssl/test/server.pem
similarity index 100%
rename from extra/openssl/test/server.pem
rename to unmaintained/openssl/test/server.pem

From 830d993366970ecbd8b2e173008ea8551403ea8a Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 05:47:14 -0500
Subject: [PATCH 39/77] Fix flags unit tests

---
 extra/concurrency/flags/flags-tests.factor | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/extra/concurrency/flags/flags-tests.factor b/extra/concurrency/flags/flags-tests.factor
index d13c474554..9d3f6de98c 100755
--- a/extra/concurrency/flags/flags-tests.factor
+++ b/extra/concurrency/flags/flags-tests.factor
@@ -1,12 +1,12 @@
 IN: concurrency.flags.tests
 USING: tools.test concurrency.flags concurrency.combinators
-kernel threads locals ;
+kernel threads locals accessors ;
 
 :: flag-test-1 ( -- )
     [let | f [  ] |
         [ f raise-flag ] "Flag test" spawn drop
         f lower-flag
-        f flag-value?
+        f value>>
     ] ;
 
 [ f ] [ flag-test-1 ] unit-test
@@ -15,7 +15,7 @@ kernel threads locals ;
     [let | f [  ] |
         [ 1000 sleep f raise-flag ] "Flag test" spawn drop
         f lower-flag
-        f flag-value?
+        f value>>
     ] ;
 
 [ f ] [ flag-test-2 ] unit-test
@@ -23,7 +23,7 @@ kernel threads locals ;
 :: flag-test-3 ( -- )
     [let | f [  ] |
         f raise-flag
-        f flag-value?
+        f value>>
     ] ;
 
 [ t ] [ flag-test-3 ] unit-test
@@ -32,7 +32,7 @@ kernel threads locals ;
     [let | f [  ] |
         [ f raise-flag ] "Flag test" spawn drop
         f wait-for-flag
-        f flag-value?
+        f value>>
     ] ;
 
 [ t ] [ flag-test-4 ] unit-test
@@ -41,7 +41,7 @@ kernel threads locals ;
     [let | f [  ] |
         [ 1000 sleep f raise-flag ] "Flag test" spawn drop
         f wait-for-flag
-        f flag-value?
+        f value>>
     ] ;
 
 [ t ] [ flag-test-5 ] unit-test

From 08e0eff03f4dd8aa476544fae49d389b6d0e831a Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 07:49:13 -0500
Subject: [PATCH 40/77] Fix stack effect

---
 core/checksums/checksums-tests.factor | 7 +++++++
 extra/checksums/null/null.factor      | 4 ++--
 2 files changed, 9 insertions(+), 2 deletions(-)
 create mode 100644 core/checksums/checksums-tests.factor

diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor
new file mode 100644
index 0000000000..1ec675b0cf
--- /dev/null
+++ b/core/checksums/checksums-tests.factor
@@ -0,0 +1,7 @@
+IN: checksums.tests
+USING: checksums tools.test ;
+
+\ checksum-bytes must-infer
+\ checksum-stream must-infer
+\ checksum-lines must-infer
+\ checksum-file must-infer
diff --git a/extra/checksums/null/null.factor b/extra/checksums/null/null.factor
index d2dc305ac2..d3ab878a12 100644
--- a/extra/checksums/null/null.factor
+++ b/extra/checksums/null/null.factor
@@ -1,8 +1,8 @@
-USING: checksums ;
+USING: checksums kernel ;
 IN: checksums.null
 
 SINGLETON: null
 
 INSTANCE: null checksum
 
-M: null checksum-bytes ;
+M: null checksum-bytes drop ;

From 1b2d7eac4a3fda2b4483791252a0972663b26285 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 07:49:29 -0500
Subject: [PATCH 41/77] with-return

---
 core/continuations/continuations-tests.factor | 2 ++
 core/continuations/continuations.factor       | 8 ++++++++
 core/prettyprint/sections/sections.factor     | 9 ++++-----
 3 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor
index 996d17077c..28581820fd 100755
--- a/core/continuations/continuations-tests.factor
+++ b/core/continuations/continuations-tests.factor
@@ -117,3 +117,5 @@ T{ dispose-dummy } "b" set
 [ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
 
 [ t ] [ "b" get disposed?>> ] unit-test
+
+[ ] [ [ return ] with-return ] unit-test
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index 3e675b1f0f..78effb043a 100755
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -101,6 +101,14 @@ PRIVATE>
 : continue ( continuation -- )
     f swap continue-with ;
 
+SYMBOL: return-continuation
+
+: with-return ( quot -- )
+    [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
+
+: return ( -- )
+    return-continuation get continue ;
+
 GENERIC: compute-restarts ( error -- seq )
 
  ( -- pprinter ) 0 1 f 0 pprinter boa ;
+:  ( -- pprinter ) 0 1 0 pprinter boa ;
 
 : record-vocab ( word -- )
     word-vocabulary [ dup pprinter-use get set-at ] when* ;
@@ -34,7 +34,7 @@ TUPLE: pprinter last-newline line-count end-printing indent ;
     ] [
         pprinter get (>>last-newline)
         line-limit? [
-            "..." write pprinter get end-printing>> continue
+            "..." write pprinter get return
         ] when
         pprinter get [ 1+ ] change-line-count drop
         nl do-indent
@@ -275,9 +275,8 @@ M: colon unindent-first-line? drop t ;
         [
             dup style>> [
                 [
-                    >r pprinter get (>>end-printing) r>
                     short-section
-                ] curry callcc0
+                ] curry with-return
             ] with-nesting
         ] if-nonempty
     ] with-variable ;

From 0314d05a08311e574e8d9b427bd49206f11e01b4 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 07:49:36 -0500
Subject: [PATCH 42/77] Cleanup compiler

---
 core/compiler/compiler.factor           | 59 ++++++++++++++++---------
 core/inference/state/state-tests.factor |  4 ++
 core/inference/state/state.factor       |  4 --
 3 files changed, 42 insertions(+), 25 deletions(-)

diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 806ea914bb..ef00e94dd5 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -4,38 +4,55 @@ USING: kernel namespaces arrays sequences io inference.backend
 inference.state generator debugger words compiler.units
 continuations vocabs assocs alien.compiler dlists optimizer
 definitions math compiler.errors threads graphs generic
-inference ;
+inference combinators ;
 IN: compiler
 
 : ripple-up ( word -- )
     compiled-usage [ drop queue-compile ] assoc-each ;
 
 : save-effect ( word effect -- )
-    over "compiled-uses" word-prop [
-        2dup swap "compiled-effect" word-prop =
-        [ over ripple-up ] unless
-    ] when
-    "compiled-effect" set-word-prop ;
-
-: finish-compile ( word effect dependencies -- )
-    >r dupd save-effect r>
-    over compiled-unxref
-    over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
-
-: compile-succeeded ( word -- effect dependencies )
     [
-        [ word-dataflow optimize ] keep dup generate
-    ] computing-dependencies ;
+        over "compiled-effect" word-prop = [
+            dup "compiled-uses" word-prop
+            [ dup ripple-up ] when
+        ] unless drop
+    ]
+    [ "compiled-effect" set-word-prop ] 2bi ;
+
+: compile-begins ( word -- )
+    f swap compiler-error ;
 
 : compile-failed ( word error -- )
-    f pick compiled get set-at
-    swap compiler-error ;
+    [ swap compiler-error ]
+    [
+        drop
+        [ f swap compiled get set-at ]
+        [ f save-effect ]
+        bi
+    ] 2bi ;
+
+: compile-succeeded ( effect word -- )
+    [ swap save-effect ]
+    [ compiled-unxref ]
+    [
+        dup compiled-crossref?
+        [ dependencies get compiled-xref ] [ drop ] if
+    ] tri ;
 
 : (compile) ( word -- )
-    f over compiler-error
-    [ dup compile-succeeded finish-compile ]
-    [ dupd compile-failed f save-effect ]
-    recover ;
+    [
+        H{ } clone dependencies set
+
+        {
+            [ compile-begins ]
+            [
+                [ word-dataflow ] [ compile-failed return ] recover
+                optimize
+            ]
+            [ dup generate ]
+            [ compile-succeeded ]
+        } cleave
+    ] curry with-return ;
 
 : compile-loop ( assoc -- )
     dup assoc-empty? [ drop ] [
diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor
index 84d72bdd9b..fe1f51a5e7 100644
--- a/core/inference/state/state-tests.factor
+++ b/core/inference/state/state-tests.factor
@@ -1,6 +1,10 @@
 IN: inference.state.tests
 USING: tools.test inference.state words ;
 
+: computing-dependencies ( quot -- dependencies )
+    H{ } clone [ dependencies rot with-variable ] keep ;
+    inline
+
 SYMBOL: a
 SYMBOL: b
 
diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor
index a426f410e2..6f0eecf2d9 100755
--- a/core/inference/state/state.factor
+++ b/core/inference/state/state.factor
@@ -36,10 +36,6 @@ SYMBOL: dependencies
         2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
     ] [ 3drop ] if ;
 
-: computing-dependencies ( quot -- dependencies )
-    H{ } clone [ dependencies rot with-variable ] keep ;
-    inline
-
 ! Did the current control-flow path throw an error?
 SYMBOL: terminated?
 

From 9633bda05209387e1f3e95b375b7abd532b77d5b Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 08:48:42 -0500
Subject: [PATCH 43/77] Fix drag-gesture error

---
 extra/ui/gestures/gestures.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor
index 9835e90b39..5bba095253 100755
--- a/extra/ui/gestures/gestures.factor
+++ b/extra/ui/gestures/gestures.factor
@@ -111,7 +111,8 @@ SYMBOL: double-click-timeout
     ] if ;
 
 : drag-gesture ( -- )
-    hand-buttons get-global first  button-gesture ;
+    hand-buttons get-global
+    dup empty? [ drop ] [ first  button-gesture ] if ;
 
 SYMBOL: drag-timer
 

From 26aa6561232a018497b7fc3429a5570d0253670b Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 08:48:51 -0500
Subject: [PATCH 44/77] with-locals no longer necessary

---
 extra/benchmark/fasta/fasta.factor |  4 ++--
 extra/locals/locals-docs.factor    | 24 +++---------------------
 extra/locals/locals-tests.factor   | 21 +++++++++++++++------
 extra/locals/locals.factor         | 19 +++++++++++--------
 extra/peg/ebnf/ebnf.factor         |  4 ++--
 5 files changed, 33 insertions(+), 39 deletions(-)

diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor
index 215b677e16..d449c0fc5b 100755
--- a/extra/benchmark/fasta/fasta.factor
+++ b/extra/benchmark/fasta/fasta.factor
@@ -81,7 +81,7 @@ HINTS: random fixnum ;
     write-description
     [let | k! [ 0 ] alu [ ] |
         [| len | k len alu make-repeat-fasta k! ] split-lines
-    ] with-locals ; inline
+    ] ; inline
 
 : fasta ( n out -- )
     homo-sapiens make-cumulative
@@ -103,7 +103,7 @@ HINTS: random fixnum ;
             drop
         ] with-file-writer
 
-    ] with-locals ;
+    ] ;
 
 : run-fasta 2500000 reverse-complement-in fasta ;
 
diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor
index 96485825ff..961017f39e 100644
--- a/extra/locals/locals-docs.factor
+++ b/extra/locals/locals-docs.factor
@@ -2,15 +2,6 @@ USING: help.syntax help.markup kernel macros prettyprint
 memoize ;
 IN: locals
 
-
-
 HELP: [|
 { $syntax "[| bindings... | body... ]" }
 { $description "A lambda abstraction. When called, reads stack values into the bindings from left to right; the body may then refer to these bindings." }
@@ -22,8 +13,7 @@ HELP: [|
         "3 5 adder call ."
         "8"
     }
-}
-$with-locals-note ;
+} ;
 
 HELP: [let
 { $syntax "[let | binding1 [ value1... ]\n       binding2 [ value2... ]\n       ... |\n    body... ]" }
@@ -38,8 +28,7 @@ HELP: [let
         "6 { 36 14 } frobnicate ."
         "{ 36 2 }"
     }
-}
-$with-locals-note ;
+} ;
 
 HELP: [let*
 { $syntax "[let* | binding1 [ value1... ]\n       binding2 [ value2... ]\n       ... |\n    body... ]" }
@@ -55,8 +44,7 @@ HELP: [let*
         "1 { 32 48 } frobnicate ."
         "{ 2 3 }"
     }
-}
-$with-locals-note ;
+} ;
 
 { POSTPONE: [let POSTPONE: [let* } related-words
 
@@ -75,10 +63,6 @@ HELP: [wlet
     }
 } ;
 
-HELP: with-locals
-{ $values { "form" "a quotation, lambda, let or wlet form" } { "quot" "a quotation" } }
-{ $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ;
-
 HELP: ::
 { $syntax ":: word ( bindings... -- outputs... ) body... ;" }
 { $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
@@ -136,8 +120,6 @@ $nl
 { $subsection POSTPONE: :: }
 { $subsection POSTPONE: MEMO:: }
 { $subsection POSTPONE: MACRO:: }
-"Explicit closure conversion outside of applicative word definitions:"
-{ $subsection with-locals }
 "Lexical binding forms:"
 { $subsection POSTPONE: [let }
 { $subsection POSTPONE: [let* }
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index bb2fd9893c..5c3d2005a8 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -1,6 +1,6 @@
 USING: locals math sequences tools.test hashtables words kernel
 namespaces arrays strings prettyprint io.streams.string parser
-;
+accessors ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -55,7 +55,6 @@ IN: locals.tests
 
 [ 5 ] [
     [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
-    with-locals
 ] unit-test
 
 :: wlet-test-2 ( a b -- seq )
@@ -108,7 +107,7 @@ write-test-2 "q" set
 
 [ 10 20 ]
 [
-    20 10 [| a! | [| b! | a b ] ] with-locals call call
+    20 10 [| a! | [| b! | a b ] ] call call
 ] unit-test
 
 :: write-test-3 ( a! -- q ) [| b | b a! ] ;
@@ -170,16 +169,22 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
 
 [ ] [ \ lambda-generic see ] unit-test
 
+:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
+
 [ "[let | a! [ ] | ]" ] [
-    [let | a! [ ] | ] unparse
+    \ unparse-test-1 "lambda" word-prop body>> first unparse
 ] unit-test
 
+:: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
+
 [ "[wlet | a! [ ] | ]" ] [
-    [wlet | a! [ ] | ] unparse
+    \ unparse-test-2 "lambda" word-prop body>> first unparse
 ] unit-test
 
+:: unparse-test-3 ( -- b ) [| a! | ] ;
+
 [ "[| a! | ]" ] [
-    [| a! | ] unparse
+    \ unparse-test-3 "lambda" word-prop body>> first unparse
 ] unit-test
 
 DEFER: xyzzy
@@ -237,3 +242,7 @@ M: integer next-method-test 3 + ;
 M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 
 [ 5 ] [ 1 next-method-test ] unit-test
+
+: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
+
+[ { 4 5 6 } ] [ no-with-locals-test ] unit-test
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 031348fbe8..4b7ab8cdad 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -201,8 +201,11 @@ M: object local-rewrite* , ;
 : pop-locals ( assoc -- )
     use get delete ;
 
+SYMBOL: in-lambda?
+
 : (parse-lambda) ( assoc end -- quot )
-    parse-until >quotation swap pop-locals ;
+    t in-lambda? [ parse-until ] with-variable
+    >quotation swap pop-locals ;
 
 : parse-lambda ( -- lambda )
     "|" parse-tokens make-locals dup push-locals
@@ -283,24 +286,24 @@ M: wlet local-rewrite*
     CREATE-METHOD
     [ parse-locals-definition ] with-method-definition ;
 
+: parsed-lambda ( form -- )
+    in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
+
 PRIVATE>
 
-: [| parse-lambda parsed ; parsing
+: [| parse-lambda parsed-lambda ; parsing
 
 : [let
     scan "|" assert= parse-bindings
-\ ] (parse-lambda)  parsed ; parsing
+    \ ] (parse-lambda)  parsed-lambda ; parsing
 
 : [let*
     scan "|" assert= parse-bindings*
-    >r \ ] parse-until >quotation  parsed r> pop-locals ;
-    parsing
+    \ ] (parse-lambda)  parsed-lambda ; parsing
 
 : [wlet
     scan "|" assert= parse-wbindings
-    \ ] (parse-lambda)  parsed ; parsing
-
-MACRO: with-locals ( form -- quot ) lambda-rewrite ;
+    \ ] (parse-lambda)  parsed-lambda ; parsing
 
 : :: (::) define ; parsing
 
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 0ee7bf515f..c3252de500 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -324,7 +324,7 @@ M: ebnf-sequence build-locals ( code ast -- code )
         ] 2each
         " | " %
         %  
-        " ] with-locals" %     
+        " ]" %     
     ] "" make 
   ] if ;
 
@@ -334,7 +334,7 @@ M: ebnf-var build-locals ( code ast -- )
     name>> % " [ dup ] " %
     " | " %
     %  
-    " ] with-locals" %     
+    " ]" %     
   ] "" make ;
 
 M: object build-locals ( code ast -- )

From d61683ecdbfd34d163d50a78568e698a25f2e12d Mon Sep 17 00:00:00 2001
From: Alex Chapman 
Date: Thu, 8 May 2008 01:08:48 +1000
Subject: [PATCH 45/77] jamshred: collision detection half working (half
 broken)

---
 extra/jamshred/oint/oint-tests.factor     |  4 ++
 extra/jamshred/oint/oint.factor           |  7 +-
 extra/jamshred/player/player.factor       | 11 +---
 extra/jamshred/tunnel/tunnel-tests.factor | 31 ++++++++-
 extra/jamshred/tunnel/tunnel.factor       | 79 ++++++++++-------------
 5 files changed, 71 insertions(+), 61 deletions(-)

diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor
index cf9f22261a..401935fd01 100644
--- a/extra/jamshred/oint/oint-tests.factor
+++ b/extra/jamshred/oint/oint-tests.factor
@@ -2,3 +2,7 @@ USING: jamshred.oint tools.test ;
 IN: jamshred.oint-tests
 
 [ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor
index 9f4eada11e..e2104b6f41 100644
--- a/extra/jamshred/oint/oint.factor
+++ b/extra/jamshred/oint/oint.factor
@@ -9,6 +9,7 @@ IN: jamshred.oint
 ! segment's location and orientation are given by an oint.
 
 TUPLE: oint location forward up left ;
+C:  oint
 
 : rotation-quaternion ( theta axis -- quaternion )
     swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
@@ -48,13 +49,13 @@ TUPLE: oint location forward up left ;
     #! the scalar projection of v1 onto v2
     tuck v. swap norm / ;
 
+: proj-perp ( u v -- w )
+    dupd proj v- ;
+
 : perpendicular-distance ( oint oint -- distance )
     tuck distance-vector swap 2dup left>> scalar-projection abs
     -rot up>> scalar-projection abs + ;
 
-: proj-perp ( v u -- w )
-    dupd proj v- ;
-
 :: reflect ( v n -- v' )
     #! bounce v on a surface with normal n
     v v n v. n n v. / 2 * n n*v v- ;
diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor
index 4aba302a75..979ad136d3 100644
--- a/extra/jamshred/player/player.factor
+++ b/extra/jamshred/player/player.factor
@@ -27,7 +27,6 @@ TUPLE: player < oint name tunnel nearest-segment last-move ;
 
 : player-speed ( player -- speed )
     drop max-speed ;
-    ! dup nearest-segment>> fraction-from-wall sq max-speed * ;
 
 : distance-to-move ( player -- distance )
     [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ]
@@ -35,14 +34,9 @@ TUPLE: player < oint name tunnel nearest-segment last-move ;
 
 DEFER: (move-player)
 
-USE: morse
 : ?bounce ( distance-remaining player -- )
     over 0 > [
-        "e" play-as-morse
-        [ dup nearest-segment>> bounce ]
-        ! [ (move-player) ] ! uncomment when bounce works...
-        [ 2drop ]
-        bi
+        [ dup nearest-segment>> bounce ] [ (move-player) ] bi
     ] [
         2drop
     ] if ;
@@ -50,14 +44,11 @@ USE: morse
 : move-player-distance ( distance-remaining player distance -- distance-remaining player )
     pick min tuck over go-forward [ - ] dip ;
 
-USE: prettyprint
-USE: io.streams.string
 : (move-player) ( distance-remaining player -- )
     over 0 <= [
         2drop
     ] [
         dup dup nearest-segment>> distance-to-collision
-        [ dup . ] with-string-writer jamshred-log
         move-player-distance ?bounce
     ] if ;
 
diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor
index 8031678896..c6755318e6 100644
--- a/extra/jamshred/tunnel/tunnel-tests.factor
+++ b/extra/jamshred/tunnel/tunnel-tests.factor
@@ -3,8 +3,8 @@
 USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
 IN: jamshred.tunnel.tests
 
-[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 }
-        T{ segment T{ oint f { 1 1 1 } } 1 }
+[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
+        T{ segment f { 1 1 1 } f f f 1 }
         T{ oint f { 0 0 0.25 } }
         nearer-segment segment-number ] unit-test
 
@@ -15,3 +15,30 @@ IN: jamshred.tunnel.tests
 [ 3 ] [  T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
 
 [ F{ 0 0 0 } ] [  T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
+
+: test-segment-oint ( -- oint )
+    { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 }  ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+    { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } 
+    initial-segment ;
+
+[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+    { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } 
+    initial-segment ;
+
+[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0 1 0 } ] [ simple-collision-up collision-vector ] unit-test
diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
index 3ac864a7f7..9b0257d372 100755
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors random sequences vectors ;
+USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline
@@ -24,7 +24,7 @@ C:  segment
     dup [ / pi 2 * * ] curry map ;
 
 : segment-number++ ( segment -- )
-    dup segment-number 1+ swap set-segment-number ;
+    [ number>> 1+ ] keep (>>number) ;
 
 : random-color ( -- color )
     { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
@@ -47,8 +47,8 @@ C:  segment
 : default-segment-radius ( -- r ) 1 ;
 
 : initial-segment ( -- segment )
-        F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
-        0 random-color default-segment-radius  ;
+    F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
+    0 random-color default-segment-radius  ;
 
 : random-segments ( n -- segments )
     initial-segment 1vector swap (random-segments) ;
@@ -97,65 +97,52 @@ C:  segment
     [ nearest-segment-forward ] 3keep
     nearest-segment-backward r> nearer-segment ;
 
-: distance-from-centre ( oint segment -- distance )
-    perpendicular-distance ;
+: vector-to-centre ( seg loc -- v )
+    over location>> swap v- swap forward>> proj-perp ;
 
-: distance-from-wall ( oint segment -- distance )
-    tuck distance-from-centre swap segment-radius swap - ;
+: distance-from-centre ( seg loc -- distance )
+    vector-to-centre norm ;
 
-: fraction-from-centre ( oint segment -- fraction )
-    tuck distance-from-centre swap segment-radius / ;
+: wall-normal ( seg oint -- n )
+    location>> vector-to-centre normalize ;
 
-: fraction-from-wall ( oint segment -- fraction )
+: from ( seg loc -- radius d-f-c )
+    dupd location>> distance-from-centre [ radius>> ] dip ;
+
+: distance-from-wall ( seg loc -- distance ) from - ;
+: fraction-from-centre ( seg loc -- fraction ) from / ;
+: fraction-from-wall ( seg loc -- fraction )
     fraction-from-centre 1 swap - ;
 
-: sideways-heading ( oint segment -- v )
-    [ forward>> ] bi@ proj-perp ;
-
-! : facing-nearest-wall? ( oint segment -- ? )
-!     [ [ location>> ] bi@ distance ]
-!     [ sideways-heading ]
-!     [ [ location>> ] bi@ [ v+ ] dip distance ] tri < ;
-
-! : distance-to-collision ( oint segment -- distance )
-! ! TODO: this isn't right. If oint is facing away from the wall then it should return a much bigger distance...
-!     #! distance on the oint's heading to the segment wall
-!     facing-nearest-wall? [
-!         [ sideways-heading norm ]
-!         [ distance-from-wall ] 2bi swap /
-!     ] [
-!     ] if ;
-
-USING: jamshred.log prettyprint io.streams.string ;
-
 : distant 10 ; inline
 
-:: (collision-coefficient) ( -2b sqrt(b^2-2ac) 2a -- c )
-    sqrt(b^2-2ac) complex? [
+:: (collision-coefficient) ( -b sqrt(b^2-4ac) 2a -- c )
+    sqrt(b^2-4ac) complex? [
         distant
     ] [
-        -2b sqrt(b^2-2ac) + 2a /
-        -2b sqrt(b^2-2ac) - 2a / max ! the -ve answer is behind us
+        -b sqrt(b^2-4ac) + 2a /
+        -b sqrt(b^2-4ac) - 2a / max ! the -ve answer is behind us
     ] if ;
 
 :: collision-coefficient ( v w -- c )
     [let* | a [ v dup v. ]
             b [ v w v. 2 * ]
             c [ w dup v. v dup v. - ] |
-        b neg b sq a c * 4 * - sqrt a 2 * (collision-coefficient) ] ;
+        c b a quadratic [ real-part ] bi@ max ] ;
 
+: sideways-heading ( oint segment -- v )
+    [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+    [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: collision-vector ( oint segment -- v )
+        dupd [ sideways-heading ] [ sideways-relative-location ] 2bi
+        collision-coefficient swap forward>> n*v ;
+
+USING: prettyprint jamshred.log io.streams.string ;
 : distance-to-collision ( oint segment -- distance )
-    [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ]
-    [ drop forward>> n*v norm ] 2tri ;
-
-:: (wall-normal) ( seg loc -- n )
-    [let* | back [ loc seg location>> v- ]
-           back-proj [ back seg forward>> proj ]
-           perp-point [ loc back-proj v- ] |
-        perp-point seg location>> v- normalize ] ;
-
-: wall-normal ( segment oint -- n )
-    location>> (wall-normal) ;
+    collision-vector norm [ dup . ] with-string-writer jamshred-log ;
 
 : bounce-forward ( segment oint -- )
     [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;

From a7c0b356a84c58edc83e6703cd944e311710e6a3 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 10:31:19 -0500
Subject: [PATCH 46/77] Fix inference.state tests

---
 core/inference/state/state-tests.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor
index fe1f51a5e7..c63786dc9e 100644
--- a/core/inference/state/state-tests.factor
+++ b/core/inference/state/state-tests.factor
@@ -1,5 +1,5 @@
 IN: inference.state.tests
-USING: tools.test inference.state words ;
+USING: tools.test inference.state words kernel namespaces ;
 
 : computing-dependencies ( quot -- dependencies )
     H{ } clone [ dependencies rot with-variable ] keep ;

From e82144946a19eaf500807fb1fe4ba87246b001d5 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 12:32:38 -0500
Subject: [PATCH 47/77] Fix performance regression: bignum >float got slower
 recently

---
 extra/benchmark/partial-sums/partial-sums.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/extra/benchmark/partial-sums/partial-sums.factor b/extra/benchmark/partial-sums/partial-sums.factor
index b4bb1fa8d2..8eb883241b 100644
--- a/extra/benchmark/partial-sums/partial-sums.factor
+++ b/extra/benchmark/partial-sums/partial-sums.factor
@@ -3,7 +3,8 @@ prettyprint words hints ;
 IN: benchmark.partial-sums
 
 : summing ( n quot -- y )
-    [ + ] compose 0.0 -rot 1 -rot (each-integer) ; inline
+    [ >float ] swap [ + ] 3compose
+    0.0 -rot 1 -rot (each-integer) ; inline
 
 : 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing ;
 

From 51ab72a375f1694ac96766b0de49fa0498dde78d Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Wed, 7 May 2008 14:21:57 -0500
Subject: [PATCH 48/77] fix typo

---
 extra/taxes/taxes-tests.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor
index 32dbd0d625..17d1998f67 100644
--- a/extra/taxes/taxes-tests.factor
+++ b/extra/taxes/taxes-tests.factor
@@ -111,6 +111,6 @@ IN: taxes.tests
     24000 2008 2 f   withholding biweekly dollars/cents
 ] unit-test
 
-[ 754 22 ] [
+[ 754 72 ] [
     78250 2008 2 f   withholding biweekly dollars/cents
 ] unit-test

From 1d60d722fe13d831c55577ceccc6d06c96605d93 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 17:42:41 -0500
Subject: [PATCH 49/77] Improve time word, faster card scan

---
 core/bootstrap/primitives.factor              |  2 +-
 core/inference/known-words/known-words.factor |  2 +-
 extra/benchmark/benchmark.factor              |  2 +-
 extra/optimizer/report/report.factor          |  2 +-
 .../ave-time/ave-time-docs.factor             |  6 +-
 extra/project-euler/ave-time/ave-time.factor  | 13 +--
 extra/reports/optimizer/optimizer.factor      |  2 +-
 extra/tools/test/test.factor                  |  4 +-
 extra/tools/time/time-docs.factor             |  4 +-
 extra/tools/time/time.factor                  | 34 ++++++--
 vm/data_gc.c                                  | 82 ++++++++++++++-----
 vm/data_gc.h                                  |  7 +-
 vm/primitives.c                               |  2 +-
 13 files changed, 107 insertions(+), 55 deletions(-)

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 6149e83893..753464ab80 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -607,7 +607,7 @@ tuple
     { "(exists?)" "io.files.private" }
     { "(directory)" "io.files.private" }
     { "gc" "memory" }
-    { "gc-time" "memory" }
+    { "gc-stats" "memory" }
     { "save-image" "memory" }
     { "save-image-and-exit" "memory" }
     { "datastack" "kernel" }
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index b68c98d25d..a6dd089db1 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -362,7 +362,7 @@ M: object infer-call
 
 \ gc { } { }  set-primitive-effect
 
-\ gc-time { } { integer }  set-primitive-effect
+\ gc-stats { } { array }  set-primitive-effect
 
 \ save-image { string } { }  set-primitive-effect
 
diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor
index a75251331f..c00087fc9f 100755
--- a/extra/benchmark/benchmark.factor
+++ b/extra/benchmark/benchmark.factor
@@ -6,7 +6,7 @@ continuations debugger ;
 IN: benchmark
 
 : run-benchmark ( vocab -- result )
-  [ [ require ] [ [ run ] benchmark nip ] bi ] curry
+  [ [ require ] [ [ run ] benchmark ] bi ] curry
   [ error. f ] recover ;
 
 : run-benchmarks ( -- assoc )
diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor
index 70756e81c2..60b83819d5 100755
--- a/extra/optimizer/report/report.factor
+++ b/extra/optimizer/report/report.factor
@@ -20,7 +20,7 @@ IN: optimizer.report
     [
         dup [
             word-dataflow nip 1 count-optimization-passes
-        ] benchmark nip 2array
+        ] benchmark 2array
     ] { } map>assoc
     [ first ] "Worst number of optimizer passes:" results
     [ second ] "Worst compile times:" results ;
diff --git a/extra/project-euler/ave-time/ave-time-docs.factor b/extra/project-euler/ave-time/ave-time-docs.factor
index cc40ae4bf1..d8ee0846b0 100644
--- a/extra/project-euler/ave-time/ave-time-docs.factor
+++ b/extra/project-euler/ave-time/ave-time-docs.factor
@@ -16,9 +16,7 @@ HELP: ave-time
     "This word can be used to compare performance of the non-optimizing and optimizing compilers."
     $nl
     "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:"
-    { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run / 6 ms GC ave time - 10 trials" }
+    { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] 10 ave-time" "1116 ms run time - 10 trials" }
     "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:"
-    { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run / 13 ms GC ave time - 10 trials" }
+    { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] 10 ave-time" "202 ms run time - 10 trials" }
 } ;
-
-{ benchmark collect-benchmarks gc-time millis time ave-time } related-words
diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor
index b908dbd7b0..c8212b4009 100644
--- a/extra/project-euler/ave-time/ave-time.factor
+++ b/extra/project-euler/ave-time/ave-time.factor
@@ -4,20 +4,13 @@ USING: arrays combinators io kernel math math.functions math.parser
     math.statistics namespaces sequences tools.time ;
 IN: project-euler.ave-time
 
-
-
 : collect-benchmarks ( quot n -- seq )
   [
-    >r >r datastack r> [ benchmark 2array , ] curry tuck
+    >r >r datastack r> [ benchmark , ] curry tuck
     [ with-datastack drop ] 2curry r> swap times call
   ] { } make ;
 
 : ave-time ( quot n -- )
-    [ collect-benchmarks ] keep swap ave-benchmarks [
-        dup second # " ms run / " % first # " ms GC ave time - " % # " trials" %
+    [ collect-benchmarks ] keep swap mean round [
+        # " ms run time - " % # " trials" %
     ] "" make print flush ; inline
diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor
index 06e76d0a99..51eae24333 100755
--- a/extra/reports/optimizer/optimizer.factor
+++ b/extra/reports/optimizer/optimizer.factor
@@ -20,7 +20,7 @@ IN: report.optimizer
     [
         dup [
             word-dataflow nip 1 count-optimization-passes
-        ] benchmark nip 2array
+        ] benchmark 2array
     ] { } map>assoc ;
 
 : optimizer-measurements. ( alist -- )
diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor
index 854ef7af0e..8ef80c6add 100755
--- a/extra/tools/test/test.factor
+++ b/extra/tools/test/test.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces arrays prettyprint sequences kernel
 vectors quotations words parser assocs combinators
-continuations debugger io io.files vocabs tools.time
+continuations debugger io io.files vocabs
 vocabs.loader source-files compiler.units inspector
 inference effects tools.vocabs ;
 IN: tools.test
@@ -19,7 +19,7 @@ SYMBOL: this-test
 
 : (unit-test) ( what quot -- )
     swap dup . flush this-test set
-    [ time ] curry failures get [
+    failures get [
         [ this-test get failure ] recover
     ] [
         call
diff --git a/extra/tools/time/time-docs.factor b/extra/tools/time/time-docs.factor
index 36ab3c01d4..46d356bef5 100644
--- a/extra/tools/time/time-docs.factor
+++ b/extra/tools/time/time-docs.factor
@@ -6,9 +6,9 @@ ARTICLE: "timing" "Timing code"
 { $subsection time }
 "A lower-level word puts timings on the stack, intead of printing:"
 { $subsection benchmark }
-"You can also read the system clock and total garbage collection time directly:"
+"You can also read the system clock and garbage collection statistics directly:"
 { $subsection millis } 
-{ $subsection gc-time }
+{ $subsection gc-stats }
 { $see-also "profiling" } ;
 
 ABOUT: "timing"
diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor
index 4862cc2b27..3ddea1b74d 100644
--- a/extra/tools/time/time.factor
+++ b/extra/tools/time/time.factor
@@ -1,14 +1,32 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math memory io namespaces system
-math.parser ;
+USING: kernel math math.vectors memory io io.styles prettyprint
+namespaces system sequences assocs ;
 IN: tools.time
 
 : benchmark ( quot -- gctime runtime )
-    millis >r gc-time >r call gc-time r> - millis r> - ;
-    inline
+    millis >r call millis r> - ; inline
+
+: stats. ( data -- )
+    {
+        "Run time"
+        "GC time"
+        "Nursery collections"
+        "Aging collections"
+        "Tenured collections"
+        "Cards checked"
+        "Cards scanned"
+        "Code literal collections"
+    } swap zip [ nip 0 > ] assoc-filter
+    standard-table-style [
+        [
+            [
+                [ [ write ] with-cell ] [ pprint-cell ] bi*
+            ] with-row
+        ] assoc-each
+    ] tabular-output ;
+
+: stats gc-stats millis prefix ;
 
 : time ( quot -- )
-    benchmark
-    [ # " ms run / " % # " ms GC time" % ] "" make print flush ;
-    inline
+    stats >r call stats r> v- stats. ; inline
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 5aa47c8c6c..da112edb31 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -144,7 +144,10 @@ void init_data_heap(CELL gens,
 	gc_time = 0;
 	aging_collections = 0;
 	nursery_collections = 0;
+	tenured_collections = 0;
+	cards_checked = 0;
 	cards_scanned = 0;
+	code_heap_scans = 0;
 	secure_gc = secure_gc_;
 }
 
@@ -283,7 +286,7 @@ DEFINE_PRIMITIVE(end_scan)
 }
 
 /* Scan all the objects in the card */
-INLINE void collect_card(F_CARD *ptr, CELL gen, CELL here)
+void collect_card(F_CARD *ptr, CELL gen, CELL here)
 {
 	F_CARD c = *ptr;
 	CELL offset = (c & CARD_BASE_MASK);
@@ -305,14 +308,49 @@ INLINE void collect_card(F_CARD *ptr, CELL gen, CELL here)
 	cards_scanned++;
 }
 
-/* Copy all newspace objects referenced from marked cards to the destination */
-INLINE void collect_gen_cards(CELL gen)
+void collect_card_deck(CELL gen,
+	F_CARD *first_card, F_CARD *last_card,
+	F_CARD mask, F_CARD unmask)
 {
-	F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[gen].start);
 	CELL here = data_heap->generations[gen].here;
-	F_CARD *last_card = ADDR_TO_CARD(here - 1);
 
-	CELL mask, unmask;
+	long long cards_checked_ = 0;
+
+	u32 *quad_ptr;
+	u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
+
+	u32 *last_card_aligned = (u32 *)(((CELL)last_card + 3) & ~3);
+
+	for(quad_ptr = (u32 *)first_card; quad_ptr <= (u32 *)last_card_aligned; quad_ptr++)
+	{
+		cards_checked_ += 4;
+
+		if(*quad_ptr & quad_mask)
+		{
+			F_CARD *ptr = (F_CARD *)quad_ptr;
+
+			int card;
+			for(card = 0; card < 4; card++)
+			{
+				if(ptr[card] & mask)
+				{
+					collect_card(&ptr[card],gen,here);
+					ptr[card] &= ~unmask;
+				}
+			}
+		}
+	}
+
+	cards_checked += cards_checked_;
+}
+
+/* Copy all newspace objects referenced from marked cards to the destination */
+void collect_gen_cards(CELL gen)
+{
+	F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[gen].start);
+	F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[gen].here - 1);
+
+	F_CARD mask, unmask;
 
 	/* if we are collecting the nursery, we care about old->nursery pointers
 	but not old->aging pointers */
@@ -360,14 +398,7 @@ INLINE void collect_gen_cards(CELL gen)
 		return;
 	}
 
-	for(; ptr <= last_card; ptr++)
-	{
-		if(*ptr & mask)
-		{
-			collect_card(ptr,gen,here);
-			*ptr &= ~unmask;
-		}
-	}
+	collect_card_deck(gen,first_card,last_card,mask,unmask);
 }
 
 /* Scan cards in all generations older than the one being collected, copying
@@ -657,17 +688,13 @@ void end_gc(void)
 
 		if(collecting_gen == TENURED)
 		{
+			tenured_collections++;
 			GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
-			aging_collections = 0;
-			cards_scanned = 0;
 		}
 		else if(HAVE_AGING_P && collecting_gen == AGING)
 		{
 			aging_collections++;
-
 			GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
-			nursery_collections = 0;
-			cards_scanned = 0;
 		}
 	}
 	else
@@ -758,7 +785,10 @@ void garbage_collection(CELL gen,
 			literals from any code block which gets marked as live.
 			if we are not doing code GC, just consider all literals
 			as roots. */
+			code_heap_scans++;
+
 			collect_literals();
+
 			if(collecting_accumulation_gen_p())
 				last_code_heap_scan = collecting_gen;
 			else
@@ -794,9 +824,19 @@ DEFINE_PRIMITIVE(gc)
 }
 
 /* Push total time spent on GC */
-DEFINE_PRIMITIVE(gc_time)
+DEFINE_PRIMITIVE(gc_stats)
 {
-	box_unsigned_8(gc_time);
+	CELL array = tag_object(allot_array(ARRAY_TYPE,7,F));
+	REGISTER_ROOT(array);
+	set_array_nth(untag_object(array),0,tag_bignum(long_long_to_bignum(gc_time)));
+	set_array_nth(untag_object(array),1,allot_cell(nursery_collections));
+	set_array_nth(untag_object(array),2,allot_cell(aging_collections));
+	set_array_nth(untag_object(array),3,allot_cell(tenured_collections));
+	set_array_nth(untag_object(array),4,tag_bignum(long_long_to_bignum(cards_scanned)));
+	set_array_nth(untag_object(array),5,tag_bignum(long_long_to_bignum(cards_checked)));
+	set_array_nth(untag_object(array),6,allot_cell(code_heap_scans));
+	UNREGISTER_ROOT(array);
+	dpush(array);
 }
 
 DEFINE_PRIMITIVE(become)
diff --git a/vm/data_gc.h b/vm/data_gc.h
index be9ed159b7..1b42eafb36 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -145,7 +145,10 @@ void init_data_heap(CELL gens,
 s64 gc_time;
 CELL nursery_collections;
 CELL aging_collections;
-CELL cards_scanned;
+CELL tenured_collections;
+s64 cards_checked;
+s64 cards_scanned;
+CELL code_heap_scans;
 
 /* only meaningful during a GC */
 bool performing_gc;
@@ -364,7 +367,7 @@ INLINE void* allot_object(CELL type, CELL a)
 CELL collect_next(CELL scan);
 
 DECLARE_PRIMITIVE(gc);
-DECLARE_PRIMITIVE(gc_time);
+DECLARE_PRIMITIVE(gc_stats);
 DECLARE_PRIMITIVE(become);
 
 CELL find_all_words(void);
diff --git a/vm/primitives.c b/vm/primitives.c
index da04870ecd..cc8cf61013 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -91,7 +91,7 @@ void *primitives[] = {
 	primitive_existsp,
 	primitive_read_dir,
 	primitive_gc,
-	primitive_gc_time,
+	primitive_gc_stats,
 	primitive_save_image,
 	primitive_save_image_and_exit,
 	primitive_datastack,

From ea2107e4637a9037aab3a02b307c378725dfdfc6 Mon Sep 17 00:00:00 2001
From: Alex Chapman 
Date: Thu, 8 May 2008 12:17:05 +1000
Subject: [PATCH 50/77] jamshred: collision detection better, bounce still
 buggy

---
 extra/jamshred/tunnel/tunnel.factor | 23 ++++++-----------------
 1 file changed, 6 insertions(+), 17 deletions(-)

diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
index 9b0257d372..4369944e9e 100755
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -114,21 +114,11 @@ C:  segment
 : fraction-from-wall ( seg loc -- fraction )
     fraction-from-centre 1 swap - ;
 
-: distant 10 ; inline
-
-:: (collision-coefficient) ( -b sqrt(b^2-4ac) 2a -- c )
-    sqrt(b^2-4ac) complex? [
-        distant
-    ] [
-        -b sqrt(b^2-4ac) + 2a /
-        -b sqrt(b^2-4ac) - 2a / max ! the -ve answer is behind us
-    ] if ;
-
-:: collision-coefficient ( v w -- c )
+:: collision-coefficient ( v w r -- c )
     [let* | a [ v dup v. ]
             b [ v w v. 2 * ]
-            c [ w dup v. v dup v. - ] |
-        c b a quadratic [ real-part ] bi@ max ] ;
+            c [ w dup v. r sq - ] |
+        c b a quadratic max ] ;
 
 : sideways-heading ( oint segment -- v )
     [ forward>> ] bi@ proj-perp ;
@@ -137,12 +127,11 @@ C:  segment
     [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
 
 : collision-vector ( oint segment -- v )
-        dupd [ sideways-heading ] [ sideways-relative-location ] 2bi
-        collision-coefficient swap forward>> n*v ;
+    [ sideways-heading ] [ sideways-relative-location ] [ radius>> ] 2tri
+    swap [ collision-coefficient ] dip forward>> n*v ;
 
-USING: prettyprint jamshred.log io.streams.string ;
 : distance-to-collision ( oint segment -- distance )
-    collision-vector norm [ dup . ] with-string-writer jamshred-log ;
+    collision-vector norm ;
 
 : bounce-forward ( segment oint -- )
     [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;

From 3ada291e8a1f2ff4902dcc095851a847999bbad6 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 21:37:12 -0500
Subject: [PATCH 51/77] Fix binary-trees benchmark

---
 extra/benchmark/binary-trees/binary-trees.factor | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor
index 6e63877989..bd3d460961 100644
--- a/extra/benchmark/binary-trees/binary-trees.factor
+++ b/extra/benchmark/binary-trees/binary-trees.factor
@@ -53,3 +53,5 @@ M: f item-check drop 0 ;
 
 : binary-trees-main ( -- )
     16 binary-trees ;
+
+MAIN: binary-trees-main

From 739a75f2bb7956fe7ce0b70bc7c2332c75661af5 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 21:39:20 -0500
Subject: [PATCH 52/77] More efficient minor GC

---
 core/compiler/constants/constants.factor      |   1 +
 core/cpu/x86/intrinsics/intrinsics.factor     |   6 +
 core/inference/known-words/known-words.factor |   2 +-
 core/memory/memory-docs.factor                |   4 -
 vm/data_gc.c                                  | 107 ++++++++++++------
 vm/data_gc.h                                  |  40 +++++--
 6 files changed, 108 insertions(+), 52 deletions(-)

diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor
index 11f64c9373..9594cf7b23 100755
--- a/core/compiler/constants/constants.factor
+++ b/core/compiler/constants/constants.factor
@@ -5,6 +5,7 @@ IN: compiler.constants
 
 ! These constants must match vm/memory.h
 : card-bits 6 ;
+: deck-bits 12 ;
 : card-mark HEX: 40 HEX: 80 bitor ;
 
 ! These constants must match vm/layouts.h
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index c48f33b765..a8bcf00d15 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -63,9 +63,15 @@ IN: cpu.x86.intrinsics
 : generate-write-barrier ( -- )
     #! Mark the card pointed to by vreg.
     "val" get operand-immediate? "obj" get fresh-object? or [
+        ! Mark the card
         "obj" operand card-bits SHR
         "cards_offset" f temp-reg v>operand %alien-global
         temp-reg v>operand "obj" operand [+] card-mark OR
+
+        ! Mark the card deck
+        "obj" operand deck-bits card-bits - SHR
+        "decks_offset" f temp-reg v>operand %alien-global
+        temp-reg v>operand "obj" operand [+] card-mark OR
     ] unless ;
 
 \ set-slot {
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index a6dd089db1..ff5fc478ca 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -372,7 +372,7 @@ M: object infer-call
 t over set-effect-terminated?
 set-primitive-effect
 
-\ data-room { } { integer array }  set-primitive-effect
+\ data-room { } { integer integer array }  set-primitive-effect
 \ data-room make-flushable
 
 \ code-room { } { integer integer integer integer }  set-primitive-effect
diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor
index 75876a3c8f..38f39ec588 100755
--- a/core/memory/memory-docs.factor
+++ b/core/memory/memory-docs.factor
@@ -40,10 +40,6 @@ HELP: instances
 HELP: gc ( -- )
 { $description "Performs a full garbage collection." } ;
 
-HELP: gc-time ( -- n )
-{ $values { "n" "a timestamp in milliseconds" } }
-{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
-
 HELP: data-room ( -- cards generations )
 { $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
 { $description "Queries the runtime for memory usage information." } ;
diff --git a/vm/data_gc.c b/vm/data_gc.c
index da112edb31..a0440b575f 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -21,10 +21,11 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start)
 	return z->end;
 }
 
-void init_cards_offset(void)
+void init_card_decks(void)
 {
-	cards_offset = (CELL)data_heap->cards
-		- (data_heap->segment->start >> CARD_BITS);
+	CELL start = data_heap->segment->start & ~(DECK_SIZE - 1);
+	cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
+	decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
 }
 
 F_DATA_HEAP *alloc_data_heap(CELL gens,
@@ -62,10 +63,14 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
 	data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
 	data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
 
-	CELL cards_size = total_size / CARD_SIZE;
+	CELL cards_size = (total_size + DECK_SIZE) / CARD_SIZE;
 	data_heap->cards = safe_malloc(cards_size);
 	data_heap->cards_end = data_heap->cards + cards_size;
 
+	CELL decks_size = (total_size + DECK_SIZE) / DECK_SIZE;
+	data_heap->decks = safe_malloc(decks_size);
+	data_heap->decks_end = data_heap->decks + decks_size;
+
 	CELL alloter = data_heap->segment->start;
 
 	alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
@@ -105,6 +110,7 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap)
 	free(data_heap->generations);
 	free(data_heap->semispaces);
 	free(data_heap->cards);
+	free(data_heap->decks);
 	free(data_heap);
 }
 
@@ -113,17 +119,28 @@ cleared when a generation has been cleared */
 void clear_cards(CELL from, CELL to)
 {
 	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
 	F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
-	F_CARD *ptr = ADDR_TO_CARD(data_heap->generations[to].start);
-	for(; ptr < last_card; ptr++)
-		clear_card(ptr);
+	F_CARD *ptr;
+	for(ptr = first_card; ptr < last_card; ptr++)
+		*ptr = CARD_BASE_MASK; /* invalid value */
+}
+
+void clear_decks(CELL from, CELL to)
+{
+	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start);
+	F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end);
+	F_CARD *ptr;
+	for(ptr = first_deck; ptr < last_deck; ptr++)
+		*ptr = 0;
 }
 
 void set_data_heap(F_DATA_HEAP *data_heap_)
 {
 	data_heap = data_heap_;
 	nursery = data_heap->generations[NURSERY];
-	init_cards_offset();
+	init_card_decks();
 	clear_cards(NURSERY,TENURED);
 }
 
@@ -141,13 +158,16 @@ void init_data_heap(CELL gens,
 	extra_roots_region = alloc_segment(getpagesize());
 	extra_roots = extra_roots_region->start - CELLS;
 
-	gc_time = 0;
-	aging_collections = 0;
+	nursery_gc_time = 0;
 	nursery_collections = 0;
+	aging_gc_time = 0;
+	aging_collections = 0;
+	tenured_gc_time = 0;
 	tenured_collections = 0;
-	cards_checked = 0;
 	cards_scanned = 0;
+	decks_scanned = 0;
 	code_heap_scans = 0;
+	bytes_copied = 0;
 	secure_gc = secure_gc_;
 }
 
@@ -231,6 +251,7 @@ DEFINE_PRIMITIVE(data_room)
 	int gen;
 
 	dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
+	dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
 
 	for(gen = 0; gen < data_heap->gen_count; gen++)
 	{
@@ -293,9 +314,9 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here)
 
 	if(offset == CARD_BASE_MASK)
 	{
-		if(c == 0xff)
+		/* if(c == 0xff)
 			critical_error("bad card",(CELL)ptr);
-		else
+		else */
 			return;
 	}
 
@@ -308,23 +329,18 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here)
 	cards_scanned++;
 }
 
-void collect_card_deck(CELL gen,
-	F_CARD *first_card, F_CARD *last_card,
-	F_CARD mask, F_CARD unmask)
+void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
 {
-	CELL here = data_heap->generations[gen].here;
+	F_CARD *first_card = DECK_TO_CARD(deck);
+	F_CARD *last_card = DECK_TO_CARD(deck + 1);
 
-	long long cards_checked_ = 0;
+	CELL here = data_heap->generations[gen].here;
 
 	u32 *quad_ptr;
 	u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
 
-	u32 *last_card_aligned = (u32 *)(((CELL)last_card + 3) & ~3);
-
-	for(quad_ptr = (u32 *)first_card; quad_ptr <= (u32 *)last_card_aligned; quad_ptr++)
+	for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
 	{
-		cards_checked_ += 4;
-
 		if(*quad_ptr & quad_mask)
 		{
 			F_CARD *ptr = (F_CARD *)quad_ptr;
@@ -341,14 +357,14 @@ void collect_card_deck(CELL gen,
 		}
 	}
 
-	cards_checked += cards_checked_;
+	decks_scanned++;
 }
 
 /* Copy all newspace objects referenced from marked cards to the destination */
 void collect_gen_cards(CELL gen)
 {
-	F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[gen].start);
-	F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[gen].here - 1);
+	F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
+	F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
 
 	F_CARD mask, unmask;
 
@@ -398,7 +414,16 @@ void collect_gen_cards(CELL gen)
 		return;
 	}
 
-	collect_card_deck(gen,first_card,last_card,mask,unmask);
+	F_DECK *ptr;
+
+	for(ptr = first_deck; ptr < last_deck; ptr++)
+	{
+		if(*ptr & mask)
+		{
+			collect_card_deck(ptr,gen,mask,unmask);
+			*ptr &= ~unmask;
+		}
+	}
 }
 
 /* Scan cards in all generations older than the one being collected, copying
@@ -485,6 +510,7 @@ INLINE void *copy_untagged_object(void *pointer, CELL size)
 		longjmp(gc_jmp,1);
 	allot_barrier(newspace->here);
 	newpointer = allot_zone(newspace,size);
+	bytes_copied += size;
 	memcpy(newpointer,pointer,size);
 	return newpointer;
 }
@@ -615,6 +641,7 @@ CELL collect_next(CELL scan)
 INLINE void reset_generation(CELL i)
 {
 	F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
+	bytes_collected += (z->here - z->start);
 	z->here = z->start;
 	if(secure_gc)
 		memset((void*)z->start,69,z->size);
@@ -669,7 +696,7 @@ void begin_gc(CELL requested_bytes)
 #endif
 }
 
-void end_gc(void)
+void end_gc(CELL gc_elapsed)
 {
 	if(growing_data_heap)
 	{
@@ -689,11 +716,13 @@ void end_gc(void)
 		if(collecting_gen == TENURED)
 		{
 			tenured_collections++;
+			tenured_gc_time += gc_elapsed;
 			GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
 		}
 		else if(HAVE_AGING_P && collecting_gen == AGING)
 		{
 			aging_collections++;
+			aging_gc_time += gc_elapsed;
 			GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
 		}
 	}
@@ -704,6 +733,7 @@ void end_gc(void)
 		reset_generations(NURSERY,collecting_gen);
 
 		nursery_collections++;
+		nursery_gc_time += gc_elapsed;
 	}
 
 	if(collecting_gen == TENURED)
@@ -802,9 +832,8 @@ void garbage_collection(CELL gen,
 	CELL gc_elapsed = (current_millis() - start);
 
 	GC_PRINT(END_GC,gc_elapsed);
-	end_gc();
+	end_gc(gc_elapsed);
 
-	gc_time += gc_elapsed;
 	performing_gc = false;
 }
 
@@ -826,15 +855,19 @@ DEFINE_PRIMITIVE(gc)
 /* Push total time spent on GC */
 DEFINE_PRIMITIVE(gc_stats)
 {
-	CELL array = tag_object(allot_array(ARRAY_TYPE,7,F));
+	CELL array = tag_object(allot_array(ARRAY_TYPE,11,F));
 	REGISTER_ROOT(array);
-	set_array_nth(untag_object(array),0,tag_bignum(long_long_to_bignum(gc_time)));
+	set_array_nth(untag_object(array),0,allot_cell(nursery_gc_time));
 	set_array_nth(untag_object(array),1,allot_cell(nursery_collections));
-	set_array_nth(untag_object(array),2,allot_cell(aging_collections));
-	set_array_nth(untag_object(array),3,allot_cell(tenured_collections));
-	set_array_nth(untag_object(array),4,tag_bignum(long_long_to_bignum(cards_scanned)));
-	set_array_nth(untag_object(array),5,tag_bignum(long_long_to_bignum(cards_checked)));
-	set_array_nth(untag_object(array),6,allot_cell(code_heap_scans));
+	set_array_nth(untag_object(array),2,allot_cell(aging_gc_time));
+	set_array_nth(untag_object(array),3,allot_cell(aging_collections));
+	set_array_nth(untag_object(array),4,allot_cell(tenured_gc_time));
+	set_array_nth(untag_object(array),5,allot_cell(tenured_collections));
+	set_array_nth(untag_object(array),6,tag_bignum(long_long_to_bignum(cards_scanned)));
+	set_array_nth(untag_object(array),7,tag_bignum(long_long_to_bignum(decks_scanned)));
+	set_array_nth(untag_object(array),8,allot_cell(code_heap_scans));
+	set_array_nth(untag_object(array),9,tag_bignum(long_long_to_bignum(bytes_copied)));
+	set_array_nth(untag_object(array),10,tag_bignum(long_long_to_bignum(bytes_collected)));
 	UNREGISTER_ROOT(array);
 	dpush(array);
 }
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 1b42eafb36..149c55d97f 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -46,6 +46,9 @@ typedef struct {
 
 	CELL *cards;
 	CELL *cards_end;
+
+	CELL *decks;
+	CELL *decks_end;
 } F_DATA_HEAP;
 
 F_DATA_HEAP *data_heap;
@@ -71,17 +74,27 @@ offset within the card */
 #define CARD_BITS 6
 #define ADDR_CARD_MASK (CARD_SIZE-1)
 
-INLINE void clear_card(F_CARD *c)
-{
-	*c = CARD_BASE_MASK; /* invalid value */
-}
-
 DLLEXPORT CELL cards_offset;
-void init_cards_offset(void);
 
 #define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
 #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> DECK_BITS) + decks_offset)
+#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset)<
Date: Wed, 7 May 2008 21:54:41 -0500
Subject: [PATCH 53/77] Fixes

---
 extra/tools/memory/memory.factor  |  1 +
 extra/tools/time/time-docs.factor | 12 ++----------
 extra/tools/time/time.factor      | 22 +++++++++++++---------
 3 files changed, 16 insertions(+), 19 deletions(-)

diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor
index b8fdcab280..9628b218e9 100644
--- a/extra/tools/memory/memory.factor
+++ b/extra/tools/memory/memory.factor
@@ -36,6 +36,7 @@ IN: tools.memory
         [ first2 ] [ number>string "Generation " prepend ] bi*
         write-total/used/free
     ] 2each
+    "Decks" write-total
     "Cards" write-total ;
 
 : write-labelled-size ( n string -- )
diff --git a/extra/tools/time/time-docs.factor b/extra/tools/time/time-docs.factor
index 46d356bef5..c0afa920c4 100644
--- a/extra/tools/time/time-docs.factor
+++ b/extra/tools/time/time-docs.factor
@@ -20,14 +20,6 @@ HELP: benchmark
 
 HELP: time
 { $values { "quot" "a quotation" } }
-{ $description "Runs a quotation and then prints the total run time and time spent in the garbage collector." }
-{ $examples
-    "This word can be used to compare performance of the non-optimizing and optimizing compilers."
-    $nl
-    "First, we time a quotation directly; quotations are compiled by the non-optimizing quotation compiler:"
-    { $unchecked-example "[ 1000000 0 [ + ] reduce drop ] time" "1116 ms run / 6 ms GC time" }
-    "Now we define a word and compile it with the optimizing word compiler. This results is faster execution:"
-    { $unchecked-example ": foo 1000000 0 [ + ] reduce ;" "\\ foo compile" "[ foo drop ] time" "202 ms run / 13 ms GC time" }
-} ;
+{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ;
 
-{ gc-time benchmark millis time } related-words
+{ benchmark millis time } related-words
diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor
index 3ddea1b74d..bca5e3c573 100644
--- a/extra/tools/time/time.factor
+++ b/extra/tools/time/time.factor
@@ -9,15 +9,19 @@ IN: tools.time
 
 : stats. ( data -- )
     {
-        "Run time"
-        "GC time"
-        "Nursery collections"
-        "Aging collections"
-        "Tenured collections"
-        "Cards checked"
-        "Cards scanned"
-        "Code literal collections"
-    } swap zip [ nip 0 > ] assoc-filter
+        "Run time (ms):"
+        "Nursery GC time (ms):"
+        "Nursery GC #:"
+        "Aging GC time (ms):"
+        "Aging GC #:"
+        "Tenured GC time (ms):"
+        "Tenured GC #:"
+        "Cards scanned:"
+        "Decks scanned:"
+        "Code literal GC #:"
+        "Bytes copied:"
+        "Bytes collected:"
+    } swap zip
     standard-table-style [
         [
             [

From 052962d3b8dd9d5ea37bf515965f56c03421688e Mon Sep 17 00:00:00 2001
From: Alex Chapman 
Date: Thu, 8 May 2008 13:04:44 +1000
Subject: [PATCH 54/77] jamshred is playable! (scroll to acc/decelerate)

---
 extra/jamshred/jamshred.factor      | 13 +++++++++----
 extra/jamshred/player/player.factor | 21 ++++++++++++++-------
 extra/jamshred/tunnel/tunnel.factor |  4 +++-
 3 files changed, 26 insertions(+), 12 deletions(-)

diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor
index bdec1e57e5..44dcdc8659 100755
--- a/extra/jamshred/jamshred.factor
+++ b/extra/jamshred/jamshred.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ;
+USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ;
 IN: jamshred
 
 TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
@@ -8,8 +8,8 @@ TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
 :  ( jamshred -- gadget )
     jamshred-gadget construct-gadget swap >>jamshred ;
 
-: default-width ( -- x ) 640 ;
-: default-height ( -- y ) 480 ;
+: default-width ( -- x ) 800 ;
+: default-height ( -- y ) 600 ;
 
 M: jamshred-gadget pref-dim*
     drop default-width default-height 2array ;
@@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
     ] [
         dup [ jamshred>> jamshred-update ]
         [ relayout-1 ] bi
-        50 sleep jamshred-loop
+        10 sleep jamshred-loop
     ] if ;
 
 M: jamshred-gadget graft* ( gadget -- )
@@ -57,10 +57,15 @@ M: jamshred-gadget ungraft* ( gadget -- )
         ] [ 2drop ] if* 
     ] 2keep >>last-hand-loc drop ;
 
+: handle-mouse-scroll ( jamshred-gadget -- )
+    jamshred>> jamshred-player scroll-direction get
+    second neg swap change-player-speed ;
+
 jamshred-gadget H{
     { T{ key-down f f "r" } [ jamshred-restart ] }
     { T{ key-down f f " " } [ jamshred>> toggle-running ] }
     { T{ motion } [ handle-mouse-motion ] }
+    { T{ mouse-scroll } [ handle-mouse-scroll ] }
 } set-gestures
 
 : jamshred-window ( -- )
diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor
index 979ad136d3..1ff73d51e4 100644
--- a/extra/jamshred/player/player.factor
+++ b/extra/jamshred/player/player.factor
@@ -1,12 +1,17 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences system ;
+USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order math.ranges sequences system ;
 IN: jamshred.player
 
-TUPLE: player < oint name tunnel nearest-segment last-move ;
+TUPLE: player < oint name tunnel nearest-segment last-move speed ;
+
+! speeds are in GL units / second
+: default-speed ( -- speed ) 1.0 ;
+: max-speed ( -- speed ) 10.0 ;
 
 :  ( name -- player )
-    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f f player boa ;
+    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip
+    f f f default-speed player boa ;
 
 : turn-player ( player x-radians y-radians -- )
     >r over r> left-pivot up-pivot ;
@@ -23,13 +28,15 @@ TUPLE: player < oint name tunnel nearest-segment last-move ;
     [ (>>nearest-segment) ] tri ;
 
 : moved ( player -- ) millis swap (>>last-move) ;
-: max-speed ( -- speed ) 1.0 ; ! units/second
 
-: player-speed ( player -- speed )
-    drop max-speed ;
+: speed-range ( -- range )
+    max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+    [ + speed-range clamp-to-range ] change-speed drop ;
 
 : distance-to-move ( player -- distance )
-    [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ]
+    [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
     [ (>>last-move) ] tri ;
 
 DEFER: (move-player)
diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
index 4369944e9e..139cdbfb53 100755
--- a/extra/jamshred/tunnel/tunnel.factor
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -137,7 +137,9 @@ C:  segment
     [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
 
 : bounce-left ( segment oint -- )
-    [ forward>> vneg ] dip [ left>> swap reflect ] [ (>>left) ] bi ;
+    #! must be done after forward
+    [ forward>> vneg ] dip [ left>> swap reflect ]
+    [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
 
 : bounce-up ( segment oint -- )
     #! must be done after forward and left!

From 22a9a8b95e75d6f648a2729bd605545101c85ebd Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Wed, 7 May 2008 23:09:18 -0500
Subject: [PATCH 55/77] More improvements to 'time' word

---
 extra/tools/time/time.factor |  58 +++++++++++------
 vm/data_gc.c                 | 121 +++++++++++++++++++----------------
 vm/data_gc.h                 |  20 +++---
 vm/primitives.c              |   1 +
 4 files changed, 116 insertions(+), 84 deletions(-)

diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor
index bca5e3c573..0a0121c74e 100644
--- a/extra/tools/time/time.factor
+++ b/extra/tools/time/time.factor
@@ -1,36 +1,54 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.vectors memory io io.styles prettyprint
-namespaces system sequences assocs ;
+namespaces system sequences splitting assocs strings ;
 IN: tools.time
 
 : benchmark ( quot -- gctime runtime )
     millis >r call millis r> - ; inline
 
-: stats. ( data -- )
-    {
-        "Run time (ms):"
-        "Nursery GC time (ms):"
-        "Nursery GC #:"
-        "Aging GC time (ms):"
-        "Aging GC #:"
-        "Tenured GC time (ms):"
-        "Tenured GC #:"
-        "Cards scanned:"
-        "Decks scanned:"
-        "Code literal GC #:"
-        "Bytes copied:"
-        "Bytes collected:"
-    } swap zip
+: simple-table. ( values -- )
     standard-table-style [
         [
             [
-                [ [ write ] with-cell ] [ pprint-cell ] bi*
+                [
+                    dup string?
+                    [ [ write ] with-cell ]
+                    [ pprint-cell ]
+                    if
+                ] each
             ] with-row
-        ] assoc-each
+        ] each
     ] tabular-output ;
 
-: stats gc-stats millis prefix ;
+: time. ( data -- )
+    unclip
+    "==== RUNNING TIME" print nl pprint " ms" print nl
+    4 cut*
+    "==== GARBAGE COLLECTION" print nl
+    [
+        6 group
+        {
+            "GC count:"
+            "Cumulative GC time (ms):"
+            "Longest GC pause (ms):"
+            "Average GC pause (ms):"
+            "Objects copied:"
+            "Bytes copied:"
+        } prefix
+        flip
+        { "" "Nursery" "Aging" "Tenured" } prefix
+        simple-table.
+    ]
+    [
+        nl
+        {
+            "Total GC time (ms):"
+            "Cards scanned:"
+            "Decks scanned:"
+            "Code heap literal scans:"
+        } swap zip simple-table.
+    ] bi* ;
 
 : time ( quot -- )
-    stats >r call stats r> v- stats. ; inline
+    gc-reset millis >r call gc-stats millis r> - prefix time. ; inline
diff --git a/vm/data_gc.c b/vm/data_gc.c
index a0440b575f..aed2cef4d1 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -144,6 +144,13 @@ void set_data_heap(F_DATA_HEAP *data_heap_)
 	clear_cards(NURSERY,TENURED);
 }
 
+void gc_reset(void)
+{
+	int i;
+	for(i = 0; i < MAX_GEN_COUNT; i++)
+		memset(&gc_stats[i],0,sizeof(F_GC_STATS));
+}
+
 void init_data_heap(CELL gens,
 	CELL young_size,
 	CELL aging_size,
@@ -158,17 +165,13 @@ void init_data_heap(CELL gens,
 	extra_roots_region = alloc_segment(getpagesize());
 	extra_roots = extra_roots_region->start - CELLS;
 
-	nursery_gc_time = 0;
-	nursery_collections = 0;
-	aging_gc_time = 0;
-	aging_collections = 0;
-	tenured_gc_time = 0;
-	tenured_collections = 0;
+	secure_gc = secure_gc_;
+
+	gc_reset();
+
 	cards_scanned = 0;
 	decks_scanned = 0;
 	code_heap_scans = 0;
-	bytes_copied = 0;
-	secure_gc = secure_gc_;
 }
 
 /* Size of the object pointed to by a tagged pointer */
@@ -312,21 +315,16 @@ void collect_card(F_CARD *ptr, CELL gen, CELL here)
 	F_CARD c = *ptr;
 	CELL offset = (c & CARD_BASE_MASK);
 
-	if(offset == CARD_BASE_MASK)
+	if(offset != CARD_BASE_MASK)
 	{
-		/* if(c == 0xff)
-			critical_error("bad card",(CELL)ptr);
-		else */
-			return;
+		CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
+		CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
+	
+		while(card_scan < card_end && card_scan < here)
+			card_scan = collect_next(card_scan);
+	
+		cards_scanned++;
 	}
-
-	CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
-	CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-
-	while(card_scan < card_end && card_scan < here)
-		card_scan = collect_next(card_scan);
-
-	cards_scanned++;
 }
 
 void collect_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
@@ -510,7 +508,11 @@ INLINE void *copy_untagged_object(void *pointer, CELL size)
 		longjmp(gc_jmp,1);
 	allot_barrier(newspace->here);
 	newpointer = allot_zone(newspace,size);
-	bytes_copied += size;
+
+	F_GC_STATS *s = &gc_stats[collecting_gen];
+	s->object_count++;
+	s->bytes_copied += size;
+
 	memcpy(newpointer,pointer,size);
 	return newpointer;
 }
@@ -641,7 +643,7 @@ CELL collect_next(CELL scan)
 INLINE void reset_generation(CELL i)
 {
 	F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
-	bytes_collected += (z->here - z->start);
+
 	z->here = z->start;
 	if(secure_gc)
 		memset((void*)z->start,69,z->size);
@@ -652,7 +654,9 @@ their allocation pointers and cards reset. */
 void reset_generations(CELL from, CELL to)
 {
 	CELL i;
-	for(i = from; i <= to; i++) reset_generation(i);
+	for(i = from; i <= to; i++)
+		reset_generation(i);
+
 	clear_cards(from,to);
 }
 
@@ -698,6 +702,13 @@ void begin_gc(CELL requested_bytes)
 
 void end_gc(CELL gc_elapsed)
 {
+	F_GC_STATS *s = &gc_stats[collecting_gen];
+
+	s->collections++;
+	s->gc_time += gc_elapsed;
+	if(s->max_gc_time < gc_elapsed)
+		s->max_gc_time = gc_elapsed;
+
 	if(growing_data_heap)
 	{
 		dealloc_data_heap(old_data_heap);
@@ -712,28 +723,12 @@ void end_gc(CELL gc_elapsed)
 		old-school Cheney collector */
 		if(collecting_gen != NURSERY)
 			reset_generations(NURSERY,collecting_gen - 1);
-
-		if(collecting_gen == TENURED)
-		{
-			tenured_collections++;
-			tenured_gc_time += gc_elapsed;
-			GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
-		}
-		else if(HAVE_AGING_P && collecting_gen == AGING)
-		{
-			aging_collections++;
-			aging_gc_time += gc_elapsed;
-			GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
-		}
 	}
 	else
 	{
 		/* all generations up to and including the one
 		collected are now empty */
 		reset_generations(NURSERY,collecting_gen);
-
-		nursery_collections++;
-		nursery_gc_time += gc_elapsed;
 	}
 
 	if(collecting_gen == TENURED)
@@ -852,24 +847,38 @@ DEFINE_PRIMITIVE(gc)
 	gc();
 }
 
-/* Push total time spent on GC */
 DEFINE_PRIMITIVE(gc_stats)
 {
-	CELL array = tag_object(allot_array(ARRAY_TYPE,11,F));
-	REGISTER_ROOT(array);
-	set_array_nth(untag_object(array),0,allot_cell(nursery_gc_time));
-	set_array_nth(untag_object(array),1,allot_cell(nursery_collections));
-	set_array_nth(untag_object(array),2,allot_cell(aging_gc_time));
-	set_array_nth(untag_object(array),3,allot_cell(aging_collections));
-	set_array_nth(untag_object(array),4,allot_cell(tenured_gc_time));
-	set_array_nth(untag_object(array),5,allot_cell(tenured_collections));
-	set_array_nth(untag_object(array),6,tag_bignum(long_long_to_bignum(cards_scanned)));
-	set_array_nth(untag_object(array),7,tag_bignum(long_long_to_bignum(decks_scanned)));
-	set_array_nth(untag_object(array),8,allot_cell(code_heap_scans));
-	set_array_nth(untag_object(array),9,tag_bignum(long_long_to_bignum(bytes_copied)));
-	set_array_nth(untag_object(array),10,tag_bignum(long_long_to_bignum(bytes_collected)));
-	UNREGISTER_ROOT(array);
-	dpush(array);
+	GROWABLE_ARRAY(stats);
+
+	CELL i;
+	CELL total_gc_time = 0;
+
+	for(i = 0; i < MAX_GEN_COUNT; i++)
+	{
+		F_GC_STATS *s = &gc_stats[i];
+		GROWABLE_ADD(stats,allot_cell(s->collections));
+		GROWABLE_ADD(stats,allot_cell(s->gc_time));
+		GROWABLE_ADD(stats,allot_cell(s->max_gc_time));
+		GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
+		GROWABLE_ADD(stats,allot_cell(s->object_count));
+		GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
+
+		total_gc_time += s->gc_time;
+	}
+
+	GROWABLE_ADD(stats,allot_cell(total_gc_time));
+	GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
+	GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
+	GROWABLE_ADD(stats,allot_cell(code_heap_scans));
+
+	GROWABLE_TRIM(stats);
+	dpush(stats);
+}
+
+DEFINE_PRIMITIVE(gc_reset)
+{
+	gc_reset();
 }
 
 DEFINE_PRIMITIVE(become)
diff --git a/vm/data_gc.h b/vm/data_gc.h
index 149c55d97f..c1023b8043 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -138,6 +138,8 @@ void collect_cards(void);
 /* the oldest generation */
 #define TENURED (data_heap->gen_count-1)
 
+#define MAX_GEN_COUNT 3
+
 /* used during garbage collection only */
 F_ZONE *newspace;
 
@@ -158,16 +160,17 @@ void init_data_heap(CELL gens,
 	bool secure_gc_);
 
 /* statistics */
-CELL nursery_gc_time;
-CELL nursery_collections;
-CELL aging_gc_time;
-CELL aging_collections;
-CELL tenured_gc_time;
-CELL tenured_collections;
+typedef struct {
+	CELL collections;
+	CELL gc_time;
+	CELL max_gc_time;
+	CELL object_count;
+	u64 bytes_copied;
+} F_GC_STATS;
+
+F_GC_STATS gc_stats[MAX_GEN_COUNT];
 u64 cards_scanned;
 u64 decks_scanned;
-u64 bytes_copied;
-u64 bytes_collected;
 CELL code_heap_scans;
 
 /* only meaningful during a GC */
@@ -388,6 +391,7 @@ CELL collect_next(CELL scan);
 
 DECLARE_PRIMITIVE(gc);
 DECLARE_PRIMITIVE(gc_stats);
+DECLARE_PRIMITIVE(gc_reset);
 DECLARE_PRIMITIVE(become);
 
 CELL find_all_words(void);
diff --git a/vm/primitives.c b/vm/primitives.c
index cc8cf61013..133ca38567 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -186,4 +186,5 @@ void *primitives[] = {
 	primitive_resize_float_array,
 	primitive_dll_validp,
 	primitive_unimplemented,
+	primitive_gc_reset,
 };

From 28d7fc37b87e57d5c7314a2fd2f9af8326fed8c0 Mon Sep 17 00:00:00 2001
From: Alex Chapman 
Date: Thu, 8 May 2008 17:41:49 +1000
Subject: [PATCH 56/77] jamshred: attempts at deployment, bangs on hitting the
 wall

---
 extra/jamshred/deploy.factor        |  12 ++++++++++++
 extra/jamshred/game/game.factor     |   8 ++++----
 extra/jamshred/jamshred.factor      |  19 +++++++++++++++++--
 extra/jamshred/player/player.factor |  13 +++++++------
 extra/jamshred/sound/bang.wav       | Bin 0 -> 20460 bytes
 extra/jamshred/sound/sound.factor   |  13 +++++++++++++
 6 files changed, 53 insertions(+), 12 deletions(-)
 create mode 100644 extra/jamshred/deploy.factor
 create mode 100644 extra/jamshred/sound/bang.wav
 create mode 100644 extra/jamshred/sound/sound.factor

diff --git a/extra/jamshred/deploy.factor b/extra/jamshred/deploy.factor
new file mode 100644
index 0000000000..9a18cf1f9b
--- /dev/null
+++ b/extra/jamshred/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 "Jamshred" }
+}
diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor
index e187d26a17..dcb82d1de0 100644
--- a/extra/jamshred/game/game.factor
+++ b/extra/jamshred/game/game.factor
@@ -1,13 +1,13 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ;
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ;
 IN: jamshred.game
 
-TUPLE: jamshred tunnel players running quit ;
+TUPLE: jamshred sounds tunnel players running quit ;
 
 :  ( -- jamshred )
-     "Player 1"  2dup swap play-in-tunnel 1array f f
-    jamshred boa ;
+      "Player 1" pick 
+    2dup swap play-in-tunnel 1array f f jamshred boa ;
 
 : jamshred-player ( jamshred -- player )
     ! TODO: support more than one player
diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor
index 44dcdc8659..6b305696e5 100755
--- a/extra/jamshred/jamshred.factor
+++ b/extra/jamshred/jamshred.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.gadgets ui.gestures ui.render math.vectors ;
+USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ;
 IN: jamshred
 
 TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
@@ -26,10 +26,20 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
         10 sleep jamshred-loop
     ] if ;
 
+: fullscreen ( gadget -- )
+    find-world t swap set-fullscreen* ;
+
+: no-fullscreen ( gadget -- )
+    find-world f swap set-fullscreen* ;
+
+: toggle-fullscreen ( world -- )
+    [ fullscreen? not ] keep set-fullscreen* ;
+
 M: jamshred-gadget graft* ( gadget -- )
     [ jamshred-loop ] in-thread drop ;
+
 M: jamshred-gadget ungraft* ( gadget -- )
-    jamshred>> t >>quit drop ;
+    jamshred>> t swap (>>quit) ;
 
 : jamshred-restart ( jamshred-gadget -- )
      >>jamshred drop ;
@@ -61,9 +71,14 @@ M: jamshred-gadget ungraft* ( gadget -- )
     jamshred>> jamshred-player scroll-direction get
     second neg swap change-player-speed ;
 
+: quit ( gadget -- )
+    [ no-fullscreen ] [ close-window ] bi ;
+
 jamshred-gadget H{
     { T{ key-down f f "r" } [ jamshred-restart ] }
     { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+    { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+    { T{ key-down f f "q" } [ quit ] }
     { T{ motion } [ handle-mouse-motion ] }
     { T{ mouse-scroll } [ handle-mouse-scroll ] }
 } set-gestures
diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor
index 1ff73d51e4..bea4ab4836 100644
--- a/extra/jamshred/player/player.factor
+++ b/extra/jamshred/player/player.factor
@@ -1,16 +1,16 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order math.ranges sequences system ;
+USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
 IN: jamshred.player
 
-TUPLE: player < oint name tunnel nearest-segment last-move speed ;
+TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
 
 ! speeds are in GL units / second
 : default-speed ( -- speed ) 1.0 ;
-: max-speed ( -- speed ) 10.0 ;
+: max-speed ( -- speed ) 30.0 ;
 
-:  ( name -- player )
-    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip
+:  ( name sounds -- player )
+    [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
     f f f default-speed player boa ;
 
 : turn-player ( player x-radians y-radians -- )
@@ -43,7 +43,8 @@ DEFER: (move-player)
 
 : ?bounce ( distance-remaining player -- )
     over 0 > [
-        [ dup nearest-segment>> bounce ] [ (move-player) ] bi
+        [ dup nearest-segment>> bounce ] [ sounds>> bang ]
+        [ (move-player) ] tri
     ] [
         2drop
     ] if ;
diff --git a/extra/jamshred/sound/bang.wav b/extra/jamshred/sound/bang.wav
new file mode 100644
index 0000000000000000000000000000000000000000..b15af141eca5d69222fe90ae594afe407ae971a5
GIT binary patch
literal 20460
zcmXB64J>r~z9zW7*Q!$Lt=DUNYuB+I$8qawS8MHRaYY*~#<i(Yz;_v@m?f=;Nzx5>B2!bH-NU0@=k`02O2piGzAA0`75%#$-
zN{NtBLs+rRL2$$&5l2)IEkr7|WD@s=&v-B{jU^(3s3hi%RbvMK7ZYxygeW6)qn^ko
z=7?KjljtQjh&5uB$RiqvK|&`Mi8CS_`;-zVII?UU8B@lEv1{xbE<7iVL8ISjH~I_*
zv0|hVeK_)>VK!2Yd*f2yFdlK9(Qo@P#=KEx6d4`ZQfq7&bH=nWV4N6xxQ<~Q^&HO&
zqs8zWl}1R9C%O#I$TU>F*9hwM21VTA8+L;sE{!9-$Vep2#0~ztB^Z3Ni2qbWH=d0{
zT-k{cz`0g%?jHQ@F_w%q!(nV1IYz0mW4MhPoN30e7y|B%Alh-4b4EOIYuGUY?{`v<
z`?VA4L@Tyu5F^C0F-SZa2}A->fU`x6aol48k&DsK$Myh@)<9fgd`EERkTHv^SixNc
zjVz;*NFgj3xgH{iD8Y!@Fhh3i8^UL+*pDJoamRTCg=@UWCvM}$h$9A#1|tc_PR6&V
zhyna9BHhFiQHPmXC6aIreK?aJJNF;gv3f_MlnV=-|*{;7|kBs)eVjo!brB`nx=5>pplFt9^h)?iGCsu_b^5*
z5FB|<6p%KmfLteB#3O929_Jq<9taD$3+tOFycmfFVge(%Pc#$fMlCT7TlN}tMzzsT
zG!Z4nG2tXcV+ThK84=@wu#ps*j_)+X;_q;*L?VPe4u~53pGq9UGu#-l8T{8p%;J1K
z*c!oc&oDcMF;gz%m2&u|Jv1(+R$AU_iz3G>iXX#e$Eihw|oC@)&DU(K@9!>kM(iKh(0p)zi*EX
zjGrx>&rU7$|EG%8-T!#7M*OF}jg-xX|Fdzc^8ZTR7Poi)@2(x^f4=_DL%Ui3<>tS1
z?%DtA?tjhOKicp9e+mx@4txG!eLOw(9Tgrph`7J${I@m#gRgA9o%x50!JAtBAM}67
z{MUyy`ahhNJ!_fXIcLJ}^xt>?i>ZIyc8)Z6#JQ<~UsF}$zq$WO|A(%ByerR=l74dh
z{=hi;NA;WWjBer?~=a^G@)esBNhwtwFJ=g>cwJd8e^KiK|M^{2T%J^sn=YH%&N
zo?J)k4{cXUm;b
zsT3N!`mO0auG@0|Vff>sxrbVaCL3PWtF;l<@0Qt#*pAp+o--PleDl(Wsh9=x(1-h^
z%I`}}J7)8DdVPr2w_ov)HCI8cvd+_I4Pu-V?P)cMwni{@+jgxJ`
z!N5dt%i+vW4oj~(vmuW6B@7q2)K
zdQvij=SGg=R?~$$y;@(5Nn%U1ZL%%Y@MY=Erg+%OxJQR2`6ziIx&HUW@4L-~rj(d#
zv+%K6STF`yv+fZybw7KA5#B#?K*Ic{nX~#^K86Kyr%l^1C7yC
zy+Q9Xc9mm8Cpb#}lKkb-HTf{+PJb@*4@i^B)Yk)dUT{upcnwIsoT}{6?znrQmB}JP
z(F?jSW+MJsaDKWmSH}36h+G=V3FZ0j{S6-9KX?2&@MYzfJMXD?;MYg*`GfmsF*x|T
z8g3@m^lQ}_jVKo1sZztbxE@P9*UlGli{z4WWND92O(^|7JH9ueDpvo#QRbKN`(@_WqHswxJ?srHz3qk4f^FebZB98;mb5W{Rb(`B`!!CQH_XZ+Bb%IR
zYII&Z(QkQMO!bEm+fLj}?AoX54|!~qe
zYjICPk;QLMviWSc34_ULiO0WjBv(5cVrKM1Df?|Ha2Z~Uo~uE!Tuvd&qMTZzj;fpF
zhBi$033=wSn1YXv__@zdKU{pSh#UTJM(@+lLixu$TcIuGw_S0RWih5McK*X*{O#x7
z-#sM?@pZN$x6yeyJ6i8c
z{i*hT`+oK^^S=lG(DzW`8ho1jx##ESKVJQ5=||@uY_2s=%`Z#-fl%7h^82I;#~0LwIejF4=RUbHoc+NQ!`vLxoX(86y}T@)(iDgdWs1e9sDg{i=&9V
z$kZ5Jbe=pwmzn1nm0RHM7>+J84RX^=H<8A6MyptlUdXJAjjvR+ELg9u64~6ju>Rf6
z$Bvj3HlXgvJ^G_5ThN6Q;egqquZ?|W#;8~OBdgk=u+3$gu9#DLQqEJaxl>}Bx-)9D
za=L_hWS?SsO%9<`7^e@6F@2huqb}ITnBABmQ^4G3tzf6ROXH_2
z$La5HQr&-%YhRA5{ZJd5W44;hOtT-x6Q>g!Kh=ER|Gx9Hm>Bm%hke13@I$6u{!Q-h
zcAPhVCI5B*UluzLlIK20Vh5NwCJ^I|7vr$3m|Jtb
zw#uEx7IIEgJRdM02^ZGh58M2hdCxZXx%4le|K-?UdYxB)nVnSsgD3epnfMoLf5l~;
zIfK6y?WaGaB-j4My3?Cd=%`A_j&sF7f4B3o-)
z50!;i1EUdlF!z_EUzh!v{)u02yt6;$JeEE>e{BBo^rw!;ygya_;q(voyV;*=0%PIl
zS4(guyeE47y}|gD@o7ala_4C@-b6@^1n}ItY6^IKQz1(=Ke_eK`e5w5P{CV%i5y|$;&)p$=usGoG
z&p%&$34ZB%8u@dAtMSjmPsdN|?zE@uKb8Es`*Hi}(x3X8^<~yG>OFAR{B-T*eD`0s
z-zvm?H7J&Ty?(8G&G7F0I`4mcS$i#bOZZY5nttsHI70_t?|xqL_WttZ9}gACjH;5B
zj{~1(tXmcrGs>oD=BV&C`EupW@>#z$2CgD!N}SrK&&W2VQ$J&y*$dLIJZW~#7xqN$
z%D(21lZ;knE&43wtCtaX`2I}})IQIA$%tCR<>5BX$7XAH+Ku8+S|c0Mww$P3$nDAy
zGhx)KdsHFK5gnlG7X4JU>t)OtwFyphMm7kSv9p%U?}~ot_^!zov~1H$MweWst|`^v
zKzT+)UoqCzIO04s5K58F+K}-~)
zC2rfAhFn}qEl}n3jma6eZC^2MjeO_)&Gz?wKg^|`{>zMv@l?z2j(>1EsvMX0%Wk~K
zR9ihJ!E_Ykj@jjw_-S(o*Cn(HLQIimH}>g+Ze5RQv~1F4l+~1G8UN5`J>|0aMpK5c
zXPGwTn+blx5^vdyRgtmFOqG@k>jFP#-ZU=?S4OIqqXqSK;+#6xvgKa2QL}?{_KN=3
z8Go5?>N)T_?RS6K4HZV6f!?pjuW7-jx58kVSf@P`ZRWC%+vW_$EHLJp59J?6;x9kU
zeelIu?7knCe^~#)gJ^ES81Op~ipqY)%M{Ao?T@LsuME4???#6b$v>*)bhKgxtMIuOEpku
z=@}G^b)UuJvxU+t^_$_y*IO#rmPe>?4vyv*?LVgxB9HB1hqAsZo4*
z8-Kfa+j<%MlJd17u<_;(ZA&TPO0hC}|8^q9!#|4k3%Y<9P#?rZNmY;J(Qt!29xnB-
zyq1N^-v-0Nn=i5!=@fUh6LCqNF>#R#SkLiw?jGeG-TPHu<^I0EOJ|$Yx
zOhLiP_47?!BKgd3@SRKoTTa%=&(cmfC%6&%+Iq1;JDY9exSoZiAtab|s7Y?v|hWeqMP@a3}xT
z?|%N#>~(&*^koDF!n@&)x96bw<;?%^a`}AqJo#((m%Ko2U^kfccKVtXdJgUe(_hnG
zpWbqU^?~x&$(L&1R$wJE5`KK03#5eXZ{FA0x2@2F+@==FeX5m8Ags(jUCOqD0hCBR
z(N4Kmnbm5EBV%7X*HV-`t$|hrGpuu)X@d&o;DYp_>C`mMRO@?MadaX&FPS43k#!@U
z+9EF1W@$Av^2S6DLS>5PrAPA;UgDS!m`koE34(5vLqIIH8
zebQ}&E$Vt3h-600p@E<~*z_8D-HUEX#cHBH4HapYZYB1OWOjxuR34;;Xu+!-DUlZ<
zBQF`h9RHm9%fxflTkqRWq*5Dze&@tY$iddPvB2tUY9PbE6P$Q0^soCay}D=N=fa=b
z-4=K8&)hF#o;LTv&!fJhm!q#9KNCpt)dhrCA{Y=)aA$2%;%z7F5@*7bZ?4EO*g{cA
zj%KRsYP-5EFDmE80%tKhVs~w07AmGPb{?T7jnLH@-AVPRoB9Pgr=IEAR14W?TxlM8
zPVI=UNZ0y}m>kWKtia;s;q*v-)EzDqXQVZ8GjtZ7kxO7F<$4y~#}twIdMmJ=!+2J!
zJ(GiBT+UyNwC$ZwgfF+p=2m(6fTh1)Su>~KTu?Mj^)?6zWt6F^4Y}@2_SN1;p*r$Elg>XnasY|ZF
z)NQG@WLbtR^RW-+5iW;c;5Rr6yTV2(>81n0!)L}c
z#+=#uV#iF`yo++^jJ6^*MVM%rTt}Rery6CXlDn!`^&3tiQSVn)#8G)q3#lb~r+%w<
z>FK&h-BvrKbTt6`oKXwaR`DiO8Y&Sd;#l>*eUJF_IoB
ziK@z#oGh2iPSGyU>n&s(bIb4W$LtWR6CLEJDS>-p^_XYYMITaW#-es8Hi}bnn^dG_
zsJnWb5)AJ}=0YiN@ox{W7k=W)?XT@GRe}4r_P6Yy`7Jm66l#0f{5s(4eIEWI_*-7Z
zmka+c@ZjJVU!YNJP-iqNc|fI7GU=yIgd5YGX(%SgvSQj5Mq>ueDsL5JrkXyW)}d6F
zlTK13+~gFOXg-ClyG#e>km=5Jz}a~VGs{d1{pJf{nAtJzj1%Hi8&>PpF{w$uGWy9J
zZPZvIJE;pMo%adX$mIvN;<%iT!I%!PlRkdkGH^N;>*4YDYpKfMl
zcACkeUF1Cx)Z2|?IZsZKIpmExbwj^_Puq=3ZArb=n)DWRP0yqWev(^ZUlL9%x
zotKT5i@?C!cBE68)H4i^@x*vcd9hR0qEB<*B_>pTUQ3wx)bp_!camc*j2#r*=2S~n
zOrm)vCRcd(`4HXAYy&&oQnQ3p$rqcX2FWeWBjPQoqT*9~)g9fd9cr?+pzkP)`W<1@
zH?=L&L8^qEDxxghAbSNbiV%Z(zqV!E>LsYWTxs*799;-qMRFnoQolN+-vj$47(O{u
zy-;(NEwM3di&Ve0hwG$+=vKrLafWt+hi`h+qRmnX^sQ+!CfRatO5hK9mr%f!upC(<
z`6Y`~6gdf%gw!{C_&QYac8%CXQkLEFxvGAbx+SU`qgQ9O&wPvl1r*q
zij`a`2iWOIE>uUfbkaeu6IoOiT|%rGllqlPNsFQ?Ii=@lk8~muG8JtNtp!Jeu3$p2
z=*<%Kh`QJYFIbX;6gYLph`LTyl?0fLou>#0x|pCgaq(qQXr#oKPME;tq%7B}U3okJAA
zBeRK4qexv=eA*~EOU2XIR3TMPT~JeGt(Kr*mep3}P}3zs62wJuE1WA+`i(wS=xU`JDFlO!0t1LY(6{4
zIB0og6S?J@PSQx-Sh1-93~%uV<%w?Ri(Ctt(#5=Z(eGA3md
z>DNlS>QtsBkCI6w>#alz(?gdrrOXUBV>&T+#Abask6E=m#*A_e%mQ1^w+i)ql90qN
z30K0EdC@$_X9)#-1JuVh`jOb8Lv%6b%0>H)Mx#Q#RN8bAwXY82m|Ri^#7k*6(i63d
z<%rKrv`FlVdgUj5NDt||hEo|*7v*`y3;t_U8{{=*Q7Mnqho9v^?N+l86NE#3h;D{!
zLwmu_z=LnwH}bOmYI)lX1pOZWq2KJ^`nurH4&=Oaybv$hugih+*Sv6AWHl^CkHW<`
zXP-Q1oY3R+E!9e*mPr;7J^Gz)1|CdSl5|d47e}Nz$u1?S9Ym1KM6L)@gH(WOr*qf~
zwwT-Hy}Z>_z@wgG$}>f{HDN}m;aj*IW`nM$os5NV5xRvEp^#7H8o_TW*(PqCt6)}{
zEcTk}qqgW|wp{RYd!|)XBO1+_<_?R?EPn`^>&y;IoVCQfEv%TB7_dXGmK&uW_yKc)
zdDrAL7h4>$d9fDjh$VzdS>>%&^Twj~GE
zWPO(CBr}L1x{GF*09VKLFpDh1R{>uYaYIaio}!M76SYXm*T#%C^+J>NMr~O>QifGQ
z-y>U@Yt9el)h^hDK7p{Lo5%Q8Hb`5^ZmNgsCNHQhCZFZ_0`sV_02^#X&9g8j5_|t4
z#X23k_Tf2Z$ee51GwZ?@PB~ghu)&cDGoU>kM&dO^b*--%)%#2
z$qKRv_5EXA)J}j*E{p(4uobk64$@Wh0pk-qCcEI}##lE;3FoFVOQYo(%6~uG%#CyF
z>@}Of7jsr-hj!EVghyLcFQlF5hIlVGDkG{}X;5r(g?uYt%LQ_k`~=Q+NF1X_q1ISZ
zHxW+@5&cJi9&U*Nazig8z0@e143s-3$U-fD$ChGl&P=4xEbz&%B3f$
zQ`C$Z^4@sTFO6sIQV(ctT1Yw7dbLLNRH;yKHsuUe_$H$Sv)PCma~G9Ea9TMsP_;Uy
z&7ohQ5QwjYJK^nY23O8!a{JttAo3pWncbk@yB2N@ogAhn$u=!lU6ht0ZIL7?L7D~z
zm8A+5=5WWr>z+tq92w05c&#KZ9?bBc64!AbWzP#pXI%1eX*M3q#f
z3D>!R$Y2g0(m-Qt9}5Q&7Z@ZE`UZkPzKgu5cP$Xz%o
z5(v$Q215sLOOb`hIaIvTP+gDut~;N`Je2m4Oy3gXiJxXiYRNN<9l;
z?$q=2N5iKlA<8i1dmqgRkx2&8k+F|Hl5Gw7Lwiu~)fIJAyVsYrTy0G+M2AlT?k=C)
zCK{;(W|lr8d&ooTgu10ly4Kq!{Jst(hS*NDJ<#joK&Ys0@0R
z@{r9`BUwhLG9z>=-OIMIZbXqLHVf}=xe;M0U5E{V-#%Md}2zxAe!GJV{v@L-xVw;03uKi%V_TQCW6c4a98p%a1N{#1YJeP|YUm+4!sPRUFl=r`ta8Nc
zS`sZ=mhPBclLajFh!=TP7!sT@(-zKhgHD((b8^hOnL#FO;jXy?evixL?3|swW1pFR
zCY=>eN&pbDrPjM9o#?HvLBmoP5ChLVef`%Z@=Y^*y5PoLo$@<4dIML5`e6>+$}9kVOiWyV!i>=E4FrhkfBJX
z2p8-G?Eqp?$tJ3ma!@H`B2i!vx=r`%-9#VFv2{!%^vZlPNF
zUfGn-q3UixV@g0&dqx(q%C+*6T=cFd$m>$Am@J+}gVC1gp;#eph^x{H;$*e#m0V(>
zcpy$lE79FZUF1156Fv&hgs8BJSnUoihmXU{z~Sf712JBj6KztuJR~nG(~3))lS}2v
zC>L>s3nH6{@MDq3NF|O!MdPARkqKxBJ7HTm6ec46P+wRKkB72DZDB678_ap#@u&Eg
zzFK^DzUQyGe(~$m*Xgg$ukNpHFB^gTz}D;bYwzpw>u$gqPy?tIymr1`2g(AWm+}|K
z%ah;huX}lTSqiiVG6F3x-TuLsfj~{5HBkM!7i}9GRx^E%-Y6dJ!0WX?|f|L}<1b
zFI$0yx7yIt+d#NCvLBhlb1=Gs+%_y1VrCr5m{O^Y>RZM*`Vy_^$J+#AtE3(D4(un%
zn9_65nb{1k(`8r<%1A*!;V3%jat({VuU4yb>WVg_J)k3S5__Z(Wu)IIAV=ta#tK|W
zA&%98dDNlWvWO4R5G3L*d8{So8}6*AvTB2glD@r
zKWg^ttea_PoV1Aj;qb#>-YnH6?brkYZ+s+m?z|we)1Zat)Dm|Hpx=*
znY7TGjG4Jdzur8qqLbdEfi>wwc9C=O&B83dVwyBT9TE~v>82H7UlGJ>4pBuCKo=tW0p3HlLh;hBuyplzy6TA|))
zm7@Imp8Os4Vs=X6;6EL$R~z8(O8dq1EbJTAseFPwSYB>w*Xi)7y*ON!90z){4a#V<3;6-B$N}f*6lS#Py
z8lu>+p?h@&-K*(DH5pGek$sd%U7$DMhOTCM7=h_yw!w-9n0vYyBa}erQB%|wl}|O|
zm7<67St=8vC+JaT4EqLY57Uc2kZpQ|nxmd68;(@Sw6M?Y6H~>GBB!45S*T}*OeN++
z)J7}#Vp!=s&j|H`pI_p)`38QQWB6p@imPYSgmR&UUF97@H|OKpxn-b{3Pxb>k^knH
zD^`U?mm%A`nGxUuGcV(tDnBPY34^9$lWe**1q8p~5nO`Vlpsv-c5amIXZ`FFn~38%
z!ArY<5=yxPZiky>ZOk1k+Q+Q1@vNEkGc8OxIyj2xTl$WvXLgucR%Zgt6C*-#N$2~K
z4Q-qg9y7|cF$`;G+`wHa%r$*RZWvX@xORo?QfRC}wHza?WB_)%U^MEKKBRR6x5a5*
z)q$CN00s=|rBGbz^=o}a-_jF}3%q;QSG9UIRjHH{IsgRuhzCMO25>Zsk_7E2mPCxlT?}?&U>!To#}oH$gpU
zM-ID{)}&*pMYiyXk|1hsz;N=-Dn^>6U~p7M}pz0Fcm%v4TTOv4Wa9h4OuiV
zToD-y_lEOA7JM>>PoCbYLcO8*@I|OAlpL-M1>Um2ni7%YR>Rkk9C2Peh-OBcP#NXI
zS)tjt<=}d-{Vfi<6NRHshwH%ZQ9c?xMHR)#wwL%W$+ink9CNgW{C5C>=^7Dgd|Q
zjuezDlvU*RF}XqBmTcfq#pjXPGN>N1r0PH!$l^u+pHBm2#6@5As3;sC^vSq8_+5oz4aZGsA!O88=hT
zhL~e~XAF^=;gX@(%k)ixA(amWWerkh&c-$*w0t;C;X(a3M}mrvQ2(?W+#7)n(#1R
zAmpJ(tOdv~-)u3LfF*Di!g3wsiAj&CfW|g!o->V^4uxAG*L06Oq4LA{w$A%_2k+&I
z;obGT51Da~D@8uKMIX{8m(QQ_R(P%zIVy{Dvz@pSf{#Gkd4hj=StqBn1<(-VnM}GH
zz2!IbH0`9Hs5*?MgIQv2TseEk95L0*0L{^J)H&%Uw}8sqp`C3IbwG?qh|4Z$hz$Dq
z3yD2q0W2v(d7#y{Q7IHd?I2_6U?p~FXewrInRHO4=!kCs2E8Q?uw{^_CPs+_vY2cH
z@;t<0jfDu;+(uFvZi`V25|9vG=tf6(9ammjhGPEAy+pbyU|7SxKaO>)rs?6`?w)awWd?0EIK6*j1N$qV6lX%CmBzoGbC_
zfwG~@D!Njkwy00YeY;u_?jgtMHL{`G92gd?E>TgPt|t>Pl0}4ol_fpo2}UrHY$j*P
zZBoYgJ`fCo~y8e;*?B6y=np|
zMkfVw2kR$xkfF<=Q1@b8L_T>y`p8T$i%BYpZUc6xMm07OTymY|xHYznU1jfqz{=re
zy=)!0aT&N>BCEsdGPxi-%zBwEW{N3-wwy)xL(iY1X24eaVR|zaNz3Wv2Fu>1gH$VwM2bDw;3tO%n8Plo~SnhuiWXP-iFm56jsFCBa7ET8}sS6
z+7$AB4N!>
zX2DtW$R;4)E^?Plq>?EYSp?05p*Yl7Me+{1K^*EtC*&&G5A@nWx?nBn%As_it~6Su
z?6BA#MEyf51PcnH4rZexR55A+6Z9qB$Z%{P+sSsILL6dCxKlO-nm{u52uxEA4qwI9
zAi8dI9Itb$z)N2Ck$qrm-+SK>U$>#aPJ(eTTpDGQOIBU%zvSRXkT*H$TN+0hhV?3c)Gd^P7AZR`eue
zpE@8qC!f!Y+z4mkE^uX|td(^_MfX9OPDbwYGafJmU_q?L>2~$
z(kb}HFjj5VBbK~de;oWJ9T{6Ujtv>Bp=uB{Qn5P9LYxAxKVwy&8-C)2r#0%iP}kb@
zb;R}^eMEQbj&E4|Q5(``VHIZBM6t$cW9p%@qg=z5GZE#7)rjiQ1Wi`;cO0g!s;$^J
zOS?ksJOENF10v5>1$6;+#wK(zq`+Gz5S44dS8U3(Yyrlblu9LCT9rzq8tDjLw}bcf
zi0dhmPjbqqz;F-pjNA^Nnv)0QefU*|oCpt11VWsJpLNP+#i}sy|8pg%R4ZwUU#3vm
zUW1;|j3W(76ViY*EU8i(jDmf=cIf)2j
z?cl93N7RtRWGQm556C8iK8MQbr3iWk^O%neY^Kto-$ck8auJotC2|vfKAn7ga;eQvFc3Mv((1s5EL3_jE%hAaiWty343c
ztX>*G2AiWSV42IvC*81GC+^3KqcgM}UVj9A>l9~iz@6`4Bnpr(Y=|y#VDGEYKiq^2
zCO1xwVw{E%ZyLyFjPn6>kazsy!r12%%UDr4PxygPZ%~zNc&~ba>8V(ax&CcErW0#F
z=g=KBkJX`eC@YVcuXC(28HA3Rgtd+<@PZ_LP3r`2O-Ec55Jz*sQx{Q5l;ZNJxt5AK0eeMCjG%M+_WgB{qtK@uWbR)O3nPB4)
zAeM3*r3kr920F@VF$*^K*cN%5h@*+h$BN}4mk6&d}tJn%4sU|j+Erj~2Gfwst%zTZJ89VF4b*8YJ
z&=6K})yIq#t4Q+ERe45dp{ppL$)``?neFi1Qn~_ny#X(rqz7R6wTK0a@Rd5~Q(IV#
zO%S`rn9+@O#M7|cJ)rDKXu+NMdk9rH7dU(qcG(UL?nI4#Os~@I`ka=cb%QBaLlZg1
zY|g6r>aMb;3T#+>My
zn3K|_T4_RT2G&Uz3(z@|fjU-`$VlfvM$2HN9a26zRUA@C42qRf8s1q@b=((=(H-mt
zvo02^pg(Vl5mdO=#49`(#Zx@SMZ1_Hwu%*Er+6lEQU`hy`w+8F&rzwAh2sG
z0-Q4r)U%Ce2O@Y8u5b!|a1ARThc=+&ZkCjO+}$j!eG2zkk2{G&9;gO3DuoYa1ADm?
zH+m_$pb@o0Kj??At-SAdq!K`V(?)71nF_V_WXGHSX_`r3owJE3uCI
z2|0p!uMHti)nW~E2tCS&$k7~DqwhdTEG7q`Bw7)H%Ymc=R3+AV9nzb?;+u%?H|T86
zWJ;g~p{m17Bf_ULoAecZ4h8d&UPY%vF(UOeeMEb(^^V>}o*1BKfG+YF8UF|AL?$1|
z;sol}G_#1;9^``kcccNfjj9tn&#u6;ZqVi6ME%Ucr2=Ec;o-!)Txh&K=nzeXUsQ7e
zAhCV+3HsJFTM9o=nFCa)N8qnJKsslP4O>gu5~yHVtb;9PUFfe~M-IA$XH4P>HsSBB
z;IQq`iIbQL<`^jG5|#O5dKrjl8R)13KGI4HbS_l56nIK4U5)x}m
zCcO^%rWVf*aA!BLaS%D?8uPn=)&C+YuG^Sr5B{HmM_+$?FF=i52S?90E)ho)z<=^#
zH#^8k)A&1vcN6$_H{z=URkm&Y5@=0?ebplu#lhM<_!fmxe$xzk-MIexw?>n
zQnf9$3jFsDt6-9ld*Xr6*3?t=8ZjPSOUO1e>b`oZo*`Daz}Fw}=>U9U9f;@wTN1uy
zvwd*+WBAKBo_VN-`@lEuQ2ap@rYm5YO^|ztJ_gGkyVp{$u87N
z#IqdavK=T`!)hs5OfAsok$R-vMXCE?{i;p;SkVUd-AcW^x%bT}Nc$HxK;y&5TOS;3#G{4lK0@pYP*&Ntn_7&_HJ4
zw*vNvW^}mAb72~X>U>^kI!7)`l?T7{i
z3|4tC^LQNN=neSv7`#274pGxoCzzX)s-Uu{diYowYQIfDtP~Wd5In|-J1?Sgfao5f
zbF5=zCc*Ef$#SR?PST5NixpbP6UKG`nqeJOiw2?!bt)@ZNCA|?dHgm;27dFQ1D0Hm
zUldVc%a2e$*70;>_8RpTVD4H}O5>2-95Lqd>yf*LakZPc(j551J3<_QCl0Hf@P!&E
zv&U*C{G%P(`I>sIh15czun=rNQM(4#bg2b;J3OF5)753|QY(Y5{)mp+as3MG%Ww2n
zjBzP`x8n*L(<9=_GhRzjfhvSPm4&%zdH)?5C{*c~vwR@#CSZ_haLYRAI`OCqT|x74
z!mi&np$qB~4B-swZUQ238E{(({gy00DZmZqFiXj
zBAdg-gZ+Eh31lnufkGG9z;|x(O@X_@_D$f!6?P64k1Hr&2P}glxsaz;an=sj&dSiC
z@4&`UzW{#YfHYmeoNh4hOJu@L2cA|$Vw~l-)``wT-pckX262X
z=z!gW+O-5!I|Uvzi)SNM0_JoD_HqGU-T;O!Ap49ULo^d@@PHb`mR6`I_@rx!?U?&TxsEq{KsRH+=IdZ$vN
z)B-ov;*kV)UWzJQ7c93M*4hZ3-HZ1#sL{_ui9H7EI6#-&2`qRGJzE0y4PeU_EPP#d
z%L{m2MR!!2+zNYdgT*hSD_{v;v4&&yg2xO)74sv1!~=Vp(Ux`_f{ZN
z4%gww+0JmDIoXA+XYi>b?6(H*I>vV$K&{otMzu--_>M!-Wz@!TQKh{!BK
z)Dvrf2WOB^`t<>H;3N0NvVyXr-dhIs-K<26@^7v{wKA_Ksj{0y?N=Xnlw1eaZye>%x)SQEl%+
z+*rcv6maV*)V^aVVJASl{m?L0Q4t?N7HWl}U5x#j@OKM)jN!9OytV@aPT^4x#bXNp
zzv~jsxT8wMqcS=kwe&>j8Vt@GqMX=X4gGADUPJD^0Lt6}mcGF8Mu3z%@EpW-jNwY!
zaGo^!5mD|8YRCZcb_@D#%AiQRA7RTd
zSwnV`Wq5XC7PH7S^y{U74L_iUe~+6)X#U+5hxRr@P?Cb81NXH#R9w}@(md>
z(9i|M5&{nk&UlV~zEkxUdFdQ@@*0To20eZupt2GufOXm&Sk#{Oqw2Kj
z4B_t~)VDL>1h;NQZJ+__+YoAz+d#`3@VQguJP)F0DiB-){I4F-wH#=D0_tZQd@!E$
zqq;SWS@olev4EKh5ZPoE_(Bq?6Ytq@23wCv54gb*X8aOZ&jVhO3oMj`IA0FcZWQX(
zEcCKvybeJD>!*5w1BZc{ur3Sg9z(@J4;QEhsCfk5)!>sp>@^7#HHt?gwj=^iIVqKV
zgn}EvIYd~Qg}TPOOY$66b&9iY!q$cnABMj1mMrAzLNfWiBNUyXB5FVs9t4!K0Kq{K
zy8%``1SjdoJ$J&Y`tUjf?h^d=3ui}AgFP6X4LoLnz%Ic_N6^9125alV@3r+qV_3yF
z79ht2P?L#3)v-Y*_M+xjgq26{ytnt~{HV)%HO`{zX0T*gk3+9U3KTX1Hot@DieetP_CEC1
zBmD&2=NQp<5A%Kw<#i4^Y&E!e18iXgtfvijR0_*k){f9Gas#Wsgbj{Do2&n(#igR}
z#D(sdTg3SVSo9I>^-fLJ?(p{-ykZ4gg0Sd)@R1YjbA*iG#%F|>DL_FUuKVG|6
tZP4{xYL@1~ew)B)XUHMjcs+p^y?^`NS5o0wc2w4@;BQ^Pr# ( -- sounds )
+    init-openal 1 gen-sources first sounds boa
+    dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
+
+: bang ( sounds -- ) bang>> source-play check-error ;

From f5f065ce75f1be381a1c7cd7eced7c0a8310adbd Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos 
Date: Thu, 8 May 2008 06:13:14 -0500
Subject: [PATCH 57/77] Unix 'open' now throws an exception. The low-level
 'open' is now in unix.ffi.

---
 extra/unix/ffi/ffi.factor |  6 ++++++
 extra/unix/unix.factor    | 18 +++++++++++++++---
 2 files changed, 21 insertions(+), 3 deletions(-)
 create mode 100644 extra/unix/ffi/ffi.factor

diff --git a/extra/unix/ffi/ffi.factor b/extra/unix/ffi/ffi.factor
new file mode 100644
index 0000000000..11a8405b1d
--- /dev/null
+++ b/extra/unix/ffi/ffi.factor
@@ -0,0 +1,6 @@
+
+USING: alien.syntax ;
+
+IN: unix.ffi
+
+FUNCTION: int open ( char* path, int flags, int prot ) ;
\ No newline at end of file
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index 9005cd2b2a..38af4b8695 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -2,7 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: alien alien.c-types alien.syntax kernel libc structs
-math namespaces system combinators vocabs.loader unix.types ;
+       math namespaces system combinators vocabs.loader unix.ffi unix.types
+       qualified ;
+
+QUALIFIED: unix.ffi
 
 IN: unix
 
@@ -75,7 +78,17 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_
 FUNCTION: int munmap ( void* addr, size_t len ) ;
 FUNCTION: uint ntohl ( uint n ) ;
 FUNCTION: ushort ntohs ( ushort n ) ;
-FUNCTION: int open ( char* path, int flags, int prot ) ;
+FUNCTION: char* strerror ( int errno ) ;
+
+TUPLE: open-error path flags prot message ;
+
+: open ( path flags prot -- int )
+  [ ] [ unix.ffi:open ] 3bi
+  dup 0 >=
+    [ nip nip nip ]
+    [ drop err_no strerror open-error boa throw ]
+  if ;
+
 FUNCTION: int pclose ( void* file ) ;
 FUNCTION: int pipe ( int* filedes ) ;
 FUNCTION: void* popen ( char* command, char* type ) ;
@@ -96,7 +109,6 @@ FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ;
 FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ;
 FUNCTION: int setuid ( uid_t uid ) ;
 FUNCTION: int socket ( int domain, int type, int protocol ) ;
-FUNCTION: char* strerror ( int errno ) ;
 FUNCTION: int symlink ( char* path1, char* path2 ) ;
 FUNCTION: int system ( char* command ) ;
 FUNCTION: int unlink ( char* path ) ;

From b1bc2ff7af1180c2a3a160683bde41fe66ba5701 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos 
Date: Thu, 8 May 2008 06:35:42 -0500
Subject: [PATCH 58/77] io.files: Minor help fix

---
 core/io/files/files-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index d18babf31b..dd550070a4 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -277,7 +277,7 @@ HELP: append-path
 
 HELP: prepend-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
-{ $description "Concatenates two pathnames." } ;
+{ $description "Appends str1 onto str2 to form a pathname." } ;
 
 { append-path prepend-path } related-words
 

From 70ac6fdc15fd82ba66aef0f1258b1592b5a5cf86 Mon Sep 17 00:00:00 2001
From: Alex Chapman 
Date: Fri, 9 May 2008 00:09:12 +1000
Subject: [PATCH 59/77] jamshred: fixed hang bug with a call to yield (I think
 it's fixed)

---
 extra/jamshred/jamshred.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor
index 6b305696e5..3fb7113fde 100755
--- a/extra/jamshred/jamshred.factor
+++ b/extra/jamshred/jamshred.factor
@@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
     ] [
         dup [ jamshred>> jamshred-update ]
         [ relayout-1 ] bi
-        10 sleep jamshred-loop
+        yield jamshred-loop
     ] if ;
 
 : fullscreen ( gadget -- )

From 8f969e9d91609d85ff73756c35cc9b56622c77c5 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 16:04:30 -0500
Subject: [PATCH 60/77] Clean up Ed's change

---
 extra/unix/unix.factor | 11 +++--------
 1 file changed, 3 insertions(+), 8 deletions(-)

diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index 38af4b8695..bc3e3ca162 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -80,14 +80,11 @@ FUNCTION: uint ntohl ( uint n ) ;
 FUNCTION: ushort ntohs ( ushort n ) ;
 FUNCTION: char* strerror ( int errno ) ;
 
-TUPLE: open-error path flags prot message ;
+ERROR: open-error path flags prot message ;
 
 : open ( path flags prot -- int )
-  [ ] [ unix.ffi:open ] 3bi
-  dup 0 >=
-    [ nip nip nip ]
-    [ drop err_no strerror open-error boa throw ]
-  if ;
+    3dup unix.ffi:open
+    dup 0 >= [ >r 3drop r> ] [ drop err_no strerror open-error ] if ;
 
 FUNCTION: int pclose ( void* file ) ;
 FUNCTION: int pipe ( int* filedes ) ;
@@ -171,8 +168,6 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ;
 FUNCTION: pid_t wait ( int* status ) ;
 FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
 
 {

From 2164bcf784e45706c44ba912e97ee1455a65496b Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 16:05:46 -0500
Subject: [PATCH 61/77] Fix Ed's fix

---
 core/io/files/files-docs.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index dd550070a4..ec74bb001e 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -273,11 +273,11 @@ $nl
 
 HELP: append-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
-{ $description "Concatenates two pathnames." } ;
+{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
 
 HELP: prepend-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
-{ $description "Appends str1 onto str2 to form a pathname." } ;
+{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ;
 
 { append-path prepend-path } related-words
 

From 0ea519364af30dba69f45fd7cccf134e319e50ab Mon Sep 17 00:00:00 2001
From: slava 
Date: Thu, 8 May 2008 16:58:13 -0500
Subject: [PATCH 62/77] Fix UI

---
 extra/ui/backend/backend.factor |  2 ++
 extra/ui/cocoa/cocoa.factor     | 15 +++------------
 extra/ui/ui.factor              | 18 +++++++++++++++++-
 extra/ui/windows/windows.factor | 20 ++++++++------------
 extra/ui/x11/x11.factor         |  8 ++------
 5 files changed, 32 insertions(+), 31 deletions(-)

diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor
index d95cbd69ed..7ca09b89b4 100755
--- a/extra/ui/backend/backend.factor
+++ b/extra/ui/backend/backend.factor
@@ -5,6 +5,8 @@ IN: ui.backend
 
 SYMBOL: ui-backend
 
+HOOK: do-events ui-backend ( -- )
+
 HOOK: set-title ui-backend ( string world -- )
 
 HOOK: set-fullscreen* ui-backend ( ? world -- )
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 59adcf9af1..10980249f3 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -14,18 +14,8 @@ C:  handle
 
 SINGLETON: cocoa-ui-backend
 
-SYMBOL: stop-after-last-window?
-
-: event-loop? ( -- ? )
-    stop-after-last-window? get-global
-    [ windows get-global empty? not ] [ t ] if ;
-
-: event-loop ( -- )
-    event-loop? [
-        [
-            [ NSApp do-events ui-wait ] ui-try
-        ] with-autorelease-pool event-loop
-    ] when ;
+M: cocoa-ui-backend do-events ( -- )
+    [ [ NSApp do-events ui-wait ] ui-try ] with-autorelease-pool ;
 
 TUPLE: pasteboard handle ;
 
@@ -112,6 +102,7 @@ M: cocoa-ui-backend ui
     "UI" assert.app [
         [
             init-clipboard
+            stop-after-last-window? off
             cocoa-init-hook get [ call ] when*
             start-ui
             finish-launching
diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor
index 12565235ab..e864d39f39 100755
--- a/extra/ui/ui.factor
+++ b/extra/ui/ui.factor
@@ -10,6 +10,18 @@ IN: ui
 ! Assoc mapping aliens to gadgets
 SYMBOL: windows
 
+SYMBOL: stop-after-last-window?
+
+: event-loop? ( -- ? )
+    {
+        { [ stop-after-last-window? get not ] [ t ] }
+        { [ graft-queue dlist-empty? not ] [ t ] }
+        { [ windows get-global empty? not ] [ t ] }
+        [ f ]
+    } cond ;
+
+: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
+
 : window ( handle -- world ) windows get-global at ;
 
 : window-focus ( handle -- gadget ) window world-focus ;
@@ -201,5 +213,9 @@ MAIN: ui
         call
     ] [
         f windows set-global
-        ui-hook [ ui ] with-variable
+        [
+            ui-hook set
+            stop-after-last-window? on
+            ui
+        ] with-scope
     ] if ;
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index e3e1fc5124..5e17d02542 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -387,17 +387,12 @@ SYMBOL: trace-messages?
 
 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
 
-: event-loop ( msg -- )
-    {
-        { [ windows get empty? ] [ drop ] }
-        { [ dup peek-message? ] [ ui-wait event-loop ] }
-        { [ dup MSG-message WM_QUIT = ] [ drop ] }
-        [
-            dup TranslateMessage drop
-            dup DispatchMessage drop
-            event-loop
-        ]
-    } cond ;
+M: windows-ui-backend do-events
+    msg-obj get-global
+    dup peek-message? [ drop ui-wait ] [
+        [ TranslateMessage drop ]
+        [ DispatchMessage drop ] bi
+    ] if ;
 
 : register-wndclassex ( -- class )
     "WNDCLASSEX" 
@@ -500,10 +495,11 @@ M: windows-ui-backend set-title ( string world -- )
 M: windows-ui-backend ui
     [
         [
+            stop-after-last-window? on
             init-clipboard
             init-win32-ui
             start-ui
-            msg-obj get event-loop
+            event-loop
         ] [ cleanup-win32-ui ] [ ] cleanup
     ] ui-running ;
 
diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor
index 606a45eba5..50d383e6b8 100755
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@@ -183,15 +183,10 @@ M: world client-event
         ui-wait wait-event
     ] if ;
 
-: do-events ( -- )
+M: x11-ui-backend do-events
     wait-event dup XAnyEvent-window window dup
     [ [ 2dup handle-event ] assert-depth ] when 2drop ;
 
-: event-loop ( -- )
-    windows get empty? [
-        [ do-events ] ui-try event-loop
-    ] unless ;
-
 : x-clipboard@ ( gadget clipboard -- prop win )
     x-clipboard-atom swap
     find-world world-handle x11-handle-window ;
@@ -254,6 +249,7 @@ M: x11-ui-backend ui ( -- )
     [
         f [
             [
+                stop-after-last-window? on
                 init-clipboard
                 start-ui
                 event-loop

From 2f4571312f21528179c9fb4bf3437324dc0c5f90 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 17:04:14 -0500
Subject: [PATCH 63/77] UI fix

---
 extra/cocoa/application/application.factor | 3 ---
 extra/ui/cocoa/cocoa.factor                | 7 ++++++-
 2 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor
index 2ae17a1604..90159c1656 100755
--- a/extra/cocoa/application/application.factor
+++ b/extra/cocoa/application/application.factor
@@ -29,9 +29,6 @@ IN: cocoa.application
 : do-event ( app -- ? )
     dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
 
-: do-events ( app -- )
-    dup do-event [ do-events ] [ drop ] if ;
-
 : add-observer ( observer selector name object -- )
     >r >r >r >r NSNotificationCenter -> defaultCenter
     r> r> sel_registerName
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 10980249f3..d1b7f22b41 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -15,7 +15,12 @@ C:  handle
 SINGLETON: cocoa-ui-backend
 
 M: cocoa-ui-backend do-events ( -- )
-    [ [ NSApp do-events ui-wait ] ui-try ] with-autorelease-pool ;
+    [
+        [
+            NSApp [ dup do-event ] [ ] [ ] while drop
+            ui-wait
+        ] ui-try
+    ] with-autorelease-pool ;
 
 TUPLE: pasteboard handle ;
 

From 23d95c99f2fa967a4c1a70572e5e967875365f99 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 17:04:28 -0500
Subject: [PATCH 64/77] Add primitive

---
 core/bootstrap/primitives.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 753464ab80..3ce783d620 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -702,6 +702,7 @@ tuple
     { "resize-float-array" "float-arrays" }
     { "dll-valid?" "alien" }
     { "unimplemented" "kernel.private" }
+    { "gc-reset" "memory" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

From 2148c5eb6c4eb04adf9b6070a68cb5cc2d29b6ec Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 17:29:53 -0500
Subject: [PATCH 65/77] Fix docs

---
 extra/cocoa/application/application-docs.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/cocoa/application/application-docs.factor b/extra/cocoa/application/application-docs.factor
index ad2f8ffbd9..01a79cf35a 100644
--- a/extra/cocoa/application/application-docs.factor
+++ b/extra/cocoa/application/application-docs.factor
@@ -26,7 +26,7 @@ HELP: with-cocoa
 { $values { "quot" quotation } }
 { $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
 
-HELP: do-events
+HELP: do-event
 { $values { "app" "an " { $snippet "NSApplication" } } }
 { $description "Processes any pending events in the queue. Does not block." } ;
 
@@ -49,7 +49,7 @@ ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
 { $subsection NSApp }
 { $subsection with-autorelease-pool }
 { $subsection with-cocoa }
-{ $subsection do-events }
+{ $subsection do-event }
 { $subsection add-observer }
 { $subsection remove-observer }
 { $subsection install-delegate } ;

From 793c58f7a2dd84cb4779f2112b9fbd1f27c663d2 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 17:30:33 -0500
Subject: [PATCH 66/77] Simpler write barrier, upate PowerPC write barrier

---
 core/cpu/ppc/intrinsics/intrinsics.factor | 11 +++++++++++
 core/cpu/x86/intrinsics/intrinsics.factor |  2 +-
 2 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 34e9900893..95af9e4b4b 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -56,14 +56,25 @@ IN: cpu.ppc.intrinsics
 : load-cards-offset ( dest -- )
     "cards_offset" f pick %load-dlsym  dup 0 LWZ ;
 
+: load-decks-offset ( dest -- )
+    "decks_offset" f pick %load-dlsym  dup 0 LWZ ;
+
 : %write-barrier ( -- )
     "val" get operand-immediate? "obj" get fresh-object? or [
+        ! Mark the card
         "obj" operand "scratch" operand card-bits SRWI
         "val" operand load-cards-offset
         "scratch" operand dup "val" operand ADD
         "val" operand "scratch" operand 0 LBZ
         "val" operand dup card-mark ORI
         "val" operand "scratch" operand 0 STB
+
+        ! Mark the card deck
+        "obj" operand "scratch" operand deck-bits SRWI
+        "val" operand load-decks-offset
+        "scratch" operand dup "val" operand ADD
+        card-mark "val" operand LI
+        "val" operand "scratch" operand 0 STB
     ] unless ;
 
 \ set-slot {
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index a8bcf00d15..e0004f5f61 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -71,7 +71,7 @@ IN: cpu.x86.intrinsics
         ! Mark the card deck
         "obj" operand deck-bits card-bits - SHR
         "decks_offset" f temp-reg v>operand %alien-global
-        temp-reg v>operand "obj" operand [+] card-mark OR
+        temp-reg v>operand "obj" operand [+] card-mark MOV
     ] unless ;
 
 \ set-slot {

From ce76b1888eee5b70a19c8e3b3dd5facd01251e1d Mon Sep 17 00:00:00 2001
From: Doug Coleman 
Date: Thu, 8 May 2008 19:36:44 -0500
Subject: [PATCH 67/77] add adler-32 checksum, tests, and docs

---
 extra/checksums/adler-32/adler-32-docs.factor  | 11 +++++++++++
 extra/checksums/adler-32/adler-32-tests.factor |  5 +++++
 extra/checksums/adler-32/adler-32.factor       | 15 +++++++++++++++
 extra/checksums/adler-32/authors.txt           |  1 +
 4 files changed, 32 insertions(+)
 create mode 100755 extra/checksums/adler-32/adler-32-docs.factor
 create mode 100644 extra/checksums/adler-32/adler-32-tests.factor
 create mode 100644 extra/checksums/adler-32/adler-32.factor
 create mode 100644 extra/checksums/adler-32/authors.txt

diff --git a/extra/checksums/adler-32/adler-32-docs.factor b/extra/checksums/adler-32/adler-32-docs.factor
new file mode 100755
index 0000000000..b7400cbaa0
--- /dev/null
+++ b/extra/checksums/adler-32/adler-32-docs.factor
@@ -0,0 +1,11 @@
+USING: help.markup help.syntax ;
+IN: checksums.adler-32
+
+HELP: adler-32
+{ $description "Adler-32 checksum algorithm." } ;
+
+ARTICLE: "checksums.adler-32" "Adler-32 checksum"
+"The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync."
+{ $subsection adler-32 } ;
+
+ABOUT: "checksums.adler-32"
diff --git a/extra/checksums/adler-32/adler-32-tests.factor b/extra/checksums/adler-32/adler-32-tests.factor
new file mode 100644
index 0000000000..ccee74baae
--- /dev/null
+++ b/extra/checksums/adler-32/adler-32-tests.factor
@@ -0,0 +1,5 @@
+USING: checksums.adler-32 checksums strings tools.test ;
+IN: checksums.adler-32.tests
+
+[ 300286872 ] [ "Wikipedia" adler-32 checksum-bytes ] unit-test
+[ 2679885283 ] [ 10000 CHAR: a  adler-32 checksum-bytes ] unit-test
diff --git a/extra/checksums/adler-32/adler-32.factor b/extra/checksums/adler-32/adler-32.factor
new file mode 100644
index 0000000000..1be4bfb584
--- /dev/null
+++ b/extra/checksums/adler-32/adler-32.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: checksums classes.singleton kernel math math.ranges
+math.vectors sequences ;
+IN: checksums.adler-32
+
+SINGLETON: adler-32
+
+: adler-32-modulus 65521 ; inline
+
+M: adler-32 checksum-bytes ( bytes checksum -- value )
+    drop
+    [ sum 1+ ]
+    [ [ dup length [1,b]  v. ] [ length ] bi + ] bi
+    [ adler-32-modulus mod ] bi@ 16 shift bitor ;
diff --git a/extra/checksums/adler-32/authors.txt b/extra/checksums/adler-32/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/checksums/adler-32/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

From 89de1282be90a870eeffd6b960f37241233aeade Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 20:34:40 -0500
Subject: [PATCH 68/77] Better support for 8-bit instructions in x86 assembler,
 more efficient write barrier on x86

---
 core/cpu/x86/assembler/assembler-tests.factor |   3 +
 core/cpu/x86/assembler/assembler.factor       | 202 ++++++++++--------
 core/cpu/x86/intrinsics/intrinsics.factor     |   4 +-
 3 files changed, 113 insertions(+), 96 deletions(-)

diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor
index caa00bd618..4c0f04fcc2 100644
--- a/core/cpu/x86/assembler/assembler-tests.factor
+++ b/core/cpu/x86/assembler/assembler-tests.factor
@@ -36,3 +36,6 @@ IN: cpu.x86.assembler.tests
 
 [ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
 [ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
+
+[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5  OR ] { } make ] unit-test
+[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5  MOV ] { } make ] unit-test
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index cabd81dad6..bc6a12d167 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/core/cpu/x86/assembler/assembler.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator.fixup io.binary kernel
 combinators kernel.private math namespaces parser sequences
-words system layouts math.order ;
+words system layouts math.order accessors ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86 and AMD64.
@@ -11,11 +11,6 @@ IN: cpu.x86.assembler
 ! In 64-bit mode, { 1234 } is RIP-relative.
 ! Beware!
 
-: n, >le % ; inline
-: 4, 4 n, ; inline
-: 2, 2 n, ; inline
-: cell, bootstrap-cell n, ; inline
-
 ! Register operands -- eg, ECX
 <<
 
@@ -45,6 +40,10 @@ REGISTERS: 128
 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
 
+TUPLE: byte value ;
+
+C:  byte
+
  ;
 ! Addressing modes
 TUPLE: indirect base index scale displacement ;
 
-M: indirect extended? indirect-base extended? ;
+M: indirect extended? base>> extended? ;
 
 : canonicalize-EBP
     #! { EBP } ==> { EBP 0 }
-    dup indirect-base { EBP RBP R13 } memq? [
-        dup indirect-displacement [
-            drop
-        ] [
-            0 swap set-indirect-displacement
-        ] if
-    ] [
-        drop
-    ] if ;
+    dup base>> { EBP RBP R13 } member? [
+        dup displacement>> [ 0 >>displacement ] unless
+    ] when drop ;
 
 : canonicalize-ESP
     #! { ESP } ==> { ESP ESP }
-    dup indirect-base { ESP RSP R12 } memq? [
-        ESP swap set-indirect-index
-    ] [
-        drop
-    ] if ;
+    dup base>> { ESP RSP R12 } member? [ ESP >>index ] when drop ;
 
 : canonicalize ( indirect -- )
     #! Modify the indirect to work around certain addressing mode
     #! quirks.
-    dup canonicalize-EBP
-    canonicalize-ESP ;
+    [ canonicalize-EBP ] [ canonicalize-ESP ] bi ;
 
 :  ( base index scale displacement -- indirect )
     indirect boa dup canonicalize ;
 
 : reg-code "register" word-prop 7 bitand ;
 
-: indirect-base* indirect-base EBP or reg-code ;
+: indirect-base* base>> EBP or reg-code ;
 
-: indirect-index* indirect-index ESP or reg-code ;
+: indirect-index* index>> ESP or reg-code ;
 
-: indirect-scale* indirect-scale 0 or ;
+: indirect-scale* scale>> 0 or ;
 
 GENERIC: sib-present? ( op -- ? )
 
 M: indirect sib-present?
-    dup indirect-base { ESP RSP } memq?
-    over indirect-index rot indirect-scale or or ;
+    [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
 
 M: register sib-present? drop f ;
 
@@ -130,16 +117,23 @@ M: indirect r/m
 
 M: register r/m reg-code ;
 
-: byte? -128 127 between? ;
+! Immediate operands
+UNION: immediate byte integer ;
+
+GENERIC: fits-in-byte? ( value -- ? )
+
+M: byte fits-in-byte? drop t ;
+
+M: integer fits-in-byte? -128 127 between? ;
 
 GENERIC: modifier ( op -- n )
 
 M: indirect modifier
-    dup indirect-base [
-        indirect-displacement {
-            { [ dup not ]      [ BIN: 00 ] }
-            { [ dup byte? ]    [ BIN: 01 ] }
-            { [ dup integer? ] [ BIN: 10 ] }
+    dup base>> [
+        displacement>> {
+            { [ dup not ] [ BIN: 00 ] }
+            { [ dup fits-in-byte? ] [ BIN: 01 ] }
+            { [ dup immediate? ] [ BIN: 10 ] }
         } cond nip
     ] [
         drop BIN: 00
@@ -147,14 +141,23 @@ M: indirect modifier
 
 M: register modifier drop BIN: 11 ;
 
+GENERIC# n, 1 ( value n -- )
+
+M: integer n, >le % ;
+M: byte n, >r value>> r> n, ;
+: 1, 1 n, ; inline
+: 4, 4 n, ; inline
+: 2, 2 n, ; inline
+: cell, bootstrap-cell n, ; inline
+
 : mod-r/m, ( reg# indirect -- )
-    dup modifier 6 shift rot 3 shift rot r/m bitor bitor , ;
+    [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
 
 : sib, ( indirect -- )
     dup sib-present? [
-        dup indirect-base*
-        over indirect-index* 3 shift bitor
-        swap indirect-scale* 6 shift bitor ,
+        [ indirect-base* ]
+        [ indirect-index* 3 shift ]
+        [ indirect-scale* 6 shift ] tri bitor bitor ,
     ] [
         drop
     ] if ;
@@ -162,9 +165,9 @@ M: register modifier drop BIN: 11 ;
 GENERIC: displacement, ( op -- )
 
 M: indirect displacement,
-    dup indirect-displacement dup [
-        swap indirect-base
-        [ dup byte? [ , ] [ 4, ] if ] [ 4, ] if
+    dup displacement>> dup [
+        swap base>>
+        [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
     ] [
         2drop
     ] if ;
@@ -172,18 +175,19 @@ M: indirect displacement,
 M: register displacement, drop ;
 
 : addressing ( reg# indirect -- )
-    [ mod-r/m, ] keep [ sib, ] keep displacement, ;
+    [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
 
 ! Utilities
 UNION: operand register indirect ;
 
-: operand-64? ( operand -- ? )
-    dup indirect? [
-        dup indirect-base register-64?
-        swap indirect-index register-64? or
-    ] [
-        register-64?
-    ] if ;
+GENERIC: operand-64? ( operand -- ? )
+
+M: indirect operand-64?
+    [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
+
+M: register-64 operand-64? drop t ;
+
+M: object operand-64? drop f ;
 
 : rex.w? ( rex.w reg r/m -- ? )
     {
@@ -198,8 +202,7 @@ UNION: operand register indirect ;
 : rex.b
     [ extended? [ BIN: 00000001 bitor ] when ] keep
     dup indirect? [
-        indirect-index extended?
-        [ BIN: 00000010 bitor ] when
+        index>> extended? [ BIN: 00000010 bitor ] when
     ] [
         drop
     ] if ;
@@ -230,25 +233,34 @@ UNION: operand register indirect ;
 
 : opcode-or ( opcode mask -- opcode' )
     swap dup array?
-    [ 1 cut* first rot bitor suffix ] [ bitor ] if ;
+    [ unclip-last rot bitor suffix ] [ bitor ] if ;
 
-: 1-operand ( op reg rex.w opcode -- )
+: 1-operand ( op reg,rex.w,opcode -- )
     #! The 'reg' is not really a register, but a value for the
     #! 'reg' field of the mod-r/m byte.
-    >r >r over r> prefix-1 r> opcode, swap addressing ;
+    first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
 
-: immediate-1 ( imm dst reg rex.w opcode -- )
-    1-operand , ;
+: immediate-operand-size-bit
+    pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
 
-: immediate-1/4 ( imm dst reg rex.w opcode -- )
+: immediate-1 ( imm dst reg,rex.w,opcode -- )
+    immediate-operand-size-bit 1-operand 1, ;
+
+: immediate-4 ( imm dst reg,rex.w,opcode -- )
+    immediate-operand-size-bit 1-operand 4, ;
+
+: immediate-fits-in-size-bit
+    pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
+
+: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
     #! If imm is a byte, compile the opcode and the byte.
-    #! Otherwise, set the 32-bit operand flag in the opcode, and
+    #! Otherwise, set the 8-bit operand flag in the opcode, and
     #! compile the cell. The 'reg' is not really a register, but
     #! a value for the 'reg' field of the mod-r/m byte.
-    >r >r pick byte? [
-        r> r> BIN: 10 opcode-or immediate-1
+    pick fits-in-byte? [
+        immediate-fits-in-size-bit immediate-1
     ] [
-        r> r> 1-operand 4,
+        immediate-4
     ] if ;
 
 : (2-operand) ( dst src op -- )
@@ -283,22 +295,24 @@ PRIVATE>
 ! Moving stuff
 GENERIC: PUSH ( op -- )
 M: register PUSH f HEX: 50 short-operand ;
-M: integer PUSH HEX: 68 , 4, ;
-M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
+M: immediate PUSH HEX: 68 , 4, ;
+M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
 
 GENERIC: POP ( op -- )
 M: register POP f HEX: 58 short-operand ;
-M: operand POP BIN: 000 f HEX: 8f 1-operand ;
+M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
 
 ! MOV where the src is immediate.
 GENERIC: (MOV-I) ( src dst -- )
 M: register (MOV-I) t HEX: b8 short-operand cell, ;
-M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
+M: operand (MOV-I)
+    { BIN: 000 t HEX: c6 }
+    pick byte? [ immediate-1 ] [ immediate-4 ] if ;
 
 PREDICATE: callable < word register? not ;
 
 GENERIC: MOV ( dst src -- )
-M: integer MOV swap (MOV-I) ;
+M: immediate MOV swap (MOV-I) ;
 M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
 M: operand MOV HEX: 88 2-operand ;
 
@@ -309,13 +323,13 @@ GENERIC: JMP ( op -- )
 : (JMP) HEX: e9 , 0 4, rc-relative ;
 M: callable JMP (JMP) rel-word ;
 M: label JMP (JMP) label-fixup ;
-M: operand JMP BIN: 100 t HEX: ff 1-operand ;
+M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 
 GENERIC: CALL ( op -- )
 : (CALL) HEX: e8 , 0 4, rc-relative ;
 M: callable CALL (CALL) rel-word ;
 M: label CALL (CALL) label-fixup ;
-M: operand CALL BIN: 010 t HEX: ff 1-operand ;
+M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 
 GENERIC# JUMPcc 1 ( addr opcode -- )
 : (JUMPcc) extended-opcode, 0 4, rc-relative ;
@@ -347,57 +361,57 @@ M: label JUMPcc (JUMPcc) label-fixup ;
 ! Arithmetic
 
 GENERIC: ADD ( dst src -- )
-M: integer ADD swap BIN: 000 t HEX: 81 immediate-1/4 ;
+M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
 M: operand ADD OCT: 000 2-operand ;
 
 GENERIC: OR ( dst src -- )
-M: integer OR swap BIN: 001 t HEX: 81 immediate-1/4 ;
+M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
 M: operand OR OCT: 010 2-operand ;
 
 GENERIC: ADC ( dst src -- )
-M: integer ADC swap BIN: 010 t HEX: 81 immediate-1/4 ;
+M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
 M: operand ADC OCT: 020 2-operand ;
 
 GENERIC: SBB ( dst src -- )
-M: integer SBB swap BIN: 011 t HEX: 81 immediate-1/4 ;
+M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
 M: operand SBB OCT: 030 2-operand ;
 
 GENERIC: AND ( dst src -- )
-M: integer AND swap BIN: 100 t HEX: 81 immediate-1/4 ;
+M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
 M: operand AND OCT: 040 2-operand ;
 
 GENERIC: SUB ( dst src -- )
-M: integer SUB swap BIN: 101 t HEX: 81 immediate-1/4 ;
+M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
 M: operand SUB OCT: 050 2-operand ;
 
 GENERIC: XOR ( dst src -- )
-M: integer XOR swap BIN: 110 t HEX: 81 immediate-1/4 ;
+M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
 M: operand XOR OCT: 060 2-operand ;
 
 GENERIC: CMP ( dst src -- )
-M: integer CMP swap BIN: 111 t HEX: 81 immediate-1/4 ;
+M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
-: NOT  ( dst -- ) BIN: 010 t HEX: f7 1-operand ;
-: NEG  ( dst -- ) BIN: 011 t HEX: f7 1-operand ;
-: MUL  ( dst -- ) BIN: 100 t HEX: f7 1-operand ;
-: IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ;
-: DIV  ( dst -- ) BIN: 110 t HEX: f7 1-operand ;
-: IDIV ( src -- ) BIN: 111 t HEX: f7 1-operand ;
+: NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
+: NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
+: MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
+: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
+: DIV  ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
+: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
 
 : CDQ HEX: 99 , ;
 : CQO HEX: 48 , CDQ ;
 
-: ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ;
-: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ;
-: RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ;
-: RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ;
-: SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ;
-: SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ;
-: SAR ( dst n -- ) swap BIN: 111 t HEX: c1 immediate-1 ;
+: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
+: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
+: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
+: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
+: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
+: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
+: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
 
 GENERIC: IMUL2 ( dst src -- )
-M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ;
+M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
 M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 
 : MOVSX ( dst src -- )
@@ -432,11 +446,11 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 
 ! x87 Floating Point Unit
 
-: FSTPS ( operand -- ) BIN: 011 f HEX: d9 1-operand ;
-: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ;
+: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
+: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
 
-: FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ;
-: FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ;
+: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
+: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
 
 ! SSE multimedia instructions
 
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index e0004f5f61..db303982ba 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -66,12 +66,12 @@ IN: cpu.x86.intrinsics
         ! Mark the card
         "obj" operand card-bits SHR
         "cards_offset" f temp-reg v>operand %alien-global
-        temp-reg v>operand "obj" operand [+] card-mark OR
+        temp-reg v>operand "obj" operand [+] card-mark  OR
 
         ! Mark the card deck
         "obj" operand deck-bits card-bits - SHR
         "decks_offset" f temp-reg v>operand %alien-global
-        temp-reg v>operand "obj" operand [+] card-mark MOV
+        temp-reg v>operand "obj" operand [+] card-mark  MOV
     ] unless ;
 
 \ set-slot {

From 59f85c321e8eb87a61667ce5819773351f2b8e40 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 20:35:37 -0500
Subject: [PATCH 69/77] Doc fixes from stesch

---
 core/io/io-docs.factor | 4 ++--
 core/io/io.factor      | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index ddea4da556..2d74dfabd5 100755
--- a/core/io/io-docs.factor
+++ b/core/io/io-docs.factor
@@ -125,7 +125,7 @@ $nl
 ABOUT: "streams"
 
 HELP: stream-readln
-{ $values { "stream" "an input stream" } { "str" string } }
+{ $values { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
 { $contract "Reads a line of input from the stream. Outputs " { $link f } " on stream exhaustion." }
 { $notes "Most code only works on one stream at a time and should instead use " { $link readln } "; see " { $link "stdio" } "." }
 $io-error ;
@@ -139,7 +139,7 @@ $io-error ;
 HELP: stream-read
 { $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } }
 { $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." }
-{ $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." }
+{ $notes "Most code only works on one stream at a time and should instead use " { $link read } "; see " { $link "stdio" } "." }
 $io-error ;
 
 HELP: stream-read-until
diff --git a/core/io/io.factor b/core/io/io.factor
index e28fd28fb3..6bad8331db 100755
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -4,7 +4,7 @@ USING: hashtables generic kernel math namespaces sequences
 continuations assocs io.styles ;
 IN: io
 
-GENERIC: stream-readln ( stream -- str )
+GENERIC: stream-readln ( stream -- str/f )
 GENERIC: stream-read1 ( stream -- ch/f )
 GENERIC: stream-read ( n stream -- str/f )
 GENERIC: stream-read-until ( seps stream -- str/f sep/f )

From 32d5311821f84023342c5be51479b9eed66e9141 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 20:36:25 -0500
Subject: [PATCH 70/77] Fix typo found by wrunt

---
 extra/tools/deploy/config/config-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor
index 4af1219daf..2960cf452d 100755
--- a/extra/tools/deploy/config/config-docs.factor
+++ b/extra/tools/deploy/config/config-docs.factor
@@ -96,7 +96,7 @@ HELP: deploy-io
         { "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." } ;
+"The default value is 2, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such as networking are not available." } ;
 
 HELP: deploy-reflection
 { $description "The level of reflection support required by the deployed image."

From d4fcaa9e84a56ca47162afd8714506adbbfab277 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 21:59:27 -0500
Subject: [PATCH 71/77] Fix USING:

---
 core/cpu/x86/architecture/architecture.factor | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index f0ca47a1ba..0b67ef7eb3 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.compiler arrays
-cpu.x86.assembler cpu.architecture kernel kernel.private math
-memory namespaces sequences words generator generator.registers
-generator.fixup system layouts combinators compiler.constants
-math.order ;
+cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
+kernel kernel.private math memory namespaces sequences words
+generator generator.registers generator.fixup system layouts
+combinators compiler.constants math.order ;
 IN: cpu.x86.architecture
 
 HOOK: ds-reg cpu

From d0cb65956617ed26a82c61c6eda12d441c20e98d Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 23:21:06 -0500
Subject: [PATCH 72/77] Update docs

---
 core/checksums/checksums-docs.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor
index c352f02af4..9196008ba6 100644
--- a/core/checksums/checksums-docs.factor
+++ b/core/checksums/checksums-docs.factor
@@ -48,4 +48,5 @@ $nl
 { $subsection "checksums.crc32" }
 { $vocab-subsection "MD5 checksum" "checksums.md5" }
 { $vocab-subsection "SHA1 checksum" "checksums.sha1" }
-{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } ;
+{ $vocab-subsection "SHA2 checksum" "checksums.sha2" }
+{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } ;

From fb605aadadc894cd571e1f5f1da776c543a46236 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Thu, 8 May 2008 23:21:46 -0500
Subject: [PATCH 73/77] Simpler write barrier

---
 core/cpu/ppc/intrinsics/intrinsics.factor     | 17 ++++-----
 core/cpu/x86/32/32.factor                     |  5 ++-
 core/cpu/x86/64/64.factor                     |  5 ++-
 core/cpu/x86/architecture/architecture.factor |  3 +-
 core/cpu/x86/intrinsics/intrinsics.factor     |  2 +-
 vm/Config.unix                                |  4 +-
 vm/data_gc.c                                  | 37 ++++++++++++++-----
 vm/data_gc.h                                  | 25 +++++++------
 8 files changed, 60 insertions(+), 38 deletions(-)

diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 95af9e4b4b..d85c70577e 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -61,20 +61,17 @@ IN: cpu.ppc.intrinsics
 
 : %write-barrier ( -- )
     "val" get operand-immediate? "obj" get fresh-object? or [
+        "scratch1" operand card-mark LI
+
         ! Mark the card
-        "obj" operand "scratch" operand card-bits SRWI
         "val" operand load-cards-offset
-        "scratch" operand dup "val" operand ADD
-        "val" operand "scratch" operand 0 LBZ
-        "val" operand dup card-mark ORI
-        "val" operand "scratch" operand 0 STB
+        "obj" operand "scratch2" operand card-bits SRWI
+        "val" operand "scratch2" operand "val" operand STBX
 
         ! Mark the card deck
-        "obj" operand "scratch" operand deck-bits SRWI
         "val" operand load-decks-offset
-        "scratch" operand dup "val" operand ADD
-        card-mark "val" operand LI
-        "val" operand "scratch" operand 0 STB
+        "obj" operand "scratch" operand deck-bits SRWI
+        "val" operand "scratch" operand "val" operand STBX
     ] unless ;
 
 \ set-slot {
@@ -82,7 +79,7 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-literal-known-tag STW %write-barrier ] H{
             { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "scratch" } } }
+            { +scratch+ { { f "scratch1" } { f "scratch2" } } }
             { +clobber+ { "val" } }
         }
     }
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 50e38f2082..9ef8177cf3 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -22,8 +22,9 @@ M: x86.32 temp-reg-2 ECX ;
 
 M: temp-reg v>operand drop EBX ;
 
-M: x86.32 %alien-invoke ( symbol dll -- )
-    (CALL) rel-dlsym ;
+M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
+
+M: x86.32 %alien-invoke (CALL) rel-dlsym ;
 
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index 5f396e7751..9c44a6a656 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -130,7 +130,10 @@ M: x86.64 %prepare-box-struct ( size -- )
 
 M: x86.64 %prepare-var-args RAX RAX XOR ;
 
-M: x86.64 %alien-invoke ( symbol dll -- )
+M: x86.64 %alien-global
+    [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
+
+M: x86.64 %alien-invoke
     0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
 
 M: x86.64 %prepare-alien-indirect ( -- )
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 0b67ef7eb3..88881b19a8 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -63,8 +63,7 @@ M: x86 %prologue ( n -- )
 M: x86 %epilogue ( n -- )
     stack-reg swap ADD ;
 
-: %alien-global ( symbol dll register -- )
-    [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
+HOOK: %alien-global cpu ( symbol dll register -- )
 
 M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index db303982ba..667f08c053 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -66,7 +66,7 @@ IN: cpu.x86.intrinsics
         ! Mark the card
         "obj" operand card-bits SHR
         "cards_offset" f temp-reg v>operand %alien-global
-        temp-reg v>operand "obj" operand [+] card-mark  OR
+        temp-reg v>operand "obj" operand [+] card-mark  MOV
 
         ! Mark the card deck
         "obj" operand deck-bits card-bits - SHR
diff --git a/vm/Config.unix b/vm/Config.unix
index e7b19e96e1..a25d0df95e 100644
--- a/vm/Config.unix
+++ b/vm/Config.unix
@@ -1,4 +1,6 @@
-CFLAGS += -fomit-frame-pointer
+ifndef DEBUG
+	CFLAGS += -fomit-frame-pointer
+endif
 
 EXE_SUFFIX =
 DLL_PREFIX = lib
diff --git a/vm/data_gc.c b/vm/data_gc.c
index aed2cef4d1..f44b8a7a05 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -24,6 +24,7 @@ CELL init_zone(F_ZONE *z, CELL size, CELL start)
 void init_card_decks(void)
 {
 	CELL start = data_heap->segment->start & ~(DECK_SIZE - 1);
+	allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
 	cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
 	decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
 }
@@ -64,6 +65,9 @@ F_DATA_HEAP *alloc_data_heap(CELL gens,
 	data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
 
 	CELL cards_size = (total_size + DECK_SIZE) / CARD_SIZE;
+	data_heap->allot_markers = safe_malloc(cards_size);
+	data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
+
 	data_heap->cards = safe_malloc(cards_size);
 	data_heap->cards_end = data_heap->cards + cards_size;
 
@@ -109,6 +113,7 @@ void dealloc_data_heap(F_DATA_HEAP *data_heap)
 	dealloc_segment(data_heap->segment);
 	free(data_heap->generations);
 	free(data_heap->semispaces);
+	free(data_heap->allot_markers);
 	free(data_heap->cards);
 	free(data_heap->decks);
 	free(data_heap);
@@ -122,8 +127,7 @@ void clear_cards(CELL from, CELL to)
 	F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
 	F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
 	F_CARD *ptr;
-	for(ptr = first_card; ptr < last_card; ptr++)
-		*ptr = CARD_BASE_MASK; /* invalid value */
+	for(ptr = first_card; ptr < last_card; ptr++) *ptr = 0;
 }
 
 void clear_decks(CELL from, CELL to)
@@ -132,8 +136,16 @@ void clear_decks(CELL from, CELL to)
 	F_CARD *first_deck = ADDR_TO_CARD(data_heap->generations[to].start);
 	F_CARD *last_deck = ADDR_TO_CARD(data_heap->generations[from].end);
 	F_CARD *ptr;
-	for(ptr = first_deck; ptr < last_deck; ptr++)
-		*ptr = 0;
+	for(ptr = first_deck; ptr < last_deck; ptr++) *ptr = 0;
+}
+
+void clear_allot_markers(CELL from, CELL to)
+{
+	/* NOTE: reverse order due to heap layout. */
+	F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
+	F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
+	F_CARD *ptr;
+	for(ptr = first_card; ptr < last_card; ptr++) *ptr = CARD_BASE_MASK;
 }
 
 void set_data_heap(F_DATA_HEAP *data_heap_)
@@ -142,6 +154,8 @@ void set_data_heap(F_DATA_HEAP *data_heap_)
 	nursery = data_heap->generations[NURSERY];
 	init_card_decks();
 	clear_cards(NURSERY,TENURED);
+	clear_decks(NURSERY,TENURED);
+	clear_allot_markers(NURSERY,TENURED);
 }
 
 void gc_reset(void)
@@ -290,7 +304,7 @@ CELL next_object(void)
 
 	if(heap_scan_ptr >= data_heap->generations[TENURED].here)
 		return F;
-	
+
 	type = untag_header(value);
 	heap_scan_ptr += untagged_object_size(heap_scan_ptr);
 
@@ -312,17 +326,16 @@ DEFINE_PRIMITIVE(end_scan)
 /* Scan all the objects in the card */
 void collect_card(F_CARD *ptr, CELL gen, CELL here)
 {
-	F_CARD c = *ptr;
-	CELL offset = (c & CARD_BASE_MASK);
+	CELL offset = CARD_OFFSET(ptr);
 
 	if(offset != CARD_BASE_MASK)
 	{
 		CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
 		CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-	
+
 		while(card_scan < card_end && card_scan < here)
 			card_scan = collect_next(card_scan);
-	
+
 		cards_scanned++;
 	}
 }
@@ -658,6 +671,8 @@ void reset_generations(CELL from, CELL to)
 		reset_generation(i);
 
 	clear_cards(from,to);
+	clear_decks(from,to);
+	clear_allot_markers(from,to);
 }
 
 /* Prepare to start copying reachable objects into an unused zone */
@@ -682,6 +697,8 @@ void begin_gc(CELL requested_bytes)
 		reset_generation(collecting_gen);
 		newspace = &data_heap->generations[collecting_gen];
 		clear_cards(collecting_gen,collecting_gen);
+		clear_decks(collecting_gen,collecting_gen);
+		clear_allot_markers(collecting_gen,collecting_gen);
 	}
 	else
 	{
@@ -891,7 +908,7 @@ DEFINE_PRIMITIVE(become)
 		critical_error("bad parameters to become",0);
 
 	CELL i;
-	
+
 	for(i = 0; i < capacity; i++)
 	{
 		CELL old_obj = array_nth(old_objects,i);
diff --git a/vm/data_gc.h b/vm/data_gc.h
index c1023b8043..20692c14e6 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -44,6 +44,9 @@ typedef struct {
 	F_ZONE *generations;
 	F_ZONE* semispaces;
 
+	CELL *allot_markers;
+	CELL *allot_markers_end;
+
 	CELL *cards;
 	CELL *cards_end;
 
@@ -75,6 +78,7 @@ offset within the card */
 #define ADDR_CARD_MASK (CARD_SIZE-1)
 
 DLLEXPORT CELL cards_offset;
+DLLEXPORT CELL allot_markers_offset;
 
 #define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
 #define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<> DECK_BITS) + decks_offset)
-#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset)<> CARD_BITS) + allot_markers_offset)
+#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
+
 void init_card_decks(void);
 
 /* this is an inefficient write barrier. compiled definitions use a more
@@ -101,11 +108,8 @@ any time we are potentially storing a pointer from an older generation
 to a younger one */
 INLINE void write_barrier(CELL address)
 {
-	F_CARD *c = ADDR_TO_CARD(address);
-	*c |= CARD_MARK_MASK;
-
-	F_DECK *d = ADDR_TO_DECK(address);
-	*d = CARD_MARK_MASK ;
+	*ADDR_TO_CARD(address) = CARD_MARK_MASK;
+	*ADDR_TO_DECK(address) = CARD_MARK_MASK;
 }
 
 #define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
@@ -119,11 +123,10 @@ INLINE void set_slot(CELL obj, CELL slot, CELL value)
 /* we need to remember the first object allocated in the card */
 INLINE void allot_barrier(CELL address)
 {
-	F_CARD *ptr = ADDR_TO_CARD(address);
-	F_CARD c = *ptr;
-	CELL b = (c & CARD_BASE_MASK);
-	CELL a = (address & ADDR_CARD_MASK);
-	*ptr = ((c & CARD_MARK_MASK) | ((b < a) ? b : a));
+	F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
+	F_CARD b = *ptr;
+	F_CARD a = (address & ADDR_CARD_MASK);
+	*ptr = (b < a ? b : a);
 }
 
 void clear_cards(CELL from, CELL to);

From b1566be8448a392ebcdaa9c6dc62426bb456bb53 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos 
Date: Fri, 9 May 2008 09:05:52 -0500
Subject: [PATCH 74/77] time: Update docs and stack effect for 'benchmark'

---
 extra/tools/time/time-docs.factor | 3 ++-
 extra/tools/time/time.factor      | 2 +-
 2 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/extra/tools/time/time-docs.factor b/extra/tools/time/time-docs.factor
index c0afa920c4..5fedba1700 100644
--- a/extra/tools/time/time-docs.factor
+++ b/extra/tools/time/time-docs.factor
@@ -14,7 +14,8 @@ ARTICLE: "timing" "Timing code"
 ABOUT: "timing"
 
 HELP: benchmark
-{ $values { "quot" "a quotation" } { "gctime" "an integer denoting milliseconds" } { "runtime" "an integer denoting milliseconds" } }
+{ $values { "quot" "a quotation" }
+          { "runtime" "an integer denoting milliseconds" } }
 { $description "Runs a quotation, measuring the total wall clock time and the total time spent in the garbage collector." }
 { $notes "A nicer word for interactive use is " { $link time } "." } ;
 
diff --git a/extra/tools/time/time.factor b/extra/tools/time/time.factor
index 0a0121c74e..82d3491743 100644
--- a/extra/tools/time/time.factor
+++ b/extra/tools/time/time.factor
@@ -4,7 +4,7 @@ USING: kernel math math.vectors memory io io.styles prettyprint
 namespaces system sequences splitting assocs strings ;
 IN: tools.time
 
-: benchmark ( quot -- gctime runtime )
+: benchmark ( quot -- runtime )
     millis >r call millis r> - ; inline
 
 : simple-table. ( values -- )

From 83c4f87a2fdfdd36c725f89b4d72873078fe4ae1 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos 
Date: Fri, 9 May 2008 09:11:46 -0500
Subject: [PATCH 75/77] builder: Update for new 'benchmark' effect

---
 extra/builder/test/test.factor | 4 ++--
 extra/builder/util/util.factor | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor
index 957af28dc1..0bf8922a27 100644
--- a/extra/builder/test/test.factor
+++ b/extra/builder/test/test.factor
@@ -26,8 +26,8 @@ IN: builder.test
 
 : do-all ( -- )
   bootstrap-time get   "../boot-time" utf8 [ . ] with-file-writer
-  [ do-load  ] runtime "../load-time" utf8 [ . ] with-file-writer
-  [ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
+  [ do-load  ] benchmark "../load-time" utf8 [ . ] with-file-writer
+  [ do-tests ] benchmark "../test-time" utf8 [ . ] with-file-writer
   do-help-lint
   do-benchmarks ;
 
diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor
index c40efaaa04..5eac98d3bc 100644
--- a/extra/builder/util/util.factor
+++ b/extra/builder/util/util.factor
@@ -12,7 +12,7 @@ IN: builder.util
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: runtime ( quot -- time ) benchmark nip ;
+: runtime ( quot -- time ) benchmark ;
 
 : minutes>ms ( min -- ms ) 60 * 1000 * ;
 

From 3f1a2224b1168a327016d892bbf4751b973ef11e Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos 
Date: Fri, 9 May 2008 10:00:24 -0500
Subject: [PATCH 76/77] builder.test: minor fix

---
 extra/builder/test/test.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor
index 0bf8922a27..2a0769f278 100644
--- a/extra/builder/test/test.factor
+++ b/extra/builder/test/test.factor
@@ -3,6 +3,7 @@ USING: kernel namespaces assocs
        io.files io.encodings.utf8 prettyprint 
        help.lint
        benchmark
+       tools.time
        bootstrap.stage2
        tools.test tools.vocabs
        builder.util ;

From 8babbe05d9b56d3aacb257b34c0aeb8a42de809b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos 
Date: Fri, 9 May 2008 14:36:33 -0500
Subject: [PATCH 77/77] builder.util: Remove 'runtime' (use benchmark instead)

---
 extra/builder/util/util.factor | 2 --
 1 file changed, 2 deletions(-)

diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor
index 5eac98d3bc..f9ab6c1d1d 100644
--- a/extra/builder/util/util.factor
+++ b/extra/builder/util/util.factor
@@ -12,8 +12,6 @@ IN: builder.util
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: runtime ( quot -- time ) benchmark ;
-
 : minutes>ms ( min -- ms ) 60 * 1000 * ;
 
 : file>string ( file -- string ) utf8 file-contents ;