From 517671fad00035ca4b272d1128849974229e55be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 27 Apr 2008 03:16:12 -0500
Subject: [PATCH 01/11] 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 [ <promise> ] 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
+
<PRIVATE
: schedule-sleep ( thread ms -- )
@@ -110,36 +112,54 @@ PRIVATE>
[ ] 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 )
<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 ;
+
+\ <interactor> must-infer
[
- \ <interactor> must-infer
-
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
@@ -13,6 +13,7 @@ tools.test kernel calendar parser ;
[ ] [ <promise> "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
+[ ] [ <pane> <pane-stream> <interactor> "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 <delay>
- swap set-interactor-help ;
-
-: init-interactor-history ( interactor -- )
- V{ } clone swap set-interactor-history ;
-
-: init-interactor-state ( interactor -- )
- <flag> over set-interactor-flag
- <box> swap set-interactor-thread ;
+: <help-model> ( interactor -- model )
+ editor-caret 1/3 seconds <delay> ;
: <interactor> ( output -- gadget )
<source-editor>
interactor construct-editor
- tuck set-interactor-output
- dup init-interactor-history
- dup init-interactor-state
- dup init-caret-help ;
+ V{ } clone >>history
+ <flag> >>flag
+ dup <help-model> >>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 ;
<scrolling-pane> g-> set-listener-gadget-output
<scroller> "Output" <labelled-gadget> 1 track, ;
-: listener-stream ( listener -- stream )
- dup listener-gadget-input
- swap listener-gadget-output <pane-stream>
- <duplex-stream> ;
+: <listener-stream> ( listener -- stream )
+ [ input>> ] [ output>> <pane-stream> ] bi <duplex-stream> ;
: <listener-input> ( listener -- gadget )
- listener-gadget-output <pane-stream> <interactor> ;
+ output>> <pane-stream> <interactor> ;
: listener-input, ( -- )
g <listener-input> 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 <listener-stream> [
+ [ [ 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 <model> 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 e82fb3b6dc3729fbe920b77c9e0ac42a9c760232 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Mon, 5 May 2008 19:52:56 -0500
Subject: [PATCH 02/11] 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 } } <interval-map> ] 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 ;
: <interval-map> ( 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 <microdan@gmail.com>
Date: Mon, 5 May 2008 23:46:51 -0500
Subject: [PATCH 03/11] 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 <microdan@gmail.com>
Date: Mon, 5 May 2008 23:47:22 -0500
Subject: [PATCH 04/11] 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
<PRIVATE
-VALUE: char>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+ <byte-array> 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 <interval-map> ;
: >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 <microdan@gmail.com>
Date: Tue, 6 May 2008 03:46:44 -0500
Subject: [PATCH 05/11] 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 <array> ] 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
-
-: <matrix> ( m n -- matrix )
- [ drop 0 <array> ] 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 <matrix> 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 <microdan@gmail.com>
Date: Tue, 6 May 2008 03:47:39 -0500
Subject: [PATCH 06/11] 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 53832ccd2f070c37349649e7f6f3ea884faf9c14 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 6 May 2008 09:01:28 -0500
Subject: [PATCH 07/11] 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 d1545ac9297b058832b74ad63085a503677e337f Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <microdan@gmail.com>
Date: Tue, 6 May 2008 15:51:34 -0500
Subject: [PATCH 08/11] 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
+<PRIVATE
+: levenshtein-step ( insert delete change same? -- next )
+ 0 1 ? + >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 <array> ] 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 ;
+<PRIVATE
TUPLE: trace-state old new table i j ;
: old-nth ( state -- elt )
@@ -86,9 +88,10 @@ TUPLE: trace-state old new table i j ;
: trace-diff ( old new table -- diff )
[ ] [ first length 1- ] [ length 1- ] tri trace-state boa
[ (trace-diff) ] { } make reverse ;
+PRIVATE>
: 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 <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 6 May 2008 21:23:07 -0500
Subject: [PATCH 09/11] 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 <count-down> r> keep await ; inline
: parallel-each ( seq quot -- )
- over length <count-down>
- [ [ >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 ;
: <count-down> ( 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-error
: ?linked dup linked-error? [ rethrow ] when ;
From 90299783d6d6edd49c6df30b17f041c59763660e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 6 May 2008 21:23:18 -0500
Subject: [PATCH 10/11] 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-reader*> ( 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> <encoder-duplex>
] with-destructors ;
-: with-fds ( input-fd output-fd quot -- )
- >r >r [ <reader> dup add-always-destructor ] [ input-stream get ] if* r> r> [
- >r [ <writer> dup add-always-destructor ] [ output-stream get ] if* r>
- with-output-stream*
- ] 2curry with-input-stream* ; inline
+<PRIVATE
-: <pipes> ( n -- pipes )
- [ (pipe) dup add-always-destructor ] replicate
- f f pipe boa [ prefix ] [ suffix ] bi
- 2 <clumps> ;
+: ?reader [ <reader> dup add-always-destructor ] [ input-stream get ] if* ;
+: ?writer [ <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- <pipes> ] 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 )
+: <pipes> ( n -- pipes )
+ [
+ [ (pipe) dup add-error-destructor ] replicate
+ T{ pipe } [ prefix ] [ suffix ] bi
+ 2 <clumps>
+ ] 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- <pipes> ] 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 <decoder> ] change
+ output-stream [ utf8 <encoder> ] change
input-stream get lines reverse [ print ] each f
]
"grep x"
From 732b84bcf9da5745163f7cbd5e2bbe75ab8e3498 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 6 May 2008 22:20:55 -0500
Subject: [PATCH 11/11] 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 <event-stream> >>handle ;
+ [let | path [ path normalize-path ] |
+ path mailbox macosx-monitor new-monitor
+ dup [ enqueue-notifications ] curry
+ path 1array 0 0 <event-stream> >>handle
+ ] ;
M: macosx-monitor dispose
handle>> dispose ;