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

Makefile

@@ -145,7 +145,8 @@ wince-arm:
 
 macosx.app: factor
 	mkdir -p $(BUNDLE)/Contents/MacOS
-	cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
+	mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
+	ln -s Factor.app/Contents/MacOS/factor ./factor
 	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
 
 	install_name_tool \

core/compiler/units/units.factor

@@ -42,7 +42,7 @@ definition-observers global [ V{ } like ] change-at
 GENERIC: definitions-changed ( assoc obj -- )
 
 : add-definition-observer ( obj -- )
-    definition-observers get push ;
+    definition-observers get push-new ;
 
 : remove-definition-observer ( obj -- )
     definition-observers get delete ;

core/threads/threads-docs.factor

@@ -19,8 +19,7 @@ ARTICLE: "threads-yield" "Yielding and suspending threads"
 { $subsection yield }
 "Sleeping for a period of time:"
 { $subsection sleep }
-"Interruptible sleep:"
+"Interrupting sleep:"
-{ $subsection nap }
 { $subsection interrupt }
 "Threads can be suspended and woken up at some point in the future when a condition is satisfied:"
 { $subsection suspend }
@@ -106,14 +105,17 @@ HELP: stop
 HELP: yield
 { $description "Adds the current thread to the end of the run queue, and switches to the next runnable thread." } ;
 
+HELP: sleep-until
+{ $values { "time/f" "a non-negative integer or " { $link f } } }
+{ $description "Suspends the current thread until the given time, or indefinitely if a value of " { $link f } " is passed in."
+$nl
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
+
 HELP: sleep
 { $values { "ms" "a non-negative integer" } }
-{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." }
+{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds."
-{ $errors "Throws an error if another thread interrupted the sleep with " { $link interrupt } "." } ;
+$nl
-
+"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
-HELP: nap
-{ $values { "ms/f" "a non-negative integer or " { $link f } } { "?" "a boolean indicating whether the thread was interrupted" } }
-{ $description "Suspends the current thread until another thread interrupts it with " { $link interrupt } ". If the input parameter is not " { $link f } ", then the thread will also wake up if the timeout expires before an interrupt is received." } ;
 
 HELP: interrupt
 { $values { "thread" thread } }

core/threads/threads.factor

@@ -75,12 +75,15 @@ PRIVATE>
 : sleep-queue 43 getenv ;
 
 : resume ( thread -- )
+    f over set-thread-state
     check-registered run-queue push-front ;
 
 : resume-now ( thread -- )
+    f over set-thread-state
     check-registered run-queue push-back ;
 
 : resume-with ( obj thread -- )
+    f over set-thread-state
     check-registered 2array run-queue push-front ;
 
 <PRIVATE
@@ -131,34 +134,27 @@ PRIVATE>
         self swap call next
     ] callcc1 2nip ; inline
 
-: yield ( -- ) [ resume ] "yield" suspend drop ;
+: yield ( -- ) [ resume ] f suspend drop ;
 
-GENERIC: nap-until ( time -- ? )
+GENERIC: sleep-until ( time/f -- )
 
-M: integer nap-until [ schedule-sleep ] curry "sleep" suspend ;
+M: integer sleep-until
+    [ schedule-sleep ] curry "sleep" suspend drop ;
 
-M: f nap-until drop [ drop ] "interrupt" suspend ;
+M: f sleep-until
+    drop [ drop ] "interrupt" suspend drop ;
 
-GENERIC: nap ( time -- ? )
+GENERIC: sleep ( ms -- )
 
-M: real nap millis + >integer nap-until ;
+M: real sleep
-
+    millis + >integer sleep-until ;
-M: f nap nap-until ;
-
-: sleep-until ( time -- )
-    nap-until [ "Sleep interrupted" throw ] when ;
-
-: sleep ( time -- )
-    nap [ "Sleep interrupted" throw ] when ;
 
 : interrupt ( thread -- )
-    dup self eq? [
+    dup thread-state [
-        drop
-    ] [
         dup thread-sleep-entry [ sleep-queue heap-delete ] when*
         f over set-thread-sleep-entry
-        t swap resume-with
+        dup resume
-    ] if ;
+    ] when drop ;
 
 : (spawn) ( thread -- )
     [
@@ -204,6 +200,7 @@ M: f nap nap-until ;
     initial-thread global
     [ drop f "Initial" [ die ] <thread> ] cache
     <box> over set-thread-continuation
+    f over set-thread-state
     dup register-thread
     set-self ;
 

extra/alarms/alarms.factor

@@ -62,7 +62,7 @@ SYMBOL: alarm-thread
 
 : alarm-thread-loop ( -- )
     alarms get-global
-    dup next-alarm nap-until drop
+    dup next-alarm sleep-until
     dup trigger-alarms
     alarm-thread-loop ;
 

extra/calendar/calendar.factor

@@ -473,9 +473,9 @@ M: timestamp year. ( timestamp -- )
 : seconds-since-midnight ( timestamp -- x )
     dup beginning-of-day timestamp- ;
 
-M: timestamp nap-until timestamp>millis nap-until ;
+M: timestamp sleep-until timestamp>millis sleep-until ;
 
-M: dt nap from-now nap-until ;
+M: dt sleep from-now sleep-until ;
 
 {
     { [ unix? ] [ "calendar.unix" ] }

extra/io/windows/launcher/launcher.factor

@@ -146,8 +146,8 @@ M: windows-io kill-process* ( handle -- )
 
 : wait-loop ( -- )
     processes get dup assoc-empty?
-    [ drop f nap drop ]
+    [ drop f sleep-until ]
-    [ wait-for-processes [ 100 nap drop ] when ] if ;
+    [ wait-for-processes [ 100 sleep ] when ] if ;
 
 SYMBOL: wait-thread
 

extra/ogg/player/player.factor

@@ -14,7 +14,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
        sequences libc shuffle alien.c-types system openal math
        namespaces threads shuffle opengl arrays ui.gadgets.worlds
        combinators math.parser ui.gadgets ui.render opengl.gl ui
-       continuations io.files hints combinators.lib sequences.lib ;
+       continuations io.files hints combinators.lib sequences.lib debugger ;
 
 IN: ogg.player
 
@@ -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 find-world draw-world
+        dup player-gadget relayout yield
     ] when ;
 
 : num-audio-buffers-processed ( player -- player n )
@@ -177,7 +177,7 @@ HINTS: yuv>rgb byte-array byte-array ;
 : append-audio ( player -- player bool )
     num-audio-buffers-processed {
         { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
-        { [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] }
+        { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
         { [ t ] [ fill-processed-audio-buffer t ] }
     } cond ;
 
@@ -602,8 +602,7 @@ M: theora-gadget draw-gadget* ( gadget -- )
     parse-remaining-headers
     initialize-decoder
     dup player-gadget [ initialize-gui ] when*
-    [ decode ] [ drop ] recover
+    [ decode ] try
-!    decode
     wait-for-sound
     cleanup
     drop ;

extra/tools/threads/threads.factor

@@ -8,7 +8,10 @@ heaps.private system math math.parser ;
 : thread. ( thread -- )
     dup thread-id pprint-cell
     dup thread-name over [ write-object ] with-cell
-    dup thread-state "running" or [ write ] with-cell
+    dup thread-state [
+        [ dup self eq? "running" "yield" ? ] unless*
+        write
+    ] with-cell
     [
         thread-sleep-entry [
             entry-key millis [-] number>string write

extra/ui/cocoa/cocoa.factor

@@ -19,7 +19,7 @@ SYMBOL: stop-after-last-window?
 : event-loop ( -- )
     event-loop? [
         [
-            [ NSApp do-events ui-step 10 sleep ] ui-try
+            [ NSApp do-events ui-step ui-wait ] ui-try
         ] with-autorelease-pool event-loop
     ] when ;
 

extra/ui/gadgets/gadgets.factor

@@ -2,7 +2,7 @@
 ! 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 ;
+models threads ;
 IN: ui.gadgets
 
 TUPLE: rect loc dim ;
@@ -178,13 +178,17 @@ 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 -- )
     #! When unit testing gadgets without the UI running, the
     #! invalid queue is not initialized and we simply ignore
     #! invalidation requests.
-    layout-queue [ push-front ] [ drop ] if* ;
+    layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
 
 DEFER: relayout
 
@@ -256,11 +260,11 @@ M: gadget layout* drop ;
 
 : queue-graft ( gadget -- )
     { f t } over set-gadget-graft-state
-    graft-queue push-front ;
+    graft-queue push-front notify-ui-thread ;
 
 : queue-ungraft ( gadget -- )
     { t f } over set-gadget-graft-state
-    graft-queue push-front ;
+    graft-queue push-front notify-ui-thread ;
 
 : graft-later ( gadget -- )
     dup gadget-graft-state {

extra/ui/ui.factor

@@ -133,6 +133,9 @@ SYMBOL: ui-hook
 : ui-step ( -- )
     [ notify-queued layout-queued redraw-worlds ] assert-depth ;
 
+: ui-wait ( -- )
+    10 sleep ;
+
 : open-world-window ( world -- )
     dup pref-dim over set-gadget-dim dup relayout graft ui-step ;
 
@@ -155,6 +158,7 @@ M: object close-window
     find-world [ ungraft ] when* ;
 
 : start-ui ( -- )
+    self ui-thread set-global
     restore-windows? [
         restore-windows
     ] [

extra/ui/windows/windows.factor

@@ -15,8 +15,11 @@ TUPLE: windows-ui-backend ;
 : lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
 
 : enum-clipboard ( -- seq )
-    0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ]
+    0
-    { } unfold nip ;
+    [ EnumClipboardFormats win32-error dup dup 0 > ]
+    [ ]
+    [ drop ]
+    unfold nip ;
 
 : with-clipboard ( quot -- )
     f OpenClipboard win32-error=0/f
@@ -40,13 +43,12 @@ TUPLE: windows-ui-backend ;
 : copy ( str -- )
     lf>crlf [
         string>u16-alien
-        f OpenClipboard win32-error=0/f
         EmptyClipboard win32-error=0/f
         GMEM_MOVEABLE over length 1+ GlobalAlloc
             dup win32-error=0/f
     
         dup GlobalLock dup win32-error=0/f
-        rot dup length memcpy
+        swapd byte-array>memory
         dup GlobalUnlock win32-error=0/f
         CF_UNICODETEXT swap SetClipboardData win32-error=0/f
     ] with-clipboard ;
@@ -72,31 +74,29 @@ SYMBOL: mouse-captured
 : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
 : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
 
-: adjust-RECT ( RECT -- )
-    style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
-
-: make-RECT ( width height -- RECT )
-    "RECT" <c-object> [ set-RECT-bottom ] keep [ set-RECT-right ] keep ;
-
-: make-adjusted-RECT ( width height -- RECT )
-    make-RECT dup adjust-RECT ;
-
-: get-RECT-dimensions ( RECT -- width height )
-    [ RECT-right ] keep [ RECT-left - ] keep
-    [ RECT-bottom ] keep RECT-top - ;
-
 : get-RECT-top-left ( RECT -- x y )
     [ RECT-left ] keep RECT-top ;
 
+: get-RECT-dimensions ( RECT -- x y width height )
+    [ get-RECT-top-left ] keep
+    [ RECT-right ] keep [ RECT-left - ] keep
+    [ RECT-bottom ] keep RECT-top - ;
+
 : handle-wm-paint ( hWnd uMsg wParam lParam -- )
     #! wParam and lParam are unused
     #! only paint if width/height both > 0
     3drop window draw-world ;
 
 : handle-wm-size ( hWnd uMsg wParam lParam -- )
-    [ lo-word ] keep hi-word make-RECT get-RECT-dimensions 2array 2nip
+    2nip
+    [ lo-word ] keep hi-word 2array
     dup { 0 0 } = [ 2drop ] [ swap window set-gadget-dim ui-step ] if ;
 
+: handle-wm-move ( hWnd uMsg wParam lParam -- )
+    2nip
+    [ lo-word ] keep hi-word 2array
+    swap window set-world-loc ;
+
 : wm-keydown-codes ( -- key )
     H{
         { 8 "BACKSPACE" }
@@ -240,7 +240,7 @@ M: windows-ui-backend (close-window)
 
 : mouse-absolute>relative ( lparam handle -- array )
     >r >lo-hi r>
-    0 0 make-RECT [ GetWindowRect win32-error=0/f ] keep
+    "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
     get-RECT-top-left 2array v- ;
 
 : mouse-event>gesture ( uMsg -- button )
@@ -317,6 +317,7 @@ M: windows-ui-backend (close-window)
                 { [ dup WM_PAINT = ]
                       [ drop 4dup handle-wm-paint DefWindowProc ] }
                 { [ dup WM_SIZE = ]      [ drop handle-wm-size 0 ] }
+                { [ dup WM_MOVE = ]      [ drop handle-wm-move 0 ] }
 
                 ! Keyboard events
                 { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
@@ -353,7 +354,7 @@ M: windows-ui-backend (close-window)
     {
         { [ windows get empty? ] [ drop ] }
         { [ dup peek-message? ] [
-            >r [ ui-step 10 sleep ] ui-try
+            >r [ ui-step ui-wait ] ui-try
             r> event-loop
         ] }
         { [ dup MSG-message WM_QUIT = ] [ drop ] }
@@ -383,13 +384,26 @@ M: windows-ui-backend (close-window)
         RegisterClassEx dup win32-error=0/f
     ] when ;
 
-: create-window ( width height -- hwnd )
+: adjust-RECT ( RECT -- )
+    style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+
+: make-RECT ( world -- RECT )
+    dup world-loc { 40 40 } vmax dup rot rect-dim v+
+    "RECT" <c-object>
+    over first over set-RECT-right
+    swap second over set-RECT-bottom
+    over first over set-RECT-left
+    swap second over set-RECT-top ;
+
+: make-adjusted-RECT ( rect -- RECT )
+    make-RECT dup adjust-RECT ;
+
+: create-window ( rect -- hwnd )
     make-adjusted-RECT
     >r class-name-ptr get-global f r>
     >r >r >r ex-style r> r>
         { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
-        CW_USEDEFAULT dup r>
+    r> get-RECT-dimensions
-    get-RECT-dimensions
     f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
 
 : show-window ( hWnd -- )
@@ -424,7 +438,7 @@ M: windows-ui-backend (close-window)
     get-dc dup setup-pixel-format dup get-rc ;
 
 M: windows-ui-backend (open-window) ( world -- )
-    [ rect-dim first2 create-window dup setup-gl ] keep
+    [ create-window dup setup-gl ] keep
     [ f <win> ] keep
     [ swap win-hWnd register-window ] 2keep
     dupd set-world-handle
@@ -445,8 +459,8 @@ M: windows-ui-backend raise-window* ( world -- )
 M: windows-ui-backend set-title ( string world -- )
     world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep
     dup win-title [ free ] when*
-    >r malloc-u16-string r>
+    >r malloc-u16-string dup r>
-    dupd set-win-title alien-address
+    set-win-title alien-address
     SendMessage drop ;
 
 M: windows-ui-backend ui

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 10 sleep wait-event
+        ui-step ui-wait wait-event
     ] if ;
 
 : do-events ( -- )