diff --git a/basis/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor deleted file mode 100644 index 3b70b43a28..0000000000 --- a/basis/alarms/alarms-docs.factor +++ /dev/null @@ -1,74 +0,0 @@ -USING: help.markup help.syntax calendar quotations system ; -IN: alarms - -HELP: alarm -{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ; - -HELP: start-alarm -{ $values { "alarm" alarm } } -{ $description "Starts an alarm." } ; - -HELP: restart-alarm -{ $values { "alarm" alarm } } -{ $description "Starts or restarts an alarm. Restarting an alarm causes the a sleep of initial delay nanoseconds before looping. An alarm's parameters may be modified and restarted with this word." } ; - -HELP: stop-alarm -{ $values { "alarm" alarm } } -{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ; - -HELP: every -{ $values - { "quot" quotation } { "interval-duration" duration } - { "alarm" alarm } } -{ $description "Creates an alarm that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the alarm will stop." } -{ $examples - { $unchecked-example - "USING: alarms io calendar ;" - """[ "Hi Buddy." print flush ] 10 seconds every drop""" - "" - } -} ; - -HELP: later -{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } } -{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the alarm before " { $snippet "quot" } " runs. This alarm is not repeated." } -{ $examples - { $unchecked-example - "USING: alarms io calendar ;" - """[ "Break's over!" print flush ] 15 minutes later drop""" - "" - } -} ; - -HELP: delayed-every -{ $values - { "quot" quotation } { "duration" duration } - { "alarm" alarm } } -{ $description "Creates an alarm that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the alarm will stop." } -{ $examples - { $unchecked-example - "USING: alarms io calendar ;" - """[ "Hi Buddy." print flush ] 10 seconds every drop""" - "" - } -} ; - -ARTICLE: "alarms" "Alarms" -"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per alarm and consist of a quotation, a delay duration, and an interval duration. After starting an alarm, the alarm thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the alarm from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl -"The alarm class:" -{ $subsections alarm } -"Create an alarm before starting it:" -{ $subsections } -"Starting an alarm:" -{ $subsections start-alarm restart-alarm } -"Stopping an alarm:" -{ $subsections stop-alarm } - -"A recurring alarm without an initial delay:" -{ $subsections every } -"A one-time alarm with an initial delay:" -{ $subsections later } -"A recurring alarm with an initial delay:" -{ $subsections delayed-every } ; - -ABOUT: "alarms" diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index 92035a19c8..ddca921c78 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -1,119 +1,5 @@ -! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. +! Copyright (C) 2010 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs calendar combinators.short-circuit fry -heaps init kernel math math.functions math.parser namespaces -quotations sequences system threads ; +USING: ; IN: alarms -TUPLE: alarm - { quot callable initial: [ ] } - start-nanos - delay-nanos - interval-nanos - iteration-start-nanos - quotation-running? - restart? - thread ; - -nanoseconds ( obj -- duration/f ) -M: f >nanoseconds ; -M: real >nanoseconds >integer ; -M: duration >nanoseconds duration>nanoseconds >integer ; - -: set-next-alarm-time ( alarm -- alarm ) - ! start + delay + ceiling((now - (start + delay)) / interval) * interval - nano-count - over start-nanos>> - - over delay-nanos>> [ - ] when* - over interval-nanos>> / ceiling - over interval-nanos>> * - over start-nanos>> + - over delay-nanos>> [ + ] when* - >>iteration-start-nanos ; - -: stop-alarm? ( alarm -- ? ) - { [ thread>> self eq? not ] [ restart?>> ] } 1|| ; - -DEFER: call-alarm-loop - -: loop-alarm ( alarm -- ) - nano-count over - [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi < - [ set-next-alarm-time ] dip - [ dup iteration-start-nanos>> ] [ 0 ] if - 0 or sleep-until call-alarm-loop ; - -: maybe-loop-alarm ( alarm -- ) - dup { [ stop-alarm? ] [ interval-nanos>> not ] } 1|| - [ drop ] [ loop-alarm ] if ; - -: call-alarm-loop ( alarm -- ) - dup stop-alarm? [ - drop - ] [ - [ - [ t >>quotation-running? drop ] - [ quot>> call( -- ) ] - [ f >>quotation-running? drop ] tri - ] keep - maybe-loop-alarm - ] if ; - -: sleep-delay ( alarm -- ) - dup stop-alarm? [ - drop - ] [ - nano-count >>start-nanos - delay-nanos>> [ sleep ] when* - ] if ; - -: alarm-loop ( alarm -- ) - [ sleep-delay ] - [ nano-count >>iteration-start-nanos call-alarm-loop ] - [ dup restart?>> [ f >>restart? alarm-loop ] [ drop ] if ] tri ; - -PRIVATE> - -: ( quot delay-duration/f interval-duration/f -- alarm ) - alarm new - swap >nanoseconds >>interval-nanos - swap >nanoseconds >>delay-nanos - swap >>quot ; inline - -: start-alarm ( alarm -- ) - [ - '[ _ alarm-loop ] "Alarm execution" spawn - ] keep thread<< ; - -: stop-alarm ( alarm -- ) - dup quotation-running?>> [ - f >>thread drop - ] [ - [ [ interrupt ] when* f ] change-thread drop - ] if ; - -: restart-alarm ( alarm -- ) - t >>restart? - dup quotation-running?>> [ - drop - ] [ - dup thread>> [ nip interrupt ] [ start-alarm ] if* - ] if ; - - [ start-alarm ] keep ; - -PRIVATE> - -: every ( quot interval-duration -- alarm ) - [ f ] dip (start-alarm) ; - -: later ( quot delay-duration -- alarm ) - f (start-alarm) ; - -: delayed-every ( quot duration -- alarm ) - dup (start-alarm) ; diff --git a/basis/alarms/authors.txt b/basis/alarms/authors.txt old mode 100755 new mode 100644 diff --git a/basis/alarms/summary.txt b/basis/alarms/summary.txt deleted file mode 100644 index f6e12238fa..0000000000 --- a/basis/alarms/summary.txt +++ /dev/null @@ -1 +0,0 @@ -One-time and recurring events diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 8758b8198b..d9a6dfb370 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -7,6 +7,8 @@ IN: calendar HOOK: gmt-offset os ( -- hours minutes seconds ) +HOOK: gmt os ( -- timestamp ) + TUPLE: duration { year real } { month real } @@ -371,10 +373,6 @@ M: duration time- : timestamp>micros ( timestamp -- n ) unix-1970 (time-) 1000000 * >integer ; -: gmt ( -- timestamp ) - #! GMT time, right now - unix-1970 system-micros microseconds time+ ; - : now ( -- timestamp ) gmt >local-time ; : hence ( duration -- timestamp ) now swap time+ ; : ago ( duration -- timestamp ) now swap time- ; diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index fdc85c943a..40475b4d40 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -5,11 +5,11 @@ kernel math unix unix.time unix.types namespaces system accessors classes.struct ; IN: calendar.unix -: timeval>seconds ( timeval -- seconds ) +: timeval>duration ( timeval -- duration ) [ sec>> seconds ] [ usec>> microseconds ] bi time+ ; : timeval>unix-time ( timeval -- timestamp ) - timeval>seconds since-1970 ; + timeval>duration since-1970 ; : timespec>seconds ( timespec -- seconds ) [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ; @@ -28,3 +28,7 @@ IN: calendar.unix M: unix gmt-offset ( -- hours minutes seconds ) get-time gmtoff>> 3600 /mod 60 /mod ; + +M: unix gmt + timeval f [ gettimeofday io-error ] 2keep drop + timeval>unix-time ; diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor index 265a58507c..80253ea91b 100644 --- a/basis/calendar/windows/windows.factor +++ b/basis/calendar/windows/windows.factor @@ -1,8 +1,33 @@ USING: calendar namespaces alien.c-types system windows.kernel32 kernel math combinators windows.errors -accessors classes.struct ; +accessors classes.struct calendar.format math.functions ; IN: calendar.windows +: timestamp>SYSTEMTIME ( timestamp -- SYSTEMTIME ) + { + [ year>> ] + [ month>> ] + [ day-of-week ] + [ day>> ] + [ hour>> ] + [ minute>> ] + [ + second>> dup floor + [ nip >integer ] + [ - 1000 * >integer ] 2bi + ] + } cleave \ SYSTEMTIME ; + +: SYSTEMTIME>timestamp ( SYSTEMTIME -- timestamp ) + { + [ wYear>> ] + [ wMonth>> ] + [ wDay>> ] + [ wHour>> ] + [ wMinute>> ] + [ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ] + } cleave instant ; + M: windows gmt-offset ( -- hours minutes seconds ) TIME_ZONE_INFORMATION dup GetTimeZoneInformation { @@ -11,3 +36,6 @@ M: windows gmt-offset ( -- hours minutes seconds ) { TIME_ZONE_ID_STANDARD [ Bias>> ] } { TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] } } case neg 60 /mod 0 ; + +M: windows gmt + SYSTEMTIME [ GetSystemTime ] keep SYSTEMTIME>timestamp ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 8bdfb8dd57..ae39f62868 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -474,4 +474,7 @@ CONSULT: struct-test-delegate struct-test-delegator del>> ; 7 >>a 8 >>b ] unit-test +<<<<<<< HEAD +======= +>>>>>>> alien.data: make binary-zero? public and move it from classes.struct.private diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 9353317f0b..7bd72ec826 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: deques threads kernel arrays sequences alarms fry ; +USING: deques threads kernel arrays sequences timers fry ; IN: concurrency.conditions : notify-1 ( deque -- ) @@ -9,8 +9,8 @@ IN: concurrency.conditions : notify-all ( deque -- ) [ resume-now ] slurp-deque ; inline -: queue-timeout ( queue timeout -- alarm ) - #! Add an alarm which removes the current thread from the +: queue-timeout ( queue timeout -- timer ) + #! Add an timer which removes the current thread from the #! queue, and resumes it, passing it a value of t. [ [ self swap push-front* ] keep '[ @@ -28,7 +28,7 @@ ERROR: wait-timeout ; : wait ( queue timeout status -- ) over [ [ queue-timeout ] dip suspend - [ wait-timeout ] [ stop-alarm ] if + [ wait-timeout ] [ stop-timer ] if ] [ [ drop queue ] dip suspend drop ] if ; inline diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor index dc280c1e44..ef4270221f 100644 --- a/basis/furnace/alloy/alloy.factor +++ b/basis/furnace/alloy/alloy.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences db.tuples alarms calendar db fry +USING: kernel sequences db.tuples timers calendar db fry furnace.db furnace.cache furnace.asides diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index 3eb7a11215..33de393d90 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -3,7 +3,7 @@ USING: assocs kernel math.intervals math.parser namespaces strings random accessors quotations hashtables sequences continuations fry calendar combinators combinators.short-circuit -destructors alarms io.sockets db db.tuples db.types +destructors io.sockets db db.tuples db.types http http.server http.server.dispatchers http.server.filters furnace.cache furnace.scopes furnace.utilities ; IN: furnace.sessions diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 5bf89b9520..7652bfcfd0 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays combinators continuations fry io io.backend io.directories io.directories.hierarchy io.files io.pathnames -kernel math math.bitwise math.parser namespaces random +kernel locals math math.bitwise math.parser namespaces random sequences system vocabs.loader ; IN: io.files.unique @@ -78,9 +78,10 @@ PRIVATE> : temporary-file ( -- path ) "" unique-file ; -: with-working-directory ( path quot -- ) - over make-directories - dupd '[ _ _ with-temporary-directory ] with-directory ; inline +:: cleanup-unique-working-directory ( quot -- ) + unique-directory :> path + path [ path quot with-temporary-directory ] with-directory + path delete-tree ; inline { { [ os unix? ] [ "io.files.unique.unix" ] } diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index 8d747086a7..73de6bf1a2 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -37,17 +37,22 @@ M: callable run-pipeline-element '[ _ call( -- result ) ] with-streams* ] with-destructors ; -: ( n -- pipes ) +GENERIC: ( obj -- pipes ) + +M: integer ( n -- pipes ) [ [ (pipe) |dispose ] replicate T{ pipe } [ prefix ] [ suffix ] bi 2 ] with-destructors ; +M: sequence + [ { } ] [ length 1 - ] if-empty ; + PRIVATE> : run-pipeline ( seq -- results ) - [ length dup zero? [ drop { } ] [ 1 - ] if ] keep + [ ] keep [ [ [ first in>> ] [ second out>> ] bi ] dip run-pipeline-element diff --git a/basis/io/timeouts/timeouts.factor b/basis/io/timeouts/timeouts.factor index 957ba30193..68110ded15 100644 --- a/basis/io/timeouts/timeouts.factor +++ b/basis/io/timeouts/timeouts.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel calendar alarms io io.encodings accessors +USING: kernel calendar timers io io.encodings accessors namespaces fry io.streams.null ; IN: io.timeouts @@ -13,11 +13,11 @@ M: encoder set-timeout stream>> set-timeout ; GENERIC: cancel-operation ( obj -- ) -: queue-timeout ( obj timeout -- alarm ) +: queue-timeout ( obj timeout -- timer ) [ '[ _ cancel-operation ] ] dip later ; : with-timeout* ( obj timeout quot -- ) - 3dup drop queue-timeout [ nip call ] dip stop-alarm ; + 3dup drop queue-timeout [ nip call ] dip stop-timer ; inline : with-timeout ( obj quot -- ) diff --git a/basis/logging/insomniac/insomniac.factor b/basis/logging/insomniac/insomniac.factor index 72e37ef8af..2a0be6aa79 100644 --- a/basis/logging/insomniac/insomniac.factor +++ b/basis/logging/insomniac/insomniac.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp kernel -io.files io.streams.string namespaces make alarms assocs +io.files io.streams.string namespaces make timers assocs io.encodings.utf8 accessors calendar sequences ; QUALIFIED: io.sockets IN: logging.insomniac diff --git a/basis/models/delay/delay.factor b/basis/models/delay/delay.factor index 8292bb9c04..d194d76e6d 100644 --- a/basis/models/delay/delay.factor +++ b/basis/models/delay/delay.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms fry kernel models ; +USING: accessors timers fry kernel models ; IN: models.delay -TUPLE: delay < model model timeout alarm ; +TUPLE: delay < model model timeout timer ; : update-delay-model ( delay -- ) [ model>> value>> ] keep set-model ; @@ -15,13 +15,13 @@ TUPLE: delay < model model timeout alarm ; [ add-dependency ] keep ; : stop-delay ( delay -- ) - alarm>> [ stop-alarm ] when* ; + timer>> [ stop-timer ] when* ; : start-delay ( delay -- ) dup - [ '[ _ f >>alarm update-delay-model ] ] [ timeout>> ] bi + [ '[ _ f >>timer update-delay-model ] ] [ timeout>> ] bi later - >>alarm drop ; + >>timer drop ; M: delay model-changed nip dup stop-delay start-delay ; diff --git a/basis/timers/authors.txt b/basis/timers/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/timers/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/timers/summary.txt b/basis/timers/summary.txt new file mode 100644 index 0000000000..56260b6be3 --- /dev/null +++ b/basis/timers/summary.txt @@ -0,0 +1 @@ +One-time and recurring timers for relative time offsets diff --git a/basis/timers/timers-docs.factor b/basis/timers/timers-docs.factor new file mode 100644 index 0000000000..fb07c8a4cc --- /dev/null +++ b/basis/timers/timers-docs.factor @@ -0,0 +1,74 @@ +USING: help.markup help.syntax calendar quotations system ; +IN: timers + +HELP: timer +{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ; + +HELP: start-timer +{ $values { "timer" timer } } +{ $description "Starts a timer." } ; + +HELP: restart-timer +{ $values { "timer" timer } } +{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ; + +HELP: stop-timer +{ $values { "timer" timer } } +{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ; + +HELP: every +{ $values + { "quot" quotation } { "interval-duration" duration } + { "timer" timer } } +{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." } +{ $examples + { $unchecked-example + "USING: timers io calendar ;" + """[ "Hi Buddy." print flush ] 10 seconds every drop""" + "" + } +} ; + +HELP: later +{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } } +{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." } +{ $examples + { $unchecked-example + "USING: timers io calendar ;" + """[ "Break's over!" print flush ] 15 minutes later drop""" + "" + } +} ; + +HELP: delayed-every +{ $values + { "quot" quotation } { "duration" duration } + { "timer" timer } } +{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." } +{ $examples + { $unchecked-example + "USING: timers io calendar ;" + """[ "Hi Buddy." print flush ] 10 seconds every drop""" + "" + } +} ; + +ARTICLE: "timers" "Alarms" +"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl +"The timer class:" +{ $subsections timer } +"Create a timer before starting it:" +{ $subsections } +"Starting a timer:" +{ $subsections start-timer restart-timer } +"Stopping a timer:" +{ $subsections stop-timer } + +"A recurring timer without an initial delay:" +{ $subsections every } +"A one-time timer with an initial delay:" +{ $subsections later } +"A recurring timer with an initial delay:" +{ $subsections delayed-every } ; + +ABOUT: "timers" diff --git a/basis/alarms/alarms-tests.factor b/basis/timers/timers-tests.factor similarity index 66% rename from basis/alarms/alarms-tests.factor rename to basis/timers/timers-tests.factor index ed1ab632ae..82274aff45 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/timers/timers-tests.factor @@ -1,12 +1,12 @@ -USING: alarms alarms.private calendar concurrency.count-downs +USING: timers timers.private calendar concurrency.count-downs concurrency.promises fry kernel math math.order sequences threads tools.test tools.time ; -IN: alarms.tests +IN: timers.tests [ ] [ 1 { f } clone 2dup - [ first stop-alarm count-down ] 2curry 1 seconds later + [ first stop-timer count-down ] 2curry 1 seconds later swap set-first await ] unit-test @@ -28,20 +28,20 @@ IN: alarms.tests { 3 } dup '[ 4 _ set-first ] 2 seconds later 1/2 seconds sleep - stop-alarm + stop-timer ] unit-test [ { 1 } ] [ { 0 } dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later - [ stop-alarm ] [ start-alarm ] bi + [ stop-timer ] [ start-timer ] bi 4 seconds sleep ] unit-test [ { 0 } ] [ { 0 } dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later - 2 seconds sleep stop-alarm + 2 seconds sleep stop-timer 1/2 seconds sleep ] unit-test @@ -49,19 +49,19 @@ IN: alarms.tests { 0 } dup '[ 1 _ set-first ] 300 milliseconds later 150 milliseconds sleep - [ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi + [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi ] unit-test [ { 1 } ] [ { 0 } dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later - 100 milliseconds sleep restart-alarm 300 milliseconds sleep + 100 milliseconds sleep restart-timer 300 milliseconds sleep ] unit-test [ { 4 } ] [ { 0 } dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds - dup start-alarm - 700 milliseconds sleep dup restart-alarm - 700 milliseconds sleep stop-alarm 500 milliseconds sleep + dup start-timer + 700 milliseconds sleep dup restart-timer + 700 milliseconds sleep stop-timer 500 milliseconds sleep ] unit-test diff --git a/basis/timers/timers.factor b/basis/timers/timers.factor new file mode 100644 index 0000000000..a12ecba830 --- /dev/null +++ b/basis/timers/timers.factor @@ -0,0 +1,122 @@ +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar combinators.short-circuit fry +heaps init kernel math math.functions math.parser namespaces +quotations sequences system threads ; +IN: timers + +TUPLE: timer + { quot callable initial: [ ] } + start-nanos + delay-nanos + interval-nanos + iteration-start-nanos + quotation-running? + restart? + thread ; + +nanoseconds ( obj -- duration/f ) +M: f >nanoseconds ; +M: real >nanoseconds >integer ; +M: duration >nanoseconds duration>nanoseconds >integer ; + +: set-next-timer-time ( timer -- timer ) + ! start + delay + ceiling((now - (start + delay)) / interval) * interval + nano-count + over start-nanos>> - + over delay-nanos>> [ - ] when* + over interval-nanos>> / ceiling + over interval-nanos>> * + over start-nanos>> + + over delay-nanos>> [ + ] when* + >>iteration-start-nanos ; + +: stop-timer? ( timer -- ? ) + { [ thread>> self eq? not ] [ restart?>> ] } 1|| ; + +DEFER: call-timer-loop + +: loop-timer ( timer -- ) + nano-count over + [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi < + [ set-next-timer-time ] dip + [ dup iteration-start-nanos>> ] [ 0 ] if + 0 or sleep-until call-timer-loop ; + +: maybe-loop-timer ( timer -- ) + dup { [ stop-timer? ] [ interval-nanos>> not ] } 1|| + [ drop ] [ loop-timer ] if ; + +: call-timer-loop ( timer -- ) + dup stop-timer? [ + drop + ] [ + [ + [ t >>quotation-running? drop ] + [ quot>> call( -- ) ] + [ f >>quotation-running? drop ] tri + ] keep + maybe-loop-timer + ] if ; + +: sleep-delay ( timer -- ) + dup stop-timer? [ + drop + ] [ + nano-count >>start-nanos + delay-nanos>> [ sleep ] when* + ] if ; + +: timer-loop ( timer -- ) + [ sleep-delay ] + [ nano-count >>iteration-start-nanos call-timer-loop ] + [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ; + +PRIVATE> + +: ( quot delay-duration/f interval-duration/f -- timer ) + timer new + swap >nanoseconds >>interval-nanos + swap >nanoseconds >>delay-nanos + swap >>quot ; inline + +: start-timer ( timer -- ) + [ + '[ _ timer-loop ] "Alarm execution" spawn + ] keep thread<< ; + +: stop-timer ( timer -- ) + dup quotation-running?>> [ + f >>thread drop + ] [ + [ [ interrupt ] when* f ] change-thread drop + ] if ; + +: restart-timer ( timer -- ) + t >>restart? + dup quotation-running?>> [ + drop + ] [ + dup thread>> [ nip interrupt ] [ start-timer ] if* + ] if ; + + [ start-timer ] keep ; + +PRIVATE> + +: every ( quot interval-duration -- timer ) + [ f ] dip (start-timer) ; + +: later ( quot delay-duration -- timer ) + f (start-timer) ; + +: delayed-every ( quot duration -- timer ) + dup (start-timer) ; + +: nanos-since ( nano-count -- nanos ) + [ nano-count ] dip - ; diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index 740abb0feb..4ee9869f76 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -64,7 +64,7 @@ $nl HELP: deploy-threads? { $description "Deploy flag. If set, thread support will be included in the final image." $nl -"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ; +"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, timers, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ; HELP: deploy-ui? { $description "Deploy flag. If set, the Factor UI will be included in the deployed image." diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 44291a96cc..b435f5c8e7 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -317,7 +317,7 @@ IN: tools.deploy.shaker strip-io? [ io-backend , ] when { } { - "alarms" + "timers" "tools" "io.launcher" "random" diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 8fd3e53e19..e995876f26 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -5,7 +5,7 @@ io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader vocabs.metadata io combinators calendar accessors math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets classes -math alien urls splitting ascii combinators.short-circuit alarms +math alien urls splitting ascii combinators.short-circuit timers words.symbol system summary ; IN: tools.scaffold @@ -128,7 +128,7 @@ M: bad-developer-name summary { "ch" "a character" } { "word" word } { "array" array } - { "alarm" alarm } + { "timers" timer } { "duration" duration } { "path" "a pathname string" } { "vocab" "a vocabulary specifier" } diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 0e0de67440..06ea870196 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -569,6 +569,9 @@ H{ } clone wm-handlers set-global [ [ execute( -- wm ) add-wm-handler ] with each ] [ wm-handlers get-global set-at ] if ; +: remove-wm-handler ( wm -- ) + wm-handlers get-global delete-at ; + [ handle-wm-close 0 ] WM_CLOSE add-wm-handler [ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 4777e42abc..d50405809f 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays assocs calendar colors.constants +USING: accessors timers arrays assocs calendar colors.constants combinators combinators.short-circuit documents documents.elements fry grouping kernel locals make math math.functions math.order math.ranges math.rectangles @@ -15,7 +15,7 @@ IN: ui.gadgets.editors TUPLE: editor < line-gadget caret-color caret mark -focused? blink blink-alarm ; +focused? blink blink-timer ; > [ stop-alarm ] when* ; + blink-timer>> [ stop-timer ] when* ; : start-blinking ( editor -- ) t >>blink - blink-alarm>> [ restart-alarm ] when* ; + blink-timer>> [ restart-timer ] when* ; : restart-blinking ( editor -- ) dup focused?>> [ @@ -80,12 +80,12 @@ M: editor graft* [ dup mark>> activate-editor-model ] [ [ - '[ _ blink-caret ] blink-interval get dup - ] keep blink-alarm<< + '[ _ blink-caret ] blink-interval get dup + ] keep blink-timer<< ] tri ; M: editor ungraft* - [ [ stop-blinking ] [ f >>blink-alarm drop ] bi ] + [ [ stop-blinking ] [ f >>blink-timer drop ] bi ] [ dup caret>> deactivate-editor-model ] [ dup mark>> deactivate-editor-model ] tri ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index a63d64312b..e713b0f999 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs continuations kernel math models -namespaces opengl opengl.textures sequences io colors combinators -combinators.short-circuit fry math.vectors math.rectangles cache -ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.pixel-formats destructors literals strings ; +USING: accessors arrays assocs cache colors combinators +combinators.short-circuit concurrency.promises continuations +destructors fry io kernel literals math math.rectangles +math.vectors models namespaces opengl opengl.textures sequences +strings ui.backend ui.gadgets ui.gadgets.tracks ui.gestures +ui.pixel-formats ui.render ; IN: ui.gadgets.worlds SYMBOLS: @@ -40,6 +41,7 @@ TUPLE: world < track window-loc pixel-format-attributes background-color + promise window-controls window-resources ; @@ -118,7 +120,8 @@ M: world request-focus-on ( child gadget -- ) f >>active? { 0 0 } >>window-loc f >>grab-input? - V{ } clone >>window-resources ; + V{ } clone >>window-resources + >>promise ; : initial-background-color ( attributes -- color ) window-controls>> textured-background swap member-eq? diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 41b7f69cbe..658e179301 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.order models namespaces make sequences words strings system hashtables math.parser -math.vectors classes.tuple classes boxes calendar alarms combinators +math.vectors classes.tuple classes boxes calendar timers combinators sets columns fry deques ui.gadgets ui.gadgets.private ascii combinators.short-circuit ; FROM: namespaces => set ; @@ -188,15 +188,15 @@ SYMBOL: drag-timer [ drag-gesture ] 300 milliseconds 100 milliseconds - + [ drag-timer get-global >box ] - [ start-alarm ] bi + [ start-timer ] bi ] when ; : stop-drag-timer ( -- ) hand-buttons get-global empty? [ drag-timer get-global ?box - [ stop-alarm ] [ drop ] if + [ stop-timer ] [ drop ] if ] when ; : fire-motion ( -- ) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 1e5af88ac8..eaeeb01f03 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs boxes io kernel math models namespaces make -dlists deques sequences threads words continuations init -combinators combinators.short-circuit hashtables -concurrency.flags sets accessors calendar fry destructors -ui.gadgets ui.gadgets.private ui.gadgets.worlds -ui.gadgets.tracks ui.gestures ui.backend ui.render strings -classes.tuple classes.tuple.parser lexer vocabs.parser parser ; +USING: accessors arrays assocs boxes classes.tuple +classes.tuple.parser combinators combinators.short-circuit +concurrency.flags concurrency.promises continuations deques +destructors dlists fry init kernel lexer make math namespaces +parser sequences sets strings threads ui.backend ui.gadgets +ui.gadgets.private ui.gadgets.worlds ui.gestures vocabs.parser +words ; IN: ui [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ] [ [ (close-window) f ] change-handle drop ] [ unfocus-world ] + [ promise>> t swap fulfill ] } cleave ; : init-ui ( -- ) diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index 72132bb132..bd3a02fcab 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel alien.syntax alien.c-types math unix.types -classes.struct accessors ; +USING: accessors alien.c-types alien.syntax calendar +classes.struct kernel math unix.types ; IN: unix.time STRUCT: timeval @@ -24,6 +24,15 @@ STRUCT: timespec swap >>nsec swap >>sec ; +STRUCT: timezone + { tz_minuteswest int } + { tz_dsttime int } ; + +: timestamp>timezone ( timestamp -- timezone ) + gmt-offset>> duration>minutes + 1 + \ timezone ; inline + STRUCT: tm { sec int } { min int } @@ -40,3 +49,5 @@ STRUCT: tm FUNCTION: time_t time ( time_t* t ) ; FUNCTION: tm* localtime ( time_t* clock ) ; FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ; +FUNCTION: int settimeofday ( timeval* TP, timezone* TZP ) ; +FUNCTION: int adjtime ( timeval* delta, timeval* olddelta ) ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 94cedef38a..be11fc66a0 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1800,7 +1800,7 @@ FUNCTION: BOOL SetProcessPriorityBoost ( HANDLE hProcess, BOOL disablePriorityBo ! FUNCTION: SetProcessWorkingSetSize ! FUNCTION: SetStdHandle ! FUNCTION: SetSystemPowerState -! FUNCTION: SetSystemTime +FUNCTION: BOOL SetSystemTime ( SYSTEMTIME* lpSystemTime ) ; ! FUNCTION: SetSystemTimeAdjustment ! FUNCTION: SetTapeParameters ! FUNCTION: SetTapePosition diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index c00199e9b3..07f6e9ef9a 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -536,7 +536,6 @@ tuple { "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) } { "(exit)" "system" "primitive_exit" (( n -- * )) } { "nano-count" "system" "primitive_nano_count" (( -- ns )) } - { "system-micros" "system" "primitive_system_micros" (( -- us )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) } { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) } { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) } diff --git a/extra/audio/engine/engine.factor b/extra/audio/engine/engine.factor index a188df853b..d7079c4aaa 100644 --- a/extra/audio/engine/engine.factor +++ b/extra/audio/engine/engine.factor @@ -1,5 +1,5 @@ ! (c)2009 Joe Groff bsd license -USING: accessors alien audio classes.struct fry calendar alarms +USING: accessors alien audio classes.struct fry calendar timers combinators combinators.short-circuit destructors generalizations kernel literals locals math openal sequences sequences.generalizations specialized-arrays strings ; @@ -70,7 +70,7 @@ TUPLE: audio-engine < disposable listener { next-source integer } clips - update-alarm ; + update-timer ; TUPLE: audio-clip < disposable { audio-engine audio-engine } @@ -226,20 +226,20 @@ DEFER: update-audio : start-audio ( audio-engine -- ) dup start-audio* - dup '[ _ update-audio ] 20 milliseconds every >>update-alarm + dup '[ _ update-audio ] 20 milliseconds every >>update-timer drop ; : stop-audio ( audio-engine -- ) dup al-sources>> [ { [ make-engine-current ] - [ update-alarm>> [ stop-alarm ] when* ] + [ update-timer>> [ stop-timer ] when* ] [ clips>> clone [ dispose ] each ] [ al-sources>> free-sources ] [ f >>al-sources f >>clips - f >>update-alarm + f >>update-timer drop ] [ al-context>> alcSuspendContext ] diff --git a/extra/audio/engine/test/test.factor b/extra/audio/engine/test/test.factor index 0791a226d4..419f31d73b 100644 --- a/extra/audio/engine/test/test.factor +++ b/extra/audio/engine/test/test.factor @@ -1,5 +1,5 @@ ! (c)2009 Joe Groff bsd license -USING: accessors alarms audio audio.engine audio.loader calendar +USING: accessors timers audio audio.engine audio.loader calendar destructors io kernel locals math math.functions math.ranges specialized-arrays sequences random math.vectors ; FROM: alien.c-types => short ; @@ -41,10 +41,10 @@ M: noise-generator dispose ] when engine update-audio - ] 20 milliseconds every :> alarm + ] 20 milliseconds every :> timer "Press Enter to stop the test." print readln drop - alarm stop-alarm + timer stop-timer engine dispose ; MAIN: audio-engine-test diff --git a/extra/benchmark/struct/authors.txt b/extra/benchmark/struct/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/benchmark/struct/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/benchmark/struct/struct.factor b/extra/benchmark/struct/struct.factor new file mode 100644 index 0000000000..addc40ddba --- /dev/null +++ b/extra/benchmark/struct/struct.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types classes.struct kernel memory +system vm ; +IN: benchmark.struct + +STRUCT: benchmark-data + { time ulonglong } + { data-room data-heap-room } + { code-room mark-sweep-sizes } ; + +STRUCT: benchmark-data-pair + { start benchmark-data } + { stop benchmark-data } ; + +: ( -- benchmark-data ) + \ benchmark-data + nano-count >>time + code-room >>code-room + data-room >>data-room ; inline + +: ( start stop -- benchmark-data-pair ) + \ benchmark-data-pair + swap >>stop + swap >>start ; inline + +: with-benchmarking ( ... quot -- ... benchmark-data-pair ) + + [ call ] dip + ; inline + diff --git a/extra/codebook/authors.txt b/extra/codebook/authors.txt new file mode 100644 index 0000000000..0bc3c5ad4d --- /dev/null +++ b/extra/codebook/authors.txt @@ -0,0 +1,2 @@ +Joe Groff +Doug Coleman diff --git a/extra/codebook/codebook.factor b/extra/codebook/codebook.factor new file mode 100644 index 0000000000..2803169ba8 --- /dev/null +++ b/extra/codebook/codebook.factor @@ -0,0 +1,245 @@ +! (c)2010 Joe Groff bsd license +USING: accessors arrays assocs calendar calendar.format +combinators combinators.short-circuit fry io io.backend +io.directories io.encodings.binary io.encodings.detect +io.encodings.utf8 io.files io.files.info io.files.types +io.files.unique io.launcher io.pathnames kernel locals math +math.parser namespaces sequences sorting strings system +unicode.categories xml.syntax xml.writer xmode.catalog +xmode.marker xmode.tokens ; +IN: codebook + +! Usage: "my/source/tree" codebook +! Writes tree.opf, tree.ncx, and tree.html to a temporary directory +! Writes tree.mobi to resource:codebooks +! Requires kindlegen to compile tree.mobi for Kindle + +CONSTANT: codebook-style + { + { COMMENT1 [ [XML <-> XML] ] } + { COMMENT2 [ [XML <-> XML] ] } + { COMMENT3 [ [XML <-> XML] ] } + { COMMENT4 [ [XML <-> XML] ] } + { DIGIT [ [XML <-> XML] ] } + { FUNCTION [ [XML <-> XML] ] } + { KEYWORD1 [ [XML <-> XML] ] } + { KEYWORD2 [ [XML <-> XML] ] } + { KEYWORD3 [ [XML <-> XML] ] } + { KEYWORD4 [ [XML <-> XML] ] } + { LABEL [ [XML <-> XML] ] } + { LITERAL1 [ [XML <-> XML] ] } + { LITERAL2 [ [XML <-> XML] ] } + { LITERAL3 [ [XML <-> XML] ] } + { LITERAL4 [ [XML <-> XML] ] } + { MARKUP [ [XML <-> XML] ] } + { OPERATOR [ [XML <-> XML] ] } + [ drop ] + } + +: first-line ( filename encoding -- line ) + [ readln ] with-file-reader ; + +TUPLE: code-file + name encoding mode ; + +: include-file-name? ( name -- ? ) + { + [ path-components [ "." head? ] any? not ] + [ link-info type>> +regular-file+ = ] + } 1&& ; + +: code-files ( dir -- files ) + '[ + [ include-file-name? ] filter [ + dup detect-file dup binary? + [ f ] [ 2dup dupd first-line find-mode ] if + code-file boa + ] map [ mode>> ] filter [ name>> ] sort-with + ] with-directory-tree-files ; + +: html-name-char ( char -- str ) + { + { [ dup alpha? ] [ 1string ] } + { [ dup digit? ] [ 1string ] } + [ >hex 6 CHAR: 0 pad-head "_" "_" surround ] + } cond ; + +: file-html-name ( name -- name ) + [ html-name-char ] { } map-as concat ".html" append ; + +: toc-list ( files -- list ) + [ name>> ] map natural-sort [ + [ file-html-name ] keep + [XML
  • ><->
    • XML] + ] map ; + +! insert zero-width non-joiner between all characters so words can wrap anywhere +: zwnj ( string -- s|t|r|i|n|g ) + [ CHAR: \u00200c "" 2sequence ] { } map-as concat ; + +! We wrap every line in because Kindle tends to forget the font when +! moving back pages +: htmlize-tokens ( tokens line# -- html-tokens ) + swap [ + [ str>> zwnj ] [ id>> ] bi codebook-style case + ] map [XML <-> <-> XML] + "\n" 2array ; + +: line#>string ( i line#len -- i-string ) + [ number>string ] [ CHAR: \s pad-head ] bi* ; + +:: code>html ( dir file -- page ) + file name>> :> name + "Generating HTML for " write name write "..." print flush + dir [ file [ name>> ] [ encoding>> ] bi file-lines ] with-directory :> lines + lines length 1 + number>string length :> line#len + file mode>> load-mode :> rules + f lines [| l i | l rules tokenize-line i 1 + line#len line#>string htmlize-tokens ] + map-index concat nip :> html-lines + + + <-name-> + + + +

    <-name->

    + 
    <-html-lines->
    + + + XML> ; + +:: code>toc-html ( dir name files -- html ) + "Generating HTML table of contents" print flush + + now timestamp>rfc822 :> timestamp + dir absolute-path :> source + dir [ + files toc-list :> toc + + + + <-name-> + + + +

    <-name->

    + Generated from
    + <-source->
    + at <-timestamp->
    +
    +
      <-toc->
    + + + XML> + ] with-directory ; + +:: code>ncx ( dir name files -- xml ) + "Generating NCX table of contents" print flush + + files [| file i | + file name>> :> name + name file-html-name :> filename + i 2 + number>string :> istr + + [XML playOrder=<-istr->> + <-name-> + /> + XML] + ] map-index :> file-nav-points + + + + + + Table of Contents + + + <-file-nav-points-> + + XML> ; + +:: code>opf ( dir name files -- xml ) + "Generating OPF manifest" print flush + name ".ncx" append :> ncx-name + + files [ + name>> file-html-name dup + [XML href=<-> media-type="text/html" /> XML] + ] map :> html-manifest + + files [ name>> file-html-name [XML /> XML] ] map :> html-spine + + + > + + <-name-> + en + + + + + + <-html-manifest-> + media-type="application/x-dtbncx+xml" /> + + + + <-html-spine-> + + + + + XML> ; + +: write-dest-file ( xml dest-dir name ext -- ) + append append-path utf8 [ write-xml ] with-file-writer ; + +SYMBOL: kindlegen-path +kindlegen-path [ "kindlegen" ] initialize + +SYMBOL: codebook-output-path +codebook-output-path [ "resource:codebooks" ] initialize + +: kindlegen ( path -- ) + [ kindlegen-path get "-unicode" ] dip 3array try-process ; + +: kindle-path ( directory name extension -- path ) + [ append-path ] dip append ; + +:: codebook ( src-dir -- ) + codebook-output-path get normalize-path :> dest-dir + + "Generating ebook for " write src-dir write " in " write dest-dir print flush + + dest-dir make-directories + [ + current-temporary-directory get :> temp-dir + src-dir file-name :> name + src-dir code-files :> files + + src-dir name files code>opf + temp-dir name ".opf" write-dest-file + + "vocab:codebook/cover.jpg" temp-dir copy-file-into + + src-dir name files code>ncx + temp-dir name ".ncx" write-dest-file + + src-dir name files code>toc-html + temp-dir "_toc.html" "" write-dest-file + + files [| file | + src-dir file code>html + temp-dir file name>> file-html-name "" write-dest-file + ] each + + temp-dir name ".opf" kindle-path kindlegen + temp-dir name ".mobi" kindle-path dest-dir copy-file-into + + dest-dir name ".mobi" kindle-path :> mobi-path + + "Job's finished: " write mobi-path print flush + ] cleanup-unique-working-directory ; diff --git a/extra/codebook/cover.jpg b/extra/codebook/cover.jpg new file mode 100644 index 0000000000..039415d727 Binary files /dev/null and b/extra/codebook/cover.jpg differ diff --git a/extra/game/input/demos/joysticks/joysticks.factor b/extra/game/input/demos/joysticks/joysticks.factor index ab65369ea1..3f909c7781 100644 --- a/extra/game/input/demos/joysticks/joysticks.factor +++ b/extra/game/input/demos/joysticks/joysticks.factor @@ -1,7 +1,7 @@ USING: ui ui.gadgets sequences kernel arrays math colors colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors accessors fry ui.gadgets.packs game.input ui.gadgets.labels -ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons +ui.gadgets.borders timers calendar locals strings ui.gadgets.buttons combinators math.parser assocs threads ; IN: game.input.demos.joysticks @@ -73,7 +73,7 @@ CONSTANT: pov-polygons COLOR: red [ >>indicator ] [ add-gadget ] bi dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ; -TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; +TUPLE: joystick-demo-gadget < pack axis raxis controller buttons timer ; : add-gadget-with-border ( parent child -- parent ) { 2 2 } COLOR: gray >>boundary add-gadget ; @@ -108,7 +108,7 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; : kill-update-axes ( gadget -- ) COLOR: gray >>interior - [ [ stop-alarm ] when* f ] change-alarm + [ [ stop-timer ] when* f ] change-timer relayout-1 ; : (update-axes) ( gadget controller-state -- ) @@ -125,11 +125,11 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ; [ (update-axes) ] [ kill-update-axes ] if* ; M: joystick-demo-gadget graft* - dup '[ _ update-axes ] FREQUENCY every >>alarm + dup '[ _ update-axes ] FREQUENCY every >>timer drop ; M: joystick-demo-gadget ungraft* - alarm>> [ stop-alarm ] when* ; + timer>> [ stop-timer ] when* ; : joystick-window ( controller -- ) [ ] [ product-string ] bi diff --git a/extra/game/input/demos/key-caps/key-caps.factor b/extra/game/input/demos/key-caps/key-caps.factor index 363c7c801c..c8d8e0bc53 100644 --- a/extra/game/input/demos/key-caps/key-caps.factor +++ b/extra/game/input/demos/key-caps/key-caps.factor @@ -1,6 +1,6 @@ USING: game.input game.input.scancodes kernel ui.gadgets ui.gadgets.buttons sequences accessors -words arrays assocs math calendar fry alarms ui +words arrays assocs math calendar fry timers ui ui.gadgets.borders ui.gestures literals ; IN: game.input.demos.key-caps @@ -134,7 +134,7 @@ CONSTANT: key-locations H{ CONSTANT: KEYBOARD-SIZE { 230 65 } CONSTANT: FREQUENCY $[ 1/30 seconds ] -TUPLE: key-caps-gadget < gadget keys alarm ; +TUPLE: key-caps-gadget < gadget keys timer ; : make-key-gadget ( scancode dim array -- ) [ @@ -163,11 +163,11 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ; M: key-caps-gadget graft* open-game-input - dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm + dup '[ _ update-key-caps-state ] FREQUENCY every >>timer drop ; M: key-caps-gadget ungraft* - alarm>> [ stop-alarm ] when* + timer>> [ stop-timer ] when* close-game-input ; M: key-caps-gadget handle-gesture diff --git a/extra/game/loop/loop-docs.factor b/extra/game/loop/loop-docs.factor index 1605c45284..c42e39e17b 100644 --- a/extra/game/loop/loop-docs.factor +++ b/extra/game/loop/loop-docs.factor @@ -26,22 +26,6 @@ $nl { } related-words -HELP: benchmark-frames-per-second -{ $values - { "loop" game-loop } - { "n" float } -} -{ $description "Returns the average number of times per second the game loop has called " { $link draw* } " on its delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ; - -HELP: benchmark-ticks-per-second -{ $values - { "loop" game-loop } - { "n" float } -} -{ $description "Returns the average number of times per second the game loop has called " { $link tick* } " on its tick delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ; - -{ reset-loop-benchmark benchmark-frames-per-second benchmark-ticks-per-second } related-words - HELP: draw* { $values { "tick-slice" float } { "delegate" "a " { $link "game.loop-delegates" } } @@ -59,12 +43,6 @@ HELP: game-loop-error } { $description "If an uncaught error is thrown from inside a game loop delegate's " { $link tick* } " or " { $link draw* } ", the game loop will catch the error, stop the game loop, and rethrow an error of this class." } ; -HELP: reset-loop-benchmark -{ $values - { "loop" game-loop } -} -{ $description "Resets the benchmark counters on a " { $link game-loop } ". Subsequent calls to " { $link benchmark-frames-per-second } " and " { $link benchmark-ticks-per-second } " will measure their values from the point " { $snippet "reset-loop-benchmark" } " was called." } ; - HELP: start-loop { $values { "loop" game-loop } @@ -109,12 +87,6 @@ ARTICLE: "game.loop" "Game loops" start-loop stop-loop } -"The game loop maintains performance counters:" -{ $subsections - reset-loop-benchmark - benchmark-frames-per-second - benchmark-ticks-per-second -} "The game loop catches errors that occur in the delegate's methods during the course of the game loop:" { $subsections game-loop-error diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor index c4c190355b..ddb5f8b17d 100644 --- a/extra/game/loop/loop.factor +++ b/extra/game/loop/loop.factor @@ -1,34 +1,38 @@ ! (c)2009 Joe Groff bsd license -USING: accessors alarms calendar continuations destructors fry -kernel math math.order namespaces system ui ui.gadgets.worlds ; +USING: accessors timers alien.c-types calendar classes.struct +continuations destructors fry kernel math math.order memory +namespaces sequences specialized-vectors system +tools.memory ui ui.gadgets.worlds vm vocabs.loader arrays +benchmark.struct locals ; IN: game.loop TUPLE: game-loop { tick-interval-nanos integer read-only } tick-delegate draw-delegate - { last-tick integer } { running? boolean } - { tick-number integer } - { frame-number integer } - { benchmark-time integer } - { benchmark-tick-number integer } - { benchmark-frame-number integer } - alarm ; + { tick# integer } + { frame# integer } + tick-timer + draw-timer + benchmark-data ; + +STRUCT: game-loop-benchmark + { benchmark-data-pair benchmark-data-pair } + { tick# ulonglong } + { frame# ulonglong } ; + +SPECIALIZED-VECTOR: game-loop-benchmark + +: ( benchmark-data-pair tick frame -- obj ) + \ game-loop-benchmark + swap >>frame# + swap >>tick# + swap >>benchmark-data-pair ; inline GENERIC: tick* ( delegate -- ) GENERIC: draw* ( tick-slice delegate -- ) -SYMBOL: game-loop - -: since-last-tick ( loop -- nanos ) - last-tick>> nano-count swap - ; - -: tick-slice ( loop -- slice ) - [ since-last-tick ] [ tick-interval-nanos>> ] bi /f 1.0 min ; - -CONSTANT: MAX-FRAMES-TO-SKIP 5 - DEFER: stop-loop TUPLE: game-loop-error game-loop error ; @@ -40,70 +44,69 @@ TUPLE: game-loop-error game-loop error ; [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ; : fps ( fps -- nanos ) - 1,000,000,000 swap /i ; inline + [ 1,000,000,000 ] dip /i ; inline > ] + [ frame#>> ] + [ benchmark-data>> ] tri push ; + +: last-tick-percent-offset ( loop -- float ) + [ draw-timer>> iteration-start-nanos>> nano-count swap - ] + [ tick-interval-nanos>> ] bi /f 1.0 min ; + : redraw ( loop -- ) - [ 1 + ] change-frame-number - [ tick-slice ] [ draw-delegate>> ] bi draw* ; + [ 1 + ] change-frame# + [ + [ last-tick-percent-offset ] [ draw-delegate>> ] bi + [ draw* ] with-benchmarking + ] keep record-benchmarking ; : tick ( loop -- ) - tick-delegate>> tick* ; + [ + [ tick-delegate>> tick* ] with-benchmarking + ] keep record-benchmarking ; : increment-tick ( loop -- ) - [ 1 + ] change-tick-number - dup tick-interval-nanos>> [ + ] curry change-last-tick + [ 1 + ] change-tick# drop ; -: ?tick ( loop count -- ) - [ nano-count >>last-tick drop ] [ - over [ since-last-tick ] [ tick-interval-nanos>> ] bi >= - [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ] - [ 2drop ] if - ] if-zero ; - -: benchmark-nanos ( loop -- nanos ) - nano-count swap benchmark-time>> - ; - PRIVATE> -: reset-loop-benchmark ( loop -- loop ) - nano-count >>benchmark-time - dup tick-number>> >>benchmark-tick-number - dup frame-number>> >>benchmark-frame-number ; +:: when-running ( loop quot -- ) + [ + loop + dup running?>> quot [ drop ] if + ] [ + loop game-loop-error + ] recover ; inline -: benchmark-ticks-per-second ( loop -- n ) - [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-nanos ] tri /f ; -: benchmark-frames-per-second ( loop -- n ) - [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-nanos ] tri /f ; +: tick-iteration ( loop -- ) + [ [ tick ] [ increment-tick ] bi ] when-running ; -: (game-tick) ( loop -- ) - dup running?>> - [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] bi ] - [ drop ] if ; - -: game-tick ( loop -- ) - dup game-loop [ - [ (game-tick) ] [ game-loop-error ] recover - ] with-variable ; +: frame-iteration ( loop -- ) + [ redraw ] when-running ; : start-loop ( loop -- ) - nano-count >>last-tick t >>running? - reset-loop-benchmark - [ - [ '[ _ game-tick ] f ] - [ tick-interval-nanos>> nanoseconds ] bi - - ] keep [ alarm<< ] [ drop start-alarm ] 2bi ; + + dup + [ '[ _ tick-iteration ] f ] + [ tick-interval-nanos>> nanoseconds ] bi >>tick-timer + + dup '[ _ frame-iteration ] f 1 milliseconds >>draw-timer + + [ tick-timer>> ] [ draw-timer>> ] bi [ start-timer ] bi@ ; : stop-loop ( loop -- ) f >>running? - alarm>> stop-alarm ; + [ tick-timer>> ] [ draw-timer>> ] bi [ stop-timer ] bi@ ; : ( tick-interval-nanos tick-delegate draw-delegate -- loop ) - nano-count f 0 0 nano-count 0 0 f + f 0 0 f f + game-loop-benchmark-vector{ } clone game-loop boa ; : ( tick-interval-nanos delegate -- loop ) @@ -112,6 +115,4 @@ PRIVATE> M: game-loop dispose stop-loop ; -USE: vocabs.loader - { "game.loop" "prettyprint" } "game.loop.prettyprint" require-when diff --git a/extra/game/worlds/worlds.factor b/extra/game/worlds/worlds.factor index f8b3ae8587..a04ac3f195 100644 --- a/extra/game/worlds/worlds.factor +++ b/extra/game/worlds/worlds.factor @@ -1,7 +1,8 @@ ! (c)2009 Joe Groff bsd license -USING: accessors combinators fry game.input game.loop generic kernel math -parser sequences ui ui.gadgets ui.gadgets.worlds ui.gestures threads -words audio.engine destructors ; +USING: accessors audio.engine combinators destructors fry +game.input game.loop generic kernel math parser sequences +threads ui ui.gadgets ui.gadgets.worlds ui.gestures words +words.constant ; IN: game.worlds TUPLE: game-world < world @@ -48,7 +49,7 @@ M: game-world begin-world [ >>game-loop begin-game-world ] keep start-loop ; M: game-world end-world - [ [ stop-loop ] when* f ] change-game-loop + dup game-loop>> [ stop-loop ] when* [ end-game-world ] [ audio-engine>> [ dispose ] when* ] [ use-game-input?>> [ close-game-input ] when ] tri ; @@ -70,8 +71,18 @@ M: game-world apply-world-attributes [ call-next-method ] } cleave ; +: start-game ( attributes -- game-world ) + f swap open-window* ; + +: wait-game ( attributes -- game-world ) + f swap open-window* dup promise>> ?promise drop ; + +: define-attributes-word ( word tuple -- ) + [ name>> "-attributes" append create-in ] dip define-constant ; + SYNTAX: GAME: CREATE game-attributes parse-main-window-attributes + 2dup define-attributes-word parse-definition define-main-window ; diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 950b34a8d7..02337276e6 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry irc.client irc.client.chats kernel namespaces sequences threads io.launcher io splitting -make mason.common mason.updates calendar math alarms +make mason.common mason.updates calendar math timers io.encodings.8-bit.latin1 debugger ; IN: irc.gitbot diff --git a/extra/key-logger/key-logger.factor b/extra/key-logger/key-logger.factor index 471c86cbfd..fd04d3a15d 100644 --- a/extra/key-logger/key-logger.factor +++ b/extra/key-logger/key-logger.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2010 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms bit-arrays calendar game.input io +USING: accessors timers bit-arrays calendar game.input io io.binary io.encodings.binary io.files kernel literals math namespaces system threads ; IN: key-logger @@ -28,7 +28,7 @@ SYMBOL: key-logger ] unless ; : stop-key-logger ( -- ) - key-logger get-global [ stop-alarm ] when* + key-logger get-global [ stop-timer ] when* f key-logger set-global close-game-input ; diff --git a/extra/mason/common/common-tests.factor b/extra/mason/common/common-tests.factor index 6d7f973296..b8e01d3993 100644 --- a/extra/mason/common/common-tests.factor +++ b/extra/mason/common/common-tests.factor @@ -1,6 +1,7 @@ IN: mason.common.tests USING: prettyprint mason.common mason.config -namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ; +namespaces calendar tools.test io.files +io.files.temp io.encodings.utf8 sequences ; [ "00:01:02" ] [ 62,000,000,000 nanos>time ] unit-test @@ -11,7 +12,7 @@ namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ; ] with-scope ] unit-test -[ "/home/bobby/builds/2008-09-11-12-23" ] [ +[ t ] [ [ "/home/bobby/builds" builds-dir set T{ timestamp @@ -23,6 +24,7 @@ namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ; } datestamp stamp set build-dir ] with-scope + "/home/bobby/builds/2008-09-11-12-23" head? ] unit-test [ ] [ "empty-test" temp-file utf8 [ ] with-file-writer ] unit-test diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index db68a558e0..5e37a683cf 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -57,6 +57,7 @@ M: unix really-delete-tree delete-tree ; [ day>> , ] [ hour>> , ] [ minute>> , ] + [ drop nano-count , ] } cleave ] { } make [ pad-00 ] map "-" join ; diff --git a/extra/mason/updates/updates.factor b/extra/mason/updates/updates.factor index 60a155eae7..57a8c748d2 100644 --- a/extra/mason/updates/updates.factor +++ b/extra/mason/updates/updates.factor @@ -1,9 +1,17 @@ ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io.launcher bootstrap.image.download -mason.common mason.platform ; +USING: bootstrap.image.download combinators.short-circuit +io.directories io.launcher kernel mason.common mason.platform ; IN: mason.updates +: git-reset-cmd ( -- cmd ) + { + "git" + "reset" + "--hard" + "HEAD" + } ; + : git-pull-cmd ( -- cmd ) { "git" @@ -14,6 +22,8 @@ IN: mason.updates } ; : updates-available? ( -- ? ) + ".git/index" delete-file + git-reset-cmd short-running-process git-id git-pull-cmd short-running-process git-id @@ -23,6 +33,4 @@ IN: mason.updates boot-image-name maybe-download-image ; : new-code-available? ( -- ? ) - updates-available? - new-image-available? - or ; \ No newline at end of file + { [ updates-available? ] [ new-image-available? ] } 0|| ; diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 5d97284551..f0e086343e 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar combinators +USING: accessors timers arrays calendar combinators combinators.smart continuations debugger http.client fry init io.streams.string kernel locals math math.parser db namespaces sequences site-watcher.db site-watcher.email ; @@ -48,4 +48,4 @@ PRIVATE> ] unless ; : stop-site-watcher ( -- ) - running-site-watcher get [ stop-alarm ] when* ; + running-site-watcher get [ stop-timer ] when* ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index e1051cf21b..5a65851037 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -229,9 +229,9 @@ M: terrain-world tick-game-world GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; : sky-gradient ( world -- t ) - game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ; + game-loop>> tick#>> SKY-PERIOD mod SKY-PERIOD /f ; : sky-theta ( world -- theta ) - game-loop>> tick-number>> SKY-SPEED * ; + game-loop>> tick#>> SKY-SPEED * ; M: terrain-world begin-game-world "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index 839d9690c2..25802a2411 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -1,10 +1,13 @@ ! Copyright (C) 2006, 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar kernel make math math.rectangles math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ; +USING: accessors timers arrays calendar kernel make math math.rectangles +math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets +ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures +ui.render ui ; FROM: tetris.game => level>> ; IN: tetris -TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ; +TUPLE: tetris-gadget < gadget { tetris tetris } { timer } ; : ( tetris -- gadget ) tetris-gadget new swap >>tetris ; @@ -52,10 +55,10 @@ tetris-gadget H{ [ tetris>> ?update ] [ relayout-1 ] bi ; M: tetris-gadget graft* ( gadget -- ) - [ [ tick ] curry 100 milliseconds every ] keep alarm<< ; + [ [ tick ] curry 100 milliseconds every ] keep timer<< ; M: tetris-gadget ungraft* ( gadget -- ) - [ stop-alarm f ] change-alarm drop ; + [ stop-timer f ] change-timer drop ; : tetris-window ( -- ) [ diff --git a/extra/time/authors.txt b/extra/time/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/time/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/time/macosx/authors.txt b/extra/time/macosx/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/time/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/time/macosx/macosx.factor b/extra/time/macosx/macosx.factor new file mode 100644 index 0000000000..c28b5c9b72 --- /dev/null +++ b/extra/time/macosx/macosx.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.data calendar calendar.unix classes.struct +io.files.info.unix.private kernel system time unix unix.time ; +IN: time.macosx + +M: macosx adjust-time-monotonic + timestamp>timeval + \ timeval + [ adjtime io-error ] keep dup binary-zero? [ + drop instant + ] [ + timeval>duration since-1970 now time- + ] if ; + diff --git a/extra/time/macosx/platforms.txt b/extra/time/macosx/platforms.txt new file mode 100644 index 0000000000..6e806f449e --- /dev/null +++ b/extra/time/macosx/platforms.txt @@ -0,0 +1 @@ +macosx diff --git a/extra/time/time.factor b/extra/time/time.factor new file mode 100644 index 0000000000..61a4d7415e --- /dev/null +++ b/extra/time/time.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel system vocabs.loader ; +IN: time + +HOOK: set-time os ( timestamp -- ) +HOOK: adjust-time-monotonic os ( timestamp -- seconds ) + +os { + { [ dup macosx? ] [ drop "time.macosx" require ] } + { [ dup windows? ] [ drop "time.windows" require ] } + { [ dup unix? ] [ drop "time.unix" require ] } + [ drop ] +} cond diff --git a/extra/time/unix/authors.txt b/extra/time/unix/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/time/unix/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/time/unix/platforms.txt b/extra/time/unix/platforms.txt new file mode 100644 index 0000000000..509143d863 --- /dev/null +++ b/extra/time/unix/platforms.txt @@ -0,0 +1 @@ +unix diff --git a/extra/time/unix/unix.factor b/extra/time/unix/unix.factor new file mode 100644 index 0000000000..ba1bc6e3fb --- /dev/null +++ b/extra/time/unix/unix.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar kernel math system time unix unix.time ; +IN: time.unix + +M: unix set-time + [ unix-1970 time- duration>microseconds >integer make-timeval ] + [ timestamp>timezone ] bi + settimeofday io-error ; diff --git a/extra/time/windows/authors.txt b/extra/time/windows/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/time/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/time/windows/platforms.txt b/extra/time/windows/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/extra/time/windows/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/extra/time/windows/windows.factor b/extra/time/windows/windows.factor new file mode 100644 index 0000000000..e5d7f918d9 --- /dev/null +++ b/extra/time/windows/windows.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar.windows system time windows.errors +windows.kernel32 kernel classes.struct calendar ; +IN: time.windows + +M: windows set-time + >gmt + timestamp>SYSTEMTIME SetSystemTime win32-error=0/f ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index a003c8b618..a2beb513ab 100644 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sorting math math.order -calendar alarms logging concurrency.combinators namespaces +calendar timers logging concurrency.combinators namespaces db.types db.tuples db fry locals hashtables syndication urls xml.writer validators html.forms diff --git a/vm/factor.cpp b/vm/factor.cpp index 9c56575009..6a6d7f55f9 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -123,7 +123,7 @@ void factor_vm::init_factor(vm_parameters *p) if(p->image_path == NULL) p->image_path = default_image_path(); - srand((unsigned int)system_micros()); + srand((unsigned int)nano_count()); init_ffi(); init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size); init_callbacks(p->callback_size); diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 034dfcbf5f..e95b84f51a 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -19,13 +19,6 @@ THREADHANDLE start_thread(void *(*start_routine)(void *),void *args) static void *null_dll; -u64 system_micros() -{ - struct timeval t; - gettimeofday(&t,NULL); - return (u64)t.tv_sec * 1000000 + t.tv_usec; -} - void sleep_nanos(u64 nsec) { timespec ts; diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 3673c4e121..54e9d068ef 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -42,7 +42,6 @@ inline static THREADHANDLE thread_id() { return pthread_self(); } void signal_handler(int signal, siginfo_t* siginfo, void* uap); void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); -u64 system_micros(); u64 nano_count(); void sleep_nanos(u64 nsec); void open_console(); diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp index a57db667c4..65e8ef5b09 100644 --- a/vm/os-windows-ce.cpp +++ b/vm/os-windows-ce.cpp @@ -3,16 +3,6 @@ namespace factor { -u64 system_micros() -{ - SYSTEMTIME st; - FILETIME ft; - GetSystemTime(&st); - SystemTimeToFileTime(&st, &ft); - return (((s64)ft.dwLowDateTime - | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10; -} - char *strerror(int err) { /* strerror() is not defined on WinCE */ diff --git a/vm/os-windows-ce.hpp b/vm/os-windows-ce.hpp index 02de1cd4a8..892fc88be9 100755 --- a/vm/os-windows-ce.hpp +++ b/vm/os-windows-ce.hpp @@ -21,7 +21,6 @@ char *getenv(char *name); #define snprintf _snprintf #define snwprintf _snwprintf -u64 system_micros(); void c_to_factor_toplevel(cell quot); void open_console(); diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 97cd2146af..7fdb882122 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -8,14 +8,6 @@ THREADHANDLE start_thread(void *(*start_routine)(void *), void *args) return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0); } -u64 system_micros() -{ - FILETIME t; - GetSystemTimeAsFileTime(&t); - return (((u64)t.dwLowDateTime | (u64)t.dwHighDateTime<<32) - - EPOCH_OFFSET) / 10; -} - u64 nano_count() { static double scale_factor; diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 020a506038..ad8a9907a7 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -45,7 +45,6 @@ typedef wchar_t vm_char; inline static void early_init() {} -u64 system_micros(); u64 nano_count(); void sleep_nanos(u64 nsec); long getpagesize(); diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 9cda1db9a8..5df73f5fac 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -125,7 +125,6 @@ namespace factor _(special_object) \ _(string) \ _(strip_stack_traces) \ - _(system_micros) \ _(tuple) \ _(tuple_boa) \ _(unimplemented) \ diff --git a/vm/run.cpp b/vm/run.cpp index 6c8a8452e7..605fd9b725 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -8,11 +8,6 @@ void factor_vm::primitive_exit() exit((int)to_fixnum(ctx->pop())); } -void factor_vm::primitive_system_micros() -{ - ctx->push(from_unsigned_8(system_micros())); -} - void factor_vm::primitive_nano_count() { u64 nanos = nano_count(); diff --git a/vm/vm.hpp b/vm/vm.hpp index 147647b528..40b3df5ecf 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -146,7 +146,6 @@ struct factor_vm // run void primitive_exit(); - void primitive_system_micros(); void primitive_nano_count(); void primitive_sleep(); void primitive_set_slot();