From abc1e0d35b407fdd8fbdeee41ecddab5c60e0b06 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 25 Feb 2008 16:48:11 -0600
Subject: [PATCH 1/9] UI thread cleanup
---
core/threads/threads.factor | 37 ++++++++++++++++++++-----------
extra/ogg/player/player.factor | 2 +-
extra/ui/cocoa/cocoa.factor | 2 +-
extra/ui/cocoa/views/views.factor | 1 -
extra/ui/ui-docs.factor | 2 +-
extra/ui/ui.factor | 31 +++++++++++++++++---------
extra/ui/windows/windows.factor | 10 ++++-----
extra/ui/x11/x11.factor | 2 +-
8 files changed, 53 insertions(+), 34 deletions(-)
mode change 100644 => 100755 extra/ui/cocoa/views/views.factor
diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index 490c8dc740..e045f15bdb 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -86,6 +86,13 @@ PRIVATE>
f over set-thread-state
check-registered 2array run-queue push-front ;
+: sleep-time ( -- ms/f )
+ {
+ { [ run-queue dlist-empty? not ] [ 0 ] }
+ { [ sleep-queue heap-empty? ] [ f ] }
+ { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
+ } cond ;
+
<PRIVATE
: schedule-sleep ( thread ms -- )
@@ -106,23 +113,27 @@ PRIVATE>
[ ] while
drop ;
-: next ( -- )
+: next ( -- * )
expire-sleep-loop
- run-queue pop-back
- dup array? [ first2 ] [ f swap ] if dup set-self
- f over set-thread-state
- thread-continuation box>
- continue-with ;
+ 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
+ ] [
+ pop-back
+ dup array? [ first2 ] [ f swap ] if dup set-self
+ f over set-thread-state
+ thread-continuation box>
+ continue-with
+ ] if ;
PRIVATE>
-: sleep-time ( -- ms/f )
- {
- { [ run-queue dlist-empty? not ] [ 0 ] }
- { [ sleep-queue heap-empty? ] [ f ] }
- { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
- } cond ;
-
: stop ( -- )
self dup thread-exit-handler call
unregister-thread next ;
diff --git a/extra/ogg/player/player.factor b/extra/ogg/player/player.factor
index 3307e921b8..e24cee748e 100755
--- a/extra/ogg/player/player.factor
+++ b/extra/ogg/player/player.factor
@@ -149,7 +149,7 @@ HINTS: yuv>rgb byte-array byte-array ;
dup player-gadget [
dup { player-td player-yuv } get-slots theora_decode_YUVout drop
dup player-rgb over player-yuv yuv>rgb
- dup player-gadget relayout yield
+ dup player-gadget relayout-1 yield
] when ;
: num-audio-buffers-processed ( player -- player n )
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index b719556cba..572e798bd0 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
: event-loop ( -- )
event-loop? [
[
- [ NSApp do-events ui-step ui-wait ] ui-try
+ [ NSApp do-events ui-wait ] ui-try
] with-autorelease-pool event-loop
] when ;
diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor
old mode 100644
new mode 100755
index feac09ffc4..5ab3ec28f3
--- a/extra/ui/cocoa/views/views.factor
+++ b/extra/ui/cocoa/views/views.factor
@@ -298,7 +298,6 @@ CLASS: {
[
[
2drop dup view-dim swap window set-gadget-dim
- ui-step
] ui-try
]
}
diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor
index 9b3a05e101..1b1e9d99f3 100755
--- a/extra/ui/ui-docs.factor
+++ b/extra/ui/ui-docs.factor
@@ -167,7 +167,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
{ $subsection start-ui }
"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down."
$nl
-"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-step } ", which performs pending layout and sleeps for 10 milliseconds." ;
+"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
ARTICLE: "ui-backend-windows" "UI backend window management"
"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor
index adff223bc7..276bd3ec2a 100755
--- a/extra/ui/ui.factor
+++ b/extra/ui/ui.factor
@@ -130,14 +130,31 @@ SYMBOL: ui-hook
: notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ;
-: ui-step ( -- )
+: update-ui ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ;
: ui-wait ( -- )
10 sleep ;
+: ui-try ( quot -- ) [ ui-error ] recover ;
+
+: ui-running ( quot -- )
+ t \ ui-running set-global
+ [ f \ ui-running set-global ] [ ] cleanup ; inline
+
+: ui-thread-running? ( -- ? )
+ ui-thread get-global self eq? \ ui-running get-global and ;
+
+: update-ui-loop ( -- )
+ ui-thread-running?
+ [ [ update-ui ] ui-try f sleep-until update-ui-loop ] when ;
+
+: start-ui-thread ( -- )
+ [ self ui-thread set-global update-ui-loop ]
+ "UI update" spawn drop ;
+
: open-world-window ( world -- )
- dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
+ dup pref-dim over set-gadget-dim dup relayout graft ;
: open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r>
@@ -158,16 +175,12 @@ M: object close-window
find-world [ ungraft ] when* ;
: start-ui ( -- )
- self ui-thread set-global
+ start-ui-thread
restore-windows? [
restore-windows
] [
init-ui ui-hook get call
- ] if ui-step ;
-
-: ui-running ( quot -- )
- t \ ui-running set-global
- [ f \ ui-running set-global ] [ ] cleanup ; inline
+ ] if update-ui ;
: ui-running? ( -- ? )
\ ui-running get-global ;
@@ -185,5 +198,3 @@ MAIN: ui
f windows set-global
ui-hook [ ui ] with-variable
] if ;
-
-: ui-try ( quot -- ) [ ui-error ] recover ;
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index b7040c875d..45da2706f4 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -85,12 +85,12 @@ SYMBOL: mouse-captured
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
#! only paint if width/height both > 0
- 3drop window draw-world ;
+ 3drop window relayout-1 ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
+ dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
@@ -353,14 +353,12 @@ M: windows-ui-backend (close-window)
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
- { [ dup peek-message? ] [
- >r [ ui-step ui-wait ] ui-try
- r> event-loop
- ] }
+ { [ dup peek-message? ] [ ui-wait event-loop ] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
{ [ t ] [
dup TranslateMessage drop
dup DispatchMessage drop
+ yield
event-loop
] }
} cond ;
diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor
index d56bd8e119..1fec668717 100755
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@@ -178,7 +178,7 @@ M: world client-event
next-event dup
None XFilterEvent zero? [ drop wait-event ] unless
] [
- ui-step ui-wait wait-event
+ ui-wait wait-event
] if ;
: do-events ( -- )
From 438f00a6a5d10f59d20a8f44a8a320e24d79e149 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 25 Feb 2008 17:19:34 -0600
Subject: [PATCH 2/9] UI fixes
---
extra/concurrency/conditions/conditions.factor | 2 +-
extra/ui/gadgets/gadgets.factor | 15 ++++++++++-----
extra/ui/tools/listener/listener.factor | 2 +-
extra/ui/ui.factor | 14 ++++++--------
4 files changed, 18 insertions(+), 15 deletions(-)
diff --git a/extra/concurrency/conditions/conditions.factor b/extra/concurrency/conditions/conditions.factor
index 359ceaa9ae..b10aded671 100755
--- a/extra/concurrency/conditions/conditions.factor
+++ b/extra/concurrency/conditions/conditions.factor
@@ -8,7 +8,7 @@ IN: concurrency.conditions
dup dlist-empty? [ drop ] [ pop-back resume-now ] if ;
: notify-all ( dlist -- )
- [ resume-now ] dlist-slurp yield ;
+ [ resume-now ] dlist-slurp ;
: queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index 3db3b9c270..c6cb5bc14a 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -2,9 +2,18 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists
-models threads ;
+models threads concurrency.messaging ;
IN: ui.gadgets
+SYMBOL: ui-thread
+
+: notify-ui-thread ( -- )
+ self ui-thread get-global eq? [
+ "notify" ui-thread get-global send
+ ] unless ;
+
+: stop-ui-thread ( -- ) "stop" ui-thread get-global send ;
+
TUPLE: rect loc dim ;
C: <rect> rect
@@ -178,10 +187,6 @@ M: array gadget-text*
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
-SYMBOL: ui-thread
-
-: notify-ui-thread ( -- ) ui-thread get interrupt ;
-
: layout-queue ( -- queue ) \ layout-queue get ;
: layout-later ( gadget -- )
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index d828471609..7617b0f32d 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -133,7 +133,7 @@ M: stack-display tool-scroller
: restart-listener ( listener -- )
dup com-end dup clear-output
- [ init-namespaces listener-thread ] curry
+ [ listener-thread ] curry
"Listener" spawn drop ;
: init-listener ( listener -- )
diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor
index 276bd3ec2a..1bd84df518 100755
--- a/extra/ui/ui.factor
+++ b/extra/ui/ui.factor
@@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
-hashtables ;
+hashtables concurrency.messaging ;
IN: ui
! Assoc mapping aliens to gadgets
@@ -142,16 +142,14 @@ SYMBOL: ui-hook
t \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline
-: ui-thread-running? ( -- ? )
- ui-thread get-global self eq? \ ui-running get-global and ;
-
: update-ui-loop ( -- )
- ui-thread-running?
- [ [ update-ui ] ui-try f sleep-until update-ui-loop ] when ;
+ receive { { "notify" [ ] } { "stop" [ stop ] } } case
+ [ update-ui ] ui-try
+ update-ui-loop ;
: start-ui-thread ( -- )
- [ self ui-thread set-global update-ui-loop ]
- "UI update" spawn drop ;
+ [ update-ui-loop ]
+ "UI update" spawn ui-thread set-global ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ;
From 1013db07c40929d4bb962f520776889fc72da86a Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 25 Feb 2008 18:39:27 -0600
Subject: [PATCH 3/9] builder: a few fixes and cleanups
---
extra/builder/builder.factor | 25 +++++++++++--------------
extra/builder/release/release.factor | 6 ++++++
extra/builder/util/util.factor | 6 +++++-
3 files changed, 22 insertions(+), 15 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 4cd2613e8d..2b51f8603e 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -65,12 +65,6 @@ IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! : factor-binary ( -- name )
-! os "macosx" =
-! [ "./Factor.app/Contents/MacOS/factor" ]
-! [ "./factor" ]
-! if ;
-
: bootstrap-cmd ( -- cmd )
{ "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
@@ -146,7 +140,11 @@ SYMBOL: build-status
show-benchmark-deltas
- "../benchmarks" "../../benchmarks" copy-file
+ "../benchmarks" "../../benchmarks" copy-file
+
+ ".." cd
+
+ maybe-release
] with-file-writer
@@ -167,7 +165,7 @@ SYMBOL: builder-recipients
builder-from get >>from
builder-recipients get >>to
subject >>subject
- "../report" file>string >>body
+ "./report" file>string >>body
send ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -176,11 +174,11 @@ SYMBOL: builder-recipients
{ "bzip2" my-boot-image-name } to-strings run-process drop ;
: build ( -- )
- [ (build) ] [ drop ] recover
- build-status get [ maybe-release ] when
+ [ (build) ] failsafe
+ builds cd stamp> cd
[ send-builder-email ] [ drop "not sending mail" . ] recover
- ".." cd { "rm" "-rf" "factor" } run-process drop
- [ compress-image ] [ drop ] recover ;
+ { "rm" "-rf" "factor" } run-process drop
+ [ compress-image ] failsafe ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -215,8 +213,7 @@ USE: bootstrap.image.download
[ build ]
when
]
- [ drop ]
- recover
+ failsafe
5 minutes sleep
build-loop ;
diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor
index eb947ff14f..403ead78cd 100644
--- a/extra/builder/release/release.factor
+++ b/extra/builder/release/release.factor
@@ -64,6 +64,8 @@ USING: system sequences splitting ;
: linux-release ( -- )
+ "factor" cd
+
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
@@ -78,6 +80,8 @@ USING: system sequences splitting ;
: windows-release ( -- )
+ "factor" cd
+
{ "rm" "-rf" "Factor.app" } run-process drop
{ "rm" "-rf" common-files } to-strings run-process drop
@@ -92,6 +96,8 @@ USING: system sequences splitting ;
: macosx-release ( -- )
+ "factor" cd
+
{ "rm" "-rf" common-files } to-strings run-process drop
".." cd
diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor
index 3d699d4ba8..a838eced6d 100644
--- a/extra/builder/util/util.factor
+++ b/extra/builder/util/util.factor
@@ -104,4 +104,8 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
USE: prettyprint
-: to-file ( object file -- ) [ . ] with-file-writer ;
\ No newline at end of file
+: to-file ( object file -- ) [ . ] with-file-writer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: failsafe ( quot -- ) [ drop ] recover ;
\ No newline at end of file
From 84016a36c0f1da46f26efe6eee08194c708b0289 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 25 Feb 2008 19:37:43 -0600
Subject: [PATCH 4/9] Regression fixes
---
core/compiler/tests/curry.factor | 4 +-
core/compiler/tests/float.factor | 2 +-
core/compiler/tests/intrinsics.factor | 13 +++--
core/compiler/tests/simple.factor | 2 +-
core/compiler/tests/tuples.factor | 2 +-
core/compiler/units/units.factor | 9 +--
core/inference/state/state-tests.factor | 2 +-
core/optimizer/optimizer-tests.factor | 2 +-
core/parser/parser.factor | 2 +-
core/words/words-tests.factor | 8 ++-
extra/cocoa/cocoa-tests.factor | 3 +-
extra/concurrency/flags/flags.factor | 21 +++++++
extra/concurrency/mailboxes/mailboxes.factor | 2 +-
extra/html/elements/elements.factor | 4 +-
extra/io/unix/unix-tests.factor | 60 +++++++++-----------
extra/ui/gadgets/gadgets.factor | 11 +---
extra/ui/tools/search/search.factor | 5 +-
extra/ui/ui.factor | 31 ++++++----
18 files changed, 103 insertions(+), 80 deletions(-)
create mode 100644 extra/concurrency/flags/flags.factor
diff --git a/core/compiler/tests/curry.factor b/core/compiler/tests/curry.factor
index 77ac01e101..982b3cfb75 100755
--- a/core/compiler/tests/curry.factor
+++ b/core/compiler/tests/curry.factor
@@ -1,5 +1,5 @@
-USING: tools.test compiler quotations math kernel sequences
-assocs namespaces ;
+USING: tools.test quotations math kernel sequences
+assocs namespaces compiler.units ;
IN: temporary
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
diff --git a/core/compiler/tests/float.factor b/core/compiler/tests/float.factor
index 10d3baea9b..11470f7102 100755
--- a/core/compiler/tests/float.factor
+++ b/core/compiler/tests/float.factor
@@ -1,5 +1,5 @@
IN: temporary
-USING: compiler kernel kernel.private memory math
+USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index 5dfe447443..d1e6f7abf4 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/core/compiler/tests/intrinsics.factor
@@ -1,10 +1,11 @@
IN: temporary
-USING: arrays compiler kernel kernel.private math math.constants
-math.private sequences strings tools.test words continuations
-sequences.private hashtables.private byte-arrays strings.private
-system random layouts vectors.private sbufs.private
-strings.private slots.private alien alien.accessors
-alien.c-types alien.syntax namespaces libc sequences.private ;
+USING: arrays compiler.units kernel kernel.private math
+math.constants math.private sequences strings tools.test words
+continuations sequences.private hashtables.private byte-arrays
+strings.private system random layouts vectors.private
+sbufs.private strings.private slots.private alien
+alien.accessors alien.c-types alien.syntax namespaces libc
+sequences.private ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor
index 6deed6c756..7f23e28bec 100755
--- a/core/compiler/tests/simple.factor
+++ b/core/compiler/tests/simple.factor
@@ -1,4 +1,4 @@
-USING: compiler tools.test kernel kernel.private
+USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory ;
IN: temporary
diff --git a/core/compiler/tests/tuples.factor b/core/compiler/tests/tuples.factor
index a23b6739ad..7acd599cb8 100755
--- a/core/compiler/tests/tuples.factor
+++ b/core/compiler/tests/tuples.factor
@@ -1,5 +1,5 @@
IN: temporary
-USING: kernel tools.test compiler ;
+USING: kernel tools.test compiler.units ;
TUPLE: color red green blue ;
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 9f1976bec4..9849ddca7d 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables ;
+vocabs definitions hashtables init ;
IN: compiler.units
SYMBOL: old-definitions
@@ -37,12 +37,13 @@ SYMBOL: recompile-hook
SYMBOL: definition-observers
-definition-observers global [ V{ } like ] change-at
-
GENERIC: definitions-changed ( assoc obj -- )
+[ V{ } clone definition-observers set-global ]
+"compiler.units" add-init-hook
+
: add-definition-observer ( obj -- )
- definition-observers get push-new ;
+ definition-observers get push ;
: remove-definition-observer ( obj -- )
definition-observers get delete ;
diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor
index e9c31171ed..02a3c4fde0 100644
--- a/core/inference/state/state-tests.factor
+++ b/core/inference/state/state-tests.factor
@@ -1,5 +1,5 @@
IN: temporary
-USING: tools.test inference.state ;
+USING: tools.test inference.state words ;
SYMBOL: a
SYMBOL: b
diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor
index 66d3956dba..c63787ad52 100755
--- a/core/optimizer/optimizer-tests.factor
+++ b/core/optimizer/optimizer-tests.factor
@@ -1,4 +1,4 @@
-USING: arrays compiler generic hashtables inference kernel
+USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index bc129041e5..63d3f2e45f 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -468,7 +468,7 @@ SYMBOL: interactive-vocabs
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2 diff
- [ nip define-symbol ] assoc-each ;
+ [ nip dup reset-generic define-symbol ] assoc-each ;
: forget-smudged ( -- )
smudged-usage forget-all
diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor
index f29d21cd9f..63e30178f5 100755
--- a/core/words/words-tests.factor
+++ b/core/words/words-tests.factor
@@ -1,6 +1,6 @@
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
-vocabs continuations tuples compiler.units ;
+vocabs continuations tuples compiler.units io.streams.string ;
IN: temporary
[ 4 ] [
@@ -156,11 +156,13 @@ SYMBOL: quot-uses-b
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
[ ] [
- "IN: temporary GENERIC: symbol-generic" eval
+ "IN: temporary GENERIC: symbol-generic" <string-reader>
+ "symbol-generic-test" parse-stream drop
] unit-test
[ ] [
- "IN: temporary TUPLE: symbol-generic ;" eval
+ "IN: temporary TUPLE: symbol-generic ;" <string-reader>
+ "symbol-generic-test" parse-stream drop
] unit-test
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test
diff --git a/extra/cocoa/cocoa-tests.factor b/extra/cocoa/cocoa-tests.factor
index 1f94c051b7..44f0b50996 100644
--- a/extra/cocoa/cocoa-tests.factor
+++ b/extra/cocoa/cocoa-tests.factor
@@ -1,6 +1,7 @@
IN: temporary
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
-compiler kernel namespaces cocoa.classes tools.test memory ;
+compiler kernel namespaces cocoa.classes tools.test memory
+compiler.units ;
CLASS: {
{ +superclass+ "NSObject" }
diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor
new file mode 100644
index 0000000000..d4e60d63ee
--- /dev/null
+++ b/extra/concurrency/flags/flags.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: boxes kernel threads ;
+IN: concurrency.flags
+
+TUPLE: flag value? thread ;
+
+: <flag> ( -- flag ) f <box> flag construct-boa ;
+
+: raise-flag ( flag -- )
+ dup flag-value? [
+ dup flag-thread ?box
+ [ resume ] [ drop t over set-flag-value? ] if
+ ] unless drop ;
+
+: lower-flag ( flag -- )
+ dup flag-value? [
+ f swap set-flag-value?
+ ] [
+ [ flag-thread >box ] curry "flag" suspend drop
+ ] if ;
diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor
index e5f12d5507..adfb5bac0a 100755
--- a/extra/concurrency/mailboxes/mailboxes.factor
+++ b/extra/concurrency/mailboxes/mailboxes.factor
@@ -15,7 +15,7 @@ TUPLE: mailbox threads data ;
: mailbox-put ( obj mailbox -- )
[ mailbox-data push-front ] keep
- mailbox-threads notify-all ;
+ mailbox-threads notify-all yield ;
: block-unless-pred ( pred mailbox timeout -- )
2over mailbox-data dlist-contains? [
diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor
index 101bc423b5..4f9a052032 100644
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@@ -87,14 +87,14 @@ SYMBOL: html
#! word.
foo> [ ">" write-html ] empty-effect html-word ;
-: </foo> [ "</" % % ">" % ] "" make ;
+: </foo> "</" swap ">" 3append ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup [ write-html ] curry empty-effect html-word ;
-: <foo/> [ "<" % % "/>" % ] "" make ;
+: <foo/> "<" swap "/>" 3append ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor
index 6eb0b78955..af7417854e 100755
--- a/extra/io/unix/unix-tests.factor
+++ b/extra/io/unix/unix-tests.factor
@@ -4,12 +4,12 @@ sequences prettyprint system ;
IN: temporary
! Unix domain stream sockets
-[
- [
- "unix-domain-socket-test" resource-path delete-file
- ] ignore-errors
+: socket-server "unix-domain-socket-test" temp-file ;
- "unix-domain-socket-test" resource-path <local>
+[
+ [ socket-server delete-file ] ignore-errors
+
+ socket-server <local>
<server> [
stdio get accept [
"Hello world" print flush
@@ -17,14 +17,14 @@ IN: temporary
] with-stream
] with-stream
- "unix-domain-socket-test" resource-path delete-file
+ socket-server delete-file
] "Test" spawn drop
yield
[ { "Hello world" "FOO" } ] [
[
- "unix-domain-socket-test" resource-path <local> <client>
+ socket-server <local> <client>
[
readln ,
"XYZ" print flush
@@ -33,17 +33,16 @@ yield
] { } make
] unit-test
-! Unix domain datagram sockets
-[
- "unix-domain-datagram-test" resource-path delete-file
-] ignore-errors
+: datagram-server "unix-domain-datagram-test" temp-file ;
+: datagram-client "unix-domain-datagram-test-2" temp-file ;
-: server-addr "unix-domain-datagram-test" temp-file <local> ;
-: client-addr "unix-domain-datagram-test-2" temp-file <local> ;
+! Unix domain datagram sockets
+[ datagram-server delete-file ] ignore-errors
+[ datagram-client delete-file ] ignore-errors
[
[
- server-addr <datagram> "d" set
+ datagram-server <local> <datagram> "d" set
"Receive 1" print
@@ -67,58 +66,53 @@ yield
"Done" print
- "unix-domain-datagram-test" resource-path delete-file
+ datagram-server delete-file
] with-scope
] "Test" spawn drop
yield
-[
- "unix-domain-datagram-test-2" resource-path delete-file
-] ignore-errors
+[ datagram-client delete-file ] ignore-errors
-client-addr <datagram>
+datagram-client <local> <datagram>
"d" set
[ ] [
"hello" >byte-array
- server-addr
+ datagram-server <local>
"d" get send
] unit-test
[ "olleh" t ] [
"d" get receive
- server-addr =
+ datagram-server <local> =
>r >string r>
] unit-test
[ ] [
"hello" >byte-array
- server-addr
+ datagram-server <local>
"d" get send
] unit-test
[ "hello world" t ] [
"d" get receive
- server-addr =
+ datagram-server <local> =
>r >string r>
] unit-test
[ ] [ "d" get dispose ] unit-test
! Test error behavior
+: another-datagram "unix-domain-datagram-test-3" temp-file ;
-[
- "unix-domain-datagram-test-3" resource-path delete-file
-] ignore-errors
+[ another-datagram delete-file ] ignore-errors
-"unix-domain-datagram-test-2" temp-file delete-file
+datagram-client delete-file
-[ ] [ client-addr <datagram> "d" set ] unit-test
+[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
-[
- B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
-] must-fail
+[ B{ 1 2 3 } another-datagram <local> "d" get send ] must-fail
[ ] [ "d" get dispose ] unit-test
@@ -126,7 +120,7 @@ client-addr <datagram>
[ "d" get receive ] must-fail
-[ B{ 1 2 } server-addr "d" get send ] must-fail
+[ B{ 1 2 } datagram-server <local> "d" get send ] must-fail
! Invalid parameter tests
@@ -140,7 +134,7 @@ client-addr <datagram>
[
image [
- B{ 1 2 } server-addr
+ B{ 1 2 } datagram-server <local>
stdio get send
] with-file-reader
] must-fail
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index c6cb5bc14a..ed3631bca5 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -2,17 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists
-models threads concurrency.messaging ;
+models threads concurrency.flags ;
IN: ui.gadgets
-SYMBOL: ui-thread
+SYMBOL: ui-notify-flag
-: notify-ui-thread ( -- )
- self ui-thread get-global eq? [
- "notify" ui-thread get-global send
- ] unless ;
-
-: stop-ui-thread ( -- ) "stop" ui-thread get-global send ;
+: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
TUPLE: rect loc dim ;
diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor
index 8041db3c77..b37b4ca707 100755
--- a/extra/ui/tools/search/search.factor
+++ b/extra/ui/tools/search/search.factor
@@ -7,7 +7,7 @@ source-files definitions strings tools.completion tools.crossref
tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
-tools.browser unicode.case calendar ;
+tools.browser unicode.case calendar ui ;
IN: ui.tools.search
TUPLE: live-search field list ;
@@ -45,7 +45,8 @@ search-field H{
} set-gestures
: <search-model> ( producer -- model )
- >r g live-search-field gadget-model 1/5 seconds <delay>
+ >r g live-search-field gadget-model
+ ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
: <search-list> ( seq limited? presenter -- gadget )
diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor
index 1bd84df518..477fffe6af 100755
--- a/extra/ui/ui.factor
+++ b/extra/ui/ui.factor
@@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.messaging ;
+hashtables concurrency.flags ;
IN: ui
! Assoc mapping aliens to gadgets
@@ -138,18 +138,25 @@ SYMBOL: ui-hook
: ui-try ( quot -- ) [ ui-error ] recover ;
+SYMBOL: ui-thread
+
: ui-running ( quot -- )
t \ ui-running set-global
[ f \ ui-running set-global ] [ ] cleanup ; inline
+: ui-running? ( -- ? )
+ \ ui-running get-global ;
+
: update-ui-loop ( -- )
- receive { { "notify" [ ] } { "stop" [ stop ] } } case
- [ update-ui ] ui-try
- update-ui-loop ;
+ ui-running? ui-thread get-global self eq? [
+ ui-notify-flag get lower-flag
+ [ update-ui ] ui-try
+ update-ui-loop
+ ] when ;
: start-ui-thread ( -- )
- [ update-ui-loop ]
- "UI update" spawn ui-thread set-global ;
+ [ self ui-thread set-global update-ui-loop ]
+ "UI update" spawn drop ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup relayout graft ;
@@ -173,17 +180,17 @@ M: object close-window
find-world [ ungraft ] when* ;
: start-ui ( -- )
- start-ui-thread
restore-windows? [
restore-windows
] [
init-ui ui-hook get call
- ] if update-ui ;
+ ] if
+ notify-ui-thread start-ui-thread ;
-: ui-running? ( -- ? )
- \ ui-running get-global ;
-
-[ f \ ui-running set-global ] "ui" add-init-hook
+[
+ f \ ui-running set-global
+ <flag> ui-notify-flag set-global
+] "ui" add-init-hook
HOOK: ui ui-backend ( -- )
From fc1cd5080054c386feeedf7dc7a5f331f8e772c7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 25 Feb 2008 20:09:44 -0600
Subject: [PATCH 5/9] Cleanup
---
extra/io/sockets/impl/impl.factor | 2 +-
extra/smtp/smtp.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor
index d7ac18ee20..77e8e098b1 100755
--- a/extra/io/sockets/impl/impl.factor
+++ b/extra/io/sockets/impl/impl.factor
@@ -53,7 +53,7 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
SYMBOL: port-override
-: (port) port-override get [ ] [ ] ?if ;
+: (port) port-override get swap or ;
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index c74a6e72fb..184bd0c1cc 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -114,7 +114,7 @@ LOG: smtp-response DEBUG
: extract-email ( recepient -- email )
#! This could be much smarter.
- " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ;
+ " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
: message-id ( -- string )
[
From 4ee8a0cfa679de701d7530fa1e6110d0ed6157db Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 25 Feb 2008 20:09:52 -0600
Subject: [PATCH 6/9] Better code heap
---
vm/code_heap.c | 2 +-
vm/factor.c | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 4113e8abc8..e55188c6a8 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -229,7 +229,7 @@ CELL allot_code_block(CELL size)
/* Insufficient room even after code GC, give up */
if(start == 0)
- critical_error("Out of memory in add-compiled-block",0);
+ fatal_error("Out of memory in add-compiled-block",0);
}
return start;
diff --git a/vm/factor.c b/vm/factor.c
index 826ad65324..20667a23f5 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -19,7 +19,7 @@ void default_parameters(F_PARAMETERS *p)
p->rs_size = 32 * CELLS;
p->gen_count = 3;
- p->code_size = 4 * CELLS;
+ p->code_size = 8 * CELLS;
p->young_size = 2 * CELLS;
p->aging_size = 4 * CELLS;
#endif
From 15587627a3f24a4666af1f41161ba03c35ce58e7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 25 Feb 2008 20:17:16 -0600
Subject: [PATCH 7/9] Fix issue where refresh-all/load-everything would
sometimes try to load a vocab more than once
---
core/vocabs/loader/loader.factor | 41 +++++++++++++++-----------------
1 file changed, 19 insertions(+), 22 deletions(-)
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 2d53ed82e2..8bdd9b902f 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -153,16 +153,18 @@ SYMBOL: load-help?
[ load-error. nl ] each ;
SYMBOL: blacklist
+SYMBOL: failures
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
+ V{ } clone failures set
[
[ require ]
- [ >r vocab-name r> 2array blacklist get push ]
+ [ swap vocab-name failures get set-at ]
recover
] each
- blacklist get
+ failures get
] with-compiler-errors ;
: do-refresh ( modified-sources modified-docs -- )
@@ -176,12 +178,17 @@ SYMBOL: blacklist
: refresh-all ( -- ) "" refresh ;
GENERIC: (load-vocab) ( name -- vocab )
-!
+
+: add-to-blacklist ( error vocab -- )
+ vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
+
M: vocab (load-vocab)
- dup vocab-root [
- dup vocab-source-loaded? [ dup load-source ] unless
- dup vocab-docs-loaded? [ dup load-docs ] unless
- ] when ;
+ [
+ dup vocab-root [
+ dup vocab-source-loaded? [ dup load-source ] unless
+ dup vocab-docs-loaded? [ dup load-docs ] unless
+ ] when
+ ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ;
@@ -189,24 +196,14 @@ M: string (load-vocab)
M: vocab-link (load-vocab)
vocab-name (load-vocab) ;
-TUPLE: blacklisted-vocab name ;
-
-: blacklisted-vocab ( name -- * )
- \ blacklisted-vocab construct-boa throw ;
-
-M: blacklisted-vocab error.
- "This vocabulary depends on the " write
- blacklisted-vocab-name write
- " vocabulary which failed to load" print ;
-
[
- dup vocab-name blacklist get key? [
- vocab-name blacklisted-vocab
+ dup vocab-name blacklist get at* [
+ rethrow
] [
- [
- dup vocab [ ] [ ] ?if (load-vocab)
- ] with-compiler-errors
+ drop
+ [ dup vocab swap or (load-vocab) ] with-compiler-errors
] if
+
] load-vocab-hook set-global
: vocab-where ( vocab -- loc )
From 7902018b720340c3dabbb7d812b912c6c80c3694 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.internal.stack-effects.com>
Date: Mon, 25 Feb 2008 21:33:07 -0600
Subject: [PATCH 8/9] Handbook update
---
extra/concurrency/flags/flags-docs.factor | 33 +++++++++++++++++++++++
extra/help/handbook/handbook.factor | 4 ++-
2 files changed, 36 insertions(+), 1 deletion(-)
create mode 100644 extra/concurrency/flags/flags-docs.factor
diff --git a/extra/concurrency/flags/flags-docs.factor b/extra/concurrency/flags/flags-docs.factor
new file mode 100644
index 0000000000..cf37715c5c
--- /dev/null
+++ b/extra/concurrency/flags/flags-docs.factor
@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: concurrency.flags
+
+HELP: flag
+{ $class-description "A flag allows one thread to notify another when a condition is satisfied." } ;
+
+HELP: <flag>
+{ $values { "flag" flag } }
+{ $description "Creates a new flag." } ;
+
+HELP: raise-flag
+{ $values { "flag" flag } }
+{ $description "Raises a flag, notifying any threads waiting on it. Does nothing if the flag has already been raised." } ;
+
+HELP: lower-flag
+{ $values { "flag" flag } }
+{ $description "Attempts to lower a flag. If the flag has been raised previously, returns immediately, otherwise waits for it to be raised first." } ;
+
+ARTICLE: "concurrency.flags" "Flags"
+"A " { $emphasis "flag" } " is a condition notification device which can be in one of two states: " { $emphasis "lowered" } " (the initial state) or " { $emphasis "raised" } "."
+$nl
+"The flag can be raised at any time; raising a raised flag does nothing. Lowering a flag if the flag has not been raised, it first waits for it to be raised."
+$nl
+"Essentially, a flag can be thought of as a counting semaphore where the count never goes above one."
+{ $subsection flag }
+{ $subsection flag? }
+"Raising and lowering flags:"
+{ $subsection raise-flag }
+{ $subsection lower-flag } ;
+
+ABOUT: "concurrency.flags"
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index f12e0180b1..422d7ef1e8 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -86,7 +86,8 @@ concurrency.futures
concurrency.locks
concurrency.semaphores
concurrency.count-downs
-concurrency.exchangers ;
+concurrency.exchangers
+concurrency.flags ;
ARTICLE: "concurrency" "Concurrency"
"Factor supports a variety of concurrency abstractions, however they are mostly used to multiplex input/output operations since the thread scheduling is co-operative and only one CPU is used at a time."
@@ -106,6 +107,7 @@ $nl
{ $subsection "concurrency.semaphores" }
{ $subsection "concurrency.count-downs" }
{ $subsection "concurrency.exchangers" }
+{ $subsection "concurrency.flags" }
"Other concurrency abstractions include " { $vocab-link "concurrency.distributed" } " and " { $vocab-link "channels" } "." ;
ARTICLE: "objects" "Objects"
From 18a96f87ee2e43e210ff128d346e5ec90482fa9f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 25 Feb 2008 22:24:15 -0600
Subject: [PATCH 9/9] builder.release: fix bug
---
extra/builder/release/release.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor
index 403ead78cd..c65241d922 100644
--- a/extra/builder/release/release.factor
+++ b/extra/builder/release/release.factor
@@ -126,8 +126,8 @@ USING: system sequences splitting ;
: release? ( -- ? )
{
- "../load-everything-vocabs"
- "../test-all-vocabs"
+ "./load-everything-vocabs"
+ "./test-all-vocabs"
}
[ eval-file empty? ]
all? ;