Fixes
Slava Pestov
parent
0eda22fb5a
commit
666c7803f7
|
|
@ -64,7 +64,7 @@ M: object init-stdio
|
|||
stdin-handle stdout-handle <duplex-c-stream> stdio set-global
|
||||
stderr-handle <c-writer> <plain-writer> stderr set-global ;
|
||||
|
||||
M: object io-multiplex (sleep) ;
|
||||
M: object io-multiplex 60 60 * 1000 * or (sleep) ;
|
||||
|
||||
M: object <file-reader>
|
||||
"rb" fopen <c-reader> <line-reader> ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.thread
|
||||
USING: threads io.backend namespaces init ;
|
||||
USING: threads io.backend namespaces init math ;
|
||||
|
||||
: io-thread ( -- )
|
||||
sleep-time io-multiplex yield ;
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ PRIVATE>
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: sleep-time ( -- ms )
|
||||
: sleep-time ( -- ms/f )
|
||||
{
|
||||
{ [ run-queue dlist-empty? not ] [ 0 ] }
|
||||
{ [ sleep-queue heap-empty? ] [ f ] }
|
||||
|
|
@ -134,18 +134,21 @@ PRIVATE>
|
|||
: yield ( -- ) [ resume ] "yield" suspend drop ;
|
||||
|
||||
: nap ( ms/f -- ? )
|
||||
[
|
||||
>fixnum millis + [ schedule-sleep ] curry "sleep"
|
||||
] [
|
||||
[ drop ] "interrupt"
|
||||
] if* suspend ;
|
||||
[ >fixnum millis + [ schedule-sleep ] curry "sleep" ]
|
||||
[ [ drop ] "interrupt" ] if*
|
||||
suspend ;
|
||||
|
||||
: sleep ( ms -- )
|
||||
nap [ "Sleep interrupted" throw ] when ;
|
||||
|
||||
: interrupt ( thread -- )
|
||||
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
|
||||
t swap resume-with ;
|
||||
dup self eq? [
|
||||
drop
|
||||
] [
|
||||
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
|
||||
f over set-thread-sleep-entry
|
||||
t swap resume-with
|
||||
] if ;
|
||||
|
||||
: (spawn) ( thread -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: alarms
|
||||
USING: help.markup help.syntax calendar ;
|
||||
USING: help.markup help.syntax calendar quotations ;
|
||||
|
||||
HELP: alarm
|
||||
{ $class-description "An alarm. Cancel passed to " { $link cancel-alarm } "." } ;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,12 @@ TUPLE: alarm time interval quot entry ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: alarms
|
||||
SYMBOL: alarm-thread
|
||||
|
||||
: notify-alarm-thread ( -- )
|
||||
alarm-thread get-global interrupt ;
|
||||
|
||||
: check-alarm
|
||||
pick timestamp? [ "Not a timestamp" throw ] unless
|
||||
over dup dt? swap not or [ "Not a dt" throw ] unless
|
||||
|
|
@ -16,11 +22,10 @@ TUPLE: alarm time interval quot entry ;
|
|||
: <alarm> ( time delay quot -- alarm )
|
||||
check-alarm <box> alarm construct-boa ;
|
||||
|
||||
SYMBOL: alarms
|
||||
SYMBOL: alarm-thread
|
||||
|
||||
: notify-alarm-thread ( -- )
|
||||
alarm-thread get-global interrupt ;
|
||||
: register-alarm ( alarm -- )
|
||||
dup dup alarm-time alarms get-global heap-push*
|
||||
swap alarm-entry >box
|
||||
notify-alarm-thread ;
|
||||
|
||||
: alarm-expired? ( alarm now -- ? )
|
||||
>r alarm-time r> <=> 0 <= ;
|
||||
|
|
@ -28,7 +33,7 @@ SYMBOL: alarm-thread
|
|||
: reschedule-alarm ( alarm -- )
|
||||
dup alarm-time over alarm-interval +dt
|
||||
over set-alarm-time
|
||||
add-alarm drop ;
|
||||
register-alarm ;
|
||||
|
||||
: call-alarm ( alarm -- )
|
||||
dup alarm-quot try
|
||||
|
|
@ -52,10 +57,9 @@ SYMBOL: alarm-thread
|
|||
|
||||
: next-alarm ( alarms -- ms )
|
||||
dup heap-empty?
|
||||
[ drop f ] [
|
||||
heap-peek drop alarm-time now
|
||||
[ timestamp>unix-time ] 2apply [-] 1000 *
|
||||
] if ;
|
||||
[ drop f ]
|
||||
[ heap-peek drop alarm-time now timestamp- 1000 * 0 max ]
|
||||
if ;
|
||||
|
||||
: alarm-thread-loop ( -- )
|
||||
alarms get-global
|
||||
|
|
@ -73,11 +77,7 @@ SYMBOL: alarm-thread
|
|||
PRIVATE>
|
||||
|
||||
: add-alarm ( time frequency quot -- alarm )
|
||||
<alarm> [
|
||||
dup dup alarm-time alarms get-global heap-push*
|
||||
swap alarm-entry >box
|
||||
notify-alarm-thread
|
||||
] keep ;
|
||||
<alarm> [ register-alarm ] keep ;
|
||||
|
||||
: cancel-alarm ( alarm -- )
|
||||
alarm-entry box> alarms get-global heap-delete ;
|
||||
|
|
|
|||
|
|
@ -223,7 +223,13 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
|
||||
|
||||
: unix-1970 ( -- timestamp )
|
||||
1970 1 1 0 0 0 0 <timestamp> ; foldable
|
||||
1970 1 1 0 0 0 0 <timestamp> ;
|
||||
|
||||
: millis>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> 1000 /f seconds +dt ;
|
||||
|
||||
: timestamp>millis ( timestamp -- n )
|
||||
unix-1970 timestamp- 1000 * >integer ;
|
||||
|
||||
: unix-time>timestamp ( n -- timestamp )
|
||||
>r unix-1970 r> seconds +dt ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,6 @@ ARTICLE: "io.timeouts" "I/O timeout protocol"
|
|||
{ $subsection timed-out }
|
||||
"A combinator to be used in operations which can time out:"
|
||||
{ $subsection with-timeout }
|
||||
{ $see-also "stream-protocol" "io.launcher" }
|
||||
;
|
||||
{ $see-also "stream-protocol" "io.launcher" } ;
|
||||
|
||||
ABOUT: "io.timeouts"
|
||||
|
|
|
|||
|
|
@ -178,7 +178,7 @@ M: write-task do-io-task
|
|||
M: port port-flush ( port -- )
|
||||
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
M: unix-io io-multiplex ( ms -- )
|
||||
M: unix-io io-multiplex ( ms/f -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
||||
M: unix-io init-stdio ( -- )
|
||||
|
|
|
|||
|
|
@ -66,7 +66,8 @@ M: kqueue-mx unregister-io-task ( task mx -- )
|
|||
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
|
||||
|
||||
M: kqueue-mx wait-for-events ( ms mx -- )
|
||||
swap make-timespec dupd wait-kevent handle-kevents ;
|
||||
swap dup [ make-timespec ] when
|
||||
dupd wait-kevent handle-kevents ;
|
||||
|
||||
: make-proc-kevent ( pid -- kevent )
|
||||
"kevent" <c-object>
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
swap >r dup init-fdsets r> make-timeval
|
||||
swap >r dup init-fdsets r> dup [ make-timeval ] when
|
||||
select multiplexer-error
|
||||
dup read-fdset/tasks pick handle-fdset
|
||||
dup write-fdset/tasks rot handle-fdset ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,9 @@ IN: io.windows.ce.backend
|
|||
: port-errored ( port -- )
|
||||
win32-error-string swap set-port-error ;
|
||||
|
||||
M: windows-ce-io io-multiplex ( ms -- ) (sleep) ;
|
||||
M: windows-ce-io io-multiplex ( ms -- )
|
||||
60 60 * 1000 * or (sleep) ;
|
||||
|
||||
M: windows-ce-io add-completion ( handle -- ) drop ;
|
||||
|
||||
GENERIC: wince-read ( port port-handle -- )
|
||||
|
|
|
|||
|
|
@ -57,7 +57,8 @@ M: windows-nt-io add-completion ( handle -- )
|
|||
] "I/O" suspend 3drop ;
|
||||
|
||||
: wait-for-overlapped ( ms -- overlapped ? )
|
||||
>r master-completion-port get-global r> ! port ms
|
||||
>r master-completion-port get-global
|
||||
r> INFINITE or ! timeout
|
||||
0 <int> ! bytes
|
||||
f <void*> ! key
|
||||
f <void*> ! overlapped
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: help.syntax help.markup kernel math classes tuples ;
|
||||
USING: help.syntax help.markup kernel math classes tuples
|
||||
calendar ;
|
||||
IN: models
|
||||
|
||||
HELP: model
|
||||
|
|
@ -142,18 +143,18 @@ HELP: delay
|
|||
{ $examples
|
||||
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
|
||||
{ $code
|
||||
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
|
||||
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"
|
||||
": <funny-slider>"
|
||||
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
|
||||
"<funny-slider> dup gadget."
|
||||
"gadget-model 500 <delay> [ number>string ] <filter>"
|
||||
"gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
|
||||
"<label-control> gadget."
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <delay>
|
||||
{ $values { "model" model } { "timeout" "a positive integer" } { "delay" delay } }
|
||||
{ $description "Creates a new instance of " { $link delay } ". A timer of " { $snippet "timeout" } " milliseconds must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
|
||||
{ $values { "model" model } { "timeout" dt } { "delay" delay } }
|
||||
{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
|
||||
{ $examples "See the example in the documentation for " { $link delay } "." } ;
|
||||
|
||||
HELP: range-value
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generic kernel math sequences arrays assocs alarms ;
|
||||
USING: generic kernel math sequences arrays assocs alarms
|
||||
calendar ;
|
||||
IN: models
|
||||
|
||||
TUPLE: model value connections dependencies ref locked? ;
|
||||
|
|
@ -186,14 +187,14 @@ TUPLE: delay model timeout alarm ;
|
|||
[ add-dependency ] keep ;
|
||||
|
||||
: cancel-delay ( delay -- )
|
||||
delay-model-alarm [ cancel-alarm ] when* ;
|
||||
delay-alarm [ cancel-alarm ] when* ;
|
||||
|
||||
: start-delay ( delay -- )
|
||||
now over delay-model-timeout dt+ f
|
||||
now over delay-timeout +dt f
|
||||
pick [ f over set-delay-alarm update-delay-model ] curry
|
||||
add-alarm swap set-delay-model-alarm ;
|
||||
add-alarm swap set-delay-alarm ;
|
||||
|
||||
M: delay model-changed nip start-delay ;
|
||||
M: delay model-changed nip dup cancel-delay start-delay ;
|
||||
|
||||
M: delay model-activated update-delay-model ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: models sequences ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel ;
|
||||
ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel
|
||||
calendar ;
|
||||
IN: ui.gadgets.status-bar
|
||||
|
||||
: <status-bar> ( model -- gadget )
|
||||
100 <delay> [ "" like ] <filter> <label-control>
|
||||
1/10 seconds <delay> [ "" like ] <filter> <label-control>
|
||||
dup reverse-video-theme
|
||||
t over set-gadget-root? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs kernel math models namespaces
|
||||
sequences words strings system hashtables math.parser
|
||||
math.vectors tuples classes ui.gadgets combinators.lib ;
|
||||
math.vectors tuples classes ui.gadgets combinators.lib boxes
|
||||
calendar alarms ;
|
||||
IN: ui.gestures
|
||||
|
||||
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
|
||||
|
|
@ -113,7 +114,7 @@ SYMBOL: drag-timer
|
|||
|
||||
: start-drag-timer ( -- )
|
||||
hand-buttons get-global empty? [
|
||||
now 300 milliseconds dt+ 100 milliseconds
|
||||
now 300 milliseconds +dt 100 milliseconds
|
||||
[ drag-gesture ] add-alarm drag-timer get-global >box
|
||||
] when ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ math.vectors models namespaces parser prettyprint quotations
|
|||
sequences sequences.lib strings threads listener
|
||||
tuples ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
||||
definitions boxes ;
|
||||
definitions boxes calendar ;
|
||||
IN: ui.tools.interactor
|
||||
|
||||
TUPLE: interactor
|
||||
|
|
@ -29,7 +29,8 @@ help ;
|
|||
] if ;
|
||||
|
||||
: init-caret-help ( interactor -- )
|
||||
dup editor-caret 100 <delay> swap set-interactor-help ;
|
||||
dup editor-caret 1/3 seconds <delay>
|
||||
swap set-interactor-help ;
|
||||
|
||||
: init-interactor-history ( interactor -- )
|
||||
V{ } clone swap set-interactor-history ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs ui.tools.interactor ui.tools.listener
|
||||
ui.tools.workspace help help.topics io.files io.styles kernel
|
||||
|
|
@ -7,7 +7,7 @@ source-files 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 ;
|
||||
tools.browser unicode.case calendar ;
|
||||
IN: ui.tools.search
|
||||
|
||||
TUPLE: live-search field list ;
|
||||
|
|
@ -45,7 +45,7 @@ search-field H{
|
|||
} set-gestures
|
||||
|
||||
: <search-model> ( producer -- model )
|
||||
>r g live-search-field gadget-model 200 <delay>
|
||||
>r g live-search-field gadget-model 1/5 seconds <delay>
|
||||
[ "\n" join ] r> append <filter> ;
|
||||
|
||||
: <search-list> ( seq limited? presenter -- gadget )
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax alien.c-types arrays combinators
|
||||
io io.nonblocking kernel math namespaces parser prettyprint
|
||||
sequences windows.errors windows.types windows.kernel32 words ;
|
||||
kernel math namespaces parser prettyprint sequences
|
||||
windows.errors windows.types windows.kernel32 words ;
|
||||
IN: windows
|
||||
|
||||
: lo-word ( wparam -- lo ) <short> *short ; inline
|
||||
|
|
|
|||
Loading…
Reference in New Issue