diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor new file mode 100644 index 0000000000..4842f8b7ae --- /dev/null +++ b/extra/alarms/alarms.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays calendar combinators concurrency generic +init kernel math namespaces sequences threads ; +IN: alarms + +TUPLE: alarm time quot ; + +C: alarm + + 0 > ] curry* subset ; + +: unexpired-alarms ( -- seq ) + now alarms get-global + [ alarm-time <=> 0 <= ] curry* subset ; + +: call-alarm ( alarm -- ) + alarm-quot spawn drop ; + +: do-alarms ( -- ) + expired-alarms [ call-alarm ] each + unexpired-alarms alarms set-global ; + +: alarm-receive-loop ( -- ) + receive dup alarm? [ handle-alarm ] [ drop ] if + alarm-receive-loop ; + +: start-alarm-receiver ( -- ) + [ + alarm-receive-loop + ] spawn alarm-receiver set-global ; + +: alarm-loop ( -- ) + alarms get-global empty? [ + do-alarms + ] unless 100 sleep alarm-loop ; + +: start-alarm-looper ( -- ) + [ + alarm-loop + ] spawn alarm-looper set-global ; + +: send-alarm ( str alarm -- ) + over set-delegate + alarm-receiver get-global send ; + +: start-alarm-daemon ( -- ) + alarms get-global [ V{ } clone alarms set-global ] unless + start-alarm-looper + start-alarm-receiver ; + +[ start-alarm-daemon ] "alarms" add-init-hook +PRIVATE> + +: register-alarm ( alarm -- ) + "register" send-alarm ; + +: unregister-alarm ( alarm -- ) + "unregister" send-alarm ; + +: change-alarm ( alarm-old alarm-new -- ) + "register" send-alarm + "unregister" send-alarm ; + +! Example: +! 5 seconds from-now [ "hi" print flush ] register-alarm diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 426ef617ca..1e9b769823 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -43,7 +43,6 @@ TUPLE: thread timeout continuation continued? ; : (mailbox-block-if-empty) ( mailbox timeout -- mailbox2 ) over mailbox-empty? [ [ swap mailbox-threads push stop ] callcc0 - "(mailbox-block-if-empty)" print flush (mailbox-block-if-empty) ] [ drop diff --git a/misc/install.sh b/misc/install.sh index baf05192ec..006a7cf604 100755 --- a/misc/install.sh +++ b/misc/install.sh @@ -112,7 +112,7 @@ check_ret wget if [[ $OS == windows-nt ]] ; then wget http://factorcode.org/dlls/freetype6.dll check_ret - wget http://factorcode.org/dlls/zlib1.dla + wget http://factorcode.org/dlls/zlib1.dll check_ret fi