Merge branch 'master' into no_literal_table
commit
69b4e8e2c3
|
@ -4,9 +4,23 @@ IN: alarms
|
||||||
HELP: alarm
|
HELP: alarm
|
||||||
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
|
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
|
||||||
|
|
||||||
|
HELP: current-alarm
|
||||||
|
{ $description "A symbol that contains the currently executing alarm, availble only to the alarm quotation. One use for this symbol is if a repeated alarm wishes to cancel itself from executing in the future."
|
||||||
|
}
|
||||||
|
{ $examples
|
||||||
|
{ $unchecked-example
|
||||||
|
"""USING: alarms calendar io threads ;"""
|
||||||
|
"""["""
|
||||||
|
""" "Hi, this should only get printed once..." print flush"""
|
||||||
|
""" current-alarm get cancel-alarm"""
|
||||||
|
"""] 1 seconds every"""
|
||||||
|
""
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
HELP: add-alarm
|
HELP: add-alarm
|
||||||
{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
|
{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
|
||||||
{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from the alarm thread." } ;
|
{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from a new thread spawned by the alarm thread. If a repeated alarm's quotation throws an exception, the alarm will not be rescheduled." } ;
|
||||||
|
|
||||||
HELP: later
|
HELP: later
|
||||||
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
|
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
|
||||||
|
@ -27,7 +41,7 @@ HELP: every
|
||||||
{ $values
|
{ $values
|
||||||
{ "quot" quotation } { "duration" duration }
|
{ "quot" quotation } { "duration" duration }
|
||||||
{ "alarm" alarm } }
|
{ "alarm" alarm } }
|
||||||
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." }
|
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency. If the quotation throws an exception that is not caught inside it, the alarm scheduler will cancel the alarm and will not reschedule it again." }
|
||||||
{ $examples
|
{ $examples
|
||||||
{ $unchecked-example
|
{ $unchecked-example
|
||||||
"USING: alarms io calendar ;"
|
"USING: alarms io calendar ;"
|
||||||
|
@ -44,6 +58,8 @@ ARTICLE: "alarms" "Alarms"
|
||||||
{ $subsections every }
|
{ $subsections every }
|
||||||
"Register a one-time alarm:"
|
"Register a one-time alarm:"
|
||||||
{ $subsections later }
|
{ $subsections later }
|
||||||
|
"The currently executing alarm:"
|
||||||
|
{ $subsections current-alarm }
|
||||||
"Low-level interface to add alarms:"
|
"Low-level interface to add alarms:"
|
||||||
{ $subsections add-alarm }
|
{ $subsections add-alarm }
|
||||||
"Cancelling an alarm:"
|
"Cancelling an alarm:"
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
|
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs boxes calendar
|
USING: accessors assocs boxes calendar combinators.short-circuit
|
||||||
combinators.short-circuit fry heaps init kernel math.order
|
continuations fry heaps init kernel math.order
|
||||||
namespaces quotations threads math system ;
|
namespaces quotations threads math system ;
|
||||||
IN: alarms
|
IN: alarms
|
||||||
|
|
||||||
|
@ -11,21 +11,27 @@ TUPLE: alarm
|
||||||
interval
|
interval
|
||||||
{ entry box } ;
|
{ entry box } ;
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
|
|
||||||
SYMBOL: alarms
|
SYMBOL: alarms
|
||||||
SYMBOL: alarm-thread
|
SYMBOL: alarm-thread
|
||||||
|
SYMBOL: current-alarm
|
||||||
|
|
||||||
|
: cancel-alarm ( alarm -- )
|
||||||
|
entry>> [ alarms get-global heap-delete ] if-box? ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: notify-alarm-thread ( -- )
|
: notify-alarm-thread ( -- )
|
||||||
alarm-thread get-global interrupt ;
|
alarm-thread get-global interrupt ;
|
||||||
|
|
||||||
: normalize-argument ( obj -- nanoseconds )
|
GENERIC: >nanoseconds ( obj -- duration/f )
|
||||||
>duration duration>nanoseconds >integer ;
|
M: f >nanoseconds ;
|
||||||
|
M: real >nanoseconds >integer ;
|
||||||
|
M: duration >nanoseconds duration>nanoseconds >integer ;
|
||||||
|
|
||||||
: <alarm> ( quot start interval -- alarm )
|
: <alarm> ( quot start interval -- alarm )
|
||||||
alarm new
|
alarm new
|
||||||
swap dup [ normalize-argument ] when >>interval
|
swap >nanoseconds >>interval
|
||||||
swap dup [ normalize-argument nano-count + ] when >>start
|
swap >nanoseconds nano-count + >>start
|
||||||
swap >>quot
|
swap >>quot
|
||||||
<box> >>entry ;
|
<box> >>entry ;
|
||||||
|
|
||||||
|
@ -43,7 +49,16 @@ SYMBOL: alarm-thread
|
||||||
: call-alarm ( alarm -- )
|
: call-alarm ( alarm -- )
|
||||||
[ entry>> box> drop ]
|
[ entry>> box> drop ]
|
||||||
[ dup interval>> [ reschedule-alarm ] [ drop ] if ]
|
[ dup interval>> [ reschedule-alarm ] [ drop ] if ]
|
||||||
[ quot>> "Alarm execution" spawn drop ] tri ;
|
[
|
||||||
|
[ ] [ quot>> ] [ ] tri
|
||||||
|
'[
|
||||||
|
_ current-alarm
|
||||||
|
[
|
||||||
|
_ [ _ dup interval>> [ cancel-alarm ] [ drop ] if rethrow ]
|
||||||
|
recover
|
||||||
|
] with-variable
|
||||||
|
] "Alarm execution" spawn drop
|
||||||
|
] tri ;
|
||||||
|
|
||||||
: (trigger-alarms) ( alarms n -- )
|
: (trigger-alarms) ( alarms n -- )
|
||||||
over heap-empty? [
|
over heap-empty? [
|
||||||
|
@ -87,6 +102,3 @@ PRIVATE>
|
||||||
: later ( quot duration -- alarm ) f add-alarm ;
|
: later ( quot duration -- alarm ) f add-alarm ;
|
||||||
|
|
||||||
: every ( quot duration -- alarm ) dup add-alarm ;
|
: every ( quot duration -- alarm ) dup add-alarm ;
|
||||||
|
|
||||||
: cancel-alarm ( alarm -- )
|
|
||||||
entry>> [ alarms get-global heap-delete ] if-box? ;
|
|
||||||
|
|
|
@ -143,8 +143,7 @@ GENERIC: easter ( obj -- obj' )
|
||||||
32 2 e * + 2 i * + h - k - 7 mod :> l
|
32 2 e * + 2 i * + h - k - 7 mod :> l
|
||||||
a 11 h * + 22 l * + 451 /i :> m
|
a 11 h * + 22 l * + 451 /i :> m
|
||||||
|
|
||||||
h l + 7 m * - 114 + 31 /mod 1 + :> ( month day )
|
h l + 7 m * - 114 + 31 /mod 1 + ;
|
||||||
month day ;
|
|
||||||
|
|
||||||
M: integer easter ( year -- timestamp )
|
M: integer easter ( year -- timestamp )
|
||||||
dup easter-month-day <date> ;
|
dup easter-month-day <date> ;
|
||||||
|
@ -171,11 +170,6 @@ M: timestamp easter ( timestamp -- timestamp )
|
||||||
: microseconds ( x -- duration ) 1000000 / seconds ;
|
: microseconds ( x -- duration ) 1000000 / seconds ;
|
||||||
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
|
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
|
||||||
|
|
||||||
GENERIC: >duration ( obj -- duration/f )
|
|
||||||
M: duration >duration ;
|
|
||||||
M: real >duration seconds ;
|
|
||||||
M: f >duration ;
|
|
||||||
|
|
||||||
GENERIC: year ( obj -- n )
|
GENERIC: year ( obj -- n )
|
||||||
M: integer year ;
|
M: integer year ;
|
||||||
M: timestamp year year>> ;
|
M: timestamp year year>> ;
|
||||||
|
|
|
@ -52,8 +52,11 @@ SYMBOL: matrix
|
||||||
[ first-col ] keep
|
[ first-col ] keep
|
||||||
dup 1 + rows-from clear-col ;
|
dup 1 + rows-from clear-col ;
|
||||||
|
|
||||||
|
: find-row ( row# quot -- i elt )
|
||||||
|
[ rows-from ] dip find ; inline
|
||||||
|
|
||||||
: pivot-row ( col# row# -- n )
|
: pivot-row ( col# row# -- n )
|
||||||
rows-from swap '[ [ _ ] dip nth-row nth abs ] sort-with last ;
|
[ dupd nth-row nth zero? not ] find-row 2nip ;
|
||||||
|
|
||||||
: (echelon) ( col# row# -- )
|
: (echelon) ( col# row# -- )
|
||||||
over cols < over rows < and [
|
over cols < over rows < and [
|
||||||
|
|
Loading…
Reference in New Issue